diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,8 +8,8 @@ ![Bloodhound (dog)](./bloodhound.jpg) -Elasticsearch client and query DSL for Haskell -============================================== +Elasticsearch and OpenSearch client and query DSL for Haskell +============================================================= Why? ---- @@ -26,13 +26,39 @@ Version compatibility --------------------- -See the [Github compatibility workflow](./.github/workflows/compat.yml) for a -listing of Elasticsearch and OpenSearch versions we test against. +Bloodhound supports and is continuously tested against the following +Elasticsearch and OpenSearch releases (see the +[compat workflow](./.github/workflows/compat.yml) and the +[CI runs](https://github.com/bitemyapp/bloodhound/actions/workflows/compat.yml)): -The workflow executions can be seen in the [Github actions -view](https://github.com/bitemyapp/bloodhound/actions/workflows/compat.yml). +| Backend | CI-tested version | +|---------------|-------------------| +| Elasticsearch | 7.17.25 | +| Elasticsearch | 8.19.16 | +| Elasticsearch | 9.4.2 | +| OpenSearch | 1.3.19 | +| OpenSearch | 2.19.5 | +| OpenSearch | 3.7.0 | +Backends +-------- +Each backend is exposed as its own type-safe module set, so only the +endpoints that actually exist on that version are available: + +* `Database.Bloodhound.ElasticSearch7.*` +* `Database.Bloodhound.ElasticSearch8.*` +* `Database.Bloodhound.ElasticSearch9.*` +* `Database.Bloodhound.OpenSearch1.*` +* `Database.Bloodhound.OpenSearch2.*` +* `Database.Bloodhound.OpenSearch3.*` + +A shared `Database.Bloodhound.Common.*` layer carries the cross-backend +surface, and `Database.Bloodhound.Dynamic.*` dispatches to the right +backend at runtime (detected from the server). Use +`StaticBH backend m a` for type-safe, backend-specific code. + + Stability --------- @@ -190,11 +216,6 @@ Beginning here: -Function Score Query --------------------- - - - Node discovery and failover --------------------------- @@ -215,45 +236,10 @@ -GeoShapeFilter --------------- - - - -Geohash cell filter -------------------- - - - -HasChild Filter ---------------- - - - -HasParent Filter ----------------- - - - -Indices Filter --------------- - - - -Query Filter ------------- - - - Script based sorting -------------------- - -Collapsing redundantly nested and/or structures ------------------------------------------------ - -The Seminearring instance, if deeply nested can possibly produce nested structure that is redundant. Depending on how this affects ES performance, reducing this structure might be valuable. Runtime checking for cycles in data structures ---------------------------------------------- diff --git a/bloodhound.cabal b/bloodhound.cabal --- a/bloodhound.cabal +++ b/bloodhound.cabal @@ -1,9 +1,9 @@ cabal-version: 3.4 name: bloodhound -version: 0.26.0.0 -synopsis: Elasticsearch client library for Haskell -description: Elasticsearch made awesome for Haskell hackers +version: 1.0.0.0 +synopsis: Elasticsearch and OpenSearch client library for Haskell +description: Elasticsearch and OpenSearch client and query DSL for Haskell. Provides per-backend, type-safe modules for Elasticsearch 7/8/9 and OpenSearch 1/2/3, a shared Common layer, and runtime dynamic backend dispatch. category: Database, Search homepage: https://github.com/bitemyapp/bloodhound.git#readme bug-reports: https://github.com/bitemyapp/bloodhound.git/issues @@ -16,7 +16,7 @@ extra-doc-files: README.md changelog.md -tested-with: GHC==8.10.7, GHC==9.0.2, GHC==9.2.8, GHC==9.4.8, GHC==9.6.6, GHC==9.8.4, GHC==9.10.1, GHC==9.12.1 +tested-with: GHC==9.8.4, GHC==9.10.3, GHC==9.12.4, GHC==9.14.1 source-repository head @@ -37,26 +37,60 @@ Database.Bloodhound.ElasticSearch7.Client Database.Bloodhound.ElasticSearch7.Requests Database.Bloodhound.ElasticSearch7.Types + Database.Bloodhound.ElasticSearch8.Client + Database.Bloodhound.ElasticSearch8.Requests + Database.Bloodhound.ElasticSearch8.Types + Database.Bloodhound.ElasticSearch9.Client + Database.Bloodhound.ElasticSearch9.Requests + Database.Bloodhound.ElasticSearch9.Types Database.Bloodhound.OpenSearch1.Client Database.Bloodhound.OpenSearch1.Requests Database.Bloodhound.OpenSearch1.Types Database.Bloodhound.OpenSearch2.Client Database.Bloodhound.OpenSearch2.Requests Database.Bloodhound.OpenSearch2.Types + Database.Bloodhound.OpenSearch3.Client + Database.Bloodhound.OpenSearch3.Requests + Database.Bloodhound.OpenSearch3.Types + Database.Bloodhound.Internal.Utils.SSE other-modules: Database.Bloodhound.Internal.Client.BHRequest Database.Bloodhound.Internal.Client.Doc Database.Bloodhound.Internal.Utils.Requests Database.Bloodhound.Internal.Utils.Imports + Database.Bloodhound.Internal.Utils.Secret Database.Bloodhound.Internal.Utils.StringlyTyped Database.Bloodhound.Internal.Versions.Common.Types.Aggregation Database.Bloodhound.Internal.Versions.Common.Types.Analysis + Database.Bloodhound.Internal.Versions.Common.Types.Analyze + Database.Bloodhound.Internal.Versions.Common.Types.AsyncSearch + Database.Bloodhound.Internal.Versions.Common.Types.Autoscaling Database.Bloodhound.Internal.Versions.Common.Types.Bulk + Database.Bloodhound.Internal.Versions.Common.Types.Cat + Database.Bloodhound.Internal.Versions.Common.Types.Cluster + Database.Bloodhound.Internal.Versions.Common.Types.ClusterSettings + Database.Bloodhound.Internal.Versions.Common.Types.ClusterState + Database.Bloodhound.Internal.Versions.Common.Types.ClusterStats Database.Bloodhound.Internal.Versions.Common.Types.Count + Database.Bloodhound.Internal.Versions.Common.Types.Dangling + Database.Bloodhound.Internal.Versions.Common.Types.DiskUsage + Database.Bloodhound.Internal.Versions.Common.Types.Document + Database.Bloodhound.Internal.Versions.Common.Types.Enrich + Database.Bloodhound.Internal.Versions.Common.Types.Explain + Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + Database.Bloodhound.Internal.Versions.Common.Types.FieldCaps + Database.Bloodhound.Internal.Versions.Common.Types.FieldUsageStats + Database.Bloodhound.Internal.Versions.Common.Types.Fleet Database.Bloodhound.Internal.Versions.Common.Types.Highlight + Database.Bloodhound.Internal.Versions.Common.Types.ILM Database.Bloodhound.Internal.Versions.Common.Types.Indices + Database.Bloodhound.Internal.Versions.Common.Types.Ingest + Database.Bloodhound.Internal.Versions.Common.Types.KeepAlive + Database.Bloodhound.Internal.Versions.Common.Types.Logstash + Database.Bloodhound.Internal.Versions.Common.Types.Migration Database.Bloodhound.Internal.Versions.Common.Types.Newtypes Database.Bloodhound.Internal.Versions.Common.Types.Nodes + Database.Bloodhound.Internal.Versions.Common.Types.PendingTask Database.Bloodhound.Internal.Versions.Common.Types.PointInTime Database.Bloodhound.Internal.Versions.Common.Types.Query Database.Bloodhound.Internal.Versions.Common.Types.Query.CommonTerms @@ -64,23 +98,151 @@ Database.Bloodhound.Internal.Versions.Common.Types.Query.Fuzzy Database.Bloodhound.Internal.Versions.Common.Types.Query.Match Database.Bloodhound.Internal.Versions.Common.Types.Query.MoreLikeThis - Database.Bloodhound.Internal.Versions.Common.Types.Query.MoreLikeThisField + Database.Bloodhound.Internal.Versions.Common.Types.Query.Neural + Database.Bloodhound.Internal.Versions.Common.Types.Query.NeuralSparse Database.Bloodhound.Internal.Versions.Common.Types.Query.Prefix Database.Bloodhound.Internal.Versions.Common.Types.Query.QueryString Database.Bloodhound.Internal.Versions.Common.Types.Query.Range Database.Bloodhound.Internal.Versions.Common.Types.Query.Regexp Database.Bloodhound.Internal.Versions.Common.Types.Query.SimpleQueryString - Database.Bloodhound.Internal.Versions.Common.Types.Query.Wildcard + Database.Bloodhound.Internal.Versions.Common.Types.Query.Wildcard + Database.Bloodhound.Internal.Versions.Common.Types.Knn + Database.Bloodhound.Internal.Versions.Common.Types.OpType + Database.Bloodhound.Internal.Versions.Common.Types.RankEval Database.Bloodhound.Internal.Versions.Common.Types.Reindex + Database.Bloodhound.Internal.Versions.Common.Types.Refresh + Database.Bloodhound.Internal.Versions.Common.Types.ReloadSearchAnalyzers + Database.Bloodhound.Internal.Versions.Common.Types.RemoteClusterInfo + Database.Bloodhound.Internal.Versions.Common.Types.RepositoriesMetering + Database.Bloodhound.Internal.Versions.Common.Types.Reroute + Database.Bloodhound.Internal.Versions.Common.Types.Retriever + Database.Bloodhound.Internal.Versions.Common.Types.Rollup Database.Bloodhound.Internal.Versions.Common.Types.Script + Database.Bloodhound.Internal.Versions.Common.Types.ScriptContexts + Database.Bloodhound.Internal.Versions.Common.Types.ScriptLanguages + Database.Bloodhound.Internal.Versions.Common.Types.Security + Database.Bloodhound.Internal.Versions.Common.Types.Security.ApiKeys + Database.Bloodhound.Internal.Versions.Common.Types.Security.Authentication + Database.Bloodhound.Internal.Versions.Common.Types.Security.Privileges + Database.Bloodhound.Internal.Versions.Common.Types.Security.RoleMappings + Database.Bloodhound.Internal.Versions.Common.Types.Security.Roles + Database.Bloodhound.Internal.Versions.Common.Types.Security.ServiceAccounts + Database.Bloodhound.Internal.Versions.Common.Types.Security.Sso + Database.Bloodhound.Internal.Versions.Common.Types.Security.Users + Database.Bloodhound.Internal.Versions.Common.Types.MultiGet + Database.Bloodhound.Internal.Versions.Common.Types.MultiSearch + Database.Bloodhound.Internal.Versions.Common.Types.MultiSearchTemplate Database.Bloodhound.Internal.Versions.Common.Types.Search + Database.Bloodhound.Internal.Versions.Common.Types.SearchableSnapshots + Database.Bloodhound.Internal.Versions.Common.Types.SearchShards + Database.Bloodhound.Internal.Versions.Common.Types.SLM Database.Bloodhound.Internal.Versions.Common.Types.Snapshots Database.Bloodhound.Internal.Versions.Common.Types.Sort Database.Bloodhound.Internal.Versions.Common.Types.Suggest Database.Bloodhound.Internal.Versions.Common.Types.Task + Database.Bloodhound.Internal.Versions.Common.Types.TermVectors + Database.Bloodhound.Internal.Versions.Common.Types.TextStructure + Database.Bloodhound.Internal.Versions.Common.Types.Transform Database.Bloodhound.Internal.Versions.Common.Types.Units + Database.Bloodhound.Internal.Versions.Common.Types.Validate + Database.Bloodhound.Internal.Versions.Common.Types.VectorTile + Database.Bloodhound.Internal.Versions.Common.Types.VersionType + Database.Bloodhound.Internal.Versions.Common.Types.VotingConfigExclusion + Database.Bloodhound.Internal.Versions.Common.Types.Watcher + Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.DataStream + Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.EventQueryLanguage Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.PointInTime + Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.SyncedFlush + Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.TermsEnum + Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.EsQueryLanguage + Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.EsQueryViews + Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Inference + Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.MigrationReindex + Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.QueryRules + Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.SearchApplications + Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Synonyms + Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.BehavioralAnalytics + Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Connectors + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.EsQueryLanguage + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.Features + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.HealthReport + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.PointInTime + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.Streams + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.IngestGeoIp + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.SimulateIngest + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.Downsample + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.ResolveCluster + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlDataFrameAnalytics + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlTrainedModels + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlAnomalyJobs + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlDatafeeds + Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlFiltersCalendars + Database.Bloodhound.Internal.Versions.OpenSearch1.Types + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.Alerting + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.CCR + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.AnomalyDetection + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.ISM + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.IndexTransforms + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.KnnModel + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.KnnStats + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.KnnTrain + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.MLModel + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.MLStats + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.MLTask + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.Rollups + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.SQLPPL + Database.Bloodhound.Internal.Versions.OpenSearch1.Types.SQLStats + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.Alerting + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.CCR + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.AnomalyDetection + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.ISM + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.IndexTransforms + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.KnnModel + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.KnnStats + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.KnnTrain + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLAgent + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLConnectors + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLControllers + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLModel + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLModelGroups + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLMemory + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLProfile + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLStats + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLTask + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.Notifications Database.Bloodhound.Internal.Versions.OpenSearch2.Types.PointInTime + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.Rollups + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.SecurityAnalytics + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.SnapshotManagement + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.SQLPPL + Database.Bloodhound.Internal.Versions.OpenSearch2.Types.SQLStats + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.Alerting + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.CCR + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.AnomalyDetection + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.FlowFramework + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.IndexTransforms + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.ISM + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.JobScheduler + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.KnnModel + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.KnnStats + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.KnnTrain + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLAgent + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLConnectors + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLControllers + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLModel + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLModelGroups + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLMemory + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLProfile + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLStats + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLTask + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.NeuralStats + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.Notifications + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.PointInTime + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.Rollups + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.SecurityAnalytics + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.SnapshotManagement + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.SQLPPL + Database.Bloodhound.Internal.Versions.OpenSearch3.Types.SQLStats Paths_bloodhound autogen-modules: Paths_bloodhound @@ -92,6 +254,7 @@ , base >=4.14 && <5 , blaze-builder >= 0.1 && <1 , bytestring >=0.10.0 && <1 + , conduit >=1.3 && <2 , containers >=0.5.0.0 && <1 , exceptions >=0.1 && <1 , hashable >=1 && <2 @@ -101,6 +264,7 @@ , mtl >=1.0 && <3 , network-uri >=2.6 && <3 , optics-core >=0.4 && <0.5 + , resourcet >=1.2 && <2 , scientific >=0.3.0.0 && <1 , template-haskell >=2.10 && <3 , text >=0.11 && <3 @@ -108,41 +272,168 @@ , unordered-containers >=0.1 && <1 , vector >=0.10.9 && <1 , versions >= 5.0.2 && <7 - default-language: Haskell2010 + default-language: GHC2021 default-extensions: DataKinds DeriveAnyClass - DeriveGeneric DerivingStrategies DerivingVia - GeneralizedNewtypeDeriving - KindSignatures - TypeApplications test-suite bloodhound-tests type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: Test.AggregationSpec + Test.AlertingSpec + Test.AnalyzeSpec + Test.AnomalyDetectionSpec + Test.AsyncSearchSpec + Test.AutoscalingSpec + Test.BehavioralAnalyticsSpec Test.BulkAPISpec + Test.CatSpec + Test.ConnectorsSpec + Test.CCRSpec Test.CountSpec + Test.DocumentOptionsSpec Test.DocumentsSpec + Test.DataStreamsSpec + Test.DiskUsageSpec + Test.DownsampleSpec + Test.EnrichSpec + Test.EsQueryLanguageSpec + Test.EsQueryViewsSpec + Test.EventQueryLanguageSpec + Test.ExplainSpec + Test.ExplainOptionsSpec + Test.FieldCapsSpec + Test.FieldUsageStatsSpec + Test.FeaturesSpec + Test.FleetSpec + Test.FreezeIndexSpec Test.HighlightsSpec + Test.HealthReportSpec + Test.HybridQuerySpec + Test.ILMSpec + Test.IndexDocumentParamsSpec + Test.IndexTransformsSpec Test.IndicesSpec + Test.IngestPipelineSpec + Test.IngestGeoIpSpec + Test.IndexSettingsOptionsSpec + Test.InferenceSpec + Test.ISMSpec Test.JSONSpec + Test.JobSchedulerSpec + Test.ClusterAllocationExplainSpec + Test.ClusterHealthSpec + Test.ClusterSettingsSpec + Test.ClusterStateSpec + Test.ClusterStatsSpec + Test.ClusterRemoteInfoSpec + Test.LogstashSpec + Test.MLStatsSpec + Test.MLModelSpec + Test.MLTrainSpec + Test.MLModelGroupsSpec + Test.MLConnectorsSpec + Test.MLMemorySpec + Test.MLControllersSpec + Test.MLProfileSpec + Test.MlDataFrameAnalyticsSpec + Test.MlTrainedModelsSpec + Test.MlAnomalySpec + Test.MigrationReindexSpec + Test.MigrationSpec + Test.MultiGetOptionsSpec + Test.MultiGetSpec + Test.MultiSearchSpec + Test.MultiSearchTemplateSpec + Test.NeuralQuerySpec + Test.NeuralSearchSpec + Test.NeuralSparseQuerySpec + Test.NeuralStatsSpec + Test.NeuralWarmupSpec + Test.NeuralClearCacheSpec Test.NodesSpec + Test.OSAsyncSearchSpec + Test.ParseEsResponseSpec Test.PointInTimeSpec + Test.PendingTasksSpec Test.QuerySpec + Test.QueryRulesSpec + Test.RankEvalSpec + Test.RenderTemplateSpec + Test.RerouteSpec + Test.ReloadSearchAnalyzersSpec + Test.RepositoriesMeteringSpec + Test.ResolveClusterSpec + Test.RollupSpec + Test.SearchApplicationsSpec + Test.SearchableSnapshotsSpec + Test.SecurityApiKeysSpec + Test.SecurityAuthenticateSpec + Test.SecurityPrivilegesSpec + Test.SecurityRoleMappingsSpec + Test.SecurityRolesSpec + Test.SecurityServiceAccountsSpec + Test.SecuritySsoSpec + Test.SecurityUsersSpec + Test.SimulateIngestSpec Test.ReindexSpec + Test.ReindexOptionsSpec + Test.ReindexResponseSpec + Test.ResizeSpec + Test.RolloverSpec + Test.RollupsSpec Test.ScanScrollSpec + Test.ScrollSpec Test.ScriptSpec + Test.ScriptContextsSpec + Test.ScriptLanguagesSpec Test.SearchAfterSpec + Test.SearchBodySpec + Test.SearchOptionsSpec + Test.SearchIntegrationSpec + Test.SearchShardsSpec Test.SnapshotsSpec + Test.SnapshotManagementSpec + Test.SLMSpec + Test.StreamsSpec Test.SortingSpec Test.SourceFilteringSpec Test.SuggestSpec + Test.SyncedFlushSpec + Test.SynonymsSpec + Test.TasksSpec Test.TemplatesSpec + Test.TermVectorsOptionsSpec + Test.TermVectorsSpec + Test.TextStructureSpec + Test.TermsEnumSpec + Test.TransformSpec + Test.FlowFrameworkSpec + Test.KnnClearCacheSpec + Test.KnnEs8Spec + Test.KnnEs9Spec + Test.KnnModelSpec + Test.KnnOs1Spec + Test.KnnOs2Spec + Test.KnnOs3Spec + Test.KnnStatsSpec + Test.KnnTrainSpec + Test.KnnWarmupSpec + Test.MLTaskSpec + Test.NotificationsSpec + Test.SQLPPLSpec + Test.SQLStatsSpec + Test.SecurityAnalyticsSpec + Test.SSESpec Test.TypesSpec + Test.ValidateSpec + Test.VectorTileSpec + Test.VotingConfigExclusionsSpec + Test.WatcherSpec TestsUtils.ApproxEq TestsUtils.Common TestsUtils.Generators @@ -156,7 +447,6 @@ build-depends: QuickCheck , aeson >=2.0 - , aeson-optics , base , bloodhound , bytestring >=0.10.0 @@ -173,31 +463,26 @@ , optics , pretty-simple , quickcheck-properties + , scientific >=0.3.0.0 && <1 , temporary , text >=0.11 , time >=1.4 , unix-compat + , unordered-containers >=0.1 && <1 , vector >=0.10.9 , versions >= 5.0.2 - default-language: Haskell2010 + default-language: GHC2021 default-extensions: DataKinds DefaultSignatures DeriveAnyClass - DeriveGeneric DerivingStrategies DerivingVia DuplicateRecordFields - GeneralizedNewtypeDeriving - KindSignatures LambdaCase OverloadedStrings - RankNTypes RecordWildCards - ScopedTypeVariables - TypeApplications TypeFamilies - TypeOperators test-suite doctests type: exitcode-stdio-1.0 @@ -207,7 +492,7 @@ Paths_bloodhound other-modules: Paths_bloodhound - default-language: Haskell2010 + default-language: GHC2021 ghc-options: -threaded build-depends: aeson diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,13 +1,25 @@ -0.26.0.0 -======== +1.0.0.0 +======= - @blackheaven - - breaking: change `DateHistogramAggregation.dateInterval` from `Interval` to `Maybe Interval` - - breaking: change `mkDateHistogram` signature from `FieldName -> Interval -> DateHistogramAggregation` to `FieldName -> DateHistogramAggregation` - - breaking: replace `TermsAggregation.term` from `Either Text Text` to `TermsAggregationTarget` - - breaking: change `mkTermsAggregation` signature from `Text -> TermsAggregation` to `FieldName -> TermsAggregation` - - feat: add `IntervalFixed` constructor to `Interval` sum type - - feat: add `bhResponseHook` to `BHEnv` for post-response debugging/processing - - feat: add `TermsAggregationTarget` sum type with `TermsAggregationTargetField` and `TermsAggregationTargetScript` constructors + + **Breaking (relative to 0.25.0.0)** + - `createSnapshot` return type changes from `Acknowledged` to `CreateSnapshotResponse`, a sum type (`CreateSnapshotAcknowledged` | `CreateSnapshotCompleted` wrapping `SnapshotInfo`). Required so `snapWaitForCompletion=True` decodes the full snapshot object the server returns instead of failing on the `{"acknowledged": _}` shape. + + **Multi-backend type-safe architecture** + - Per-backend modules exposing only version-correct surfaces: `Database.Bloodhound.{ElasticSearch7,ElasticSearch8,ElasticSearch9,OpenSearch1,OpenSearch2,OpenSearch3}.{Client,Requests,Types}`, a shared `Database.Bloodhound.Common.*` layer, and `Database.Bloodhound.Dynamic.*` for runtime-detected dispatch. + - `StaticBH backend m a` for type-safe, backend-specific code. + + **New API surfaces** + - OpenSearch plugins: ISM, Alerting, Anomaly Detection, Index Transforms, Index Rollups, Snapshot Management, Job Scheduler, Flow Framework, ML Commons, k-NN, Notifications, Security Analytics, Neural Search, SQL/PPL, CCR. + - Elasticsearch: data-stream lifecycle, downsample, inference endpoints, search applications, ES|QL (`/_query`), behavioral analytics, connectors, query rules, synonyms, resolve cluster, health report, features, streams, simulate ingest, ingest geoip, ML. + - Shared: snapshot selection and repo options, point-in-time multi-target via `IndexPattern`, enrich, repositories metering. + + **Infrastructure and robustness** + - GHC 9.8.4 / 9.10.3 / 9.12.4 / 9.14.1 support. + - CI readiness gate switched to an HTTP `_cluster/health` poll (replaces the flaky `docker logs | grep GREEN`); disk-watermark relaxation for constrained runners. + - `EsError` gains a null-tolerant `FromJSON` (surfaces OS 1.3 `/_script_language` 500s instead of opaque parse failures). + - All compiler warnings eliminated across `src/` (build + Haddock clean); ormolu applied across touched files; test suite ~5800+ examples. + 0.25.0.0 ======== diff --git a/src/Database/Bloodhound/Client/Cluster.hs b/src/Database/Bloodhound/Client/Cluster.hs --- a/src/Database/Bloodhound/Client/Cluster.hs +++ b/src/Database/Bloodhound/Client/Cluster.hs @@ -20,19 +20,21 @@ SBackendType (..), emptyBody, mkBHEnv, + mkHttpRequest, performBHRequest, runBH, tryPerformBHRequest, unsafePerformBH, withDynamicBH, + withStreamingResponse, ) where import Control.Monad.Catch import Control.Monad.Except -import qualified Data.ByteString.Lazy.Char8 as L +import Data.ByteString.Lazy.Char8 qualified as L import Data.Kind -import qualified Data.Text as T +import Data.Text qualified as T import Database.Bloodhound.Internal.Client.BHRequest import Database.Bloodhound.Internal.Utils.Imports import Database.Bloodhound.Internal.Versions.Common.Types.Bulk as ReexportCompat @@ -41,8 +43,8 @@ import Database.Bloodhound.Internal.Versions.Common.Types.Nodes as ReexportCompat import Database.Bloodhound.Internal.Versions.Common.Types.Snapshots as ReexportCompat import Database.Bloodhound.Internal.Versions.Common.Types.Units as ReexportCompat -import qualified Network.HTTP.Client as HTTP -import qualified Network.URI as URI +import Network.HTTP.Client qualified as HTTP +import Network.URI qualified as URI -- | Common environment for Elasticsearch calls. Connections will be -- pipelined according to the provided HTTP connection manager. @@ -69,10 +71,14 @@ -- | Backend (i.e. implementation) the queries are ran against data BackendType = ElasticSearch7 + | ElasticSearch8 + | ElasticSearch9 | OpenSearch1 | OpenSearch2 + | OpenSearch3 | -- | unknown, can be anything Dynamic + deriving stock (Eq, Show) -- | Best-effort, by-passed for 'Dynamic', statically enforced implementation type family WithBackendType (expected :: BackendType) (actual :: BackendType) :: Constraint where @@ -124,22 +130,7 @@ dispatch request = BH $ do env <- ask @BHEnv liftIO $ do - initReq <- parseUrl' $ getEndpoint (bhServer env) (bhRequestEndpoint request) - let setQueryStrings = - case bhRequestQueryStrings request of - [] -> id - xs -> HTTP.setQueryString xs - req <- - bhRequestHook env $ - HTTP.setRequestIgnoreStatus $ - setQueryStrings $ - initReq - { HTTP.method = bhRequestMethod request, - HTTP.requestHeaders = - ("Content-Type", "application/json") : HTTP.requestHeaders initReq, - HTTP.requestBody = HTTP.RequestBodyLBS $ fromMaybe emptyBody $ bhRequestBody request - } - + req <- mkHttpRequest env request let mgr = bhManager env rawResp <- HTTP.httpLbs req mgr BHResponse <$> bhResponseHook env rawResp @@ -161,9 +152,89 @@ emptyBody :: L.ByteString emptyBody = L.pack "" +-- | Build an @http-client@ 'HTTP.Request' from a 'BHEnv' and a +-- 'BHRequest'. This is the single source of truth for request +-- construction: the buffering 'dispatch' path and the streaming +-- 'withStreamingResponse' path both route through here, so any change +-- to header \/ body \/ query wiring applies uniformly. +-- +-- The function preserves both query mechanisms a 'BHRequest' carries: +-- 'bhRequestEndpoint'\'s own 'getRawEndpointQueries' (rendered into the +-- URL string by 'getEndpoint') and the separate 'bhRequestQueryStrings' +-- (applied via 'HTTP.setQueryString' after parsing). The body defaults +-- to 'emptyBody' when 'Nothing' (matching the historical wire shape). +-- Status-code exceptions are suppressed +-- ('HTTP.setRequestIgnoreStatus') because Bloodhound does its own +-- status-based parsing in 'parseEsResponse'. +mkHttpRequest :: BHEnv -> BHRequest contextualized body -> IO HTTP.Request +mkHttpRequest env request = do + initReq <- parseUrl' endpointText + let setQueryStrings = + case bhRequestQueryStrings request of + [] -> id + xs -> HTTP.setQueryString xs + bhRequestHook env $ + HTTP.setRequestIgnoreStatus $ + setQueryStrings $ + initReq + { HTTP.method = bhRequestMethod request, + HTTP.requestHeaders = + ("Content-Type", "application/json") : HTTP.requestHeaders initReq, + HTTP.requestBody = HTTP.RequestBodyLBS $ fromMaybe emptyBody $ bhRequestBody request + } + where + endpointText = getEndpoint (bhServer env) (bhRequestEndpoint request) + parseUrl' :: (MonadThrow m) => Text -> m HTTP.Request parseUrl' t = HTTP.parseRequest (URI.escapeURIString URI.isAllowedInURI (T.unpack t)) +-- | Execute a 'BHRequest' against the cluster and hand the caller the +-- streaming response body via a bracketed continuation, instead of +-- buffering the entire body into memory as 'dispatch'\/'performBHRequest' +-- do. This is the low-level primitive on which streaming endpoints +-- (e.g. the ML Commons Execute Stream Agent API, which emits +-- Server-Sent Events) are layered. +-- +-- The continuation receives the @http-client@ 'HTTP.Response' whose +-- 'HTTP.responseBody' is a 'HTTP.BodyReader' (an @IO 'BS.ByteString'@ +-- that yields the next chunk on each call, blocking until data is +-- available, and returning an empty 'BS.ByteString' at end-of-stream). +-- The bracket ensures the connection is released when the continuation +-- exits, even on exception. Use 'HTTP.brRead' to pull chunks manually, +-- or feed the 'HTTP.BodyReader' into a streaming parser (e.g. the SSE +-- parser in "Database.Bloodhound.Internal.Utils.SSE"). +-- +-- The continuation runs in 'IO' (not the underlying monad @m@): the +-- caller is responsible for any monad-lifting it needs inside the +-- continuation. Higher-level streaming sources built on this primitive +-- (e.g. a @conduit@ 'ConduitT') handle that lifting themselves. +-- +-- /Behavioural differences from 'dispatch':/ +-- +-- * The 'bhResponseHook' is __not__ invoked. The hook's type +-- ('bhResponseHook' :: 'HTTP.Response' 'L.ByteString' -> @…@) +-- requires the body to be fully materialized, which defeats the +-- purpose of streaming. Debug logging that relied on the response +-- hook will not see streaming responses. +-- * 'HTTP.setRequestIgnoreStatus' is still applied (so non-2xx is not +-- raised as an 'HttpException' by @http-client@); the caller is +-- responsible for inspecting 'HTTP.responseStatus' inside the +-- continuation if it cares about the status. +-- * The 'bhRequestHook' __is__ applied (it operates on the request, +-- not the response), so custom authentication strategies continue to +-- work for streaming requests. +withStreamingResponse :: + (MonadIO m) => + BHRequest contextualized body -> + (HTTP.Response HTTP.BodyReader -> IO a) -> + BH m a +withStreamingResponse request inner = + BH $ do + env <- ask @BHEnv + liftIO $ do + req <- mkHttpRequest env request + HTTP.withResponse req (bhManager env) inner + runBH :: BHEnv -> BH m a -> m (Either EsError a) runBH e f = runExceptT $ runReaderT (unBH f) e @@ -205,8 +276,11 @@ -- | Dependently-typed version of 'BackendType' data SBackendType :: BackendType -> Type where SElasticSearch7 :: SBackendType 'ElasticSearch7 + SElasticSearch8 :: SBackendType 'ElasticSearch8 + SElasticSearch9 :: SBackendType 'ElasticSearch9 SOpenSearch1 :: SBackendType 'OpenSearch1 SOpenSearch2 :: SBackendType 'OpenSearch2 + SOpenSearch3 :: SBackendType 'OpenSearch3 -- | Run an action given an actual backend withDynamicBH :: @@ -217,6 +291,9 @@ withDynamicBH backend f = case backend of ElasticSearch7 -> unsafePerformBH $ f SElasticSearch7 + ElasticSearch8 -> unsafePerformBH $ f SElasticSearch8 + ElasticSearch9 -> unsafePerformBH $ f SElasticSearch9 OpenSearch1 -> unsafePerformBH $ f SOpenSearch1 OpenSearch2 -> unsafePerformBH $ f SOpenSearch2 + OpenSearch3 -> unsafePerformBH $ f SOpenSearch3 Dynamic -> throwEsError $ EsError Nothing "Cannot perform on a 'Dynamic' backend" diff --git a/src/Database/Bloodhound/Common/Client.hs b/src/Database/Bloodhound/Common/Client.hs --- a/src/Database/Bloodhound/Common/Client.hs +++ b/src/Database/Bloodhound/Common/Client.hs @@ -24,674 +24,5501 @@ -- ** Indices createIndex, - createIndexWith, - flushIndex, - deleteIndex, - updateIndexSettings, - getIndexSettings, - forceMergeIndex, - indexExists, - openIndex, - closeIndex, - listIndices, - catIndices, - waitForYellowIndex, - Requests.HealthStatus (..), - - -- *** Index Aliases - updateIndexAliases, - getIndexAliases, - deleteIndexAlias, - - -- *** Index Templates - putTemplate, - templateExists, - deleteTemplate, - - -- ** Mapping - putMapping, - - -- ** Documents - indexDocument, - updateDocument, - updateByQuery, - getDocument, - documentExists, - deleteDocument, - deleteByQuery, - Requests.IndexedDocument (..), - Requests.DeletedDocuments (..), - Requests.DeletedDocumentsRetries (..), - - -- ** Searching - searchAll, - searchByIndex, - searchByIndices, - searchByIndexTemplate, - searchByIndicesTemplate, - scanSearch, - getInitialScroll, - getInitialSortedScroll, - advanceScroll, - refreshIndex, - Requests.mkSearch, - Requests.mkAggregateSearch, - Requests.mkHighlightSearch, - Requests.mkSearchTemplate, - bulk, - Requests.pageSearch, - Requests.mkShardCount, - Requests.mkReplicaCount, - getStatus, - - -- ** Templates - storeSearchTemplate, - getSearchTemplate, - deleteSearchTemplate, - - -- ** Snapshot/Restore - - -- *** Snapshot Repos - getSnapshotRepos, - updateSnapshotRepo, - verifySnapshotRepo, - deleteSnapshotRepo, - - -- *** Snapshots - createSnapshot, - getSnapshots, - deleteSnapshot, - - -- *** Restoring Snapshots - restoreSnapshot, - - -- *** Reindex - reindex, - reindexAsync, - - -- *** Task - getTask, - - -- ** Nodes - getNodesInfo, - getNodesStats, - - -- ** Request Utilities - Requests.encodeBulkOperations, - Requests.encodeBulkOperation, - - -- * Authentication - basicAuthHook, - - -- * Count - countByIndex, - - -- * Generic - Acknowledged (..), - Accepted (..), - IgnoredBody (..), - ) -where - -import Control.Monad -import Control.Monad.Catch -import Data.Aeson -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Text.Encoding as T -import Data.Time.Clock -import qualified Data.Vector as V -import Database.Bloodhound.Client.Cluster -import qualified Database.Bloodhound.Common.Requests as Requests -import Database.Bloodhound.Common.Types -import Network.HTTP.Client hiding (Proxy) -import Prelude hiding (filter, head) - --- $setup --- >>> :set -XOverloadedStrings --- >>> :set -XDeriveGeneric --- >>> import Database.Bloodhound --- >>> import Network.HTTP.Client --- >>> let testServer = (Server "http://localhost:9200") --- >>> let runBH' = withBH defaultManagerSettings testServer --- >>> let testIndex = IndexName "twitter" --- >>> let defaultIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 0) --- >>> data TweetMapping = TweetMapping deriving stock (Eq, Show) --- >>> _ <- runBH' $ deleteIndex testIndex --- >>> _ <- runBH' $ deleteIndex (IndexName "didimakeanindex") --- >>> import GHC.Generics --- >>> import Data.Time.Calendar (Day (..)) --- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime) --- >>> :{ --- instance ToJSON TweetMapping where --- toJSON TweetMapping = --- object ["properties" .= --- object ["location" .= --- object ["type" .= ("geo_point" :: Text)]]] --- data Location = Location { lat :: Double --- , lon :: Double } deriving stock (Eq, Generic, Show) --- data Tweet = Tweet { user :: Text --- , postDate :: UTCTime --- , message :: Text --- , age :: Int --- , location :: Location } deriving stock (Eq, Generic, Show) --- exampleTweet = Tweet { user = "bitemyapp" --- , postDate = UTCTime --- (ModifiedJulianDay 55000) --- (secondsToDiffTime 10) --- , message = "Use haskell!" --- , age = 10000 --- , location = Location 40.12 (-71.34) } --- instance ToJSON Tweet where --- toJSON = genericToJSON defaultOptions --- instance FromJSON Tweet where --- parseJSON = genericParseJSON defaultOptions --- instance ToJSON Location where --- toJSON = genericToJSON defaultOptions --- instance FromJSON Location where --- parseJSON = genericParseJSON defaultOptions --- data BulkTest = BulkTest { name :: Text } deriving stock (Eq, Generic, Show) --- instance FromJSON BulkTest where --- parseJSON = genericParseJSON defaultOptions --- instance ToJSON BulkTest where --- toJSON = genericToJSON defaultOptions --- :} - --- | Convenience function that sets up a manager and BHEnv and runs --- the given set of bloodhound operations. Connections will be --- pipelined automatically in accordance with the given manager --- settings in IO. If you've got your own monad transformer stack, you --- should use 'runBH' directly. -withBH :: ManagerSettings -> Server -> BH IO a -> IO a -withBH ms s f = do - mgr <- newManager ms - let env = mkBHEnv s mgr - runBH env f >>= either throwM return - --- | 'getStatus' fetches the 'Status' of a 'Server' --- --- >>> serverStatus <- runBH' getStatus --- >>> fmap tagline (serverStatus) --- Just "You Know, for Search" -getStatus :: (MonadBH m) => m Status -getStatus = performBHRequest $ Requests.getStatus - --- | 'getSnapshotRepos' gets the definitions of a subset of the --- defined snapshot repos. -getSnapshotRepos :: (MonadBH m) => SnapshotRepoSelection -> m [GenericSnapshotRepo] -getSnapshotRepos sel = performBHRequest $ Requests.getSnapshotRepos sel - --- | Create or update a snapshot repo -updateSnapshotRepo :: - (MonadBH m) => - (SnapshotRepo repo) => - -- | Use 'defaultSnapshotRepoUpdateSettings' if unsure - SnapshotRepoUpdateSettings -> - repo -> - m Acknowledged -updateSnapshotRepo settings repo = performBHRequest $ Requests.updateSnapshotRepo settings repo - --- | Verify if a snapshot repo is working. __NOTE:__ this API did not --- make it into Elasticsearch until 1.4. If you use an older version, --- you will get an error here. -verifySnapshotRepo :: (MonadBH m) => SnapshotRepoName -> m SnapshotVerification -verifySnapshotRepo repoName = performBHRequest $ Requests.verifySnapshotRepo repoName - -deleteSnapshotRepo :: (MonadBH m) => SnapshotRepoName -> m Acknowledged -deleteSnapshotRepo repoName = performBHRequest $ Requests.deleteSnapshotRepo repoName - --- | Create and start a snapshot -createSnapshot :: - (MonadBH m) => - SnapshotRepoName -> - SnapshotName -> - SnapshotCreateSettings -> - m Acknowledged -createSnapshot repoName snapName settings = performBHRequest $ Requests.createSnapshot repoName snapName settings - --- | Get info about known snapshots given a pattern and repo name. -getSnapshots :: (MonadBH m) => SnapshotRepoName -> SnapshotSelection -> m [SnapshotInfo] -getSnapshots repoName sel = performBHRequest $ Requests.getSnapshots repoName sel - --- | Delete a snapshot. Cancels if it is running. -deleteSnapshot :: (MonadBH m) => SnapshotRepoName -> SnapshotName -> m Acknowledged -deleteSnapshot repoName snapName = performBHRequest $ Requests.deleteSnapshot repoName snapName - --- | Restore a snapshot to the cluster See --- --- for more details. -restoreSnapshot :: - (MonadBH m) => - SnapshotRepoName -> - SnapshotName -> - -- | Start with 'defaultSnapshotRestoreSettings' and customize - -- from there for reasonable defaults. - SnapshotRestoreSettings -> - m Accepted -restoreSnapshot repoName snapName settings = performBHRequest $ Requests.restoreSnapshot repoName snapName settings - -getNodesInfo :: (MonadBH m) => NodeSelection -> m NodesInfo -getNodesInfo sel = performBHRequest $ Requests.getNodesInfo sel - -getNodesStats :: (MonadBH m) => NodeSelection -> m NodesStats -getNodesStats sel = performBHRequest $ Requests.getNodesStats sel - --- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'. --- --- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex") --- >>> isSuccess response --- True --- >>> runBH' $ indexExists (IndexName "didimakeanindex") --- True -createIndex :: (MonadBH m) => IndexSettings -> IndexName -> m Acknowledged -createIndex indexSettings indexName = performBHRequest $ Requests.createIndex indexSettings indexName - --- | Create an index, providing it with any number of settings. This --- is more expressive than 'createIndex' but makes is more verbose --- for the common case of configuring only the shard count and --- replica count. -createIndexWith :: - (MonadBH m) => - [UpdatableIndexSetting] -> - -- | shard count - Int -> - IndexName -> - m Acknowledged -createIndexWith updates shards indexName = performBHRequest $ Requests.createIndexWith updates shards indexName - --- | 'flushIndex' will flush an index given a 'Server' and an 'IndexName'. -flushIndex :: (MonadBH m) => IndexName -> m ShardResult -flushIndex indexName = performBHRequest $ Requests.flushIndex indexName - --- | 'deleteIndex' will delete an index given a 'Server' and an 'IndexName'. --- --- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex") --- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex") --- >>> isSuccess response --- True --- >>> runBH' $ indexExists (IndexName "didimakeanindex") --- False -deleteIndex :: (MonadBH m) => IndexName -> m Acknowledged -deleteIndex indexName = performBHRequest $ Requests.deleteIndex indexName - --- | 'updateIndexSettings' will apply a non-empty list of setting updates to an index --- --- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "unconfiguredindex") --- >>> response <- runBH' $ updateIndexSettings (BlocksWrite False :| []) (IndexName "unconfiguredindex") --- >>> isSuccess response --- True -updateIndexSettings :: - (MonadBH m) => - NonEmpty UpdatableIndexSetting -> - IndexName -> - m Acknowledged -updateIndexSettings updates indexName = performBHRequest $ Requests.updateIndexSettings updates indexName - -getIndexSettings :: (MonadBH m) => IndexName -> m IndexSettingsSummary -getIndexSettings indexName = performBHRequest $ Requests.getIndexSettings indexName - --- | 'forceMergeIndex' --- --- The force merge API allows to force merging of one or more indices through --- an API. The merge relates to the number of segments a Lucene index holds --- within each shard. The force merge operation allows to reduce the number of --- segments by merging them. --- --- This call will block until the merge is complete. If the http connection is --- lost, the request will continue in the background, and any new requests will --- block until the previous force merge is complete. - --- For more information see --- . --- Nothing --- worthwhile comes back in the response body, so matching on the status --- should suffice. --- --- 'forceMergeIndex' with a maxNumSegments of 1 and onlyExpungeDeletes --- to True is the main way to release disk space back to the OS being --- held by deleted documents. --- --- >>> let ixn = IndexName "unoptimizedindex" --- >>> _ <- runBH' $ deleteIndex ixn >> createIndex defaultIndexSettings ixn --- >>> response <- runBH' $ forceMergeIndex (IndexList (ixn :| [])) (defaultIndexOptimizationSettings { maxNumSegments = Just 1, onlyExpungeDeletes = True }) --- >>> isSuccess response --- True -forceMergeIndex :: (MonadBH m) => IndexSelection -> ForceMergeIndexSettings -> m ShardsResult -forceMergeIndex ixs settings = performBHRequest $ Requests.forceMergeIndex ixs settings - --- | 'indexExists' enables you to check if an index exists. Returns 'Bool' --- in IO --- --- >>> exists <- runBH' $ indexExists testIndex -indexExists :: (MonadBH m) => IndexName -> m Bool -indexExists indexName = performBHRequest $ Requests.indexExists indexName - --- | 'refreshIndex' will force a refresh on an index. You must --- do this if you want to read what you wrote. --- --- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex --- >>> _ <- runBH' $ refreshIndex testIndex -refreshIndex :: (MonadBH m) => IndexName -> m ShardResult -refreshIndex indexName = performBHRequest $ Requests.refreshIndex indexName - --- | Block until the index becomes available for indexing --- documents. This is useful for integration tests in which --- indices are rapidly created and deleted. -waitForYellowIndex :: (MonadBH m) => IndexName -> m Requests.HealthStatus -waitForYellowIndex indexName = performBHRequest $ Requests.waitForYellowIndex indexName - --- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at --- --- --- >>> response <- runBH' $ openIndex testIndex -openIndex :: (MonadBH m) => IndexName -> m Acknowledged -openIndex indexName = performBHRequest $ Requests.openIndex indexName - --- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at --- --- --- >>> response <- runBH' $ closeIndex testIndex -closeIndex :: (MonadBH m) => IndexName -> m Acknowledged -closeIndex indexName = performBHRequest $ Requests.closeIndex indexName - --- | 'listIndices' returns a list of all index names on a given 'Server' -listIndices :: (MonadBH m) => m [IndexName] -listIndices = performBHRequest $ Requests.listIndices - --- | 'catIndices' returns a list of all index names on a given 'Server' as well as their doc counts -catIndices :: (MonadBH m) => m [(IndexName, Int)] -catIndices = performBHRequest $ Requests.catIndices - --- | 'updateIndexAliases' updates the server's index alias --- table. Operations are atomic. Explained in further detail at --- --- --- >>> let src = IndexName "a-real-index" --- >>> let aliasName = IndexName "an-alias" --- >>> let iAlias = IndexAlias src (IndexAliasName aliasName) --- >>> let aliasCreate = IndexAliasCreate Nothing Nothing --- >>> _ <- runBH' $ deleteIndex src --- >>> isSuccess <$> runBH' (createIndex defaultIndexSettings src) --- True --- >>> runBH' $ indexExists src --- True --- >>> isSuccess <$> runBH' (updateIndexAliases (AddAlias iAlias aliasCreate :| [])) --- True --- >>> runBH' $ indexExists aliasName --- True -updateIndexAliases :: (MonadBH m) => NonEmpty IndexAliasAction -> m Acknowledged -updateIndexAliases actions = performBHRequest $ Requests.updateIndexAliases actions - --- | Get all aliases configured on the server. -getIndexAliases :: (MonadBH m) => m IndexAliasesSummary -getIndexAliases = performBHRequest $ Requests.getIndexAliases - --- | Delete a single alias, removing it from all indices it --- is currently associated with. -deleteIndexAlias :: (MonadBH m) => IndexAliasName -> m Acknowledged -deleteIndexAlias indexAliasName = performBHRequest $ Requests.deleteIndexAlias indexAliasName - --- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'. --- Explained in further detail at --- --- --- >>> let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping] --- >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl") -putTemplate :: (MonadBH m) => IndexTemplate -> TemplateName -> m Acknowledged -putTemplate indexTemplate templateName = performBHRequest $ Requests.putTemplate indexTemplate templateName - --- | 'templateExists' checks to see if a template exists. --- --- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl") -templateExists :: (MonadBH m) => TemplateName -> m Bool -templateExists templateName = performBHRequest $ Requests.templateExists templateName - --- | 'deleteTemplate' is an HTTP DELETE and deletes a template. --- --- >>> let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping] --- >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl") --- >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl") -deleteTemplate :: (MonadBH m) => TemplateName -> m Acknowledged -deleteTemplate templateName = performBHRequest $ Requests.deleteTemplate templateName - --- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas --- for documents in indexes. --- --- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex --- >>> resp <- runBH' $ putMapping testIndex TweetMapping --- >>> print resp --- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("content-type","application/json; charset=UTF-8"),("content-encoding","gzip"),("transfer-encoding","chunked")], responseBody = "{\"acknowledged\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} -putMapping :: forall r a m. (MonadBH m, FromJSON r, ToJSON a) => IndexName -> a -> m r -putMapping indexName mapping = performBHRequest $ Requests.putMapping indexName mapping - --- | 'indexDocument' is the primary way to save a single document in --- Elasticsearch. The document itself is simply something we can --- convert into a JSON 'Value'. The 'DocId' will function as the --- primary key for the document. You are encouraged to generate --- your own id's and not rely on Elasticsearch's automatic id --- generation. Read more about it here: --- https://github.com/bitemyapp/bloodhound/issues/107 --- --- >>> resp <- runBH' $ indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1") --- >>> print resp --- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("content-type","application/json; charset=UTF-8"),("content-encoding","gzip"),("content-length","152")], responseBody = "{\"_index\":\"twitter\",\"_type\":\"_doc\",\"_id\":\"1\",\"_version\":2,\"result\":\"updated\",\"_shards\":{\"total\":1,\"successful\":1,\"failed\":0},\"_seq_no\":1,\"_primary_term\":1}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} -indexDocument :: - forall doc m. - (MonadBH m, ToJSON doc) => - IndexName -> - IndexDocumentSettings -> - doc -> - DocId -> - m Requests.IndexedDocument -indexDocument indexName cfg document docId = performBHRequest $ Requests.indexDocument indexName cfg document docId - --- | 'updateDocument' provides a way to perform an partial update of a --- an already indexed document. -updateDocument :: - forall patch m. - (MonadBH m, ToJSON patch) => - IndexName -> - IndexDocumentSettings -> - patch -> - DocId -> - m Requests.IndexedDocument -updateDocument indexName cfg patch docId = performBHRequest $ Requests.updateDocument indexName cfg patch docId - -updateByQuery :: (MonadBH m, FromJSON a) => IndexName -> Query -> Maybe Script -> m a -updateByQuery indexName q mScript = performBHRequest $ Requests.updateByQuery indexName q mScript - --- | 'deleteDocument' is the primary way to delete a single document. --- --- >>> _ <- runBH' $ deleteDocument testIndex (DocId "1") -deleteDocument :: (MonadBH m) => IndexName -> DocId -> m Requests.IndexedDocument -deleteDocument indexName docId = performBHRequest $ Requests.deleteDocument indexName docId - --- | 'deleteByQuery' performs a deletion on every document that matches a query. --- --- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing --- >>> _ <- runBH' $ deleteDocument testIndex query -deleteByQuery :: (MonadBH m) => IndexName -> Query -> m Requests.DeletedDocuments -deleteByQuery indexName query = performBHRequest $ Requests.deleteByQuery indexName query - --- | 'bulk' uses --- --- to perform bulk operations. The 'BulkOperation' data type encodes the --- index\/update\/delete\/create operations. You pass a 'V.Vector' of 'BulkOperation's --- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch --- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead. --- --- >>> let stream = V.fromList [BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah"))] --- >>> _ <- runBH' $ bulk stream --- >>> _ <- runBH' $ refreshIndex testIndex -bulk :: - forall m. - (MonadBH m) => - V.Vector BulkOperation -> - m BulkResponse -bulk ops = performBHRequest $ Requests.bulk @StatusDependant ops - --- | 'getDocument' is a straight-forward way to fetch a single document from --- Elasticsearch using a 'Server', 'IndexName', and a 'DocId'. --- The 'DocId' is the primary key for your Elasticsearch document. --- --- >>> yourDoc <- runBH' $ getDocument testIndex (DocId "1") -getDocument :: (MonadBH m, FromJSON a) => IndexName -> DocId -> m (EsResult a) -getDocument indexName docId = performBHRequest $ Requests.getDocument indexName docId - --- | 'documentExists' enables you to check if a document exists. -documentExists :: (MonadBH m) => IndexName -> DocId -> m Bool -documentExists indexName docId = performBHRequest $ Requests.documentExists indexName docId - --- | 'searchAll', given a 'Search', will perform that search against all indexes --- on an Elasticsearch server. Try to avoid doing this if it can be helped. --- --- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing --- >>> let search = mkSearch (Just query) Nothing --- >>> response <- runBH' $ searchAll search -searchAll :: forall a m. (MonadBH m, FromJSON a) => Search -> m (SearchResult a) -searchAll search = performBHRequest $ Requests.searchAll search - --- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search --- within an index on an Elasticsearch server. --- --- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing --- >>> let search = mkSearch (Just query) Nothing --- >>> response <- runBH' $ searchByIndex testIndex search -searchByIndex :: forall a m. (MonadBH m, FromJSON a) => IndexName -> Search -> m (SearchResult a) -searchByIndex indexName search = performBHRequest $ Requests.searchByIndex indexName search - --- | 'searchByIndices' is a variant of 'searchByIndex' that executes a --- 'Search' over many indices. This is much faster than using --- 'mapM' to 'searchByIndex' over a collection since it only --- causes a single HTTP request to be emitted. -searchByIndices :: forall a m. (MonadBH m, FromJSON a) => NonEmpty IndexName -> Search -> m (SearchResult a) -searchByIndices ixs search = performBHRequest $ Requests.searchByIndices ixs search - --- | 'searchByIndexTemplate', given a 'SearchTemplate' and an 'IndexName', will perform that search --- within an index on an Elasticsearch server. --- --- >>> let query = SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } }, \"size\" : \"{{my_size}}\"}" --- >>> let search = mkSearchTemplate (Right query) Nothing --- >>> response <- runBH' $ searchByIndexTemplate testIndex search -searchByIndexTemplate :: - forall a m. - (MonadBH m, FromJSON a) => - IndexName -> - SearchTemplate -> - m (SearchResult a) -searchByIndexTemplate indexName search = performBHRequest $ Requests.searchByIndexTemplate indexName search - --- | 'searchByIndicesTemplate' is a variant of 'searchByIndexTemplate' that executes a --- 'SearchTemplate' over many indices. This is much faster than using --- 'mapM' to 'searchByIndexTemplate' over a collection since it only --- causes a single HTTP request to be emitted. -searchByIndicesTemplate :: - forall a m. - (MonadBH m, FromJSON a) => - NonEmpty IndexName -> - SearchTemplate -> - m (SearchResult a) -searchByIndicesTemplate ixs search = performBHRequest $ Requests.searchByIndicesTemplate ixs search - --- | 'storeSearchTemplate', saves a 'SearchTemplateSource' to be used later. -storeSearchTemplate :: (MonadBH m) => SearchTemplateId -> SearchTemplateSource -> m Acknowledged -storeSearchTemplate tid ts = performBHRequest $ Requests.storeSearchTemplate tid ts - --- | 'getSearchTemplate', get info of an stored 'SearchTemplateSource'. -getSearchTemplate :: (MonadBH m) => SearchTemplateId -> m GetTemplateScript -getSearchTemplate tid = performBHRequest $ Requests.getSearchTemplate tid - --- | 'storeSearchTemplate', -deleteSearchTemplate :: (MonadBH m) => SearchTemplateId -> m Acknowledged -deleteSearchTemplate tid = performBHRequest $ Requests.deleteSearchTemplate tid - --- | For a given search, request a scroll for efficient streaming of --- search results. Note that the search is put into 'SearchTypeScan' --- mode and thus results will not be sorted. Combine this with --- 'advanceScroll' to efficiently stream through the full result set -getInitialScroll :: - forall a m. - (MonadBH m, FromJSON a) => - IndexName -> - Search -> - m (ParsedEsResponse (SearchResult a)) -getInitialScroll indexName search' = performBHRequest $ Requests.getInitialScroll indexName search' - --- | For a given search, request a scroll for efficient streaming of --- search results. Combine this with 'advanceScroll' to efficiently --- stream through the full result set. Note that this search respects --- sorting and may be less efficient than 'getInitialScroll'. -getInitialSortedScroll :: - forall a m. - (MonadBH m, FromJSON a) => - IndexName -> - Search -> - m (SearchResult a) -getInitialSortedScroll indexName search = performBHRequest $ Requests.getInitialSortedScroll indexName search - --- | Use the given scroll to fetch the next page of documents. If there are no --- further pages, 'SearchResult.searchHits.hits' will be '[]'. -advanceScroll :: - forall a m. - (MonadBH m, FromJSON a) => - ScrollId -> - -- | How long should the snapshot of data be kept around? This timeout is updated every time 'advanceScroll' is used, so don't feel the need to set it to the entire duration of your search processing. Note that durations < 1s will be rounded up. Also note that 'NominalDiffTime' is an instance of Num so literals like 60 will be interpreted as seconds. 60s is a reasonable default. - NominalDiffTime -> - m (SearchResult a) -advanceScroll sid scroll = performBHRequest $ Requests.advanceScroll sid scroll - --- | 'scanSearch' uses the 'scroll' API of elastic, --- for a given 'IndexName'. Note that this will --- consume the entire search result set and will be doing O(n) list --- appends so this may not be suitable for large result sets. In that --- case, 'getInitialScroll' and 'advanceScroll' are good low level --- tools. You should be able to hook them up trivially to conduit, --- pipes, or your favorite streaming IO abstraction of choice. Note --- that ordering on the search would destroy performance and thus is --- ignored. -scanSearch :: forall a m. (FromJSON a, MonadBH m) => IndexName -> Search -> m [Hit a] -scanSearch indexName search = do - initialSearchResult <- getInitialScroll indexName search - let (hits', josh) = case initialSearchResult of - Right SearchResult {..} -> (hits searchHits, scrollId) - Left _ -> ([], Nothing) - (totalHits, _) <- scanAccumulator [] (hits', josh) - return totalHits - where - scanAccumulator :: [Hit a] -> ([Hit a], Maybe ScrollId) -> m ([Hit a], Maybe ScrollId) - scanAccumulator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing) - scanAccumulator oldHits ([], _) = return (oldHits, Nothing) - scanAccumulator oldHits (newHits, msid) = do - (newHits', msid') <- scroll' msid - scanAccumulator (oldHits ++ newHits) (newHits', msid') - - scroll' :: Maybe ScrollId -> m ([Hit a], Maybe ScrollId) - scroll' Nothing = return ([], Nothing) - scroll' (Just sid) = do - res <- tryPerformBHRequest $ Requests.advanceScroll sid 60 - case res of - Right SearchResult {..} -> return (hits searchHits, scrollId) - Left _ -> return ([], Nothing) - --- | This is a hook that can be set via the 'bhRequestHook' function --- that will authenticate all requests using an HTTP Basic --- Authentication header. Note that it is *strongly* recommended that --- this option only be used over an SSL connection. --- --- >> (mkBHEnv myServer myManager) { bhRequestHook = basicAuthHook (EsUsername "myuser") (EsPassword "mypass") } -basicAuthHook :: (Monad m) => EsUsername -> EsPassword -> Request -> m Request -basicAuthHook (EsUsername u) (EsPassword p) = return . applyBasicAuth u' p' - where - u' = T.encodeUtf8 u - p' = T.encodeUtf8 p - -countByIndex :: (MonadBH m) => IndexName -> CountQuery -> m CountResponse -countByIndex indexName q = performBHRequest $ Requests.countByIndex indexName q - -reindex :: (MonadBH m) => ReindexRequest -> m ReindexResponse -reindex = performBHRequest . Requests.reindex - -reindexAsync :: (MonadBH m) => ReindexRequest -> m TaskNodeId -reindexAsync = performBHRequest . Requests.reindexAsync - -getTask :: (MonadBH m, FromJSON a) => TaskNodeId -> m (TaskResponse a) -getTask = performBHRequest . Requests.getTask + createIndexOptions, + CreateIndexOptions (..), + ActiveShardCount (..), + defaultCreateIndexOptions, + createIndexWith, + flushIndex, + flushIndexWith, + FlushIndexOptions (..), + defaultFlushIndexOptions, + clearIndexCache, + reloadSearchAnalyzers, + reloadSearchAnalyzersWith, + ReloadSearchAnalyzersResponse (..), + ReloadDetail (..), + ReloadSearchAnalyzersOptions (..), + defaultReloadSearchAnalyzersOptions, + reloadSearchAnalyzersOptionsParams, + diskUsage, + diskUsageWith, + DiskUsageResponse (..), + DiskUsageIndex (..), + DiskUsageFieldBreakdown (..), + DiskUsageInvertedIndex (..), + DiskUsageOptions (..), + defaultDiskUsageOptions, + diskUsageOptionsParams, + fieldUsageStats, + fieldUsageStatsWith, + FieldUsageStatsResponse (..), + FieldUsageStatsIndex (..), + FieldUsageShard (..), + FieldUsageRouting (..), + FieldUsageStats (..), + FieldUsageBreakdown (..), + FieldUsageInvertedIndex (..), + FieldUsageStatsOptions (..), + defaultFieldUsageStatsOptions, + fieldUsageStatsOptionsParams, + getScriptContexts, + ScriptContextsResponse (..), + ScriptContextInfo (..), + ScriptContextMethod (..), + ScriptContextParam (..), + getScriptLanguages, + ScriptLanguagesResponse (..), + ScriptLanguageContext (..), + deleteIndex, + updateIndexSettings, + updateIndexSettingsWith, + UpdateIndexSettingsOptions (..), + defaultUpdateIndexSettingsOptions, + getIndexSettings, + getIndexSettingsWith, + GetIndexSettingsOptions (..), + defaultGetIndexSettingsOptions, + getIndex, + getIndexStats, + getIndexRecovery, + getIndexSegments, + getShardStores, + getShardStoresWith, + ShardStoresOptions (..), + defaultShardStoresOptions, + IndexInfo (..), + IndexStats (..), + IndexStatEntry (..), + IndexStatAggregate (..), + IndexStatMetrics (..), + IndexStatDocs (..), + IndexStatStore (..), + IndexRecovery (..), + IndexSegments (..), + ShardStores (..), + ShardStoresShard (..), + ShardStore (..), + ShardStoreNode (..), + ShardStoreAllocation (..), + ShardStoreException (..), + ShardRecovery (..), + ShardRecoveryIndex (..), + ShardRecoveryFiles (..), + forceMergeIndex, + indexExists, + openIndex, + openIndexWith, + closeIndex, + closeIndexWith, + OpenCloseIndexOptions (..), + defaultOpenCloseIndexOptions, + listIndices, + catIndices, + catIndicesWith, + catAliases, + catAliasesWith, + catAllocation, + catAllocationWith, + catCount, + catCountWith, + catMaster, + catMasterWith, + catHealth, + catHealthWith, + catPendingTasks, + catPendingTasksWith, + catPlugins, + catPluginsWith, + catTemplates, + catTemplatesWith, + catThreadPool, + catThreadPoolWith, + catFielddata, + catFielddataWith, + catNodeattrs, + catNodeattrsWith, + catRepositories, + catRepositoriesWith, + catShards, + catShardsWith, + catTasks, + catTasksWith, + catSnapshots, + catSnapshotsWith, + catNodes, + catNodesWith, + catSegments, + catSegmentsWith, + catRecovery, + catRecoveryWith, + catComponentTemplates, + catComponentTemplatesWith, + catCircuitBreakers, + catCircuitBreakersWith, + catMlJobs, + catMlJobsWith, + catMlDataFrameAnalytics, + catMlDataFrameAnalyticsWith, + catMlDatafeeds, + catMlDatafeedsWith, + catMlTrainedModels, + catMlTrainedModelsWith, + catTransforms, + catTransformsWith, + catHelp, + addIndexBlock, + removeIndexBlock, + IndexBlock (..), + indexBlockText, + waitForYellowIndex, + rolloverIndex, + RolloverConditions (..), + RolloverResponse (..), + defaultRolloverConditions, + shrinkIndex, + ShrinkSettings (..), + defaultShrinkSettings, + splitIndex, + SplitSettings (..), + defaultSplitSettings, + cloneIndex, + CloneSettings (..), + defaultCloneSettings, + Requests.HealthStatus (..), + resolveIndex, + resolveIndexWith, + ResolveIndexOptions (..), + defaultResolveIndexOptions, + ResolvedIndices (..), + ResolvedIndex (..), + ResolvedAlias (..), + ResolvedDataStream (..), + + -- *** Dangling indices + listDanglingIndices, + importDanglingIndex, + importDanglingIndexWith, + deleteDanglingIndex, + deleteDanglingIndexWith, + DanglingIndexUuid (..), + unDanglingIndexUuid, + DanglingIndex (..), + DanglingIndicesResponse (..), + ImportDanglingIndexOptions (..), + defaultImportDanglingIndexOptions, + DeleteDanglingIndexOptions (..), + defaultDeleteDanglingIndexOptions, + + -- *** Index Aliases + updateIndexAliases, + updateIndexAliasesWith, + UpdateAliasesOptions (..), + defaultUpdateAliasesOptions, + updateAliasesOptionsParams, + createIndexAlias, + getIndexAliases, + getIndexAlias, + deleteIndexAlias, + deleteIndexAliasFrom, + aliasExists, + defaultIndexAliasCreate, + + -- *** Index Templates + putTemplate, + templateExists, + getTemplate, + deleteTemplate, + ComponentTemplate (..), + ComposableTemplate (..), + ComposableTemplateContent (..), + ComposableTemplateOptions (..), + defaultComposableTemplateOptions, + composableTemplateOptionsParams, + putIndexTemplate, + putIndexTemplateWith, + getIndexTemplate, + deleteIndexTemplate, + putComponentTemplate, + deleteComponentTemplate, + IndexTemplateInfo (..), + GetIndexTemplatesResponse (..), + TemplateInfo (..), + GetTemplatesResponse (..), + getComponentTemplate, + ComponentTemplateInfo (..), + GetComponentTemplatesResponse (..), + TemplateNamePattern (..), + SimulatedTemplate (..), + SimulatedTemplateOverlap (..), + simulateIndexTemplate, + simulateIndexTemplateWith, + simulateIndex, + simulateIndexWith, + + -- ** Mapping + putMapping, + putMappingWith, + getMapping, + getFieldMapping, + FieldMappingResponse (..), + FieldMappingIndexEntry (..), + FieldMappingDetail (..), + + -- ** Documents + indexDocument, + updateDocument, + updateDocumentWith, + UpdateBody (..), + mkUpdateDoc, + mkUpdateScript, + updateByQuery, + updateByQueryWith, + rethrottleUpdateByQuery, + getDocument, + getDocumentWith, + getDocumentSource, + getDocumentSourceWith, + getDocuments, + getDocumentsWith, + getDocumentsMulti, + getDocumentsMultiWith, + TermVectors (..), + FieldTermVectors (..), + FieldStatistics (..), + TermVectorStats (..), + TermVectorToken (..), + TermVectorsRequest (..), + TermVectorsFilter (..), + defaultTermVectorsRequest, + defaultTermVectorsFilter, + TermVectorsOptions (..), + defaultTermVectorsOptions, + termVectorsOptionsParams, + getTermVectors, + getTermVectorsWith, + MultiTermVectorsDoc (..), + mkMultiTermVectorsDoc, + MultiTermVectors (..), + MultiTermVectorsResponse (..), + getMultiTermVectors, + getMultiTermVectorsWith, + getMultiTermVectorsByIndex, + getMultiTermVectorsByIndexWith, + GetDocumentOptions (..), + defaultGetDocumentOptions, + GetDocumentSourceOptions (..), + defaultGetDocumentSourceOptions, + MultiGetOptions (..), + defaultMultiGetOptions, + DeleteDocumentOptions (..), + defaultDeleteDocumentOptions, + DocumentExistsOptions (..), + defaultDocumentExistsOptions, + DocumentSourceExistsOptions (..), + defaultDocumentSourceExistsOptions, + ByQueryOptions (..), + ConflictsPolicy (..), + Slices (..), + defaultByQueryOptions, + documentExists, + documentExistsWith, + documentSourceExists, + documentSourceExistsWith, + deleteDocument, + deleteDocumentWith, + deleteByQuery, + deleteByQueryWith, + rethrottleDeleteByQuery, + Requests.IndexedDocument (..), + Requests.DeletedDocuments (..), + Requests.DeletedDocumentsRetries (..), + + -- ** Searching + searchAll, + searchAllWith, + multiSearch, + multiSearchWith, + multiSearchByIndex, + multiSearchByIndexWith, + Requests.MultiSearchTemplateItem (..), + multiSearchTemplate, + multiSearchTemplateWith, + multiSearchTemplateByIndex, + multiSearchTemplateByIndexWith, + searchByIndex, + searchByIndexWith, + searchByIndices, + searchByIndicesWith, + explainDocument, + explainDocumentWith, + ExplainOptions (..), + defaultExplainOptions, + explainOptionsParams, + searchByIndexTemplate, + searchByIndicesTemplate, + scanSearch, + getInitialScroll, + getInitialSortedScroll, + advanceScroll, + advanceScrollWith, + AdvanceScrollOptions (..), + defaultAdvanceScrollOptions, + advanceScrollOptionsParams, + clearScroll, + refreshIndex, + refreshIndexWith, + RefreshIndexOptions (..), + defaultRefreshIndexOptions, + Requests.mkSearch, + SearchOptions (..), + defaultSearchOptions, + Requests.mkAggregateSearch, + Requests.mkHighlightSearch, + Requests.mkSearchTemplate, + bulk, + bulkWith, + Requests.pageSearch, + Requests.mkShardCount, + Requests.mkReplicaCount, + getStatus, + + -- ** Templates + storeSearchTemplate, + getSearchTemplate, + deleteSearchTemplate, + renderTemplate, + + -- ** Snapshot/Restore + + -- *** Snapshot Repos + getSnapshotRepos, + getSnapshotReposWith, + updateSnapshotRepo, + verifySnapshotRepo, + verifySnapshotRepoWith, + cleanupSnapshotRepo, + cleanupSnapshotRepoWith, + deleteSnapshotRepo, + deleteSnapshotRepoWith, + SnapshotMasterTimeoutOptions (..), + defaultSnapshotMasterTimeoutOptions, + SnapshotRepoGetOptions (..), + defaultSnapshotRepoGetOptions, + SnapshotRepoTimeoutOptions (..), + defaultSnapshotRepoTimeoutOptions, + + -- *** Snapshots + createSnapshot, + cloneSnapshot, + getSnapshots, + getSnapshotsWith, + SnapshotSelectionOptions (..), + SnapshotSortField (..), + SnapshotSortOrder (..), + defaultSnapshotSelectionOptions, + getSnapshotStatus, + getSnapshotStatusWith, + SnapshotStatusOptions (..), + defaultSnapshotStatusOptions, + deleteSnapshot, + deleteSnapshotWith, + + -- *** Restoring Snapshots + restoreSnapshot, + + -- *** Reindex + reindex, + reindexWith, + reindexAsync, + reindexAsyncWith, + rethrottleReindex, + ReindexOptions (..), + defaultReindexOptions, + reindexOptionsParams, + + -- *** Task + getTask, + getTaskWith, + cancelTask, + listTasks, + TaskInfo (..), + TaskListNode (..), + TaskListResponse (..), + taskListFlat, + TaskListOptions (..), + TaskListGroupBy (..), + defaultTaskListOptions, + TaskGetOptions (..), + defaultTaskGetOptions, + + -- ** Async Search + getAsyncSearch, + getAsyncSearchStatus, + + -- ** Nodes + getNodesInfo, + getNodesInfoWith, + getNodesStats, + getNodesStatsWith, + getNodesUsage, + getNodesUsageWith, + getNodesHotThreads, + getNodesHotThreadsWith, + reloadSecureSettings, + NodeInfoMetric (..), + renderNodeInfoMetric, + NodeStatsMetric (..), + renderNodeStatsMetric, + NodeStatsLevel (..), + renderNodeStatsLevel, + NodeUsageMetric (..), + renderNodeUsageMetric, + + -- ** Cluster + getClusterHealth, + getClusterHealthWith, + getClusterHealthForIndex, + getClusterHealthForIndexWith, + ClusterHealthOptions (..), + ClusterHealthLevel (..), + ClusterHealthStatus (..), + defaultClusterHealthOptions, + getClusterSettings, + getClusterSettingsWith, + ClusterSettings (..), + ClusterSettingsOptions (..), + defaultClusterSettingsOptions, + updateClusterSettings, + updateClusterSettingsWith, + ClusterSettingsUpdate (..), + defaultClusterSettingsUpdate, + ClusterSettingsUpdateOptions (..), + defaultClusterSettingsUpdateOptions, + getClusterState, + getClusterStateWith, + ClusterStateOptions (..), + ClusterStateMetric (..), + renderClusterStateMetric, + defaultClusterStateOptions, + getClusterStats, + getPendingTasks, + PendingTask (..), + PendingTaskPriority (..), + explainAllocation, + AllocationExplainRequest (..), + AllocationExplanation (..), + defaultAllocationExplainRequest, + mkAllocationExplainRequest, + getRemoteClusterInfo, + RemoteClustersInfo (..), + RemoteClusterInfo (..), + RemoteClusterMode (..), + updateVotingConfigExclusions, + clearVotingConfigExclusions, + VotingConfigExclusionOptions (..), + defaultVotingConfigExclusionOptions, + votingConfigExclusionOptionsParams, + rerouteCluster, + rerouteClusterWith, + RerouteCommand (..), + RerouteOptions (..), + defaultRerouteOptions, + rerouteOptionsParams, + RerouteResponse (..), + + -- ** Index Lifecycle Management (ILM) + getILMPolicy, + putILMPolicy, + deleteILMPolicy, + explainILM, + explainILMWith, + startILM, + stopILM, + getILMStatus, + moveILMStep, + retryILMStep, + removeILM, + migrateDataTiers, + migrateDataTiersWith, + ILMPolicyId (..), + ILMPolicy (..), + ILMPolicyInfo (..), + ILMInUseBy (..), + ILMExplanation (..), + ILMExplanations (..), + ILMExplainOptions (..), + defaultILMExplainOptions, + ILMStepKey (..), + MoveStepRequest (..), + ILMOperationMode (..), + ILMStatus (..), + MigrateDataTiersRequest (..), + defaultMigrateDataTiersRequest, + MigrateDataTiersOptions (..), + defaultMigrateDataTiersOptions, + MigrateDataTiersResponse (..), + + -- ** Snapshot Lifecycle Management (SLM) + putSLMPolicy, + getSLMPolicy, + deleteSLMPolicy, + executeSLMPolicy, + getSLMStatus, + stopSLM, + startSLM, + + -- ** Enrich + putEnrichPolicy, + getEnrichPolicy, + deleteEnrichPolicy, + executeEnrichPolicy, + executeEnrichPolicyWith, + getEnrichExecuteStats, + getEnrichPolicyExecuteStats, + EnrichPolicyId (..), + EnrichPolicyType (..), + EnrichPolicyConfig (..), + EnrichPolicy (..), + EnrichPolicyInfo (..), + EnrichPoliciesResponse (..), + EnrichPolicyPhase (..), + EnrichExecuteStatsEntry (..), + EnrichExecuteStatsResponse (..), + EnrichExecuteOptions (..), + defaultEnrichExecuteOptions, + + -- ** Autoscaling + putAutoscalingPolicy, + getAutoscalingPolicy, + deleteAutoscalingPolicy, + getAutoscalingCapacity, + AutoscalingPolicyName (..), + AutoscalingPolicy (..), + defaultAutoscalingPolicy, + AutoscalingCapacity (..), + AutoscalingCapacityPolicy (..), + CapacitySize (..), + AutoscalingResource (..), + AutoscalingCurrentNode (..), + AutoscalingDeciderResult (..), + + -- ** Security — shared privilege vocabulary + ClusterPrivilege (..), + IndexPrivilegeName (..), + ApplicationName (..), + ApplicationPrivilegeName (..), + ResourceName (..), + FieldSecurity (..), + defaultFieldSecurity, + IndexPrivilege (..), + defaultIndexPrivilege, + ApplicationPrivilege (..), + defaultApplicationPrivilege, + + -- ** Security — roles (/_security/role/*) + putRole, + getRole, + getRoles, + deleteRole, + clearRoleCache, + RoleName (..), + Role (..), + defaultRole, + RoleCreatedResponse (..), + RoleDeletedResponse (..), + RolesListResponse (..), + ClearRoleCacheResponse (..), + + -- ** Security — role mappings (/_security/role_mapping/*) + putRoleMapping, + getRoleMapping, + getRoleMappings, + deleteRoleMapping, + RoleMappingName (..), + RoleMapping (..), + defaultRoleMapping, + RoleMappingRule (..), + RoleMappingsListResponse (..), + + -- ** Security — users (/_security/user/*) + putUser, + getUser, + getUsers, + deleteUser, + enableUser, + disableUser, + changeUserPassword, + userHasPrivileges, + selfHasPrivileges, + getUserPrivileges, + UserName (..), + User (..), + UserCreateBody (..), + defaultUserCreateBody, + UserCreatedResponse (..), + UserDeletedResponse (..), + UsersListResponse (..), + ChangePasswordBody (..), + HasPrivilegesRequest (..), + defaultHasPrivilegesRequest, + HasPrivilegesResponse (..), + HasPrivilegesIndexResult (..), + HasPrivilegesApplicationResult (..), + UserPrivileges (..), + UserIndexPrivileges (..), + UserApplicationPrivileges (..), + + -- ** Security — API keys (/_security/api_key) + createApiKey, + grantApiKey, + getApiKey, + invalidateApiKey, + updateApiKey, + queryApiKey, + queryApiKeyWith, + + -- ** Security — authentication (/_security/_authenticate, _whoami, _logout) + authenticate, + whoami, + logout, + ApiKeyId (..), + ApiKeyName (..), + CreateApiKeyRequest (..), + defaultCreateApiKeyRequest, + ApiKeyCreatedResponse (..), + GrantApiKeyRequest (..), + GrantType (..), + ApiKeySpec (..), + defaultApiKeySpec, + RetrieveApiKeyRequest (..), + defaultRetrieveApiKeyRequest, + ApiKeyInfo (..), + apiKeyInfoExtrasLens, + ApiKeyRetrievalResponse (..), + InvalidateApiKeyRequest (..), + defaultInvalidateApiKeyRequest, + InvalidateApiKeyResponse (..), + InvalidateApiKeyError (..), + UpdateApiKeyRequest (..), + QueryApiKeyRequest (..), + defaultQueryApiKeyRequest, + QueryApiKeyResponse (..), + Requests.QueryApiKeyOptions (..), + Requests.defaultQueryApiKeyOptions, + AuthenticateResponse (..), + SecurityRealm (..), + WhoAmIResponse (..), + whoAmIResponseExtrasLens, + LogoutRequest (..), + defaultLogoutRequest, + LogoutResponse (..), + + -- ** Security — service accounts (/_security/service/*) + getServiceAccounts, + getServiceAccountsInNamespace, + getServiceAccount, + createServiceToken, + getServiceCredentials, + deleteServiceToken, + ServiceAccountNamespace (..), + ServiceAccountService (..), + ServiceTokenName (..), + ServiceAccount (..), + defaultServiceAccount, + ServiceAccountsListResponse (..), + ServiceTokenSecret (..), + CreateServiceTokenResponse (..), + GetServiceCredentialsResponse (..), + ServiceTokenDeletedResponse (..), + + -- ** Security — SSO / token (/_security/oauth2, /_security/oidc, /_security/saml) + getToken, + invalidateToken, + prepareSamlAuthentication, + authenticateSaml, + logoutSaml, + prepareOidcAuthentication, + authenticateOidc, + logoutOidc, + SsoToken (..), + SsoRefreshToken (..), + OAuth2GrantType (..), + oAuth2GrantTypeText, + GetTokenRequest (..), + defaultGetTokenRequest, + GetTokenResponse (..), + TokenAuthentication (..), + SsoRealmInfo (..), + tokenAuthenticationExtrasLens, + InvalidateTokenRequest (..), + defaultInvalidateTokenRequest, + InvalidateTokenResponse (..), + InvalidateTokenError (..), + SsoTokenResponse (..), + SsoRedirectResponse (..), + SamlPrepareRequest (..), + defaultSamlPrepareRequest, + SamlPrepareResponse (..), + SamlAuthenticateRequest (..), + SamlLogoutRequest (..), + OidcPrepareRequest (..), + defaultOidcPrepareRequest, + OidcPrepareResponse (..), + OidcAuthenticateRequest (..), + OidcLogoutRequest (..), + + -- ** Security — application privileges (/_security/privilege/*) + putPrivilege, + getPrivileges, + getPrivilegesInApplication, + getPrivilege, + deletePrivilege, + clearPrivilegeCache, + ActionName (..), + ApplicationPrivilegeDefinition (..), + defaultApplicationPrivilegeDefinition, + ApplicationPrivilegeInfo (..), + PrivilegesListResponse (..), + PrivilegeCreatedResponse (..), + PrivilegeDeletedResponse (..), + ClearPrivilegeCacheResponse (..), + + -- ** Fleet + getFleetGlobalCheckpoints, + getFleetGlobalCheckpointsWith, + fleetSearch, + fleetSearchWith, + fleetMultiSearch, + fleetMultiSearchWith, + GlobalCheckpoint (..), + FleetGlobalCheckpointsResponse (..), + FleetGlobalCheckpointsOptions (..), + defaultFleetGlobalCheckpointsOptions, + FleetSearchOptions (..), + defaultFleetSearchOptions, + SLMPolicyId (..), + SLMPolicy (..), + SLMPolicyInfo (..), + SLMExecutionResult (..), + SLMOperationMode (..), + SLMStatus (..), + + -- ** Repositories Metering + getRepositoriesMetering, + deleteRepositoriesMetering, + RepositoriesMeteringResponse (..), + NodeRepositoriesMetering (..), + RepositoryMeteringInfo (..), + RepositoriesMeteringNodesSummary (..), + + -- ** Rollup + putRollupJob, + getRollupJob, + deleteRollupJob, + startRollupJob, + stopRollupJob, + stopRollupJobWith, + getRollupJobStats, + getRollupCapabilities, + getRollupIndexCapabilities, + rollupSearchByIndex, + rollupSearchByIndexWith, + RollupJobId (..), + RollupJobConfig (..), + defaultRollupJobConfig, + RollupGroups (..), + defaultRollupGroups, + RollupDateHistogramGroup (..), + defaultRollupDateHistogramGroup, + RollupTermsGroup (..), + RollupHistogramGroup (..), + RollupJobMetric (..), + RollupJobMetricAgg (..), + rollupJobMetricAggText, + GetRollupJobsResponse (..), + RollupJob (..), + RollupJobStatus (..), + RollupJobState (..), + rollupJobStateText, + RollupJobStats (..), + GetRollupJobStatsResponse (..), + RollupJobStatsEntry (..), + RollupCapabilitiesResponse (..), + RollupIndexCapabilities (..), + RollupJobCapability (..), + RollupFieldCapability (..), + RollupCapabilityAgg (..), + rollupCapabilityAggText, + StopRollupJobOptions (..), + defaultStopRollupJobOptions, + RollupJobStarted (..), + RollupJobStopped (..), + + -- ** Searchable Snapshots + mountSearchableSnapshot, + mountSearchableSnapshotWith, + getSearchableSnapshotsStats, + getSearchableSnapshotsCacheStats, + clearSearchableSnapshotsCache, + SearchableSnapshotMount (..), + defaultSearchableSnapshotMount, + SearchableSnapshotStorage (..), + SearchableSnapshotMountOptions (..), + defaultSearchableSnapshotMountOptions, + SearchableSnapshotMountResponse (..), + SearchableSnapshotsStatsResponse (..), + SearchableSnapshotsCacheStatsResponse (..), + + -- ** Watcher + putWatch, + getWatch, + deleteWatch, + executeWatch, + executeWatchWith, + ackWatch, + activateWatch, + deactivateWatch, + watcherStats, + watcherStatsWith, + getWatcherSettings, + updateWatcherSettings, + startWatcher, + stopWatcher, + WatchId (..), + WatchBody (..), + Watch (..), + WatchStatus (..), + WatchState (..), + ExecuteWatchRequest (..), + ExecuteWatchResponse (..), + ExecuteWatchOptions (..), + defaultExecuteWatchOptions, + AckWatchResponse (..), + WatchStateResponse (..), + AckState (..), + WatchExecutionState (..), + WatcherStatsResponse (..), + WatcherStatsSummary (..), + WatcherStatsMetric (..), + WatcherSettings (..), + + -- ** Text structure + findStructure, + findStructureWith, + findMessageStructure, + findMessageStructureWith, + findFieldStructure, + findFieldStructureWith, + testGrokPattern, + testGrokPatternWith, + FindStructureResponse (..), + FindStructureFieldStats (..), + FindStructureTopHit (..), + FindStructureOptions (..), + defaultFindStructureOptions, + findStructureOptionsParams, + FindMessageStructureRequest (..), + FindMessageStructureOptions (..), + defaultFindMessageStructureOptions, + findMessageStructureOptionsParams, + FindFieldStructureOptions (..), + defaultFindFieldStructureOptions, + findFieldStructureOptionsParams, + TestGrokPatternRequest (..), + TestGrokPatternResponse (..), + TestGrokPatternOptions (..), + defaultTestGrokPatternOptions, + testGrokPatternOptionsParams, + + -- ** Transform + putTransform, + putTransformWith, + updateTransform, + updateTransformWith, + getTransforms, + getTransformsWith, + deleteTransform, + deleteTransformWith, + startTransform, + startTransformWith, + stopTransform, + stopTransformWith, + previewTransform, + previewTransformWith, + getTransformStats, + getTransformStatsWith, + explainTransform, + TransformId (..), + TransformState (..), + TransformHealth (..), + TransformSource (..), + TransformDestination (..), + TransformLatest (..), + TransformSync (..), + TransformSyncTime (..), + TransformSettings (..), + TransformConfig (..), + PutTransformResponse (..), + TransformsResponse (..), + DeleteTransformResponse (..), + StopTransformResponse (..), + PreviewTransformResponse (..), + TransformStatsResponse (..), + TransformStats (..), + TransformExplainResponse (..), + TransformExplainEntry (..), + PutTransformOptions (..), + defaultPutTransformOptions, + UpdateTransformOptions (..), + defaultUpdateTransformOptions, + GetTransformsOptions (..), + defaultGetTransformsOptions, + DeleteTransformOptions (..), + defaultDeleteTransformOptions, + StartTransformOptions (..), + defaultStartTransformOptions, + StopTransformOptions (..), + defaultStopTransformOptions, + PreviewTransformOptions (..), + defaultPreviewTransformOptions, + GetTransformStatsOptions (..), + defaultGetTransformStatsOptions, + + -- ** Migration + getMigrationDeprecations, + getSystemFeatures, + upgradeSystemFeatures, + DeprecationLevel (..), + Deprecation (..), + MigrationDeprecations (..), + FeatureMigrationStatus (..), + FeatureUpgradeIndex (..), + FeatureUpgradeInfo (..), + FeatureUpgradeStatus (..), + + -- ** Ingest Pipelines + putIngestPipeline, + getIngestPipeline, + deleteIngestPipeline, + simulateIngestPipeline, + getGrokPatterns, + GrokPatterns (..), + PipelineId (..), + IngestPipeline (..), + IngestPipelineInfo (..), + SimulateResult (..), + + -- ** Async Search + deleteAsyncSearch, + submitAsyncSearch, + submitAsyncSearchWith, + AsyncSearchId (..), + AsyncSearchResult (..), + AsyncSearchStatus (..), + AsyncSearchSubmitOptions (..), + defaultAsyncSearchSubmitOptions, + assoWaitForCompletionLens, + assoKeepOnCompletionLens, + assoKeepAliveLens, + assoBatchedReduceSizeLens, + assoCcsMinimizeRoundtripsLens, + + -- ** Request Utilities + Requests.encodeBulkOperations, + Requests.encodeBulkOperation, + + -- * Authentication + basicAuthHook, + + -- * Count + countByIndex, + countByIndexWith, + countAll, + CountOptions (..), + defaultCountOptions, + countOptionsParams, + + -- * Validate + validateQuery, + validateQueryWith, + validateAll, + ValidateOptions (..), + defaultValidateOptions, + validateOptionsParams, + + -- * Rank Evaluation + evaluateRank, + evaluateRankByIndex, + evaluateRankWith, + RankEvalOptions (..), + defaultRankEvalOptions, + rankEvalOptionsParams, + + -- * Analyze + analyzeText, + + -- * Field Capabilities + getFieldCaps, + getFieldCapsWith, + FieldPattern (..), + FieldCapsRequest (..), + defaultFieldCapsRequest, + FieldCapsOptions (..), + defaultFieldCapsOptions, + fieldCapsOptionsParams, + FieldCapsResponse (..), + FieldCapability (..), + + -- * Search Shards + getSearchShards, + getSearchShardsWith, + SearchShardsResponse (..), + SearchShardsNode (..), + SearchShardsShard (..), + SearchShardsState (..), + SearchShardsOptions (..), + defaultSearchShardsOptions, + searchShardsOptionsParams, + + -- * Generic + Acknowledged (..), + Accepted (..), + IgnoredBody (..), + ) +where + +import Control.Monad +import Control.Monad.Catch +import Data.Aeson +import Data.ByteString.Lazy qualified as L +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Data.Text.Encoding qualified as T +import Data.Time.Clock +import Data.Vector qualified as V +import Database.Bloodhound.Client.Cluster +import Database.Bloodhound.Common.Requests qualified as Requests +import Database.Bloodhound.Common.Types +import Network.HTTP.Client hiding (Proxy) +import Prelude hiding (filter, head) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> :set -XDeriveGeneric +-- >>> import Database.Bloodhound +-- >>> import Network.HTTP.Client +-- >>> let testServer = (Server "http://localhost:9200") +-- >>> let runBH' = withBH defaultManagerSettings testServer +-- >>> let testIndex = IndexName "twitter" +-- >>> let defaultIndexSettings = IndexSettings (ShardCount 1) (ReplicaCount 0) +-- >>> data TweetMapping = TweetMapping deriving stock (Eq, Show) +-- >>> _ <- runBH' $ deleteIndex testIndex +-- >>> _ <- runBH' $ deleteIndex (IndexName "didimakeanindex") +-- >>> import GHC.Generics +-- >>> import Data.Time.Calendar (Day (..)) +-- >>> import Data.Time.Clock (UTCTime (..), secondsToDiffTime) +-- >>> :{ +-- instance ToJSON TweetMapping where +-- toJSON TweetMapping = +-- object ["properties" .= +-- object ["location" .= +-- object ["type" .= ("geo_point" :: Text)]]] +-- data Location = Location { lat :: Double +-- , lon :: Double } deriving stock (Eq, Generic, Show) +-- data Tweet = Tweet { user :: Text +-- , postDate :: UTCTime +-- , message :: Text +-- , age :: Int +-- , location :: Location } deriving stock (Eq, Generic, Show) +-- exampleTweet = Tweet { user = "bitemyapp" +-- , postDate = UTCTime +-- (ModifiedJulianDay 55000) +-- (secondsToDiffTime 10) +-- , message = "Use haskell!" +-- , age = 10000 +-- , location = Location 40.12 (-71.34) } +-- instance ToJSON Tweet where +-- toJSON = genericToJSON defaultOptions +-- instance FromJSON Tweet where +-- parseJSON = genericParseJSON defaultOptions +-- instance ToJSON Location where +-- toJSON = genericToJSON defaultOptions +-- instance FromJSON Location where +-- parseJSON = genericParseJSON defaultOptions +-- data BulkTest = BulkTest { name :: Text } deriving stock (Eq, Generic, Show) +-- instance FromJSON BulkTest where +-- parseJSON = genericParseJSON defaultOptions +-- instance ToJSON BulkTest where +-- toJSON = genericToJSON defaultOptions +-- :} + +-- | Convenience function that sets up a manager and BHEnv and runs +-- the given set of bloodhound operations. Connections will be +-- pipelined automatically in accordance with the given manager +-- settings in IO. If you've got your own monad transformer stack, you +-- should use 'runBH' directly. +withBH :: ManagerSettings -> Server -> BH IO a -> IO a +withBH ms s f = do + mgr <- newManager ms + let env = mkBHEnv s mgr + runBH env f >>= either throwM return + +-- | 'getStatus' fetches the 'Status' of a 'Server' +-- +-- >>> serverStatus <- runBH' getStatus +-- >>> fmap tagline (serverStatus) +-- Just "You Know, for Search" +getStatus :: (MonadBH m) => m Status +getStatus = performBHRequest $ Requests.getStatus + +-- | 'getSnapshotRepos' gets the definitions of a subset of the +-- defined snapshot repos. +getSnapshotRepos :: (MonadBH m) => SnapshotRepoSelection -> m [GenericSnapshotRepo] +getSnapshotRepos sel = performBHRequest $ Requests.getSnapshotRepos sel + +-- | Variant of 'getSnapshotRepos' that accepts +-- 'SnapshotRepoGetOptions' for the @master_timeout@ and @local@ URI +-- parameters. +getSnapshotReposWith :: + (MonadBH m) => + SnapshotRepoSelection -> + SnapshotRepoGetOptions -> + m [GenericSnapshotRepo] +getSnapshotReposWith sel opts = performBHRequest $ Requests.getSnapshotReposWith sel opts + +-- | Create or update a snapshot repo +updateSnapshotRepo :: + (MonadBH m) => + (SnapshotRepo repo) => + -- | Use 'defaultSnapshotRepoUpdateSettings' if unsure + SnapshotRepoUpdateSettings -> + repo -> + m Acknowledged +updateSnapshotRepo settings repo = performBHRequest $ Requests.updateSnapshotRepo settings repo + +-- | Verify if a snapshot repo is working. __NOTE:__ this API did not +-- make it into Elasticsearch until 1.4. If you use an older version, +-- you will get an error here. +verifySnapshotRepo :: (MonadBH m) => SnapshotRepoName -> m SnapshotVerification +verifySnapshotRepo repoName = performBHRequest $ Requests.verifySnapshotRepo repoName + +-- | Variant of 'verifySnapshotRepo' that accepts +-- 'SnapshotRepoTimeoutOptions' for the @master_timeout@ and +-- @timeout@ URI parameters. +verifySnapshotRepoWith :: + (MonadBH m) => + SnapshotRepoName -> + SnapshotRepoTimeoutOptions -> + m SnapshotVerification +verifySnapshotRepoWith repoName opts = performBHRequest $ Requests.verifySnapshotRepoWith repoName opts + +-- | Removes stale data from a snapshot repository (segments not +-- referenced by any snapshot). Returns a 'SnapshotCleanupResult' +-- reporting the bytes and blobs deleted. A missing repository +-- surfaces as an 'EsError'. +cleanupSnapshotRepo :: + (MonadBH m) => + SnapshotRepoName -> + m SnapshotCleanupResult +cleanupSnapshotRepo repoName = performBHRequest $ Requests.cleanupSnapshotRepo repoName + +-- | Variant of 'cleanupSnapshotRepo' that accepts +-- 'SnapshotMasterTimeoutOptions' for the @master_timeout@ URI +-- parameter. +cleanupSnapshotRepoWith :: + (MonadBH m) => + SnapshotRepoName -> + SnapshotMasterTimeoutOptions -> + m SnapshotCleanupResult +cleanupSnapshotRepoWith repoName opts = performBHRequest $ Requests.cleanupSnapshotRepoWith repoName opts + +deleteSnapshotRepo :: (MonadBH m) => SnapshotRepoName -> m Acknowledged +deleteSnapshotRepo repoName = performBHRequest $ Requests.deleteSnapshotRepo repoName + +-- | Variant of 'deleteSnapshotRepo' that accepts +-- 'SnapshotRepoTimeoutOptions' for the @master_timeout@ and +-- @timeout@ URI parameters. +deleteSnapshotRepoWith :: + (MonadBH m) => + SnapshotRepoName -> + SnapshotRepoTimeoutOptions -> + m Acknowledged +deleteSnapshotRepoWith repoName opts = performBHRequest $ Requests.deleteSnapshotRepoWith repoName opts + +-- | Create and start a snapshot. Returns 'CreateSnapshotResponse', +-- a sum type whose two arms decode the two response shapes the +-- server emits: 'CreateSnapshotAcknowledged' for the default +-- @wait_for_completion=false@ path (@{"acknowledged": }@) and +-- 'CreateSnapshotCompleted' for @wait_for_completion=true@ +-- (@{"snapshot": {…}}@). See 'Requests.createSnapshot' for details. +createSnapshot :: + (MonadBH m) => + SnapshotRepoName -> + SnapshotName -> + SnapshotCreateSettings -> + m CreateSnapshotResponse +createSnapshot repoName snapName settings = performBHRequest $ Requests.createSnapshot repoName snapName settings + +-- | Clone a snapshot within the same repository, copying a (partial or +-- full) selection of indices from the source snapshot to a new target +-- snapshot. A missing repository\/source snapshot (404) or an +-- already-existing target (409) surfaces as an 'EsError'. +cloneSnapshot :: + (MonadBH m) => + SnapshotRepoName -> + SnapshotName -> + SnapshotName -> + SnapshotCloneSettings -> + m Acknowledged +cloneSnapshot repoName src target settings = + performBHRequest $ Requests.cloneSnapshot repoName src target settings + +-- | Get info about known snapshots given a pattern and repo name. +getSnapshots :: (MonadBH m) => SnapshotRepoName -> SnapshotSelection -> m [SnapshotInfo] +getSnapshots repoName sel = performBHRequest $ Requests.getSnapshots repoName sel + +-- | Variant of 'getSnapshots' that accepts 'SnapshotSelectionOptions' +-- for the @master_timeout@, @verbose@, @index_details@, +-- @include_repository@, @sort@, @order@, @size@, @offset@, @after@, +-- @from_sort_value@, @ignore_unavailable@, @index_names@ and +-- @slm_policy_filter@ URI parameters. Calling with +-- 'defaultSnapshotSelectionOptions' is byte-for-byte identical to +-- 'getSnapshots'. +getSnapshotsWith :: + (MonadBH m) => + SnapshotRepoName -> + SnapshotSelection -> + SnapshotSelectionOptions -> + m [SnapshotInfo] +getSnapshotsWith repoName sel opts = performBHRequest $ Requests.getSnapshotsWith repoName sel opts + +-- | Get detailed shard-level status of a snapshot. Use this rather than +-- 'getSnapshots' to monitor in-progress snapshots. +getSnapshotStatus :: (MonadBH m) => SnapshotRepoName -> SnapshotName -> m [SnapshotStatus] +getSnapshotStatus repoName snapName = performBHRequest $ Requests.getSnapshotStatus repoName snapName + +-- | Variant of 'getSnapshotStatus' that accepts +-- 'SnapshotStatusOptions' for the @master_timeout@ and +-- @ignore_unavailable@ URI parameters. +getSnapshotStatusWith :: + (MonadBH m) => + SnapshotRepoName -> + SnapshotName -> + SnapshotStatusOptions -> + m [SnapshotStatus] +getSnapshotStatusWith repoName snapName opts = performBHRequest $ Requests.getSnapshotStatusWith repoName snapName opts + +-- | Delete a snapshot. Cancels if it is running. +deleteSnapshot :: (MonadBH m) => SnapshotRepoName -> SnapshotName -> m Acknowledged +deleteSnapshot repoName snapName = performBHRequest $ Requests.deleteSnapshot repoName snapName + +-- | Variant of 'deleteSnapshot' that accepts +-- 'SnapshotMasterTimeoutOptions' for the @master_timeout@ URI +-- parameter. +deleteSnapshotWith :: + (MonadBH m) => + SnapshotRepoName -> + SnapshotName -> + SnapshotMasterTimeoutOptions -> + m Acknowledged +deleteSnapshotWith repoName snapName opts = performBHRequest $ Requests.deleteSnapshotWith repoName snapName opts + +-- | Restore a snapshot to the cluster See +-- +-- for more details. +restoreSnapshot :: + (MonadBH m) => + SnapshotRepoName -> + SnapshotName -> + -- | Start with 'defaultSnapshotRestoreSettings' and customize + -- from there for reasonable defaults. + SnapshotRestoreSettings -> + m Accepted +restoreSnapshot repoName snapName settings = performBHRequest $ Requests.restoreSnapshot repoName snapName settings + +getNodesInfo :: (MonadBH m) => NodeSelection -> m NodesInfo +getNodesInfo sel = performBHRequest $ Requests.getNodesInfo sel + +-- | 'getNodesInfoWith' is the fully-parameterised form of +-- 'getNodesInfo'. See 'Requests.getNodesInfoWith' and +-- 'NodeInfoOptions' for the available parameters. +getNodesInfoWith :: (MonadBH m) => NodeSelection -> NodeInfoOptions -> m NodesInfo +getNodesInfoWith sel opts = performBHRequest $ Requests.getNodesInfoWith sel opts + +getNodesStats :: (MonadBH m) => NodeSelection -> m NodesStats +getNodesStats sel = performBHRequest $ Requests.getNodesStats sel + +-- | 'getNodesStatsWith' is the fully-parameterised form of +-- 'getNodesStats'. See 'Requests.getNodesStatsWith' and +-- 'NodeStatsOptions' for the available parameters. +getNodesStatsWith :: (MonadBH m) => NodeSelection -> NodeStatsOptions -> m NodesStats +getNodesStatsWith sel opts = performBHRequest $ Requests.getNodesStatsWith sel opts + +getNodesUsage :: (MonadBH m) => NodeSelection -> m NodesUsage +getNodesUsage sel = performBHRequest $ Requests.getNodesUsage sel + +-- | 'getNodesUsageWith' is the fully-parameterised form of +-- 'getNodesUsage'. See 'Requests.getNodesUsageWith' and +-- 'NodeUsageOptions' for the available parameters. +getNodesUsageWith :: (MonadBH m) => NodeSelection -> NodeUsageOptions -> m NodesUsage +getNodesUsageWith sel opts = performBHRequest $ Requests.getNodesUsageWith sel opts + +-- | 'getNodesHotThreads' fetches the @GET /_nodes/hot_threads@ report +-- (high-CPU diagnostic). See 'Requests.getNodesHotThreads' for the +-- semantics of the @Maybe 'NodeSelector'@ and @Maybe 'ThreadCount'@ +-- parameters. +getNodesHotThreads :: (MonadBH m) => Maybe NodeSelector -> Maybe ThreadCount -> m Text +getNodesHotThreads mSel mThreadCount = performBHRequest $ Requests.getNodesHotThreads mSel mThreadCount + +-- | 'getNodesHotThreadsWith' is the fully-parameterised form of +-- 'getNodesHotThreads'. See 'Requests.getNodesHotThreadsWith' and +-- 'HotThreadsOptions' for the available parameters. +getNodesHotThreadsWith :: (MonadBH m) => Maybe NodeSelector -> HotThreadsOptions -> m Text +getNodesHotThreadsWith mSel opts = performBHRequest $ Requests.getNodesHotThreadsWith mSel opts + +-- | 'reloadSecureSettings' reloads keystore-backed secure settings on +-- the selected nodes without a restart. Pass @Nothing@ for cluster-wide +-- reload, or @Just sel@ to scope to a 'NodeSelection'. See +-- 'Requests.reloadSecureSettings' for the URL rendering of each +-- selection form. +reloadSecureSettings :: (MonadBH m) => Maybe NodeSelection -> m Acknowledged +reloadSecureSettings mSel = performBHRequest $ Requests.reloadSecureSettings mSel + +getClusterHealth :: (MonadBH m) => m ClusterHealth +getClusterHealth = performBHRequest Requests.getClusterHealth + +-- | Fully-parameterised cluster health query ('ClusterHealthOptions' for +-- every URI parameter). See 'Requests.getClusterHealthWith'. +getClusterHealthWith :: (MonadBH m) => ClusterHealthOptions -> m ClusterHealth +getClusterHealthWith opts = performBHRequest $ Requests.getClusterHealthWith opts + +-- | Per-index cluster health (@GET /_cluster/health/{index}@). +getClusterHealthForIndex :: (MonadBH m) => IndexName -> m ClusterHealth +getClusterHealthForIndex indexName = performBHRequest $ Requests.getClusterHealthForIndex indexName + +-- | Per-index cluster health with the full 'ClusterHealthOptions' +-- parameter set. This is the most general cluster-health query. +getClusterHealthForIndexWith :: + (MonadBH m) => + ClusterHealthOptions -> + IndexName -> + m ClusterHealth +getClusterHealthForIndexWith opts indexName = + performBHRequest $ Requests.getClusterHealthForIndexWith opts indexName + +getClusterState :: (MonadBH m) => m ClusterState +getClusterState = performBHRequest Requests.getClusterState + +-- | Explain why a shard is (or is not) allocated — +-- @/_cluster/allocation/explain@. See 'Requests.explainAllocation'. +explainAllocation :: + (MonadBH m) => + Maybe AllocationExplainRequest -> + m AllocationExplanation +explainAllocation = performBHRequest . Requests.explainAllocation + +-- | Fetch connection state for every configured remote cluster +-- (@GET /_remote/info@). Returns an alias-keyed +-- 'RemoteClustersInfo'; an empty object on a cluster with no remotes +-- configured. Elasticsearch-only — OpenSearch does not expose this +-- endpoint. See 'Requests.getRemoteClusterInfo'. +getRemoteClusterInfo :: (MonadBH m) => m RemoteClustersInfo +getRemoteClusterInfo = performBHRequest Requests.getRemoteClusterInfo + +-- | Manually add voting config exclusions for departed nodes +-- (@POST /_cluster/voting_config_exclusions@). The server requires at +-- least one node id or name across the two option lists. +-- Elasticsearch-only — OpenSearch does not expose this endpoint. See +-- 'Requests.updateVotingConfigExclusions'. +updateVotingConfigExclusions :: + (MonadBH m) => + VotingConfigExclusionOptions -> + m Acknowledged +updateVotingConfigExclusions opts = + performBHRequest $ Requests.updateVotingConfigExclusions opts + +-- | Clear all voting config exclusions the cluster is currently +-- holding (@DELETE /_cluster/voting_config_exclusions@). +-- Elasticsearch-only — OpenSearch does not expose this endpoint. See +-- 'Requests.clearVotingConfigExclusions'. +clearVotingConfigExclusions :: (MonadBH m) => m Acknowledged +clearVotingConfigExclusions = + performBHRequest Requests.clearVotingConfigExclusions + +-- | Fully-parameterised cluster state query +-- (@GET /_cluster/state/{metric}/{index}@). See +-- 'Requests.getClusterStateWith' and 'ClusterStateOptions' for the +-- available URI parameters. Passing 'defaultClusterStateOptions' +-- reproduces 'getClusterState' byte-for-byte. +getClusterStateWith :: + (MonadBH m) => + ClusterStateOptions -> + m ClusterState +getClusterStateWith opts = + performBHRequest $ Requests.getClusterStateWith opts + +-- | Fetch cluster-level statistics (@GET /_cluster/stats@): indices +-- counts, shards, docs, store size, versions and per-node aggregates +-- (count by role, JVM, FS, OS, plugins, ingest, ...). See +-- 'Requests.getClusterStats'. +getClusterStats :: (MonadBH m) => m ClusterStats +getClusterStats = performBHRequest Requests.getClusterStats + +-- | Fetch the cluster-level changes not yet executed by the master +-- (@GET /_cluster/pending_tasks@): pending index creations, mapping +-- updates, shard starts, reroutes and the like. Returns the plain +-- list of 'PendingTask' values (empty when the cluster is idle). See +-- 'Requests.getPendingTasks'. +getPendingTasks :: (MonadBH m) => m [PendingTask] +getPendingTasks = performBHRequest Requests.getPendingTasks + +-- | Fetch cluster-wide settings (@GET /_cluster/settings@). Returns the +-- persistent and transient layers; the defaults layer is omitted unless +-- the request is issued via 'getClusterSettingsWith' with +-- 'csoIncludeDefaults' set. +getClusterSettings :: (MonadBH m) => m ClusterSettings +getClusterSettings = performBHRequest Requests.getClusterSettings + +-- | Fully-parameterised cluster settings query +-- ('ClusterSettingsOptions' for every URI parameter). See +-- 'Requests.getClusterSettingsWith'. +getClusterSettingsWith :: (MonadBH m) => ClusterSettingsOptions -> m ClusterSettings +getClusterSettingsWith opts = performBHRequest $ Requests.getClusterSettingsWith opts + +-- | Update cluster-wide settings (@PUT /_cluster/settings@). Applies the +-- persistent and\/or transient settings carried by the +-- 'ClusterSettingsUpdate' body; assign 'Null' to a key to clear it. See +-- 'Requests.updateClusterSettings'. +updateClusterSettings :: (MonadBH m) => ClusterSettingsUpdate -> m Acknowledged +updateClusterSettings update = performBHRequest $ Requests.updateClusterSettings update + +-- | Fully-parameterised cluster settings update +-- ('ClusterSettingsUpdateOptions' for every URI parameter). See +-- 'Requests.updateClusterSettingsWith'. +updateClusterSettingsWith :: + (MonadBH m) => + ClusterSettingsUpdateOptions -> + ClusterSettingsUpdate -> + m Acknowledged +updateClusterSettingsWith opts update = + performBHRequest $ Requests.updateClusterSettingsWith opts update + +-- | Manually execute shard reroute commands (@POST /_cluster/reroute@). +-- Each 'RerouteCommand' (move, cancel, allocate_replica, ...) is applied +-- immediately; the cluster acknowledges the operation. See +-- 'Requests.rerouteCluster' and 'rerouteClusterWith' for the non-mutating +-- @dry_run@ form. +rerouteCluster :: (MonadBH m) => [RerouteCommand] -> m Acknowledged +rerouteCluster cmds = performBHRequest $ Requests.rerouteCluster cmds + +-- | Fully-parameterised cluster reroute +-- ('RerouteOptions' for every URI parameter). Returns the rich +-- 'RerouteResponse' so that @dry_run\@true@ surfaces the simulated +-- cluster state and @explain@ surfaces the allocation-decision +-- explanations. See 'Requests.rerouteClusterWith'. +rerouteClusterWith :: + (MonadBH m) => + RerouteOptions -> + [RerouteCommand] -> + m RerouteResponse +rerouteClusterWith opts cmds = + performBHRequest $ Requests.rerouteClusterWith opts cmds + +createIndex :: (MonadBH m) => IndexSettings -> IndexName -> m Acknowledged +createIndex indexSettings indexName = performBHRequest $ Requests.createIndex indexSettings indexName + +-- | Create an index, providing it with any number of settings. This +-- is more expressive than 'createIndex' but makes is more verbose +-- for the common case of configuring only the shard count and +-- replica count. +createIndexWith :: + (MonadBH m) => + [UpdatableIndexSetting] -> + -- | shard count + Int -> + IndexName -> + m Acknowledged +createIndexWith updates shards indexName = performBHRequest $ Requests.createIndexWith updates shards indexName + +-- | Create an index with the full set of body fields (@settings@, +-- @mappings@, @aliases@) and URI parameters (@wait_for_active_shards@, +-- @master_timeout@, @timeout@) accepted by the create-index endpoint. +-- This is a superset of 'createIndex' \/ 'createIndexWith' for callers +-- that need more than just @settings@. See 'CreateIndexOptions' for the +-- shape and 'defaultCreateIndexOptions' for an empty starting point. +-- +-- @since 0.26.0.0 +createIndexOptions :: + (MonadBH m) => + CreateIndexOptions -> + IndexName -> + m Acknowledged +createIndexOptions opts indexName = performBHRequest $ Requests.createIndexOptions opts indexName + +-- | 'flushIndex' will flush an index given a 'Server' and an 'IndexName'. +-- Returns 'ShardsResult' (the @{\"_shards\": {...}}@ envelope); reach the +-- inner counts via 'srShards'. +flushIndex :: (MonadBH m) => IndexName -> m ShardsResult +flushIndex indexName = performBHRequest $ Requests.flushIndex indexName + +-- | 'flushIndexWith' is the fully-parameterised form of 'flushIndex'. +-- Pass 'defaultFlushIndexOptions' to reproduce the legacy behaviour. +flushIndexWith :: (MonadBH m) => FlushIndexOptions -> IndexName -> m ShardsResult +flushIndexWith opts indexName = performBHRequest $ Requests.flushIndexWith opts indexName + +-- | 'clearIndexCache' clears the caches (query, fielddata, request) +-- for a single index. Wraps @POST \/\\/_cache\/clear@. +-- +-- Returns 'ShardsResult' (the @{\"_shards\": {...}}@ envelope), like the +-- neighbouring 'flushIndex' and 'refreshIndex', because the ES\/OS +-- response wraps the shard stats in a top-level @_shards@ key. Only +-- @?fielddata@, @?query@, @?request@ for selective clearing are not yet +-- exposed. +-- +-- See +-- +-- and +-- . +-- +-- @since 0.26.0.0 +clearIndexCache :: (MonadBH m) => IndexName -> m ShardsResult +clearIndexCache indexName = performBHRequest $ Requests.clearIndexCache indexName + +-- | 'reloadSearchAnalyzers' reloads an index's updateable search +-- analyzers (e.g. @updateable@ @synonym@\/@synonym_graph@ filters), +-- picking up changes to the underlying synonym files. Maps to +-- @POST \/{index}/_reload_search_analyzers@. +-- +-- Equivalent to +-- @'reloadSearchAnalyzersWith' 'defaultReloadSearchAnalyzersOptions'@. +-- +-- See +-- +-- and +-- . +-- +-- @since 0.26.0.0 +reloadSearchAnalyzers :: + (MonadBH m) => + IndexName -> + m ReloadSearchAnalyzersResponse +reloadSearchAnalyzers = reloadSearchAnalyzersWith defaultReloadSearchAnalyzersOptions + +-- | 'reloadSearchAnalyzersWith' is the fully-parameterised form of +-- 'reloadSearchAnalyzers'. +reloadSearchAnalyzersWith :: + (MonadBH m) => + ReloadSearchAnalyzersOptions -> + IndexName -> + m ReloadSearchAnalyzersResponse +reloadSearchAnalyzersWith opts indexName = + performBHRequest $ Requests.reloadSearchAnalyzersWith opts indexName + +-- | 'diskUsage' analyses the disk usage of each field of an index. Maps +-- to @POST \/{index}/_disk_usage@. ES-only feature (technical preview) +-- and resource-intensive; 'defaultDiskUsageOptions' sets the required +-- @run_expensive_tasks=true@. +-- +-- Equivalent to @'diskUsageWith' 'defaultDiskUsageOptions'@. +-- +-- See +-- . +-- +-- @since 0.26.0.0 +diskUsage :: + (MonadBH m) => + IndexName -> + m DiskUsageResponse +diskUsage = diskUsageWith defaultDiskUsageOptions + +-- | 'diskUsageWith' is the fully-parameterised form of 'diskUsage'. +diskUsageWith :: + (MonadBH m) => + DiskUsageOptions -> + IndexName -> + m DiskUsageResponse +diskUsageWith opts indexName = + performBHRequest $ Requests.diskUsageWith opts indexName + +-- | 'fieldUsageStats' reports per-shard, per-field access counts. Maps +-- to @GET \/{index}/_field_usage_stats@. ES-only feature (technical +-- preview). +-- +-- Equivalent to +-- @'fieldUsageStatsWith' 'defaultFieldUsageStatsOptions'@. +-- +-- See +-- . +-- +-- @since 0.26.0.0 +fieldUsageStats :: + (MonadBH m) => + IndexName -> + m FieldUsageStatsResponse +fieldUsageStats = fieldUsageStatsWith defaultFieldUsageStatsOptions + +-- | 'fieldUsageStatsWith' is the fully-parameterised form of +-- 'fieldUsageStats'. +fieldUsageStatsWith :: + (MonadBH m) => + FieldUsageStatsOptions -> + IndexName -> + m FieldUsageStatsResponse +fieldUsageStatsWith opts indexName = + performBHRequest $ Requests.fieldUsageStatsWith opts indexName + +-- | 'getScriptContexts' lists every Painless \/ expression execution +-- context the cluster knows about, with each context's method +-- catalogue. Maps to @GET /_script_context@. +-- +-- See +-- . +-- +-- @since 0.26.0.0 +getScriptContexts :: + (MonadBH m) => + m ScriptContextsResponse +getScriptContexts = performBHRequest $ Requests.getScriptContexts + +-- | 'getScriptLanguages' lists the script languages the cluster +-- supports and, per language, the execution contexts in which each may +-- run. Maps to @GET /_script_language@. +-- +-- Note: on OpenSearch 1.3 this endpoint returns HTTP 500 (a server +-- bug); calls against a 1.3 cluster will fail. +-- +-- See +-- . +-- +-- @since 0.26.0.0 +getScriptLanguages :: + (MonadBH m) => + m ScriptLanguagesResponse +getScriptLanguages = performBHRequest $ Requests.getScriptLanguages + +-- | 'deleteIndex' will delete an index given a 'Server' and an 'IndexName'. +-- +-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex") +-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex") +-- >>> isSuccess response +-- True +-- >>> runBH' $ indexExists (IndexName "didimakeanindex") +-- False +deleteIndex :: (MonadBH m) => IndexName -> m Acknowledged +deleteIndex indexName = performBHRequest $ Requests.deleteIndex indexName + +-- | 'updateIndexSettings' will apply a non-empty list of setting updates to an index +-- +-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "unconfiguredindex") +-- >>> response <- runBH' $ updateIndexSettings (BlocksWrite False :| []) (IndexName "unconfiguredindex") +-- >>> isSuccess response +-- True +-- +-- Equivalent to @'updateIndexSettingsWith' updates 'defaultUpdateIndexSettingsOptions'@. +updateIndexSettings :: + (MonadBH m) => + NonEmpty UpdatableIndexSetting -> + IndexName -> + m Acknowledged +updateIndexSettings updates indexName = performBHRequest $ Requests.updateIndexSettings updates indexName + +-- | 'updateIndexSettingsWith' is the fully-parameterised form of +-- 'updateIndexSettings'. Pass 'defaultUpdateIndexSettingsOptions' to +-- reproduce the legacy behaviour. +updateIndexSettingsWith :: + (MonadBH m) => + NonEmpty UpdatableIndexSetting -> + IndexName -> + UpdateIndexSettingsOptions -> + m Acknowledged +updateIndexSettingsWith updates indexName opts = + performBHRequest $ Requests.updateIndexSettingsWith updates indexName opts + +-- | 'getIndexSettings' retrieves the live settings of a single index. +-- Equivalent to @'getIndexSettingsWith' name 'defaultGetIndexSettingsOptions'@. +getIndexSettings :: (MonadBH m) => IndexName -> m IndexSettingsSummary +getIndexSettings indexName = performBHRequest $ Requests.getIndexSettings indexName + +-- | 'getIndexSettingsWith' is the fully-parameterised form of +-- 'getIndexSettings'. Pass 'defaultGetIndexSettingsOptions' to reproduce +-- the legacy behaviour. +getIndexSettingsWith :: + (MonadBH m) => + IndexName -> + GetIndexSettingsOptions -> + m IndexSettingsSummary +getIndexSettingsWith indexName opts = + performBHRequest $ Requests.getIndexSettingsWith indexName opts + +-- | 'getIndex' fetches the full definition of a single index — its +-- @aliases@, @mappings@ and @settings@ — in one request. Wraps the +-- @GET \/\@ endpoint +-- (). +getIndex :: (MonadBH m) => IndexName -> m IndexInfo +getIndex indexName = performBHRequest $ Requests.getIndex indexName + +-- | 'getIndexStats' returns statistics for a single index — the +-- @GET \/\\/_stats@ endpoint +-- (). +getIndexStats :: (MonadBH m) => IndexName -> m IndexStats +getIndexStats indexName = performBHRequest $ Requests.getIndexStats indexName + +-- | 'getIndexRecovery' returns information about ongoing and completed +-- shard recoveries for the given index (e.g. after snapshot restore, +-- replica allocation or peer recovery on node restart). Wraps the +-- @GET \/\\/_recovery@ endpoint +-- (). +getIndexRecovery :: (MonadBH m) => IndexName -> m IndexRecovery +getIndexRecovery indexName = performBHRequest $ Requests.getIndexRecovery indexName + +-- | 'getIndexSegments' returns low-level Lucene segment information +-- for the given index, one entry per shard copy (primary and each +-- replica). Wraps the @GET \/\\/_segments@ endpoint +-- (; +-- also implemented by OpenSearch — see +-- ). +getIndexSegments :: (MonadBH m) => IndexName -> m IndexSegments +getIndexSegments indexName = performBHRequest $ Requests.getIndexSegments indexName + +-- | 'getShardStores' returns store information for every shard copy +-- (primary and each replica) of the given index, one entry per copy +-- describing where it is allocated and its allocation state. Wraps the +-- @GET \/\\/_shard_stores@ endpoint +-- (; +-- also implemented by OpenSearch — see +-- ). +-- +-- Equivalent to @'getShardStoresWith' 'defaultShardStoresOptions'@. Use +-- the @With@ variant to pass URI parameters such as @status@ +-- (cluster-health filter). Surfaced as 'StatusDependant' so genuine +-- server-side errors (auth, missing index, 5xx, ...) decode as an +-- 'EsError'. +getShardStores :: (MonadBH m) => IndexName -> m ShardStores +getShardStores indexName = performBHRequest $ Requests.getShardStores indexName + +-- | Like 'getShardStores' but additionally accepts 'ShardStoresOptions' +-- rendered as URI parameters. 'defaultShardStoresOptions' makes this +-- byte-for-byte identical to 'getShardStores'. +getShardStoresWith :: + (MonadBH m) => + IndexName -> + ShardStoresOptions -> + m ShardStores +getShardStoresWith indexName opts = + performBHRequest $ Requests.getShardStoresWith indexName opts + +-- | 'resolveIndex' resolves indices, aliases and data streams matching +-- the given patterns. Wraps @GET /_resolve/index\/{name}@ +-- (; +-- also implemented by OpenSearch — see +-- ). +-- +-- Patterns are comma-joined into a single path segment; an empty list +-- is treated as the wildcard @*@. Use 'resolveIndexWith' to pass URI +-- parameters such as @expand_wildcards@. Surfaced as 'StatusDependant' +-- so genuine server-side errors (auth, malformed pattern, ...) decode +-- as an 'EsError'. A missing concrete target usually returns 200 with +-- empty result arrays rather than a 404 — see 'ResolveIndexOptions' +-- for the @ignore_unavailable@ knob (documented on ES 8.x+, silently +-- accepted by OpenSearch). +resolveIndex :: (MonadBH m) => [IndexPattern] -> m ResolvedIndices +resolveIndex patterns = performBHRequest $ Requests.resolveIndex patterns + +-- | Like 'resolveIndex' but additionally accepts 'ResolveIndexOptions' +-- rendered as URI parameters. 'defaultResolveIndexOptions' makes this +-- byte-for-byte identical to 'resolveIndex'. +resolveIndexWith :: + (MonadBH m) => + ResolveIndexOptions -> + [IndexPattern] -> + m ResolvedIndices +resolveIndexWith opts patterns = + performBHRequest $ Requests.resolveIndexWith opts patterns + +-- | 'listDanglingIndices' returns every dangling index currently +-- known to the cluster. See 'Requests.listDanglingIndices' for the +-- underlying builder and wire-shape details. Not implemented by +-- OpenSearch — a request against an OS backend surfaces as an +-- 'EsError'. +-- +-- @since 0.26.0.0 +listDanglingIndices :: (MonadBH m) => m [DanglingIndex] +listDanglingIndices = performBHRequest Requests.listDanglingIndices + +-- | 'importDanglingIndex' re-attaches a dangling index to the cluster +-- metadata via @POST /_dangling/{uuid}@. The +-- @accept_data_loss=true@ flag is set by +-- 'defaultImportDanglingIndexOptions'. See 'Requests.importDanglingIndex'. +-- +-- @since 0.26.0.0 +importDanglingIndex :: + (MonadBH m) => + DanglingIndexUuid -> + m Acknowledged +importDanglingIndex uuid = + performBHRequest $ Requests.importDanglingIndex uuid + +-- | Fully-parameterised form of 'importDanglingIndex'. Pass +-- 'defaultImportDanglingIndexOptions' to reproduce the bare behaviour. +-- See 'Requests.importDanglingIndexWith'. +-- +-- @since 0.26.0.0 +importDanglingIndexWith :: + (MonadBH m) => + DanglingIndexUuid -> + ImportDanglingIndexOptions -> + m Acknowledged +importDanglingIndexWith uuid opts = + performBHRequest $ Requests.importDanglingIndexWith uuid opts + +-- | 'deleteDanglingIndex' permanently removes a dangling index's +-- on-disk data via @DELETE /_dangling/{uuid}@. See +-- 'Requests.deleteDanglingIndex'. +-- +-- @since 0.26.0.0 +deleteDanglingIndex :: + (MonadBH m) => + DanglingIndexUuid -> + m Acknowledged +deleteDanglingIndex uuid = + performBHRequest $ Requests.deleteDanglingIndex uuid + +-- | Fully-parameterised form of 'deleteDanglingIndex'. Pass +-- 'defaultDeleteDanglingIndexOptions' to send no parameters at all. +-- See 'Requests.deleteDanglingIndexWith'. +-- +-- @since 0.26.0.0 +deleteDanglingIndexWith :: + (MonadBH m) => + DanglingIndexUuid -> + DeleteDanglingIndexOptions -> + m Acknowledged +deleteDanglingIndexWith uuid opts = + performBHRequest $ Requests.deleteDanglingIndexWith uuid opts + +-- | 'forceMergeIndex' +-- +-- The force merge API allows to force merging of one or more indices through +-- an API. The merge relates to the number of segments a Lucene index holds +-- within each shard. The force merge operation allows to reduce the number of +-- segments by merging them. +-- +-- This call will block until the merge is complete. If the http connection is +-- lost, the request will continue in the background, and any new requests will +-- block until the previous force merge is complete. + +-- For more information see +-- . +-- Nothing +-- worthwhile comes back in the response body, so matching on the status +-- should suffice. +-- +-- 'forceMergeIndex' with a maxNumSegments of 1 and onlyExpungeDeletes +-- to True is the main way to release disk space back to the OS being +-- held by deleted documents. +-- +-- >>> let ixn = IndexName "unoptimizedindex" +-- >>> _ <- runBH' $ deleteIndex ixn >> createIndex defaultIndexSettings ixn +-- >>> response <- runBH' $ forceMergeIndex (IndexList (ixn :| [])) (defaultIndexOptimizationSettings { maxNumSegments = Just 1, onlyExpungeDeletes = True }) +-- >>> isSuccess response +-- True +forceMergeIndex :: (MonadBH m) => IndexSelection -> ForceMergeIndexSettings -> m ShardsResult +forceMergeIndex ixs settings = performBHRequest $ Requests.forceMergeIndex ixs settings + +-- | 'indexExists' enables you to check if an index exists. Returns 'Bool' +-- in IO +-- +-- >>> exists <- runBH' $ indexExists testIndex +indexExists :: (MonadBH m) => IndexName -> m Bool +indexExists indexName = performBHRequest $ Requests.indexExists indexName + +-- | 'refreshIndex' will force a refresh on an index. You must +-- do this if you want to read what you wrote. +-- +-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex +-- >>> _ <- runBH' $ refreshIndex testIndex +-- +-- Returns 'ShardsResult' (the @{\"_shards\": {...}}@ envelope); reach the +-- inner counts via 'srShards'. +refreshIndex :: (MonadBH m) => IndexName -> m ShardsResult +refreshIndex indexName = performBHRequest $ Requests.refreshIndex indexName + +-- | 'refreshIndexWith' is the fully-parameterised form of 'refreshIndex'. +-- Pass 'defaultRefreshIndexOptions' to reproduce the legacy behaviour. +refreshIndexWith :: (MonadBH m) => RefreshIndexOptions -> IndexName -> m ShardsResult +refreshIndexWith opts indexName = performBHRequest $ Requests.refreshIndexWith opts indexName + +-- | Block until the index becomes available for indexing +-- documents. This is useful for integration tests in which +-- indices are rapidly created and deleted. +waitForYellowIndex :: (MonadBH m) => IndexName -> m Requests.HealthStatus +waitForYellowIndex indexName = performBHRequest $ Requests.waitForYellowIndex indexName + +-- | 'rolloverIndex' rolls an alias over to a new index when the +-- supplied conditions are met on the alias's current write index. The +-- alias must point at exactly one write index whose name matches the +-- rollover naming convention (e.g. @logs-000001@ -> @logs-000002@). +-- Wraps @POST /\/_rollover@. +-- +-- Pass @'Just' conditions@ to set thresholds (any subset of +-- 'rolloverConditionsMaxAge' \/ 'rolloverConditionsMaxDocs' \/ +-- 'rolloverConditionsMaxSize' \/ 'rolloverConditionsMaxPrimaryShardSize'; +-- at least one should be 'Just'). Pass 'Nothing' to roll over +-- unconditionally. See 'RolloverResponse' for the result. +-- +-- @since 0.26.0.0 +rolloverIndex :: + (MonadBH m) => + IndexAliasName -> + Maybe RolloverConditions -> + m RolloverResponse +rolloverIndex alias mConditions = performBHRequest $ Requests.rolloverIndex alias mConditions + +-- | Shrink an existing index into a new index with fewer primary shards. +-- Wraps @POST /\/_shrink/\@. The source must be +-- read-only (@index.blocks.write: true@) and all primary shards must be +-- co-located on one node; the target's @number_of_shards@ must be a +-- divisor of the source's. Override 'shrinkSettingsOptions' to set the +-- target shard count, aliases and the other body fields and URI +-- parameters (@wait_for_active_shards@, @master_timeout@, @timeout@). +-- +-- @since 0.26.0.0 +shrinkIndex :: + (MonadBH m) => + IndexName -> + IndexName -> + ShrinkSettings -> + m Acknowledged +shrinkIndex source target settings = + performBHRequest $ Requests.shrinkIndex source target settings + +-- | Split an existing index into a new index with more primary shards. +-- Wraps @POST /\/_split/\@. The source must be +-- read-only (@index.blocks.write: true@); the target's +-- @number_of_shards@ must be a multiple of the source's, and the +-- source's @index.number_of_routing_shards@ must be a multiple of the +-- target's. See 'shrinkSettingsOptions' for the body and URI parameter +-- surface. +-- +-- @since 0.26.0.0 +splitIndex :: + (MonadBH m) => + IndexName -> + IndexName -> + SplitSettings -> + m Acknowledged +splitIndex source target settings = + performBHRequest $ Requests.splitIndex source target settings + +-- | Clone an existing index into a new index with the same mappings and +-- settings. Wraps @POST /\/_clone/\@. The source must +-- be read-only (@index.blocks.write: true@); the target inherits the +-- source's @number_of_shards@. See 'shrinkSettingsOptions' for the +-- body and URI parameter surface (the record is wrapped under +-- 'cloneSettingsOptions' here). +-- +-- @since 0.26.0.0 +cloneIndex :: + (MonadBH m) => + IndexName -> + IndexName -> + CloneSettings -> + m Acknowledged +cloneIndex source target settings = + performBHRequest $ Requests.cloneIndex source target settings + +-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at +-- +-- +-- >>> response <- runBH' $ openIndex testIndex +openIndex :: (MonadBH m) => IndexName -> m Acknowledged +openIndex indexName = performBHRequest $ Requests.openIndex indexName + +-- | 'openIndexWith' is the fully-parameterised form of 'openIndex'. Pass +-- 'defaultOpenCloseIndexOptions' to reproduce the legacy behaviour. +openIndexWith :: (MonadBH m) => OpenCloseIndexOptions -> IndexName -> m Acknowledged +openIndexWith opts indexName = performBHRequest $ Requests.openIndexWith opts indexName + +-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at +-- +-- +-- >>> response <- runBH' $ closeIndex testIndex +closeIndex :: (MonadBH m) => IndexName -> m Acknowledged +closeIndex indexName = performBHRequest $ Requests.closeIndex indexName + +-- | 'closeIndexWith' is the fully-parameterised form of 'closeIndex'. Pass +-- 'defaultOpenCloseIndexOptions' to reproduce the legacy behaviour. +closeIndexWith :: (MonadBH m) => OpenCloseIndexOptions -> IndexName -> m Acknowledged +closeIndexWith opts indexName = performBHRequest $ Requests.closeIndexWith opts indexName + +-- | 'listIndices' returns a list of all index names on a given 'Server' +listIndices :: (MonadBH m) => m [IndexName] +listIndices = performBHRequest $ Requests.listIndices + +-- | 'catIndices' returns a list of all index names on a given 'Server' as well as their doc counts +catIndices :: (MonadBH m) => m [(IndexName, Int)] +catIndices = performBHRequest $ Requests.catIndices + +-- | 'catIndicesWith' is the fully-parameterised form of 'catIndices'. +-- See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatIndicesOptions' +-- for the available parameters. +catIndicesWith :: (MonadBH m) => CatIndicesOptions -> m [CatIndicesRow] +catIndicesWith = performBHRequest . Requests.catIndicesWith + +-- | 'catAliases' lists every index alias on the cluster via +-- @GET /_cat\/aliases?format=json@. Equivalent to +-- @'catAliasesWith' 'Nothing' 'defaultCatAliasesOptions'@. +catAliases :: (MonadBH m) => m [CatAliasesRow] +catAliases = performBHRequest $ Requests.catAliases + +-- | 'catAliasesWith' is the fully-parameterised form of 'catAliases'. +-- See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatAliasesOptions' +-- for the available parameters. +catAliasesWith :: + (MonadBH m) => + Maybe AliasName -> + CatAliasesOptions -> + m [CatAliasesRow] +catAliasesWith mAlias opts = + performBHRequest $ Requests.catAliasesWith mAlias opts + +-- | 'catAllocation' lists the allocation of disk space for indexes and +-- the number of shards on each data node via +-- @GET /_cat\/allocation?format=json@. Equivalent to +-- @'catAllocationWith' 'Nothing' 'defaultCatAllocationOptions'@. +catAllocation :: (MonadBH m) => m [CatAllocationRow] +catAllocation = performBHRequest $ Requests.catAllocation + +-- | 'catAllocationWith' is the fully-parameterised form of +-- 'catAllocation'. See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatAllocationOptions' +-- for the available parameters. +catAllocationWith :: + (MonadBH m) => + Maybe NodeName -> + CatAllocationOptions -> + m [CatAllocationRow] +catAllocationWith mNode opts = + performBHRequest $ Requests.catAllocationWith mNode opts + +-- | 'catCount' reports the document count for the whole cluster via +-- @GET /_cat\/count?format=json@. Equivalent to +-- @'catCountWith' 'Nothing' 'defaultCatCountOptions'@. +catCount :: (MonadBH m) => m [CatCountRow] +catCount = performBHRequest $ Requests.catCount + +-- | 'catCountWith' is the fully-parameterised form of 'catCount'. See +-- "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatCountOptions' +-- for the available parameters. +catCountWith :: + (MonadBH m) => + Maybe IndexName -> + CatCountOptions -> + m [CatCountRow] +catCountWith mIndex opts = + performBHRequest $ Requests.catCountWith mIndex opts + +-- | 'catMaster' reports the identity of the elected master node via +-- @GET /_cat\/master?format=json@. Equivalent to +-- @'catMasterWith' 'defaultCatMasterOptions'@. +catMaster :: (MonadBH m) => m [CatMasterRow] +catMaster = performBHRequest $ Requests.catMaster + +-- | 'catMasterWith' is the fully-parameterised form of 'catMaster'. See +-- "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatMasterOptions' +-- for the available parameters. +catMasterWith :: + (MonadBH m) => + CatMasterOptions -> + m [CatMasterRow] +catMasterWith opts = + performBHRequest $ Requests.catMasterWith opts + +-- | 'catHealth' reports a one-row-per-snapshot summary of cluster +-- health via @GET /_cat\/health?format=json@. Equivalent to +-- @'catHealthWith' 'defaultCatHealthOptions'@. +catHealth :: (MonadBH m) => m [CatHealthRow] +catHealth = performBHRequest $ Requests.catHealth + +-- | 'catHealthWith' is the fully-parameterised form of 'catHealth'. See +-- "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatHealthOptions' +-- for the available parameters. +catHealthWith :: + (MonadBH m) => + CatHealthOptions -> + m [CatHealthRow] +catHealthWith opts = + performBHRequest $ Requests.catHealthWith opts + +-- | 'catPendingTasks' lists the cluster-level tasks waiting to be +-- executed via @GET /_cat\/pending_tasks?format=json@. Equivalent to +-- @'catPendingTasksWith' 'defaultCatPendingTasksOptions'@. +catPendingTasks :: (MonadBH m) => m [CatPendingTasksRow] +catPendingTasks = performBHRequest $ Requests.catPendingTasks + +-- | 'catPendingTasksWith' is the fully-parameterised form of +-- 'catPendingTasks'. See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatPendingTasksOptions' +-- for the available parameters. +catPendingTasksWith :: + (MonadBH m) => + CatPendingTasksOptions -> + m [CatPendingTasksRow] +catPendingTasksWith opts = + performBHRequest $ Requests.catPendingTasksWith opts + +-- | 'catPlugins' lists the plugins installed on each node via +-- @GET /_cat\/plugins?format=json@. Equivalent to +-- @'catPluginsWith' 'defaultCatPluginsOptions'@. +catPlugins :: (MonadBH m) => m [CatPluginsRow] +catPlugins = performBHRequest $ Requests.catPlugins + +-- | 'catPluginsWith' is the fully-parameterised form of 'catPlugins'. +-- See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatPluginsOptions' +-- for the available parameters. +catPluginsWith :: + (MonadBH m) => + CatPluginsOptions -> + m [CatPluginsRow] +catPluginsWith opts = + performBHRequest $ Requests.catPluginsWith opts + +-- | 'catTemplates' lists the cluster's index templates via +-- @GET /_cat\/templates?format=json@. Equivalent to +-- @'catTemplatesWith' 'Nothing' 'defaultCatTemplatesOptions'@. +catTemplates :: (MonadBH m) => m [CatTemplatesRow] +catTemplates = performBHRequest $ Requests.catTemplates + +-- | 'catTemplatesWith' is the fully-parameterised form of 'catTemplates'. +-- See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatTemplatesOptions' +-- for the available parameters. +catTemplatesWith :: + (MonadBH m) => + Maybe TemplateName -> + CatTemplatesOptions -> + m [CatTemplatesRow] +catTemplatesWith mName opts = + performBHRequest $ Requests.catTemplatesWith mName opts + +-- | 'catThreadPool' lists the thread pools of each node via +-- @GET /_cat\/thread_pool?format=json@. Equivalent to +-- @'catThreadPoolWith' 'Nothing' 'defaultCatThreadPoolOptions'@. +catThreadPool :: (MonadBH m) => m [CatThreadPoolRow] +catThreadPool = performBHRequest $ Requests.catThreadPool + +-- | 'catThreadPoolWith' is the fully-parameterised form of +-- 'catThreadPool'. See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatThreadPoolOptions' +-- for the available parameters. +catThreadPoolWith :: + (MonadBH m) => + Maybe IndexName -> + CatThreadPoolOptions -> + m [CatThreadPoolRow] +catThreadPoolWith mPool opts = + performBHRequest $ Requests.catThreadPoolWith mPool opts + +-- | 'catFielddata' lists the amount of heap memory currently used by +-- the field data cache, per field per node, via +-- @GET /_cat\/fielddata?format=json@. Equivalent to +-- @'catFielddataWith' 'Nothing' 'defaultCatFielddataOptions'@. +catFielddata :: (MonadBH m) => m [CatFielddataRow] +catFielddata = performBHRequest $ Requests.catFielddata + +-- | 'catFielddataWith' is the fully-parameterised form of +-- 'catFielddata'. See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatFielddataOptions' +-- for the available parameters. +catFielddataWith :: + (MonadBH m) => + Maybe FieldName -> + CatFielddataOptions -> + m [CatFielddataRow] +catFielddataWith mField opts = + performBHRequest $ Requests.catFielddataWith mField opts + +-- | 'catNodeattrs' lists custom node attributes via +-- @GET /_cat\/nodeattrs?format=json@. Equivalent to +-- @'catNodeattrsWith' 'defaultCatNodeattrsOptions'@. +catNodeattrs :: (MonadBH m) => m [CatNodeattrsRow] +catNodeattrs = performBHRequest $ Requests.catNodeattrs + +-- | 'catNodeattrsWith' is the fully-parameterised form of +-- 'catNodeattrs'. See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatNodeattrsOptions' +-- for the available parameters. +catNodeattrsWith :: + (MonadBH m) => + CatNodeattrsOptions -> + m [CatNodeattrsRow] +catNodeattrsWith opts = + performBHRequest $ Requests.catNodeattrsWith opts + +-- | 'catRepositories' lists snapshot repositories registered on the +-- cluster via @GET /_cat\/repositories?format=json@. Equivalent to +-- @'catRepositoriesWith' 'defaultCatRepositoriesOptions'@. +catRepositories :: (MonadBH m) => m [CatRepositoriesRow] +catRepositories = performBHRequest $ Requests.catRepositories + +-- | 'catRepositoriesWith' is the fully-parameterised form of +-- 'catRepositories'. See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatRepositoriesOptions' +-- for the available parameters. +catRepositoriesWith :: + (MonadBH m) => + CatRepositoriesOptions -> + m [CatRepositoriesRow] +catRepositoriesWith opts = + performBHRequest $ Requests.catRepositoriesWith opts + +-- | 'catShards' lists the state of every primary and replica shard in +-- the cluster via @GET /_cat\/shards?format=json@. Equivalent to +-- @'catShardsWith' 'Nothing' 'defaultCatShardsOptions'@. +catShards :: (MonadBH m) => m [CatShardsRow] +catShards = performBHRequest $ Requests.catShards + +-- | 'catShardsWith' is the fully-parameterised form of 'catShards'. +-- See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatShardsOptions' +-- for the available parameters. +catShardsWith :: + (MonadBH m) => + Maybe IndexName -> + CatShardsOptions -> + m [CatShardsRow] +catShardsWith mIndex opts = + performBHRequest $ Requests.catShardsWith mIndex opts + +-- | 'catTasks' lists the tasks currently executing on the cluster via +-- @GET /_cat\/tasks?format=json@. Equivalent to +-- @'catTasksWith' 'defaultCatTasksOptions'@. +catTasks :: (MonadBH m) => m [CatTasksRow] +catTasks = performBHRequest $ Requests.catTasks + +-- | 'catTasksWith' is the fully-parameterised form of 'catTasks'. See +-- "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatTasksOptions' +-- for the available parameters. +catTasksWith :: + (MonadBH m) => + CatTasksOptions -> + m [CatTasksRow] +catTasksWith opts = + performBHRequest $ Requests.catTasksWith opts + +-- | 'catSnapshots' lists the snapshots stored in every snapshot +-- repository registered on the cluster via +-- @GET /_cat\/snapshots?format=json@. Equivalent to +-- @'catSnapshotsWith' 'Nothing' 'defaultCatSnapshotsOptions'@. +catSnapshots :: (MonadBH m) => m [CatSnapshotsRow] +catSnapshots = performBHRequest $ Requests.catSnapshots + +-- | 'catSnapshotsWith' is the fully-parameterised form of +-- 'catSnapshots'. See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatSnapshotsOptions' +-- for the available parameters. +catSnapshotsWith :: + (MonadBH m) => + Maybe SnapshotRepoName -> + CatSnapshotsOptions -> + m [CatSnapshotsRow] +catSnapshotsWith mRepo opts = + performBHRequest $ Requests.catSnapshotsWith mRepo opts + +-- | 'catNodes' lists the cluster topology — one row per node with its +-- identity, resource usage, and elected-master flag — via +-- @GET /_cat\/nodes?format=json@. Equivalent to +-- @'catNodesWith' 'defaultCatNodesOptions'@. +catNodes :: (MonadBH m) => m [CatNodesRow] +catNodes = performBHRequest $ Requests.catNodes + +-- | 'catNodesWith' is the fully-parameterised form of 'catNodes'. +-- See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatNodesOptions' +-- for the available parameters. +catNodesWith :: + (MonadBH m) => + CatNodesOptions -> + m [CatNodesRow] +catNodesWith opts = + performBHRequest $ Requests.catNodesWith opts + +-- | 'catSegments' lists the low-level Lucene segments of each shard of +-- each index via @GET /_cat\/segments?format=json@. Equivalent to +-- @'catSegmentsWith' 'Nothing' 'defaultCatSegmentsOptions'@. +catSegments :: (MonadBH m) => m [CatSegmentsRow] +catSegments = performBHRequest $ Requests.catSegments + +-- | 'catSegmentsWith' is the fully-parameterised form of 'catSegments'. +-- See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatSegmentsOptions' +-- for the available parameters. +catSegmentsWith :: + (MonadBH m) => + Maybe IndexName -> + CatSegmentsOptions -> + m [CatSegmentsRow] +catSegmentsWith mIndex opts = + performBHRequest $ Requests.catSegmentsWith mIndex opts + +-- | 'catRecovery' lists shard recovery progress for each shard of each +-- index via @GET /_cat\/recovery?format=json@. Equivalent to +-- @'catRecoveryWith' 'Nothing' 'defaultCatRecoveryOptions'@. +catRecovery :: (MonadBH m) => m [CatRecoveryRow] +catRecovery = performBHRequest $ Requests.catRecovery + +-- | 'catRecoveryWith' is the fully-parameterised form of 'catRecovery'. +-- See "Database.Bloodhound.Common.Requests" and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatRecoveryOptions' +-- for the available parameters. +catRecoveryWith :: + (MonadBH m) => + Maybe IndexName -> + CatRecoveryOptions -> + m [CatRecoveryRow] +catRecoveryWith mIndex opts = + performBHRequest $ Requests.catRecoveryWith mIndex opts + +-- | 'catComponentTemplates' lists the component templates. +-- See 'Database.Bloodhound.Common.Requests.catComponentTemplates' and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatComponentTemplatesRow'. +-- +-- @since 0.26.0.0 +catComponentTemplates :: (MonadBH m) => m [CatComponentTemplatesRow] +catComponentTemplates = performBHRequest $ Requests.catComponentTemplates + +-- | 'catComponentTemplatesWith' is the fully-parameterised form of +-- 'catComponentTemplates'. +-- +-- @since 0.26.0.0 +catComponentTemplatesWith :: + (MonadBH m) => + Maybe Text -> + CatComponentTemplatesOptions -> + m [CatComponentTemplatesRow] +catComponentTemplatesWith mName opts = + performBHRequest $ Requests.catComponentTemplatesWith mName opts + +-- | 'catCircuitBreakers' lists the JVM circuit breakers. +-- See 'Database.Bloodhound.Common.Requests.catCircuitBreakers' and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatCircuitBreakersRow'. +-- +-- @since 0.26.0.0 +catCircuitBreakers :: (MonadBH m) => m [CatCircuitBreakersRow] +catCircuitBreakers = performBHRequest $ Requests.catCircuitBreakers + +-- | 'catCircuitBreakersWith' is the fully-parameterised form of +-- 'catCircuitBreakers'. +-- +-- @since 0.26.0.0 +catCircuitBreakersWith :: + (MonadBH m) => + Maybe Text -> + CatCircuitBreakersOptions -> + m [CatCircuitBreakersRow] +catCircuitBreakersWith mPatterns opts = + performBHRequest $ Requests.catCircuitBreakersWith mPatterns opts + +-- | 'catMlJobs' lists the ML anomaly-detection jobs. +-- See 'Database.Bloodhound.Common.Requests.catMlJobs' and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatMlJobsRow'. +-- +-- @since 0.26.0.0 +catMlJobs :: (MonadBH m) => m [CatMlJobsRow] +catMlJobs = performBHRequest $ Requests.catMlJobs + +-- | 'catMlJobsWith' is the fully-parameterised form of 'catMlJobs'. +-- +-- @since 0.26.0.0 +catMlJobsWith :: + (MonadBH m) => + Maybe Text -> + CatMlJobsOptions -> + m [CatMlJobsRow] +catMlJobsWith mJobId opts = + performBHRequest $ Requests.catMlJobsWith mJobId opts + +-- | 'catMlDataFrameAnalytics' lists the ML data frame analytics jobs. +-- See 'Database.Bloodhound.Common.Requests.catMlDataFrameAnalytics' and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatMlDataFrameAnalyticsRow'. +-- +-- @since 0.26.0.0 +catMlDataFrameAnalytics :: (MonadBH m) => m [CatMlDataFrameAnalyticsRow] +catMlDataFrameAnalytics = + performBHRequest $ Requests.catMlDataFrameAnalytics + +-- | 'catMlDataFrameAnalyticsWith' is the fully-parameterised form of +-- 'catMlDataFrameAnalytics'. +-- +-- @since 0.26.0.0 +catMlDataFrameAnalyticsWith :: + (MonadBH m) => + Maybe Text -> + CatMlDataFrameAnalyticsOptions -> + m [CatMlDataFrameAnalyticsRow] +catMlDataFrameAnalyticsWith mId opts = + performBHRequest $ Requests.catMlDataFrameAnalyticsWith mId opts + +-- | 'catMlDatafeeds' lists the ML datafeeds. +-- See 'Database.Bloodhound.Common.Requests.catMlDatafeeds' and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatMlDatafeedsRow'. +-- +-- @since 0.26.0.0 +catMlDatafeeds :: (MonadBH m) => m [CatMlDatafeedsRow] +catMlDatafeeds = performBHRequest $ Requests.catMlDatafeeds + +-- | 'catMlDatafeedsWith' is the fully-parameterised form of +-- 'catMlDatafeeds'. +-- +-- @since 0.26.0.0 +catMlDatafeedsWith :: + (MonadBH m) => + Maybe Text -> + CatMlDatafeedsOptions -> + m [CatMlDatafeedsRow] +catMlDatafeedsWith mDatafeedId opts = + performBHRequest $ Requests.catMlDatafeedsWith mDatafeedId opts + +-- | 'catMlTrainedModels' lists the ML trained models. +-- See 'Database.Bloodhound.Common.Requests.catMlTrainedModels' and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatMlTrainedModelsRow'. +-- +-- @since 0.26.0.0 +catMlTrainedModels :: (MonadBH m) => m [CatMlTrainedModelsRow] +catMlTrainedModels = performBHRequest $ Requests.catMlTrainedModels + +-- | 'catMlTrainedModelsWith' is the fully-parameterised form of +-- 'catMlTrainedModels'. +-- +-- @since 0.26.0.0 +catMlTrainedModelsWith :: + (MonadBH m) => + Maybe Text -> + CatMlTrainedModelsOptions -> + m [CatMlTrainedModelsRow] +catMlTrainedModelsWith mModelId opts = + performBHRequest $ Requests.catMlTrainedModelsWith mModelId opts + +-- | 'catTransforms' lists the transforms. +-- See 'Database.Bloodhound.Common.Requests.catTransforms' and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cat.CatTransformsRow'. +-- +-- @since 0.26.0.0 +catTransforms :: (MonadBH m) => m [CatTransformsRow] +catTransforms = performBHRequest $ Requests.catTransforms + +-- | 'catTransformsWith' is the fully-parameterised form of 'catTransforms'. +-- +-- @since 0.26.0.0 +catTransformsWith :: + (MonadBH m) => + Maybe Text -> + CatTransformsOptions -> + m [CatTransformsRow] +catTransformsWith mTransformId opts = + performBHRequest $ Requests.catTransformsWith mTransformId opts + +-- | 'catHelp' fetches the @GET /_cat@ report, which lists the +-- available cat commands as plain text. See +-- 'Database.Bloodhound.Common.Requests.catHelp'. +-- +-- @since 0.26.0.0 +catHelp :: (MonadBH m) => m Text +catHelp = performBHRequest $ Requests.catHelp + +-- | 'addIndexBlock' applies an 'IndexBlock' to an index via +-- @PUT /\/_block/\@, returning 'Acknowledged' on +-- success. Useful for cluster maintenance: temporarily disabling +-- writes, reads, or metadata operations without closing the index. +-- +-- See 'Database.Bloodhound.Common.Requests.addIndexBlock' for the +-- underlying request builder, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +addIndexBlock :: (MonadBH m) => IndexName -> IndexBlock -> m Acknowledged +addIndexBlock indexName block = performBHRequest $ Requests.addIndexBlock indexName block + +-- | 'removeIndexBlock' releases an 'IndexBlock' from an index. +-- Counterpart to 'addIndexBlock'. Because the dedicated +-- @PUT /\/_block/\@ endpoint is add-only on every +-- supported backend (ES7+ and OS1+), the removal uses +-- @PUT /\/_settings@ with the matching @BlocksX False@ +-- 'UpdatableIndexSetting'. Surfaced as 'StatusDependant' so a 404 +-- for a missing index decodes as a structured 'EsError' (unlike +-- 'updateIndexSettings', which is 'StatusIndependant'). See +-- 'Database.Bloodhound.Common.Requests.removeIndexBlock' for details. +-- +-- @since 0.26.0.0 +removeIndexBlock :: (MonadBH m) => IndexName -> IndexBlock -> m Acknowledged +removeIndexBlock indexName block = performBHRequest $ Requests.removeIndexBlock indexName block + +-- | 'updateIndexAliases' updates the server's index alias +-- table. Operations are atomic. Explained in further detail at +-- +-- +-- >>> let src = IndexName "a-real-index" +-- >>> let aliasName = IndexName "an-alias" +-- >>> let iAlias = IndexAlias src (IndexAliasName aliasName) +-- >>> let aliasCreate = defaultIndexAliasCreate +-- >>> _ <- runBH' $ deleteIndex src +-- >>> isSuccess <$> runBH' (createIndex defaultIndexSettings src) +-- True +-- >>> runBH' $ indexExists src +-- True +-- >>> isSuccess <$> runBH' (updateIndexAliases (AddAlias iAlias aliasCreate :| [])) +-- True +-- >>> runBH' $ indexExists aliasName +-- True +updateIndexAliases :: (MonadBH m) => NonEmpty IndexAliasAction -> m Acknowledged +updateIndexAliases actions = performBHRequest $ Requests.updateIndexAliases actions + +-- | 'updateIndexAliasesWith' is the fully-parameterised form of +-- 'updateIndexAliases'. See "Database.Bloodhound.Common.Requests" for +-- the underlying builder and 'UpdateAliasesOptions' for the available +-- URI parameters. +updateIndexAliasesWith :: + (MonadBH m) => + UpdateAliasesOptions -> + NonEmpty IndexAliasAction -> + m Acknowledged +updateIndexAliasesWith opts actions = + performBHRequest $ Requests.updateIndexAliasesWith opts actions + +-- | Get all aliases configured on the server. +getIndexAliases :: (MonadBH m) => m IndexAliasesSummary +getIndexAliases = performBHRequest $ Requests.getIndexAliases + +-- | Get aliases for a single source index, optionally narrowed to one +-- alias name (@GET /{index}/_alias[\/{name}]@). See +-- "Database.Bloodhound.Common.Requests" for the underlying builder and +-- the wire-shape details. A missing index or named alias surfaces as +-- an 'EsError' (404); wrap with 'tryEsError' for a miss-tolerant +-- variant. +-- +-- >>> IndexAliasesInfo _ <- runBH' $ getIndexAlias (IndexName "my-index") (Just (AliasName (IndexName "my-alias"))) +getIndexAlias :: + (MonadBH m) => + IndexName -> + Maybe AliasName -> + m IndexAliasesInfo +getIndexAlias srcIndex mAlias = + performBHRequest $ Requests.getIndexAlias srcIndex mAlias + +-- | Delete a single alias name, removing it from /every/ index it is +-- currently associated with (the underlying request uses the @_all@ +-- wildcard). See 'deleteIndexAliasFrom' for a per-source-index variant. +deleteIndexAlias :: (MonadBH m) => IndexAliasName -> m Acknowledged +deleteIndexAlias indexAliasName = performBHRequest $ Requests.deleteIndexAlias indexAliasName + +-- | Remove an alias from a single source index, hitting +-- @DELETE /{index}/_alias/{name}@. Leaves any other index publishing +-- the same alias name untouched. +deleteIndexAliasFrom :: + (MonadBH m) => + IndexName -> + IndexAliasName -> + m Acknowledged +deleteIndexAliasFrom srcIndex aliasName = + performBHRequest $ Requests.deleteIndexAliasFrom srcIndex aliasName + +-- | Add an alias to a single index via @PUT /{index}/_alias/{name}@ — +-- the non-atomic, single-action variant of 'updateIndexAliases'. Pass +-- 'defaultIndexAliasCreate' for an empty body. Returns the server's +-- 'Acknowledged' flag. +-- +-- >>> _ <- runBH' $ createIndexAlias (IndexName "my-index") (IndexAliasName (IndexName "my-alias")) defaultIndexAliasCreate +createIndexAlias :: + (MonadBH m) => + IndexName -> + IndexAliasName -> + IndexAliasCreate -> + m Acknowledged +createIndexAlias srcIndex aliasName body = + performBHRequest $ Requests.createIndexAlias srcIndex aliasName body + +-- | Check whether an alias name exists anywhere in the cluster, hitting +-- @HEAD /_alias/{name}@. Returns 'False' when the alias is absent (404) +-- rather than throwing. +-- +-- >>> present <- runBH' $ aliasExists (IndexAliasName (IndexName "my-alias")) +aliasExists :: (MonadBH m) => IndexAliasName -> m Bool +aliasExists aliasName = performBHRequest $ Requests.aliasExists aliasName + +-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'. +-- Explained in further detail at +-- +-- +-- >>> let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping] +-- >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl") +putTemplate :: (MonadBH m) => IndexTemplate -> TemplateName -> m Acknowledged +putTemplate indexTemplate templateName = performBHRequest $ Requests.putTemplate indexTemplate templateName + +-- | 'templateExists' checks to see if a template exists. +-- +-- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl") +templateExists :: (MonadBH m) => TemplateName -> m Bool +templateExists templateName = performBHRequest $ Requests.templateExists templateName + +-- | 'getTemplate' fetches /legacy/ templates (the @GET /_template@ +-- endpoint). Read-side counterpart of 'putTemplate'. See +-- 'Database.Bloodhound.Common.Requests.getTemplate' for the wire +-- envelope details and the 'TemplateInfo' body shape. +-- +-- () +getTemplate :: (MonadBH m) => Maybe TemplateNamePattern -> m [TemplateInfo] +getTemplate = performBHRequest . Requests.getTemplate + +-- | 'deleteTemplate' is an HTTP DELETE and deletes a template. +-- +-- >>> let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping] +-- >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl") +-- >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl") +deleteTemplate :: (MonadBH m) => TemplateName -> m Acknowledged +deleteTemplate templateName = performBHRequest $ Requests.deleteTemplate templateName + +-- | 'putIndexTemplate' creates or updates a /composable/ index template +-- (the @PUT /_index_template/{name}@ endpoint, available since +-- Elasticsearch 7.8 and in OpenSearch 2.x). This is the modern +-- replacement for the legacy 'putTemplate' (which targets +-- @PUT /_template@): composable templates can be assembled from +-- reusable component templates and carry an explicit priority for +-- deterministic conflict resolution. +-- +-- Unlike the legacy 'putTemplate' this surfaces 4xx responses as +-- 'EsError's. To fail when a template with the given name already +-- exists, use 'putIndexTemplateWith' with @'ctoCreate' = 'Just' True@. +-- +-- () +putIndexTemplate :: (MonadBH m) => TemplateName -> ComposableTemplate -> m Acknowledged +putIndexTemplate templateName template = performBHRequest $ Requests.putIndexTemplate templateName template + +-- | Like 'putIndexTemplate' but additionally accepts +-- 'ComposableTemplateOptions' rendered as URI parameters. Use +-- 'defaultComposableTemplateOptions' to send no parameters at all. +putIndexTemplateWith :: (MonadBH m) => TemplateName -> ComposableTemplate -> ComposableTemplateOptions -> m Acknowledged +putIndexTemplateWith templateName template opts = performBHRequest $ Requests.putIndexTemplateWith templateName template opts + +-- | 'getIndexTemplate' fetches /composable/ index templates (the +-- @GET /_index_template@ endpoint). Read-side counterpart of +-- 'putIndexTemplate'. +-- +-- * @'Nothing'@ → list every composable template +-- on the cluster. +-- * @'Just' ('TemplateNamePattern' p)@ → list the templates whose +-- names match @p@ (a literal name or a glob such as @"logs-*"@; the +-- server does the matching). A pattern that matches no template +-- surfaces as an 'EsError' (HTTP 404); wrap with +-- 'tryPerformBHRequest' if you need miss-tolerant lookup. +-- +-- The body of each returned 'IndexTemplateInfo' is decoded into a +-- 'ComposableTemplate'. +-- +-- () +getIndexTemplate :: (MonadBH m) => Maybe TemplateNamePattern -> m [IndexTemplateInfo] +getIndexTemplate = performBHRequest . Requests.getIndexTemplate + +-- | 'deleteIndexTemplate' deletes a /composable/ index template +-- (@DELETE /_index_template/{name}@). It is the write-side counterpart +-- of 'putIndexTemplate'. Like 'getIndexTemplate', a @404@ for a missing +-- template is surfaced as an 'EsError'; wrap with +-- 'tryPerformBHRequest' for miss-tolerant deletion. +deleteIndexTemplate :: (MonadBH m) => TemplateName -> m Acknowledged +deleteIndexTemplate templateName = performBHRequest $ Requests.deleteIndexTemplate templateName + +-- | 'simulateIndexTemplate' resolves a hypothetical 'ComposableTemplate' +-- against the templates already registered on the cluster (the +-- @POST /_index_template/_simulate@ endpoint, available since +-- Elasticsearch 7.8 and in OpenSearch 2.x). The server returns the +-- merged @settings@\/@mappings@\/@aliases@ that would be applied to a +-- new matching index, plus the list of /existing/ composable templates +-- whose @index_patterns@ overlap the supplied template's patterns. +-- +-- Like 'putIndexTemplate', this surfaces 4xx responses as 'EsError's. +-- +-- () +simulateIndexTemplate :: (MonadBH m) => ComposableTemplate -> m SimulatedTemplate +simulateIndexTemplate = performBHRequest . Requests.simulateIndexTemplate + +-- | Like 'simulateIndexTemplate' but additionally accepts +-- 'ComposableTemplateOptions' rendered as URI parameters. Use +-- 'defaultComposableTemplateOptions' to send no parameters at all. +simulateIndexTemplateWith :: (MonadBH m) => ComposableTemplate -> ComposableTemplateOptions -> m SimulatedTemplate +simulateIndexTemplateWith template opts = performBHRequest $ Requests.simulateIndexTemplateWith template opts + +-- | 'simulateIndex' resolves the composable index template(s) that +-- Elasticsearch /would/ apply to a hypothetical new index with the given +-- name (@POST /_index_template/_simulate_index/{name}@, available since +-- Elasticsearch 7.8 and in OpenSearch 2.x). Returns the merged +-- @settings@\/@mappings@\/@aliases@ and any lower-priority templates that +-- also matched. Read-only — safe to call without side effects. +-- +-- This is the index-name-driven counterpart of 'simulateIndexTemplate' +-- (which takes a 'ComposableTemplate' body). +simulateIndex :: (MonadBH m) => IndexName -> m SimulatedTemplate +simulateIndex = performBHRequest . Requests.simulateIndex + +-- | Like 'simulateIndex' but additionally accepts 'ComposableTemplateOptions' +-- rendered as URI parameters. Use 'defaultComposableTemplateOptions' to +-- send no parameters at all, in which case the emitted request is +-- byte-for-byte identical to 'simulateIndex'. See 'simulateIndexWith' in +-- the Requests module for the wire-shape details. +simulateIndexWith :: (MonadBH m) => IndexName -> ComposableTemplateOptions -> m SimulatedTemplate +simulateIndexWith indexName opts = performBHRequest $ Requests.simulateIndexWith indexName opts + +-- | 'putComponentTemplate' creates or updates a reusable /component/ +-- template (@PUT /_component_template/{name}@, available since +-- Elasticsearch 7.8 and in OpenSearch 2.x). Component templates are +-- building blocks composed into composable index templates (see +-- 'ComposableTemplate'\'s @composed_of@ field); they have no +-- @index_patterns@ of their own. +-- +-- Like 'putIndexTemplate', this surfaces 4xx responses as 'EsError's. +-- +-- () +putComponentTemplate :: (MonadBH m) => TemplateName -> ComponentTemplate -> m Acknowledged +putComponentTemplate templateName template = performBHRequest $ Requests.putComponentTemplate templateName template + +-- | 'deleteComponentTemplate' deletes a reusable /component/ template +-- (@DELETE /_component_template/{name}@). It is the write-side counterpart +-- of 'putComponentTemplate'. Like 'deleteIndexTemplate', a @404@ for a +-- missing template is surfaced as an 'EsError'; wrap with +-- 'tryPerformBHRequest' for miss-tolerant deletion. +deleteComponentTemplate :: (MonadBH m) => TemplateName -> m Acknowledged +deleteComponentTemplate templateName = performBHRequest $ Requests.deleteComponentTemplate templateName + +-- | 'getComponentTemplate' fetches reusable /component/ templates (the +-- @GET /_component_template@ endpoint, available since Elasticsearch +-- 7.8 and in OpenSearch 2.x). Read-side counterpart of +-- 'putComponentTemplate'. See 'Requests.getComponentTemplate' for the +-- shape of the @Maybe TemplateNamePattern@ argument. +-- +-- Like 'getIndexTemplate', this is 'StatusDependant': a 4xx (in +-- particular a @404@ when no component template matches the pattern) +-- is surfaced as an 'EsError'. Callers that want miss-tolerant lookup +-- should use 'tryPerformBHRequest'. +-- +-- () +getComponentTemplate :: (MonadBH m) => Maybe TemplateNamePattern -> m [ComponentTemplateInfo] +getComponentTemplate = performBHRequest . Requests.getComponentTemplate + +-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas +-- for documents in indexes. +-- +-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex +-- >>> resp <- runBH' $ putMapping testIndex TweetMapping +-- >>> print resp +-- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("content-type","application/json; charset=UTF-8"),("content-encoding","gzip"),("transfer-encoding","chunked")], responseBody = "{\"acknowledged\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} +putMapping :: forall r a m. (MonadBH m, FromJSON r, ToJSON a) => IndexName -> a -> m r +putMapping indexName mapping = performBHRequest $ Requests.putMapping indexName mapping + +-- | 'putMappingWith' is the fully-parameterised form of 'putMapping'. +-- Every URI parameter accepted by @PUT /{index}/_mapping@ is exposed via +-- 'PutMappingOptions'. 'defaultPutMappingOptions' makes this +-- byte-for-byte identical to 'putMapping'. See 'Requests.putMappingWith' +-- for details. +putMappingWith :: + forall r a m. + (MonadBH m, FromJSON r, ToJSON a) => + IndexName -> + a -> + PutMappingOptions -> + m r +putMappingWith indexName mapping opts = + performBHRequest $ Requests.putMappingWith indexName mapping opts + +-- | 'getMapping' fetches the mapping for a given index. Wraps the +-- @GET \/\\/_mapping@ endpoint +-- (). +-- +-- The response is generic over any 'FromJSON' @r@, mirroring +-- 'putMapping'. Decode into a 'Value' for an untyped view of the mapping +-- (the response is shaped @{\: {mappings: {...}}}@), or into a +-- custom type. Use 'getIndex' to fetch aliases and settings alongside +-- the mappings in a single request. +getMapping :: forall r m. (MonadBH m, FromJSON r) => IndexName -> m r +getMapping indexName = performBHRequest $ Requests.getMapping indexName + +-- | 'getFieldMapping' fetches the mapping for specific fields of a given +-- index. Wraps the @GET \/\\/_mapping\/field\/\@ endpoint +-- (). +-- +-- The response is generic over any 'FromJSON' @r', mirroring 'getMapping'. +-- Decode into a 'Value' for an untyped view, or into +-- 'FieldMappingResponse' for a structured one. +getFieldMapping :: + forall r m. + (MonadBH m, FromJSON r) => + IndexName -> + [FieldName] -> + m r +getFieldMapping indexName fields = + performBHRequest $ Requests.getFieldMapping indexName fields + +-- | 'indexDocument' is the primary way to save a single document in +-- Elasticsearch. The document itself is simply something we can +-- convert into a JSON 'Value'. The 'DocId' will function as the +-- primary key for the document. You are encouraged to generate +-- your own id's and not rely on Elasticsearch's automatic id +-- generation. Read more about it here: +-- https://github.com/bitemyapp/bloodhound/issues/107 +-- +-- >>> resp <- runBH' $ indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1") +-- >>> print resp +-- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("content-type","application/json; charset=UTF-8"),("content-encoding","gzip"),("content-length","152")], responseBody = "{\"_index\":\"twitter\",\"_type\":\"_doc\",\"_id\":\"1\",\"_version\":2,\"result\":\"updated\",\"_shards\":{\"total\":1,\"successful\":1,\"failed\":0},\"_seq_no\":1,\"_primary_term\":1}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} +indexDocument :: + forall doc m. + (MonadBH m, ToJSON doc) => + IndexName -> + IndexDocumentSettings -> + doc -> + DocId -> + m Requests.IndexedDocument +indexDocument indexName cfg document docId = performBHRequest $ Requests.indexDocument indexName cfg document docId + +-- | 'updateDocument' provides a way to perform an partial update of a +-- an already indexed document. +updateDocument :: + forall patch m. + (MonadBH m, ToJSON patch) => + IndexName -> + IndexDocumentSettings -> + patch -> + DocId -> + m Requests.IndexedDocument +updateDocument indexName cfg patch docId = performBHRequest $ Requests.updateDocument indexName cfg patch docId + +-- | Like 'updateDocument' but accepts the full 'UpdateBody' union, +-- supporting script-driven updates, upserts, @doc_as_upsert@ and +-- @scripted_upsert@. The 'IndexDocumentSettings' argument still supplies +-- the URI-level parameters shared with the Index API. +updateDocumentWith :: + forall m. + (MonadBH m) => + IndexName -> + IndexDocumentSettings -> + UpdateBody -> + DocId -> + m Requests.IndexedDocument +updateDocumentWith indexName cfg body docId = performBHRequest $ Requests.updateDocumentWith indexName cfg body docId + +updateByQuery :: (MonadBH m, FromJSON a) => IndexName -> Query -> Maybe Script -> m a +updateByQuery indexName q mScript = performBHRequest $ Requests.updateByQuery indexName q mScript + +-- | Like 'updateByQuery' but accepts 'ByQueryOptions' for URI-level +-- parameters (@conflicts@, @wait_for_completion@, @slices@, @max_docs@, +-- @routing@, @scroll_size@, @refresh@, @timeout@, @scroll@, +-- @request_cache@, @pipeline@). +updateByQueryWith :: + forall a m. + (MonadBH m, FromJSON a) => + ByQueryOptions -> + IndexName -> + Query -> + Maybe Script -> + m a +updateByQueryWith opts indexName q mScript = performBHRequest $ Requests.updateByQueryWith opts indexName q mScript + +-- | 'rethrottleUpdateByQuery' changes the maximum documents-per-second +-- rate of an in-progress asynchronous @update_by_query@ task. Maps to +-- @POST /_update_by_query/{task_id}/_rethrottle?requests_per_second=@. +-- Returns a 'TaskListResponse' (same shape as 'cancelTask') listing +-- the task(s) whose rate was changed — an empty node list means the +-- task had already finished. Pass the 'TaskNodeId' returned by an +-- asynchronous 'updateByQueryWith' (called with +-- @bqoWaitForCompletion = Just False@). Use 'RethrottleUnlimited' to +-- disable throttling, or @'RethrottlePerSecond' n@ for any non-negative +-- decimal rate. +-- +-- See +-- . +rethrottleUpdateByQuery :: (MonadBH m) => TaskNodeId -> RethrottleRate -> m TaskListResponse +rethrottleUpdateByQuery tid = performBHRequest . Requests.rethrottleUpdateByQuery tid + +-- | 'deleteDocument' is the primary way to delete a single document. +-- +-- >>> _ <- runBH' $ deleteDocument testIndex (DocId "1") +deleteDocument :: (MonadBH m) => IndexName -> DocId -> m Requests.IndexedDocument +deleteDocument indexName docId = performBHRequest $ Requests.deleteDocument indexName docId + +-- | Like 'deleteDocument' but accepts 'DeleteDocumentOptions' for +-- URI-level parameters (@wait_for_active_shards@, @refresh@, +-- @routing@, @timeout@, @version@, @version_type@, @if_seq_no@, +-- @if_primary_term@). +deleteDocumentWith :: + (MonadBH m) => + DeleteDocumentOptions -> + IndexName -> + DocId -> + m Requests.IndexedDocument +deleteDocumentWith opts indexName docId = + performBHRequest $ Requests.deleteDocumentWith opts indexName docId + +-- | 'deleteByQuery' performs a deletion on every document that matches a query. +-- +-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing +-- >>> _ <- runBH' $ deleteByQuery testIndex query +deleteByQuery :: (MonadBH m, FromJSON a) => IndexName -> Query -> m a +deleteByQuery indexName query = performBHRequest $ Requests.deleteByQuery indexName query + +-- | Like 'deleteByQuery' but accepts 'ByQueryOptions' for URI-level +-- parameters (same set as 'updateByQueryWith'). The response type is +-- polymorphic: instantiate at 'TaskNodeId' when called with +-- @bqoWaitForCompletion = Just False@ to get the async task id. +deleteByQueryWith :: + forall a m. + (MonadBH m, FromJSON a) => + ByQueryOptions -> + IndexName -> + Query -> + m a +deleteByQueryWith opts indexName query = performBHRequest $ Requests.deleteByQueryWith opts indexName query + +-- | 'rethrottleDeleteByQuery' changes the maximum documents-per-second +-- rate of an in-progress asynchronous @delete_by_query@ task. Maps to +-- @POST /_delete_by_query/{task_id}/_rethrottle?requests_per_second=@. +-- Returns a 'TaskListResponse' (same shape as 'cancelTask') listing +-- the task(s) whose rate was changed — an empty node list means the +-- task had already finished. Pass the 'TaskNodeId' returned by an +-- asynchronous 'deleteByQueryWith' (called with +-- @bqoWaitForCompletion = Just False@). Use 'RethrottleUnlimited' to +-- disable throttling, or @'RethrottlePerSecond' n@ for any non-negative +-- decimal rate. +-- +-- See +-- . +rethrottleDeleteByQuery :: (MonadBH m) => TaskNodeId -> RethrottleRate -> m TaskListResponse +rethrottleDeleteByQuery tid = performBHRequest . Requests.rethrottleDeleteByQuery tid + +-- | 'bulk' uses +-- +-- to perform bulk operations. The 'BulkOperation' data type encodes the +-- index\/update\/delete\/create operations. You pass a 'V.Vector' of 'BulkOperation's +-- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch +-- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead. +-- +-- Uses 'defaultBulkSettings' (no URI parameters). For control over the +-- @refresh@, @routing@, @pipeline@, @wait_for_active_shards@, etc. +-- parameters, use 'bulkWith'. +-- +-- >>> let stream = V.fromList [BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah")) []] +-- >>> _ <- runBH' $ bulk stream +-- >>> _ <- runBH' $ refreshIndex testIndex +bulk :: + forall m. + (MonadBH m) => + V.Vector BulkOperation -> + m BulkResponse +bulk ops = performBHRequest $ Requests.bulk @StatusDependant ops + +-- | Like 'bulk' but accepts a 'BulkSettings' record carrying the URI-level +-- parameters of the @POST /_bulk@ endpoint. 'defaultBulkSettings' makes +-- this byte-for-byte equivalent to 'bulk'. +bulkWith :: + forall m. + (MonadBH m) => + BulkSettings -> + V.Vector BulkOperation -> + m BulkResponse +bulkWith opts ops = performBHRequest $ Requests.bulkWith @StatusDependant opts ops + +-- | 'getDocument' is a straight-forward way to fetch a single document from +-- Elasticsearch using a 'Server', 'IndexName', and a 'DocId'. +-- The 'DocId' is the primary key for your Elasticsearch document. +-- +-- >>> yourDoc <- runBH' $ getDocument testIndex (DocId "1") +getDocument :: (MonadBH m, FromJSON a) => IndexName -> DocId -> m (EsResult a) +getDocument indexName docId = performBHRequest $ Requests.getDocument indexName docId + +-- | Like 'getDocument' but accepts 'GetDocumentOptions' for URI-level +-- parameters (@_source@, @_source_includes@\/@_source_excludes@, +-- @stored_fields@, @preference@, @realtime@, @refresh@, @routing@, +-- @version@, @version_type@). +getDocumentWith :: + forall a m. + (MonadBH m, FromJSON a) => + GetDocumentOptions -> + IndexName -> + DocId -> + m (EsResult a) +getDocumentWith opts indexName docId = performBHRequest $ Requests.getDocumentWith opts indexName docId + +-- | 'getDocumentSource' fetches only the @_source@ of a document (no +-- metadata envelope). Maps to +-- @GET \/{index}\/_doc\/{id}\/_source@. Returns 'Nothing' when the +-- document does not exist (HTTP 404); other non-2xx responses throw +-- 'EsError' (use +-- 'Database.Bloodhound.Client.Cluster.tryPerformBHRequest' to +-- surface them as @'Either' 'EsError' ('Maybe' a)@ instead). +getDocumentSource :: + forall a m. + (MonadBH m, FromJSON a) => + IndexName -> + DocId -> + m (Maybe a) +getDocumentSource indexName docId = performBHRequest $ Requests.getDocumentSource indexName docId + +-- | Like 'getDocumentSource' but accepts 'GetDocumentSourceOptions' +-- carrying the source-filtering and routing parameters that apply to +-- the source-only endpoint. +getDocumentSourceWith :: + forall a m. + (MonadBH m, FromJSON a) => + GetDocumentSourceOptions -> + IndexName -> + DocId -> + m (Maybe a) +getDocumentSourceWith opts indexName docId = performBHRequest $ Requests.getDocumentSourceWith opts indexName docId + +getDocuments :: + (MonadBH m, FromJSON a) => + IndexName -> + [DocId] -> + m (MultiGetResponse a) +getDocuments indexName docIds = performBHRequest $ Requests.getDocuments indexName docIds + +-- | Like 'getDocuments' but accepts 'MultiGetOptions' applied at the +-- URI level. +getDocumentsWith :: + forall a m. + (MonadBH m, FromJSON a) => + MultiGetOptions -> + IndexName -> + [DocId] -> + m (MultiGetResponse a) +getDocumentsWith opts indexName docIds = performBHRequest $ Requests.getDocumentsWith opts indexName docIds + +getDocumentsMulti :: + (MonadBH m, FromJSON a) => + MultiGet -> + m (MultiGetResponse a) +getDocumentsMulti body = performBHRequest $ Requests.getDocumentsMulti body + +-- | Like 'getDocumentsMulti' but accepts 'MultiGetOptions' applied at +-- the URI level. Per-document filtering is carried by the 'MultiGet' body. +getDocumentsMultiWith :: + forall a m. + (MonadBH m, FromJSON a) => + MultiGetOptions -> + MultiGet -> + m (MultiGetResponse a) +getDocumentsMultiWith opts body = performBHRequest $ Requests.getDocumentsMultiWith opts body + +-- | 'getTermVectors' returns information and statistics about the +-- terms in the fields of a particular document. Maps to +-- @POST \/{index}\/_termvectors\/{id}@. Pass +-- 'defaultTermVectorsRequest' to reproduce the parameterless form; +-- populate 'TermVectorsRequest' fields to request @fields@, +-- @offsets@, @positions@, @term_statistics@, @field_statistics@, +-- @payload@, or apply a 'TermVectorsFilter'. +getTermVectors :: + (MonadBH m) => + IndexName -> + DocId -> + TermVectorsRequest -> + m TermVectors +getTermVectors indexName docId body = performBHRequest $ Requests.getTermVectors indexName docId body + +-- | Like 'getTermVectors' but accepts 'TermVectorsOptions' carrying +-- the URI-level parameters (@preference@, @realtime@, @routing@, +-- @version@, @version_type@). 'defaultTermVectorsOptions' makes the +-- wire output byte-identical to 'getTermVectors'. +getTermVectorsWith :: + (MonadBH m) => + TermVectorsOptions -> + IndexName -> + DocId -> + TermVectorsRequest -> + m TermVectors +getTermVectorsWith opts indexName docId body = + performBHRequest $ Requests.getTermVectorsWith opts indexName docId body + +-- | 'getMultiTermVectors' returns term vectors for multiple documents +-- in a single request. Maps to @POST \/_mtermvectors@ (no index in +-- the URL). Each 'MultiTermVectorsDoc' must carry its own @_index@. +-- For the single-index form, see 'getMultiTermVectorsByIndex'. +getMultiTermVectors :: + (MonadBH m) => + MultiTermVectors -> + m MultiTermVectorsResponse +getMultiTermVectors body = performBHRequest $ Requests.getMultiTermVectors body + +-- | Like 'getMultiTermVectors' but accepts 'TermVectorsOptions' +-- carrying the URI-level parameters (@preference@, @realtime@, +-- @routing@, @version@, @version_type@). 'defaultTermVectorsOptions' +-- makes the wire output byte-identical to 'getMultiTermVectors'. +getMultiTermVectorsWith :: + (MonadBH m) => + TermVectorsOptions -> + MultiTermVectors -> + m MultiTermVectorsResponse +getMultiTermVectorsWith opts body = + performBHRequest $ Requests.getMultiTermVectorsWith opts body + +-- | 'getMultiTermVectorsByIndex' is the single-index form of +-- 'getMultiTermVectors'. Maps to +-- @POST \/{index}\/_mtermvectors@. Each 'DocId' is wrapped with +-- 'mkMultiTermVectorsDoc' (no per-doc @_index@, no parameter +-- overrides); for per-document overrides, build the +-- 'MultiTermVectors' body directly and use 'getMultiTermVectors'. +getMultiTermVectorsByIndex :: + (MonadBH m) => + IndexName -> + [DocId] -> + m MultiTermVectorsResponse +getMultiTermVectorsByIndex indexName docIds = + performBHRequest $ Requests.getMultiTermVectorsByIndex indexName docIds + +-- | Like 'getMultiTermVectorsByIndex' but accepts 'TermVectorsOptions' +-- carrying the URI-level parameters (@preference@, @realtime@, +-- @routing@, @version@, @version_type@). 'defaultTermVectorsOptions' +-- makes the wire output byte-identical to 'getMultiTermVectorsByIndex'. +getMultiTermVectorsByIndexWith :: + (MonadBH m) => + TermVectorsOptions -> + IndexName -> + [DocId] -> + m MultiTermVectorsResponse +getMultiTermVectorsByIndexWith opts indexName docIds = + performBHRequest $ Requests.getMultiTermVectorsByIndexWith opts indexName docIds + +documentExists :: (MonadBH m) => IndexName -> DocId -> m Bool +documentExists indexName docId = performBHRequest $ Requests.documentExists indexName docId + +-- | Like 'documentExists' but accepts 'DocumentExistsOptions' for the +-- URI-level parameters (@stored_fields@, @preference@, @realtime@, +-- @refresh@, @routing@, @version@, @version_type@). See +-- 'Requests.documentExistsWith' for the wire-level details. +documentExistsWith :: + (MonadBH m) => + DocumentExistsOptions -> + IndexName -> + DocId -> + m Bool +documentExistsWith opts indexName docId = + performBHRequest $ Requests.documentExistsWith opts indexName docId + +-- | 'documentSourceExists' checks whether @_source@ is present for the +-- given document, hitting @HEAD \/{index}\/_doc\/{id}\/_source@. +-- Returns 'False' on any non-2xx status (including 404); see +-- 'Requests.documentSourceExists' for the wire-level details. +documentSourceExists :: (MonadBH m) => IndexName -> DocId -> m Bool +documentSourceExists indexName docId = + performBHRequest $ Requests.documentSourceExists indexName docId + +-- | Like 'documentSourceExists' but accepts +-- 'DocumentSourceExistsOptions' for the URI-level parameters +-- (@preference@, @realtime@, @refresh@, @routing@, @version@, +-- @version_type@). See 'Requests.documentSourceExistsWith' for the +-- wire-level details. +documentSourceExistsWith :: + (MonadBH m) => + DocumentSourceExistsOptions -> + IndexName -> + DocId -> + m Bool +documentSourceExistsWith opts indexName docId = + performBHRequest $ Requests.documentSourceExistsWith opts indexName docId + +-- | 'searchAll', given a 'Search', will perform that search against all indexes +-- on an Elasticsearch server. Try to avoid doing this if it can be helped. +-- +-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing +-- >>> let search = mkSearch (Just query) Nothing +-- >>> response <- runBH' $ searchAll search +searchAll :: forall a m. (MonadBH m, FromJSON a) => Search -> m (SearchResult a) +searchAll search = performBHRequest $ Requests.searchAll search + +-- | 'searchAllWith' is a variant of 'searchAll' that accepts a +-- 'SearchOptions' record for URI-level parameters such as @preference@, +-- @routing@, and @request_cache@. See 'SearchOptions' for the full set. +searchAllWith :: + forall a m. + (MonadBH m, FromJSON a) => + SearchOptions -> + Search -> + m (SearchResult a) +searchAllWith opts search = performBHRequest $ Requests.searchAllWith opts search + +-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search +-- within an index on an Elasticsearch server. +-- +-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing +-- >>> let search = mkSearch (Just query) Nothing +-- >>> response <- runBH' $ searchByIndex testIndex search +searchByIndex :: forall a m. (MonadBH m, FromJSON a) => IndexName -> Search -> m (SearchResult a) +searchByIndex indexName search = performBHRequest $ Requests.searchByIndex indexName search + +-- | 'searchByIndexWith' is a variant of 'searchByIndex' that accepts a +-- 'SearchOptions' record for URI-level parameters such as @preference@, +-- @routing@, and @request_cache@. See 'SearchOptions' for the full set. +-- +-- >>> let opts = defaultSearchOptions { soPreference = Just "_local", soRequestCache = Just True } +-- >>> response <- runBH' $ searchByIndexWith testIndex opts search +searchByIndexWith :: + forall a m. + (MonadBH m, FromJSON a) => + IndexName -> + SearchOptions -> + Search -> + m (SearchResult a) +searchByIndexWith indexName opts search = performBHRequest $ Requests.searchByIndexWith indexName opts search + +-- | 'searchByIndices' is a variant of 'searchByIndex' that executes a +-- 'Search' over many indices. This is much faster than using +-- 'mapM' to 'searchByIndex' over a collection since it only +-- causes a single HTTP request to be emitted. +searchByIndices :: forall a m. (MonadBH m, FromJSON a) => NonEmpty IndexName -> Search -> m (SearchResult a) +searchByIndices ixs search = performBHRequest $ Requests.searchByIndices ixs search + +-- | 'searchByIndicesWith' is a variant of 'searchByIndices' that accepts a +-- 'SearchOptions' record for URI-level parameters. See 'SearchOptions' for +-- the full set. +searchByIndicesWith :: + forall a m. + (MonadBH m, FromJSON a) => + NonEmpty IndexName -> + SearchOptions -> + Search -> + m (SearchResult a) +searchByIndicesWith ixs opts search = performBHRequest $ Requests.searchByIndicesWith ixs opts search + +-- | 'explainDocument' computes a score explanation for a single +-- document under a given 'Query' (see +-- , +-- ). +-- +-- See 'Requests.explainDocument' for the full semantics, in +-- particular the three distinguishable outcomes: matched; doc exists +-- but query does not match (explanation is @Just (Explanation 0.0 +-- ...)@); and missing document (explanation is 'Nothing'). A missing +-- document /does not/ surface as an 'EsError' — its HTTP-404 body is +-- shaped like an 'ExplainResponse' and decodes cleanly as +-- @ExplainResponse { explainResponseMatched = False, explainResponseExplanation = Nothing }@. +explainDocument :: + forall m. + (MonadBH m) => + IndexName -> + DocId -> + Query -> + m ExplainResponse +explainDocument indexName docId query = + performBHRequest $ Requests.explainDocument indexName docId query + +-- | Like 'explainDocument' but accepts an 'ExplainOptions' record +-- carrying the URI-level @_explain@ parameters (@routing@, +-- @preference@, @stored_fields@, @_source@ filtering, and the +-- query-parsing @default_operator@\/@analyzer@\/@df@\/ +-- @analyze_wildcard@\/@lenient@). 'defaultExplainOptions' makes this +-- byte-for-byte equivalent to 'explainDocument'. See +-- 'Requests.explainDocumentWith' for the full semantics. +explainDocumentWith :: + forall m. + (MonadBH m) => + ExplainOptions -> + IndexName -> + DocId -> + Query -> + m ExplainResponse +explainDocumentWith opts indexName docId query = + performBHRequest $ Requests.explainDocumentWith opts indexName docId query + +multiSearch :: + forall a m. + (MonadBH m, FromJSON a) => + NonEmpty MultiSearchItem -> + m (MultiSearchResponse a) +multiSearch items = performBHRequest $ Requests.multiSearch items + +-- | 'multiSearchWith' is a variant of 'multiSearch' that accepts a +-- 'SearchOptions' record for URI-level parameters +-- (@max_concurrent_searches@, @typed_keys@, ...). Per-header fields ride +-- on each 'MultiSearchItem'. +multiSearchWith :: + forall a m. + (MonadBH m, FromJSON a) => + SearchOptions -> + NonEmpty MultiSearchItem -> + m (MultiSearchResponse a) +multiSearchWith opts items = performBHRequest $ Requests.multiSearchWith opts items + +multiSearchByIndex :: + forall a m. + (MonadBH m, FromJSON a) => + IndexName -> + NonEmpty Search -> + m (MultiSearchResponse a) +multiSearchByIndex indexName searches = performBHRequest $ Requests.multiSearchByIndex indexName searches + +-- | 'multiSearchByIndexWith' is a variant of 'multiSearchByIndex' that +-- accepts a 'SearchOptions' record. +multiSearchByIndexWith :: + forall a m. + (MonadBH m, FromJSON a) => + SearchOptions -> + IndexName -> + NonEmpty Search -> + m (MultiSearchResponse a) +multiSearchByIndexWith opts indexName searches = + performBHRequest $ Requests.multiSearchByIndexWith opts indexName searches + +-- | 'multiSearchTemplate' performs a multi-search template request +-- against @_msearch/template@. Each 'MultiSearchTemplateItem' pairs a +-- per-sub-request header with a 'SearchTemplate' body. See +-- 'Database.Bloodhound.Common.Requests.multiSearchTemplate'. +multiSearchTemplate :: + forall a m. + (MonadBH m, FromJSON a) => + NonEmpty MultiSearchTemplateItem -> + m (MultiSearchResponse a) +multiSearchTemplate items = performBHRequest $ Requests.multiSearchTemplate items + +-- | 'multiSearchTemplateWith' is a variant of 'multiSearchTemplate' that +-- accepts a 'SearchOptions' record. +multiSearchTemplateWith :: + forall a m. + (MonadBH m, FromJSON a) => + SearchOptions -> + NonEmpty MultiSearchTemplateItem -> + m (MultiSearchResponse a) +multiSearchTemplateWith opts items = + performBHRequest $ Requests.multiSearchTemplateWith opts items + +-- | 'multiSearchTemplateByIndex' runs an @_msearch/template@ scoped to a +-- single index. +multiSearchTemplateByIndex :: + forall a m. + (MonadBH m, FromJSON a) => + IndexName -> + NonEmpty SearchTemplate -> + m (MultiSearchResponse a) +multiSearchTemplateByIndex indexName templates = + performBHRequest $ Requests.multiSearchTemplateByIndex indexName templates + +-- | 'multiSearchTemplateByIndexWith' is a variant of +-- 'multiSearchTemplateByIndex' that accepts a 'SearchOptions' record. +multiSearchTemplateByIndexWith :: + forall a m. + (MonadBH m, FromJSON a) => + SearchOptions -> + IndexName -> + NonEmpty SearchTemplate -> + m (MultiSearchResponse a) +multiSearchTemplateByIndexWith opts indexName templates = + performBHRequest $ Requests.multiSearchTemplateByIndexWith opts indexName templates + +searchByIndexTemplate :: + forall a m. + (MonadBH m, FromJSON a) => + IndexName -> + SearchTemplate -> + m (SearchResult a) +searchByIndexTemplate indexName search = performBHRequest $ Requests.searchByIndexTemplate indexName search + +-- | 'searchByIndicesTemplate' is a variant of 'searchByIndexTemplate' that executes a +-- 'SearchTemplate' over many indices. This is much faster than using +-- 'mapM' to 'searchByIndexTemplate' over a collection since it only +-- causes a single HTTP request to be emitted. +searchByIndicesTemplate :: + forall a m. + (MonadBH m, FromJSON a) => + NonEmpty IndexName -> + SearchTemplate -> + m (SearchResult a) +searchByIndicesTemplate ixs search = performBHRequest $ Requests.searchByIndicesTemplate ixs search + +-- | 'storeSearchTemplate', saves a 'SearchTemplateSource' to be used later. +storeSearchTemplate :: (MonadBH m) => SearchTemplateId -> SearchTemplateSource -> m Acknowledged +storeSearchTemplate tid ts = performBHRequest $ Requests.storeSearchTemplate tid ts + +-- | 'getSearchTemplate', get info of an stored 'SearchTemplateSource'. +getSearchTemplate :: (MonadBH m) => SearchTemplateId -> m GetTemplateScript +getSearchTemplate tid = performBHRequest $ Requests.getSearchTemplate tid + +-- | 'storeSearchTemplate', +deleteSearchTemplate :: (MonadBH m) => SearchTemplateId -> m Acknowledged +deleteSearchTemplate tid = performBHRequest $ Requests.deleteSearchTemplate tid + +-- | 'renderTemplate' renders a 'SearchTemplate' as a search request +-- body without executing the search. See +-- 'Database.Bloodhound.Common.Requests.renderTemplate' for the +-- endpoint shape (GET-with-body, path derived from the +-- 'searchTemplate' field) and the raw-'Value' return contract. +renderTemplate :: (MonadBH m) => SearchTemplate -> m (ParsedEsResponse Value) +renderTemplate = performBHRequest . Requests.renderTemplate + +-- | For a given search, request a scroll for efficient streaming of +-- search results. Note that the search is put into 'SearchTypeScan' +-- mode and thus results will not be sorted. Combine this with +-- 'advanceScroll' to efficiently stream through the full result set +getInitialScroll :: + forall a m. + (MonadBH m, FromJSON a) => + IndexName -> + Search -> + m (ParsedEsResponse (SearchResult a)) +getInitialScroll indexName search' = performBHRequest $ Requests.getInitialScroll indexName search' + +-- | For a given search, request a scroll for efficient streaming of +-- search results. Combine this with 'advanceScroll' to efficiently +-- stream through the full result set. Note that this search respects +-- sorting and may be less efficient than 'getInitialScroll'. +getInitialSortedScroll :: + forall a m. + (MonadBH m, FromJSON a) => + IndexName -> + Search -> + m (SearchResult a) +getInitialSortedScroll indexName search = performBHRequest $ Requests.getInitialSortedScroll indexName search + +-- | Use the given scroll to fetch the next page of documents. If there are no +-- further pages, 'SearchResult.searchHits.hits' will be '[]'. +-- +-- Equivalent to @'advanceScrollWith' 'defaultAdvanceScrollOptions'@. Use +-- the @With@ variant to send @?rest_total_hits_as_int=true@. +advanceScroll :: + forall a m. + (MonadBH m, FromJSON a) => + ScrollId -> + -- | How long should the snapshot of data be kept around? This timeout is updated every time 'advanceScroll' is used, so don't feel the need to set it to the entire duration of your search processing. Note that durations < 1s will be rounded up. Also note that 'NominalDiffTime' is an instance of Num so literals like 60 will be interpreted as seconds. 60s is a reasonable default. + NominalDiffTime -> + m (SearchResult a) +advanceScroll sid scroll = performBHRequest $ Requests.advanceScroll sid scroll + +-- | Like 'advanceScroll' but accepts an 'AdvanceScrollOptions' record +-- carrying URI-level parameters for @POST /_search/scroll@ (currently +-- only @rest_total_hits_as_int@). +-- +-- @'advanceScrollWith' 'defaultAdvanceScrollOptions'@ is byte-for-byte +-- identical to 'advanceScroll'. +advanceScrollWith :: + forall a m. + (MonadBH m, FromJSON a) => + AdvanceScrollOptions -> + ScrollId -> + -- | How long should the snapshot of data be kept around? See + -- 'advanceScroll' for details. + NominalDiffTime -> + m (SearchResult a) +advanceScrollWith opts sid scroll = + performBHRequest $ Requests.advanceScrollWith opts sid scroll + +-- | Release a scroll context immediately rather than waiting for its +-- @keep_alive@ to expire. Use this after finishing (or abandoning) a +-- scan-scroll stream so the server can free the associated snapshot before +-- the @search.max_open_scroll_context@ limit is reached. +clearScroll :: (MonadBH m) => ScrollId -> m ClearScrollResponse +clearScroll sid = performBHRequest $ Requests.clearScroll sid + +-- | 'scanSearch' uses the 'scroll' API of elastic, +-- for a given 'IndexName'. Note that this will +-- consume the entire search result set and will be doing O(n) list +-- appends so this may not be suitable for large result sets. In that +-- case, 'getInitialScroll' and 'advanceScroll' are good low level +-- tools. You should be able to hook them up trivially to conduit, +-- pipes, or your favorite streaming IO abstraction of choice. Note +-- that ordering on the search would destroy performance and thus is +-- ignored. +scanSearch :: forall a m. (FromJSON a, MonadBH m) => IndexName -> Search -> m [Hit a] +scanSearch indexName search = do + initialSearchResult <- getInitialScroll indexName search + let (hits', josh) = case initialSearchResult of + Right SearchResult {..} -> (hits searchHits, scrollId) + Left _ -> ([], Nothing) + (totalHits, _) <- scanAccumulator [] (hits', josh) + return totalHits + where + scanAccumulator :: [Hit a] -> ([Hit a], Maybe ScrollId) -> m ([Hit a], Maybe ScrollId) + scanAccumulator oldHits (newHits, Nothing) = return (oldHits ++ newHits, Nothing) + scanAccumulator oldHits ([], _) = return (oldHits, Nothing) + scanAccumulator oldHits (newHits, msid) = do + (newHits', msid') <- scroll' msid + scanAccumulator (oldHits ++ newHits) (newHits', msid') + + scroll' :: Maybe ScrollId -> m ([Hit a], Maybe ScrollId) + scroll' Nothing = return ([], Nothing) + scroll' (Just sid) = do + res <- tryPerformBHRequest $ Requests.advanceScroll sid 60 + case res of + Right SearchResult {..} -> return (hits searchHits, scrollId) + Left _ -> return ([], Nothing) + +-- | This is a hook that can be set via the 'bhRequestHook' function +-- that will authenticate all requests using an HTTP Basic +-- Authentication header. Note that it is *strongly* recommended that +-- this option only be used over an SSL connection. +-- +-- >> (mkBHEnv myServer myManager) { bhRequestHook = basicAuthHook (EsUsername "myuser") (EsPassword "mypass") } +basicAuthHook :: (Monad m) => EsUsername -> EsPassword -> Request -> m Request +basicAuthHook (EsUsername u) (EsPassword p) = return . applyBasicAuth u' p' + where + u' = T.encodeUtf8 u + p' = T.encodeUtf8 p + +countByIndex :: (MonadBH m) => IndexName -> CountQuery -> m CountResponse +countByIndex indexName q = performBHRequest $ Requests.countByIndex indexName q + +-- | 'countByIndexWith' is the 'MonadBH' runner for +-- 'Database.Bloodhound.Common.Requests.countByIndexWith'. See that +-- function for the request-shape details. +countByIndexWith :: + (MonadBH m) => + Maybe [IndexName] -> + CountOptions -> + CountQuery -> + m CountResponse +countByIndexWith mIndices opts q = + performBHRequest $ Requests.countByIndexWith mIndices opts q + +-- | 'countAll' is the 'MonadBH' runner for +-- 'Database.Bloodhound.Common.Requests.countAll'. +countAll :: (MonadBH m) => CountQuery -> m CountResponse +countAll q = performBHRequest $ Requests.countAll q + +-- | 'validateQuery' is the 'MonadBH' runner for +-- 'Database.Bloodhound.Common.Requests.validateQuery'. See that +-- function for the request-shape details. +validateQuery :: + (MonadBH m) => + IndexName -> + ValidateQuery -> + m ValidateQueryResponse +validateQuery indexName q = + performBHRequest $ Requests.validateQuery indexName q + +-- | 'validateQueryWith' is the 'MonadBH' runner for +-- 'Database.Bloodhound.Common.Requests.validateQueryWith'. See that +-- function for the request-shape details. +validateQueryWith :: + (MonadBH m) => + Maybe [IndexName] -> + ValidateOptions -> + ValidateQuery -> + m ValidateQueryResponse +validateQueryWith mIndices opts q = + performBHRequest $ Requests.validateQueryWith mIndices opts q + +-- | 'validateAll' is the 'MonadBH' runner for +-- 'Database.Bloodhound.Common.Requests.validateAll'. +validateAll :: + (MonadBH m) => + ValidateQuery -> + m ValidateQueryResponse +validateAll q = performBHRequest $ Requests.validateAll q + +-- | 'evaluateRank' is the 'MonadBH' runner for +-- 'Database.Bloodhound.Common.Requests.evaluateRank'. See that +-- function for the request-shape details. +evaluateRank :: (MonadBH m) => RankEvalRequest -> m RankEvalResponse +evaluateRank = performBHRequest . Requests.evaluateRank + +-- | 'evaluateRankByIndex' is the 'MonadBH' runner for +-- 'Database.Bloodhound.Common.Requests.evaluateRankByIndex'. +evaluateRankByIndex :: + (MonadBH m) => IndexName -> RankEvalRequest -> m RankEvalResponse +evaluateRankByIndex indexName = + performBHRequest . Requests.evaluateRankByIndex indexName + +-- | 'evaluateRankWith' is the 'MonadBH' runner for +-- 'Database.Bloodhound.Common.Requests.evaluateRankWith'. +evaluateRankWith :: + (MonadBH m) => + Maybe [IndexName] -> + RankEvalOptions -> + RankEvalRequest -> + m RankEvalResponse +evaluateRankWith mIndices opts body = + performBHRequest $ Requests.evaluateRankWith mIndices opts body + +-- | 'analyzeText' runs the analysis pipeline on the supplied text +-- without indexing it. Pass 'Nothing' to call @POST /_analyze@ with +-- only built-in or named analyzers, or @'Just' index@ to call +-- @POST \/{index}\/_analyze@ and reference analyzers configured on +-- that index. See "Database.Bloodhound.Common.Requests#analyzeText" +-- for the request-shape details and the supported subset of the API. +analyzeText :: (MonadBH m) => Maybe IndexName -> AnalyzeRequest -> m AnalyzeResponse +analyzeText mIndex req = performBHRequest $ Requests.analyzeText mIndex req + +getFieldCaps :: (MonadBH m) => Maybe [IndexName] -> [FieldPattern] -> m FieldCapsResponse +getFieldCaps mIndices fields = performBHRequest $ Requests.getFieldCaps mIndices fields + +getFieldCapsWith :: + (MonadBH m) => + Maybe [IndexName] -> + FieldCapsOptions -> + FieldCapsRequest -> + m FieldCapsResponse +getFieldCapsWith mIndices opts req = + performBHRequest $ Requests.getFieldCapsWith mIndices opts req + +-- | 'getSearchShards' returns the shards and nodes that a search +-- request would be executed against, without running the search +-- itself. Wraps @GET \/{indices}\/_search_shards@ +-- (; +-- also implemented by OpenSearch — see +-- ). Pass +-- 'Nothing' or @'Just' []@ to target every index; pass a non-empty +-- list to restrict to a comma-joined subset. +-- +-- Surfaced as 'StatusDependant' so genuine server-side errors (auth, +-- missing index, 5xx, ...) decode as an 'EsError'. +getSearchShards :: + (MonadBH m) => + Maybe [IndexName] -> + m SearchShardsResponse +getSearchShards mIndices = + performBHRequest $ Requests.getSearchShards mIndices + +-- | Like 'getSearchShards' but additionally accepts 'SearchShardsOptions' +-- rendered as URI parameters (@allow_no_indices@, @expand_wildcards@, +-- @ignore_unavailable@, @local@, @preference@, @routing@). +-- 'defaultSearchShardsOptions' makes this byte-for-byte identical to +-- 'getSearchShards'. +getSearchShardsWith :: + (MonadBH m) => + Maybe [IndexName] -> + SearchShardsOptions -> + m SearchShardsResponse +getSearchShardsWith mIndices opts = + performBHRequest $ Requests.getSearchShardsWith mIndices opts + +reindex :: (MonadBH m) => ReindexRequest -> m ReindexResponse +reindex = performBHRequest . Requests.reindex + +-- | Like 'reindex' but accepts 'ReindexOptions' carrying the URI-level +-- parameters documented for @POST /_reindex@ +-- (). +-- Pass 'defaultReindexOptions' to reproduce the legacy behaviour. +reindexWith :: (MonadBH m) => ReindexOptions -> ReindexRequest -> m ReindexResponse +reindexWith opts = performBHRequest . Requests.reindexWith opts + +reindexAsync :: (MonadBH m) => ReindexRequest -> m TaskNodeId +reindexAsync = performBHRequest . Requests.reindexAsync + +-- | Like 'reindexAsync' but accepts 'ReindexOptions' carrying the +-- URI-level parameters documented for @POST /_reindex@. @wait_for_completion=false@ +-- is always appended; pass 'defaultReindexOptions' to reproduce the +-- legacy behaviour. +reindexAsyncWith :: (MonadBH m) => ReindexOptions -> ReindexRequest -> m TaskNodeId +reindexAsyncWith opts = performBHRequest . Requests.reindexAsyncWith opts + +-- | 'rethrottleReindex' changes the maximum documents-per-second rate +-- of an in-progress asynchronous reindex. Maps to +-- @POST /_reindex/{task_id}/_rethrottle?requests_per_second=@. +-- Returns a 'TaskListResponse' (same shape as 'cancelTask') listing +-- the task(s) whose rate was changed — an empty node list means the +-- task had already finished. Pass the 'TaskNodeId' returned by +-- 'reindexAsync'. Use 'RethrottleUnlimited' to disable throttling, +-- or @'RethrottlePerSecond' n@ for any non-negative decimal rate. +-- +-- See +-- . +rethrottleReindex :: (MonadBH m) => TaskNodeId -> RethrottleRate -> m TaskListResponse +rethrottleReindex tid = performBHRequest . Requests.rethrottleReindex tid + +-- | Legacy 'getTask'; equivalent to @'getTaskWith' 'defaultTaskGetOptions'@. +getTask :: (MonadBH m, FromJSON a) => TaskNodeId -> m (TaskResponse a) +getTask = performBHRequest . Requests.getTask + +-- | Like 'getTask' but accepts 'TaskGetOptions' carrying the URI-level +-- parameters documented for @GET /_tasks/{task_id}@ +-- (@wait_for_completion@, @timeout@). Pass 'defaultTaskGetOptions' to +-- reproduce the legacy behaviour. +getTaskWith :: (MonadBH m, FromJSON a) => TaskGetOptions -> TaskNodeId -> m (TaskResponse a) +getTaskWith opts = performBHRequest . Requests.getTaskWith opts + +-- | 'cancelTask' cancels a currently running task by id. Maps to +-- @POST /_tasks/{task_id}/_cancel@. The response lists the tasks that +-- were actually cancelled (same nodes-grouped shape as 'listTasks'), +-- returned as a 'TaskListResponse' — empty if the task had already +-- finished. Pass the 'TaskNodeId' returned by 'reindexAsync' or +-- observed via 'listTasks' or 'getTask'. +-- +-- See +-- . +cancelTask :: (MonadBH m) => TaskNodeId -> m TaskListResponse +cancelTask = performBHRequest . Requests.cancelTask + +-- | 'listTasks' lists currently running tasks on the cluster. Maps to +-- @GET /_tasks@. Pass 'Nothing' for the unfiltered endpoint, or a +-- populated 'TaskListOptions' to filter (e.g. by @actions@) or to +-- request @detailed@ task bodies. Flatten the structured +-- 'TaskListResponse' with 'taskListFlat' to obtain a plain +-- @['TaskInfo']@. +listTasks :: (MonadBH m) => Maybe TaskListOptions -> m TaskListResponse +listTasks = performBHRequest . Requests.listTasks + +-- | 'getAsyncSearch' polls an async search by id, returning its current +-- running state and any partial or final results. Maps to +-- @GET /_async_search/{id}@. +-- +-- See +-- . +getAsyncSearch :: (MonadBH m, FromJSON a) => AsyncSearchId -> m (AsyncSearchResult a) +getAsyncSearch = performBHRequest . Requests.getAsyncSearch + +-- | 'getAsyncSearchStatus' reports only the running\/partial state (and +-- scheduling times) for an async search, without transferring the result +-- set. Maps to @GET /_async_search/status/{id}@. +-- +-- See +-- . +getAsyncSearchStatus :: (MonadBH m) => AsyncSearchId -> m AsyncSearchStatus +getAsyncSearchStatus = performBHRequest . Requests.getAsyncSearchStatus + +-- | 'getILMPolicy' lists ILM policies. +-- +-- * @'Nothing'@ → @GET /_ilm/policy@ returns every policy on the cluster. +-- * @'Just' pid@ → @GET /_ilm/policy/{pid}@ returns just that one (as a +-- singleton list). +-- +-- See +-- . +getILMPolicy :: (MonadBH m) => Maybe ILMPolicyId -> m [ILMPolicyInfo] +getILMPolicy = performBHRequest . Requests.getILMPolicy + +-- | 'putILMPolicy' creates or updates a single ILM policy by id. Maps to +-- @PUT /_ilm/policy/{id}@ and returns 'Acknowledged' on success. +-- +-- See +-- . +putILMPolicy :: (MonadBH m) => ILMPolicyId -> ILMPolicy -> m Acknowledged +putILMPolicy policyId policy = performBHRequest $ Requests.putILMPolicy policyId policy + +-- | 'deleteILMPolicy' deletes a single ILM policy by id. Maps to +-- @DELETE /_ilm/policy/{id}@ and returns 'Acknowledged' on success. +-- Deleting a policy that does not exist surfaces as an 'EsError'. +-- +-- See +-- . +deleteILMPolicy :: (MonadBH m) => ILMPolicyId -> m Acknowledged +deleteILMPolicy = performBHRequest . Requests.deleteILMPolicy + +-- | 'explainILM' retrieves the ILM state (managed flag, current +-- phase\/action\/step, age, error details, ...) for every index matched +-- by the given 'IndexName', which may be a wildcard (@*@) or a +-- comma-separated list. Maps to @GET /_ilm/explain/{index}@ and returns +-- one 'ILMExplanation' per concrete matched index. +-- +-- Equivalent to @'explainILMWith' 'defaultILMExplainOptions'@. +-- +-- See +-- . +explainILM :: (MonadBH m) => IndexName -> m ILMExplanations +explainILM indexName = performBHRequest $ Requests.explainILM indexName + +-- | Like 'explainILM' but accepts an 'ILMExplainOptions' record for the +-- @only_errors@, @only_managed@ and @master_timeout@ URI parameters. +-- 'defaultILMExplainOptions' makes this byte-for-byte equivalent to +-- 'explainILM'. +explainILMWith :: + (MonadBH m) => + ILMExplainOptions -> + IndexName -> + m ILMExplanations +explainILMWith opts indexName = + performBHRequest $ Requests.explainILMWith opts indexName + +-- | 'startILM' starts the ILM plugin. Maps to @POST /_ilm/start@ and +-- returns 'Acknowledged' on success. ILM runs by default; this is only +-- needed to resume after 'stopILM'. +-- +-- See +-- . +startILM :: (MonadBH m) => m Acknowledged +startILM = performBHRequest Requests.startILM + +-- | 'stopILM' stops the ILM plugin. Maps to @POST /_ilm/stop@ and +-- returns 'Acknowledged' on success. +-- +-- See +-- . +stopILM :: (MonadBH m) => m Acknowledged +stopILM = performBHRequest Requests.stopILM + +-- | 'getILMStatus' reports the cluster-wide ILM operation mode. +-- Maps to @GET /_ilm/status@. +-- +-- See +-- . +getILMStatus :: (MonadBH m) => m ILMStatus +getILMStatus = performBHRequest Requests.getILMStatus + +-- | 'moveILMStep' forces the given index from one lifecycle step into +-- another. Maps to @POST /_ilm/move/{index}@. Returns 'Acknowledged' on +-- success. +-- +-- See +-- . +moveILMStep :: + (MonadBH m) => + IndexName -> + MoveStepRequest -> + m Acknowledged +moveILMStep indexName body = + performBHRequest $ Requests.moveILMStep indexName body + +-- | 'retryILMStep' retries the current ILM step for an index in an error +-- state. Maps to @POST /_ilm/retry/{index}@ and returns 'Acknowledged' on +-- success. +-- +-- See +-- . +retryILMStep :: (MonadBH m) => IndexName -> m Acknowledged +retryILMStep indexName = + performBHRequest $ Requests.retryILMStep indexName + +-- | 'removeILM' detaches the given index from ILM management. Maps to +-- @POST /_ilm/remove/{index}@ and returns 'Acknowledged' on success. +-- +-- See +-- . +removeILM :: (MonadBH m) => IndexName -> m Acknowledged +removeILM indexName = + performBHRequest $ Requests.removeILM indexName + +-- | 'migrateDataTiers' migrates the cluster's allocation routing from the +-- legacy @node.attr.*@ style to the modern data-tier style. Maps to +-- @POST /_ilm/migrate_to_data_tiers@ and returns a +-- 'MigrateDataTiersResponse'. +-- +-- Equivalent to +-- @'migrateDataTiersWith' 'defaultMigrateDataTiersOptions' 'defaultMigrateDataTiersRequest'@. +-- Use 'migrateDataTiersWith' to preview (with 'migrateDataTiersOptionsDryRun') +-- or to override the auto-detected legacy template and node attribute. +-- +-- See +-- . +migrateDataTiers :: (MonadBH m) => m MigrateDataTiersResponse +migrateDataTiers = performBHRequest Requests.migrateDataTiers + +-- | 'migrateDataTiersWith' is the fully-parameterised form of +-- 'migrateDataTiers'. +migrateDataTiersWith :: + (MonadBH m) => + MigrateDataTiersOptions -> + MigrateDataTiersRequest -> + m MigrateDataTiersResponse +migrateDataTiersWith opts body = + performBHRequest $ Requests.migrateDataTiersWith opts body + +-- | 'putSLMPolicy' creates or updates a single snapshot lifecycle policy +-- by id. Maps to @PUT /_slm/policy/{id}@ and returns 'Acknowledged' on +-- success. The 'SLMPolicy' body is sent as-is at the top level of the +-- request — SLM, unlike ILM, does @not@ wrap the policy under a @policy@ +-- key. +-- +-- See +-- . +putSLMPolicy :: (MonadBH m) => SLMPolicyId -> SLMPolicy -> m Acknowledged +putSLMPolicy policyId policy = + performBHRequest $ Requests.putSLMPolicy policyId policy + +-- | 'putIngestPipeline' creates or updates a single ingest pipeline by id. +-- Maps to @PUT /_ingest/pipeline/{id}@ and returns 'Acknowledged' on +-- success. The 'IngestPipeline' body is sent as-is at the top level of the +-- request — ingest, unlike ILM, does @not@ wrap the pipeline under a +-- @pipeline@ key. +-- +-- Available on Elasticsearch 5.0+ and OpenSearch 1.x\/2.x\/3.x, so the +-- request lives in the Common layer and is re-exported by every client +-- module. +-- +-- See +-- . +putIngestPipeline :: + (MonadBH m) => + PipelineId -> + IngestPipeline -> + m Acknowledged +putIngestPipeline pipelineId pipeline = + performBHRequest $ Requests.putIngestPipeline pipelineId pipeline + +-- | 'getIngestPipeline' lists one or all ingest pipelines. Maps to +-- @GET /_ingest/pipeline[\/{id}]@. The response is keyed by pipeline id +-- on the wire; the client decoder walks the keys and returns a flat list +-- of 'IngestPipelineInfo' values (the same shape 'getILMPolicy' uses). +-- +-- See +-- . +getIngestPipeline :: + (MonadBH m) => + Maybe PipelineId -> + m [IngestPipelineInfo] +getIngestPipeline = performBHRequest . Requests.getIngestPipeline + +-- | 'deleteIngestPipeline' deletes a single ingest pipeline by id. Maps to +-- @DELETE /_ingest/pipeline/{id}@ and returns 'Acknowledged' on success. +-- +-- See +-- . +deleteIngestPipeline :: (MonadBH m) => PipelineId -> m Acknowledged +deleteIngestPipeline = performBHRequest . Requests.deleteIngestPipeline + +-- | 'simulateIngestPipeline' runs the supplied documents through an ingest +-- pipeline without indexing anything, returning the per-document +-- transformed results. The 'PipelineId' argument selects between the +-- stored-pipeline form (@POST /_ingest/pipeline/{id}/_simulate@) and the +-- inline-only form (@POST /_ingest/pipeline/_simulate@). +-- +-- See +-- . +simulateIngestPipeline :: + (MonadBH m) => + Maybe PipelineId -> + IngestPipeline -> + [Value] -> + m SimulateResult +simulateIngestPipeline mPipelineId pipeline docs = + performBHRequest $ + Requests.simulateIngestPipeline mPipelineId pipeline docs + +-- | 'getGrokPatterns' lists the built-in grok patterns shipped with the +-- grok ingest processor. Maps to @GET /_ingest/processor/grok@ and +-- returns a 'GrokPatterns'. +-- +-- See +-- . +getGrokPatterns :: (MonadBH m) => m GrokPatterns +getGrokPatterns = performBHRequest Requests.getGrokPatterns + +-- | 'getSLMPolicy' lists SLM policies. +-- +-- * @'Nothing'@ → @GET /_slm/policy@ returns every policy on the cluster. +-- * @'Just' pid@ → @GET /_slm/policy/{pid}@ returns just that one (as a +-- singleton list). +-- +-- See +-- . +getSLMPolicy :: (MonadBH m) => Maybe SLMPolicyId -> m [SLMPolicyInfo] +getSLMPolicy = performBHRequest . Requests.getSLMPolicy + +-- | 'deleteSLMPolicy' deletes a single SLM policy by id. Maps to +-- @DELETE /_slm/policy/{id}@ and returns 'Acknowledged' on success. +-- +-- See +-- . +deleteSLMPolicy :: (MonadBH m) => SLMPolicyId -> m Acknowledged +deleteSLMPolicy = performBHRequest . Requests.deleteSLMPolicy + +-- | 'executeSLMPolicy' triggers a single SLM policy immediately, outside +-- of its schedule. Maps to @POST /_slm/execute/{id}@ and returns the +-- 'SnapshotName' of the newly-created snapshot on success. +-- +-- See +-- . +executeSLMPolicy :: (MonadBH m) => SLMPolicyId -> m SnapshotName +executeSLMPolicy = performBHRequest . Requests.executeSLMPolicy + +-- | 'getSLMStatus' reports the cluster-wide SLM operation mode +-- ('SLMOperationMode') alongside the cumulative snapshot creation and +-- deletion counters. Maps to @GET /_slm/status@. +-- +-- See +-- . +getSLMStatus :: (MonadBH m) => m SLMStatus +getSLMStatus = performBHRequest Requests.getSLMStatus + +-- | 'stopSLM' stops all SLM scheduling. Maps to @POST /_slm/stop@ and +-- returns 'Acknowledged' on success. +-- +-- See +-- . +stopSLM :: (MonadBH m) => m Acknowledged +stopSLM = performBHRequest Requests.stopSLM + +-- | 'startSLM' (re)starts SLM scheduling. Maps to @POST /_slm/start@ and +-- returns 'Acknowledged' on success. Inverse of 'stopSLM'. +-- +-- See +-- . +-- +-- @since 0.26.0.0 +startSLM :: (MonadBH m) => m Acknowledged +startSLM = performBHRequest Requests.startSLM + +------------------------------------------------------------------------------ +-- Enrich policy API + +-- | 'putEnrichPolicy' creates or replaces an enrich policy by id. Maps to +-- @PUT /_enrich/policy/{policy_id}@ and returns 'Acknowledged' on +-- success. +-- +-- See +-- . +putEnrichPolicy :: + (MonadBH m) => + EnrichPolicyId -> + EnrichPolicy -> + m Acknowledged +putEnrichPolicy policyId policy = + performBHRequest $ Requests.putEnrichPolicy policyId policy + +-- | 'getEnrichPolicy' lists enrich policies. @'Nothing'@ returns every +-- policy on the cluster; @'Just' pid@ returns just that one (as a +-- singleton 'EnrichPoliciesResponse'). +-- +-- See +-- . +getEnrichPolicy :: + (MonadBH m) => + Maybe EnrichPolicyId -> + m EnrichPoliciesResponse +getEnrichPolicy = performBHRequest . Requests.getEnrichPolicy + +-- | 'deleteEnrichPolicy' deletes a single enrich policy by id. Maps to +-- @DELETE /_enrich/policy/{policy_id}@ and returns 'Acknowledged' on +-- success. +-- +-- See +-- . +deleteEnrichPolicy :: (MonadBH m) => EnrichPolicyId -> m Acknowledged +deleteEnrichPolicy = performBHRequest . Requests.deleteEnrichPolicy + +-- | 'executeEnrichPolicy' triggers a synchronous execution of an enrich +-- policy (creating\/refreshing its follower index). Maps to +-- @POST /_enrich/policy/{policy_id}/_execute@ and returns 'Acknowledged'. +-- +-- See +-- . +executeEnrichPolicy :: (MonadBH m) => EnrichPolicyId -> m Acknowledged +executeEnrichPolicy = performBHRequest . Requests.executeEnrichPolicy + +-- | Like 'executeEnrichPolicy' but accepts 'EnrichExecuteOptions' +-- carrying the documented URI parameter @wait_for_completion@. +-- +-- See +-- . +executeEnrichPolicyWith :: + (MonadBH m) => + EnrichPolicyId -> + EnrichExecuteOptions -> + m Acknowledged +executeEnrichPolicyWith pid opts = + performBHRequest $ Requests.executeEnrichPolicyWith pid opts + +-- | 'getEnrichExecuteStats' reports the executor pool and per-policy +-- execution statistics across the cluster. Maps to +-- @GET /_enrich/_execute_stats@. +-- +-- See +-- . +getEnrichExecuteStats :: (MonadBH m) => m EnrichExecuteStatsResponse +getEnrichExecuteStats = performBHRequest Requests.getEnrichExecuteStats + +-- | 'getEnrichPolicyExecuteStats' reports execution statistics for a +-- single enrich policy. Maps to +-- @GET /_enrich/policy/{policy_id}/_execute_stats@ (per-policy variant, +-- ES 7.16+). +-- +-- See +-- . +getEnrichPolicyExecuteStats :: + (MonadBH m) => + EnrichPolicyId -> + m EnrichExecuteStatsResponse +getEnrichPolicyExecuteStats = + performBHRequest . Requests.getEnrichPolicyExecuteStats + +------------------------------------------------------------------------------ +-- Autoscaling API + +-- | 'putAutoscalingPolicy' creates or replaces an autoscaling policy by name. +-- Maps to @PUT /_autoscaling/policy/{name}@ and returns 'Acknowledged' on +-- success. +-- +-- See +-- . +putAutoscalingPolicy :: + (MonadBH m) => + AutoscalingPolicyName -> + AutoscalingPolicy -> + m Acknowledged +putAutoscalingPolicy name policy = + performBHRequest $ Requests.putAutoscalingPolicy name policy + +-- | 'getAutoscalingPolicy' retrieves a single autoscaling policy by name. +-- Maps to @GET /_autoscaling/policy/{name}@. +-- +-- See +-- . +getAutoscalingPolicy :: + (MonadBH m) => + AutoscalingPolicyName -> + m AutoscalingPolicy +getAutoscalingPolicy = + performBHRequest . Requests.getAutoscalingPolicy + +-- | 'deleteAutoscalingPolicy' deletes a single autoscaling policy by name. +-- Maps to @DELETE /_autoscaling/policy/{name}@ and returns 'Acknowledged'. +-- +-- See +-- . +deleteAutoscalingPolicy :: + (MonadBH m) => + AutoscalingPolicyName -> + m Acknowledged +deleteAutoscalingPolicy = + performBHRequest . Requests.deleteAutoscalingPolicy + +-- | 'getAutoscalingCapacity' reports the current autoscaling capacity for +-- every configured policy. Maps to @GET /_autoscaling/capacity@. +-- +-- See +-- . +getAutoscalingCapacity :: (MonadBH m) => m AutoscalingCapacity +getAutoscalingCapacity = + performBHRequest Requests.getAutoscalingCapacity + +------------------------------------------------------------------------------ +-- Security — roles API (/_security/role/*) + +-- | 'putRole' creates or replaces a role by name. Maps to +-- @PUT /_security/role/{name}@; 'RoleCreatedResponse' reports whether +-- the role was newly created (@created=True@) or updated. +-- +-- See +-- . +putRole :: (MonadBH m) => RoleName -> Role -> m RoleCreatedResponse +putRole name role = performBHRequest $ Requests.putRole name role + +-- | 'getRoles' lists every role on the cluster. Maps to +-- @GET /_security/role@. +-- +-- See +-- . +getRoles :: (MonadBH m) => m RolesListResponse +getRoles = performBHRequest Requests.getRoles + +-- | 'getRole' fetches a single role by name. Maps to +-- @GET /_security/role/{name}@; the result is a singleton +-- 'RolesListResponse' (possibly empty if the role is absent). +-- +-- See +-- . +getRole :: (MonadBH m) => RoleName -> m RolesListResponse +getRole = performBHRequest . Requests.getRole + +-- | 'deleteRole' deletes a role by name. Maps to +-- @DELETE /_security/role/{name}@; 'RoleDeletedResponse' reports +-- whether the role existed. +-- +-- See +-- . +deleteRole :: (MonadBH m) => RoleName -> m RoleDeletedResponse +deleteRole = performBHRequest . Requests.deleteRole + +-- | 'clearRoleCache' evicts a role from the security cache. Maps to +-- @POST /_security/role/{name}/_clear_cache@. +-- +-- See +-- . +clearRoleCache :: (MonadBH m) => RoleName -> m ClearRoleCacheResponse +clearRoleCache = performBHRequest . Requests.clearRoleCache + +------------------------------------------------------------------------------ +-- Security — role mappings API (/_security/role_mapping/*) + +-- | 'putRoleMapping' creates or replaces a role mapping. Maps to +-- @PUT /_security/role_mapping/{name}@. +-- +-- See +-- . +putRoleMapping :: + (MonadBH m) => + RoleMappingName -> + RoleMapping -> + m Acknowledged +putRoleMapping name rm = performBHRequest $ Requests.putRoleMapping name rm + +-- | 'getRoleMappings' lists every role mapping. Maps to +-- @GET /_security/role_mapping@. +getRoleMappings :: (MonadBH m) => m RoleMappingsListResponse +getRoleMappings = performBHRequest Requests.getRoleMappings + +-- | 'getRoleMapping' fetches a single role mapping by name. +getRoleMapping :: + (MonadBH m) => + RoleMappingName -> + m RoleMappingsListResponse +getRoleMapping = performBHRequest . Requests.getRoleMapping + +-- | 'deleteRoleMapping' deletes a role mapping by name. Maps to +-- @DELETE /_security/role_mapping/{name}@. +deleteRoleMapping :: (MonadBH m) => RoleMappingName -> m Acknowledged +deleteRoleMapping = performBHRequest . Requests.deleteRoleMapping + +------------------------------------------------------------------------------ +-- Security — users API (/_security/user/*) + +-- | 'putUser' creates or updates a user. Maps to +-- @PUT /_security/user/{username}@; 'UserCreatedResponse' reports +-- whether the user was newly created (@created=True@) or updated. +-- +-- See +-- . +putUser :: + (MonadBH m) => + UserName -> + UserCreateBody -> + m UserCreatedResponse +putUser username body = performBHRequest $ Requests.putUser username body + +-- | 'getUsers' lists every user on the cluster. Maps to +-- @GET /_security/user@. +-- +-- See +-- . +getUsers :: (MonadBH m) => m UsersListResponse +getUsers = performBHRequest Requests.getUsers + +-- | 'getUser' fetches a single user by username. Maps to +-- @GET /_security/user/{username}@. +getUser :: (MonadBH m) => UserName -> m UsersListResponse +getUser = performBHRequest . Requests.getUser + +-- | 'deleteUser' deletes a user by username. Maps to +-- @DELETE /_security/user/{username}@; 'UserDeletedResponse' reports +-- whether the user existed. +-- +-- See +-- . +deleteUser :: (MonadBH m) => UserName -> m UserDeletedResponse +deleteUser = performBHRequest . Requests.deleteUser + +-- | 'enableUser' enables a user. Maps to +-- @PUT /_security/user/{username}/_enable@. +enableUser :: (MonadBH m) => UserName -> m Acknowledged +enableUser = performBHRequest . Requests.enableUser + +-- | 'disableUser' disables a user. Maps to +-- @PUT /_security/user/{username}/_disable@. +disableUser :: (MonadBH m) => UserName -> m Acknowledged +disableUser = performBHRequest . Requests.disableUser + +-- | 'changeUserPassword' changes a user's password. Maps to +-- @POST /_security/user/{username}/_password@. +-- +-- See +-- . +changeUserPassword :: + (MonadBH m) => + UserName -> + ChangePasswordBody -> + m Acknowledged +changeUserPassword username body = + performBHRequest $ Requests.changeUserPassword username body + +-- | 'userHasPrivileges' checks the privileges held by a named user. +-- Maps to @POST /_security/user/{username}/_has_privileges@. +-- +-- See +-- . +userHasPrivileges :: + (MonadBH m) => + UserName -> + HasPrivilegesRequest -> + m HasPrivilegesResponse +userHasPrivileges username req = + performBHRequest $ Requests.userHasPrivileges username req + +-- | 'selfHasPrivileges' checks the privileges held by the current +-- (authenticated) user. Maps to @POST /_security/user/_has_privileges@. +selfHasPrivileges :: + (MonadBH m) => + HasPrivilegesRequest -> + m HasPrivilegesResponse +selfHasPrivileges = performBHRequest . Requests.selfHasPrivileges + +-- | 'getUserPrivileges' lists the current user's effective privileges. +-- Maps to @GET /_security/user/_privileges@. +-- +-- See +-- . +getUserPrivileges :: (MonadBH m) => m UserPrivileges +getUserPrivileges = performBHRequest Requests.getUserPrivileges + +------------------------------------------------------------------------------ +-- Security — API keys (/_security/api_key) + +-- | 'createApiKey' mints a new API key. Maps to @POST /_security/api_key@. +-- The plaintext 'ApiKeyCreatedResponse' secret is returned exactly once. +-- +-- See +-- . +createApiKey :: + (MonadBH m) => + CreateApiKeyRequest -> + m ApiKeyCreatedResponse +createApiKey = performBHRequest . Requests.createApiKey + +-- | 'grantApiKey' mints an API key on behalf of another principal. Maps +-- to @POST /_security/api_key/grant@. +-- +-- See +-- . +grantApiKey :: + (MonadBH m) => + GrantApiKeyRequest -> + m ApiKeyCreatedResponse +grantApiKey = performBHRequest . Requests.grantApiKey + +-- | 'getApiKey' retrieves API keys matching the filter. Maps to +-- @GET /_security/api_key@. The plaintext key is NOT included. +-- +-- See +-- . +getApiKey :: + (MonadBH m) => + RetrieveApiKeyRequest -> + m ApiKeyRetrievalResponse +getApiKey = performBHRequest . Requests.getApiKey + +-- | 'invalidateApiKey' revokes API keys matching the filter. Maps to +-- @DELETE /_security/api_key@. +-- +-- See +-- . +invalidateApiKey :: + (MonadBH m) => + InvalidateApiKeyRequest -> + m InvalidateApiKeyResponse +invalidateApiKey = performBHRequest . Requests.invalidateApiKey + +-- | 'updateApiKey' updates a key's role descriptors and/or metadata. +-- Maps to @PUT /_security/api_key/{id}@. +-- +-- See +-- . +updateApiKey :: + (MonadBH m) => + ApiKeyId -> + UpdateApiKeyRequest -> + m Acknowledged +updateApiKey apiKeyId body = + performBHRequest $ Requests.updateApiKey apiKeyId body + +-- | 'queryApiKey' lists API keys via the Query-DSL paginated endpoint. +-- Maps to @POST /_security/_query/api_key@ (ES 7.16+ \/ 8.x). +-- +-- See +-- . +queryApiKey :: + (MonadBH m) => + QueryApiKeyRequest -> + m QueryApiKeyResponse +queryApiKey = performBHRequest . Requests.queryApiKey + +-- | Variant of 'queryApiKey' that also sets the @with_limited_by@, +-- @with_profile_uid@, and @typed_keys@ URI parameters. Calling with +-- 'defaultQueryApiKeyOptions' is byte-for-byte identical to 'queryApiKey'. +queryApiKeyWith :: + (MonadBH m) => + QueryApiKeyRequest -> + Requests.QueryApiKeyOptions -> + m QueryApiKeyResponse +queryApiKeyWith req opts = + performBHRequest $ Requests.queryApiKeyWith req opts + +-- | 'authenticate' returns information about the credentials the request +-- was made with. Maps to @GET /_security/_authenticate@. When the request +-- carries an API key (@Authorization: ApiKey @), the response +-- describes that API key. +-- +-- See +-- . +authenticate :: (MonadBH m) => m AuthenticateResponse +authenticate = performBHRequest Requests.authenticate + +-- | 'whoami' returns the identity of the current authenticated user +-- (ES 7.16+). Maps to @GET /_security/_whoami@. +-- +-- See +-- . +whoami :: (MonadBH m) => m WhoAmIResponse +whoami = performBHRequest Requests.whoami + +-- | 'logout' logs out of a SAML/OIDC SSO token. Maps to +-- @POST /_security/_logout@ with the SSO token to invalidate. +-- +-- See +-- . +logout :: (MonadBH m) => LogoutRequest -> m LogoutResponse +logout = performBHRequest . Requests.logout + +------------------------------------------------------------------------------ +-- Security — service accounts (/_security/service/*) + +-- | 'getServiceAccounts' lists every service account. Maps to +-- @GET /_security/service@. +getServiceAccounts :: (MonadBH m) => m ServiceAccountsListResponse +getServiceAccounts = performBHRequest Requests.getServiceAccounts + +-- | 'getServiceAccountsInNamespace' lists the service accounts in a +-- namespace. Maps to @GET /_security/service/{namespace}@. +getServiceAccountsInNamespace :: + (MonadBH m) => + ServiceAccountNamespace -> + m ServiceAccountsListResponse +getServiceAccountsInNamespace = + performBHRequest . Requests.getServiceAccountsInNamespace + +-- | 'getServiceAccount' retrieves a single service account. Maps to +-- @GET /_security/service/{namespace}/{service}@. +getServiceAccount :: + (MonadBH m) => + ServiceAccountNamespace -> + ServiceAccountService -> + m ServiceAccountsListResponse +getServiceAccount namespace service = + performBHRequest $ Requests.getServiceAccount namespace service + +-- | 'createServiceToken' creates a service account token. The secret +-- token @value@ is returned exactly once. Maps to +-- @POST /_security/service/{namespace}/{service}/credential/token[/{token_name}]@. +createServiceToken :: + (MonadBH m) => + ServiceAccountNamespace -> + ServiceAccountService -> + Maybe ServiceTokenName -> + m CreateServiceTokenResponse +createServiceToken namespace service maybeTokenName = + performBHRequest $ + Requests.createServiceToken namespace service maybeTokenName + +-- | 'getServiceCredentials' lists the credentials (tokens) of a service +-- account. Maps to +-- @GET /_security/service/{namespace}/{service}/credential@. +getServiceCredentials :: + (MonadBH m) => + ServiceAccountNamespace -> + ServiceAccountService -> + m GetServiceCredentialsResponse +getServiceCredentials namespace service = + performBHRequest $ Requests.getServiceCredentials namespace service + +-- | 'deleteServiceToken' deletes a service account token. Maps to +-- @DELETE /_security/service/{namespace}/{service}/credential/token/{token_name}@. +deleteServiceToken :: + (MonadBH m) => + ServiceAccountNamespace -> + ServiceAccountService -> + ServiceTokenName -> + m ServiceTokenDeletedResponse +deleteServiceToken namespace service tokenName = + performBHRequest $ + Requests.deleteServiceToken namespace service tokenName + +------------------------------------------------------------------------------ +-- Security — SSO / token (/_security/oauth2, /_security/oidc, /_security/saml) + +-- | 'getToken' mints an OAuth2 bearer token. Maps to +-- @POST /_security/oauth2/token@. +-- +-- See +-- . +getToken :: + (MonadBH m) => + GetTokenRequest -> + m GetTokenResponse +getToken = performBHRequest . Requests.getToken + +-- | 'invalidateToken' revokes an access/refresh token (or every token +-- for a realm/user). Maps to @DELETE /_security/oauth2/token@. +-- +-- See +-- . +invalidateToken :: + (MonadBH m) => + InvalidateTokenRequest -> + m InvalidateTokenResponse +invalidateToken = performBHRequest . Requests.invalidateToken + +-- | 'prepareSamlAuthentication' mints a SAML @@ redirect +-- URL. Maps to @POST /_security/saml/prepare@. +-- +-- See +-- . +prepareSamlAuthentication :: + (MonadBH m) => + SamlPrepareRequest -> + m SamlPrepareResponse +prepareSamlAuthentication = performBHRequest . Requests.prepareSamlAuthentication + +-- | 'authenticateSaml' exchanges a SAML @@ for an ES access +-- and refresh token. Maps to @POST /_security/saml/authenticate@. +-- +-- See +-- . +authenticateSaml :: + (MonadBH m) => + SamlAuthenticateRequest -> + m SsoTokenResponse +authenticateSaml = performBHRequest . Requests.authenticateSaml + +-- | 'logoutSaml' invalidates a SAML-issued token pair. Maps to +-- @POST /_security/saml/logout@. +-- +-- See +-- . +logoutSaml :: + (MonadBH m) => + SamlLogoutRequest -> + m SsoRedirectResponse +logoutSaml = performBHRequest . Requests.logoutSaml + +-- | 'prepareOidcAuthentication' mints an OpenID Connect authentication +-- request URL. Maps to @POST /_security/oidc/prepare@. +-- +-- See +-- . +prepareOidcAuthentication :: + (MonadBH m) => + OidcPrepareRequest -> + m OidcPrepareResponse +prepareOidcAuthentication = + performBHRequest . Requests.prepareOidcAuthentication + +-- | 'authenticateOidc' exchanges an OpenID Connect authentication +-- response for an ES access and refresh token. Maps to +-- @POST /_security/oidc/authenticate@. +-- +-- See +-- . +authenticateOidc :: + (MonadBH m) => + OidcAuthenticateRequest -> + m SsoTokenResponse +authenticateOidc = performBHRequest . Requests.authenticateOidc + +-- | 'logoutOidc' invalidates an OIDC-issued token pair. Maps to +-- @POST /_security/oidc/logout@. +-- +-- See +-- . +logoutOidc :: + (MonadBH m) => + OidcLogoutRequest -> + m SsoRedirectResponse +logoutOidc = performBHRequest . Requests.logoutOidc + +------------------------------------------------------------------------------ +-- Security — application privileges (/_security/privilege/*) + +-- | 'putPrivilege' creates or updates a single application privilege. Maps +-- to @PUT /_security/privilege/{application}/{privilege}@. +putPrivilege :: + (MonadBH m) => + ApplicationName -> + ApplicationPrivilegeName -> + ApplicationPrivilegeDefinition -> + m PrivilegeCreatedResponse +putPrivilege application privilege definition = + performBHRequest $ + Requests.putPrivilege application privilege definition + +-- | 'getPrivileges' lists every application privilege. Maps to +-- @GET /_security/privilege@. +getPrivileges :: (MonadBH m) => m PrivilegesListResponse +getPrivileges = performBHRequest Requests.getPrivileges + +-- | 'getPrivilegesInApplication' lists every privilege for one application. +-- Maps to @GET /_security/privilege/{application}@. +getPrivilegesInApplication :: + (MonadBH m) => + ApplicationName -> + m PrivilegesListResponse +getPrivilegesInApplication = + performBHRequest . Requests.getPrivilegesInApplication + +-- | 'getPrivilege' fetches a single privilege. Maps to +-- @GET /_security/privilege/{application}/{privilege}@. +getPrivilege :: + (MonadBH m) => + ApplicationName -> + ApplicationPrivilegeName -> + m PrivilegesListResponse +getPrivilege application privilege = + performBHRequest $ Requests.getPrivilege application privilege + +-- | 'deletePrivilege' deletes a single application privilege. Maps to +-- @DELETE /_security/privilege/{application}/{privilege}@. +deletePrivilege :: + (MonadBH m) => + ApplicationName -> + ApplicationPrivilegeName -> + m PrivilegeDeletedResponse +deletePrivilege application privilege = + performBHRequest $ Requests.deletePrivilege application privilege + +-- | 'clearPrivilegeCache' evicts application privileges from the native +-- privilege cache. Maps to +-- @POST /_security/privilege/{applications}/_clear_cache@; pass @"*"@ +-- (via 'IsString') as one of the applications to clear every application. +clearPrivilegeCache :: + (MonadBH m) => + NonEmpty ApplicationName -> + m ClearPrivilegeCacheResponse +clearPrivilegeCache = + performBHRequest . Requests.clearPrivilegeCache + +------------------------------------------------------------------------------ +-- Fleet API + +-- | 'getFleetGlobalCheckpoints' returns the current global checkpoints for +-- a single index. Maps to @GET /{index}/_fleet/global_checkpoints@ with +-- 'defaultFleetGlobalCheckpointsOptions'. Use 'getFleetGlobalCheckpointsWith' +-- to poll until the checkpoints advance. +-- +-- See +-- . +getFleetGlobalCheckpoints :: + (MonadBH m) => + IndexName -> + m FleetGlobalCheckpointsResponse +getFleetGlobalCheckpoints indexName = + performBHRequest $ Requests.getFleetGlobalCheckpoints indexName + +-- | Like 'getFleetGlobalCheckpoints' but accepts 'FleetGlobalCheckpointsOptions'. +-- +-- See +-- . +getFleetGlobalCheckpointsWith :: + (MonadBH m) => + IndexName -> + FleetGlobalCheckpointsOptions -> + m FleetGlobalCheckpointsResponse +getFleetGlobalCheckpointsWith indexName opts = + performBHRequest $ Requests.getFleetGlobalCheckpointsWith indexName opts + +-- | 'fleetSearch' runs a checkpoint-aware search against a single index. +-- Maps to @POST /{index}/_fleet/_fleet_search@ with +-- 'defaultFleetSearchOptions'. The request body and response are the +-- standard 'Search' \/ 'SearchResult' shapes. +-- +-- See +-- . +fleetSearch :: + (MonadBH m, FromJSON a) => + IndexName -> + Search -> + m (SearchResult a) +fleetSearch indexName = + performBHRequest . Requests.fleetSearch indexName + +-- | Like 'fleetSearch' but accepts 'FleetSearchOptions' carrying the +-- documented URI parameters @wait_for_checkpoints@ and +-- @allow_partial_search_results@. +-- +-- See +-- . +fleetSearchWith :: + (MonadBH m, FromJSON a) => + IndexName -> + FleetSearchOptions -> + Search -> + m (SearchResult a) +fleetSearchWith indexName opts = + performBHRequest . Requests.fleetSearchWith indexName opts + +-- | 'fleetMultiSearch' runs several fleet searches in a single request, +-- following the same NDJSON body shape as @_msearch@. Maps to +-- @POST /{index}/_fleet/_fleet_msearch@ with 'defaultFleetSearchOptions'. +-- +-- See +-- . +fleetMultiSearch :: + (MonadBH m, FromJSON a) => + IndexName -> + NonEmpty MultiSearchItem -> + m (MultiSearchResponse a) +fleetMultiSearch indexName = + performBHRequest . Requests.fleetMultiSearch indexName + +-- | Like 'fleetMultiSearch' but accepts 'FleetSearchOptions' carrying the +-- documented URI parameters @wait_for_checkpoints@ and +-- @allow_partial_search_results@. +-- +-- See +-- . +fleetMultiSearchWith :: + (MonadBH m, FromJSON a) => + IndexName -> + FleetSearchOptions -> + NonEmpty MultiSearchItem -> + m (MultiSearchResponse a) +fleetMultiSearchWith indexName opts = + performBHRequest . Requests.fleetMultiSearchWith indexName opts + +-- Repositories metering API + +-- | 'getRepositoriesMetering' reports the repository metering counters +-- (snapshot creation\/deletion throughput and counts) for each +-- cloud-backed repository on each node. @'Nothing'@ is cluster-wide +-- (@GET /_nodes/_repositories_metering@); @'Just' sel@ scopes to a +-- 'NodeSelection' (@GET /_nodes/{seg}/_repositories_metering@). +-- +-- See +-- . +getRepositoriesMetering :: + (MonadBH m) => + Maybe NodeSelection -> + m RepositoriesMeteringResponse +getRepositoriesMetering = + performBHRequest . Requests.getRepositoriesMetering + +-- | 'deleteRepositoriesMetering' resets the repository metering counters +-- to zero across the cluster (@'Nothing'@) or on a node selection +-- (@'Just'@), returning 'Acknowledged'. +-- +-- See +-- . +deleteRepositoriesMetering :: + (MonadBH m) => + Maybe NodeSelection -> + m Acknowledged +deleteRepositoriesMetering = + performBHRequest . Requests.deleteRepositoriesMetering + +------------------------------------------------------------------------------ +-- Rollup API + +-- | 'putRollupJob' creates or replaces a rollup job by id. Maps to +-- @PUT /_rollup/job/{job_id}@ and returns 'Acknowledged' on success. +-- +-- See +-- . +putRollupJob :: + (MonadBH m) => + RollupJobId -> + RollupJobConfig -> + m Acknowledged +putRollupJob jobId config = + performBHRequest $ Requests.putRollupJob jobId config + +-- | 'getRollupJob' retrieves the configuration, status, and stats of +-- rollup jobs. @'Nothing'@ returns every job on the cluster; @'Just' jid@ +-- returns just that one (as a singleton 'GetRollupJobsResponse'). +-- +-- See +-- . +getRollupJob :: + (MonadBH m) => + Maybe RollupJobId -> + m GetRollupJobsResponse +getRollupJob = performBHRequest . Requests.getRollupJob + +-- | 'deleteRollupJob' deletes a single rollup job by id. Maps to +-- @DELETE /_rollup/job/{job_id}@ and returns 'Acknowledged' on success. +-- +-- See +-- . +deleteRollupJob :: + (MonadBH m) => + RollupJobId -> + m Acknowledged +deleteRollupJob = performBHRequest . Requests.deleteRollupJob + +-- | 'startRollupJob' starts an existing, stopped rollup job. Maps to +-- @POST /_rollup/job/{job_id}/_start@ and returns 'RollupJobStarted'. +-- +-- See +-- . +startRollupJob :: + (MonadBH m) => + RollupJobId -> + m RollupJobStarted +startRollupJob = performBHRequest . Requests.startRollupJob + +-- | 'stopRollupJob' stops an existing, started rollup job asynchronously. +-- Maps to @POST /_rollup/job/{job_id}/_stop@ and returns 'RollupJobStopped'. +-- Use 'stopRollupJobWith' to block until the job has fully stopped. +-- +-- See +-- . +stopRollupJob :: + (MonadBH m) => + RollupJobId -> + m RollupJobStopped +stopRollupJob = performBHRequest . Requests.stopRollupJob + +-- | Like 'stopRollupJob' but accepts 'StopRollupJobOptions' carrying the +-- documented URI parameters @wait_for_completion@ and @timeout@. +-- +-- See +-- . +stopRollupJobWith :: + (MonadBH m) => + RollupJobId -> + StopRollupJobOptions -> + m RollupJobStopped +stopRollupJobWith jobId opts = + performBHRequest $ Requests.stopRollupJobWith jobId opts + +-- | 'getRollupJobStats' retrieves the transient statistics (and current +-- state) of rollup jobs. Maps to @GET /_rollup/job[/{job_id}|_all]/_stats@. +-- +-- See +-- . +getRollupJobStats :: + (MonadBH m) => + Maybe RollupJobId -> + m GetRollupJobStatsResponse +getRollupJobStats = performBHRequest . Requests.getRollupJobStats + +-- | 'getRollupCapabilities' returns the capabilities of any rollup jobs +-- configured for a given index or index pattern. Maps to +-- @GET /_rollup/data/{index}@. +-- +-- See +-- . +getRollupCapabilities :: + (MonadBH m) => + IndexPattern -> + m RollupCapabilitiesResponse +getRollupCapabilities = performBHRequest . Requests.getRollupCapabilities + +-- | 'getRollupIndexCapabilities' returns the rollup capabilities of all +-- jobs stored inside a rollup index (or index pattern). Maps to +-- @GET /{target}/_rollup/data@. +-- +-- See +-- . +getRollupIndexCapabilities :: + (MonadBH m) => + IndexName -> + m RollupCapabilitiesResponse +getRollupIndexCapabilities = + performBHRequest . Requests.getRollupIndexCapabilities + +-- | 'rollupSearchByIndex' runs a standard 'Search' against rolled-up data. +-- Maps to @GET /{index}/_rollup_search@. The response shape is the +-- standard 'SearchResult'; hits are always empty (@size@ must be @0@ or +-- omitted), so callers typically inspect 'aggregations' instead. +-- +-- See +-- . +rollupSearchByIndex :: + (FromJSON a, MonadBH m) => + IndexName -> + Search -> + m (SearchResult a) +rollupSearchByIndex indexName = + performBHRequest . Requests.rollupSearchByIndex indexName + +-- | Like 'rollupSearchByIndex' but accepts a 'SearchOptions' record for +-- URI-level parameters such as @preference@ and @routing@. +rollupSearchByIndexWith :: + (FromJSON a, MonadBH m) => + IndexName -> + SearchOptions -> + Search -> + m (SearchResult a) +rollupSearchByIndexWith indexName opts = + performBHRequest . Requests.rollupSearchByIndexWith indexName opts + +------------------------------------------------------------------------------ +-- Searchable snapshots API + +-- | 'mountSearchableSnapshot' mounts a snapshot as a searchable index. +-- Maps to @POST /_snapshot/{repository}/{snapshot}/_mount@ and returns a +-- 'SearchableSnapshotMountResponse'. +-- +-- See +-- . +mountSearchableSnapshot :: + (MonadBH m) => + SnapshotRepoName -> + SnapshotName -> + SearchableSnapshotMount -> + m SearchableSnapshotMountResponse +mountSearchableSnapshot repo snap body = + performBHRequest $ Requests.mountSearchableSnapshot repo snap body + +-- | Like 'mountSearchableSnapshot' but accepts 'SearchableSnapshotMountOptions' +-- carrying the documented URI parameters @master_timeout@, +-- @wait_for_completion@ and @storage@. +-- +-- See +-- . +mountSearchableSnapshotWith :: + (MonadBH m) => + SnapshotRepoName -> + SnapshotName -> + SearchableSnapshotMount -> + SearchableSnapshotMountOptions -> + m SearchableSnapshotMountResponse +mountSearchableSnapshotWith repo snap body opts = + performBHRequest $ Requests.mountSearchableSnapshotWith repo snap body opts + +-- | 'getSearchableSnapshotsStats' reports cluster-wide and per-index +-- searchable snapshot statistics. Maps to +-- @GET /_searchable_snapshots/stats@. +-- +-- See +-- . +getSearchableSnapshotsStats :: + (MonadBH m) => + m SearchableSnapshotsStatsResponse +getSearchableSnapshotsStats = + performBHRequest Requests.getSearchableSnapshotsStats + +-- | 'getSearchableSnapshotsCacheStats' reports cache statistics for a +-- single searchable-snapshot index. Maps to +-- @POST /_searchable_snapshots/{index}/_cache_stats@. +-- +-- See +-- . +getSearchableSnapshotsCacheStats :: + (MonadBH m) => + IndexName -> + m SearchableSnapshotsCacheStatsResponse +getSearchableSnapshotsCacheStats = + performBHRequest . Requests.getSearchableSnapshotsCacheStats + +-- | 'clearSearchableSnapshotsCache' evicts the node cache for a single +-- searchable-snapshot index. Maps to +-- @POST /_searchable_snapshots/{index}/_clear_cache@ and returns +-- 'Acknowledged' on success. +-- +-- See +-- . +clearSearchableSnapshotsCache :: + (MonadBH m) => + IndexName -> + m Acknowledged +clearSearchableSnapshotsCache = + performBHRequest . Requests.clearSearchableSnapshotsCache + +------------------------------------------------------------------------------ +-- Watcher API + +-- | 'putWatch' creates or updates a single watch by id. Maps to +-- @PUT /_watcher/watch/{id}@ and returns 'Acknowledged' on success. The +-- 'WatchBody' is carried as an opaque 'Data.Aeson.Value' — see +-- "Database.Bloodhound.Internal.Versions.Common.Types.Watcher" for the +-- rationale. +-- +-- See +-- . +putWatch :: (MonadBH m) => WatchId -> WatchBody -> m Acknowledged +putWatch wid body = performBHRequest $ Requests.putWatch wid body + +-- | 'getWatch' retrieves a single watch by id. Maps to +-- @GET /_watcher/watch/{id}@ and returns the full 'Watch' (typed envelope +-- + opaque watch DSL). A missing watch surfaces as an 'EsError'. +-- +-- See +-- . +getWatch :: (MonadBH m) => WatchId -> m Watch +getWatch = performBHRequest . Requests.getWatch + +-- | 'deleteWatch' deletes a single watch by id. Maps to +-- @DELETE /_watcher/watch/{id}@ and returns 'Acknowledged' on success. +-- +-- See +-- . +deleteWatch :: (MonadBH m) => WatchId -> m Acknowledged +deleteWatch = performBHRequest . Requests.deleteWatch + +-- | 'executeWatch' dry-runs the stored watch with the given id. Maps to +-- @POST /_watcher/watch/{id}/_execute@ with no body and returns the +-- execution record on success. Equivalent to +-- @'executeWatchWith' 'defaultExecuteWatchOptions' wid 'Nothing'@. +-- +-- See +-- . +executeWatch :: + (MonadBH m) => + WatchId -> + m ExecuteWatchResponse +executeWatch wid = + performBHRequest $ Requests.executeWatch wid + +-- | 'executeWatchWith' is the fully-parameterised form of 'executeWatch'. +-- Every URI parameter accepted by @POST /_watcher/watch/{id}/_execute@ is +-- exposed via 'ExecuteWatchOptions'; supplying a 'Just' 'ExecuteWatchRequest' +-- body runs an inline watch instead of the stored one. +executeWatchWith :: + (MonadBH m) => + ExecuteWatchOptions -> + WatchId -> + Maybe ExecuteWatchRequest -> + m ExecuteWatchResponse +executeWatchWith opts wid mBody = + performBHRequest $ Requests.executeWatchWith opts wid mBody + +-- | 'ackWatch' acknowledges the actions of a watch by id. Maps to +-- @PUT /_watcher/watch/{id}/_ack@ and returns the watch's updated +-- acknowledge state. +-- +-- See +-- . +ackWatch :: (MonadBH m) => WatchId -> m AckWatchResponse +ackWatch = performBHRequest . Requests.ackWatch + +-- | 'activateWatch' (re)activates a watch by id. Maps to +-- @PUT /_watcher/watch/{id}/_activate@ and returns the watch's updated +-- state. +-- +-- See +-- . +activateWatch :: + (MonadBH m) => + WatchId -> + m WatchStateResponse +activateWatch = performBHRequest . Requests.activateWatch + +-- | 'deactivateWatch' pauses a watch by id. Maps to +-- @PUT /_watcher/watch/{id}/_deactivate@ and returns the watch's updated +-- state. +-- +-- See +-- . +deactivateWatch :: + (MonadBH m) => + WatchId -> + m WatchStateResponse +deactivateWatch = performBHRequest . Requests.deactivateWatch + +-- | 'watcherStats' reports cluster-wide Watcher statistics. Maps to +-- @GET /_watcher/_stats@ (every metric). Equivalent to +-- @'watcherStatsWith' 'Nothing'@. +-- +-- See +-- . +watcherStats :: (MonadBH m) => m WatcherStatsResponse +watcherStats = performBHRequest Requests.watcherStats + +-- | 'watcherStatsWith' is the fully-parameterised form of 'watcherStats'. +-- Supplying 'Just' a 'WatcherStatsMetric' narrows the response to that +-- metric; 'Nothing' (or 'Just' 'WatcherStatsMetricAll') requests every +-- metric. +watcherStatsWith :: + (MonadBH m) => + Maybe WatcherStatsMetric -> + m WatcherStatsResponse +watcherStatsWith = performBHRequest . Requests.watcherStatsWith + +-- | 'getWatcherSettings' reads the cluster-wide Watcher settings. Maps to +-- @GET /_watcher/settings@. +-- +-- See +-- . +getWatcherSettings :: (MonadBH m) => m WatcherSettings +getWatcherSettings = performBHRequest Requests.getWatcherSettings + +-- | 'updateWatcherSettings' updates the cluster-wide Watcher settings. +-- Maps to @PUT /_watcher/settings@ and returns 'Acknowledged' on success. +-- +-- See +-- . +updateWatcherSettings :: + (MonadBH m) => + WatcherSettings -> + m Acknowledged +updateWatcherSettings = performBHRequest . Requests.updateWatcherSettings + +-- | 'startWatcher' starts the Watcher service cluster-wide. Maps to +-- @POST /_watcher/_start@ and returns 'Acknowledged' on success. This is +-- the inverse of 'stopWatcher'. +-- +-- See +-- . +startWatcher :: (MonadBH m) => m Acknowledged +startWatcher = performBHRequest Requests.startWatcher + +-- | 'stopWatcher' stops the Watcher service cluster-wide. Maps to +-- @POST /_watcher/_stop@ and returns 'Acknowledged' on success. In-flight +-- watch executions are allowed to finish; no new watches will fire until +-- the service is restarted (via 'startWatcher'). +-- +-- See +-- . +stopWatcher :: (MonadBH m) => m Acknowledged +stopWatcher = performBHRequest Requests.stopWatcher + +------------------------------------------------------------------------------ +-- Text structure API + +-- | 'findStructure' inspects a raw plain-text / NDJSON sample and +-- returns the inferred structure. The request body is forwarded +-- verbatim (it is /not/ JSON); see 'Requests.findStructure'. +-- +-- See +-- . +findStructure :: (MonadBH m) => L.ByteString -> m FindStructureResponse +findStructure = performBHRequest . Requests.findStructure + +-- | 'findStructureWith' is the fully-parameterised form of +-- 'findStructure'; see 'Requests.findStructureWith'. +findStructureWith :: + (MonadBH m) => + FindStructureOptions -> + L.ByteString -> + m FindStructureResponse +findStructureWith opts = + performBHRequest . Requests.findStructureWith opts + +-- | 'findMessageStructure' classifies an explicit list of log messages; +-- see 'Requests.findMessageStructure'. +-- +-- See +-- . +findMessageStructure :: + (MonadBH m) => + FindMessageStructureRequest -> + m FindStructureResponse +findMessageStructure = + performBHRequest . Requests.findMessageStructure + +-- | 'findMessageStructureWith' is the fully-parameterised form of +-- 'findMessageStructure'; see 'Requests.findMessageStructureWith'. +findMessageStructureWith :: + (MonadBH m) => + FindMessageStructureOptions -> + FindMessageStructureRequest -> + m FindStructureResponse +findMessageStructureWith opts = + performBHRequest . Requests.findMessageStructureWith opts + +-- | 'findFieldStructure' samples the stored values of a field in an +-- existing index; see 'Requests.findFieldStructure'. +-- +-- See +-- . +findFieldStructure :: + (MonadBH m) => + Text -> + Text -> + m FindStructureResponse +findFieldStructure index field = + performBHRequest $ Requests.findFieldStructure index field + +-- | 'findFieldStructureWith' is the fully-parameterised form of +-- 'findFieldStructure'; see 'Requests.findFieldStructureWith'. +findFieldStructureWith :: + (MonadBH m) => + FindFieldStructureOptions -> + m FindStructureResponse +findFieldStructureWith = + performBHRequest . Requests.findFieldStructureWith + +-- | 'testGrokPattern' compiles a grok pattern and matches it against +-- the supplied strings; see 'Requests.testGrokPattern'. +-- +-- See +-- . +testGrokPattern :: + (MonadBH m) => + TestGrokPatternRequest -> + m TestGrokPatternResponse +testGrokPattern = performBHRequest . Requests.testGrokPattern + +-- | 'testGrokPatternWith' is the fully-parameterised form of +-- 'testGrokPattern'; see 'Requests.testGrokPatternWith'. +testGrokPatternWith :: + (MonadBH m) => + TestGrokPatternOptions -> + TestGrokPatternRequest -> + m TestGrokPatternResponse +testGrokPatternWith opts = + performBHRequest . Requests.testGrokPatternWith opts + +------------------------------------------------------------------------------ +-- Transform API + +-- | 'putTransform' creates a transform. Maps to +-- @PUT /_transform/{transform_id}@ and returns 'PutTransformResponse' on +-- success. Use 'putTransformWith' to forward the @defer_validation@ or +-- @timeout@ query parameters. +-- +-- See +-- . +putTransform :: + (MonadBH m) => + TransformId -> + TransformConfig -> + m PutTransformResponse +putTransform tid config = + performBHRequest $ Requests.putTransform tid config + +-- | Like 'putTransform' but accepts 'PutTransformOptions' carrying the +-- documented @defer_validation@ and @timeout@ query parameters. +-- +-- See +-- . +putTransformWith :: + (MonadBH m) => + TransformId -> + TransformConfig -> + PutTransformOptions -> + m PutTransformResponse +putTransformWith tid config opts = + performBHRequest $ Requests.putTransformWith tid config opts + +-- | 'updateTransform' updates an existing transform. Maps to +-- @POST /_transform/{transform_id}/_update@ and returns 'Acknowledged' +-- on success. +-- +-- See +-- . +updateTransform :: + (MonadBH m) => + TransformId -> + TransformConfig -> + m Acknowledged +updateTransform tid config = + performBHRequest $ Requests.updateTransform tid config + +-- | Like 'updateTransform' but accepts 'UpdateTransformOptions' carrying +-- the documented @defer_validation@ query parameter. +-- +-- See +-- . +updateTransformWith :: + (MonadBH m) => + TransformId -> + TransformConfig -> + UpdateTransformOptions -> + m Acknowledged +updateTransformWith tid config opts = + performBHRequest $ Requests.updateTransformWith tid config opts + +-- | 'getTransforms' lists transforms. @'Nothing'@ returns every transform +-- on the cluster; @'Just' tid@ returns just that one. +-- +-- See +-- . +getTransforms :: + (MonadBH m) => + Maybe TransformId -> + m TransformsResponse +getTransforms = performBHRequest . Requests.getTransforms + +-- | Like 'getTransforms' but accepts 'GetTransformsOptions' carrying the +-- documented @from@, @size@, @allow_no_match@ and @exclude_generated@ +-- query parameters. +-- +-- See +-- . +getTransformsWith :: + (MonadBH m) => + Maybe TransformId -> + GetTransformsOptions -> + m TransformsResponse +getTransformsWith mTid opts = + performBHRequest $ Requests.getTransformsWith mTid opts + +-- | 'deleteTransform' deletes a transform by id. Maps to +-- @DELETE /_transform/{transform_id}@ and returns +-- 'DeleteTransformResponse' on success. +-- +-- See +-- . +deleteTransform :: + (MonadBH m) => + TransformId -> + m DeleteTransformResponse +deleteTransform = performBHRequest . Requests.deleteTransform + +-- | Like 'deleteTransform' but accepts 'DeleteTransformOptions' carrying +-- the documented @force@ and @delete_dest_index@ query parameters. +-- +-- See +-- . +deleteTransformWith :: + (MonadBH m) => + TransformId -> + DeleteTransformOptions -> + m DeleteTransformResponse +deleteTransformWith tid opts = + performBHRequest $ Requests.deleteTransformWith tid opts + +-- | 'startTransform' starts a transform. Maps to +-- @POST /_transform/{transform_id}/_start@ and returns 'Acknowledged' +-- on success. +-- +-- See +-- . +startTransform :: + (MonadBH m) => + TransformId -> + m Acknowledged +startTransform = performBHRequest . Requests.startTransform + +-- | Like 'startTransform' but accepts 'StartTransformOptions' carrying +-- the documented @defer_validation@ and @timeout@ query parameters. +-- +-- See +-- . +startTransformWith :: + (MonadBH m) => + TransformId -> + StartTransformOptions -> + m Acknowledged +startTransformWith tid opts = + performBHRequest $ Requests.startTransformWith tid opts + +-- | 'stopTransform' stops a transform. Maps to +-- @POST /_transform/{transform_id}/_stop@ and returns +-- 'StopTransformResponse' on success. +-- +-- See +-- . +stopTransform :: + (MonadBH m) => + TransformId -> + m StopTransformResponse +stopTransform = performBHRequest . Requests.stopTransform + +-- | Like 'stopTransform' but accepts 'StopTransformOptions' carrying the +-- documented @wait_for_checkpoint@, @wait_for_completion@, @timeout@ and +-- @allow_no_match@ query parameters. +-- +-- See +-- . +stopTransformWith :: + (MonadBH m) => + TransformId -> + StopTransformOptions -> + m StopTransformResponse +stopTransformWith tid opts = + performBHRequest $ Requests.stopTransformWith tid opts + +-- | 'previewTransform' previews a transform configuration. Maps to +-- @POST /_transform/_preview@ and returns 'PreviewTransformResponse' on +-- success. +-- +-- See +-- . +previewTransform :: + (MonadBH m) => + TransformConfig -> + m PreviewTransformResponse +previewTransform = performBHRequest . Requests.previewTransform + +-- | Like 'previewTransform' but accepts 'PreviewTransformOptions' carrying +-- the documented @timeout@ query parameter. +-- +-- See +-- . +previewTransformWith :: + (MonadBH m) => + TransformConfig -> + PreviewTransformOptions -> + m PreviewTransformResponse +previewTransformWith config opts = + performBHRequest $ Requests.previewTransformWith config opts + +-- | 'getTransformStats' reports execution statistics for transforms. +-- @'Nothing'@ returns stats for every transform; @'Just' tid@ for one. +-- +-- See +-- . +getTransformStats :: + (MonadBH m) => + Maybe TransformId -> + m TransformStatsResponse +getTransformStats = performBHRequest . Requests.getTransformStats + +-- | Like 'getTransformStats' but accepts 'GetTransformStatsOptions' +-- carrying the documented @from@, @size@ and @allow_no_match@ query +-- parameters. +-- +-- See +-- . +getTransformStatsWith :: + (MonadBH m) => + Maybe TransformId -> + GetTransformStatsOptions -> + m TransformStatsResponse +getTransformStatsWith mTid opts = + performBHRequest $ Requests.getTransformStatsWith mTid opts + +-- | 'explainTransform' explains the state of a transform. Maps to +-- @GET /_transform/{transform_id}/_explain@. +-- +-- See +-- . +explainTransform :: + (MonadBH m) => + TransformId -> + m TransformExplainResponse +explainTransform = performBHRequest . Requests.explainTransform + +-- | 'getMigrationDeprecations' lists the deprecation warnings that would +-- affect a major-version upgrade. +-- +-- * @'Nothing'@ → @GET /_migration/deprecations@ scans every index, +-- data stream, template, ILM policy and cluster\/node\/ML setting. +-- * @'Just' ix@ → @GET /{ix}/_migration/deprecations@ restricts the +-- @index_settings@ section to the supplied index. +-- +-- See +-- . +getMigrationDeprecations :: + (MonadBH m) => + Maybe IndexName -> + m MigrationDeprecations +getMigrationDeprecations = performBHRequest . Requests.getMigrationDeprecations + +-- | 'getSystemFeatures' reports the migration status of every ES +-- feature that stores versioned configuration. Maps to +-- @GET /_migration/system_features@. +-- +-- See +-- . +getSystemFeatures :: (MonadBH m) => m FeatureUpgradeStatus +getSystemFeatures = performBHRequest Requests.getSystemFeatures + +-- | 'upgradeSystemFeatures' kicks off the feature upgrade. Maps to +-- @POST /_migration/system_features@ and returns 'Acknowledged' on +-- success. The upgrade runs in the background; poll 'getSystemFeatures' +-- to observe progress. Mutates cluster state — call deliberately. +-- +-- See +-- . +upgradeSystemFeatures :: (MonadBH m) => m Acknowledged +upgradeSystemFeatures = performBHRequest Requests.upgradeSystemFeatures + +-- | 'deleteAsyncSearch' deletes an async search result and its context by id. +-- Maps to @DELETE /_async_search/{id}@ and returns 'Acknowledged' on success. +-- +-- See +-- . +deleteAsyncSearch :: (MonadBH m) => AsyncSearchId -> m Acknowledged +deleteAsyncSearch = performBHRequest . Requests.deleteAsyncSearch + +-- | 'submitAsyncSearch' submits a 'Search' for asynchronous execution, +-- returning immediately with an id and partial results. See +-- . +submitAsyncSearch :: + forall a m. + (FromJSON a, MonadBH m) => + Search -> + m (AsyncSearchResult a) +submitAsyncSearch = performBHRequest . Requests.submitAsyncSearch + +-- | Like 'submitAsyncSearch' but accepts 'AsyncSearchSubmitOptions' +-- carrying the URI parameters documented for @POST /_async_search@ +-- (@wait_for_completion@, @keep_on_completion@, @keep_alive@, +-- @batched_reduce_size@, @ccs_minimize_roundtrips@). +-- 'defaultAsyncSearchSubmitOptions' makes this byte-for-byte equivalent +-- to 'submitAsyncSearch'. +submitAsyncSearchWith :: + forall a m. + (FromJSON a, MonadBH m) => + AsyncSearchSubmitOptions -> + Search -> + m (AsyncSearchResult a) +submitAsyncSearchWith opts = performBHRequest . Requests.submitAsyncSearchWith opts diff --git a/src/Database/Bloodhound/Common/Requests.hs b/src/Database/Bloodhound/Common/Requests.hs --- a/src/Database/Bloodhound/Common/Requests.hs +++ b/src/Database/Bloodhound/Common/Requests.hs @@ -19,1156 +19,8514 @@ -- ** Indices createIndex, - createIndexWith, - flushIndex, - deleteIndex, - updateIndexSettings, - getIndexSettings, - forceMergeIndex, - indexExists, - openIndex, - closeIndex, - listIndices, - catIndices, - waitForYellowIndex, - HealthStatus (..), - - -- *** Index Aliases - updateIndexAliases, - getIndexAliases, - deleteIndexAlias, - - -- *** Index Templates - putTemplate, - templateExists, - deleteTemplate, - - -- ** Mapping - putMapping, - - -- ** Documents - indexDocument, - updateDocument, - updateByQuery, - getDocument, - documentExists, - deleteDocument, - deleteByQuery, - IndexedDocument (..), - DeletedDocuments (..), - DeletedDocumentsRetries (..), - - -- ** Searching - searchAll, - searchByIndex, - searchByIndices, - searchByIndexTemplate, - searchByIndicesTemplate, - getInitialScroll, - getInitialSortedScroll, - advanceScroll, - refreshIndex, - mkSearch, - mkAggregateSearch, - mkHighlightSearch, - mkSearchTemplate, - bulk, - pageSearch, - mkShardCount, - mkReplicaCount, - getStatus, - dispatchSearch, - - -- ** Templates - storeSearchTemplate, - getSearchTemplate, - deleteSearchTemplate, - - -- ** Snapshot/Restore - - -- *** Snapshot Repos - getSnapshotRepos, - updateSnapshotRepo, - verifySnapshotRepo, - deleteSnapshotRepo, - - -- *** Snapshots - createSnapshot, - getSnapshots, - deleteSnapshot, - - -- *** Restoring Snapshots - restoreSnapshot, - - -- *** Reindex - reindex, - reindexAsync, - - -- *** Task - getTask, - - -- ** Nodes - getNodesInfo, - getNodesStats, - - -- ** Request Utilities - encodeBulkOperations, - encodeBulkOperation, - - -- * BHResponse-handling tools - isVersionConflict, - isSuccess, - isCreated, - parseEsResponse, - parseEsResponseWith, - decodeResponse, - eitherDecodeResponse, - - -- * Count - countByIndex, - - -- * Generic - Acknowledged (..), - Accepted (..), - IgnoredBody (..), - - -- * Performing Requests - tryPerformBHRequest, - performBHRequest, - withBHResponse, - withBHResponse_, - withBHResponseParsedEsResponse, - keepBHResponse, - joinBHResponse, - ) -where - -import Control.Applicative as A -import Control.Monad -import Data.Aeson -import Data.Aeson.Key -import qualified Data.Aeson.KeyMap as X -import Data.ByteString.Builder -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Foldable (toList) -import qualified Data.List as LS (foldl') -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (catMaybes) -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock -import qualified Data.Vector as V -import Database.Bloodhound.Client.Cluster -import Database.Bloodhound.Common.Types -import Database.Bloodhound.Internal.Utils.Imports (showText) -import Database.Bloodhound.Internal.Utils.Requests -import Prelude hiding (filter, head) - --- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount' --- which rejects 'Int' values below 1 and above 1000. --- --- >>> mkShardCount 10 --- Just (ShardCount 10) -mkShardCount :: Int -> Maybe ShardCount -mkShardCount n - | n < 1 = Nothing - | n > 1000 = Nothing - | otherwise = Just (ShardCount n) - --- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount' --- which rejects 'Int' values below 0 and above 1000. --- --- >>> mkReplicaCount 10 --- Just (ReplicaCount 10) -mkReplicaCount :: Int -> Maybe ReplicaCount -mkReplicaCount n - | n < 0 = Nothing - | n > 1000 = Nothing -- ... - | otherwise = Just (ReplicaCount n) - --- | 'getStatus' fetches the 'Status' of a 'Server' --- --- >>> serverStatus <- runBH' getStatus --- >>> fmap tagline (serverStatus) --- Just "You Know, for Search" -getStatus :: BHRequest StatusDependant Status -getStatus = get [] - --- | 'getSnapshotRepos' gets the definitions of a subset of the --- defined snapshot repos. -getSnapshotRepos :: SnapshotRepoSelection -> BHRequest StatusDependant [GenericSnapshotRepo] -getSnapshotRepos sel = - unGSRs <$> get ["_snapshot", selectorSeg] - where - selectorSeg = case sel of - AllSnapshotRepos -> "_all" - SnapshotRepoList (p :| ps) -> T.intercalate "," (renderPat <$> (p : ps)) - renderPat (RepoPattern t) = t - renderPat (ExactRepo (SnapshotRepoName t)) = t - --- | Wrapper to extract the list of 'GenericSnapshotRepo' in the --- format they're returned in -newtype GSRs = GSRs {unGSRs :: [GenericSnapshotRepo]} - -instance FromJSON GSRs where - parseJSON = withObject "Collection of GenericSnapshotRepo" parse - where - parse = fmap GSRs . mapM (uncurry go) . X.toList - go rawName = withObject "GenericSnapshotRepo" $ \o -> - GenericSnapshotRepo (SnapshotRepoName $ toText rawName) - <$> o - .: "type" - <*> o - .: "settings" - --- | Create or update a snapshot repo -updateSnapshotRepo :: - (SnapshotRepo repo) => - -- | Use 'defaultSnapshotRepoUpdateSettings' if unsure - SnapshotRepoUpdateSettings -> - repo -> - BHRequest StatusIndependant Acknowledged -updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo = - put endpoint (encode body) - where - endpoint = ["_snapshot", snapshotRepoName gSnapshotRepoName] `withQueries` params - params - | repoUpdateVerify = [] - | otherwise = [("verify", Just "false")] - body = - object - [ "type" .= gSnapshotRepoType, - "settings" .= gSnapshotRepoSettings - ] - GenericSnapshotRepo {..} = toGSnapshotRepo repo - --- | Verify if a snapshot repo is working. __NOTE:__ this API did not --- make it into Elasticsearch until 1.4. If you use an older version, --- you will get an error here. -verifySnapshotRepo :: SnapshotRepoName -> BHRequest StatusDependant SnapshotVerification -verifySnapshotRepo (SnapshotRepoName n) = - post ["_snapshot", n, "_verify"] emptyBody - -deleteSnapshotRepo :: SnapshotRepoName -> BHRequest StatusIndependant Acknowledged -deleteSnapshotRepo (SnapshotRepoName n) = - delete ["_snapshot", n] - --- | Create and start a snapshot -createSnapshot :: - SnapshotRepoName -> - SnapshotName -> - SnapshotCreateSettings -> - BHRequest StatusIndependant Acknowledged -createSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) SnapshotCreateSettings {..} = - put endpoint body - where - endpoint = ["_snapshot", repoName, snapName] `withQueries` params - params = [("wait_for_completion", Just (boolQP snapWaitForCompletion))] - body = encode $ object prs - prs = - catMaybes - [ ("indices" .=) . indexSelectionName <$> snapIndices, - Just ("ignore_unavailable" .= snapIgnoreUnavailable), - Just ("ignore_global_state" .= snapIncludeGlobalState), - Just ("partial" .= snapPartial) - ] - -indexSelectionName :: IndexSelection -> Text -indexSelectionName AllIndexes = "_all" -indexSelectionName (IndexList (i :| is)) = T.intercalate "," (unIndexName <$> (i : is)) - --- | Get info about known snapshots given a pattern and repo name. -getSnapshots :: SnapshotRepoName -> SnapshotSelection -> BHRequest StatusDependant [SnapshotInfo] -getSnapshots (SnapshotRepoName repoName) sel = - unSIs <$> get ["_snapshot", repoName, snapPath] - where - snapPath = case sel of - AllSnapshots -> "_all" - SnapshotList (s :| ss) -> T.intercalate "," (renderPath <$> (s : ss)) - renderPath (SnapPattern t) = t - renderPath (ExactSnap (SnapshotName t)) = t - -newtype SIs = SIs {unSIs :: [SnapshotInfo]} - -instance FromJSON SIs where - parseJSON = withObject "Collection of SnapshotInfo" parse - where - parse o = SIs <$> o .: "snapshots" - --- | Delete a snapshot. Cancels if it is running. -deleteSnapshot :: SnapshotRepoName -> SnapshotName -> BHRequest StatusIndependant Acknowledged -deleteSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) = - delete ["_snapshot", repoName, snapName] - --- | Restore a snapshot to the cluster See --- --- for more details. -restoreSnapshot :: - SnapshotRepoName -> - SnapshotName -> - -- | Start with 'defaultSnapshotRestoreSettings' and customize - -- from there for reasonable defaults. - SnapshotRestoreSettings -> - BHRequest StatusIndependant Accepted -restoreSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) SnapshotRestoreSettings {..} = - post endpoint (encode body) - where - endpoint = ["_snapshot", repoName, snapName, "_restore"] `withQueries` params - params = [("wait_for_completion", Just (boolQP snapRestoreWaitForCompletion))] - body = - object $ - catMaybes - [ ("indices" .=) . indexSelectionName <$> snapRestoreIndices, - Just ("ignore_unavailable" .= snapRestoreIgnoreUnavailable), - Just ("include_global_state" .= snapRestoreIncludeGlobalState), - ("rename_pattern" .=) <$> snapRestoreRenamePattern, - ("rename_replacement" .=) . renderTokens <$> snapRestoreRenameReplacement, - Just ("include_aliases" .= snapRestoreIncludeAliases), - ("index_settings" .=) <$> snapRestoreIndexSettingsOverrides, - ("ignore_index_settings" .=) <$> snapRestoreIgnoreIndexSettings - ] - renderTokens (t :| ts) = mconcat (renderToken <$> (t : ts)) - renderToken (RRTLit t) = t - renderToken RRSubWholeMatch = "$0" - renderToken (RRSubGroup g) = T.pack (show (rrGroupRefNum g)) - -getNodesInfo :: NodeSelection -> BHRequest StatusDependant NodesInfo -getNodesInfo sel = - get ["_nodes", selectionSeg] - where - selectionSeg = case sel of - LocalNode -> "_local" - NodeList (l :| ls) -> T.intercalate "," (selToSeg <$> (l : ls)) - AllNodes -> "_all" - selToSeg (NodeByName (NodeName n)) = n - selToSeg (NodeByFullNodeId (FullNodeId i)) = i - selToSeg (NodeByHost (Server s)) = s - selToSeg (NodeByAttribute (NodeAttrName a) v) = a <> ":" <> v - -getNodesStats :: NodeSelection -> BHRequest StatusDependant NodesStats -getNodesStats sel = - get ["_nodes", selectionSeg, "stats"] - where - selectionSeg = case sel of - LocalNode -> "_local" - NodeList (l :| ls) -> T.intercalate "," (selToSeg <$> (l : ls)) - AllNodes -> "_all" - selToSeg (NodeByName (NodeName n)) = n - selToSeg (NodeByFullNodeId (FullNodeId i)) = i - selToSeg (NodeByHost (Server s)) = s - selToSeg (NodeByAttribute (NodeAttrName a) v) = a <> ":" <> v - --- | 'createIndex' will create an index given a 'Server', 'IndexSettings', and an 'IndexName'. --- --- >>> response <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex") --- >>> isSuccess response --- True --- >>> runBH' $ indexExists (IndexName "didimakeanindex") --- True -createIndex :: IndexSettings -> IndexName -> BHRequest StatusDependant Acknowledged -createIndex indexSettings indexName = - put [unIndexName indexName] $ encode indexSettings - --- | Create an index, providing it with any number of settings. This --- is more expressive than 'createIndex' but makes is more verbose --- for the common case of configuring only the shard count and --- replica count. -createIndexWith :: - [UpdatableIndexSetting] -> - -- | shard count - Int -> - IndexName -> - BHRequest StatusIndependant Acknowledged -createIndexWith updates shards indexName = - put [unIndexName indexName] body - where - body = - encode $ - object - [ "settings" - .= deepMerge - ( X.singleton "index.number_of_shards" (toJSON shards) - : [u | Object u <- toJSON <$> updates] - ) - ] - --- | 'flushIndex' will flush an index given a 'Server' and an 'IndexName'. -flushIndex :: IndexName -> BHRequest StatusDependant ShardResult -flushIndex indexName = - post [unIndexName indexName, "_flush"] emptyBody - --- | 'deleteIndex' will delete an index given a 'Server' and an 'IndexName'. --- --- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex") --- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex") --- >>> isSuccess response --- True --- >>> runBH' $ indexExists (IndexName "didimakeanindex") --- False -deleteIndex :: IndexName -> BHRequest StatusDependant Acknowledged -deleteIndex indexName = - delete [unIndexName indexName] - --- | 'updateIndexSettings' will apply a non-empty list of setting updates to an index --- --- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "unconfiguredindex") --- >>> response <- runBH' $ updateIndexSettings (BlocksWrite False :| []) (IndexName "unconfiguredindex") --- >>> isSuccess response --- True -updateIndexSettings :: - NonEmpty UpdatableIndexSetting -> - IndexName -> - BHRequest StatusIndependant Acknowledged -updateIndexSettings updates indexName = - put [unIndexName indexName, "_settings"] (encode body) - where - body = Object (deepMerge [u | Object u <- toJSON <$> toList updates]) - -getIndexSettings :: IndexName -> BHRequest StatusDependant IndexSettingsSummary -getIndexSettings indexName = - get [unIndexName indexName, "_settings"] - --- | 'forceMergeIndex' --- --- The force merge API allows to force merging of one or more indices through --- an API. The merge relates to the number of segments a Lucene index holds --- within each shard. The force merge operation allows to reduce the number of --- segments by merging them. --- --- This call will block until the merge is complete. If the http connection is --- lost, the request will continue in the background, and any new requests will --- block until the previous force merge is complete. - --- For more information see --- . --- Nothing --- worthwhile comes back in the response body, so matching on the status --- should suffice. --- --- 'forceMergeIndex' with a maxNumSegments of 1 and onlyExpungeDeletes --- to True is the main way to release disk space back to the OS being --- held by deleted documents. --- --- >>> let ixn = IndexName "unoptimizedindex" --- >>> _ <- runBH' $ deleteIndex ixn >> createIndex defaultIndexSettings ixn --- >>> response <- runBH' $ forceMergeIndex (IndexList (ixn :| [])) (defaultIndexOptimizationSettings { maxNumSegments = Just 1, onlyExpungeDeletes = True }) --- >>> isSuccess response --- True -forceMergeIndex :: IndexSelection -> ForceMergeIndexSettings -> BHRequest StatusDependant ShardsResult -forceMergeIndex ixs ForceMergeIndexSettings {..} = - post endpoint emptyBody - where - endpoint = [indexName, "_forcemerge"] `withQueries` params - params = - catMaybes - [ ("max_num_segments",) . Just . showText <$> maxNumSegments, - Just ("only_expunge_deletes", Just (boolQP onlyExpungeDeletes)), - Just ("flush", Just (boolQP flushAfterOptimize)) - ] - indexName = indexSelectionName ixs - -deepMerge :: [Object] -> Object -deepMerge = LS.foldl' (X.unionWith merge) mempty - where - merge (Object a) (Object b) = Object (deepMerge [a, b]) - merge _ b = b - -doesExist :: Endpoint -> BHRequest StatusDependant Bool -doesExist = - withBHResponse_ isSuccess . head' @StatusDependant @IgnoredBody - --- | 'indexExists' enables you to check if an index exists. Returns 'Bool' --- in IO --- --- >>> exists <- runBH' $ indexExists testIndex -indexExists :: IndexName -> BHRequest StatusDependant Bool -indexExists indexName = - doesExist [unIndexName indexName] - --- | 'refreshIndex' will force a refresh on an index. You must --- do this if you want to read what you wrote. --- --- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex --- >>> _ <- runBH' $ refreshIndex testIndex -refreshIndex :: IndexName -> BHRequest StatusDependant ShardResult -refreshIndex indexName = - post [unIndexName indexName, "_refresh"] emptyBody - --- | Block until the index becomes available for indexing --- documents. This is useful for integration tests in which --- indices are rapidly created and deleted. -waitForYellowIndex :: IndexName -> BHRequest StatusIndependant HealthStatus -waitForYellowIndex indexName = - get endpoint - where - endpoint = ["_cluster", "health", unIndexName indexName] `withQueries` params - params = [("wait_for_status", Just "yellow"), ("timeout", Just "10s")] - -openOrCloseIndexes :: OpenCloseIndex -> IndexName -> BHRequest StatusIndependant Acknowledged -openOrCloseIndexes oci indexName = - post [unIndexName indexName, stringifyOCIndex] emptyBody - where - stringifyOCIndex = case oci of - OpenIndex -> "_open" - CloseIndex -> "_close" - --- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at --- --- --- >>> response <- runBH' $ openIndex testIndex -openIndex :: IndexName -> BHRequest StatusIndependant Acknowledged -openIndex = openOrCloseIndexes OpenIndex - --- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at --- --- --- >>> response <- runBH' $ closeIndex testIndex -closeIndex :: IndexName -> BHRequest StatusIndependant Acknowledged -closeIndex = openOrCloseIndexes CloseIndex - --- | 'listIndices' returns a list of all index names on a given 'Server' -listIndices :: BHRequest StatusDependant [IndexName] -listIndices = - map unListedIndexName <$> get ["_cat/indices?format=json"] - -newtype ListedIndexName = ListedIndexName {unListedIndexName :: IndexName} - deriving stock (Eq, Show) - -instance FromJSON ListedIndexName where - parseJSON = - withObject "ListedIndexName" $ \o -> - ListedIndexName <$> o .: "index" - --- | 'catIndices' returns a list of all index names on a given 'Server' as well as their doc counts -catIndices :: BHRequest StatusDependant [(IndexName, Int)] -catIndices = - map unListedIndexNameWithCount <$> get ["_cat/indices?format=json"] - -newtype ListedIndexNameWithCount = ListedIndexNameWithCount {unListedIndexNameWithCount :: (IndexName, Int)} - deriving stock (Eq, Show) - -instance FromJSON ListedIndexNameWithCount where - parseJSON = - withObject "ListedIndexNameWithCount" $ \o -> do - xs <- (,) <$> o .: "index" <*> o .: "docs.count" - return $ ListedIndexNameWithCount xs - --- | 'updateIndexAliases' updates the server's index alias --- table. Operations are atomic. Explained in further detail at --- --- --- >>> let src = IndexName "a-real-index" --- >>> let aliasName = IndexName "an-alias" --- >>> let iAlias = IndexAlias src (IndexAliasName aliasName) --- >>> let aliasCreate = IndexAliasCreate Nothing Nothing --- >>> _ <- runBH' $ deleteIndex src --- >>> isSuccess <$> runBH' (createIndex defaultIndexSettings src) --- True --- >>> runBH' $ indexExists src --- True --- >>> isSuccess <$> runBH' (updateIndexAliases (AddAlias iAlias aliasCreate :| [])) --- True --- >>> runBH' $ indexExists aliasName --- True -updateIndexAliases :: NonEmpty IndexAliasAction -> BHRequest StatusIndependant Acknowledged -updateIndexAliases actions = - post ["_aliases"] (encode body) - where - body = object ["actions" .= toList actions] - --- | Get all aliases configured on the server. -getIndexAliases :: BHRequest StatusDependant IndexAliasesSummary -getIndexAliases = - get ["_aliases"] - --- | Delete a single alias, removing it from all indices it --- is currently associated with. -deleteIndexAlias :: IndexAliasName -> BHRequest StatusIndependant Acknowledged -deleteIndexAlias (IndexAliasName name) = - delete ["_all", "_alias", unIndexName name] - --- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'. --- Explained in further detail at --- --- --- >>> let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping] --- >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl") -putTemplate :: IndexTemplate -> TemplateName -> BHRequest StatusIndependant Acknowledged -putTemplate indexTemplate (TemplateName templateName) = - put ["_template", templateName] (encode indexTemplate) - --- | 'templateExists' checks to see if a template exists. --- --- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl") -templateExists :: TemplateName -> BHRequest StatusDependant Bool -templateExists (TemplateName templateName) = - doesExist ["_template", templateName] - --- | 'deleteTemplate' is an HTTP DELETE and deletes a template. --- --- >>> let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping] --- >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl") --- >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl") -deleteTemplate :: TemplateName -> BHRequest StatusIndependant Acknowledged -deleteTemplate (TemplateName templateName) = - delete ["_template", templateName] - --- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas --- for documents in indexes. --- --- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex --- >>> resp <- runBH' $ putMapping testIndex TweetMapping --- >>> print resp --- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("content-type","application/json; charset=UTF-8"),("content-encoding","gzip"),("transfer-encoding","chunked")], responseBody = "{\"acknowledged\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} -putMapping :: (FromJSON r, ToJSON a) => IndexName -> a -> BHRequest StatusDependant r -putMapping indexName mapping = - -- "_mapping" above is originally transposed - -- erroneously. The correct API call is: "/INDEX/_mapping" - put [unIndexName indexName, "_mapping"] (encode mapping) -{-# DEPRECATED putMapping "See " #-} - -versionCtlParams :: IndexDocumentSettings -> [(Text, Maybe Text)] -versionCtlParams cfg = - case idsVersionControl cfg of - NoVersionControl -> [] - InternalVersion v -> versionParams v "internal" - ExternalGT (ExternalDocVersion v) -> versionParams v "external_gt" - ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte" - ForceVersion (ExternalDocVersion v) -> versionParams v "force" - where - vt = showText . docVersionNumber - versionParams :: DocVersion -> Text -> [(Text, Maybe Text)] - versionParams v t = - [ ("version", Just $ vt v), - ("version_type", Just t) - ] - --- | 'indexDocument' is the primary way to save a single document in --- Elasticsearch. The document itself is simply something we can --- convert into a JSON 'Value'. The 'DocId' will function as the --- primary key for the document. You are encouraged to generate --- your own id's and not rely on Elasticsearch's automatic id --- generation. Read more about it here: --- https://github.com/bitemyapp/bloodhound/issues/107 --- --- >>> resp <- runBH' $ indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1") --- >>> print resp --- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("content-type","application/json; charset=UTF-8"),("content-encoding","gzip"),("content-length","152")], responseBody = "{\"_index\":\"twitter\",\"_type\":\"_doc\",\"_id\":\"1\",\"_version\":2,\"result\":\"updated\",\"_shards\":{\"total\":1,\"successful\":1,\"failed\":0},\"_seq_no\":1,\"_primary_term\":1}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} -indexDocument :: - (ToJSON doc) => - IndexName -> - IndexDocumentSettings -> - doc -> - DocId -> - BHRequest StatusDependant IndexedDocument -indexDocument indexName cfg document (DocId docId) = - put endpoint (encode body) - where - endpoint = [unIndexName indexName, "_doc", docId] `withQueries` indexQueryString cfg (DocId docId) - body = encodeDocument cfg document - --- | 'updateDocument' provides a way to perform an partial update of a --- an already indexed document. -updateDocument :: - (ToJSON patch) => - IndexName -> - IndexDocumentSettings -> - patch -> - DocId -> - BHRequest StatusDependant IndexedDocument -updateDocument indexName cfg patch (DocId docId) = - post endpoint (encode body) - where - endpoint = [unIndexName indexName, "_update", docId] `withQueries` indexQueryString cfg (DocId docId) - body = object ["doc" .= encodeDocument cfg patch] - -updateByQuery :: - (FromJSON a) => - IndexName -> - Query -> - Maybe Script -> - BHRequest StatusDependant a -updateByQuery indexName q mScript = - post endpoint (encode body) - where - endpoint = [unIndexName indexName, "_update_by_query"] - body = Object $ ("query" .= q) <> scriptObject - scriptObject :: X.KeyMap Value - scriptObject = case toJSON mScript of - Null -> mempty - Object o -> o - x -> "script" .= x - -{- From ES docs: - Parent and child documents must be indexed on the same shard. - This means that the same routing value needs to be provided when getting, deleting, or updating a child document. - - Parent/Child support in Bloodhound requires MUCH more love. - To work it around for now (and to support the existing unit test) we route "parent" documents to their "_id" - (which is the default strategy for the ES), and route all child documents to their parens' "_id" - - However, it may not be flexible enough for some corner cases. - - Buld operations are completely unaware of "routing" and are probably broken in that matter. - Or perhaps they always were, because the old "_parent" would also have this requirement. --} -indexQueryString :: IndexDocumentSettings -> DocId -> [(Text, Maybe Text)] -indexQueryString cfg (DocId docId) = - versionCtlParams cfg <> routeParams - where - routeParams = case idsJoinRelation cfg of - Nothing -> [] - Just (ParentDocument _ _) -> [("routing", Just docId)] - Just (ChildDocument _ _ (DocId pid)) -> [("routing", Just pid)] - -encodeDocument :: (ToJSON doc) => IndexDocumentSettings -> doc -> Value -encodeDocument cfg document = - case idsJoinRelation cfg of - Nothing -> toJSON document - Just (ParentDocument (FieldName field) name) -> - mergeObjects (toJSON document) (object [fromText field .= name]) - Just (ChildDocument (FieldName field) name parent) -> - mergeObjects (toJSON document) (object [fromText field .= object ["name" .= name, "parent" .= parent]]) - where - mergeObjects (Object a) (Object b) = Object (a <> b) - mergeObjects _ _ = error "Impossible happened: both document body and join parameters must be objects" - --- | 'deleteDocument' is the primary way to delete a single document. --- --- >>> _ <- runBH' $ deleteDocument testIndex (DocId "1") -deleteDocument :: IndexName -> DocId -> BHRequest StatusDependant IndexedDocument -deleteDocument indexName (DocId docId) = - delete [unIndexName indexName, "_doc", docId] - --- | 'deleteByQuery' performs a deletion on every document that matches a query. --- --- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing --- >>> _ <- runBH' $ deleteDocument testIndex query -deleteByQuery :: IndexName -> Query -> BHRequest StatusDependant DeletedDocuments -deleteByQuery indexName query = - post [unIndexName indexName, "_delete_by_query"] (encode body) - where - body = object ["query" .= query] - --- | 'bulk' uses --- --- to perform bulk operations. The 'BulkOperation' data type encodes the --- index\/update\/delete\/create operations. You pass a 'V.Vector' of 'BulkOperation's --- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch --- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead. --- --- >>> let stream = V.fromList [BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah"))] --- >>> _ <- runBH' $ bulk stream --- >>> _ <- runBH' $ refreshIndex testIndex -bulk :: - (ParseBHResponse contextualized) => - V.Vector BulkOperation -> - BHRequest contextualized BulkResponse -bulk = - post ["_bulk"] . encodeBulkOperations - --- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation' --- into an 'L.ByteString' --- --- >>> let bulkOps = V.fromList [BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah"))] --- >>> encodeBulkOperations bulkOps --- "\n{\"index\":{\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}\n" -encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString -encodeBulkOperations stream = collapsed - where - blobs = - fmap encodeBulkOperation stream - mashedTaters = - mash (mempty :: Builder) blobs - collapsed = - toLazyByteString $ mappend mashedTaters (byteString "\n") - mash :: Builder -> V.Vector L.ByteString -> Builder - mash = V.foldl' (\b x -> b <> byteString "\n" <> lazyByteString x) - -mkBulkStreamValue :: Text -> IndexName -> Text -> Value -mkBulkStreamValue operation indexName docId = - object - [ fromText operation - .= object - [ "_index" .= indexName, - "_id" .= docId - ] - ] - -mkBulkStreamValueAuto :: Text -> IndexName -> Value -mkBulkStreamValueAuto operation indexName = - object - [ fromText operation - .= object ["_index" .= indexName] - ] - -mkBulkStreamValueWithMeta :: [UpsertActionMetadata] -> Text -> IndexName -> Text -> Value -mkBulkStreamValueWithMeta meta operation indexName docId = - object - [ fromText operation - .= object - ( [ "_index" .= indexName, - "_id" .= docId - ] - <> (buildUpsertActionMetadata <$> meta) - ) - ] - --- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation' --- into an 'L.ByteString' --- --- >>> let bulkOp = BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah")) --- >>> encodeBulkOperation bulkOp --- "{\"index\":{\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}" -encodeBulkOperation :: BulkOperation -> L.ByteString -encodeBulkOperation (BulkIndex indexName (DocId docId) value) = blob - where - metadata = mkBulkStreamValue "index" indexName docId - blob = encode metadata `mappend` "\n" `mappend` encode value -encodeBulkOperation (BulkIndexAuto indexName value) = blob - where - metadata = mkBulkStreamValueAuto "index" indexName - blob = encode metadata `mappend` "\n" `mappend` encode value -encodeBulkOperation (BulkIndexEncodingAuto indexName encoding) = toLazyByteString blob - where - metadata = toEncoding (mkBulkStreamValueAuto "index" indexName) - blob = fromEncoding metadata <> "\n" <> fromEncoding encoding -encodeBulkOperation (BulkCreate indexName (DocId docId) value) = blob - where - metadata = mkBulkStreamValue "create" indexName docId - blob = encode metadata `mappend` "\n" `mappend` encode value -encodeBulkOperation (BulkDelete indexName (DocId docId)) = blob - where - metadata = mkBulkStreamValue "delete" indexName docId - blob = encode metadata -encodeBulkOperation (BulkUpdate indexName (DocId docId) value) = blob - where - metadata = mkBulkStreamValue "update" indexName docId - doc = object ["doc" .= value] - blob = encode metadata `mappend` "\n" `mappend` encode doc -encodeBulkOperation - ( BulkUpsert - indexName - (DocId docId) - payload - actionMeta - ) = blob - where - metadata = mkBulkStreamValueWithMeta actionMeta "update" indexName docId - blob = encode metadata <> "\n" <> encode doc - doc = case payload of - UpsertDoc value -> object ["doc" .= value, "doc_as_upsert" .= True] - UpsertScript scriptedUpsert script value -> - let scup = if scriptedUpsert then ["scripted_upsert" .= True] else [] - upsert = ["upsert" .= value] - in case (object (scup <> upsert), toJSON script) of - (Object obj, Object jscript) -> Object $ jscript <> obj - _ -> error "Impossible happened: serialising Script to Json should always be Object" -encodeBulkOperation (BulkCreateEncoding indexName (DocId docId) encoding) = - toLazyByteString blob - where - metadata = toEncoding (mkBulkStreamValue "create" indexName docId) - blob = fromEncoding metadata <> "\n" <> fromEncoding encoding - --- | 'getDocument' is a straight-forward way to fetch a single document from --- Elasticsearch using a 'Server', 'IndexName', and a 'DocId'. --- The 'DocId' is the primary key for your Elasticsearch document. --- --- >>> yourDoc <- runBH' $ getDocument testIndex (DocId "1") -getDocument :: (FromJSON a) => IndexName -> DocId -> BHRequest StatusIndependant (EsResult a) -getDocument indexName (DocId docId) = - get [unIndexName indexName, "_doc", docId] - --- | 'documentExists' enables you to check if a document exists. -documentExists :: IndexName -> DocId -> BHRequest StatusDependant Bool -documentExists indexName (DocId docId) = - doesExist [unIndexName indexName, "_doc", docId] - -dispatchSearch :: (FromJSON a) => Endpoint -> Search -> BHRequest StatusDependant (SearchResult a) -dispatchSearch endpoint search = - post url' (encode search) - where - url' = appendSearchTypeParam endpoint (searchType search) - appendSearchTypeParam :: Endpoint -> SearchType -> Endpoint - appendSearchTypeParam originalUrl st = originalUrl `withQueries` params - where - stText = "search_type" - params - | st == SearchTypeDfsQueryThenFetch = [(stText, Just "dfs_query_then_fetch")] - -- used to catch 'SearchTypeQueryThenFetch', which is also the default - | otherwise = [] - --- | 'searchAll', given a 'Search', will perform that search against all indexes --- on an Elasticsearch server. Try to avoid doing this if it can be helped. --- --- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing --- >>> let search = mkSearch (Just query) Nothing --- >>> response <- runBH' $ searchAll search -searchAll :: (FromJSON a) => Search -> BHRequest StatusDependant (SearchResult a) -searchAll = - dispatchSearch ["_search"] - --- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search --- within an index on an Elasticsearch server. --- --- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing --- >>> let search = mkSearch (Just query) Nothing --- >>> response <- runBH' $ searchByIndex testIndex search -searchByIndex :: (FromJSON a) => IndexName -> Search -> BHRequest StatusDependant (SearchResult a) -searchByIndex indexName = - dispatchSearch [unIndexName indexName, "_search"] - --- | 'searchByIndices' is a variant of 'searchByIndex' that executes a --- 'Search' over many indices. This is much faster than using --- 'mapM' to 'searchByIndex' over a collection since it only --- causes a single HTTP request to be emitted. -searchByIndices :: (FromJSON a) => NonEmpty IndexName -> Search -> BHRequest StatusDependant (SearchResult a) -searchByIndices ixs = - dispatchSearch [renderedIxs, "_search"] - where - renderedIxs = T.intercalate (T.singleton ',') (map unIndexName (toList ixs)) - -dispatchSearchTemplate :: - (FromJSON a) => - Endpoint -> - SearchTemplate -> - BHRequest StatusDependant (SearchResult a) -dispatchSearchTemplate endpoint search = - post endpoint $ encode search - --- | 'searchByIndexTemplate', given a 'SearchTemplate' and an 'IndexName', will perform that search --- within an index on an Elasticsearch server. --- --- >>> let query = SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } }, \"size\" : \"{{my_size}}\"}" --- >>> let search = mkSearchTemplate (Right query) Nothing --- >>> response <- runBH' $ searchByIndexTemplate testIndex search -searchByIndexTemplate :: - (FromJSON a) => - IndexName -> - SearchTemplate -> - BHRequest StatusDependant (SearchResult a) -searchByIndexTemplate indexName = - dispatchSearchTemplate [unIndexName indexName, "_search", "template"] - --- | 'searchByIndicesTemplate' is a variant of 'searchByIndexTemplate' that executes a --- 'SearchTemplate' over many indices. This is much faster than using --- 'mapM' to 'searchByIndexTemplate' over a collection since it only --- causes a single HTTP request to be emitted. -searchByIndicesTemplate :: - (FromJSON a) => - NonEmpty IndexName -> - SearchTemplate -> - BHRequest StatusDependant (SearchResult a) -searchByIndicesTemplate ixs = - dispatchSearchTemplate [renderedIxs, "_search", "template"] - where - renderedIxs = T.intercalate (T.singleton ',') (map unIndexName (toList ixs)) - --- | 'storeSearchTemplate', saves a 'SearchTemplateSource' to be used later. -storeSearchTemplate :: SearchTemplateId -> SearchTemplateSource -> BHRequest StatusDependant Acknowledged -storeSearchTemplate (SearchTemplateId tid) ts = - post ["_scripts", tid] (encode body) - where - body = Object $ X.fromList ["script" .= Object ("lang" .= String "mustache" <> "source" .= ts)] - --- | 'getSearchTemplate', get info of an stored 'SearchTemplateSource'. -getSearchTemplate :: SearchTemplateId -> BHRequest StatusIndependant GetTemplateScript -getSearchTemplate (SearchTemplateId tid) = - get ["_scripts", tid] - --- | 'storeSearchTemplate', -deleteSearchTemplate :: SearchTemplateId -> BHRequest StatusIndependant Acknowledged -deleteSearchTemplate (SearchTemplateId tid) = - delete ["_scripts", tid] - --- | For a given search, request a scroll for efficient streaming of --- search results. Note that the search is put into 'SearchTypeScan' --- mode and thus results will not be sorted. Combine this with --- 'advanceScroll' to efficiently stream through the full result set -getInitialScroll :: - (FromJSON a) => - IndexName -> - Search -> - BHRequest StatusDependant (ParsedEsResponse (SearchResult a)) -getInitialScroll indexName search' = - withBHResponseParsedEsResponse $ dispatchSearch endpoint search - where - endpoint = [unIndexName indexName, "_search"] `withQueries` [("scroll", Just "1m")] - sorting = Just [DefaultSortSpec $ mkSort (FieldName "_doc") Descending] - search = search' {sortBody = sorting} - --- | For a given search, request a scroll for efficient streaming of --- search results. Combine this with 'advanceScroll' to efficiently --- stream through the full result set. Note that this search respects --- sorting and may be less efficient than 'getInitialScroll'. -getInitialSortedScroll :: - (FromJSON a) => - IndexName -> - Search -> - BHRequest StatusDependant (SearchResult a) -getInitialSortedScroll indexName search = do - dispatchSearch endpoint search - where - endpoint = [unIndexName indexName, "_search"] `withQueries` [("scroll", Just "1m")] - --- | Use the given scroll to fetch the next page of documents. If there are no --- further pages, 'SearchResult.searchHits.hits' will be '[]'. -advanceScroll :: - (FromJSON a) => - ScrollId -> - -- | How long should the snapshot of data be kept around? This timeout is updated every time 'advanceScroll' is used, so don't feel the need to set it to the entire duration of your search processing. Note that durations < 1s will be rounded up. Also note that 'NominalDiffTime' is an instance of Num so literals like 60 will be interpreted as seconds. 60s is a reasonable default. - NominalDiffTime -> - BHRequest StatusDependant (SearchResult a) -advanceScroll (ScrollId sid) scroll = - post ["_search", "scroll"] (encode scrollObject) - where - scrollTime = showText secs <> "s" - secs :: Integer - secs = round scroll - - scrollObject = - object - [ "scroll" .= scrollTime, - "scroll_id" .= sid - ] - --- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search' --- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update --- syntax if you want to add things like aggregations or highlights while still using --- this helper function. --- --- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing --- >>> mkSearch (Just query) Nothing --- Search {queryBody = Just (TermQuery (Term {termField = "user", termValue = "bitemyapp"}) Nothing), filterBody = Nothing, searchAfterKey = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing} -mkSearch :: Maybe Query -> Maybe Filter -> Search -mkSearch query filter = - Search - { queryBody = query, - filterBody = filter, - sortBody = Nothing, - aggBody = Nothing, - highlight = Nothing, - trackSortScores = False, - from = From 0, - size = Size 10, - searchType = SearchTypeQueryThenFetch, - searchAfterKey = Nothing, - fields = Nothing, - scriptFields = Nothing, - docvalueFields = Nothing, - source = Nothing, - suggestBody = Nothing, - pointInTime = Nothing - } - --- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for --- the 'Query' and the 'Aggregation'. --- --- >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst } --- >>> terms --- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing}) --- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms -mkAggregateSearch :: Maybe Query -> Aggregations -> Search -mkAggregateSearch query mkSearchAggs = - Search - { queryBody = query, - filterBody = Nothing, - sortBody = Nothing, - aggBody = Just mkSearchAggs, - highlight = Nothing, - trackSortScores = False, - from = From 0, - size = Size 0, - searchType = SearchTypeQueryThenFetch, - searchAfterKey = Nothing, - fields = Nothing, - scriptFields = Nothing, - docvalueFields = Nothing, - source = Nothing, - suggestBody = Nothing, - pointInTime = Nothing - } - --- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for --- the 'Query' and the 'Aggregation'. --- --- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") --- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing] --- >>> let search = mkHighlightSearch (Just query) testHighlight -mkHighlightSearch :: Maybe Query -> Highlights -> Search -mkHighlightSearch query searchHighlights = - Search - { queryBody = query, - filterBody = Nothing, - sortBody = Nothing, - aggBody = Nothing, - highlight = Just searchHighlights, - trackSortScores = False, - from = From 0, - size = Size 10, - searchType = SearchTypeDfsQueryThenFetch, - searchAfterKey = Nothing, - fields = Nothing, - scriptFields = Nothing, - docvalueFields = Nothing, - source = Nothing, - suggestBody = Nothing, - pointInTime = Nothing - } - --- | 'mkSearchTemplate' is a helper function for defaulting additional fields of a 'SearchTemplate' --- to Nothing. Use record update syntax if you want to add things. -mkSearchTemplate :: Either SearchTemplateId SearchTemplateSource -> TemplateQueryKeyValuePairs -> SearchTemplate -mkSearchTemplate id_ params = SearchTemplate id_ params Nothing Nothing - --- | 'pageSearch' is a helper function that takes a search and assigns the from --- and size fields for the search. The from parameter defines the offset --- from the first result you want to fetch. The size parameter allows you to --- configure the maximum amount of hits to be returned. --- --- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") --- >>> let search = mkSearch (Just query) Nothing --- >>> search --- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing, matchQueryBoost = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing} --- >>> pageSearch (From 10) (Size 100) search --- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Or, matchQueryZeroTerms = ZeroTermsNone, matchQueryCutoffFrequency = Nothing, matchQueryMatchType = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing, matchQueryBoost = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 10, size = Size 100, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing} -pageSearch :: - -- | The result offset - From -> - -- | The number of results to return - Size -> - -- | The current seach - Search -> - -- | The paged search - Search -pageSearch resultOffset pageSize search = search {from = resultOffset, size = pageSize} - -boolQP :: Bool -> Text -boolQP True = "true" -boolQP False = "false" - -countByIndex :: IndexName -> CountQuery -> BHRequest StatusDependant CountResponse -countByIndex indexName q = - post [unIndexName indexName, "_count"] (encode q) - -reindex :: - ReindexRequest -> - BHRequest StatusDependant ReindexResponse -reindex req = - post ["_reindex"] (encode req) - -reindexAsync :: - ReindexRequest -> - BHRequest StatusDependant TaskNodeId -reindexAsync req = - post endpoint (encode req) - where - endpoint = ["_reindex"] `withQueries` [("wait_for_completion", Just "false")] - -getTask :: - (FromJSON a) => - TaskNodeId -> - BHRequest StatusDependant (TaskResponse a) -getTask (TaskNodeId task) = - get ["_tasks", task] + createIndexOptions, + createIndexOptionsBody, + createIndexOptionsParams, + createIndexWith, + flushIndex, + flushIndexWith, + clearIndexCache, + reloadSearchAnalyzers, + reloadSearchAnalyzersWith, + diskUsage, + diskUsageWith, + fieldUsageStats, + fieldUsageStatsWith, + getScriptContexts, + getScriptLanguages, + deleteIndex, + updateIndexSettings, + updateIndexSettingsWith, + getIndexSettings, + getIndexSettingsWith, + getIndex, + getIndexStats, + getIndexRecovery, + getIndexSegments, + getShardStores, + getShardStoresWith, + ShardStoresOptions (..), + defaultShardStoresOptions, + shardStoresOptionsParams, + forceMergeIndex, + indexExists, + doesExist, + openIndex, + openIndexWith, + closeIndex, + closeIndexWith, + listIndices, + catIndices, + catIndicesWith, + catAliases, + catAliasesWith, + catAllocation, + catAllocationWith, + catCount, + catCountWith, + catMaster, + catMasterWith, + catHealth, + catHealthWith, + catPendingTasks, + catPendingTasksWith, + catPlugins, + catPluginsWith, + catTemplates, + catTemplatesWith, + catThreadPool, + catThreadPoolWith, + catFielddata, + catFielddataWith, + catNodeattrs, + catNodeattrsWith, + catRepositories, + catRepositoriesWith, + catShards, + catShardsWith, + catTasks, + catTasksWith, + catSnapshots, + catSnapshotsWith, + catNodes, + catNodesWith, + catSegments, + catSegmentsWith, + catRecovery, + catRecoveryWith, + catComponentTemplates, + catComponentTemplatesWith, + catCircuitBreakers, + catCircuitBreakersWith, + catMlJobs, + catMlJobsWith, + catMlDataFrameAnalytics, + catMlDataFrameAnalyticsWith, + catMlDatafeeds, + catMlDatafeedsWith, + catMlTrainedModels, + catMlTrainedModelsWith, + catTransforms, + catTransformsWith, + catHelp, + addIndexBlock, + removeIndexBlock, + waitForYellowIndex, + rolloverIndex, + resolveIndex, + resolveIndexWith, + shrinkIndex, + splitIndex, + cloneIndex, + HealthStatus (..), + + -- *** Dangling indices + listDanglingIndices, + importDanglingIndex, + importDanglingIndexWith, + deleteDanglingIndex, + deleteDanglingIndexWith, + DanglingIndexUuid (..), + unDanglingIndexUuid, + DanglingIndex (..), + DanglingIndicesResponse (..), + ImportDanglingIndexOptions (..), + defaultImportDanglingIndexOptions, + importDanglingIndexOptionsParams, + DeleteDanglingIndexOptions (..), + defaultDeleteDanglingIndexOptions, + deleteDanglingIndexOptionsParams, + + -- *** Index Aliases + updateIndexAliases, + updateIndexAliasesWith, + UpdateAliasesOptions (..), + defaultUpdateAliasesOptions, + updateAliasesOptionsParams, + createIndexAlias, + getIndexAliases, + getIndexAlias, + deleteIndexAlias, + deleteIndexAliasFrom, + aliasExists, + defaultIndexAliasCreate, + + -- *** Index Templates + putTemplate, + templateExists, + getTemplate, + deleteTemplate, + ComponentTemplate (..), + ComposableTemplate (..), + ComposableTemplateContent (..), + ComposableTemplateOptions (..), + defaultComposableTemplateOptions, + composableTemplateOptionsParams, + putIndexTemplate, + putIndexTemplateWith, + getIndexTemplate, + deleteIndexTemplate, + simulateIndexTemplate, + simulateIndexTemplateWith, + simulateIndex, + simulateIndexWith, + putComponentTemplate, + deleteComponentTemplate, + IndexTemplateInfo (..), + GetIndexTemplatesResponse (..), + TemplateInfo (..), + GetTemplatesResponse (..), + getComponentTemplate, + ComponentTemplateInfo (..), + GetComponentTemplatesResponse (..), + TemplateNamePattern (..), + SimulatedTemplate (..), + SimulatedTemplateOverlap (..), + + -- ** Mapping + putMapping, + putMappingWith, + getMapping, + getFieldMapping, + + -- ** Documents + indexDocument, + updateDocument, + updateDocumentWith, + updateByQuery, + updateByQueryWith, + rethrottleUpdateByQuery, + getDocument, + getDocumentWith, + getDocumentSource, + getDocumentSourceWith, + getDocuments, + getDocumentsWith, + getDocumentsMulti, + getDocumentsMultiWith, + getTermVectors, + getTermVectorsWith, + getMultiTermVectors, + getMultiTermVectorsWith, + getMultiTermVectorsByIndex, + getMultiTermVectorsByIndexWith, + documentExists, + documentExistsWith, + documentSourceExists, + documentSourceExistsWith, + deleteDocument, + deleteDocumentWith, + deleteByQuery, + deleteByQueryWith, + rethrottleDeleteByQuery, + getDocumentOptionsParams, + getDocumentSourceOptionsParams, + multiGetOptionsParams, + deleteDocumentOptionsParams, + documentExistsOptionsParams, + documentSourceExistsParams, + byQueryOptionsParams, + termVectorsOptionsParams, + explainOptionsParams, + IndexedDocument (..), + DeletedDocuments (..), + DeletedDocumentsRetries (..), + + -- ** Searching + searchAll, + searchAllWith, + multiSearch, + multiSearchWith, + multiSearchByIndex, + multiSearchByIndexWith, + MultiSearchTemplateItem (..), + multiSearchTemplate, + multiSearchTemplateWith, + multiSearchTemplateByIndex, + multiSearchTemplateByIndexWith, + searchByIndex, + searchByIndexWith, + searchByIndices, + searchByIndicesWith, + explainDocument, + explainDocumentWith, + searchByIndexTemplate, + searchByIndicesTemplate, + getInitialScroll, + getInitialSortedScroll, + advanceScroll, + advanceScrollWith, + clearScroll, + refreshIndex, + refreshIndexWith, + mkSearch, + mkAggregateSearch, + mkHighlightSearch, + mkSearchTemplate, + bulk, + bulkWith, + pageSearch, + mkShardCount, + mkReplicaCount, + getStatus, + dispatchSearch, + dispatchSearchWith, + searchOptionsParams, + + -- ** Templates + storeSearchTemplate, + getSearchTemplate, + deleteSearchTemplate, + renderTemplate, + + -- ** Snapshot/Restore + + -- *** Snapshot Repos + getSnapshotRepos, + getSnapshotReposWith, + updateSnapshotRepo, + verifySnapshotRepo, + verifySnapshotRepoWith, + cleanupSnapshotRepo, + cleanupSnapshotRepoWith, + deleteSnapshotRepo, + deleteSnapshotRepoWith, + snapshotMasterTimeoutOptionsParams, + + -- *** Snapshots + createSnapshot, + cloneSnapshot, + getSnapshots, + getSnapshotsWith, + snapshotSelectionOptionsParams, + SIs (..), + getSnapshotStatus, + getSnapshotStatusWith, + deleteSnapshot, + deleteSnapshotWith, + + -- *** Restoring Snapshots + restoreSnapshot, + + -- *** Reindex + reindex, + reindexWith, + reindexAsync, + reindexAsyncWith, + rethrottleReindex, + + -- *** Task + getTask, + getTaskWith, + cancelTask, + listTasks, + taskListOptionsParams, + taskGetOptionsParams, + + -- ** Async Search + getAsyncSearch, + getAsyncSearchStatus, + + -- ** Nodes + getNodesInfo, + getNodesInfoWith, + getNodesStats, + getNodesStatsWith, + getNodesUsage, + getNodesUsageWith, + getNodesHotThreads, + getNodesHotThreadsWith, + hotThreadsOptionsParams, + reloadSecureSettings, + + -- ** Cluster + getClusterHealth, + getClusterHealthWith, + getClusterHealthForIndex, + getClusterHealthForIndexWith, + clusterHealthOptionsParams, + getClusterSettings, + getClusterSettingsWith, + clusterSettingsOptionsParams, + updateClusterSettings, + updateClusterSettingsWith, + clusterSettingsUpdateOptionsParams, + getClusterState, + getClusterStateWith, + clusterStateOptionsParams, + clusterStateOptionsPathSegments, + getClusterStats, + getPendingTasks, + explainAllocation, + getRemoteClusterInfo, + updateVotingConfigExclusions, + votingConfigExclusionOptionsParams, + clearVotingConfigExclusions, + rerouteCluster, + rerouteClusterWith, + rerouteOptionsParams, + + -- ** Index Lifecycle Management (ILM) + getILMPolicy, + putILMPolicy, + deleteILMPolicy, + explainILM, + explainILMWith, + ilmExplainOptionsParams, + startILM, + stopILM, + getILMStatus, + moveILMStep, + retryILMStep, + removeILM, + migrateDataTiers, + migrateDataTiersWith, + + -- ** Snapshot Lifecycle Management (SLM) + putSLMPolicy, + getSLMPolicy, + deleteSLMPolicy, + executeSLMPolicy, + getSLMStatus, + startSLM, + stopSLM, + + -- ** Enrich + putEnrichPolicy, + getEnrichPolicy, + deleteEnrichPolicy, + executeEnrichPolicy, + executeEnrichPolicyWith, + getEnrichExecuteStats, + getEnrichPolicyExecuteStats, + + -- ** Autoscaling + putAutoscalingPolicy, + getAutoscalingPolicy, + deleteAutoscalingPolicy, + getAutoscalingCapacity, + + -- ** Security — roles (/_security/role/*) + putRole, + getRole, + getRoles, + deleteRole, + clearRoleCache, + + -- ** Security — role mappings (/_security/role_mapping/*) + putRoleMapping, + getRoleMapping, + getRoleMappings, + deleteRoleMapping, + + -- ** Security — users (/_security/user/*) + putUser, + getUser, + getUsers, + deleteUser, + enableUser, + disableUser, + changeUserPassword, + userHasPrivileges, + selfHasPrivileges, + getUserPrivileges, + + -- ** Security — API keys (/_security/api_key) + createApiKey, + grantApiKey, + getApiKey, + invalidateApiKey, + updateApiKey, + queryApiKey, + queryApiKeyWith, + QueryApiKeyOptions (..), + defaultQueryApiKeyOptions, + + -- ** Security — authentication (/_security/_authenticate, _whoami, _logout) + authenticate, + whoami, + logout, + + -- ** Security — service accounts (/_security/service/*) + getServiceAccounts, + getServiceAccountsInNamespace, + getServiceAccount, + createServiceToken, + getServiceCredentials, + deleteServiceToken, + + -- ** Security — SSO / token (/_security/oauth2, /_security/oidc, /_security/saml) + getToken, + invalidateToken, + prepareSamlAuthentication, + authenticateSaml, + logoutSaml, + prepareOidcAuthentication, + authenticateOidc, + logoutOidc, + + -- ** Security — application privileges (/_security/privilege/*) + putPrivilege, + getPrivileges, + getPrivilegesInApplication, + getPrivilege, + deletePrivilege, + clearPrivilegeCache, + + -- ** Fleet + getFleetGlobalCheckpoints, + getFleetGlobalCheckpointsWith, + fleetSearch, + fleetSearchWith, + fleetMultiSearch, + fleetMultiSearchWith, + FleetGlobalCheckpointsOptions (..), + defaultFleetGlobalCheckpointsOptions, + FleetSearchOptions (..), + defaultFleetSearchOptions, + + -- ** Repositories Metering + getRepositoriesMetering, + deleteRepositoriesMetering, + + -- ** Rollup + putRollupJob, + getRollupJob, + deleteRollupJob, + startRollupJob, + stopRollupJob, + stopRollupJobWith, + getRollupJobStats, + getRollupCapabilities, + getRollupIndexCapabilities, + rollupSearchByIndex, + rollupSearchByIndexWith, + + -- ** Searchable Snapshots + mountSearchableSnapshot, + mountSearchableSnapshotWith, + getSearchableSnapshotsStats, + getSearchableSnapshotsCacheStats, + clearSearchableSnapshotsCache, + + -- ** Watcher + putWatch, + getWatch, + deleteWatch, + executeWatch, + executeWatchWith, + ackWatch, + activateWatch, + deactivateWatch, + watcherStats, + watcherStatsWith, + getWatcherSettings, + updateWatcherSettings, + startWatcher, + stopWatcher, + + -- ** Text structure + findStructure, + findStructureWith, + findMessageStructure, + findMessageStructureWith, + findFieldStructure, + findFieldStructureWith, + testGrokPattern, + testGrokPatternWith, + + -- ** Transform + putTransform, + putTransformWith, + updateTransform, + updateTransformWith, + getTransforms, + getTransformsWith, + deleteTransform, + deleteTransformWith, + startTransform, + startTransformWith, + stopTransform, + stopTransformWith, + previewTransform, + previewTransformWith, + getTransformStats, + getTransformStatsWith, + explainTransform, + + -- ** Migration + getMigrationDeprecations, + getSystemFeatures, + upgradeSystemFeatures, + + -- ** Ingest Pipelines + putIngestPipeline, + getIngestPipeline, + deleteIngestPipeline, + simulateIngestPipeline, + getGrokPatterns, + + -- ** Async Search + deleteAsyncSearch, + submitAsyncSearch, + submitAsyncSearchWith, + + -- ** Request Utilities + encodeBulkOperations, + encodeBulkOperation, + SSs (..), + indexQueryString, + + -- * BHResponse-handling tools + isVersionConflict, + isSuccess, + isCreated, + parseEsResponse, + parseEsResponseWith, + decodeResponse, + eitherDecodeResponse, + + -- * Count + countByIndex, + countByIndexWith, + countAll, + + -- * Validate + validateQuery, + validateQueryWith, + validateAll, + + -- * Rank Evaluation + evaluateRank, + evaluateRankByIndex, + evaluateRankWith, + + -- * Analyze + analyzeText, + + -- * Field Capabilities + getFieldCaps, + getFieldCapsWith, + + -- * Search Shards + getSearchShards, + getSearchShardsWith, + SearchShardsOptions (..), + defaultSearchShardsOptions, + searchShardsOptionsParams, + + -- * Vector Tile (Mapbox Vector Tile search) + searchVectorTile, + searchVectorTileWith, + VectorTileOptions (..), + defaultVectorTileOptions, + vectorTileOptionsParams, + TileZoom (..), + TileX (..), + TileY (..), + VectorTileGridAgg (..), + VectorTileGridType (..), + VectorTileTrackTotalHits (..), + + -- * Generic + Acknowledged (..), + Accepted (..), + IgnoredBody (..), + + -- * Performing Requests + tryPerformBHRequest, + performBHRequest, + withBHResponse, + withBHResponse_, + withBHResponseParsedEsResponse, + keepBHResponse, + joinBHResponse, + ) +where + +import Control.Applicative as A +import Control.Monad +import Data.Aeson +import Data.Aeson.Key +import Data.Aeson.KeyMap qualified as X +import Data.ByteString.Builder +import Data.ByteString.Lazy.Char8 qualified as L +import Data.Coerce (coerce) +import Data.Foldable (toList) +import Data.List qualified as LS (foldl') +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (catMaybes, fromMaybe, isNothing) +import Data.Monoid +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time.Clock +import Data.Vector qualified as V +import Database.Bloodhound.Client.Cluster +import Database.Bloodhound.Common.Types +import Database.Bloodhound.Internal.Utils.Imports (showText) +import Database.Bloodhound.Internal.Utils.Requests +import Network.HTTP.Client (responseBody) +import Network.HTTP.Types.Method qualified as NHTM +import Prelude hiding (filter, head) + +-- | 'mkShardCount' is a straight-forward smart constructor for 'ShardCount' +-- which rejects 'Int' values below 1 and above 1000. +-- +-- >>> mkShardCount 10 +-- Just (ShardCount 10) +mkShardCount :: Int -> Maybe ShardCount +mkShardCount n + | n < 1 = Nothing + | n > 1000 = Nothing + | otherwise = Just (ShardCount n) + +-- | 'mkReplicaCount' is a straight-forward smart constructor for 'ReplicaCount' +-- which rejects 'Int' values below 0 and above 1000. +-- +-- >>> mkReplicaCount 10 +-- Just (ReplicaCount 10) +mkReplicaCount :: Int -> Maybe ReplicaCount +mkReplicaCount n + | n < 0 = Nothing + | n > 1000 = Nothing -- ... + | otherwise = Just (ReplicaCount n) + +-- | 'getStatus' fetches the 'Status' of a 'Server' +-- +-- >>> serverStatus <- runBH' getStatus +-- >>> fmap tagline (serverStatus) +-- Just "You Know, for Search" +getStatus :: BHRequest StatusDependant Status +getStatus = get [] + +-- | 'getSnapshotRepos' gets the definitions of a subset of the +-- defined snapshot repos. +getSnapshotRepos :: SnapshotRepoSelection -> BHRequest StatusDependant [GenericSnapshotRepo] +getSnapshotRepos sel = getSnapshotReposWith sel defaultSnapshotRepoGetOptions + +-- | Variant of 'getSnapshotRepos' that accepts +-- 'SnapshotRepoGetOptions' for the @master_timeout@ and @local@ URI +-- parameters. Calling with 'defaultSnapshotRepoGetOptions' is +-- byte-for-byte identical to 'getSnapshotRepos'. +getSnapshotReposWith :: + SnapshotRepoSelection -> + SnapshotRepoGetOptions -> + BHRequest StatusDependant [GenericSnapshotRepo] +getSnapshotReposWith sel opts = + unGSRs <$> get (["_snapshot", selectorSeg] `withQueries` snapshotRepoGetOptionsParams opts) + where + selectorSeg = case sel of + AllSnapshotRepos -> "_all" + SnapshotRepoList (p :| ps) -> T.intercalate "," (renderPat <$> (p : ps)) + renderPat (RepoPattern t) = t + renderPat (ExactRepo (SnapshotRepoName t)) = t + +-- | Wrapper to extract the list of 'GenericSnapshotRepo' in the +-- format they're returned in +newtype GSRs = GSRs {unGSRs :: [GenericSnapshotRepo]} + +instance FromJSON GSRs where + parseJSON = withObject "Collection of GenericSnapshotRepo" parse + where + parse = fmap GSRs . mapM (uncurry go) . X.toList + go rawName = withObject "GenericSnapshotRepo" $ \o -> + GenericSnapshotRepo (SnapshotRepoName $ toText rawName) + <$> o + .: "type" + <*> o + .: "settings" + +-- | Create or update a snapshot repo +updateSnapshotRepo :: + (SnapshotRepo repo) => + -- | Use 'defaultSnapshotRepoUpdateSettings' if unsure + SnapshotRepoUpdateSettings -> + repo -> + BHRequest StatusIndependant Acknowledged +updateSnapshotRepo SnapshotRepoUpdateSettings {..} repo = + put endpoint (encode body) + where + endpoint = ["_snapshot", snapshotRepoName gSnapshotRepoName] `withQueries` params + params = + catMaybes + [ if repoUpdateVerify then Nothing else Just ("verify", Just "false"), + ("master_timeout",) . Just . renderDuration <$> repoUpdateMasterTimeout, + ("timeout",) . Just . renderDuration <$> repoUpdateTimeout + ] + body = + object + [ "type" .= gSnapshotRepoType, + "settings" .= gSnapshotRepoSettings + ] + GenericSnapshotRepo {..} = toGSnapshotRepo repo + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +-- | Verify if a snapshot repo is working. __NOTE:__ this API did not +-- make it into Elasticsearch until 1.4. If you use an older version, +-- you will get an error here. +verifySnapshotRepo :: SnapshotRepoName -> BHRequest StatusDependant SnapshotVerification +verifySnapshotRepo repoName = verifySnapshotRepoWith repoName defaultSnapshotRepoTimeoutOptions + +-- | Variant of 'verifySnapshotRepo' that accepts +-- 'SnapshotRepoTimeoutOptions' for the @master_timeout@ and +-- @timeout@ URI parameters. Calling with +-- 'defaultSnapshotRepoTimeoutOptions' is byte-for-byte identical to +-- 'verifySnapshotRepo'. +verifySnapshotRepoWith :: + SnapshotRepoName -> + SnapshotRepoTimeoutOptions -> + BHRequest StatusDependant SnapshotVerification +verifySnapshotRepoWith (SnapshotRepoName n) opts = + post (["_snapshot", n, "_verify"] `withQueries` snapshotRepoTimeoutOptionsParams opts) emptyBody + +-- | Removes stale data from a snapshot repository (indices' stale +-- segments not referenced by any snapshot). Pinned to +-- 'StatusDependant' so a 404 (missing repository) surfaces as an +-- 'EsError'. The wire format is identical across Elasticsearch and +-- OpenSearch, so this builder is shared by every versioned client +-- via "Database.Bloodhound.Common.Client". +-- +-- (, +-- ) +cleanupSnapshotRepo :: + SnapshotRepoName -> + BHRequest StatusDependant SnapshotCleanupResult +cleanupSnapshotRepo repoName = cleanupSnapshotRepoWith repoName defaultSnapshotMasterTimeoutOptions + +-- | Variant of 'cleanupSnapshotRepo' that accepts +-- 'SnapshotMasterTimeoutOptions' for the @master_timeout@ URI +-- parameter. Calling with 'defaultSnapshotMasterTimeoutOptions' is +-- byte-for-byte identical to 'cleanupSnapshotRepo'. +cleanupSnapshotRepoWith :: + SnapshotRepoName -> + SnapshotMasterTimeoutOptions -> + BHRequest StatusDependant SnapshotCleanupResult +cleanupSnapshotRepoWith (SnapshotRepoName n) opts = + post (["_snapshot", n, "_cleanup"] `withQueries` snapshotMasterTimeoutOptionsParams opts) emptyBody + +deleteSnapshotRepo :: SnapshotRepoName -> BHRequest StatusIndependant Acknowledged +deleteSnapshotRepo repoName = deleteSnapshotRepoWith repoName defaultSnapshotRepoTimeoutOptions + +-- | Variant of 'deleteSnapshotRepo' that accepts +-- 'SnapshotRepoTimeoutOptions' for the @master_timeout@ and +-- @timeout@ URI parameters. Calling with +-- 'defaultSnapshotRepoTimeoutOptions' is byte-for-byte identical to +-- 'deleteSnapshotRepo'. +deleteSnapshotRepoWith :: + SnapshotRepoName -> + SnapshotRepoTimeoutOptions -> + BHRequest StatusIndependant Acknowledged +deleteSnapshotRepoWith (SnapshotRepoName n) opts = + delete (["_snapshot", n] `withQueries` snapshotRepoTimeoutOptionsParams opts) + +-- | Create and start a snapshot. The response type +-- 'CreateSnapshotResponse' reflects the 'snapWaitForCompletion' +-- setting: when @false@ (the default) the server returns +-- @{"acknowledged": }@ (decoded to +-- 'CreateSnapshotAcknowledged'); when @true@ it returns a full +-- snapshot object @{"snapshot": {…}}@ (decoded to +-- 'CreateSnapshotCompleted' wrapping a 'SnapshotResponse'). See the +-- create-snapshot API docs for the two response shapes. +createSnapshot :: + SnapshotRepoName -> + SnapshotName -> + SnapshotCreateSettings -> + BHRequest StatusIndependant CreateSnapshotResponse +createSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) SnapshotCreateSettings {..} = + post endpoint body + where + endpoint = ["_snapshot", repoName, snapName] `withQueries` params + params = + catMaybes + [ Just ("wait_for_completion", Just (boolQP snapWaitForCompletion)), + ("master_timeout",) . Just . renderDuration <$> snapMasterTimeout + ] + body = encode $ object prs + prs = + catMaybes + [ ("indices" .=) . indexSelectionName <$> snapIndices, + Just ("ignore_unavailable" .= snapIgnoreUnavailable), + Just ("include_global_state" .= snapIncludeGlobalState), + Just ("partial" .= snapPartial), + ("metadata" .=) <$> snapMetadata, + ("feature_states" .=) . toList <$> snapFeatureStates + ] + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +indexSelectionName :: IndexSelection -> Text +indexSelectionName AllIndexes = "_all" +indexSelectionName (IndexList (i :| is)) = T.intercalate "," (unIndexName <$> (i : is)) + +-- | Clone a snapshot within the same repository, copying a (partial or +-- full) selection of indices from the source snapshot to a new target +-- snapshot. Pinned to 'StatusDependant' so that a 404 (missing +-- repository or source snapshot) and a 409 (target already exists) +-- surface as an 'EsError'. The wire format is identical across +-- Elasticsearch and OpenSearch, so this builder is shared by every +-- versioned client via "Database.Bloodhound.Common.Client". +-- +-- The target snapshot name is carried in the URL path +-- (@PUT /_snapshot\/{repo}\/{snap}\/_clone\/{target}@) per the ES and +-- OpenSearch docs; the request body carries only the @indices@ +-- selection. +-- +-- (, +-- ) +cloneSnapshot :: + SnapshotRepoName -> + SnapshotName -> + SnapshotName -> + SnapshotCloneSettings -> + BHRequest StatusDependant Acknowledged +cloneSnapshot + (SnapshotRepoName repoName) + (SnapshotName snapName) + (SnapshotName targetName) + SnapshotCloneSettings {..} = + put endpoint (encode body) + where + endpoint = + ["_snapshot", repoName, snapName, "_clone", targetName] + `withQueries` params + params = + catMaybes + [ ("master_timeout",) . Just . renderDuration <$> snapCloneMasterTimeout + ] + body = + object $ + catMaybes + [ ("indices" .=) . indexSelectionName <$> snapCloneIndices + ] + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +-- | Get info about known snapshots given a pattern and repo name. +getSnapshots :: SnapshotRepoName -> SnapshotSelection -> BHRequest StatusDependant [SnapshotInfo] +getSnapshots repoName sel = getSnapshotsWith repoName sel defaultSnapshotSelectionOptions + +-- | Variant of 'getSnapshots' that accepts 'SnapshotSelectionOptions' +-- for the @master_timeout@, @verbose@, @index_details@, +-- @include_repository@, @sort@, @order@, @size@, @offset@, @after@, +-- @from_sort_value@, @ignore_unavailable@, @index_names@ and +-- @slm_policy_filter@ URI parameters. Calling with +-- 'defaultSnapshotSelectionOptions' is byte-for-byte identical to +-- 'getSnapshots'. +-- +-- () +getSnapshotsWith :: + SnapshotRepoName -> + SnapshotSelection -> + SnapshotSelectionOptions -> + BHRequest StatusDependant [SnapshotInfo] +getSnapshotsWith (SnapshotRepoName repoName) sel opts = + unSIs <$> get (["_snapshot", repoName, snapPath] `withQueries` snapshotSelectionOptionsParams opts) + where + snapPath = case sel of + AllSnapshots -> "_all" + SnapshotList (s :| ss) -> T.intercalate "," (renderPath <$> (s : ss)) + renderPath (SnapPattern t) = t + renderPath (ExactSnap (SnapshotName t)) = t + +-- | Render the 'SnapshotSelectionOptions' URI parameters +-- (@master_timeout@, @verbose@, @index_details@, +-- @include_repository@, @sort@, @order@, @size@, @offset@, @after@, +-- @from_sort_value@, @ignore_unavailable@, @index_names@, +-- @slm_policy_filter@) as a list of @(key, value)@ pairs suitable for +-- 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultSnapshotSelectionOptions' produces an empty list (and +-- therefore no query string). +snapshotSelectionOptionsParams :: SnapshotSelectionOptions -> [(Text, Maybe Text)] +snapshotSelectionOptionsParams opts = + catMaybes + [ ("master_timeout",) . Just . renderDuration <$> ssoMasterTimeout opts, + ("verbose",) . Just . renderBool <$> ssoVerbose opts, + ("index_details",) . Just . renderBool <$> ssoIndexDetails opts, + ("include_repository",) . Just . renderBool <$> ssoIncludeRepository opts, + ("sort",) . Just . renderSnapshotSortField <$> ssoSort opts, + ("order",) . Just . renderSnapshotSortOrder <$> ssoOrder opts, + ("size",) . Just . showText <$> ssoSize opts, + ("offset",) . Just . showText <$> ssoOffset opts, + ("after",) . Just <$> ssoAfter opts, + ("from_sort_value",) . Just <$> ssoFromSortValue opts, + ("ignore_unavailable",) . Just . renderBool <$> ssoIgnoreUnavailableSnapshots opts, + ("index_names",) . Just . renderBool <$> ssoIndexNames opts, + ("slm_policy_filter",) . Just <$> ssoSlmPolicyFilter opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +-- | Render the 'SnapshotMasterTimeoutOptions' URI parameter +-- (@master_timeout@) as a list of @(key, value)@ pairs suitable for +-- 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultSnapshotMasterTimeoutOptions' produces an empty list (and +-- therefore no query string). +snapshotMasterTimeoutOptionsParams :: SnapshotMasterTimeoutOptions -> [(Text, Maybe Text)] +snapshotMasterTimeoutOptionsParams opts = + catMaybes + [ ("master_timeout",) . Just . renderDuration <$> smtoMasterTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +-- | Render the 'SnapshotRepoTimeoutOptions' URI parameters +-- (@master_timeout@, @timeout@) as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultSnapshotRepoTimeoutOptions' produces an empty list (and +-- therefore no query string). +snapshotRepoTimeoutOptionsParams :: SnapshotRepoTimeoutOptions -> [(Text, Maybe Text)] +snapshotRepoTimeoutOptionsParams opts = + catMaybes + [ ("master_timeout",) . Just . renderDuration <$> srtoMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> srtoTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +-- | Render the 'SnapshotRepoGetOptions' URI parameters +-- (@master_timeout@, @local@) as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultSnapshotRepoGetOptions' produces an empty list (and +-- therefore no query string). +snapshotRepoGetOptionsParams :: SnapshotRepoGetOptions -> [(Text, Maybe Text)] +snapshotRepoGetOptionsParams opts = + catMaybes + [ ("local",) . Just . boolQP <$> srgoLocal opts, + ("master_timeout",) . Just . renderDuration <$> srgoMasterTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +-- | Render the 'SnapshotStatusOptions' URI parameters +-- (@master_timeout@, @ignore_unavailable@) as a list of +-- @(key, value)@ pairs suitable for 'withQueries'. 'Nothing' fields +-- are omitted, so 'defaultSnapshotStatusOptions' produces an empty +-- list (and therefore no query string). +snapshotStatusOptionsParams :: SnapshotStatusOptions -> [(Text, Maybe Text)] +snapshotStatusOptionsParams opts = + catMaybes + [ ("ignore_unavailable",) . Just . boolQP <$> sstoIgnoreUnavailable opts, + ("master_timeout",) . Just . renderDuration <$> sstoMasterTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +newtype SIs = SIs {unSIs :: [SnapshotInfo]} + deriving newtype (Eq, Show) + +instance FromJSON SIs where + parseJSON = withObject "Collection of SnapshotInfo" parse + where + parse o = SIs <$> o .: "snapshots" + +-- | Get detailed status of in-progress (or completed) snapshots. Use +-- this rather than 'getSnapshots' when you need shard-level progress +-- (files copied, sizes, stages) for monitoring non-blocking snapshot +-- workflows. +-- +-- () +getSnapshotStatus :: + SnapshotRepoName -> + SnapshotName -> + BHRequest StatusDependant [SnapshotStatus] +getSnapshotStatus repoName snapName = getSnapshotStatusWith repoName snapName defaultSnapshotStatusOptions + +-- | Variant of 'getSnapshotStatus' that accepts +-- 'SnapshotStatusOptions' for the @master_timeout@ and +-- @ignore_unavailable@ URI parameters. Calling with +-- 'defaultSnapshotStatusOptions' is byte-for-byte identical to +-- 'getSnapshotStatus'. +getSnapshotStatusWith :: + SnapshotRepoName -> + SnapshotName -> + SnapshotStatusOptions -> + BHRequest StatusDependant [SnapshotStatus] +getSnapshotStatusWith (SnapshotRepoName repoName) (SnapshotName snapName) opts = + unSSs <$> get (["_snapshot", repoName, snapName, "_status"] `withQueries` snapshotStatusOptionsParams opts) + +newtype SSs = SSs {unSSs :: [SnapshotStatus]} + deriving newtype (Eq, Show) + +instance FromJSON SSs where + parseJSON = withObject "Collection of SnapshotStatus" parse + where + parse o = SSs <$> o .: "snapshots" + +-- | Delete a snapshot. Cancels if it is running. +deleteSnapshot :: SnapshotRepoName -> SnapshotName -> BHRequest StatusIndependant Acknowledged +deleteSnapshot repoName snapName = deleteSnapshotWith repoName snapName defaultSnapshotMasterTimeoutOptions + +-- | Variant of 'deleteSnapshot' that accepts +-- 'SnapshotMasterTimeoutOptions' for the @master_timeout@ URI +-- parameter. Calling with 'defaultSnapshotMasterTimeoutOptions' is +-- byte-for-byte identical to 'deleteSnapshot'. +deleteSnapshotWith :: + SnapshotRepoName -> + SnapshotName -> + SnapshotMasterTimeoutOptions -> + BHRequest StatusIndependant Acknowledged +deleteSnapshotWith (SnapshotRepoName repoName) (SnapshotName snapName) opts = + delete (["_snapshot", repoName, snapName] `withQueries` snapshotMasterTimeoutOptionsParams opts) + +-- | Restore a snapshot to the cluster See +-- +-- for more details. +restoreSnapshot :: + SnapshotRepoName -> + SnapshotName -> + -- | Start with 'defaultSnapshotRestoreSettings' and customize + -- from there for reasonable defaults. + SnapshotRestoreSettings -> + BHRequest StatusIndependant Accepted +restoreSnapshot (SnapshotRepoName repoName) (SnapshotName snapName) SnapshotRestoreSettings {..} = + post endpoint (encode body) + where + endpoint = ["_snapshot", repoName, snapName, "_restore"] `withQueries` params + params = + catMaybes + [ Just ("wait_for_completion", Just (boolQP snapRestoreWaitForCompletion)), + ("master_timeout",) . Just . renderDuration <$> snapRestoreMasterTimeout + ] + body = + object $ + catMaybes + [ ("indices" .=) . indexSelectionName <$> snapRestoreIndices, + Just ("ignore_unavailable" .= snapRestoreIgnoreUnavailable), + Just ("include_global_state" .= snapRestoreIncludeGlobalState), + ("rename_pattern" .=) <$> snapRestoreRenamePattern, + ("rename_replacement" .=) . renderTokens <$> snapRestoreRenameReplacement, + Just ("include_aliases" .= snapRestoreIncludeAliases), + ("index_settings" .=) <$> snapRestoreIndexSettingsOverrides, + ("ignore_index_settings" .=) <$> snapRestoreIgnoreIndexSettings + ] + renderTokens (t :| ts) = mconcat (renderToken <$> (t : ts)) + renderToken (RRTLit t) = t + renderToken RRSubWholeMatch = "$0" + renderToken (RRSubGroup g) = T.pack (show (rrGroupRefNum g)) + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +getNodesInfo :: NodeSelection -> BHRequest StatusDependant NodesInfo +getNodesInfo sel = getNodesInfoWith sel defaultNodeInfoOptions + +-- | 'getNodesInfoWith' is the fully-parameterised form of +-- 'getNodesInfo'. 'NodeInfoOptions' carries the @/{metrics}@ path +-- segment and the @flat_settings@, @master_timeout@, and @timeout@ +-- query parameters. +-- +-- Passing 'defaultNodeInfoOptions' yields a request byte-for-byte +-- identical to 'getNodesInfo'. +-- +-- () +getNodesInfoWith :: + NodeSelection -> + NodeInfoOptions -> + BHRequest StatusDependant NodesInfo +getNodesInfoWith sel opts = + get $ mkEndpoint endpointParts `withQueries` queries + where + endpointParts = + ["_nodes", selectionSeg] + <> case nioMetrics opts of + Just ms + | not (null ms) -> + ["info", T.intercalate "," (renderNodeInfoMetric <$> ms)] + _ -> [] + selectionSeg = nodeSelectionSeg sel + queries = + catMaybes + [ ("flat_settings",) . Just . renderBool <$> nioFlatSettings opts, + ("master_timeout",) . Just . renderDuration <$> nioMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> nioTimeout opts + ] + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +getNodesStats :: NodeSelection -> BHRequest StatusDependant NodesStats +getNodesStats sel = getNodesStatsWith sel defaultNodeStatsOptions + +-- | 'getNodesStatsWith' is the fully-parameterised form of +-- 'getNodesStats'. 'NodeStatsOptions' carries the @/{metrics}@ path +-- segment and the documented query parameters (@completion_fields@, +-- @fielddata_fields@, @fields@, @groups@, @level@, @types@, +-- @master_timeout@, @timeout@, @include_segment_file_sizes@, +-- @include_unloaded_segments@). +-- +-- Passing 'defaultNodeStatsOptions' yields a request byte-for-byte +-- identical to 'getNodesStats'. +-- +-- () +getNodesStatsWith :: + NodeSelection -> + NodeStatsOptions -> + BHRequest StatusDependant NodesStats +getNodesStatsWith sel opts = + get $ mkEndpoint endpointParts `withQueries` queries + where + endpointParts = + ["_nodes", selectionSeg, "stats"] + <> case nsoMetrics opts of + Just ms + | not (null ms) -> + [T.intercalate "," (renderNodeStatsMetric <$> ms)] + _ -> [] + selectionSeg = nodeSelectionSeg sel + queries = + catMaybes + [ ("completion_fields",) . Just <$> nsoCompletionFields opts, + ("fielddata_fields",) . Just <$> nsoFielddataFields opts, + ("fields",) . Just <$> nsoFields opts, + ("groups",) . Just <$> nsoGroups opts, + ("level",) . Just . renderNodeStatsLevel <$> nsoLevel opts, + ("types",) . Just <$> nsoTypes opts, + ("master_timeout",) . Just . renderDuration <$> nsoMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> nsoTimeout opts, + ("include_segment_file_sizes",) . Just . renderBool <$> nsoIncludeSegmentFileSizes opts, + ("include_unloaded_segments",) . Just . renderBool <$> nsoIncludeUnloadedSegments opts + ] + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +getNodesUsage :: NodeSelection -> BHRequest StatusDependant NodesUsage +getNodesUsage sel = getNodesUsageWith sel defaultNodeUsageOptions + +-- | 'getNodesUsageWith' is the fully-parameterised form of +-- 'getNodesUsage'. 'NodeUsageOptions' carries the @/{metrics}@ path +-- segment and the @master_timeout@ and @timeout@ query parameters. +-- +-- Passing 'defaultNodeUsageOptions' yields a request byte-for-byte +-- identical to 'getNodesUsage'. +-- +-- () +getNodesUsageWith :: + NodeSelection -> + NodeUsageOptions -> + BHRequest StatusDependant NodesUsage +getNodesUsageWith sel opts = + get $ mkEndpoint endpointParts `withQueries` queries + where + endpointParts = + ["_nodes", selectionSeg, "usage"] + <> case nuoMetrics opts of + Just ms + | not (null ms) -> + [T.intercalate "," (renderNodeUsageMetric <$> ms)] + _ -> [] + selectionSeg = nodeSelectionSeg sel + queries = + catMaybes + [ ("master_timeout",) . Just . renderDuration <$> nuoMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> nuoTimeout opts + ] + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +-- | 'nodeSelectionSeg' renders a 'NodeSelection' as the single path +-- segment ES\/OS use to identify nodes in @_nodes@, @_cluster@, and +-- related endpoints: @_local@ for 'LocalNode', @_all@ for 'AllNodes', +-- or a comma-joined list of selector renderings for 'NodeList'. +nodeSelectionSeg :: NodeSelection -> Text +nodeSelectionSeg sel = case sel of + LocalNode -> "_local" + NodeList (l :| ls) -> T.intercalate "," (nodeSelectorSeg <$> (l : ls)) + AllNodes -> "_all" + +-- | 'nodeSelectorSeg' renders a single 'NodeSelector' as it appears in +-- a comma-joined 'NodeList' path segment. Pattern matches the +-- individual 'NodeSelector' forms (by name, full id, host, or +-- attribute). +nodeSelectorSeg :: NodeSelector -> Text +nodeSelectorSeg (NodeByName (NodeName n)) = n +nodeSelectorSeg (NodeByFullNodeId (FullNodeId i)) = i +nodeSelectorSeg (NodeByHost (Server s)) = s +nodeSelectorSeg (NodeByAttribute (NodeAttrName a) v) = a <> ":" <> v + +-- | 'getNodesHotThreads' fetches the @GET /_nodes/hot_threads@ report +-- (the first diagnostic tool for high CPU). The response is plain text, +-- not JSON, so the body is returned verbatim as 'Text'. +-- +-- This is the legacy two-parameter form: it exposes only the 'NodeSelector' +-- and the @threads@ URI parameter. It delegates to +-- 'getNodesHotThreadsWith' with 'defaultHotThreadsOptions', so the wire +-- format is unchanged. +-- +-- * @Nothing@ selector → @GET /_nodes/hot_threads@ (server picks a node). +-- * @Just sel@ → @GET /_nodes/{seg}/hot_threads@ restricted to that node. +-- * @Just n@ thread count → @?threads=n@ query parameter. +-- +-- To set the other documented URI parameters (@interval@, @snapshots@, +-- @type@, @ignore_idle_threads@, @master_timeout@, @timeout@), use +-- 'getNodesHotThreadsWith'. +-- +-- () +getNodesHotThreads :: + Maybe NodeSelector -> + Maybe ThreadCount -> + BHRequest StatusDependant Text +getNodesHotThreads mSel mThreadCount = + getNodesHotThreadsWith mSel defaultHotThreadsOptions {htoThreads = mThreadCount} + +-- | 'getNodesHotThreadsWith' is the fully-parameterised form of +-- 'getNodesHotThreads'. Every URI parameter accepted by +-- @GET /_nodes/hot_threads@ is exposed via 'HotThreadsOptions'; pass +-- 'defaultHotThreadsOptions' to reproduce the legacy behaviour (only the +-- selector, no query string). See 'hotThreadsOptionsParams' for the +-- rendering of each field. +-- +-- * @Nothing@ selector → @GET /_nodes/hot_threads@ (server picks a node). +-- * @Just sel@ → @GET /_nodes/{seg}/hot_threads@ restricted to that node. +-- +-- () +getNodesHotThreadsWith :: + Maybe NodeSelector -> + HotThreadsOptions -> + BHRequest StatusDependant Text +getNodesHotThreadsWith mSel opts = + getText $ endpoint `withQueries` hotThreadsOptionsParams opts + where + endpoint = case mSel of + Nothing -> ["_nodes", "hot_threads"] + Just sel -> ["_nodes", nodeSelectorSeg sel, "hot_threads"] + +-- | Render the 'HotThreadsOptions' URI parameters +-- (@threads@, @interval@, @snapshots@, @type@, +-- @ignore_idle_threads@, @master_timeout@, @timeout@) as a list of +-- @(key, value)@ pairs suitable for 'withQueries'. 'Nothing' fields are +-- omitted, so 'defaultHotThreadsOptions' produces an empty list (and +-- therefore no query string). +-- +-- The hot-threads kind ('htoDocType') is emitted under the @type@ key, +-- which is the name accepted by every supported backend (ES and +-- OpenSearch). The historical name @doc_type@ is not recognised by the +-- server and is deliberately not emitted. +hotThreadsOptionsParams :: HotThreadsOptions -> [(Text, Maybe Text)] +hotThreadsOptionsParams opts = + catMaybes + [ ("threads",) . Just . showText . threadCount <$> htoThreads opts, + ("interval",) . Just . renderDuration <$> htoInterval opts, + ("snapshots",) . Just . showText <$> htoSnapshots opts, + ("type",) . Just . renderHotThreadsDocType <$> htoDocType opts, + ("ignore_idle_threads",) . Just . renderBool <$> htoIgnoreIdleThreads opts, + ("master_timeout",) . Just . renderDuration <$> htoMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> htoTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +-- | 'reloadSecureSettings' reloads keystore-backed secure settings on +-- the selected nodes without a restart. Maps to +-- @POST /_nodes/reload_secure_settings@ (cluster-wide when @Nothing@) +-- or @POST /_nodes/{seg}/reload_secure_settings@ scoped to a +-- 'NodeSelection' when @Just@. Returns 'Acknowledged' on success. +-- +-- * @Nothing@ → @POST /_nodes/reload_secure_settings@ +-- * @Just 'LocalNode'@ → @POST /_nodes/_local/reload_secure_settings@ +-- * @Just 'AllNodes'@ → @POST /_nodes/_all/reload_secure_settings@ +-- * @Just ('NodeList' ...)@ → @POST /_nodes/{csv}/reload_secure_settings@ +-- +-- The request always carries an empty body. ES optionally accepts a +-- @secure_settings@ object for keystore re-encryption; that variant is +-- not exposed here. Callers who need it should file a follow-up. +-- +-- See +-- +-- (or the OpenSearch equivalent). +reloadSecureSettings :: + Maybe NodeSelection -> + BHRequest StatusDependant Acknowledged +reloadSecureSettings mSel = + post endpoint emptyBody + where + endpoint = case mSel of + Nothing -> ["_nodes", "reload_secure_settings"] + Just sel -> ["_nodes", nodeSelectionSeg sel, "reload_secure_settings"] + +getClusterHealth :: BHRequest StatusDependant ClusterHealth +getClusterHealth = getClusterHealthWith defaultClusterHealthOptions + +-- | 'getClusterHealthWith' is the fully-parameterised form of +-- 'getClusterHealth'. Every URI parameter accepted by +-- @GET /_cluster/health@ is exposed via 'ClusterHealthOptions'; pass +-- 'defaultClusterHealthOptions' to reproduce the legacy behaviour +-- (no parameters). See 'clusterHealthOptionsParams' for the rendering of +-- each field. +-- +-- () +getClusterHealthWith :: ClusterHealthOptions -> BHRequest StatusDependant ClusterHealth +getClusterHealthWith opts = + get $ ["_cluster", "health"] `withQueries` clusterHealthOptionsParams opts + +-- | 'getClusterHealthForIndex' fetches the cluster health restricted to a +-- single index — the @GET /_cluster/health/{index}@ form. It is the +-- per-index counterpart to 'getClusterHealth'. +-- +-- () +getClusterHealthForIndex :: IndexName -> BHRequest StatusDependant ClusterHealth +getClusterHealthForIndex = getClusterHealthForIndexWith defaultClusterHealthOptions + +-- | 'getClusterHealthForIndexWith' combines the per-index form with the +-- full 'ClusterHealthOptions' parameter set (e.g. +-- @wait_for_status@, @timeout@, @level@). It shares the +-- 'clusterHealthOptionsParams' renderer with 'waitForYellowIndex' but +-- returns the structured 'ClusterHealth' response rather than 'HealthStatus'. +-- +-- /Note/: this builder is 'StatusDependant'. When @choWaitForStatus@ is +-- set and the index cannot reach that status within @choTimeout@, the +-- server responds with HTTP 503 and this function surfaces it as an +-- 'EsError'. Use 'waitForYellowIndex' if you want the 503 absorbed into +-- the returned 'HealthStatus' instead. +getClusterHealthForIndexWith :: + ClusterHealthOptions -> + IndexName -> + BHRequest StatusDependant ClusterHealth +getClusterHealthForIndexWith opts indexName = + get $ ["_cluster", "health", unIndexName indexName] `withQueries` clusterHealthOptionsParams opts + +-- | Render the 'ClusterHealthOptions' URI parameters +-- (@level@, @local@, @master_timeout@, @wait_for_status@, +-- @wait_for_active_shards@, @wait_for_nodes@, +-- @wait_for_no_relocating_shards@, @wait_for_no_initializing_shards@, +-- @timeout@) as a list of @(key, value)@ pairs suitable for 'withQueries'. +-- 'Nothing' fields are omitted, so 'defaultClusterHealthOptions' produces +-- an empty list (and therefore no query string). +clusterHealthOptionsParams :: ClusterHealthOptions -> [(Text, Maybe Text)] +clusterHealthOptionsParams opts = + catMaybes + [ ("level",) . Just . renderClusterHealthLevel <$> choLevel opts, + ("local",) . Just . renderBool <$> choLocal opts, + ("master_timeout",) . Just . renderDuration <$> choMasterTimeout opts, + ("wait_for_status",) . Just . renderClusterHealthStatus <$> choWaitForStatus opts, + ("wait_for_active_shards",) . Just . renderActiveShardCount <$> choWaitForActiveShards opts, + ("wait_for_nodes",) . Just <$> choWaitForNodes opts, + ("wait_for_no_relocating_shards",) . Just . renderBool <$> choWaitForNoRelocatingShards opts, + ("wait_for_no_initializing_shards",) . Just . renderBool <$> choWaitForNoInitializingShards opts, + ("timeout",) . Just . renderDuration <$> choTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + renderClusterHealthStatus ClusterHealthGreen = "green" + renderClusterHealthStatus ClusterHealthYellow = "yellow" + renderClusterHealthStatus ClusterHealthRed = "red" + +-- | 'getClusterState' fetches the full cluster state — the +-- @GET /_cluster/state@ endpoint. Equivalent to +-- @'getClusterStateWith' 'defaultClusterStateOptions'@ (no path +-- filters, no query parameters, server returns everything). Use +-- 'getClusterStateWith' to pass metric\/index filters or +-- @local@\/@master_timeout@\/@wait_for_metadata_version@\/@filter_path@. +-- +-- () +getClusterState :: BHRequest StatusDependant ClusterState +getClusterState = getClusterStateWith defaultClusterStateOptions + +-- | 'getClusterStateWith' is the fully-parameterised form of +-- 'getClusterState'. Every URI shape accepted by +-- @GET /_cluster/state@ is exposed via 'ClusterStateOptions': +-- +-- * @cstoMetrics@ selects which top-level sections come back +-- (@/_cluster/state/{metric}@); 'Nothing' renders as @_all@. +-- * @cstoIndices@ narrows the @metadata@ and @routing_table@ sections +-- to a comma-separated index expression +-- (@/_cluster/state/{metric}/{index}@). +-- * @cstoLocal@, @cstoMasterTimeout@, @cstoWaitForMetadataVersion@ +-- and @cstoFilterPath@ are forwarded as query parameters. +-- +-- Pass 'defaultClusterStateOptions' to reproduce the bare behaviour +-- (no path segments beyond @/_cluster/state@, no query string). +-- +-- () +getClusterStateWith :: + ClusterStateOptions -> + BHRequest StatusDependant ClusterState +getClusterStateWith opts = + get $ + mkEndpoint (["_cluster", "state"] ++ clusterStateOptionsPathSegments opts) + `withQueries` clusterStateOptionsParams opts + +-- | 'getClusterStats' returns cluster-level statistics — the +-- @GET /_cluster/stats@ endpoint. The response rolls up indices counts, +-- shards, docs, store size, versions and per-node aggregates (count by +-- role, JVM, FS, OS, plugins, ingest, ...). Only the universally-useful +-- fields are typed; the rest is preserved verbatim in the @*Other@ +-- 'Value' fields of 'ClusterStatsIndices' and 'ClusterStatsNodes'. +-- +-- () +getClusterStats :: BHRequest StatusDependant ClusterStats +getClusterStats = get ["_cluster", "stats"] + +-- | 'getPendingTasks' returns the cluster-level changes not yet +-- executed by the master — the @GET /_cluster/pending_tasks@ endpoint. +-- These are pending index creations, mapping updates, shard starts, +-- reroutes and the like. The endpoint wraps its payload in a +-- @tasks@ array; 'getPendingTasks' unwraps it so callers receive the +-- plain list of 'PendingTask' values (empty when the cluster is idle). +-- +-- () +getPendingTasks :: BHRequest StatusDependant [PendingTask] +getPendingTasks = unPendingTasksResponse <$> get ["_cluster", "pending_tasks"] + +-- | Wrapper used to decode the @{"tasks": [...]}@ envelope of +-- 'getPendingTasks' into the bare @['PendingTask']@ it carries. Mirrors +-- the @ListedIndexName@ trick used by 'listIndices'. +newtype PendingTasksResponse = PendingTasksResponse {unPendingTasksResponse :: [PendingTask]} + deriving stock (Eq, Show) + +instance FromJSON PendingTasksResponse where + parseJSON = withObject "PendingTasksResponse" $ \o -> + PendingTasksResponse <$> o .:? "tasks" .!= [] + +-- | 'explainAllocation' explains why a shard is (or is not) allocated — +-- the @/_cluster/allocation/explain@ endpoint. Pass 'Nothing' to ask +-- the server to explain the first unassigned shard it finds (sent as a +-- bodyless @GET@ — the server treats the absence of body as @{}@); +-- pass @'Just' req@ to target a specific shard (a body containing +-- @index@\/@shard@\/@primary@, sent as @POST@). +-- +-- Per the ES contract, when any of 'aerIndex', 'aerShard' or +-- 'aerPrimary' is supplied all three must be supplied together — use +-- 'mkAllocationExplainRequest' to construct a valid body for the common +-- case. +-- +-- The structured top-level fields of the response are typed +-- ('aeIndex', 'aeShard', 'aePrimary', 'aeCurrentState', ...); the +-- larger nested blobs ('aeDecisions', 'aeClusterInfo', 'aeNodes', +-- 'aeUnassignedInfo', 'aeCurrentNode') are kept as 'Data.Aeson.Value' +-- for inspection with aeson combinators. +-- +-- () +explainAllocation :: + Maybe AllocationExplainRequest -> + BHRequest StatusDependant AllocationExplanation +explainAllocation Nothing = get ["_cluster", "allocation", "explain"] +explainAllocation (Just body) = + post ["_cluster", "allocation", "explain"] (encode body) + +-- | 'getRemoteClusterInfo' fetches connection state for every +-- configured remote cluster — the @GET /_remote/info@ endpoint. The +-- response is keyed by remote-cluster alias; a cluster with no remotes +-- configured returns an empty 'RemoteClustersInfo' (i.e. @{}@ on the +-- wire). +-- +-- Note: this endpoint is Elasticsearch-only — OpenSearch does not +-- surface remote-cluster info at this path. Calls against an +-- OpenSearch cluster will return HTTP 404. +-- +-- The @/_remote/info@ path is the documented URL on every supported +-- Elasticsearch version (7.x, 8.x, 9.x); no @_cluster@ prefix is +-- involved. +-- +-- () +getRemoteClusterInfo :: BHRequest StatusDependant RemoteClustersInfo +getRemoteClusterInfo = get ["_remote", "info"] + +-- | 'updateVotingConfigExclusions' is the @POST +-- /_cluster/voting_config_exclusions@ endpoint — manually adds +-- voting config exclusions for nodes that have left the cluster +-- permanently, so ES can shrink the voting configuration without +-- waiting for the auto-converge timeout. Pass the 'FullNodeId's +-- and\/or 'NodeName's of the departed nodes via +-- 'VotingConfigExclusionOptions'; the server requires at least one +-- entry across the two lists, otherwise it rejects the request with +-- @validation_exception@. Returns 'Acknowledged'. +-- +-- Note: this endpoint is Elasticsearch-only — OpenSearch does not +-- expose voting config exclusions in its cluster API surface. Calls +-- against an OpenSearch cluster will return HTTP 404. +-- +-- /Wire-shape note/: against live ES 7.17 this endpoint returns +-- HTTP 200 with an /empty/ body (Content-Length: 0), not the +-- @{\"acknowledged\":true}@ envelope 'Acknowledged' nominally +-- expects. 'parseEsResponse' handles this by normalising such an +-- empty body to the JSON value @null@ before invoking the +-- 'Acknowledged' 'FromJSON' instance, which maps @null@ to +-- 'Acknowledged' @True@. The pure endpoint-shape tests in +-- @Test.VotingConfigExclusionsSpec@ cover the request side; the +-- live round-trip covers the response-decoding canary, and +-- @Test.ParseEsResponseSpec@ pins the 'Acknowledged' @null@→@True@ +-- mapping. +-- +-- () +updateVotingConfigExclusions :: + VotingConfigExclusionOptions -> + BHRequest StatusDependant Acknowledged +updateVotingConfigExclusions opts = + post + (["_cluster", "voting_config_exclusions"] `withQueries` votingConfigExclusionOptionsParams opts) + emptyBody + +-- | 'clearVotingConfigExclusions' is the @DELETE +-- /_cluster/voting_config_exclusions@ endpoint — clears all +-- voting config exclusions the cluster is currently holding. Pair +-- with 'updateVotingConfigExclusions' once the departed nodes have +-- been removed from the cluster topology (otherwise the exclusions +-- would block them rejoining). Returns 'Acknowledged'. +-- +-- Note: this endpoint is Elasticsearch-only — OpenSearch does not +-- expose voting config exclusions in its cluster API surface. Calls +-- against an OpenSearch cluster will return HTTP 404. +-- +-- /Wire-shape note/: same as 'updateVotingConfigExclusions' — +-- live ES 7.17 returns 200 with an empty body, decoded to +-- 'Acknowledged' @True@ via 'parseEsResponse' (empty body → +-- @null@ → 'Acknowledged' @True@). +-- +-- () +clearVotingConfigExclusions :: BHRequest StatusDependant Acknowledged +clearVotingConfigExclusions = delete ["_cluster", "voting_config_exclusions"] + +-- | 'getClusterSettings' fetches cluster-wide settings — the +-- @GET /_cluster/settings@ endpoint. Returns the persistent and +-- transient settings layers; the defaults layer is omitted unless the +-- 'csoIncludeDefaults' option is set. Use 'getClusterSettingsWith' to +-- pass URI parameters. +-- +-- () +getClusterSettings :: BHRequest StatusDependant ClusterSettings +getClusterSettings = getClusterSettingsWith defaultClusterSettingsOptions + +-- | 'getClusterSettingsWith' is the fully-parameterised form of +-- 'getClusterSettings'. Every URI parameter accepted by +-- @GET /_cluster/settings@ is exposed via 'ClusterSettingsOptions'; +-- pass 'defaultClusterSettingsOptions' to reproduce the legacy +-- behaviour (no parameters). See 'clusterSettingsOptionsParams' for the +-- rendering of each field. +-- +-- () +getClusterSettingsWith :: ClusterSettingsOptions -> BHRequest StatusDependant ClusterSettings +getClusterSettingsWith opts = + get $ ["_cluster", "settings"] `withQueries` clusterSettingsOptionsParams opts + +-- | 'updateClusterSettings' is the write-side counterpart of +-- 'getClusterSettings' — the @PUT /_cluster/settings@ endpoint. It +-- applies the persistent and\/or transient settings carried by the +-- 'ClusterSettingsUpdate' body; assign 'Null' to a key to clear it. +-- Equivalent to @'updateClusterSettingsWith' +-- 'defaultClusterSettingsUpdateOptions'@ (no URI parameters). +-- +-- /Note/: this builder is 'StatusDependant'. A malformed or rejected +-- setting surfaces as an 'EsError' rather than being swallowed. +-- +-- () +updateClusterSettings :: + ClusterSettingsUpdate -> + BHRequest StatusDependant Acknowledged +updateClusterSettings = updateClusterSettingsWith defaultClusterSettingsUpdateOptions + +-- | 'updateClusterSettingsWith' is the fully-parameterised form of +-- 'updateClusterSettings'. Every URI parameter accepted by +-- @PUT /_cluster/settings@ is exposed via 'ClusterSettingsUpdateOptions' +-- (@flat_settings@, @master_timeout@); pass +-- 'defaultClusterSettingsUpdateOptions' to reproduce the bare behaviour +-- (no parameters). See 'clusterSettingsUpdateOptionsParams' for the +-- rendering of each field. +-- +-- () +updateClusterSettingsWith :: + ClusterSettingsUpdateOptions -> + ClusterSettingsUpdate -> + BHRequest StatusDependant Acknowledged +updateClusterSettingsWith opts update = + put endpoint (encode update) + where + endpoint = + ["_cluster", "settings"] + `withQueries` clusterSettingsUpdateOptionsParams opts + +-- | 'rerouteCluster' manually executes shard reroute commands against +-- the cluster via @POST /_cluster/reroute@. Each 'RerouteCommand' +-- (move, cancel, allocate_replica, ...) is carried in the request body's +-- @commands@ array; the operation takes effect immediately. Returns +-- 'Acknowledged' on success. +-- +-- For the non-mutating @dry_run\@true@ form — which instead returns the +-- resulting cluster state without applying anything — use +-- 'rerouteClusterWith' with 'roDryRun' set; its 'RerouteResponse' +-- surfaces the simulated state in 'rrState'. +-- +-- /Note/: this builder is 'StatusDependant'. A rejected command surfaces +-- as an 'EsError' rather than being swallowed. +-- +-- () +rerouteCluster :: + [RerouteCommand] -> + BHRequest StatusDependant Acknowledged +rerouteCluster cmds = post ["_cluster", "reroute"] (encode body) + where + body = object ["commands" .= cmds] + +-- | 'rerouteClusterWith' is the fully-parameterised form of +-- 'rerouteCluster'. Every URI parameter accepted by +-- @POST /_cluster/reroute@ is exposed via 'RerouteOptions' +-- (@dry_run@, @explain@, @metric@, @master_timeout@, @timeout@); pass +-- 'defaultRerouteOptions' to reproduce the bare behaviour. The response +-- is the rich 'RerouteResponse', whose 'rrState' is populated when +-- @dry_run\@true@ (or @explain@) and whose 'rrExplanations' is populated +-- when @explain\@true@. See 'rerouteOptionsParams' for the rendering of +-- each field. +-- +-- () +rerouteClusterWith :: + RerouteOptions -> + [RerouteCommand] -> + BHRequest StatusDependant RerouteResponse +rerouteClusterWith opts cmds = post endpoint (encode body) + where + body = object ["commands" .= cmds] + endpoint = ["_cluster", "reroute"] `withQueries` rerouteOptionsParams opts + +createIndex :: IndexSettings -> IndexName -> BHRequest StatusDependant Acknowledged +createIndex indexSettings indexName = + put [unIndexName indexName] $ encode indexSettings + +createIndexWith :: + [UpdatableIndexSetting] -> + -- | shard count + Int -> + IndexName -> + BHRequest StatusIndependant Acknowledged +createIndexWith updates shards indexName = + put [unIndexName indexName] body + where + body = + encode $ + object + [ "settings" + .= deepMerge + ( X.singleton "index.number_of_shards" (toJSON shards) + : [u | Object u <- toJSON <$> updates] + ) + ] + +-- | Create an index using the full 'CreateIndexOptions' record, exposing +-- every body field (@settings@, @mappings@, @aliases@) and URI parameter +-- (@wait_for_active_shards@, @master_timeout@, @timeout@) accepted by +-- @PUT \/\@ +-- (). +-- This is a superset of 'createIndex' \/ 'createIndexWith'. +-- +-- Passing @'defaultCreateIndexOptions' { 'cioSettings' = 'Just' s }@ is +-- byte-for-byte identical to @'createIndex' s@ for the body, and adds no +-- URI parameters. +createIndexOptions :: + CreateIndexOptions -> + IndexName -> + BHRequest StatusDependant Acknowledged +createIndexOptions opts indexName = + put endpoint body + where + endpoint = + [unIndexName indexName] + `withQueries` createIndexOptionsParams opts + body = fromMaybe emptyBody (createIndexOptionsBody opts) + +-- | Render the 'CreateIndexOptions' body fields (@settings@, @mappings@, +-- @aliases@) as a single JSON object, returning 'Nothing' when all three +-- are absent (the caller then sends an empty body and lets the server +-- apply its defaults). +createIndexOptionsBody :: CreateIndexOptions -> Maybe L.ByteString +createIndexOptionsBody opts = + case (cioSettings opts, cioMappings opts, cioAliases opts) of + (Nothing, Nothing, Nothing) -> Nothing + _ -> Just . encode . Object $ deepMerge objects + where + objects :: [X.KeyMap Value] + objects = + catMaybes + [ jsonObject <$> cioSettings opts, + X.singleton "mappings" <$> cioMappings opts, + X.singleton "aliases" . Object <$> cioAliases opts + ] + +-- | Render the 'CreateIndexOptions' URI parameters +-- (@wait_for_active_shards@, @master_timeout@, @timeout@) as a list of +-- @(key, value)@ pairs suitable for 'withQueries'. 'Nothing' fields are +-- omitted, so 'defaultCreateIndexOptions' produces an empty list. +createIndexOptionsParams :: CreateIndexOptions -> [(Text, Maybe Text)] +createIndexOptionsParams opts = + catMaybes + [ ("wait_for_active_shards",) . Just . renderActiveShardCount <$> cioWaitForActiveShards opts, + ("master_timeout",) . Just . renderDuration <$> cioMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> cioTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +-- | 'flushIndex' will flush an index given a 'Server' and an 'IndexName'. +-- +-- Equivalent to @'flushIndexWith' 'defaultFlushIndexOptions'@. Use the +-- @With@ variant to pass @wait_if_ongoing@, @force@, @ignore_unavailable@, +-- @allow_no_indices@ or @expand_wildcards@. +-- +-- Returns 'ShardsResult' (the @{\"_shards\": {...}}@ envelope) because +-- ES\/OS wraps the shard stats in a top-level @_shards@ key. The inner +-- 'ShardResult' is reachable via 'srShards'. +flushIndex :: IndexName -> BHRequest StatusDependant ShardsResult +flushIndex = flushIndexWith defaultFlushIndexOptions + +-- | 'flushIndexWith' is the fully-parameterised form of 'flushIndex'. +-- Every URI parameter accepted by @POST //_flush@ is exposed via +-- 'FlushIndexOptions'; pass 'defaultFlushIndexOptions' to reproduce the +-- legacy behaviour (no parameters). +-- +-- () +flushIndexWith :: + FlushIndexOptions -> + IndexName -> + BHRequest StatusDependant ShardsResult +flushIndexWith opts indexName = + post endpoint emptyBody + where + endpoint = + [unIndexName indexName, "_flush"] + `withQueries` flushIndexOptionsParams opts + +-- | 'clearIndexCache' clears the caches (query, fielddata, request) +-- for a single index. Wraps @POST \/\\/_cache\/clear@. +-- +-- Returns 'ShardsResult' (the @{\"_shards\": {...}}@ envelope), like the +-- neighbouring 'flushIndex' and 'refreshIndex', because the ES\/OS +-- response wraps the shard stats in a top-level @_shards@ key. Only +-- @?fielddata@, @?query@, @?request@ for selective clearing are not yet +-- exposed. +-- +-- See +-- +-- and +-- . +-- +-- @since 0.26.0.0 +clearIndexCache :: IndexName -> BHRequest StatusDependant ShardsResult +clearIndexCache indexName = + post [unIndexName indexName, "_cache", "clear"] emptyBody + +-- | 'reloadSearchAnalyzers' reloads an index's updateable search +-- analyzers (picking up changes to synonym files used by +-- @updateable@ @synonym@\/@synonym_graph@ filters). Maps to +-- @POST \/{index}/_reload_search_analyzers@ and returns a +-- 'ReloadSearchAnalyzersResponse'. +-- +-- Equivalent to +-- @'reloadSearchAnalyzersWith' 'defaultReloadSearchAnalyzersOptions'@. +-- Use the @With@ variant to pass @ignore_unavailable@, +-- @allow_no_indices@ or @expand_wildcards@. +-- +-- See +-- +-- and +-- . +-- +-- @since 0.26.0.0 +reloadSearchAnalyzers :: + IndexName -> + BHRequest StatusDependant ReloadSearchAnalyzersResponse +reloadSearchAnalyzers = reloadSearchAnalyzersWith defaultReloadSearchAnalyzersOptions + +-- | 'reloadSearchAnalyzersWith' is the fully-parameterised form of +-- 'reloadSearchAnalyzers'. Every URI parameter accepted by +-- @POST \/{index}/_reload_search_analyzers@ is exposed via +-- 'ReloadSearchAnalyzersOptions'; pass +-- 'defaultReloadSearchAnalyzersOptions' to reproduce the +-- parameterless behaviour. +reloadSearchAnalyzersWith :: + ReloadSearchAnalyzersOptions -> + IndexName -> + BHRequest StatusDependant ReloadSearchAnalyzersResponse +reloadSearchAnalyzersWith opts indexName = + post endpoint emptyBody + where + endpoint = + [unIndexName indexName, "_reload_search_analyzers"] + `withQueries` reloadSearchAnalyzersOptionsParams opts + +-- | 'diskUsage' analyses the disk usage of each field of an index (or +-- the latest backing index of a data stream). Maps to +-- @POST \/{index}/_disk_usage@ and returns a 'DiskUsageResponse'. +-- +-- This is an ES-only feature (core since 7.15, technical preview) and a +-- resource-intensive operation; the API requires +-- @run_expensive_tasks=true@, which 'defaultDiskUsageOptions' sets for +-- you. Equivalent to @'diskUsageWith' 'defaultDiskUsageOptions'@. +-- +-- See +-- . +-- +-- @since 0.26.0.0 +diskUsage :: + IndexName -> + BHRequest StatusDependant DiskUsageResponse +diskUsage = diskUsageWith defaultDiskUsageOptions + +-- | 'diskUsageWith' is the fully-parameterised form of 'diskUsage'. +-- Every URI parameter accepted by @POST \/{index}/_disk_usage@ is +-- exposed via 'DiskUsageOptions'; @run_expensive_tasks@ is always +-- rendered (it is required by the API). +diskUsageWith :: + DiskUsageOptions -> + IndexName -> + BHRequest StatusDependant DiskUsageResponse +diskUsageWith opts indexName = + post endpoint emptyBody + where + endpoint = + [unIndexName indexName, "_disk_usage"] + `withQueries` diskUsageOptionsParams opts + +-- | 'fieldUsageStats' reports, per shard and field, how often each +-- structure (inverted index, stored fields, doc values, ...) was +-- accessed by searches. Maps to +-- @GET \/{index}/_field_usage_stats@ and returns a +-- 'FieldUsageStatsResponse'. +-- +-- This is an ES-only feature (technical preview). Equivalent to +-- @'fieldUsageStatsWith' 'defaultFieldUsageStatsOptions'@. +-- +-- See +-- . +-- +-- @since 0.26.0.0 +fieldUsageStats :: + IndexName -> + BHRequest StatusDependant FieldUsageStatsResponse +fieldUsageStats = fieldUsageStatsWith defaultFieldUsageStatsOptions + +-- | 'fieldUsageStatsWith' is the fully-parameterised form of +-- 'fieldUsageStats'. Every URI parameter accepted by +-- @GET \/{index}/_field_usage_stats@ is exposed via +-- 'FieldUsageStatsOptions'. +fieldUsageStatsWith :: + FieldUsageStatsOptions -> + IndexName -> + BHRequest StatusDependant FieldUsageStatsResponse +fieldUsageStatsWith opts indexName = + get endpoint + where + endpoint = + [unIndexName indexName, "_field_usage_stats"] + `withQueries` fieldUsageStatsOptionsParams opts + +-- $scriptMetadataOverview +-- +-- The @/_script_context@ and @/_script_language@ endpoints expose the +-- cluster's script-engine catalogue: the execution contexts available +-- to Painless \/ expression scripts and, per language, the contexts in +-- which each may run. They are cluster-level GETs that take no path +-- arguments, no query parameters and no request body. @/_script_context@ +-- is shared verbatim by Elasticsearch (7.x\/8.x\/9.x) and OpenSearch +-- (1.x\/2.x\/3.x); @/_script_language@ is served by Elasticsearch +-- (7.x\/8.x\/9.x) and OpenSearch (2.x\/3.x) but returns HTTP 500 on +-- OpenSearch 1.3 (a server bug). +-- +-- The endpoints are undocumented on the 7.17 docs site +-- (@painless-contexts.html@ is 404) but are present on live 7.17.25 +-- clusters. See +-- . + +-- | 'getScriptContexts' lists every Painless \/ expression execution +-- context the cluster knows about, together with the methods (and +-- their parameter signatures) each context exposes. Maps to +-- @GET /_script_context@. +-- +-- @since 0.26.0.0 +getScriptContexts :: + BHRequest StatusDependant ScriptContextsResponse +getScriptContexts = get ["_script_context"] + +-- | 'getScriptLanguages' lists the script languages the cluster +-- supports and, per language, the execution contexts in which each may +-- run. Maps to @GET /_script_language@. +-- +-- Note: on OpenSearch 1.3 this endpoint returns HTTP 500 (a server +-- bug); calls against a 1.3 cluster will fail. +-- +-- @since 0.26.0.0 +getScriptLanguages :: + BHRequest StatusDependant ScriptLanguagesResponse +getScriptLanguages = get ["_script_language"] + +-- | 'deleteIndex' will delete an index given a 'Server' and an 'IndexName'. +-- +-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "didimakeanindex") +-- >>> response <- runBH' $ deleteIndex (IndexName "didimakeanindex") +-- >>> isSuccess response +-- True +-- >>> runBH' $ indexExists (IndexName "didimakeanindex") +-- False +deleteIndex :: IndexName -> BHRequest StatusDependant Acknowledged +deleteIndex indexName = + delete [unIndexName indexName] + +-- | 'updateIndexSettings' will apply a non-empty list of setting updates to an index +-- +-- >>> _ <- runBH' $ createIndex defaultIndexSettings (IndexName "unconfiguredindex") +-- >>> response <- runBH' $ updateIndexSettings (BlocksWrite False :| []) (IndexName "unconfiguredindex") +-- >>> isSuccess response +-- True +-- +-- Equivalent to @'updateIndexSettingsWith' updates 'defaultUpdateIndexSettingsOptions'@. +-- Use the @With@ variant to pass @master_timeout@, @timeout@, +-- @preserve_existing@ or @flat_settings@. +updateIndexSettings :: + NonEmpty UpdatableIndexSetting -> + IndexName -> + BHRequest StatusIndependant Acknowledged +updateIndexSettings updates indexName = + updateIndexSettingsWith updates indexName defaultUpdateIndexSettingsOptions + +-- | 'updateIndexSettingsWith' is the fully-parameterised form of +-- 'updateIndexSettings'. Every URI parameter accepted by +-- @PUT //_settings@ is exposed via 'UpdateIndexSettingsOptions'; +-- pass 'defaultUpdateIndexSettingsOptions' to reproduce the legacy +-- behaviour (no parameters). +-- +-- () +updateIndexSettingsWith :: + NonEmpty UpdatableIndexSetting -> + IndexName -> + UpdateIndexSettingsOptions -> + BHRequest StatusIndependant Acknowledged +updateIndexSettingsWith updates indexName opts = + put endpoint (encode body) + where + endpoint = + [unIndexName indexName, "_settings"] + `withQueries` updateIndexSettingsOptionsParams opts + body = Object (deepMerge [u | Object u <- toJSON <$> toList updates]) + +-- | 'getIndexSettings' retrieves the live settings of a single index. +-- Wraps @GET //_settings@. +-- +-- Equivalent to @'getIndexSettingsWith' name 'defaultGetIndexSettingsOptions'@. +-- Use the @With@ variant to pass @master_timeout@, @flat_settings@, +-- @include_defaults@ or @local@. +getIndexSettings :: IndexName -> BHRequest StatusDependant IndexSettingsSummary +getIndexSettings indexName = + getIndexSettingsWith indexName defaultGetIndexSettingsOptions + +-- | 'getIndexSettingsWith' is the fully-parameterised form of +-- 'getIndexSettings'. Every URI parameter accepted by +-- @GET //_settings@ is exposed via 'GetIndexSettingsOptions'; +-- pass 'defaultGetIndexSettingsOptions' to reproduce the legacy +-- behaviour (no parameters). +-- +-- () +getIndexSettingsWith :: + IndexName -> + GetIndexSettingsOptions -> + BHRequest StatusDependant IndexSettingsSummary +getIndexSettingsWith indexName opts = + get ([unIndexName indexName, "_settings"] `withQueries` getIndexSettingsOptionsParams opts) + +-- | 'getIndexStats' returns statistics for a single index — the +-- @GET \/\\/_stats@ endpoint +-- (). +-- The response covers indexing, search, get, merge, flush, refresh, +-- query_cache, fielddata, docs, store, translog, segments and completion +-- stats; only 'docs' and 'store' are typed on this first cut, the rest +-- being preserved verbatim in 'indexStatMetricsOther'. +getIndexStats :: IndexName -> BHRequest StatusDependant IndexStats +getIndexStats indexName = + get [unIndexName indexName, "_stats"] + +-- | 'getIndex' fetches the full definition of a single index — its +-- @aliases@, @mappings@ and @settings@ — in one request. Wraps the +-- @GET \/\@ endpoint +-- (). +-- Use 'getIndexSettings' when only the settings are needed; 'getIndex' +-- is the right choice when mappings or aliases are also required. +getIndex :: IndexName -> BHRequest StatusDependant IndexInfo +getIndex indexName = + get [unIndexName indexName] + +-- | 'getIndexRecovery' returns information about ongoing and completed +-- shard recoveries for the given index (e.g. after snapshot restore, +-- replica allocation or peer recovery on node restart). Wraps the +-- @GET \/\\/_recovery@ endpoint +-- (). +getIndexRecovery :: IndexName -> BHRequest StatusDependant IndexRecovery +getIndexRecovery indexName = + get [unIndexName indexName, "_recovery"] + +-- | 'getIndexSegments' returns low-level Lucene segment information +-- (one entry per shard copy: primary and each replica) for the given +-- index. Wraps the @GET \/\\/_segments@ endpoint +-- (, +-- also implemented by OpenSearch — see +-- ). +getIndexSegments :: IndexName -> BHRequest StatusDependant IndexSegments +getIndexSegments indexName = + get [unIndexName indexName, "_segments"] + +-- | 'getShardStores' returns store information for every shard copy +-- (primary and each replica) of the given index — where each copy is +-- allocated and its allocation state. Wraps the +-- @GET \/\\/_shard_stores@ endpoint +-- (, +-- also implemented by OpenSearch — see +-- ). +-- +-- Equivalent to @'getShardStoresWith' 'defaultShardStoresOptions'@. Use +-- the @With@ variant to pass @status@ (cluster-health filter), +-- @expand_wildcards@, @ignore_unavailable@ or @allow_no_indices@. +getShardStores :: IndexName -> BHRequest StatusDependant ShardStores +getShardStores indexName = + getShardStoresWith indexName defaultShardStoresOptions + +-- | Like 'getShardStores' but additionally accepts 'ShardStoresOptions' +-- rendered as URI parameters. 'defaultShardStoresOptions' makes this +-- byte-for-byte identical to 'getShardStores'. +getShardStoresWith :: + IndexName -> + ShardStoresOptions -> + BHRequest StatusDependant ShardStores +getShardStoresWith indexName opts = + get ([unIndexName indexName, "_shard_stores"] `withQueries` shardStoresOptionsParams opts) + +-- | 'resolveIndex' resolves indices, aliases and data streams matching +-- the given patterns. Wraps the @GET /_resolve/index\/{name}@ endpoint +-- (, +-- also implemented by OpenSearch — see +-- ). +-- +-- The patterns are joined with @,@ into a single path segment, matching +-- the server's comma-separated multi-target syntax. An empty list is +-- treated as the wildcard @*@ (resolve every index the caller can +-- see). Individual patterns may be literal index names, glob +-- expressions (e.g. @logs-*@), alias names, data-stream names, or +-- @\:\@ remote-cluster references — the server does +-- the expansion. +-- +-- Equivalent to @'resolveIndexWith' 'defaultResolveIndexOptions'@. Use +-- the @With@ variant to pass @expand_wildcards@ (e.g. to surface +-- closed or hidden indices), @ignore_unavailable@ or +-- @allow_no_indices@. +-- +-- This builder is 'StatusDependant' so genuine server-side failures +-- (auth, malformed pattern, 5xx, ...) surface as an 'EsError'. Note +-- that on most backends a missing concrete target does /not/ produce +-- a 404 — the server returns 200 with empty @indices@/@aliases@\/ +-- @data_streams@ arrays. Use the @ignore_unavailable@ option on +-- 'ResolveIndexOptions' (documented on ES 8.x+, silently accepted by +-- OpenSearch) if you need the server to reject unavailable targets. +resolveIndex :: + [IndexPattern] -> + BHRequest StatusDependant ResolvedIndices +resolveIndex = resolveIndexWith defaultResolveIndexOptions + +-- | Like 'resolveIndex' but additionally accepts 'ResolveIndexOptions' +-- rendered as URI parameters. Use 'defaultResolveIndexOptions' to send +-- no parameters at all, in which case the emitted request is +-- byte-for-byte identical to 'resolveIndex'. +resolveIndexWith :: + ResolveIndexOptions -> + [IndexPattern] -> + BHRequest StatusDependant ResolvedIndices +resolveIndexWith opts patterns = + get $ ["_resolve", "index", renderedPatterns] `withQueries` resolveIndexOptionsParams opts + where + renderedPatterns = + if null patterns + then "*" + else T.intercalate "," (map unIndexPattern patterns) + +-- ---------------------------------------------------------------------- +-- Dangling indices (bloodhound-04f.2.16) +-- GET /_dangling, POST /_dangling/{uuid}, DELETE /_dangling/{uuid} +-- Available since Elasticsearch 7.16. OpenSearch does not implement +-- these endpoints; a request against OS surfaces as an EsError. +-- ---------------------------------------------------------------------- + +-- | 'listDanglingIndices' returns every dangling index currently known +-- to the cluster — indices whose shard data exists on disk but that +-- have no cluster-state metadata, e.g. after a partial master-node +-- loss. Wraps @GET /_dangling@ +-- (). +-- +-- A healthy cluster returns an empty list. /Not/ implemented by +-- OpenSearch — a request against an OS backend surfaces as an +-- 'EsError' (typically 404). +listDanglingIndices :: BHRequest StatusDependant [DanglingIndex] +listDanglingIndices = + danglingIndicesResponseList <$> get ["_dangling"] + +-- | 'importDanglingIndex' re-attaches a dangling index to the cluster +-- metadata, restoring it to normal use. Wraps +-- @POST /_dangling/{uuid}@. The server requires the +-- @accept_data_loss=true@ flag — 'defaultImportDanglingIndexOptions' +-- sets it; pass it explicitly via 'importDanglingIndexWith' if you +-- need to also set @master_timeout@ or @timeout@. +importDanglingIndex :: + DanglingIndexUuid -> + BHRequest StatusDependant Acknowledged +importDanglingIndex uuid = + importDanglingIndexWith uuid defaultImportDanglingIndexOptions + +-- | Fully-parameterised form of 'importDanglingIndex'. Every URI +-- parameter accepted by @POST /_dangling/{uuid}@ is exposed via +-- 'ImportDanglingIndexOptions'; pass +-- 'defaultImportDanglingIndexOptions' to reproduce the bare behaviour +-- (only the required @accept_data_loss=true@). +importDanglingIndexWith :: + DanglingIndexUuid -> + ImportDanglingIndexOptions -> + BHRequest StatusDependant Acknowledged +importDanglingIndexWith uuid opts = + post endpoint emptyBody + where + endpoint = + ["_dangling", unDanglingIndexUuid uuid] + `withQueries` importDanglingIndexOptionsParams opts + +-- | 'deleteDanglingIndex' permanently deletes the on-disk data of a +-- dangling index that the cluster will /not/ be re-importing. Wraps +-- @DELETE /_dangling/{uuid}@. Use 'deleteDanglingIndexWith' to pass +-- @master_timeout@ or @timeout@. +deleteDanglingIndex :: + DanglingIndexUuid -> + BHRequest StatusDependant Acknowledged +deleteDanglingIndex uuid = + deleteDanglingIndexWith uuid defaultDeleteDanglingIndexOptions + +-- | Fully-parameterised form of 'deleteDanglingIndex'. Every URI +-- parameter accepted by @DELETE /_dangling/{uuid}@ is exposed via +-- 'DeleteDanglingIndexOptions'; pass +-- 'defaultDeleteDanglingIndexOptions' to send no parameters at all. +deleteDanglingIndexWith :: + DanglingIndexUuid -> + DeleteDanglingIndexOptions -> + BHRequest StatusDependant Acknowledged +deleteDanglingIndexWith uuid opts = + delete (["_dangling", unDanglingIndexUuid uuid] `withQueries` deleteDanglingIndexOptionsParams opts) + +-- | 'forceMergeIndex' +-- +-- The force merge API allows to force merging of one or more indices through +-- an API. The merge relates to the number of segments a Lucene index holds +-- within each shard. The force merge operation allows to reduce the number of +-- segments by merging them. +-- +-- This call will block until the merge is complete. If the http connection is +-- lost, the request will continue in the background, and any new requests will +-- block until the previous force merge is complete. + +-- For more information see +-- . +-- Nothing +-- worthwhile comes back in the response body, so matching on the status +-- should suffice. +-- +-- 'forceMergeIndex' with a maxNumSegments of 1 and onlyExpungeDeletes +-- to True is the main way to release disk space back to the OS being +-- held by deleted documents. +-- +-- >>> let ixn = IndexName "unoptimizedindex" +-- >>> _ <- runBH' $ deleteIndex ixn >> createIndex defaultIndexSettings ixn +-- >>> response <- runBH' $ forceMergeIndex (IndexList (ixn :| [])) (defaultIndexOptimizationSettings { maxNumSegments = Just 1, onlyExpungeDeletes = True }) +-- >>> isSuccess response +-- True +forceMergeIndex :: IndexSelection -> ForceMergeIndexSettings -> BHRequest StatusDependant ShardsResult +forceMergeIndex ixs ForceMergeIndexSettings {..} = + post endpoint emptyBody + where + endpoint = [indexName, "_forcemerge"] `withQueries` params + params = + catMaybes + [ ("max_num_segments",) . Just . showText <$> maxNumSegments, + Just ("only_expunge_deletes", Just (boolQP onlyExpungeDeletes)), + Just ("flush", Just (boolQP flushAfterOptimize)) + ] + indexName = indexSelectionName ixs + +deepMerge :: [Object] -> Object +deepMerge = LS.foldl' (X.unionWith merge) mempty + where + merge (Object a) (Object b) = Object (deepMerge [a, b]) + merge _ b = b + +-- | 'doesExist' issues a HEAD request against the given endpoint and +-- returns 'True' on any 2xx response, 'False' otherwise. Used by +-- 'indexExists', 'aliasExists', 'templateExists' and the +-- version-specific @*Exists@ helpers. Note that any non-2xx status +-- (including 5xx server errors) decodes to 'False'. +doesExist :: Endpoint -> BHRequest StatusDependant Bool +doesExist = + withBHResponse_ isSuccess . head' @StatusDependant @IgnoredBody + +-- | 'indexExists' enables you to check if an index exists. Returns 'Bool' +-- in IO +-- +-- >>> exists <- runBH' $ indexExists testIndex +indexExists :: IndexName -> BHRequest StatusDependant Bool +indexExists indexName = + doesExist [unIndexName indexName] + +-- | 'refreshIndex' will force a refresh on an index. You must +-- do this if you want to read what you wrote. +-- +-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex +-- >>> _ <- runBH' $ refreshIndex testIndex +-- +-- Equivalent to @'refreshIndexWith' 'defaultRefreshIndexOptions'@. Use the +-- @With@ variant to pass @ignore_unavailable@, @allow_no_indices@, +-- @expand_wildcards@ or @force@. +-- +-- Returns 'ShardsResult' (the @{\"_shards\": {...}}@ envelope) because +-- ES\/OS wraps the shard stats in a top-level @_shards@ key. The inner +-- 'ShardResult' is reachable via 'srShards'. +refreshIndex :: IndexName -> BHRequest StatusDependant ShardsResult +refreshIndex = refreshIndexWith defaultRefreshIndexOptions + +-- | 'refreshIndexWith' is the fully-parameterised form of 'refreshIndex'. +-- Every URI parameter accepted by @POST //_refresh@ is exposed via +-- 'RefreshIndexOptions'; pass 'defaultRefreshIndexOptions' to reproduce the +-- legacy behaviour (no parameters). (@force@ has been a no-op server-side +-- since ES 2.1 but is still accepted by every backend.) +-- +-- () +refreshIndexWith :: + RefreshIndexOptions -> + IndexName -> + BHRequest StatusDependant ShardsResult +refreshIndexWith opts indexName = + post endpoint emptyBody + where + endpoint = + [unIndexName indexName, "_refresh"] + `withQueries` refreshIndexOptionsParams opts + +-- | Block until the index becomes available for indexing +-- documents. This is useful for integration tests in which +-- indices are rapidly created and deleted. +-- +-- The previously hard-coded @wait_for_status=yellow@ and @timeout=10s@ +-- parameters are now rendered through 'clusterHealthOptionsParams', but +-- the on-the-wire request and the 'StatusIndependant' / 'HealthStatus' +-- contract are preserved: a 503 returned when the index cannot reach +-- yellow within the timeout is still surfaced as a normal response +-- rather than an error. +waitForYellowIndex :: IndexName -> BHRequest StatusIndependant HealthStatus +waitForYellowIndex indexName = + get endpoint + where + endpoint = + ["_cluster", "health", unIndexName indexName] + `withQueries` clusterHealthOptionsParams opts + opts = + defaultClusterHealthOptions + { choWaitForStatus = Just ClusterHealthYellow, + choTimeout = Just (TimeUnitSeconds, 10) + } + +-- | 'rolloverIndex' rolls an alias over to a new index when the +-- conditions on the current write index are met. The alias must point +-- at exactly one write index whose name ends in a number and increments +-- by one (e.g. @logs-000001@ -> @logs-000002@). Wraps +-- @POST /\/_rollover@. +-- +-- Pass @'Just' conditions@ to set rollover thresholds; pass 'Nothing' +-- to rollover unconditionally (the server may still refuse if the +-- alias has no write index). The full set of body fields +-- (@settings@, @mappings@, @aliases@ for the new index) and URI +-- parameters (@dry_run@, @master_timeout@, @timeout@, +-- @wait_for_active_shards@) are not modelled here. +-- +-- See +-- and . +-- +-- @since 0.26.0.0 +rolloverIndex :: + IndexAliasName -> + Maybe RolloverConditions -> + BHRequest StatusDependant RolloverResponse +rolloverIndex alias mConditions = + post endpoint body + where + endpoint = [unIndexName (indexAliasName alias), "_rollover"] + body = + maybe + emptyBody + (encode . object . pure . ("conditions" .=)) + mConditions + +-- $resize +-- +-- Shrink, split and clone are three near-identical endpoints that all +-- take a source index, a target index name and the same body\/URI +-- parameters as 'createIndexOptions'. Each delegates to +-- 'createIndexOptionsBody' \/ 'createIndexOptionsParams' after +-- unwrapping the typed settings newtype. Endpoint reference URLs live +-- next to the types in +-- "Database.Bloodhound.Internal.Versions.Common.Types.Indices". + +-- | Shrink an existing index into a new index with fewer primary shards. +-- Maps to @POST //_shrink/@ and returns 'Acknowledged' +-- on success. The source index must be made read-only +-- (@index.blocks.write: true@) and every primary shard must be resident +-- on a single node before the call; the target's @number_of_shards@ +-- must be a divisor of the source's. Pass @settings@ via +-- 'shrinkSettingsOptions' to override the target's shard count. +-- +-- See +-- and . +-- +-- @since 0.26.0.0 +shrinkIndex :: + IndexName -> + IndexName -> + ShrinkSettings -> + BHRequest StatusDependant Acknowledged +shrinkIndex source target = + resizeEndpoint source target "_shrink" . shrinkSettingsOptions + +-- | Split an existing index into a new index with more primary shards. +-- Maps to @POST //_split/@ and returns 'Acknowledged' +-- on success. The source index must be read-only +-- (@index.blocks.write: true@); the target's @number_of_shards@ must +-- be a multiple of the source's, and the source's +-- @index.number_of_routing_shards@ must be a multiple of the target's. +-- Pass @settings@ via 'splitSettingsOptions' to set the target shard +-- count. +-- +-- See +-- and . +-- +-- @since 0.26.0.0 +splitIndex :: + IndexName -> + IndexName -> + SplitSettings -> + BHRequest StatusDependant Acknowledged +splitIndex source target = + resizeEndpoint source target "_split" . splitSettingsOptions + +-- | Clone an existing index into a new index with the same mappings and +-- settings. Maps to @POST //_clone/@ and returns +-- 'Acknowledged' on success. The source index must be read-only +-- (@index.blocks.write: true@); the target inherits the source's +-- @number_of_shards@. +-- +-- See +-- and . +-- +-- @since 0.26.0.0 +cloneIndex :: + IndexName -> + IndexName -> + CloneSettings -> + BHRequest StatusDependant Acknowledged +cloneIndex source target = + resizeEndpoint source target "_clone" . cloneSettingsOptions + +-- | Shared request builder for the shrink\/split\/clone endpoints. +-- Path: @POST ///@; body and URI parameters come +-- from the wrapped 'CreateIndexOptions'. +resizeEndpoint :: + IndexName -> + IndexName -> + Text -> + CreateIndexOptions -> + BHRequest StatusDependant Acknowledged +resizeEndpoint source target verb opts = + post endpoint body + where + endpoint = + [unIndexName source, verb, unIndexName target] + `withQueries` createIndexOptionsParams opts + body = fromMaybe emptyBody (createIndexOptionsBody opts) + +openOrCloseIndexes :: OpenCloseIndex -> IndexName -> BHRequest StatusIndependant Acknowledged +openOrCloseIndexes oci = openOrCloseIndexesWith oci defaultOpenCloseIndexOptions + +-- | Shared request builder for the open\/close endpoints, taking the full +-- 'OpenCloseIndexOptions' parameter set. Path: +-- @POST //_open@ (or @_close@); URI parameters come from +-- 'openCloseIndexOptionsParams'. +openOrCloseIndexesWith :: + OpenCloseIndex -> + OpenCloseIndexOptions -> + IndexName -> + BHRequest StatusIndependant Acknowledged +openOrCloseIndexesWith oci opts indexName = + post endpoint emptyBody + where + endpoint = + [unIndexName indexName, stringifyOCIndex] + `withQueries` openCloseIndexOptionsParams opts + stringifyOCIndex = case oci of + OpenIndex -> "_open" + CloseIndex -> "_close" + +-- | 'openIndexWith' is the fully-parameterised form of 'openIndex'. Every +-- URI parameter accepted by @POST //_open@ is exposed via +-- 'OpenCloseIndexOptions'; pass 'defaultOpenCloseIndexOptions' to +-- reproduce the legacy behaviour (no parameters). +-- +-- () +openIndexWith :: + OpenCloseIndexOptions -> + IndexName -> + BHRequest StatusIndependant Acknowledged +openIndexWith = openOrCloseIndexesWith OpenIndex + +-- | 'closeIndexWith' is the fully-parameterised form of 'closeIndex'. Every +-- URI parameter accepted by @POST //_close@ is exposed via +-- 'OpenCloseIndexOptions'; pass 'defaultOpenCloseIndexOptions' to +-- reproduce the legacy behaviour (no parameters). +-- +-- () +closeIndexWith :: + OpenCloseIndexOptions -> + IndexName -> + BHRequest StatusIndependant Acknowledged +closeIndexWith = openOrCloseIndexesWith CloseIndex + +-- | 'openIndex' opens an index given a 'Server' and an 'IndexName'. Explained in further detail at +-- +-- +-- >>> response <- runBH' $ openIndex testIndex +-- +-- Equivalent to @'openIndexWith' 'defaultOpenCloseIndexOptions'@. Use the +-- @With@ variant to pass @wait_for_active_shards@, @ignore_unavailable@, +-- @allow_no_indices@, @expand_wildcards@, @master_timeout@ or @timeout@. +openIndex :: IndexName -> BHRequest StatusIndependant Acknowledged +openIndex = openOrCloseIndexes OpenIndex + +-- | 'closeIndex' closes an index given a 'Server' and an 'IndexName'. Explained in further detail at +-- +-- +-- >>> response <- runBH' $ closeIndex testIndex +-- +-- Equivalent to @'closeIndexWith' 'defaultOpenCloseIndexOptions'@. Use the +-- @With@ variant to pass @wait_for_active_shards@, @ignore_unavailable@, +-- @allow_no_indices@, @expand_wildcards@, @master_timeout@ or @timeout@. +closeIndex :: IndexName -> BHRequest StatusIndependant Acknowledged +closeIndex = openOrCloseIndexes CloseIndex + +-- | 'listIndices' returns a list of all index names on a given 'Server' +listIndices :: BHRequest StatusDependant [IndexName] +listIndices = + map unListedIndexName <$> get ["_cat/indices?format=json"] + +newtype ListedIndexName = ListedIndexName {unListedIndexName :: IndexName} + deriving stock (Eq, Show) + +instance FromJSON ListedIndexName where + parseJSON = + withObject "ListedIndexName" $ \o -> + ListedIndexName <$> o .: "index" + +-- | 'catIndices' returns a list of all index names on a given 'Server' as well as their doc counts +catIndices :: BHRequest StatusDependant [(IndexName, Int)] +catIndices = + map unListedIndexNameWithCount <$> get ["_cat/indices?format=json"] + +newtype ListedIndexNameWithCount = ListedIndexNameWithCount {unListedIndexNameWithCount :: (IndexName, Int)} + deriving stock (Eq, Show) + +instance FromJSON ListedIndexNameWithCount where + parseJSON = + withObject "ListedIndexNameWithCount" $ \o -> do + xs <- (,) <$> o .: "index" <*> o .: "docs.count" + return $ ListedIndexNameWithCount xs + +-- | 'catIndicesWith' is the fully-parameterised form of 'catIndices'. +-- Every URI parameter accepted by @GET /_cat/indices@ is exposed via +-- 'CatIndicesOptions'; pass 'defaultCatIndicesOptions' to reproduce the +-- legacy behaviour (no parameters besides @format=json@). The response +-- is a structured 'CatIndicesRow' per index, with every default column +-- typed (including 'Bytes'\/'CatBytesSize' for @store.size@) and any +-- future columns preserved verbatim in 'cirOther'. +-- +-- See 'catIndicesOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +catIndicesWith :: CatIndicesOptions -> BHRequest StatusDependant [CatIndicesRow] +catIndicesWith opts = + get $ ["_cat", "indices"] `withQueries` catIndicesOptionsParams opts + +-- | 'catAliases' lists every index alias on the cluster via +-- @GET /_cat\/aliases?format=json@. Equivalent to +-- @'catAliasesWith' 'Nothing' 'defaultCatAliasesOptions'@. +-- +-- See 'catAliasesWith' for the parameterised form, and +-- +-- for the upstream documentation. +catAliases :: BHRequest StatusDependant [CatAliasesRow] +catAliases = catAliasesWith Nothing defaultCatAliasesOptions + +-- | 'catAliasesWith' is the fully-parameterised form of 'catAliases'. +-- The optional 'AliasName' narrows the result to a single alias name; +-- it is rendered as the @/@ path segment. (The ES spec also +-- permits comma-separated lists and wildcards in that segment; pass +-- them through by constructing an 'AliasName' wrapping an 'IndexName' +-- that already contains those characters.) Every URI parameter +-- accepted by @GET /_cat\/aliases@ is exposed via 'CatAliasesOptions'; +-- pass 'defaultCatAliasesOptions' to reproduce the legacy behaviour +-- (no parameters besides @format=json@). The response is a structured +-- 'CatAliasesRow' per alias, with every default column typed (including +-- the @"-"@ sentinel for @is_write_index@) and any future columns +-- preserved verbatim in 'carOther'. +-- +-- See 'catAliasesOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +catAliasesWith :: + Maybe AliasName -> + CatAliasesOptions -> + BHRequest StatusDependant [CatAliasesRow] +catAliasesWith mAlias opts = + get $ path `withQueries` catAliasesOptionsParams opts + where + path = case mAlias of + Nothing -> ["_cat", "aliases"] + Just (AliasName name) -> ["_cat", "aliases", unIndexName name] + +-- | 'catAllocation' lists the allocation of disk space for indexes and +-- the number of shards on each data node via +-- @GET /_cat\/allocation?format=json@. Equivalent to +-- @'catAllocationWith' 'Nothing' 'defaultCatAllocationOptions'@. +-- +-- See 'catAllocationWith' for the parameterised form, and +-- +-- for the upstream documentation. +catAllocation :: BHRequest StatusDependant [CatAllocationRow] +catAllocation = catAllocationWith Nothing defaultCatAllocationOptions + +-- | 'catAllocationWith' is the fully-parameterised form of +-- 'catAllocation'. The optional 'NodeName' narrows the result to a +-- specific node; it is rendered as the @/@ path segment. (The +-- ES\/OS spec also permits comma-separated lists and wildcards in that +-- segment; pass them through by constructing a 'NodeName' that already +-- contains those characters.) Every URI parameter accepted by +-- @GET /_cat\/allocation@ is exposed via 'CatAllocationOptions'; pass +-- 'defaultCatAllocationOptions' to reproduce the legacy behaviour (no +-- parameters besides @format=json@). The response is a structured +-- 'CatAllocationRow' per node, with every default column typed +-- (including 'Bytes'\/'CatBytesSize' for the @disk.*@ columns, and the +-- dedicated 'CatShardsUndesired' sum for the @shards.undesired@ @-1@ +-- sentinel) and any future columns preserved verbatim in 'calrOther'. +-- +-- See 'catAllocationOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +catAllocationWith :: + Maybe NodeName -> + CatAllocationOptions -> + BHRequest StatusDependant [CatAllocationRow] +catAllocationWith mNode opts = + get $ path `withQueries` catAllocationOptionsParams opts + where + path = case mNode of + Nothing -> ["_cat", "allocation"] + Just name -> ["_cat", "allocation", nodeName name] + +-- | 'catCount' reports the document count for the whole cluster via +-- @GET /_cat\/count?format=json@. Equivalent to +-- @'catCountWith' 'Nothing' 'defaultCatCountOptions'@. +-- +-- See 'catCountWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catCount :: BHRequest StatusDependant [CatCountRow] +catCount = catCountWith Nothing defaultCatCountOptions + +-- | 'catCountWith' is the fully-parameterised form of 'catCount'. The +-- optional 'IndexName' narrows the count to a single index; it is +-- rendered as the @/@ path segment. (The ES\/OS spec also +-- permits comma-separated lists and wildcards in that segment; pass +-- them through by constructing an 'IndexName' that already contains +-- those characters.) Every URI parameter accepted by +-- @GET /_cat\/count@ is exposed via 'CatCountOptions'; pass +-- 'defaultCatCountOptions' to reproduce the legacy behaviour (no +-- parameters besides @format=json@). The response is a structured +-- 'CatCountRow', with every default column typed and any future columns +-- preserved verbatim in 'ccrOther'. +-- +-- See 'catCountOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catCountWith :: + Maybe IndexName -> + CatCountOptions -> + BHRequest StatusDependant [CatCountRow] +catCountWith mIndex opts = + get $ path `withQueries` catCountOptionsParams opts + where + path = case mIndex of + Nothing -> ["_cat", "count"] + Just name -> ["_cat", "count", unIndexName name] + +-- | 'catMaster' reports the identity of the elected master node via +-- @GET /_cat\/master?format=json@. Equivalent to +-- @'catMasterWith' 'defaultCatMasterOptions'@. +-- +-- See 'catMasterWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catMaster :: BHRequest StatusDependant [CatMasterRow] +catMaster = catMasterWith defaultCatMasterOptions + +-- | 'catMasterWith' is the fully-parameterised form of 'catMaster'. +-- Every URI parameter accepted by @GET /_cat\/master@ is exposed via +-- 'CatMasterOptions'; pass 'defaultCatMasterOptions' to reproduce the +-- legacy behaviour (no parameters besides @format=json@). The response +-- is a structured 'CatMasterRow', with every default column typed and +-- any future columns preserved verbatim in 'cmrOther'. +-- +-- See 'catMasterOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catMasterWith :: + CatMasterOptions -> + BHRequest StatusDependant [CatMasterRow] +catMasterWith opts = + get $ ["_cat", "master"] `withQueries` catMasterOptionsParams opts + +-- | 'catHealth' reports a one-row-per-snapshot summary of cluster +-- health via @GET /_cat\/health?format=json@. Equivalent to +-- @'catHealthWith' 'defaultCatHealthOptions'@. +-- +-- See 'catHealthWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catHealth :: BHRequest StatusDependant [CatHealthRow] +catHealth = catHealthWith defaultCatHealthOptions + +-- | 'catHealthWith' is the fully-parameterised form of 'catHealth'. +-- Every URI parameter accepted by @GET /_cat\/health@ is exposed via +-- 'CatHealthOptions'; pass 'defaultCatHealthOptions' to reproduce the +-- legacy behaviour (no parameters besides @format=json@). The response +-- is a structured 'CatHealthRow', with every default column typed and +-- any future columns preserved verbatim in 'chrOther'. +-- +-- See 'catHealthOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catHealthWith :: + CatHealthOptions -> + BHRequest StatusDependant [CatHealthRow] +catHealthWith opts = + get $ ["_cat", "health"] `withQueries` catHealthOptionsParams opts + +-- | 'catPendingTasks' lists the cluster-level tasks waiting to be +-- executed via @GET /_cat\/pending_tasks?format=json@. Equivalent to +-- @'catPendingTasksWith' 'defaultCatPendingTasksOptions'@. The result +-- list is empty when the cluster is idle. +-- +-- See 'catPendingTasksWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catPendingTasks :: BHRequest StatusDependant [CatPendingTasksRow] +catPendingTasks = catPendingTasksWith defaultCatPendingTasksOptions + +-- | 'catPendingTasksWith' is the fully-parameterised form of +-- 'catPendingTasks'. Every URI parameter accepted by +-- @GET /_cat\/pending_tasks@ is exposed via 'CatPendingTasksOptions'; +-- pass 'defaultCatPendingTasksOptions' to reproduce the legacy +-- behaviour (no parameters besides @format=json@). The response is a +-- structured 'CatPendingTasksRow' per pending task, with every default +-- column typed and any future columns preserved verbatim in +-- 'cptrOther'. +-- +-- See 'catPendingTasksOptionsParams' for the rendering of each field, +-- and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catPendingTasksWith :: + CatPendingTasksOptions -> + BHRequest StatusDependant [CatPendingTasksRow] +catPendingTasksWith opts = + get $ ["_cat", "pending_tasks"] `withQueries` catPendingTasksOptionsParams opts + +-- | 'catPlugins' lists the plugins installed on each node via +-- @GET /_cat\/plugins?format=json@. Equivalent to +-- @'catPluginsWith' 'defaultCatPluginsOptions'@. The result list is +-- empty on a cluster with no plugins installed. +-- +-- See 'catPluginsWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catPlugins :: BHRequest StatusDependant [CatPluginsRow] +catPlugins = catPluginsWith defaultCatPluginsOptions + +-- | 'catPluginsWith' is the fully-parameterised form of 'catPlugins'. +-- Every URI parameter accepted by @GET /_cat\/plugins@ is exposed via +-- 'CatPluginsOptions'; pass 'defaultCatPluginsOptions' to reproduce the +-- legacy behaviour (no parameters besides @format=json@). The response +-- is a structured 'CatPluginsRow' per plugin, with every default column +-- typed and any future columns preserved verbatim in 'cprOther'. +-- +-- See 'catPluginsOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catPluginsWith :: + CatPluginsOptions -> + BHRequest StatusDependant [CatPluginsRow] +catPluginsWith opts = + get $ ["_cat", "plugins"] `withQueries` catPluginsOptionsParams opts + +-- | 'catTemplates' lists the cluster's index templates via +-- @GET /_cat\/templates?format=json@. Equivalent to +-- @'catTemplatesWith' 'Nothing' 'defaultCatTemplatesOptions'@. +-- +-- See 'catTemplatesWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catTemplates :: BHRequest StatusDependant [CatTemplatesRow] +catTemplates = catTemplatesWith Nothing defaultCatTemplatesOptions + +-- | 'catTemplatesWith' is the fully-parameterised form of 'catTemplates'. +-- The optional 'TemplateName' narrows the result to templates matching +-- a single name; it is rendered as the @/@ path segment. (The +-- ES\/OS spec also permits comma-separated lists and wildcards in that +-- segment; pass them through by constructing a 'TemplateName' that +-- already contains those characters.) Every URI parameter accepted by +-- @GET /_cat\/templates@ is exposed via 'CatTemplatesOptions'; pass +-- 'defaultCatTemplatesOptions' to reproduce the legacy behaviour (no +-- parameters besides @format=json@). The response is a structured +-- 'CatTemplatesRow' per template, with every default column typed +-- (including the stringified @index_patterns@\/@composed_of@ columns, +-- kept verbatim) and any future columns preserved verbatim in +-- 'ctprOther'. +-- +-- See 'catTemplatesOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catTemplatesWith :: + Maybe TemplateName -> + CatTemplatesOptions -> + BHRequest StatusDependant [CatTemplatesRow] +catTemplatesWith mName opts = + get $ path `withQueries` catTemplatesOptionsParams opts + where + path = case mName of + Nothing -> ["_cat", "templates"] + Just (TemplateName name) -> ["_cat", "templates", name] + +-- | 'catThreadPool' lists the thread pools of each node via +-- @GET /_cat\/thread_pool?format=json@. Equivalent to +-- @'catThreadPoolWith' 'Nothing' 'defaultCatThreadPoolOptions'@. +-- +-- See 'catThreadPoolWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catThreadPool :: BHRequest StatusDependant [CatThreadPoolRow] +catThreadPool = catThreadPoolWith Nothing defaultCatThreadPoolOptions + +-- | 'catThreadPoolWith' is the fully-parameterised form of +-- 'catThreadPool'. The optional 'IndexName' narrows the result to a +-- specific thread pool; it is rendered as the @/@ path +-- segment. (The thread-pool name is a plain string with no dedicated +-- newtype; following the catAliases\/catCount convention it is carried +-- by 'IndexName' and rendered via 'unIndexName'. The ES\/OS spec also +-- permits comma-separated lists and wildcards in that segment; pass +-- them through by constructing an 'IndexName' that already contains +-- those characters.) Every URI parameter accepted by +-- @GET /_cat\/thread_pool@ is exposed via 'CatThreadPoolOptions'; pass +-- 'defaultCatThreadPoolOptions' to reproduce the legacy behaviour (no +-- parameters besides @format=json@). The response is a structured +-- 'CatThreadPoolRow' per pool, with every default column typed +-- (including @null@-tolerance for the @core@, @max@ and @keep_alive@ +-- columns of non-@fixed@ pool types) and any future columns preserved +-- verbatim in 'ctprlOther'. +-- +-- See 'catThreadPoolOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catThreadPoolWith :: + Maybe IndexName -> + CatThreadPoolOptions -> + BHRequest StatusDependant [CatThreadPoolRow] +catThreadPoolWith mPool opts = + get $ path `withQueries` catThreadPoolOptionsParams opts + where + path = case mPool of + Nothing -> ["_cat", "thread_pool"] + Just name -> ["_cat", "thread_pool", unIndexName name] + +-- | 'catFielddata' lists the amount of heap memory currently used by +-- the field data cache, per field per node, via +-- @GET /_cat\/fielddata?format=json@. Equivalent to +-- @'catFielddataWith' 'Nothing' 'defaultCatFielddataOptions'@. +-- +-- See 'catFielddataWith' for the parameterised form, and +-- +-- for the upstream documentation. +catFielddata :: BHRequest StatusDependant [CatFielddataRow] +catFielddata = catFielddataWith Nothing defaultCatFielddataOptions + +-- | 'catFielddataWith' is the fully-parameterised form of +-- 'catFielddata'. The optional 'FieldName' narrows the result to a +-- specific field; it is rendered as the @/@ path segment. (The +-- ES\/OS spec also permits comma-separated lists and wildcards in that +-- segment; pass them through by constructing a 'FieldName' that already +-- contains those characters.) Every URI parameter accepted by +-- @GET /_cat\/fielddata@ is exposed via 'CatFielddataOptions'; pass +-- 'defaultCatFielddataOptions' to reproduce the legacy behaviour (no +-- parameters besides @format=json@). The response is a structured +-- 'CatFielddataRow' per (node, field), with every default column typed +-- (including 'Bytes'\/'CatBytesSize' for @size@) and any future columns +-- preserved verbatim in 'cfdrOther'. +-- +-- See 'catFielddataOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +catFielddataWith :: + Maybe FieldName -> + CatFielddataOptions -> + BHRequest StatusDependant [CatFielddataRow] +catFielddataWith mField opts = + get $ path `withQueries` catFielddataOptionsParams opts + where + path = case mField of + Nothing -> ["_cat", "fielddata"] + Just fname -> ["_cat", "fielddata", unFieldName fname] + +-- | 'catNodeattrs' lists custom node attributes via +-- @GET /_cat\/nodeattrs?format=json@. Equivalent to +-- @'catNodeattrsWith' 'defaultCatNodeattrsOptions'@. The result list is +-- empty when no custom node attributes are configured. +-- +-- See 'catNodeattrsWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catNodeattrs :: BHRequest StatusDependant [CatNodeattrsRow] +catNodeattrs = catNodeattrsWith defaultCatNodeattrsOptions + +-- | 'catNodeattrsWith' is the fully-parameterised form of +-- 'catNodeattrs'. Every URI parameter accepted by +-- @GET /_cat\/nodeattrs@ is exposed via 'CatNodeattrsOptions'; pass +-- 'defaultCatNodeattrsOptions' to reproduce the legacy behaviour (no +-- parameters besides @format=json@). The response is a structured +-- 'CatNodeattrsRow' per (node, attribute), with every default column +-- typed and any future columns preserved verbatim in 'cnarOther'. +-- +-- See 'catNodeattrsOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catNodeattrsWith :: + CatNodeattrsOptions -> + BHRequest StatusDependant [CatNodeattrsRow] +catNodeattrsWith opts = + get $ ["_cat", "nodeattrs"] `withQueries` catNodeattrsOptionsParams opts + +-- | 'catRepositories' lists snapshot repositories registered on the +-- cluster via @GET /_cat\/repositories?format=json@. Equivalent to +-- @'catRepositoriesWith' 'defaultCatRepositoriesOptions'@. The result +-- list is empty when no repositories are registered. +-- +-- See 'catRepositoriesWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catRepositories :: BHRequest StatusDependant [CatRepositoriesRow] +catRepositories = catRepositoriesWith defaultCatRepositoriesOptions + +-- | 'catRepositoriesWith' is the fully-parameterised form of +-- 'catRepositories'. Every URI parameter accepted by +-- @GET /_cat\/repositories@ is exposed via 'CatRepositoriesOptions'; +-- pass 'defaultCatRepositoriesOptions' to reproduce the legacy +-- behaviour (no parameters besides @format=json@). The response is a +-- structured 'CatRepositoriesRow' per repository, with every default +-- column typed and any future columns preserved verbatim in +-- 'crrOther'. +-- +-- See 'catRepositoriesOptionsParams' for the rendering of each field, +-- and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catRepositoriesWith :: + CatRepositoriesOptions -> + BHRequest StatusDependant [CatRepositoriesRow] +catRepositoriesWith opts = + get $ ["_cat", "repositories"] `withQueries` catRepositoriesOptionsParams opts + +-- | 'catShards' lists the state of every primary and replica shard in +-- the cluster via @GET /_cat\/shards?format=json@. Equivalent to +-- @'catShardsWith' 'Nothing' 'defaultCatShardsOptions'@. +-- +-- See 'catShardsWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catShards :: BHRequest StatusDependant [CatShardsRow] +catShards = catShardsWith Nothing defaultCatShardsOptions + +-- | 'catShardsWith' is the fully-parameterised form of 'catShards'. +-- The optional 'IndexName' narrows the result to a specific index (or +-- index pattern); it is rendered as the @/@ path segment. (The +-- ES\/OS spec also permits comma-separated lists and wildcards in +-- that segment; pass them through by constructing an 'IndexName' that +-- already contains those characters.) Every URI parameter accepted by +-- @GET /_cat\/shards@ is exposed via 'CatShardsOptions'; pass +-- 'defaultCatShardsOptions' to reproduce the legacy behaviour (no +-- parameters besides @format=json@). The response is a structured +-- 'CatShardsRow' per shard, with every default column typed (including +-- 'Bytes'\/'CatBytesSize' for @store@) and any future columns +-- preserved verbatim in 'csrOther'. +-- +-- See 'catShardsOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catShardsWith :: + Maybe IndexName -> + CatShardsOptions -> + BHRequest StatusDependant [CatShardsRow] +catShardsWith mIndex opts = + get $ path `withQueries` catShardsOptionsParams opts + where + path = case mIndex of + Nothing -> ["_cat", "shards"] + Just idx -> ["_cat", "shards", unIndexName idx] + +-- | 'catTasks' lists the tasks currently executing on the cluster via +-- @GET /_cat\/tasks?format=json@. Equivalent to +-- @'catTasksWith' 'defaultCatTasksOptions'@. The result list is empty +-- when the cluster is idle. +-- +-- See 'catTasksWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catTasks :: BHRequest StatusDependant [CatTasksRow] +catTasks = catTasksWith defaultCatTasksOptions + +-- | 'catTasksWith' is the fully-parameterised form of 'catTasks'. +-- Every URI parameter accepted by @GET /_cat\/tasks@ is exposed via +-- 'CatTasksOptions'; pass 'defaultCatTasksOptions' to reproduce the +-- legacy behaviour (no parameters besides @format=json@). The response +-- is a structured 'CatTasksRow' per task, with every default column +-- typed and any future columns preserved verbatim in 'ctrrOther'. +-- +-- See 'catTasksOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catTasksWith :: + CatTasksOptions -> + BHRequest StatusDependant [CatTasksRow] +catTasksWith opts = + get $ ["_cat", "tasks"] `withQueries` catTasksOptionsParams opts + +-- | 'catSnapshots' lists the snapshots stored in every snapshot +-- repository registered on the cluster via +-- @GET /_cat\/snapshots?format=json@. Equivalent to +-- @'catSnapshotsWith' 'Nothing' 'defaultCatSnapshotsOptions'@. +-- +-- See 'catSnapshotsWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catSnapshots :: BHRequest StatusDependant [CatSnapshotsRow] +catSnapshots = catSnapshotsWith Nothing defaultCatSnapshotsOptions + +-- | 'catSnapshotsWith' is the fully-parameterised form of +-- 'catSnapshots'. The optional 'SnapshotRepoName' narrows the result +-- to one or more repositories; it is rendered as the @/@ +-- path segment. (The ES\/OS spec also permits comma-separated lists +-- and wildcards in that segment, plus the @_all@ sentinel; pass them +-- through by constructing a 'SnapshotRepoName' that already contains +-- those characters.) Every URI parameter accepted by +-- @GET /_cat\/snapshots@ is exposed via 'CatSnapshotsOptions'; pass +-- 'defaultCatSnapshotsOptions' to reproduce the legacy behaviour (no +-- parameters besides @format=json@). The response is a structured +-- 'CatSnapshotsRow' per snapshot, with every default column typed and +-- any future columns preserved verbatim in 'csnrOther'. +-- +-- See 'catSnapshotsOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catSnapshotsWith :: + Maybe SnapshotRepoName -> + CatSnapshotsOptions -> + BHRequest StatusDependant [CatSnapshotsRow] +catSnapshotsWith mRepo opts = + get $ path `withQueries` catSnapshotsOptionsParams opts + where + path = case mRepo of + Nothing -> ["_cat", "snapshots"] + Just repo -> ["_cat", "snapshots", snapshotRepoName repo] + +-- | 'catNodes' lists the cluster topology — one row per node with its +-- identity, resource usage, and elected-master flag — via +-- @GET /_cat\/nodes?format=json@. Equivalent to +-- @'catNodesWith' 'defaultCatNodesOptions'@. +-- +-- See 'catNodesWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catNodes :: BHRequest StatusDependant [CatNodesRow] +catNodes = catNodesWith defaultCatNodesOptions + +-- | 'catNodesWith' is the fully-parameterised form of 'catNodes'. Every +-- URI parameter accepted by @GET /_cat\/nodes@ is exposed via +-- 'CatNodesOptions'; pass 'defaultCatNodesOptions' to reproduce the +-- legacy behaviour (no parameters besides @format=json@). The response +-- is a structured 'CatNodesRow' per node, with every default column +-- typed (including 'Bytes'\/'CatBytesSize' for the @heap.*@, @ram.*@, +-- and @disk.*@ columns, and the dedicated 'CatNodesMaster' sum for the +-- @master@ @\"*\"@\/@\"-\"@ sentinel) and any future columns preserved +-- verbatim in 'cnrOther'. +-- +-- Unlike @_cat\/allocation@ and @_cat\/shards@, the @_cat\/nodes@ +-- endpoint does not accept a path-segment filter (no +-- @GET /_cat\/nodes/\@ form exists on either ES or OS). To +-- narrow the result, use the @h@ parameter to select columns and filter +-- the returned list client-side. +-- +-- See 'catNodesOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catNodesWith :: + CatNodesOptions -> + BHRequest StatusDependant [CatNodesRow] +catNodesWith opts = + get $ ["_cat", "nodes"] `withQueries` catNodesOptionsParams opts + +-- | 'catSegments' lists the low-level Lucene segments of each shard of +-- each index via @GET /_cat\/segments?format=json@. Equivalent to +-- @'catSegmentsWith' 'Nothing' 'defaultCatSegmentsOptions'@. +-- +-- See 'catSegmentsWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catSegments :: BHRequest StatusDependant [CatSegmentsRow] +catSegments = catSegmentsWith Nothing defaultCatSegmentsOptions + +-- | 'catSegmentsWith' is the fully-parameterised form of 'catSegments'. +-- The optional 'IndexName' scopes the result to a single index via +-- @GET /\/_cat\/segments?format=json@. Every URI parameter +-- accepted by the endpoint is exposed via 'CatSegmentsOptions'; pass +-- 'defaultCatSegmentsOptions' to reproduce the legacy behaviour (no +-- parameters besides @format=json@). The response is a structured +-- 'CatSegmentsRow' per segment, with every default column typed and any +-- future columns preserved verbatim in 'cserOther'. +-- +-- See 'catSegmentsOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catSegmentsWith :: + Maybe IndexName -> + CatSegmentsOptions -> + BHRequest StatusDependant [CatSegmentsRow] +catSegmentsWith mIndex opts = + get $ path `withQueries` catSegmentsOptionsParams opts + where + path = case mIndex of + Nothing -> ["_cat", "segments"] + Just idx -> [unIndexName idx, "_cat", "segments"] + +-- | 'catRecovery' lists shard recovery progress for each shard of each +-- index via @GET /_cat\/recovery?format=json@. Equivalent to +-- @'catRecoveryWith' 'Nothing' 'defaultCatRecoveryOptions'@. +-- +-- See 'catRecoveryWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catRecovery :: BHRequest StatusDependant [CatRecoveryRow] +catRecovery = catRecoveryWith Nothing defaultCatRecoveryOptions + +-- | 'catRecoveryWith' is the fully-parameterised form of 'catRecovery'. +-- The optional 'IndexName' scopes the result to a single index via +-- @GET /\/_cat\/recovery?format=json@. Every URI parameter +-- accepted by the endpoint is exposed via 'CatRecoveryOptions'; pass +-- 'defaultCatRecoveryOptions' to reproduce the legacy behaviour (no +-- parameters besides @format=json@). The response is a structured +-- 'CatRecoveryRow' per recovery, with every default column typed and +-- any future columns preserved verbatim in 'cryrOther'. +-- +-- See 'catRecoveryOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catRecoveryWith :: + Maybe IndexName -> + CatRecoveryOptions -> + BHRequest StatusDependant [CatRecoveryRow] +catRecoveryWith mIndex opts = + get $ path `withQueries` catRecoveryOptionsParams opts + where + path = case mIndex of + Nothing -> ["_cat", "recovery"] + Just idx -> [unIndexName idx, "_cat", "recovery"] + +-- | 'catComponentTemplates' lists the component templates via +-- @GET /_cat\/component_templates?format=json@. Equivalent to +-- @'catComponentTemplatesWith' 'Nothing' 'defaultCatComponentTemplatesOptions'@. +-- The optional name narrows the result (and accepts wildcards). +-- +-- See 'catComponentTemplatesWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catComponentTemplates :: BHRequest StatusDependant [CatComponentTemplatesRow] +catComponentTemplates = + catComponentTemplatesWith Nothing defaultCatComponentTemplatesOptions + +-- | 'catComponentTemplatesWith' is the fully-parameterised form of +-- 'catComponentTemplates'. The optional 'Text' narrows the result to a +-- component template name (comma-separated lists and wildcards are +-- accepted by the server; pass them through verbatim). Every URI +-- parameter accepted by @GET /_cat\/component_templates@ is exposed via +-- 'CatComponentTemplatesOptions'. The response is a structured +-- 'CatComponentTemplatesRow' per template; the @version@ column is +-- emitted either as the literal string @"null"@ or as a native JSON +-- @null@ (both decode safely), and any future columns are preserved +-- verbatim in 'cctrOther'. +-- +-- See 'catComponentTemplatesOptionsParams' for the rendering of each +-- field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catComponentTemplatesWith :: + Maybe Text -> + CatComponentTemplatesOptions -> + BHRequest StatusDependant [CatComponentTemplatesRow] +catComponentTemplatesWith mName opts = + get $ path `withQueries` catComponentTemplatesOptionsParams opts + where + path = case mName of + Nothing -> ["_cat", "component_templates"] + Just name -> ["_cat", "component_templates", name] + +-- | 'catCircuitBreakers' lists the JVM circuit breakers via +-- @GET /_cat\/circuit_breaker?format=json@. Equivalent to +-- @'catCircuitBreakersWith' 'Nothing' 'defaultCatCircuitBreakersOptions'@. +-- +-- See 'catCircuitBreakersWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catCircuitBreakers :: BHRequest StatusDependant [CatCircuitBreakersRow] +catCircuitBreakers = + catCircuitBreakersWith Nothing defaultCatCircuitBreakersOptions + +-- | 'catCircuitBreakersWith' is the fully-parameterised form of +-- 'catCircuitBreakers'. The optional 'Text' is a comma-separated list of +-- regular expressions filtering the breaker names. Every URI parameter +-- accepted by @GET /_cat\/circuit_breaker@ is exposed via +-- 'CatCircuitBreakersOptions'. The response is a structured +-- 'CatCircuitBreakersRow' per breaker, with humanised @limit@\/@estimated +-- sizes, raw-byte @_bytes@ counts, and any future columns preserved +-- verbatim in 'ccbrOther'. +-- +-- See 'catCircuitBreakersOptionsParams' for the rendering of each field, +-- and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catCircuitBreakersWith :: + Maybe Text -> + CatCircuitBreakersOptions -> + BHRequest StatusDependant [CatCircuitBreakersRow] +catCircuitBreakersWith mPatterns opts = + get $ path `withQueries` catCircuitBreakersOptionsParams opts + where + path = case mPatterns of + Nothing -> ["_cat", "circuit_breaker"] + Just patterns -> ["_cat", "circuit_breaker", patterns] + +-- | 'catMlJobs' lists the ML anomaly-detection jobs via +-- @GET /_cat\/ml\/anomaly_detectors?format=json@. Equivalent to +-- @'catMlJobsWith' 'Nothing' 'defaultCatMlJobsOptions'@. +-- +-- See 'catMlJobsWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catMlJobs :: BHRequest StatusDependant [CatMlJobsRow] +catMlJobs = catMlJobsWith Nothing defaultCatMlJobsOptions + +-- | 'catMlJobsWith' is the fully-parameterised form of 'catMlJobs'. The +-- optional 'Text' narrows the result to a job id (wildcards accepted). +-- Every URI parameter accepted by +-- @GET /_cat\/ml\/anomaly_detectors@ is exposed via 'CatMlJobsOptions'. +-- The response is a structured 'CatMlJobsRow' per job; the commonly-used +-- columns are typed and anything else is preserved verbatim in +-- 'cmjrOther'. +-- +-- See 'catMlJobsOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catMlJobsWith :: + Maybe Text -> + CatMlJobsOptions -> + BHRequest StatusDependant [CatMlJobsRow] +catMlJobsWith mJobId opts = + get $ path `withQueries` catMlJobsOptionsParams opts + where + path = case mJobId of + Nothing -> ["_cat", "ml", "anomaly_detectors"] + Just jobId -> ["_cat", "ml", "anomaly_detectors", jobId] + +-- | 'catMlDataFrameAnalytics' lists the ML data frame analytics jobs via +-- @GET /_cat\/ml\/data_frame\/analytics?format=json@. Equivalent to +-- @'catMlDataFrameAnalyticsWith' 'Nothing' 'defaultCatMlDataFrameAnalyticsOptions'@. +-- +-- See 'catMlDataFrameAnalyticsWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catMlDataFrameAnalytics :: + BHRequest StatusDependant [CatMlDataFrameAnalyticsRow] +catMlDataFrameAnalytics = + catMlDataFrameAnalyticsWith Nothing defaultCatMlDataFrameAnalyticsOptions + +-- | 'catMlDataFrameAnalyticsWith' is the fully-parameterised form of +-- 'catMlDataFrameAnalytics'. The optional 'Text' narrows the result to an +-- analytics job id (wildcards accepted). Every URI parameter accepted by +-- @GET /_cat\/ml\/data_frame\/analytics@ is exposed via +-- 'CatMlDataFrameAnalyticsOptions'. The response is a structured +-- 'CatMlDataFrameAnalyticsRow' per job, with every default column typed +-- and any future columns preserved verbatim in 'cmfaOther'. +-- +-- See 'catMlDataFrameAnalyticsOptionsParams' for the rendering of each +-- field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catMlDataFrameAnalyticsWith :: + Maybe Text -> + CatMlDataFrameAnalyticsOptions -> + BHRequest StatusDependant [CatMlDataFrameAnalyticsRow] +catMlDataFrameAnalyticsWith mId opts = + get $ path `withQueries` catMlDataFrameAnalyticsOptionsParams opts + where + path = case mId of + Nothing -> ["_cat", "ml", "data_frame", "analytics"] + Just i -> ["_cat", "ml", "data_frame", "analytics", i] + +-- | 'catMlDatafeeds' lists the ML datafeeds via +-- @GET /_cat\/ml\/datafeeds?format=json@. Equivalent to +-- @'catMlDatafeedsWith' 'Nothing' 'defaultCatMlDatafeedsOptions'@. +-- +-- See 'catMlDatafeedsWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catMlDatafeeds :: BHRequest StatusDependant [CatMlDatafeedsRow] +catMlDatafeeds = catMlDatafeedsWith Nothing defaultCatMlDatafeedsOptions + +-- | 'catMlDatafeedsWith' is the fully-parameterised form of +-- 'catMlDatafeeds'. The optional 'Text' narrows the result to a datafeed +-- id (wildcards accepted). Every URI parameter accepted by +-- @GET /_cat\/ml\/datafeeds@ is exposed via 'CatMlDatafeedsOptions'. The +-- response is a structured 'CatMlDatafeedsRow' per datafeed, with every +-- default column typed and any future columns preserved verbatim in +-- 'cmdfOther'. +-- +-- See 'catMlDatafeedsOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catMlDatafeedsWith :: + Maybe Text -> + CatMlDatafeedsOptions -> + BHRequest StatusDependant [CatMlDatafeedsRow] +catMlDatafeedsWith mDatafeedId opts = + get $ path `withQueries` catMlDatafeedsOptionsParams opts + where + path = case mDatafeedId of + Nothing -> ["_cat", "ml", "datafeeds"] + Just datafeedId -> ["_cat", "ml", "datafeeds", datafeedId] + +-- | 'catMlTrainedModels' lists the ML trained models via +-- @GET /_cat\/ml\/trained_models?format=json@. Equivalent to +-- @'catMlTrainedModelsWith' 'Nothing' 'defaultCatMlTrainedModelsOptions'@. +-- +-- See 'catMlTrainedModelsWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catMlTrainedModels :: BHRequest StatusDependant [CatMlTrainedModelsRow] +catMlTrainedModels = + catMlTrainedModelsWith Nothing defaultCatMlTrainedModelsOptions + +-- | 'catMlTrainedModelsWith' is the fully-parameterised form of +-- 'catMlTrainedModels'. The optional 'Text' narrows the result to a model +-- id (wildcards accepted). Every URI parameter accepted by +-- @GET /_cat\/ml\/trained_models@ — including the @from@\/@size@ +-- pagination — is exposed via 'CatMlTrainedModelsOptions'. The response +-- is a structured 'CatMlTrainedModelsRow' per model, with every default +-- column typed and any future columns preserved verbatim in 'ctmrOther'. +-- +-- See 'catMlTrainedModelsOptionsParams' for the rendering of each field, +-- and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catMlTrainedModelsWith :: + Maybe Text -> + CatMlTrainedModelsOptions -> + BHRequest StatusDependant [CatMlTrainedModelsRow] +catMlTrainedModelsWith mModelId opts = + get $ path `withQueries` catMlTrainedModelsOptionsParams opts + where + path = case mModelId of + Nothing -> ["_cat", "ml", "trained_models"] + Just modelId -> ["_cat", "ml", "trained_models", modelId] + +-- | 'catTransforms' lists the transforms via +-- @GET /_cat\/transforms?format=json@. Equivalent to +-- @'catTransformsWith' 'Nothing' 'defaultCatTransformsOptions'@. +-- +-- See 'catTransformsWith' for the parameterised form, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catTransforms :: BHRequest StatusDependant [CatTransformsRow] +catTransforms = catTransformsWith Nothing defaultCatTransformsOptions + +-- | 'catTransformsWith' is the fully-parameterised form of +-- 'catTransforms'. The optional 'Text' narrows the result to a transform +-- id (wildcards accepted). Every URI parameter accepted by +-- @GET /_cat\/transforms@ — including the @from@\/@size@ pagination — is +-- exposed via 'CatTransformsOptions'. The response is a structured +-- 'CatTransformsRow' per transform, with every default column typed (the +-- natively-nullable @checkpoint_progress@\/@last_search_time@\/ +-- @changes_last_detection_time@ columns decode to 'Nothing') and any +-- future columns preserved verbatim in 'ctxrOther'. +-- +-- See 'catTransformsOptionsParams' for the rendering of each field, and +-- +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catTransformsWith :: + Maybe Text -> + CatTransformsOptions -> + BHRequest StatusDependant [CatTransformsRow] +catTransformsWith mTransformId opts = + get $ path `withQueries` catTransformsOptionsParams opts + where + path = case mTransformId of + Nothing -> ["_cat", "transforms"] + Just transformId -> ["_cat", "transforms", transformId] + +-- | 'catHelp' shows help for the CAT APIs via @GET /_cat@, returning the +-- available cat commands as a plain-text report (the @=^.^=@ banner +-- followed by the endpoint list, the same output @curl /_cat@ produces). +-- This targets the cat root rather than the @/_cat/help@ alias because +-- the root is the only path accepted across every supported backend +-- (@/_cat/help@ 405s on ES 7.x). Unlike the other @cat*@ requests, this +-- endpoint takes no URI parameters and returns a non-JSON body, so it +-- uses 'Database.Bloodhound.Internal.Utils.Requests.getText' and yields +-- 'Text' rather than a structured row list. +-- +-- See +-- for the upstream documentation. +-- +-- @since 0.26.0.0 +catHelp :: BHRequest StatusDependant Text +catHelp = getText ["_cat"] + +-- | 'addIndexBlock' applies an 'IndexBlock' to an index via +-- @PUT /\/_block/\@, returning 'Acknowledged' on +-- success. Useful for cluster maintenance: temporarily disabling +-- writes, reads, or metadata operations without closing the index. +-- +-- See +-- and . +-- +-- @since 0.26.0.0 +addIndexBlock :: + IndexName -> + IndexBlock -> + BHRequest StatusDependant Acknowledged +addIndexBlock indexName block = + put [unIndexName indexName, "_block", indexBlockText block] emptyBody + +-- | 'removeIndexBlock' releases an 'IndexBlock' from an index, returning +-- 'Acknowledged' on success. Counterpart to 'addIndexBlock'. +-- +-- Although the dedicated @PUT /\/_block/\@ endpoint is +-- documented for applying a block, it is add-only on every supported +-- backend (ES7+ and OS1+ all reject @DELETE /\/_block/\@ +-- with HTTP 405, and none recognise a @?remove=true@ parameter). The +-- canonical removal path is therefore @PUT /\/_settings@ with +-- the matching @BlocksX False@ 'UpdatableIndexSetting', which ES\/OS +-- honour even while a @metadata@ block is in effect (that block rejects +-- @GET /\/_settings@ but permits the @PUT@). This function +-- encapsulates that routing so callers see a single, +-- 'IndexBlock'-parameterised teardown. +-- +-- See +-- and . +-- +-- @since 0.26.0.0 +removeIndexBlock :: + IndexName -> + IndexBlock -> + BHRequest StatusDependant Acknowledged +removeIndexBlock indexName block = + put [unIndexName indexName, "_settings"] (encode body) + where + body = toJSON (indexBlockToUpdatable block) + +-- | 'updateIndexAliases' updates the server's index alias +-- table. Operations are atomic. Explained in further detail at +-- +-- +-- >>> let src = IndexName "a-real-index" +-- >>> let aliasName = IndexName "an-alias" +-- >>> let iAlias = IndexAlias src (IndexAliasName aliasName) +-- >>> let aliasCreate = defaultIndexAliasCreate +-- >>> _ <- runBH' $ deleteIndex src +-- >>> isSuccess <$> runBH' (createIndex defaultIndexSettings src) +-- True +-- >>> runBH' $ indexExists src +-- True +-- >>> isSuccess <$> runBH' (updateIndexAliases (AddAlias iAlias aliasCreate :| [])) +-- True +-- >>> runBH' $ indexExists aliasName +-- True +updateIndexAliases :: NonEmpty IndexAliasAction -> BHRequest StatusIndependant Acknowledged +updateIndexAliases = updateIndexAliasesWith defaultUpdateAliasesOptions + +-- | 'updateIndexAliasesWith' is the fully-parameterised form of +-- 'updateIndexAliases'. Every URI parameter accepted by +-- @POST /_aliases@ is exposed via 'UpdateAliasesOptions' +-- (@master_timeout@, @timeout@); pass 'defaultUpdateAliasesOptions' to +-- reproduce the bare behaviour (no parameters). See +-- 'updateAliasesOptionsParams' for the rendering of each field. +-- +-- () +updateIndexAliasesWith :: + UpdateAliasesOptions -> + NonEmpty IndexAliasAction -> + BHRequest StatusIndependant Acknowledged +updateIndexAliasesWith opts actions = + post (["_aliases"] `withQueries` updateAliasesOptionsParams opts) (encode body) + where + body = object ["actions" .= toList actions] + +-- | Get all aliases configured on the server. +getIndexAliases :: BHRequest StatusDependant IndexAliasesSummary +getIndexAliases = + get ["_aliases"] + +-- | Get aliases for a single source index, optionally narrowed to one +-- alias name. Hits: +-- +-- * @GET /{index}/_alias\/{name}@ when the 'AliasName' is supplied; +-- * @GET /{index}/_alias@ (every alias on that index) when it is not. +-- +-- The wire shape is identical to 'getIndexAliases' (the +-- @{index: {aliases: {...}}}@ envelope), but the result is wrapped in +-- 'IndexAliasesInfo' so callers can distinguish a per-index lookup +-- from a server-wide one at the type level. Like the other alias +-- getters, this is 'StatusDependant': a 404 (index missing, or the named alias +-- not attached to that index) surfaces as an 'EsError' rather than an +-- empty list — wrap with 'tryEsError' for a miss-tolerant variant. +-- +-- () +getIndexAlias :: + IndexName -> + Maybe AliasName -> + BHRequest StatusDependant IndexAliasesInfo +getIndexAlias srcIndex mAlias = + get endpoint + where + endpoint = + case mAlias of + Just (AliasName name) -> [unIndexName srcIndex, "_alias", unIndexName name] + Nothing -> [unIndexName srcIndex, "_alias"] + +-- | Delete a single alias name, removing it from /every/ index it is +-- currently associated with. Hits +-- @DELETE /_all\/_alias\/{name}@ — the @_all@ wildcard means an alias +-- shared by several indices is detached from all of them in one shot. +-- +-- To remove an alias from one specific source index only (leaving any +-- other bindings intact), use 'deleteIndexAliasFrom'. +deleteIndexAlias :: IndexAliasName -> BHRequest StatusIndependant Acknowledged +deleteIndexAlias (IndexAliasName name) = + delete ["_all", "_alias", unIndexName name] + +-- | Remove an alias from a single source index, hitting +-- @DELETE /{index}/_alias/{name}@. Unlike 'deleteIndexAlias' (which +-- uses the @_all@ wildcard), this leaves any other index that happens +-- to publish the same alias name untouched. +-- +-- () +deleteIndexAliasFrom :: + IndexName -> + IndexAliasName -> + BHRequest StatusIndependant Acknowledged +deleteIndexAliasFrom srcIndex (IndexAliasName name) = + delete [unIndexName srcIndex, "_alias", unIndexName name] + +-- | Add an alias to a single index, hitting +-- @PUT /{index}/_alias/{name}@. This is the non-atomic, single-action +-- variant of 'updateIndexAliases': unlike the bulk @POST /_aliases@ +-- endpoint, it does not bundle multiple actions and is not atomic +-- across several indices. Pass 'defaultIndexAliasCreate' for an empty +-- alias body, or override fields such as 'aliasCreateIsWriteIndex' via +-- record update. +-- +-- >>> _ <- runBH' $ createIndexAlias (IndexName "my-index") (IndexAliasName (IndexName "my-alias")) defaultIndexAliasCreate +-- +-- () +createIndexAlias :: + IndexName -> + IndexAliasName -> + IndexAliasCreate -> + BHRequest StatusIndependant Acknowledged +createIndexAlias srcIndex (IndexAliasName name) body = + put [unIndexName srcIndex, "_alias", unIndexName name] (encode body) + +-- | Check whether an alias name exists anywhere in the cluster, +-- hitting @HEAD /_alias/{name}@. Returns 'True' on a 2xx response and +-- 'False' on any other status (including 404); the request never +-- throws on absence. +-- +-- >>> present <- runBH' $ aliasExists (IndexAliasName (IndexName "my-alias")) +-- +-- () +aliasExists :: IndexAliasName -> BHRequest StatusDependant Bool +aliasExists (IndexAliasName name) = + doesExist ["_alias", unIndexName name] + +-- | 'putTemplate' creates a template given an 'IndexTemplate' and a 'TemplateName'. +-- Explained in further detail at +-- +-- +-- >>> let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping] +-- >>> resp <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl") +putTemplate :: IndexTemplate -> TemplateName -> BHRequest StatusIndependant Acknowledged +putTemplate indexTemplate (TemplateName templateName) = + put ["_template", templateName] (encode indexTemplate) + +-- | 'templateExists' checks to see if a template exists. +-- +-- >>> exists <- runBH' $ templateExists (TemplateName "tweet-tpl") +templateExists :: TemplateName -> BHRequest StatusDependant Bool +templateExists (TemplateName templateName) = + doesExist ["_template", templateName] + +-- | 'getTemplate' fetches /legacy/ templates (the @GET /_template@ +-- endpoint). It is the read-side counterpart of 'putTemplate' (and the +-- legacy analogue of the composable 'getIndexTemplate'). +-- +-- * @'Nothing'@ → @GET /_template@ returns every +-- legacy template on the cluster. +-- * @'Just' ('TemplateNamePattern' p)@ → @GET /_template\/\@p@ returns +-- the templates whose names match the pattern. @p@ may be a literal +-- name (no wildcard characters), a glob such as @"tweet-*"@, or a +-- comma-separated list; the server does the matching. A pattern that +-- matches no template yields a @404@, which (because this builder is +-- 'StatusDependant') surfaces as an 'EsError' — callers that want +-- miss-tolerant lookup should use 'tryPerformBHRequest'. +-- +-- The response is always a list (the wire envelope +-- @{name1: body1, name2: body2, ...}@ is peeled off by +-- 'GetTemplatesResponse' and each entry's outer key is lifted into its +-- 'tiName'), even when the pattern matches exactly one template. The +-- body of each 'TemplateInfo' is decoded into raw JSON for the +-- server-normalised @settings@ \/ @mappings@ fields; see 'TemplateInfo' +-- for why those are not typed. +-- +-- () +getTemplate :: + Maybe TemplateNamePattern -> + BHRequest StatusDependant [TemplateInfo] +getTemplate mPattern = + getTemplatesResponseTemplates <$> get endpoint + where + endpoint = + case mPattern of + Nothing -> ["_template"] + Just (TemplateNamePattern pat) -> ["_template", pat] + +-- | 'deleteTemplate' is an HTTP DELETE and deletes a template. +-- +-- >>> let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1))) [toJSON TweetMapping] +-- >>> _ <- runBH' $ putTemplate idxTpl (TemplateName "tweet-tpl") +-- >>> resp <- runBH' $ deleteTemplate (TemplateName "tweet-tpl") +deleteTemplate :: TemplateName -> BHRequest StatusIndependant Acknowledged +deleteTemplate (TemplateName templateName) = + delete ["_template", templateName] + +-- | 'putIndexTemplate' creates or updates a /composable/ index template +-- (the @PUT /_index_template/{name}@ endpoint, available since +-- Elasticsearch 7.8 and in OpenSearch 2.x). This is the modern +-- replacement for the legacy 'putTemplate' (which targets +-- @PUT /_template@): composable templates can be assembled from +-- reusable component templates and carry an explicit 'ctPriority' for +-- deterministic conflict resolution. +-- +-- This builder is 'StatusDependant', so a 4xx (e.g. an invalid body) +-- is surfaced as an 'EsError' rather than swallowed — matching +-- 'createIndex' and unlike the legacy 'putTemplate'. To fail when a +-- template with the given name already exists, use +-- 'putIndexTemplateWith' with @'ctoCreate' = 'Just' True@. +-- +-- () +putIndexTemplate :: + TemplateName -> + ComposableTemplate -> + BHRequest StatusDependant Acknowledged +putIndexTemplate (TemplateName templateName) template = + put ["_index_template", templateName] (encode template) + +-- | Like 'putIndexTemplate' but additionally accepts +-- 'ComposableTemplateOptions' rendered as URI parameters. Use +-- 'defaultComposableTemplateOptions' to send no parameters at all, in +-- which case the emitted request is byte-for-byte identical to +-- 'putIndexTemplate'. +putIndexTemplateWith :: + TemplateName -> + ComposableTemplate -> + ComposableTemplateOptions -> + BHRequest StatusDependant Acknowledged +putIndexTemplateWith (TemplateName templateName) template opts = + put endpoint (encode template) + where + endpoint = + ["_index_template", templateName] + `withQueries` composableTemplateOptionsParams opts + +-- | 'getIndexTemplate' fetches /composable/ index templates (the +-- @GET /_index_template@ endpoint, available since Elasticsearch 7.8 +-- and in OpenSearch 2.x). It is the read-side counterpart of +-- 'putIndexTemplate'. +-- +-- * @'Nothing'@ → @GET /_index_template@ returns +-- every composable template on the cluster. +-- * @'Just' ('TemplateNamePattern' p)@ → @GET /_index_template\/\@p@ +-- returns the templates whose names match the pattern. @p@ may be a +-- literal name (no wildcard characters) or a glob such as +-- @"logs-*"@; the server does the matching. A pattern that matches +-- no template yields a @404@, which (because this builder is +-- 'StatusDependant') surfaces as an 'EsError' — callers that want +-- miss-tolerant lookup should use 'tryPerformBHRequest'. +-- +-- The response is always a list (wrapped in a +-- 'GetIndexTemplatesResponse' envelope on the wire), even when the +-- pattern matches exactly one template. The body of each +-- 'IndexTemplateInfo' is decoded into a 'ComposableTemplate'. +-- +-- () +getIndexTemplate :: + Maybe TemplateNamePattern -> + BHRequest StatusDependant [IndexTemplateInfo] +getIndexTemplate mPattern = + getIndexTemplatesResponseTemplates <$> get endpoint + where + endpoint = + case mPattern of + Nothing -> ["_index_template"] + Just (TemplateNamePattern pat) -> ["_index_template", pat] + +-- | 'deleteIndexTemplate' deletes a /composable/ index template (the +-- @DELETE /_index_template/{name}@ endpoint, available since +-- Elasticsearch 7.8 and in OpenSearch 2.x). It is the write-side +-- counterpart of 'putIndexTemplate'. +-- +-- This builder is 'StatusDependant', matching 'putIndexTemplate' and +-- 'getIndexTemplate': a 4xx (in particular a @404@ when no template +-- with the given name exists) is surfaced as an 'EsError' rather than +-- swallowed. Callers that want miss-tolerant deletion should use +-- 'tryPerformBHRequest'. +-- +-- +deleteIndexTemplate :: + TemplateName -> + BHRequest StatusDependant Acknowledged +deleteIndexTemplate (TemplateName templateName) = + delete ["_index_template", templateName] + +-- | 'simulateIndexTemplate' resolves a hypothetical 'ComposableTemplate' +-- against the templates already registered on the cluster (the +-- @POST /_index_template/_simulate@ endpoint, available since +-- Elasticsearch 7.8 and in OpenSearch 2.x). The server merges the +-- supplied template with any component templates it references and +-- returns the resulting @settings@\/@mappings@\/@aliases@ that would +-- be applied to a new matching index, alongside the list of /existing/ +-- composable templates whose @index_patterns@ overlap the supplied +-- template's patterns. +-- +-- The request body is the bare 'ComposableTemplate' (the same shape +-- used by 'putIndexTemplate' for @PUT /_index_template/{name}@); no +-- @index_template@ wrapper is required. To simulate the template that +-- /would be applied/ to a hypothetical new index name, use the +-- @POST /_index_template/_simulate_index/{name}@ variant instead — +-- tracked as sibling bead @bloodhound-04f.2.17.4@. +-- +-- This builder is 'StatusDependant', matching 'putIndexTemplate': a +-- 4xx (e.g. an invalid body) is surfaced as an 'EsError' rather than +-- swallowed. +-- +-- () +simulateIndexTemplate :: + ComposableTemplate -> + BHRequest StatusDependant SimulatedTemplate +simulateIndexTemplate template = + post ["_index_template", "_simulate"] (encode template) + +-- | Like 'simulateIndexTemplate' but additionally accepts +-- 'ComposableTemplateOptions' rendered as URI parameters. Use +-- 'defaultComposableTemplateOptions' to send no parameters at all, in +-- which case the emitted request is byte-for-byte identical to +-- 'simulateIndexTemplate'. +-- +-- The simulate endpoint documents only @master_timeout@ (and the +-- pre-7.16 alias @cluster_manager_timeout@ on OpenSearch); the +-- remaining 'ComposableTemplateOptions' fields (@create@, @cause@) are +-- accepted by this builder for symmetry with 'putIndexTemplateWith' +-- but have no effect on the server. +simulateIndexTemplateWith :: + ComposableTemplate -> + ComposableTemplateOptions -> + BHRequest StatusDependant SimulatedTemplate +simulateIndexTemplateWith template opts = + post endpoint (encode template) + where + endpoint = + ["_index_template", "_simulate"] + `withQueries` composableTemplateOptionsParams opts + +-- | 'simulateIndex' resolves the composable index template(s) that +-- Elasticsearch /would/ apply to a hypothetical new index with the given +-- name — the @POST /_index_template/_simulate_index/{name}@ endpoint, +-- available since Elasticsearch 7.8 and in OpenSearch 2.x. Returns the +-- merged @settings@\/@mappings@\/@aliases@ plus any lower-priority +-- templates whose @index_patterns@ also match (the @overlapping@ field +-- of 'SimulatedTemplate'). Read-only and side-effect-free: the index is +-- not created. +-- +-- This is the index-name-driven counterpart of 'simulateIndexTemplate' +-- (which simulates a supplied 'ComposableTemplate' body against the +-- cluster's existing templates). Use 'simulateIndex' when you want to +-- know "what would index @logs-2026-06-21@ actually look like?"; +-- use 'simulateIndexTemplate' when you want to know "what would this +-- hypothetical template I haven't PUT yet produce?". +-- +-- The request is sent with no body: the index name carries all the +-- input and the server resolves against the already-registered +-- templates. (The endpoint also accepts an override body carrying an +-- @index_patterns@ field to simulate a hypothetical template on the +-- fly; that variant is not surfaced here because it overlaps with +-- 'simulateIndexTemplate' — add a follow-up if a caller needs to mix +-- both axes.) +-- +-- This builder is 'StatusDependant', matching 'simulateIndexTemplate'. +-- +-- +simulateIndex :: + IndexName -> + BHRequest StatusDependant SimulatedTemplate +simulateIndex indexName = + post ["_index_template", "_simulate_index", unIndexName indexName] emptyBody + +-- | Like 'simulateIndex' but additionally accepts +-- 'ComposableTemplateOptions' rendered as URI parameters. Use +-- 'defaultComposableTemplateOptions' to send no parameters at all, in +-- which case the emitted request is byte-for-byte identical to +-- 'simulateIndex'. +-- +-- The simulate-index endpoint documents only @master_timeout@ (and the +-- pre-7.16 alias @cluster_manager_timeout@ on OpenSearch); the remaining +-- 'ComposableTemplateOptions' fields (@create@, @cause@) are accepted by +-- this builder for symmetry with 'simulateIndexTemplateWith' but have no +-- effect on the server. +simulateIndexWith :: + IndexName -> + ComposableTemplateOptions -> + BHRequest StatusDependant SimulatedTemplate +simulateIndexWith indexName opts = + post endpoint emptyBody + where + endpoint = + ["_index_template", "_simulate_index", unIndexName indexName] + `withQueries` composableTemplateOptionsParams opts + +-- | 'putComponentTemplate' creates or updates a reusable /component/ +-- template (the @PUT /_component_template/{name}@ endpoint, available +-- since Elasticsearch 7.8 and in OpenSearch 2.x). Component templates +-- are building blocks composed into composable index templates (see +-- 'ComposableTemplate'\'s @composed_of@ field); they have no +-- @index_patterns@ of their own. +-- +-- This builder is 'StatusDependant', matching 'putIndexTemplate': a 4xx +-- (e.g. an invalid body) is surfaced as an 'EsError' rather than +-- swallowed. To fail when a component template with the given name +-- already exists, issue the request with a @create=true@ query +-- parameter (not modelled here — use the underlying 'put' if needed). +-- +-- () +putComponentTemplate :: + TemplateName -> + ComponentTemplate -> + BHRequest StatusDependant Acknowledged +putComponentTemplate (TemplateName templateName) template = + put ["_component_template", templateName] (encode template) + +-- | 'deleteComponentTemplate' deletes a reusable /component/ template +-- (the @DELETE /_component_template/{name}@ endpoint, available since +-- Elasticsearch 7.8 and in OpenSearch 2.x). It is the write-side +-- counterpart of 'putComponentTemplate'. +-- +-- This builder is 'StatusDependant', matching 'putComponentTemplate' and +-- 'deleteIndexTemplate': a 4xx (in particular a @404@ when no template +-- with the given name exists) is surfaced as an 'EsError' rather than +-- swallowed. Callers that want miss-tolerant deletion should use +-- 'tryPerformBHRequest'. +-- +-- +deleteComponentTemplate :: + TemplateName -> + BHRequest StatusDependant Acknowledged +deleteComponentTemplate (TemplateName templateName) = + delete ["_component_template", templateName] + +-- | 'getComponentTemplate' fetches reusable /component/ templates (the +-- @GET /_component_template@ endpoint, available since Elasticsearch +-- 7.8 and in OpenSearch 2.x). It is the read-side counterpart of +-- 'putComponentTemplate'. +-- +-- * @'Nothing'@ → @GET /_component_template@ +-- returns every component template on the cluster. +-- * @'Just' ('TemplateNamePattern' p)@ → @GET /_component_template\/\@p@ +-- returns the templates whose names match the pattern. @p@ may be a +-- literal name (no wildcard characters) or a glob such as +-- @"logs-*"@; the server does the matching. A pattern that matches +-- no template yields a @404@, which (because this builder is +-- 'StatusDependant') surfaces as an 'EsError' — callers that want +-- miss-tolerant lookup should use 'tryPerformBHRequest'. +-- +-- The response is always a list (wrapped in a +-- 'GetComponentTemplatesResponse' envelope on the wire), even when the +-- pattern matches exactly one template. The body of each +-- 'ComponentTemplateInfo' is decoded into a 'ComponentTemplate'. +-- +-- () +getComponentTemplate :: + Maybe TemplateNamePattern -> + BHRequest StatusDependant [ComponentTemplateInfo] +getComponentTemplate mPattern = + getComponentTemplatesResponseTemplates <$> get endpoint + where + endpoint = + case mPattern of + Nothing -> ["_component_template"] + Just (TemplateNamePattern pat) -> ["_component_template", pat] + +-- | 'putMapping' is an HTTP PUT and has upsert semantics. Mappings are schemas +-- for documents in indexes. +-- +-- Equivalent to @'putMappingWith' 'defaultPutMappingOptions'@. Use the +-- @With@ variant to pass @allow_no_indices@, @expand_wildcards@, +-- @ignore_unavailable@, @master_timeout@, @timeout@ or +-- @write_index_only@. +-- +-- >>> _ <- runBH' $ createIndex defaultIndexSettings testIndex +-- >>> resp <- runBH' $ putMapping testIndex TweetMapping +-- >>> print resp +-- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("content-type","application/json; charset=UTF-8"),("content-encoding","gzip"),("transfer-encoding","chunked")], responseBody = "{\"acknowledged\":true}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} +putMapping :: (FromJSON r, ToJSON a) => IndexName -> a -> BHRequest StatusDependant r +putMapping indexName mapping = + putMappingWith indexName mapping defaultPutMappingOptions + +-- | 'putMappingWith' is the fully-parameterised form of 'putMapping'. +-- Every URI parameter accepted by @PUT /{index}/_mapping@ is exposed via +-- 'PutMappingOptions'. 'defaultPutMappingOptions' makes this +-- byte-for-byte identical to 'putMapping'. +-- +-- () +putMappingWith :: + (FromJSON r, ToJSON a) => + IndexName -> + a -> + PutMappingOptions -> + BHRequest StatusDependant r +putMappingWith indexName mapping opts = + put endpoint (encode mapping) + where + endpoint = + [unIndexName indexName, "_mapping"] + `withQueries` putMappingOptionsParams opts + +-- | 'getMapping' fetches the mapping for a given index. Wraps the +-- @GET \/\\/_mapping@ endpoint +-- (). +-- +-- The response is generic over any 'FromJSON' @r@, mirroring +-- 'putMapping'. Decode into a 'Value' for an untyped view of +-- the mapping (the response is shaped @{\: {mappings: {...}}}@), +-- or into a custom type. Use 'getIndex' to fetch aliases and settings +-- alongside the mappings in a single request. +getMapping :: (FromJSON r) => IndexName -> BHRequest StatusDependant r +getMapping indexName = + get [unIndexName indexName, "_mapping"] + +-- | 'getFieldMapping' fetches the mapping for specific fields of a given +-- index. Wraps the @GET \/\\/_mapping\/field\/\@ endpoint +-- (). +-- +-- The response is generic over any 'FromJSON' @r', mirroring 'getMapping'. +-- Decode into a 'Value' for an untyped view, or into +-- 'FieldMappingResponse' for a structured one. The field list is joined +-- with commas, matching the ES wire format. Pass an empty list to let the +-- server reject the request. +-- +-- Field names are interpolated verbatim into the URL path (consistent with +-- the rest of the library, which does not percent-encode path segments). +-- As a consequence, a field name containing @,@ cannot be expressed on the +-- wire (the comma is the list separator) and must be requested in a +-- separate single-field call; characters such as @\/@ or @?@ will corrupt +-- the URL. Wildcards like @"*"@ or @"user*"@ work as expected. +getFieldMapping :: + (FromJSON r) => + IndexName -> + [FieldName] -> + BHRequest StatusDependant r +getFieldMapping indexName fields = + get [unIndexName indexName, "_mapping", "field", renderedFields] + where + renderedFields = T.intercalate "," (map unFieldName fields) + +versionCtlParams :: IndexDocumentSettings -> [(Text, Maybe Text)] +versionCtlParams cfg = + case idsVersionControl cfg of + NoVersionControl -> [] + InternalVersion v -> versionParams v "internal" + ExternalGTE (ExternalDocVersion v) -> versionParams v "external_gte" + ForceVersion (ExternalDocVersion v) -> versionParams v "force" + where + vt = showText . docVersionNumber + versionParams :: DocVersion -> Text -> [(Text, Maybe Text)] + versionParams v t = + [ ("version", Just $ vt v), + ("version_type", Just t) + ] + +-- | 'indexDocument' is the primary way to save a single document in +-- Elasticsearch. The document itself is simply something we can +-- convert into a JSON 'Value'. The 'DocId' will function as the +-- primary key for the document. You are encouraged to generate +-- your own id's and not rely on Elasticsearch's automatic id +-- generation. Read more about it here: +-- https://github.com/bitemyapp/bloodhound/issues/107 +-- +-- >>> resp <- runBH' $ indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1") +-- >>> print resp +-- Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("content-type","application/json; charset=UTF-8"),("content-encoding","gzip"),("content-length","152")], responseBody = "{\"_index\":\"twitter\",\"_type\":\"_doc\",\"_id\":\"1\",\"_version\":2,\"result\":\"updated\",\"_shards\":{\"total\":1,\"successful\":1,\"failed\":0},\"_seq_no\":1,\"_primary_term\":1}", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose} +indexDocument :: + (ToJSON doc) => + IndexName -> + IndexDocumentSettings -> + doc -> + DocId -> + BHRequest StatusDependant IndexedDocument +indexDocument indexName cfg document (DocId docId) = + post endpoint (encode body) + where + endpoint = [unIndexName indexName, "_doc", docId] `withQueries` indexQueryString cfg (DocId docId) + body = encodeDocument cfg document + +-- | 'updateDocument' provides a way to perform an partial update of a +-- an already indexed document. +-- +-- Sends the @{\"doc\": …}@ body shape only. For script-driven updates, +-- upserts, @doc_as_upsert@ or @scripted_upsert@, use 'updateDocumentWith' +-- with an 'UpdateBody' constructed via 'mkUpdateScript' (or the +-- 'UpdateScript' constructor directly). +updateDocument :: + (ToJSON patch) => + IndexName -> + IndexDocumentSettings -> + patch -> + DocId -> + BHRequest StatusDependant IndexedDocument +updateDocument indexName cfg patch (DocId docId) = + updateDocumentWith indexName cfg (mkUpdateDoc (encodeDocument cfg patch)) (DocId docId) + +-- | Like 'updateDocument' but accepts the full 'UpdateBody' union, +-- supporting both @{\"doc\": …}@ (partial-document) and +-- @{\"script\": …}@ (script-driven, with optional upsert and +-- @scripted_upsert@) wire shapes. The 'IndexDocumentSettings' argument +-- still supplies the URI-level parameters (@if_seq_no@, @refresh@, +-- @op_type@, …) shared with the Index API. +-- +-- See +-- . +updateDocumentWith :: + IndexName -> + IndexDocumentSettings -> + UpdateBody -> + DocId -> + BHRequest StatusDependant IndexedDocument +updateDocumentWith indexName cfg body (DocId docId) = + post endpoint (encode body) + where + endpoint = [unIndexName indexName, "_update", docId] `withQueries` indexQueryString cfg (DocId docId) + +updateByQuery :: + (FromJSON a) => + IndexName -> + Query -> + Maybe Script -> + BHRequest StatusDependant a +updateByQuery = updateByQueryWith defaultByQueryOptions + +-- | Like 'updateByQuery' but accepts 'ByQueryOptions' carrying the +-- URI-level parameters documented at +-- . +-- 'defaultByQueryOptions' makes this byte-for-byte equivalent to +-- 'updateByQuery'. +updateByQueryWith :: + (FromJSON a) => + ByQueryOptions -> + IndexName -> + Query -> + Maybe Script -> + BHRequest StatusDependant a +updateByQueryWith opts indexName q mScript = + post endpoint (encode body) + where + endpoint = [unIndexName indexName, "_update_by_query"] `withQueries` byQueryOptionsParams opts + body = Object $ ("query" .= q) <> scriptObject + scriptObject :: X.KeyMap Value + scriptObject = case toJSON mScript of + Null -> mempty + Object o -> o + x -> "script" .= x + +-- | 'rethrottleUpdateByQuery' changes the maximum documents-per-second +-- rate of an in-progress asynchronous @update_by_query@ task. Maps to +-- @POST /_update_by_query/{task_id}/_rethrottle?requests_per_second=@. +-- The 'TaskNodeId' is the composite @nodeId:localId@ identifier returned +-- by an asynchronous 'updateByQueryWith' (call it with +-- @bqoWaitForCompletion = Just False@) or observed via 'listTasks' \/ +-- 'getTask'. +-- +-- The response uses the same nodes-grouped shape as 'cancelTask' +-- (a 'TaskListResponse' listing the task(s) whose rate was changed), +-- /not/ an 'Acknowledged' — the ES wire format is a task list even +-- though the operation is conceptually an acknowledgement. An empty +-- node list typically means the task had already finished by the time +-- the request reached the server. +-- +-- Rethrottling that speeds the task up takes effect immediately; +-- rethrottling that slows it down takes effect after the current +-- batch completes (to prevent scroll timeouts). +-- +-- See +-- . +rethrottleUpdateByQuery :: + TaskNodeId -> + RethrottleRate -> + BHRequest StatusDependant TaskListResponse +rethrottleUpdateByQuery (TaskNodeId task) rate = + post endpoint emptyBody + where + endpoint = + ["_update_by_query", task, "_rethrottle"] + `withQueries` [("requests_per_second", Just (renderRethrottleRate rate))] + +{- From ES docs: + Parent and child documents must be indexed on the same shard. + This means that the same routing value needs to be provided when getting, deleting, or updating a child document. + + Parent/Child support in Bloodhound requires MUCH more love. + To work it around for now (and to support the existing unit test) we route "parent" documents to their "_id" + (which is the default strategy for the ES), and route all child documents to their parens' "_id" + + However, it may not be flexible enough for some corner cases. + + Buld operations are completely unaware of "routing" and are probably broken in that matter. + Or perhaps they always were, because the old "_parent" would also have this requirement. +-} +indexQueryString :: IndexDocumentSettings -> DocId -> [(Text, Maybe Text)] +indexQueryString cfg (DocId docId) = + versionCtlParams cfg + <> routeParams + <> opTypeParams + <> pipelineParams + <> refreshParams + <> waitForActiveShardsParams + <> ifSeqNoParams + <> requireAliasParams + <> timeoutParams + where + routeParams = case idsJoinRelation cfg of + Nothing -> [] + Just (ParentDocument _ _) -> [("routing", Just docId)] + Just (ChildDocument _ _ (DocId pid)) -> [("routing", Just pid)] + opTypeParams = case idsOpType cfg of + Just opType -> [("op_type", Just (renderOpType opType))] + Nothing -> [] + pipelineParams = case idsPipeline cfg of + Just pipeline -> [("pipeline", Just pipeline)] + Nothing -> [] + refreshParams = case idsRefresh cfg of + Just policy -> [("refresh", Just (renderRefreshPolicy policy))] + Nothing -> [] + waitForActiveShardsParams = case idsWaitForActiveShards cfg of + Just count -> [("wait_for_active_shards", Just (renderActiveShardCount count))] + Nothing -> [] + requireAliasParams = case idsRequireAlias cfg of + Just flag -> [("require_alias", Just (boolText flag))] + Nothing -> [] + timeoutParams = case idsTimeout cfg of + Just d -> [("timeout", Just (renderDuration d))] + Nothing -> [] + renderDuration (u, n) = showText n <> timeUnitsSuffix u + -- Sequence number and primary term: ES requires both to be set + -- together for optimistic concurrency control. If the caller sets + -- only one, we still emit it — the server will then respond with + -- HTTP 400, which is much louder than silently dropping the check + -- (the previous behaviour would have indexed without OCC, hiding + -- the caller's mistake). See + -- . + ifSeqNoParams = case (idsIfSeqNo cfg, idsIfPrimaryTerm cfg) of + (Just seqNo, Just primaryTerm) -> + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + (Just seqNo, Nothing) -> + [ ("if_seq_no", Just (showText seqNo)) + ] + (Nothing, Just primaryTerm) -> + [ ("if_primary_term", Just (showText primaryTerm)) + ] + (Nothing, Nothing) -> [] + boolText :: Bool -> Text + boolText True = "true" + boolText False = "false" + +encodeDocument :: (ToJSON doc) => IndexDocumentSettings -> doc -> Value +encodeDocument cfg document = + case idsJoinRelation cfg of + Nothing -> toJSON document + Just (ParentDocument (FieldName field) name) -> + mergeObjects (toJSON document) (object [fromText field .= name]) + Just (ChildDocument (FieldName field) name parent) -> + mergeObjects (toJSON document) (object [fromText field .= object ["name" .= name, "parent" .= parent]]) + where + mergeObjects (Object a) (Object b) = Object (a <> b) + mergeObjects _ _ = error "Impossible happened: both document body and join parameters must be objects" + +-- | 'deleteDocument' is the primary way to delete a single document. +-- +-- >>> _ <- runBH' $ deleteDocument testIndex (DocId "1") +deleteDocument :: IndexName -> DocId -> BHRequest StatusDependant IndexedDocument +deleteDocument = deleteDocumentWith defaultDeleteDocumentOptions + +-- | Like 'deleteDocument' but accepts 'DeleteDocumentOptions' carrying +-- the URI-level parameters documented at +-- +-- (@wait_for_active_shards@, @refresh@, @routing@, @timeout@, +-- @version@, @version_type@, @if_seq_no@, @if_primary_term@). +-- 'defaultDeleteDocumentOptions' makes this byte-for-byte equivalent +-- to 'deleteDocument'. +deleteDocumentWith :: + DeleteDocumentOptions -> + IndexName -> + DocId -> + BHRequest StatusDependant IndexedDocument +deleteDocumentWith opts indexName (DocId docId) = + delete ([unIndexName indexName, "_doc", docId] `withQueries` deleteDocumentOptionsParams opts) + +-- | 'deleteByQuery' performs a deletion on every document that matches a query. +-- +-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing +-- >>> _ <- runBH' $ deleteByQuery testIndex query +deleteByQuery :: + (FromJSON a) => + IndexName -> + Query -> + BHRequest StatusDependant a +deleteByQuery = deleteByQueryWith defaultByQueryOptions + +-- | Like 'deleteByQuery' but accepts 'ByQueryOptions' carrying the +-- URI-level parameters documented at +-- . +-- 'defaultByQueryOptions' makes this byte-for-byte equivalent to +-- 'deleteByQuery'. Like 'updateByQueryWith' the response type is +-- polymorphic: callers that pass @bqoWaitForCompletion = Just False@ +-- should instantiate it at 'TaskNodeId' to receive the background +-- task's identifier (e.g. for 'rethrottleDeleteByQuery'). +deleteByQueryWith :: + (FromJSON a) => + ByQueryOptions -> + IndexName -> + Query -> + BHRequest StatusDependant a +deleteByQueryWith opts indexName query = + post endpoint (encode body) + where + endpoint = [unIndexName indexName, "_delete_by_query"] `withQueries` byQueryOptionsParams opts + body = object ["query" .= query] + +-- | 'rethrottleDeleteByQuery' changes the maximum documents-per-second +-- rate of an in-progress asynchronous @delete_by_query@ task. Maps to +-- @POST /_delete_by_query/{task_id}/_rethrottle?requests_per_second=@. +-- The 'TaskNodeId' is the composite @nodeId:localId@ identifier returned +-- by an asynchronous 'deleteByQueryWith' (call it with +-- @bqoWaitForCompletion = Just False@) or observed via 'listTasks' \/ +-- 'getTask'. +-- +-- The response uses the same nodes-grouped shape as 'cancelTask' +-- (a 'TaskListResponse' listing the task(s) whose rate was changed), +-- /not/ an 'Acknowledged' — the ES wire format is a task list even +-- though the operation is conceptually an acknowledgement. An empty +-- node list typically means the task had already finished by the time +-- the request reached the server. +-- +-- Rethrottling that speeds the task up takes effect immediately; +-- rethrottling that slows it down takes effect after the current +-- batch completes (to prevent scroll timeouts). +-- +-- See +-- . +rethrottleDeleteByQuery :: + TaskNodeId -> + RethrottleRate -> + BHRequest StatusDependant TaskListResponse +rethrottleDeleteByQuery (TaskNodeId task) rate = + post endpoint emptyBody + where + endpoint = + ["_delete_by_query", task, "_rethrottle"] + `withQueries` [("requests_per_second", Just (renderRethrottleRate rate))] + +-- | 'bulk' uses +-- +-- to perform bulk operations. The 'BulkOperation' data type encodes the +-- index\/update\/delete\/create operations. You pass a 'V.Vector' of 'BulkOperation's +-- and a 'Server' to 'bulk' in order to send those operations up to your Elasticsearch +-- server to be performed. I changed from [BulkOperation] to a Vector due to memory overhead. +-- +-- Uses 'defaultBulkSettings' (no URI parameters). For control over the +-- @refresh@, @routing@, @pipeline@, @wait_for_active_shards@, etc. +-- parameters, use 'bulkWith'. +-- +-- >>> let stream = V.fromList [BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah")) []] +-- >>> _ <- runBH' $ bulk stream +-- >>> _ <- runBH' $ refreshIndex testIndex +bulk :: + (ParseBHResponse contextualized) => + V.Vector BulkOperation -> + BHRequest contextualized BulkResponse +bulk = + bulkWith defaultBulkSettings + +-- | Like 'bulk' but accepts a 'BulkSettings' record carrying the URI-level +-- parameters of the @POST /_bulk@ endpoint (@refresh@, @timeout@, +-- @wait_for_active_shards@, @routing@, @_source*@, @pipeline@, +-- @require_alias@). 'defaultBulkSettings' makes this byte-for-byte +-- equivalent to 'bulk'. +-- +-- Per-operation metadata (e.g. @_routing@, @_if_seq_no@) is supplied +-- via the final @[UpsertActionMetadata]@ argument of each +-- 'BulkOperation' constructor. +bulkWith :: + (ParseBHResponse contextualized) => + BulkSettings -> + V.Vector BulkOperation -> + BHRequest contextualized BulkResponse +bulkWith opts = + post (["_bulk"] `withQueries` bulkSettingsParams opts) . encodeBulkOperations + +-- | 'encodeBulkOperations' is a convenience function for dumping a vector of 'BulkOperation' +-- into an 'L.ByteString' +-- +-- >>> let bulkOps = V.fromList [BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah")) []] +-- >>> encodeBulkOperations bulkOps +-- "\n{\"index\":{\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}\n" +encodeBulkOperations :: V.Vector BulkOperation -> L.ByteString +encodeBulkOperations stream = collapsed + where + blobs = + fmap encodeBulkOperation stream + mashedTaters = + mash (mempty :: Builder) blobs + collapsed = + toLazyByteString $ mappend mashedTaters (byteString "\n") + mash :: Builder -> V.Vector L.ByteString -> Builder + mash = V.foldl' (\b x -> b <> byteString "\n" <> lazyByteString x) + +mkBulkStreamValueWithMeta :: [UpsertActionMetadata] -> Text -> IndexName -> Text -> Value +mkBulkStreamValueWithMeta meta operation indexName docId = + object + [ fromText operation + .= object + ( [ "_index" .= indexName, + "_id" .= docId + ] + <> (buildUpsertActionMetadata <$> meta) + ) + ] + +mkBulkStreamValueAutoWithMeta :: [UpsertActionMetadata] -> Text -> IndexName -> Value +mkBulkStreamValueAutoWithMeta meta operation indexName = + object + [ fromText operation + .= object + ( ["_index" .= indexName] + <> (buildUpsertActionMetadata <$> meta) + ) + ] + +-- | 'encodeBulkOperation' is a convenience function for dumping a single 'BulkOperation' +-- into an 'L.ByteString' +-- +-- >>> let bulkOp = BulkIndex testIndex (DocId "2") (toJSON (BulkTest "blah")) [] +-- >>> encodeBulkOperation bulkOp +-- "{\"index\":{\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}" +encodeBulkOperation :: BulkOperation -> L.ByteString +encodeBulkOperation (BulkIndex indexName (DocId docId) value meta) = blob + where + metadata = mkBulkStreamValueWithMeta meta "index" indexName docId + blob = encode metadata `mappend` "\n" `mappend` encode value +encodeBulkOperation (BulkIndexAuto indexName value meta) = blob + where + metadata = mkBulkStreamValueAutoWithMeta meta "index" indexName + blob = encode metadata `mappend` "\n" `mappend` encode value +encodeBulkOperation (BulkIndexEncodingAuto indexName encoding meta) = toLazyByteString blob + where + metadata = toEncoding (mkBulkStreamValueAutoWithMeta meta "index" indexName) + blob = fromEncoding metadata <> "\n" <> fromEncoding encoding +encodeBulkOperation (BulkCreate indexName (DocId docId) value meta) = blob + where + metadata = mkBulkStreamValueWithMeta meta "create" indexName docId + blob = encode metadata `mappend` "\n" `mappend` encode value +encodeBulkOperation (BulkDelete indexName (DocId docId) meta) = blob + where + metadata = mkBulkStreamValueWithMeta meta "delete" indexName docId + blob = encode metadata +encodeBulkOperation (BulkUpdate indexName (DocId docId) value meta) = blob + where + metadata = mkBulkStreamValueWithMeta meta "update" indexName docId + doc = object ["doc" .= value] + blob = encode metadata `mappend` "\n" `mappend` encode doc +encodeBulkOperation + ( BulkUpsert + indexName + (DocId docId) + payload + meta + ) = blob + where + metadata = mkBulkStreamValueWithMeta meta "update" indexName docId + blob = encode metadata <> "\n" <> encode doc + doc = case payload of + UpsertDoc value -> object ["doc" .= value, "doc_as_upsert" .= True] + UpsertScript scriptedUpsert script value -> + let scup = if scriptedUpsert then ["scripted_upsert" .= True] else [] + upsert = ["upsert" .= value] + in case (object (scup <> upsert), toJSON script) of + (Object obj, Object jscript) -> Object $ jscript <> obj + _ -> error "Impossible happened: serialising Script to Json should always be Object" +encodeBulkOperation (BulkCreateEncoding indexName (DocId docId) encoding meta) = + toLazyByteString blob + where + metadata = toEncoding (mkBulkStreamValueWithMeta meta "create" indexName docId) + blob = fromEncoding metadata <> "\n" <> fromEncoding encoding + +-- | 'getDocument' is a straight-forward way to fetch a single document from +-- Elasticsearch using a 'Server', 'IndexName', and a 'DocId'. +-- The 'DocId' is the primary key for your Elasticsearch document. +-- +-- >>> yourDoc <- runBH' $ getDocument testIndex (DocId "1") +getDocument :: (FromJSON a) => IndexName -> DocId -> BHRequest StatusIndependant (EsResult a) +getDocument = getDocumentWith defaultGetDocumentOptions + +-- | Like 'getDocument' but accepts 'GetDocumentOptions' carrying the +-- URI-level parameters (@_source@, @_source_includes@\/@_source_excludes@, +-- @stored_fields@, @preference@, @realtime@, @refresh@, @routing@, +-- @version@, @version_type@). 'defaultGetDocumentOptions' makes this +-- byte-for-byte equivalent to 'getDocument'. +getDocumentWith :: + (FromJSON a) => + GetDocumentOptions -> + IndexName -> + DocId -> + BHRequest StatusIndependant (EsResult a) +getDocumentWith opts indexName (DocId docId) = + get ([unIndexName indexName, "_doc", docId] `withQueries` getDocumentOptionsParams opts) + +-- | 'getDocumentSource' fetches only the @_source@ of a document (no +-- metadata envelope). Maps to +-- @GET \/{index}\/_source\/{id}@. The response body is the raw +-- @_source@ JSON the server stores for the document, decoded into +-- whichever 'FromJSON' type the caller picks. +-- +-- The source-only endpoint is served at @\/{index}\/_source\/{id}@ on +-- every supported backend (ES 7, 8, 9 and OpenSearch). ES 7 also +-- accepted the legacy @\/{index}\/_doc\/{id}\/_source@ path, but ES +-- 8.19+ and 9.x reject it, so the cross-version-safe path is used +-- here. +-- +-- A missing document (HTTP 404) surfaces as @'Right' 'Nothing'@ when +-- run via 'Database.Bloodhound.Client.Cluster.tryPerformBHRequest', +-- and as 'Nothing' from +-- 'Database.Bloodhound.Common.Client.getDocumentSource'. Other +-- non-2xx responses are decoded as an 'EsError' as usual. The +-- source-only endpoint returns no @{\"found\": false}@ envelope +-- (unlike the full GET API), so 404 is the only signal for a missing +-- document; we therefore treat it as the expected \"no document\" +-- outcome rather than an error. +-- +-- >>> yourSource <- runBH' $ getDocumentSource testIndex (DocId "1") +-- +-- See +-- +-- and +-- . +getDocumentSource :: + (FromJSON a) => + IndexName -> + DocId -> + BHRequest StatusDependant (Maybe a) +getDocumentSource = getDocumentSourceWith defaultGetDocumentSourceOptions + +-- | Like 'getDocumentSource' but accepts 'GetDocumentSourceOptions' +-- carrying the source-filtering and routing parameters that apply to +-- the source-only endpoint +-- (@"_source_includes"@, @"_source_excludes"@, @preference@, +-- @realtime@, @refresh@, @routing@, @version@, @version_type@). +getDocumentSourceWith :: + (FromJSON a) => + GetDocumentSourceOptions -> + IndexName -> + DocId -> + BHRequest StatusDependant (Maybe a) +getDocumentSourceWith opts indexName (DocId docId) = + BHRequest + { bhRequestMethod = NHTM.methodGet, + bhRequestEndpoint = + [unIndexName indexName, "_source", docId] + `withQueries` getDocumentSourceOptionsParams opts, + bhRequestBody = Nothing, + bhRequestQueryStrings = [], + bhRequestParser = getDocumentSourceParser + } + +-- | Parser used by 'getDocumentSourceWith'. The ES\/OS source-only +-- endpoint returns the raw @_source@ JSON on 2xx and 404 on missing +-- documents (there is no @{\"found\": false}@ envelope as the full +-- GET API produces). We therefore branch on the HTTP status code: +-- +-- * 404 → @'Right' 'Nothing'@ — the expected \"no document\" case. +-- * 2xx → body decoded as /a/ and wrapped in 'Just'. +-- * Other non-2xx → routed through 'parseEsResponse', surfacing as +-- 'Left' 'EsError'. +getDocumentSourceParser :: + forall a parsingContext. + (FromJSON a) => + BHResponse parsingContext (Maybe a) -> + Either EsProtocolException (ParsedEsResponse (Maybe a)) +getDocumentSourceParser resp + | statusCodeIs (404, 404) resp = return (Right Nothing) + -- Lift 'Just' into 'ParsedEsResponse' (= @Either EsError@): a + -- decoded source becomes @Right (Just a)@, a server-reported + -- 'EsError' is preserved as @Left e@. + | otherwise = fmap (fmap Just) (parseEsResponse (coerce @(BHResponse parsingContext (Maybe a)) @(BHResponse parsingContext a) resp)) + +getDocuments :: + (FromJSON a) => + IndexName -> + [DocId] -> + BHRequest StatusIndependant (MultiGetResponse a) +getDocuments = getDocumentsWith defaultMultiGetOptions + +-- | Like 'getDocuments' but accepts 'MultiGetOptions' applied at the +-- URI level to every requested document. For per-document source +-- filtering, build the 'MultiGet' body directly (with +-- 'multiGetDocSource'\/'multiGetDocStoredFields' on each 'MultiGetDoc') +-- and use 'getDocumentsMultiWith'. +getDocumentsWith :: + (FromJSON a) => + MultiGetOptions -> + IndexName -> + [DocId] -> + BHRequest StatusIndependant (MultiGetResponse a) +getDocumentsWith opts indexName docIds = + post endpoint (encode body) + where + endpoint = [unIndexName indexName, "_mget"] `withQueries` multiGetOptionsParams opts + body = MultiGet $ map mkMultiGetDoc docIds + +getDocumentsMulti :: + (FromJSON a) => + MultiGet -> + BHRequest StatusIndependant (MultiGetResponse a) +getDocumentsMulti = getDocumentsMultiWith defaultMultiGetOptions + +-- | Like 'getDocumentsMulti' but accepts 'MultiGetOptions' applied at +-- the URI level. Per-document @_source@\/@stored_fields@ filtering is +-- carried by the 'MultiGetDoc' records inside the 'MultiGet' body. +getDocumentsMultiWith :: + (FromJSON a) => + MultiGetOptions -> + MultiGet -> + BHRequest StatusIndependant (MultiGetResponse a) +getDocumentsMultiWith opts body = + post (["_mget"] `withQueries` multiGetOptionsParams opts) (encode body) + +-- | 'getTermVectors' returns information and statistics about terms +-- in the fields of a particular document. Maps to +-- @POST \/{index}\/_termvectors\/{id}@. The 'TermVectorsRequest' +-- body carries the optional flags (@fields@, @offsets@, +-- @positions@, @term_statistics@, @field_statistics@, @payload@, +-- @filter@); pass 'defaultTermVectorsRequest' for the +-- parameterless form. +-- +-- See +-- +-- and +-- . +getTermVectors :: + IndexName -> + DocId -> + TermVectorsRequest -> + BHRequest StatusDependant TermVectors +getTermVectors = getTermVectorsWith defaultTermVectorsOptions + +-- | Like 'getTermVectors' but accepts 'TermVectorsOptions' carrying +-- the URI-level parameters documented at +-- +-- (@preference@, @realtime@, @routing@, @version@, @version_type@). +-- 'defaultTermVectorsOptions' makes the wire output byte-identical to +-- 'getTermVectors'. +getTermVectorsWith :: + TermVectorsOptions -> + IndexName -> + DocId -> + TermVectorsRequest -> + BHRequest StatusDependant TermVectors +getTermVectorsWith opts indexName (DocId docId) body = + post + ([unIndexName indexName, "_termvectors", docId] `withQueries` termVectorsOptionsParams opts) + (encode body) + +-- | 'getMultiTermVectors' returns information and statistics about +-- terms in the fields of multiple documents in a single request. +-- Maps to @POST \/_mtermvectors@ (no index in URL). Each +-- 'MultiTermVectorsDoc' must carry its own @_index@ since the URL +-- path does not supply one. For the single-index form, see +-- 'getMultiTermVectorsByIndex'. +-- +-- See +-- +-- and +-- . +getMultiTermVectors :: + MultiTermVectors -> + BHRequest StatusDependant MultiTermVectorsResponse +getMultiTermVectors = getMultiTermVectorsWith defaultTermVectorsOptions + +-- | Like 'getMultiTermVectors' but accepts 'TermVectorsOptions' +-- carrying the URI-level parameters documented at +-- . +-- 'defaultTermVectorsOptions' makes the wire output byte-identical to +-- 'getMultiTermVectors'. +getMultiTermVectorsWith :: + TermVectorsOptions -> + MultiTermVectors -> + BHRequest StatusDependant MultiTermVectorsResponse +getMultiTermVectorsWith opts body = + post + (["_mtermvectors"] `withQueries` termVectorsOptionsParams opts) + (encode body) + +-- | 'getMultiTermVectorsByIndex' is the single-index form of +-- 'getMultiTermVectors'. Maps to +-- @POST \/{index}\/_mtermvectors@. The 'IndexName' is supplied in +-- the URL, so each 'MultiTermVectorsDoc' built by 'mkMultiTermVectorsDoc' +-- (no @_index@) is sufficient. +getMultiTermVectorsByIndex :: + IndexName -> + [DocId] -> + BHRequest StatusDependant MultiTermVectorsResponse +getMultiTermVectorsByIndex = getMultiTermVectorsByIndexWith defaultTermVectorsOptions + +-- | Like 'getMultiTermVectorsByIndex' but accepts 'TermVectorsOptions' +-- carrying the URI-level parameters documented at +-- . +-- 'defaultTermVectorsOptions' makes the wire output byte-identical to +-- 'getMultiTermVectorsByIndex'. +getMultiTermVectorsByIndexWith :: + TermVectorsOptions -> + IndexName -> + [DocId] -> + BHRequest StatusDependant MultiTermVectorsResponse +getMultiTermVectorsByIndexWith opts indexName docIds = + post + ([unIndexName indexName, "_mtermvectors"] `withQueries` termVectorsOptionsParams opts) + (encode body) + where + body = MultiTermVectors (map mkMultiTermVectorsDoc docIds) + +documentExists :: IndexName -> DocId -> BHRequest StatusDependant Bool +documentExists = documentExistsWith defaultDocumentExistsOptions + +-- | Like 'documentExists' but accepts 'DocumentExistsOptions' carrying +-- the URI-level parameters documented at +-- +-- (@stored_fields@, @preference@, @realtime@, @refresh@, @routing@, +-- @version@, @version_type@). 'defaultDocumentExistsOptions' makes +-- this byte-for-byte equivalent to 'documentExists'. +documentExistsWith :: + DocumentExistsOptions -> + IndexName -> + DocId -> + BHRequest StatusDependant Bool +documentExistsWith opts indexName (DocId docId) = + doesExist ([unIndexName indexName, "_doc", docId] `withQueries` documentExistsOptionsParams opts) + +-- | 'documentSourceExists' checks whether the @_source@ field is +-- present for a document, hitting +-- @HEAD \/{index}\/_source\/{id}@. Returns 'True' on any 2xx +-- response and 'False' otherwise (including 404 when the document or +-- its source are absent). This is the source-only counterpart of +-- 'documentExists' (which HEADs the document itself) and the +-- existence-check counterpart of 'getDocumentSource' (which GETs the +-- source body). Uses the cross-version-safe @\/{index}\/_source\/{id}@ +-- path (see 'getDocumentSource' for why the legacy @_doc\/{id}\/_source@ +-- form is not used). +-- +-- Like the other @*Exists@ helpers built on 'doesExist', this never +-- throws on absence: any non-2xx status decodes to 'False'. +-- +-- (, +-- ) +documentSourceExists :: IndexName -> DocId -> BHRequest StatusDependant Bool +documentSourceExists = documentSourceExistsWith defaultDocumentSourceExistsOptions + +-- | Like 'documentSourceExists' but accepts +-- 'DocumentSourceExistsOptions' carrying the URI-level parameters +-- documented at +-- +-- (@preference@, @realtime@, @refresh@, @routing@, @version@, +-- @version_type@). Note that @stored_fields@ is not honoured by the +-- source endpoint and is therefore absent from this record; use +-- 'documentExistsWith' for the full parameter set. +-- 'defaultDocumentSourceExistsOptions' makes this byte-for-byte +-- equivalent to 'documentSourceExists'. +documentSourceExistsWith :: + DocumentSourceExistsOptions -> + IndexName -> + DocId -> + BHRequest StatusDependant Bool +documentSourceExistsWith opts indexName (DocId docId) = + doesExist ([unIndexName indexName, "_source", docId] `withQueries` documentSourceExistsParams opts) + +-- | Backward-compatible alias for @'dispatchSearchWith' 'defaultSearchOptions'@. +-- Kept around so pre-existing callers (and the scroll helpers below) don't +-- have to thread 'SearchOptions' if they don't want any. +dispatchSearch :: (FromJSON a) => Endpoint -> Search -> BHRequest StatusDependant (SearchResult a) +dispatchSearch endpoint search = + dispatchSearchWith endpoint defaultSearchOptions search + +-- | Like 'dispatchSearch' but accepts a 'SearchOptions' record carrying the +-- URI-level search parameters (@preference@, @routing@, @request_cache@, +-- @expand_wildcards@, etc.) documented at +-- +-- and +-- . +-- +-- 'defaultSearchOptions' emits no parameters, making this byte-for-byte +-- equivalent to 'dispatchSearch'. +dispatchSearchWith :: + (FromJSON a) => + Endpoint -> + SearchOptions -> + Search -> + BHRequest StatusDependant (SearchResult a) +dispatchSearchWith endpoint opts search = + post url' (encode search) + where + url' = endpoint `withQueries` searchOptionsParams opts (searchType search) + +-- | Render a 'SearchOptions' record plus the always-present 'SearchType' as +-- a list of @key=value@ query parameters suitable for 'withQueries'. +-- 'Nothing' fields are omitted; the @search_type@ parameter is only emitted +-- when it differs from the server default ('SearchTypeQueryThenFetch'). +-- +-- The order of the returned list is stable but /unspecified/ — callers +-- (including tests) should treat it as a set and not pattern-match on the +-- head. The underlying 'withQueries' is order-insensitive. +searchOptionsParams :: SearchOptions -> SearchType -> [(Text, Maybe Text)] +searchOptionsParams SearchOptions {..} st = + stParam + <> catMaybes + [ boolParam "allow_no_indices" <$> soAllowNoIndices, + ("expand_wildcards",) . Just . renderExpandWildcards <$> soExpandWildcards, + boolParam "ignore_unavailable" <$> soIgnoreUnavailable, + ("preference",) . Just <$> soPreference, + ("routing",) . Just <$> soRouting, + boolParam "request_cache" <$> soRequestCache, + boolParam "typed_keys" <$> soTypedKeys, + boolParam "seq_no_primary_term" <$> soSeqNoPrimaryTerm, + intParam "max_concurrent_shard_requests" <$> soMaxConcurrentShardRequests, + intParam "batched_reduce_size" <$> soBatchedReduceSize, + boolParam "ccs_minimize_roundtrips" <$> soCcsMinimizeRoundtrips, + boolParam "allow_partial_search_results" <$> soAllowPartialSearchResults, + intParam "pre_filter_shard_size" <$> soPreFilterShardSize, + ("cancel_after_time_interval",) . Just . renderDuration <$> soCancelAfterTimeInterval, + intParam "max_concurrent_searches" <$> soMaxConcurrentSearches, + ("_source",) . Just . boolQP <$> soSource, + ("_source_includes",) . Just <$> soSourceIncludes, + ("_source_excludes",) . Just <$> soSourceExcludes + ] + where + -- 'SearchTypeQueryThenFetch' is the server default, so omit it to + -- preserve the legacy wire shape of 'dispatchSearch'. + stParam + | st == SearchTypeDfsQueryThenFetch = [("search_type", Just "dfs_query_then_fetch")] + | otherwise = [] + boolParam k b = (k, Just (boolQP b)) + intParam k n = (k, Just (showText n)) + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +-- | 'searchAll', given a 'Search', will perform that search against all indexes +-- on an Elasticsearch server. Try to avoid doing this if it can be helped. +-- +-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing +-- >>> let search = mkSearch (Just query) Nothing +-- >>> response <- runBH' $ searchAll search +searchAll :: (FromJSON a) => Search -> BHRequest StatusDependant (SearchResult a) +searchAll = + searchAllWith defaultSearchOptions + +-- | 'searchAllWith' is a variant of 'searchAll' that accepts a +-- 'SearchOptions' record for URI-level parameters. +searchAllWith :: + (FromJSON a) => + SearchOptions -> + Search -> + BHRequest StatusDependant (SearchResult a) +searchAllWith opts = + dispatchSearchWith ["_search"] opts + +-- | 'searchByIndex', given a 'Search' and an 'IndexName', will perform that search +-- within an index on an Elasticsearch server. +-- +-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing +-- >>> let search = mkSearch (Just query) Nothing +-- >>> response <- runBH' $ searchByIndex testIndex search +searchByIndex :: (FromJSON a) => IndexName -> Search -> BHRequest StatusDependant (SearchResult a) +searchByIndex indexName = + searchByIndexWith indexName defaultSearchOptions + +-- | 'searchByIndexWith' is a variant of 'searchByIndex' that accepts a +-- 'SearchOptions' record for URI-level parameters such as @preference@, +-- @routing@, and @request_cache@. +searchByIndexWith :: + (FromJSON a) => + IndexName -> + SearchOptions -> + Search -> + BHRequest StatusDependant (SearchResult a) +searchByIndexWith indexName opts = + dispatchSearchWith [unIndexName indexName, "_search"] opts + +-- | 'searchByIndices' is a variant of 'searchByIndex' that executes a +-- 'Search' over many indices. This is much faster than using +-- 'mapM' to 'searchByIndex' over a collection since it only +-- causes a single HTTP request to be emitted. +searchByIndices :: (FromJSON a) => NonEmpty IndexName -> Search -> BHRequest StatusDependant (SearchResult a) +searchByIndices ixs = + searchByIndicesWith ixs defaultSearchOptions + +-- | 'searchByIndicesWith' is a variant of 'searchByIndices' that accepts a +-- 'SearchOptions' record for URI-level parameters. +searchByIndicesWith :: + (FromJSON a) => + NonEmpty IndexName -> + SearchOptions -> + Search -> + BHRequest StatusDependant (SearchResult a) +searchByIndicesWith ixs opts = + dispatchSearchWith [renderedIxs, "_search"] opts + where + renderedIxs = T.intercalate (T.singleton ',') (map unIndexName (toList ixs)) + +-- | 'explainDocument' computes a score explanation for a single +-- document under a given 'Query', mirroring the +-- @POST \/{index}\/_explain\/{id}@ endpoint. The 'Query' is wrapped +-- on the wire as @{"query": ...}@ (via 'ExplainQuery'), which is the +-- shape @_explain@ actually accepts. A full 'Search' cannot be sent: +-- the server rejects the @from@\/@size@\/@track_scores@ (etc.) fields +-- that 'Search' always serialises. +-- +-- The response is parsed into an 'ExplainResponse'. Three outcomes +-- are distinguishable: +-- +-- * 'explainResponseMatched' is @True@ — the document matched; +-- 'explainResponseExplanation' is @Just@ an 'Explanation' tree. +-- * 'explainResponseMatched' is @False@ /and/ +-- 'explainResponseExplanation' is @Just (Explanation 0.0 ...)@ — +-- the document exists but the query did not match; the server +-- returns a synthetic explanation showing why (typically with +-- @value@ 0.0 and a description like @"no matching term"@). +-- * 'explainResponseMatched' is @False@ /and/ +-- 'explainResponseExplanation' is 'Nothing' — the document does +-- not exist. The server returns HTTP 404 with a body of the form +-- @{"_index":...,"_id":...,"matched":false}@, which decodes as a +-- minimal 'ExplainResponse'. ('StatusIndependant' is used so this +-- body is decoded directly rather than being routed through the +-- error-parser; a future revision could surface it as a +-- 'Left'-'EsError' if callers prefer.) +-- +-- Malformed requests (e.g. an unparseable 'Query') surface as +-- @'Left' 'EsError'@ carrying the server's HTTP status (the body +-- cannot be decoded as an 'ExplainResponse' so the wrapper falls +-- back to a synthetic parse-error message). +-- +-- Equivalent to @'explainDocumentWith' 'defaultExplainOptions'@: no +-- URI parameters are emitted, preserving the legacy wire shape. Use +-- 'explainDocumentWith' to set @routing@, @preference@, +-- @stored_fields@, @_source@ filtering, or the query-parsing +-- parameters (@default_operator@, @analyzer@, @df@, +-- @analyze_wildcard@, @lenient@). +-- +-- , +-- . +explainDocument :: + IndexName -> + DocId -> + Query -> + BHRequest StatusIndependant ExplainResponse +explainDocument = explainDocumentWith defaultExplainOptions + +-- | Like 'explainDocument' but accepts an 'ExplainOptions' record +-- carrying the URI-level parameters documented for @_explain@ +-- (@routing@, @preference@, @stored_fields@, @_source@, +-- @_source_includes@\/@_source_excludes@, @lenient@, +-- @default_operator@, @df@, @analyzer@, @analyze_wildcard@). +-- 'defaultExplainOptions' makes this byte-for-byte equivalent to +-- 'explainDocument'. +explainDocumentWith :: + ExplainOptions -> + IndexName -> + DocId -> + Query -> + BHRequest StatusIndependant ExplainResponse +explainDocumentWith opts indexName (DocId docId) query = + post ([unIndexName indexName, "_explain", docId] `withQueries` explainOptionsParams opts) (encode (ExplainQuery query)) + +dispatchMultiSearch :: + (FromJSON a) => + Endpoint -> + SearchOptions -> + NonEmpty MultiSearchItem -> + BHRequest StatusDependant (MultiSearchResponse a) +dispatchMultiSearch endpoint opts items = + post endpoint' (encodeMultiSearchItems items) + where + -- The URI-level @search_type@ parameter is omitted by + -- 'searchOptionsParams' under 'SearchTypeQueryThenFetch' (the server + -- default). Per-item @search_type@ in 'multiSearchItemSearchType' + -- overrides the URI level for that sub-request. + endpoint' = endpoint `withQueries` searchOptionsParams opts SearchTypeQueryThenFetch + +-- | 'multiSearch' performs a multi-search request against @_msearch@ with +-- 'defaultSearchOptions', preserving the legacy wire shape (no URI +-- parameters beyond what the server applies by default). +multiSearch :: + (FromJSON a) => + NonEmpty MultiSearchItem -> + BHRequest StatusDependant (MultiSearchResponse a) +multiSearch = multiSearchWith defaultSearchOptions + +-- | 'multiSearchWith' is a variant of 'multiSearch' that accepts a +-- 'SearchOptions' record carrying URI-level parameters +-- (@max_concurrent_searches@, @typed_keys@, @pre_filter_shard_size@, +-- @ccs_minimize_roundtrips@, ...). Per-header fields live on each +-- 'MultiSearchItem'; the URI-level @search_type@ is intentionally +-- omitted by 'dispatchMultiSearch' (it conflicts with the per-item +-- semantics) so set 'multiSearchItemSearchType' to choose +-- @query_then_fetch@ vs @dfs_query_then_fetch@ per sub-request. +-- +-- See +-- and . +multiSearchWith :: + (FromJSON a) => + SearchOptions -> + NonEmpty MultiSearchItem -> + BHRequest StatusDependant (MultiSearchResponse a) +multiSearchWith = dispatchMultiSearch ["_msearch"] + +-- | 'multiSearchByIndex' runs an @_msearch@ scoped to a single index, +-- with each 'Search' wrapped in a 'MultiSearchItem' that has no per-item +-- header fields set. Uses 'defaultSearchOptions'. +multiSearchByIndex :: + (FromJSON a) => + IndexName -> + NonEmpty Search -> + BHRequest StatusDependant (MultiSearchResponse a) +multiSearchByIndex = multiSearchByIndexWith defaultSearchOptions + +-- | 'multiSearchByIndexWith' is a variant of 'multiSearchByIndex' that +-- accepts a 'SearchOptions' record. The per-item header fields are +-- cleared because the index is already pinned by the URL +-- (@\/{index}\/_msearch@) and the remaining header fields +-- (@routing@, @search_type@, @preference@, ...) have no natural +-- "all sub-searches get the same value" default at this layer; callers +-- who need per-item values should switch to 'multiSearchWith'. +multiSearchByIndexWith :: + (FromJSON a) => + SearchOptions -> + IndexName -> + NonEmpty Search -> + BHRequest StatusDependant (MultiSearchResponse a) +multiSearchByIndexWith opts indexName searches = + dispatchMultiSearch [unIndexName indexName, "_msearch"] opts items + where + items = fmap emptyHeader searches + emptyHeader s = + MultiSearchItem + { multiSearchItemIndex = Nothing, + multiSearchItemRouting = Nothing, + multiSearchItemSearchType = Nothing, + multiSearchItemPreference = Nothing, + multiSearchItemAllowPartialSearchResults = Nothing, + multiSearchItemSearch = s + } + +dispatchMultiSearchTemplate :: + (FromJSON a) => + Endpoint -> + SearchOptions -> + NonEmpty MultiSearchTemplateItem -> + BHRequest StatusDependant (MultiSearchResponse a) +dispatchMultiSearchTemplate endpoint opts items = + post endpoint' (encodeMultiSearchTemplateItems items) + where + -- Same URI plumbing as 'dispatchMultiSearch': the URI-level + -- @search_type@ is omitted under 'SearchTypeQueryThenFetch' (the + -- server default). Per-item @search_type@ in + -- 'multiSearchTemplateItemSearchType' overrides the URI level for + -- that sub-request. + endpoint' = endpoint `withQueries` searchOptionsParams opts SearchTypeQueryThenFetch + +-- | 'multiSearchTemplate' performs a multi-search template request +-- against @_msearch/template@ with 'defaultSearchOptions'. Each +-- 'MultiSearchTemplateItem' pairs a per-sub-request header (index, +-- routing, ...) with a 'SearchTemplate' body. The response shape is the +-- same as @_msearch@ — a 'MultiSearchResponse' of 'SearchResult's. +-- +-- See +-- and . +multiSearchTemplate :: + (FromJSON a) => + NonEmpty MultiSearchTemplateItem -> + BHRequest StatusDependant (MultiSearchResponse a) +multiSearchTemplate = multiSearchTemplateWith defaultSearchOptions + +-- | 'multiSearchTemplateWith' is a variant of 'multiSearchTemplate' that +-- accepts a 'SearchOptions' record carrying URI-level parameters +-- (@max_concurrent_searches@, @typed_keys@, ...). Per-header fields live +-- on each 'MultiSearchTemplateItem'; the URI-level @search_type@ is +-- intentionally omitted by 'dispatchMultiSearchTemplate' (it conflicts +-- with the per-item semantics) so set +-- 'multiSearchTemplateItemSearchType' to choose @query_then_fetch@ vs +-- @dfs_query_then_fetch@ per sub-request. +-- +-- See +-- and . +multiSearchTemplateWith :: + (FromJSON a) => + SearchOptions -> + NonEmpty MultiSearchTemplateItem -> + BHRequest StatusDependant (MultiSearchResponse a) +multiSearchTemplateWith = dispatchMultiSearchTemplate ["_msearch", "template"] + +-- | 'multiSearchTemplateByIndex' runs an @_msearch/template@ scoped to a +-- single index, with each 'SearchTemplate' wrapped in a +-- 'MultiSearchTemplateItem' that has no per-item header fields set. +-- Uses 'defaultSearchOptions'. +multiSearchTemplateByIndex :: + (FromJSON a) => + IndexName -> + NonEmpty SearchTemplate -> + BHRequest StatusDependant (MultiSearchResponse a) +multiSearchTemplateByIndex = multiSearchTemplateByIndexWith defaultSearchOptions + +-- | 'multiSearchTemplateByIndexWith' is a variant of +-- 'multiSearchTemplateByIndex' that accepts a 'SearchOptions' record. +-- The per-item header fields are cleared because the index is already +-- pinned by the URL (@\/{index}\/_msearch\/template@); callers who need +-- per-item header values should switch to 'multiSearchTemplateWith'. +multiSearchTemplateByIndexWith :: + (FromJSON a) => + SearchOptions -> + IndexName -> + NonEmpty SearchTemplate -> + BHRequest StatusDependant (MultiSearchResponse a) +multiSearchTemplateByIndexWith opts indexName templates = + dispatchMultiSearchTemplate [unIndexName indexName, "_msearch", "template"] opts items + where + items = fmap emptyHeader templates + emptyHeader t = + MultiSearchTemplateItem + { multiSearchTemplateItemIndex = Nothing, + multiSearchTemplateItemRouting = Nothing, + multiSearchTemplateItemSearchType = Nothing, + multiSearchTemplateItemPreference = Nothing, + multiSearchTemplateItemAllowPartialSearchResults = Nothing, + multiSearchTemplateItemSearchTemplate = t + } + +dispatchSearchTemplate :: + (FromJSON a) => + Endpoint -> + SearchTemplate -> + BHRequest StatusDependant (SearchResult a) +dispatchSearchTemplate endpoint search = + post endpoint $ encode search + +-- | 'searchByIndexTemplate', given a 'SearchTemplate' and an 'IndexName', will perform that search +-- within an index on an Elasticsearch server. +-- +-- >>> let query = SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } }, \"size\" : \"{{my_size}}\"}" +-- >>> let search = mkSearchTemplate (Right query) Nothing +-- >>> response <- runBH' $ searchByIndexTemplate testIndex search +searchByIndexTemplate :: + (FromJSON a) => + IndexName -> + SearchTemplate -> + BHRequest StatusDependant (SearchResult a) +searchByIndexTemplate indexName = + dispatchSearchTemplate [unIndexName indexName, "_search", "template"] + +-- | 'searchByIndicesTemplate' is a variant of 'searchByIndexTemplate' that executes a +-- 'SearchTemplate' over many indices. This is much faster than using +-- 'mapM' to 'searchByIndexTemplate' over a collection since it only +-- causes a single HTTP request to be emitted. +searchByIndicesTemplate :: + (FromJSON a) => + NonEmpty IndexName -> + SearchTemplate -> + BHRequest StatusDependant (SearchResult a) +searchByIndicesTemplate ixs = + dispatchSearchTemplate [renderedIxs, "_search", "template"] + where + renderedIxs = T.intercalate (T.singleton ',') (map unIndexName (toList ixs)) + +-- | 'storeSearchTemplate', saves a 'SearchTemplateSource' to be used later. +storeSearchTemplate :: SearchTemplateId -> SearchTemplateSource -> BHRequest StatusDependant Acknowledged +storeSearchTemplate (SearchTemplateId tid) ts = + post ["_scripts", tid] (encode body) + where + body = Object $ X.fromList ["script" .= Object ("lang" .= String "mustache" <> "source" .= ts)] + +-- | 'getSearchTemplate', get info of an stored 'SearchTemplateSource'. +getSearchTemplate :: SearchTemplateId -> BHRequest StatusIndependant GetTemplateScript +getSearchTemplate (SearchTemplateId tid) = + get ["_scripts", tid] + +-- | 'storeSearchTemplate', +deleteSearchTemplate :: SearchTemplateId -> BHRequest StatusIndependant Acknowledged +deleteSearchTemplate (SearchTemplateId tid) = + delete ["_scripts", tid] + +-- | 'renderTemplate' renders a 'SearchTemplate' as a search request +-- body /without/ executing the search. The endpoint is +-- @GET /_render/template@ for an inline template (a 'SearchTemplate' +-- whose 'searchTemplate' is @'Right' source@) or +-- @GET /_render/template\/{id}@ for a stored template (whose +-- 'searchTemplate' is @'Left' ('SearchTemplateId' id)@); the path +-- segment is therefore derived from 'searchTemplate'. +-- +-- Unlike almost every other GET in the ES API, @_render/template@ +-- sends its input in a request body (the encoded 'SearchTemplate': +-- @source@ \/ @id@, @params@, @explain@, @profile@), so the request +-- is built with 'getWithBody' rather than 'get'. The body is accepted +-- verbatim by both path variants; when the @id@ path variant is used, +-- a redundant @\"id\"@ key in the body is harmless — the server takes +-- the id from the path and ignores the body copy. +-- +-- The rendered output is returned as a raw aeson 'Value'. The server +-- wraps it in a @{\"template_output\": ...}@ envelope; callers wanting +-- the rendered body itself extract the @\"template_output\"@ key. +-- Returning the whole body as 'Value' mirrors the @explainSQL@ / +-- @predict@ precedent (the only other free-form-'Value' endpoints in +-- the surface) and avoids baking in an envelope wrapper that future +-- server-side shape drift could invalidate. The request is +-- 'StatusDependant' and wrapped in 'ParsedEsResponse', so a 4xx (a +-- parse error in the template source, a missing stored id, ...) is +-- surfaced as @'Left' 'EsError'@ rather than thrown. +-- +-- () +renderTemplate :: + SearchTemplate -> + BHRequest StatusDependant (ParsedEsResponse Value) +renderTemplate search = + withBHResponseParsedEsResponse $ + getWithBody @StatusDependant endpoint (encode search) + where + endpoint = + case searchTemplate search of + Left (SearchTemplateId tid) -> ["_render", "template", tid] + Right _ -> ["_render", "template"] + +-- | For a given search, request a scroll for efficient streaming of +-- search results. Note that the search is put into 'SearchTypeScan' +-- mode and thus results will not be sorted. Combine this with +-- 'advanceScroll' to efficiently stream through the full result set +getInitialScroll :: + (FromJSON a) => + IndexName -> + Search -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult a)) +getInitialScroll indexName search' = + withBHResponseParsedEsResponse $ dispatchSearch endpoint search + where + endpoint = [unIndexName indexName, "_search"] `withQueries` [("scroll", Just "1m")] + sorting = Just [DefaultSortSpec $ mkSort (FieldName "_doc") Descending] + search = search' {sortBody = sorting} + +-- | For a given search, request a scroll for efficient streaming of +-- search results. Combine this with 'advanceScroll' to efficiently +-- stream through the full result set. Note that this search respects +-- sorting and may be less efficient than 'getInitialScroll'. +getInitialSortedScroll :: + (FromJSON a) => + IndexName -> + Search -> + BHRequest StatusDependant (SearchResult a) +getInitialSortedScroll indexName search = do + dispatchSearch endpoint search + where + endpoint = [unIndexName indexName, "_search"] `withQueries` [("scroll", Just "1m")] + +-- | Use the given scroll to fetch the next page of documents. If there are no +-- further pages, 'SearchResult.searchHits.hits' will be '[]'. +-- +-- Equivalent to @'advanceScrollWith' 'defaultAdvanceScrollOptions'@. Use +-- the @With@ variant to send @?rest_total_hits_as_int=true@ (useful when +-- you want the server to render @hits.total@ as a bare integer rather +-- than the @{value, relation}@ object). +advanceScroll :: + (FromJSON a) => + ScrollId -> + -- | How long should the snapshot of data be kept around? This timeout is updated every time 'advanceScroll' is used, so don't feel the need to set it to the entire duration of your search processing. Note that durations < 1s will be rounded up. Also note that 'NominalDiffTime' is an instance of Num so literals like 60 will be interpreted as seconds. 60s is a reasonable default. + NominalDiffTime -> + BHRequest StatusDependant (SearchResult a) +advanceScroll = + advanceScrollWith defaultAdvanceScrollOptions + +-- | Like 'advanceScroll' but accepts an 'AdvanceScrollOptions' record +-- carrying URI-level parameters for @POST /_search/scroll@. Currently +-- the only exposed parameter is @rest_total_hits_as_int@; see +-- 'AdvanceScrollOptions' for details. +-- +-- @'advanceScrollWith' 'defaultAdvanceScrollOptions'@ is byte-for-byte +-- identical to 'advanceScroll'. +-- +-- () +advanceScrollWith :: + (FromJSON a) => + AdvanceScrollOptions -> + ScrollId -> + -- | How long should the snapshot of data be kept around? This timeout is updated every time 'advanceScroll' is used, so don't feel the need to set it to the entire duration of your search processing. Note that durations < 1s will be rounded up. Also note that 'NominalDiffTime' is an instance of Num so literals like 60 will be interpreted as seconds. 60s is a reasonable default. + NominalDiffTime -> + BHRequest StatusDependant (SearchResult a) +advanceScrollWith opts (ScrollId sid) scroll = + post endpoint (encode scrollObject) + where + endpoint = + ["_search", "scroll"] `withQueries` advanceScrollOptionsParams opts + scrollTime = showText secs <> "s" + secs :: Integer + secs = round scroll + + scrollObject = + object + [ "scroll" .= scrollTime, + "scroll_id" .= sid + ] + +-- | Release a scroll context immediately rather than waiting for its +-- @keep_alive@ to expire. Both Elasticsearch and OpenSearch accept a single +-- @scroll_id@ string or a JSON array of them; here we always send a single-ID +-- array. Use this to avoid leaking contexts up to the +-- @search.max_open_scroll_context@ limit (default 500). +-- +-- Doc: https://www.elastic.co/guide/en/elasticsearch/reference/7.17/clear-scroll-api.html +clearScroll :: + ScrollId -> + BHRequest StatusDependant ClearScrollResponse +clearScroll (ScrollId sid) = + deleteWithBody ["_search", "scroll"] (encode scrollObject) + where + scrollObject = + object ["scroll_id" .= ([sid] :: [Text])] + +-- | 'mkSearch' is a helper function for defaulting additional fields of a 'Search' +-- to Nothing in case you only care about your 'Query' and 'Filter'. Use record update +-- syntax if you want to add things like aggregations or highlights while still using +-- this helper function. +-- +-- >>> let query = TermQuery (Term "user" "bitemyapp") Nothing +-- >>> mkSearch (Just query) Nothing +-- Search {queryBody = Just (TermQuery (Term {termField = "user", termValue = "bitemyapp"}) Nothing), filterBody = Nothing, searchAfterKey = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing} +mkSearch :: Maybe Query -> Maybe Filter -> Search +mkSearch query filter = + Search + { queryBody = query, + filterBody = filter, + sortBody = Nothing, + aggBody = Nothing, + highlight = Nothing, + trackSortScores = False, + from = From 0, + size = Size 10, + searchType = SearchTypeQueryThenFetch, + searchAfterKey = Nothing, + fields = Nothing, + scriptFields = Nothing, + docvalueFields = Nothing, + source = Nothing, + suggestBody = Nothing, + pointInTime = Nothing, + knnBody = Nothing, + osKnnBody = Nothing, + trackTotalHits = Nothing, + timeout = Nothing, + minScore = Nothing, + explain = Nothing, + searchVersion = Nothing, + seqNoPrimaryTerm = Nothing, + terminateAfter = Nothing, + stats = Nothing, + searchPipeline = Nothing, + storedFields = Nothing, + runtimeMappings = Nothing, + rescore = Nothing, + collapse = Nothing, + retriever = Nothing + } + +-- | 'mkAggregateSearch' is a helper function that defaults everything in a 'Search' except for +-- the 'Query' and the 'Aggregation'. +-- +-- >>> let terms = TermsAgg $ (mkTermsAggregation "user") { termCollectMode = Just BreadthFirst } +-- >>> terms +-- TermsAgg (TermsAggregation {term = Left "user", termInclude = Nothing, termExclude = Nothing, termOrder = Nothing, termMinDocCount = Nothing, termSize = Nothing, termShardSize = Nothing, termCollectMode = Just BreadthFirst, termExecutionHint = Nothing, termAggs = Nothing}) +-- >>> let myAggregation = mkAggregateSearch Nothing $ mkAggregations "users" terms +mkAggregateSearch :: Maybe Query -> Aggregations -> Search +mkAggregateSearch query mkSearchAggs = + Search + { queryBody = query, + filterBody = Nothing, + sortBody = Nothing, + aggBody = Just mkSearchAggs, + highlight = Nothing, + trackSortScores = False, + from = From 0, + size = Size 0, + searchType = SearchTypeQueryThenFetch, + searchAfterKey = Nothing, + fields = Nothing, + scriptFields = Nothing, + docvalueFields = Nothing, + source = Nothing, + suggestBody = Nothing, + pointInTime = Nothing, + knnBody = Nothing, + osKnnBody = Nothing, + trackTotalHits = Nothing, + timeout = Nothing, + minScore = Nothing, + explain = Nothing, + searchVersion = Nothing, + seqNoPrimaryTerm = Nothing, + terminateAfter = Nothing, + stats = Nothing, + searchPipeline = Nothing, + storedFields = Nothing, + runtimeMappings = Nothing, + rescore = Nothing, + collapse = Nothing, + retriever = Nothing + } + +-- | 'mkHighlightSearch' is a helper function that defaults everything in a 'Search' except for +-- the 'Query' and the 'Aggregation'. +-- +-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") +-- >>> let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing] +-- >>> let search = mkHighlightSearch (Just query) testHighlight +mkHighlightSearch :: Maybe Query -> Highlights -> Search +mkHighlightSearch query searchHighlights = + Search + { queryBody = query, + filterBody = Nothing, + sortBody = Nothing, + aggBody = Nothing, + highlight = Just searchHighlights, + trackSortScores = False, + from = From 0, + size = Size 10, + searchType = SearchTypeDfsQueryThenFetch, + searchAfterKey = Nothing, + fields = Nothing, + scriptFields = Nothing, + docvalueFields = Nothing, + source = Nothing, + suggestBody = Nothing, + pointInTime = Nothing, + knnBody = Nothing, + osKnnBody = Nothing, + trackTotalHits = Nothing, + timeout = Nothing, + minScore = Nothing, + explain = Nothing, + searchVersion = Nothing, + seqNoPrimaryTerm = Nothing, + terminateAfter = Nothing, + stats = Nothing, + searchPipeline = Nothing, + storedFields = Nothing, + runtimeMappings = Nothing, + rescore = Nothing, + collapse = Nothing, + retriever = Nothing + } + +-- | 'mkSearchTemplate' is a helper function for defaulting additional fields of a 'SearchTemplate' +-- to Nothing. Use record update syntax if you want to add things. +mkSearchTemplate :: Either SearchTemplateId SearchTemplateSource -> TemplateQueryKeyValuePairs -> SearchTemplate +mkSearchTemplate id_ params = SearchTemplate id_ params Nothing Nothing + +-- | 'pageSearch' is a helper function that takes a search and assigns the from +-- and size fields for the search. The from parameter defines the offset +-- from the first result you want to fetch. The size parameter allows you to +-- configure the maximum amount of hits to be returned. +-- +-- >>> let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell") +-- >>> let search = mkSearch (Just query) Nothing +-- >>> search +-- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Nothing, matchQueryZeroTerms = Nothing, matchQueryCutoffFrequency = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing, matchQueryBoost = Nothing, matchQueryMinimumShouldMatch = Nothing, matchQueryFuzziness = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 0, size = Size 10, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing} +-- >>> pageSearch (From 10) (Size 100) search +-- Search {queryBody = Just (QueryMatchQuery (MatchQuery {matchQueryField = FieldName "_all", matchQueryQueryString = QueryString "haskell", matchQueryOperator = Nothing, matchQueryZeroTerms = Nothing, matchQueryCutoffFrequency = Nothing, matchQueryAnalyzer = Nothing, matchQueryMaxExpansions = Nothing, matchQueryLenient = Nothing, matchQueryBoost = Nothing, matchQueryMinimumShouldMatch = Nothing, matchQueryFuzziness = Nothing})), filterBody = Nothing, sortBody = Nothing, aggBody = Nothing, highlight = Nothing, trackSortScores = False, from = From 10, size = Size 100, searchType = SearchTypeQueryThenFetch, fields = Nothing, source = Nothing} +pageSearch :: + -- | The result offset + From -> + -- | The number of results to return + Size -> + -- | The current seach + Search -> + -- | The paged search + Search +pageSearch resultOffset pageSize search = search {from = resultOffset, size = pageSize} + +boolQP :: Bool -> Text +boolQP True = "true" +boolQP False = "false" + +-- | 'countByIndex' counts the documents matching 'CountQuery' in a +-- single index. Wraps @POST \/{index}\/_count@ +-- (, +-- ). +-- +-- This is the simple, parameterless form; it is byte-for-byte +-- identical to a call made with 'defaultCountOptions'. Pass URI +-- parameters (@allow_no_indices@, @expand_wildcards@, +-- @ignore_unavailable@, @min_score@, @preference@, @routing@) +-- via 'countByIndexWith', and count across the whole cluster (or a +-- list of indices) via 'countAll' \/ 'countByIndexWith'. +countByIndex :: IndexName -> CountQuery -> BHRequest StatusDependant CountResponse +countByIndex indexName q = + countByIndexWith (Just [indexName]) defaultCountOptions q + +-- | 'countByIndexWith' is the fully-parameterised form of +-- 'countByIndex'. Every URI parameter accepted by @/_count@ is exposed +-- via 'CountOptions'. The index argument selects the request path: +-- +-- * 'Nothing' or @'Just' []@ — @POST /_count@, counts across every +-- index on the cluster (this is also what 'countAll' does). +-- * @'Just' [i]@ — @POST \/{i}\/_count@, equivalent to 'countByIndex'. +-- * @'Just' (i : is)@ — @POST \/{i,is...}\/_count@, with the index +-- names joined by commas; the server expands wildcard patterns and +-- honours 'coExpandWildcards'. +countByIndexWith :: + Maybe [IndexName] -> + CountOptions -> + CountQuery -> + BHRequest StatusDependant CountResponse +countByIndexWith mIndices opts q = + post @StatusDependant endpoint (encode q) + where + endpoint = path `withQueries` countOptionsParams opts + path = + case mIndices of + Nothing -> ["_count"] + Just [] -> ["_count"] + Just (first : rest) -> + [T.intercalate "," (map unIndexName (first : rest)), "_count"] + +-- | 'countAll' counts the documents matching 'CountQuery' across every +-- index on the cluster. Wraps @POST /_count@ (without an index path +-- segment). It is 'countByIndexWith' with the index argument set to +-- 'Nothing' and 'defaultCountOptions'; pass URI parameters by calling +-- 'countByIndexWith' directly. +countAll :: CountQuery -> BHRequest StatusDependant CountResponse +countAll q = countByIndexWith Nothing defaultCountOptions q + +-- $validateOverview +-- +-- The @_validate/query@ endpoints check whether a 'Query' parses +-- against the resolved index mapping without executing it. They are +-- shared verbatim by Elasticsearch (7.x\/8.x\/9.x) and OpenSearch +-- (1.x\/2.x\/3.x). +-- +-- * +-- * + +-- | 'validateQuery' validates a 'Query' against a single index. Wraps +-- @POST \/{index}/_validate/query@ +-- (, +-- ). +-- +-- This is the simple, parameterless form; it is byte-for-byte +-- identical to a call made with 'defaultValidateOptions'. Pass URI +-- parameters (@explain@, @all@, @expand_wildcards@, etc.) via +-- 'validateQueryWith', and validate across the whole cluster (or a +-- list of indices) via 'validateAll' \/ 'validateQueryWith'. +-- +-- On the minimal response (no @explain@, no @all@) the server +-- returns @{"valid":bool}@; 'validateQueryResponseShards' and +-- 'validateQueryResponseExplanations' will both be 'Nothing'. Use +-- 'validateQueryWith' with @voExplain = Just True@ to obtain the +-- per-index 'ValidateExplanation' breakdown. +validateQuery :: + IndexName -> + ValidateQuery -> + BHRequest StatusDependant ValidateQueryResponse +validateQuery indexName q = + validateQueryWith (Just [indexName]) defaultValidateOptions q + +-- | 'validateQueryWith' is the fully-parameterised form of +-- 'validateQuery'. Every URI parameter accepted by +-- @/_validate/query@ is exposed via 'ValidateOptions'. The index +-- argument selects the request path: +-- +-- * 'Nothing' or @'Just' []@ — @POST /_validate/query@, validates +-- against every index on the cluster (this is also what +-- 'validateAll' does). +-- * @'Just' [i]@ — @POST \/{i}/_validate/query@, equivalent to +-- 'validateQuery'. +-- * @'Just' (i : is)@ — @POST \/{i,is...}/_validate/query@, with +-- the index names joined by commas; the server expands wildcard +-- patterns and honours 'voExpandWildcards'. +validateQueryWith :: + Maybe [IndexName] -> + ValidateOptions -> + ValidateQuery -> + BHRequest StatusDependant ValidateQueryResponse +validateQueryWith mIndices opts q = + post @StatusDependant endpoint (encode q) + where + endpoint = path `withQueries` validateOptionsParams opts + path = + case mIndices of + Nothing -> ["_validate", "query"] + Just [] -> ["_validate", "query"] + Just (first : rest) -> + [ T.intercalate "," (map unIndexName (first : rest)), + "_validate", + "query" + ] + +-- | 'validateAll' validates a 'Query' across every index on the +-- cluster. Wraps @POST /_validate/query@ (without an index path +-- segment). It is 'validateQueryWith' with the index argument set to +-- 'Nothing' and 'defaultValidateOptions'; pass URI parameters by +-- calling 'validateQueryWith' directly. +validateAll :: ValidateQuery -> BHRequest StatusDependant ValidateQueryResponse +validateAll q = validateQueryWith Nothing defaultValidateOptions q + +-- $rankEvalOverview +-- +-- The @_rank_eval@ endpoints evaluate the quality of ranked search +-- results against a set of known relevance ratings. They are shared +-- verbatim by Elasticsearch (7.x\/8.x\/9.x) and OpenSearch +-- (1.x\/2.x\/3.x). +-- +-- * +-- * + +-- | 'evaluateRank' runs a rank-evaluation request against every index +-- on the cluster. Wraps @POST /_rank_eval@ with +-- 'defaultRankEvalOptions'. Pass a 'RankEvalMetric' via the +-- 'RankEvalRequest' to override the server default (mean reciprocal +-- rank with @k=20@); pass URI parameters via 'evaluateRankWith', and +-- scope to a single index (or a comma-joined list) via +-- 'evaluateRankByIndex'. +evaluateRank :: + RankEvalRequest -> + BHRequest StatusDependant RankEvalResponse +evaluateRank = evaluateRankWith Nothing defaultRankEvalOptions + +-- | 'evaluateRankByIndex' is the single-index form of 'evaluateRank'. +-- Maps to @POST \/{index}\/_rank_eval@. Use 'evaluateRankWith' to +-- target multiple comma-joined indices or to forward URI parameters +-- (@search_type@, @allow_no_indices@, @expand_wildcards@, +-- @ignore_unavailable@). +evaluateRankByIndex :: + IndexName -> + RankEvalRequest -> + BHRequest StatusDependant RankEvalResponse +evaluateRankByIndex indexName = evaluateRankWith (Just [indexName]) defaultRankEvalOptions + +-- | 'evaluateRankWith' is the fully-parameterised form of +-- 'evaluateRank'. The index argument selects the request path: +-- +-- * 'Nothing' or @'Just' []@ — @POST /_rank_eval@, evaluates across +-- every index on the cluster (this is also what 'evaluateRank' +-- does). +-- * @'Just' [i]@ — @POST \/{i}\/_rank_eval@, equivalent to +-- 'evaluateRankByIndex'. +-- * @'Just' (i : is)@ — @POST \/{i,is...}\/_rank_eval@, with the +-- index names joined by commas; the server expands wildcard +-- patterns and honours 'reoExpandWildcards'. +evaluateRankWith :: + Maybe [IndexName] -> + RankEvalOptions -> + RankEvalRequest -> + BHRequest StatusDependant RankEvalResponse +evaluateRankWith mIndices opts body = + post @StatusDependant endpoint (encode body) + where + endpoint = path `withQueries` rankEvalOptionsParams opts + path = + case mIndices of + Nothing -> ["_rank_eval"] + Just [] -> ["_rank_eval"] + Just (first : rest) -> + [T.intercalate "," (map unIndexName (first : rest)), "_rank_eval"] + +-- | 'getFieldCaps' returns the capabilities of fields (searchable, +-- aggregatable, type, contributing indices) across the given indices +-- (or every index on the cluster when 'Nothing' or @'Just' []@ is +-- supplied). The field patterns restrict which fields are returned; +-- pass @[]@ to ask for every field. Maps to @POST /_field_caps@ or +-- @POST \/{index}\/_field_caps@. +-- +-- Use 'getFieldCapsWith' to send an @index_filter@ query, runtime +-- mappings, or additional URI parameters (@allow_no_indices@, +-- @expand_wildcards@, @ignore_unavailable@, @include_unmapped@). +getFieldCaps :: + Maybe [IndexName] -> + [FieldPattern] -> + BHRequest StatusDependant FieldCapsResponse +getFieldCaps mIndices fields = + getFieldCapsWith mIndices opts defaultFieldCapsRequest + where + opts = + defaultFieldCapsOptions + { fcoFields = case fields of + [] -> Nothing + xs -> Just xs + } + +-- | 'getFieldCapsWith' is the fully-parameterised form of +-- 'getFieldCaps'. Every URI parameter accepted by @/_field_caps@ is +-- exposed via 'FieldCapsOptions' (including the @fields@ array, which +-- is sent as a comma-joined URI query parameter for cross-version +-- compatibility — Elasticsearch ≤ 7.x does not accept @fields@ in the +-- body). The 'FieldCapsRequest' body controls the @index_filter@ +-- query and the @runtime_mappings@ object. +getFieldCapsWith :: + Maybe [IndexName] -> + FieldCapsOptions -> + FieldCapsRequest -> + BHRequest StatusDependant FieldCapsResponse +getFieldCapsWith mIndices opts req = + post @StatusDependant endpoint (encode req) + where + endpoint = path `withQueries` fieldCapsOptionsParams opts + path = + case mIndices of + Nothing -> ["_field_caps"] + Just [] -> ["_field_caps"] + Just (first : rest) -> + [T.intercalate "," (map unIndexName (first : rest)), "_field_caps"] + +-- | 'getSearchShards' returns the shards and nodes that a search +-- request would be executed against, without running the search +-- itself. Pass 'Nothing' or @'Just' []@ to target every index the +-- caller can see; pass a non-empty list to restrict the routing +-- computation to a comma-joined subset. Issues +-- @POST \/{indices}\/_search_shards@ (the server also accepts @GET@ +-- but takes no body, so the bodyless 'postNoBody' variant is used). +-- +-- Equivalent to @'getSearchShardsWith' 'defaultSearchShardsOptions'@. +-- Use the @With@ variant to pass @allow_no_indices@, +-- @expand_wildcards@, @ignore_unavailable@, @local@, @master_timeout@, +-- @preference@ or @routing@. +getSearchShards :: + Maybe [IndexName] -> + BHRequest StatusDependant SearchShardsResponse +getSearchShards mIndices = + getSearchShardsWith mIndices defaultSearchShardsOptions + +-- | 'getSearchShardsWith' is the fully-parameterised form of +-- 'getSearchShards'. Every URI parameter accepted by +-- @/{indices}/_search_shards@ is exposed via 'SearchShardsOptions'. +-- 'defaultSearchShardsOptions' makes this byte-for-byte identical to +-- 'getSearchShards'. +getSearchShardsWith :: + Maybe [IndexName] -> + SearchShardsOptions -> + BHRequest StatusDependant SearchShardsResponse +getSearchShardsWith mIndices opts = + postNoBody @StatusDependant (path `withQueries` searchShardsOptionsParams opts) + where + path = + case mIndices of + Nothing -> ["_search_shards"] + Just [] -> ["_search_shards"] + Just (first : rest) -> + [T.intercalate "," (map unIndexName (first : rest)), "_search_shards"] + +-- $vectorTile +-- +-- /Vector tile search/ renders the results of a geospatial search as a +-- binary Mapbox Vector Tile (MVT, encoded as a Google Protobuf). The +-- endpoint was added in Elasticsearch 7.15.0 and is also available in +-- OpenSearch; the wire format is identical, so the request builder +-- lives in the Common layer. + +-- | 'searchVectorTile' issues a +-- @GET \/{index}\/_mvt\/{field}\/{zoom}\/{x}\/{y}@ request and returns +-- the response body verbatim as a lazy 'L.ByteString'. The body is a +-- Mapbox Vector Tile encoded as a Google Protobuf (PBF); callers are +-- responsible for decoding it with a library such as @vector-tile@. +-- +-- The 'Search' argument supplies the @query@, @aggs@, @sort@, @fields@, +-- @runtime_mappings@, @size@ and @track_total_hits@ body fields. MVT +-- does not accept the full 'Search' surface — server-side validation +-- rejects unknown fields such as @from@, @collapse@, @highlight@ and +-- @suggest@. The Haddock on 'searchVectorTileWith' lists the body +-- fields the endpoint accepts. +-- +-- Equivalent to @'searchVectorTileWith' 'defaultVectorTileOptions'@: +-- the URI parameter list is empty, so every server-side body default +-- (@extent = 4096@, @grid_precision = 8@, @size = 10000@, +-- @exact_bounds = false@, @buffer = 5@) applies. Use the @With@ +-- variant to override any of these via the corresponding URI parameter +-- (which takes precedence over the body value per the ES docs). +-- +-- See +-- +-- and +-- . +searchVectorTile :: + IndexName -> + FieldName -> + TileZoom -> + TileX -> + TileY -> + Search -> + BHRequest StatusDependant L.ByteString +searchVectorTile indexName field zoom x y = + searchVectorTileWith indexName field zoom x y defaultVectorTileOptions + +-- | 'searchVectorTileWith' is the fully-parameterised form of +-- 'searchVectorTile'. The MVT-specific URI parameters +-- ('VectorTileOptions') override the JSON body values when both are +-- set. The body fields the endpoint accepts are: +-- +-- [@query@] standard query DSL (filter the @hits@ layer). +-- [@aggs@] sub-aggregations on each @geotile_grid@ / +-- @geohex_grid@ cell (names cannot start with +-- @_mvt_@). +-- [@sort@] hit ordering (@_score@, @_doc@, +-- @_geo_distance@, @_script@). +-- [@fields@] fields to return in the @hits@ layer. +-- [@runtime_mappings@] runtime field definitions. +-- [@size@] max @hits@ features (0–10000; @0@ omits the +-- layer). +-- [@track_total_hits@] accurate hit counting. +-- +-- The MVT-specific extras (@buffer@, @extent@, @grid_agg@, +-- @grid_precision@, @grid_type@, @exact_bounds@, @with_labels@) have +-- no home on the 'Search' record; configure them via 'VectorTileOptions' +-- so they ride as URI parameters. +searchVectorTileWith :: + IndexName -> + FieldName -> + TileZoom -> + TileX -> + TileY -> + VectorTileOptions -> + Search -> + BHRequest StatusDependant L.ByteString +searchVectorTileWith indexName (FieldName field) (TileZoom zoom) (TileX x) (TileY y) opts search = + getByteStringWithBody + (endpoint `withQueries` vectorTileOptionsParams opts) + (encode search) + where + endpoint = + [ unIndexName indexName, + "_mvt", + field, + showText zoom, + showText x, + showText y + ] + +-- | 'analyzeText' runs the analysis pipeline on the supplied text +-- without indexing it. Maps to @POST /_analyze@ when the index is +-- 'Nothing', or @POST \/{index}\/_analyze@ when an 'IndexName' is +-- supplied (the analyzer configuration of that index is then +-- available for reference by name in 'analyzeRequestAnalyzer', +-- 'analyzeRequestField', etc.). +-- +-- The 'AnalyzeRequest' only references analyzers, tokenizers, filters +-- and normalizers by name; inline analyzer definitions and the +-- @explain@ response variant are not supported by this function. +-- +-- See +-- +-- and +-- . +analyzeText :: + Maybe IndexName -> + AnalyzeRequest -> + BHRequest StatusDependant AnalyzeResponse +analyzeText mIndex req = + post @StatusDependant endpoint (encode req) + where + endpoint = + case mIndex of + Nothing -> ["_analyze"] + Just indexName -> [unIndexName indexName, "_analyze"] + +reindex :: + ReindexRequest -> + BHRequest StatusDependant ReindexResponse +reindex = reindexWith defaultReindexOptions + +-- | Like 'reindex' but accepts 'ReindexOptions' carrying the URI-level +-- parameters documented at +-- . +-- 'defaultReindexOptions' makes this byte-for-byte equivalent to +-- 'reindex'. +reindexWith :: + ReindexOptions -> + ReindexRequest -> + BHRequest StatusDependant ReindexResponse +reindexWith opts req = + post endpoint (encode req) + where + endpoint = ["_reindex"] `withQueries` reindexOptionsParams opts + +reindexAsync :: + ReindexRequest -> + BHRequest StatusDependant TaskNodeId +reindexAsync = reindexAsyncWith defaultReindexOptions + +-- | Like 'reindexAsync' but accepts 'ReindexOptions' carrying the +-- URI-level parameters documented at +-- . +-- 'defaultReindexOptions' makes this byte-for-byte equivalent to +-- 'reindexAsync'. @wait_for_completion=false@ is always appended +-- (overriding any value the caller might supply via a future option), +-- because this entry point is defined to return immediately with the +-- 'TaskNodeId' of the background task — synchronous callers should use +-- 'reindexWith' instead. +reindexAsyncWith :: + ReindexOptions -> + ReindexRequest -> + BHRequest StatusDependant TaskNodeId +reindexAsyncWith opts req = + post endpoint (encode req) + where + endpoint = + ["_reindex"] + `withQueries` ( reindexOptionsParams opts + <> [("wait_for_completion", Just "false")] + ) + +-- | 'rethrottleReindex' changes the maximum documents-per-second rate +-- of an in-progress asynchronous reindex. Maps to +-- @POST /_reindex/{task_id}/_rethrottle?requests_per_second=@. The +-- 'TaskNodeId' is the composite @nodeId:localId@ identifier returned by +-- 'reindexAsync' or observed via 'listTasks' \/ 'getTask'. +-- +-- The response uses the same nodes-grouped shape as 'cancelTask' +-- (a 'TaskListResponse' listing the task(s) whose rate was changed), +-- /not/ an 'Acknowledged' — the ES wire format is a task list even +-- though the operation is conceptually an acknowledgement. An empty +-- node list typically means the task had already finished by the time +-- the request reached the server. +-- +-- Rethrottling that speeds the reindex up takes effect immediately; +-- rethrottling that slows it down takes effect after the current +-- batch completes (to prevent scroll timeouts). +-- +-- See +-- . +rethrottleReindex :: + TaskNodeId -> + RethrottleRate -> + BHRequest StatusDependant TaskListResponse +rethrottleReindex (TaskNodeId task) rate = + post endpoint emptyBody + where + endpoint = + ["_reindex", task, "_rethrottle"] + `withQueries` [("requests_per_second", Just (renderRethrottleRate rate))] + +-- | Legacy 'getTask'; equivalent to @'getTaskWith' 'defaultTaskGetOptions'@. +getTask :: + (FromJSON a) => + TaskNodeId -> + BHRequest StatusDependant (TaskResponse a) +getTask = getTaskWith defaultTaskGetOptions + +-- | 'getTask' with explicit URI parameters. Maps to +-- @GET /_tasks/{task_id}@. Pass 'defaultTaskGetOptions' to reproduce +-- the legacy parameterless behaviour; populate the fields to send +-- @wait_for_completion@ (block until the task finishes) or @timeout@ +-- (how long to wait). +-- +-- See +-- +-- and +-- . +getTaskWith :: + (FromJSON a) => + TaskGetOptions -> + TaskNodeId -> + BHRequest StatusDependant (TaskResponse a) +getTaskWith opts (TaskNodeId task) = + get $ ["_tasks", task] `withQueries` taskGetOptionsParams opts + +-- | Render the 'TaskGetOptions' URI parameters (@wait_for_completion@, +-- @timeout@) as a list of @(key, value)@ pairs suitable for +-- 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultTaskGetOptions' produces an empty list (and therefore no +-- query string). +taskGetOptionsParams :: TaskGetOptions -> [(Text, Maybe Text)] +taskGetOptionsParams opts = + catMaybes + [ ("wait_for_completion",) . Just . renderBool <$> taskGetOptionsWaitForCompletion opts, + ("timeout",) . Just . renderDuration <$> taskGetOptionsTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +-- | 'cancelTask' cancels a currently running task by id. Maps to +-- @POST /_tasks/{task_id}/_cancel@. The response uses the same +-- nodes-grouped shape as 'listTasks' — it lists the tasks that were +-- actually cancelled — so this builder returns a 'TaskListResponse', +-- which may be empty if the task had already finished by the time the +-- request reached the server. The 'TaskNodeId' is the composite +-- @nodeId:localId@ identifier returned by +-- 'Database.Bloodhound.Common.Client.reindexAsync' or observed via +-- 'listTasks' or 'getTask'. +-- +-- See +-- . +cancelTask :: + TaskNodeId -> + BHRequest StatusDependant TaskListResponse +cancelTask (TaskNodeId task) = + post ["_tasks", task, "_cancel"] emptyBody + +-- | 'listTasks' lists currently running tasks on the cluster. Maps to +-- @GET /_tasks@. Pass 'Nothing' to call the bare endpoint, or +-- @'Just' 'defaultTaskListOptions'@ to reproduce it with explicit +-- parameters; pass a populated 'TaskListOptions' to filter by node, +-- action, parent task, etc. or to request @detailed@ task bodies. +-- +-- The structured 'TaskListResponse' preserves the node grouping of the +-- server's default @group_by=nodes@; flatten it with 'taskListFlat'. +-- +-- See +-- . +listTasks :: + Maybe TaskListOptions -> + BHRequest StatusDependant TaskListResponse +listTasks opts = + get $ ["_tasks"] `withQueries` taskListOptionsParams (fromMaybe defaultTaskListOptions opts) + +-- | Render the 'TaskListOptions' URI parameters (@nodes@, @actions@, +-- @detailed@, @parent_task_id@, @wait_for_completion@, @timeout@, +-- @group_by@) as a list of @(key, value)@ pairs suitable for +-- 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultTaskListOptions' produces an empty list (and therefore no +-- query string). +taskListOptionsParams :: TaskListOptions -> [(Text, Maybe Text)] +taskListOptionsParams opts = + catMaybes + [ ("nodes",) . Just . T.intercalate "," <$> taskListOptionsNodes opts, + ("actions",) . Just . T.intercalate "," <$> taskListOptionsActions opts, + ("detailed",) . Just . renderBool <$> taskListOptionsDetailed opts, + ("parent_task_id",) . Just <$> taskListOptionsParentTaskId opts, + ("wait_for_completion",) . Just . renderBool <$> taskListOptionsWaitForCompletion opts, + ("timeout",) . Just . renderDuration <$> taskListOptionsTimeout opts, + ("group_by",) . Just . renderTaskListGroupBy <$> taskListOptionsGroupBy opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +-- $asyncSearch +-- +-- /Async Search/ submits a long-running search to the background and +-- returns an identifier that can be polled for partial or final results. +-- Available since Elasticsearch 7.7, so the request lives in the Common +-- layer and is re-exported by every client module. (OpenSearch does not +-- implement this API; calls against OS will fail at runtime with a 404.) + +-- | 'getAsyncSearch' retrieves the current state and (partial or final) +-- results of an async search. Maps to @GET /_async_search/{id}@. +-- +-- While the search is running, 'asyncSearchIsRunning' is 'True' and the +-- search-result fields (@asyncSearchHits@, @asyncSearchTook@, ...) are +-- 'Nothing'; once complete, they are populated. +-- +-- See +-- . +getAsyncSearch :: + (FromJSON a) => + AsyncSearchId -> + BHRequest StatusDependant (AsyncSearchResult a) +getAsyncSearch (AsyncSearchId searchId) = + get ["_async_search", searchId] + +-- | 'getAsyncSearchStatus' reports only the running\/partial state and +-- scheduling times for an async search — /not/ the partial or final +-- results. Maps to @GET /_async_search/status/{id}@ and returns the +-- narrower 'AsyncSearchStatus' shape (no @hits@, @aggregations@, ...). +-- +-- Useful when polling for completion without paying the cost of +-- materialising the result set on each call. +-- +-- See +-- . +getAsyncSearchStatus :: + AsyncSearchId -> + BHRequest StatusDependant AsyncSearchStatus +getAsyncSearchStatus (AsyncSearchId searchId) = + get ["_async_search", "status", searchId] + +-- $ilm +-- +-- /Index Lifecycle Management/ is the Elasticsearch-native rollover\/shrink\/ +-- delete automation (unrelated to OpenSearch's ISM plugin). Available on +-- Elasticsearch 7.x and later, so the request lives in the Common layer and +-- is re-exported by every ES client module. + +-- | 'getILMPolicy' lists ILM policies. +-- +-- * @'Nothing'@ → @GET /_ilm/policy@ returns every policy on the cluster. +-- * @'Just' pid@ → @GET /_ilm/policy/{pid}@ returns just that one (as a +-- singleton list). +-- +-- The response is a JSON object keyed by policy id, so the body decoder +-- walks the keys and folds each one into the corresponding 'ILMPolicyInfo'. +-- +-- See +-- . +getILMPolicy :: + Maybe ILMPolicyId -> + BHRequest StatusDependant [ILMPolicyInfo] +getILMPolicy mPolicyId = + unILMPolicies <$> get @StatusDependant endpoint + where + endpoint = case mPolicyId of + Nothing -> ["_ilm", "policy"] + Just (ILMPolicyId pid) -> ["_ilm", "policy", pid] + +-- | 'putILMPolicy' creates or updates a single ILM policy by id. Maps to +-- @PUT /_ilm/policy/{id}@. The 'ILMPolicy' body wraps the policy proper +-- (phases, actions, ...) under the @policy@ key that ES expects; see its +-- 'ToJSON' instance. +-- +-- See +-- . +putILMPolicy :: + ILMPolicyId -> + ILMPolicy -> + BHRequest StatusDependant Acknowledged +putILMPolicy (ILMPolicyId pid) policy = + put ["_ilm", "policy", pid] (encode policy) + +-- | 'deleteILMPolicy' deletes a single ILM policy by id. Maps to +-- @DELETE /_ilm/policy/{id}@ and returns 'Acknowledged' on success. +-- Deleting a policy that does not exist fails with an HTTP error +-- (hence 'StatusDependant'), surfaced as an 'EsError'. The wire +-- format is identical across ES 7.x, 8.x and 9.x, so the request +-- builder lives in the Common layer and is re-exported by every ES +-- client module. +-- +-- See +-- . +deleteILMPolicy :: + ILMPolicyId -> + BHRequest StatusDependant Acknowledged +deleteILMPolicy (ILMPolicyId pid) = + delete ["_ilm", "policy", pid] + +-- | 'explainILM' retrieves the ILM state for every index matched by the +-- given 'IndexName' (which may be a wildcard or a comma-separated list). +-- Maps to @GET /_ilm/explain/{index}@. The response is keyed by the +-- concrete matched index names; this function returns the bare +-- ['ILMExplanation'] (each of which carries its own 'ilmExplanationIndex'). +-- +-- Equivalent to @'explainILMWith' 'defaultILMExplainOptions'@. See +-- . +explainILM :: + IndexName -> + BHRequest StatusDependant ILMExplanations +explainILM = explainILMWith defaultILMExplainOptions + +-- | Like 'explainILM' but accepts the full 'ILMExplainOptions' record, +-- exposing the @only_errors@, @only_managed@ and @master_timeout@ URI +-- parameters. 'defaultILMExplainOptions' makes this byte-for-byte +-- equivalent to 'explainILM'. +explainILMWith :: + ILMExplainOptions -> + IndexName -> + BHRequest StatusDependant ILMExplanations +explainILMWith opts indexName = + get endpoint + where + endpoint = + ["_ilm", "explain", unIndexName indexName] + `withQueries` ilmExplainOptionsParams opts + +-- | Render the 'ILMExplainOptions' URI parameters (@only_errors@, +-- @only_managed@, @master_timeout@) as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultILMExplainOptions' produces an empty list (and therefore no +-- query string). +ilmExplainOptionsParams :: ILMExplainOptions -> [(Text, Maybe Text)] +ilmExplainOptionsParams opts = + catMaybes + [ ("only_errors",) . Just . renderBool <$> ilmeoOnlyErrors opts, + ("only_managed",) . Just . renderBool <$> ilmeoOnlyManaged opts, + ("master_timeout",) . Just . renderDuration <$> ilmeoMasterTimeout opts + ] + where + renderBool True = "true" + renderBool False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +-- -------------------------------------------------------------------------- +-- ILM control (start/stop/status/move/retry/remove) +------------------------------------------------------------------------------ + +-- | 'startILM' starts the ILM plugin. Maps to @POST /_ilm/start@ and +-- returns 'Acknowledged' on success. ILM runs by default, so this is +-- only needed to resume after a 'stopILM'. +-- +-- See +-- . +startILM :: BHRequest StatusDependant Acknowledged +startILM = post ["_ilm", "start"] emptyBody + +-- | 'stopILM' stops the ILM plugin. Maps to @POST /_ilm/stop@ and +-- returns 'Acknowledged' on success. While stopped, ILM will not manage +-- any indices; use 'startILM' to resume. +-- +-- See +-- . +stopILM :: BHRequest StatusDependant Acknowledged +stopILM = post ["_ilm", "stop"] emptyBody + +-- | 'getILMStatus' reports the cluster-wide ILM operation mode. +-- Maps to @GET /_ilm/status@. +-- +-- See +-- . +getILMStatus :: BHRequest StatusDependant ILMStatus +getILMStatus = get ["_ilm", "status"] + +-- | 'moveILMStep' forces the given index from one lifecycle step into +-- another. Maps to @POST /_ilm/move/{index}@. Both the @current_step@ +-- and @next_step@ of the 'MoveStepRequest' body must match steps the +-- index could legally reach; ES rejects moves across unrelated branches. +-- Returns 'Acknowledged' on success. +-- +-- See +-- . +moveILMStep :: + IndexName -> + MoveStepRequest -> + BHRequest StatusDependant Acknowledged +moveILMStep indexName body = + post ["_ilm", "move", unIndexName indexName] (encode body) + +-- | 'retryILMStep' retries the current ILM step for an index that has +-- entered an error state. Maps to @POST /_ilm/retry/{index}@ and +-- returns 'Acknowledged' on success. +-- +-- See +-- . +retryILMStep :: + IndexName -> + BHRequest StatusDependant Acknowledged +retryILMStep indexName = + post ["_ilm", "retry", unIndexName indexName] emptyBody + +-- | 'removeILM' detaches the given index from ILM management. Maps to +-- @POST /_ilm/remove/{index}@ and returns 'Acknowledged' on success. +-- The index keeps its current state but ILM stops driving it. +-- +-- See +-- . +removeILM :: + IndexName -> + BHRequest StatusDependant Acknowledged +removeILM indexName = + post ["_ilm", "remove", unIndexName indexName] emptyBody + +-- | 'migrateDataTiers' migrates the cluster's allocation routing from the +-- legacy @node.attr.*@ style to the modern data-tier style +-- (@data_hot@ \/ @data_warm@ \/ ...). Maps to +-- @POST /_ilm/migrate_to_data_tiers@ and returns a +-- 'MigrateDataTiersResponse' describing what was migrated. +-- +-- Equivalent to +-- @'migrateDataTiersWith' 'defaultMigrateDataTiersOptions' 'defaultMigrateDataTiersRequest'@: +-- an empty body (auto-detected node attribute and legacy template) with +-- @dry_run@ unset. Use the @With@ variant to preview the migration +-- ('migrateDataTiersOptionsDryRun' = 'Just' 'True') or to override the +-- auto-detected values. +-- +-- Available on Elasticsearch 7.14 and later. The wire format is +-- identical across ES 7.14+, 8.x and 9.x, so the request builder lives +-- in the Common layer and is re-exported by every ES client module. +-- +-- See +-- . +migrateDataTiers :: + BHRequest StatusDependant MigrateDataTiersResponse +migrateDataTiers = + migrateDataTiersWith + defaultMigrateDataTiersOptions + defaultMigrateDataTiersRequest + +-- | 'migrateDataTiersWith' is the fully-parameterised form of +-- 'migrateDataTiers'. The 'MigrateDataTiersOptions' argument exposes the +-- @dry_run@ URI parameter; the 'MigrateDataTiersRequest' argument exposes +-- the optional @legacy_template_to_delete@ and @node_attribute@ body +-- fields. 'defaultMigrateDataTiersOptions' and +-- 'defaultMigrateDataTiersRequest' together reproduce 'migrateDataTiers'. +migrateDataTiersWith :: + MigrateDataTiersOptions -> + MigrateDataTiersRequest -> + BHRequest StatusDependant MigrateDataTiersResponse +migrateDataTiersWith opts body = + post @StatusDependant endpoint (encode body) + where + endpoint = + ["_ilm", "migrate_to_data_tiers"] + `withQueries` migrateDataTiersOptionsParams opts + +-- | Render the 'MigrateDataTiersOptions' URI parameters (@dry_run@) as a +-- list of @(key, value)@ pairs suitable for 'withQueries'. 'Nothing' +-- fields are omitted, so 'defaultMigrateDataTiersOptions' produces an +-- empty list (and therefore no query string). +migrateDataTiersOptionsParams :: MigrateDataTiersOptions -> [(Text, Maybe Text)] +migrateDataTiersOptionsParams opts = + catMaybes + [ ("dry_run",) . Just . renderBool <$> migrateDataTiersOptionsDryRun opts + ] + where + renderBool True = "true" + renderBool False = "false" + +-- -------------------------------------------------------------------------- +-- Snapshot Lifecycle Management (SLM) +------------------------------------------------------------------------------ + +-- $slm +-- +-- /Snapshot Lifecycle Management/ is the Elasticsearch-native automation +-- for taking periodic snapshots of cluster indices and applying retention +-- rules (unrelated to ILM, which rolls indices over\/shrinks\/deletes). +-- Available on Elasticsearch 7.4 and later, so every request lives in the +-- Common layer and is re-exported by every ES client module. The full +-- surface is covered: +-- +-- * @PUT /_slm/policy/{id}@ — create/update a policy ('putSLMPolicy'). +-- * @GET /_slm/policy[/{id}]@ — list one or all policies ('getSLMPolicy'). +-- * @DELETE /_slm/policy/{id}@ — delete a policy ('deleteSLMPolicy'). +-- * @POST /_slm/execute/{id}@ — run a policy out of schedule +-- ('executeSLMPolicy'). +-- * @GET /_slm/status@ — read the operation mode and snapshot counters +-- ('getSLMStatus'). +-- * @POST /_slm/stop@ — stop SLM scheduling ('stopSLM'). + +-- | 'putSLMPolicy' creates or updates a single snapshot lifecycle policy by +-- id. Maps to @PUT /_slm/policy/{id}@ and returns 'Acknowledged' on +-- success. Unlike 'putILMPolicy', the 'SLMPolicy' body is sent as-is at +-- the top level of the request — SLM does @not@ wrap the policy under a +-- @policy@ key, so callers must build the JSON object directly (see +-- "Database.Bloodhound.Internal.Versions.Common.Types.SLM" for an example). +-- +-- The wire format is identical across ES 7.x, 8.x and 9.x, so the request +-- builder lives in the Common layer and is re-exported by every ES client +-- module. +-- +-- See +-- . +putSLMPolicy :: + SLMPolicyId -> + SLMPolicy -> + BHRequest StatusDependant Acknowledged +putSLMPolicy (SLMPolicyId pid) policy = + put ["_slm", "policy", pid] (encode policy) + +-- | 'getSLMPolicy' lists SLM policies. +-- +-- * @'Nothing'@ → @GET /_slm/policy@ returns every policy on the cluster. +-- * @'Just' pid@ → @GET /_slm/policy/{pid}@ returns just that one (as a +-- singleton list). +-- +-- The response is a JSON object keyed by policy id, so the body decoder +-- walks the keys and folds each one into the corresponding +-- 'SLMPolicyInfo' (overriding the placeholder id set by the +-- 'SLMPolicyInfo' decoder). +-- +-- See +-- . +getSLMPolicy :: + Maybe SLMPolicyId -> + BHRequest StatusDependant [SLMPolicyInfo] +getSLMPolicy mPolicyId = + unSLMPolicies <$> get @StatusDependant endpoint + where + endpoint = case mPolicyId of + Nothing -> ["_slm", "policy"] + Just (SLMPolicyId pid) -> ["_slm", "policy", pid] + +-- | 'deleteSLMPolicy' deletes a single SLM policy by id. Maps to +-- @DELETE /_slm/policy/{id}@ and returns 'Acknowledged' on success. +-- Deleting a policy that does not exist fails with an HTTP error (hence +-- 'StatusDependant'), surfaced as an 'EsError'. +-- +-- See +-- . +deleteSLMPolicy :: + SLMPolicyId -> + BHRequest StatusDependant Acknowledged +deleteSLMPolicy (SLMPolicyId pid) = + delete ["_slm", "policy", pid] + +-- | 'executeSLMPolicy' triggers a single SLM policy immediately, outside +-- of its schedule. Maps to @POST /_slm/execute/{id}@ and returns the +-- 'SnapshotName' of the newly-created snapshot on success. +-- +-- See +-- . +executeSLMPolicy :: + SLMPolicyId -> + BHRequest StatusDependant SnapshotName +executeSLMPolicy (SLMPolicyId pid) = + slmExecutionSnapshot + <$> post @StatusDependant ["_slm", "execute", pid] emptyBody + +-- | 'getSLMStatus' reports the cluster-wide SLM operation mode +-- ('SLMOperationMode') alongside the cumulative snapshot creation and +-- deletion counters. Maps to @GET /_slm/status@. +-- +-- See +-- . +getSLMStatus :: + BHRequest StatusDependant SLMStatus +getSLMStatus = get ["_slm", "status"] + +-- | 'stopSLM' stops all SLM scheduling. Maps to @POST /_slm/stop@ and +-- returns 'Acknowledged' on success. In-flight snapshot executions are +-- allowed to finish; no new snapshots will be scheduled until SLM is +-- restarted (via the corresponding 'startSLM', or the next cluster +-- restart). +-- +-- See +-- . +stopSLM :: BHRequest StatusDependant Acknowledged +stopSLM = post ["_slm", "stop"] emptyBody + +-- | 'startSLM' (re)starts SLM scheduling after a 'stopSLM' (or a managed +-- halt). Maps to @POST /_slm/start@ and returns 'Acknowledged' on +-- success. This is the inverse of 'stopSLM'. +-- +-- See +-- . +-- +-- @since 0.26.0.0 +startSLM :: BHRequest StatusDependant Acknowledged +startSLM = post ["_slm", "start"] emptyBody + +-- -------------------------------------------------------------------------- +-- Watcher +------------------------------------------------------------------------------ + +-- $watcher +-- +-- /Watcher/ is the Elasticsearch X-Pack alerting feature (Platinum or +-- Enterprise licence). A watch is a schedule + input + condition + actions +-- definition: Watcher evaluates the condition on the schedule and runs the +-- actions (email, webhook, index, logging, ...) when it holds. Available on +-- Elasticsearch 2.1+; the REST surface is identical across ES 7.x, 8.x and +-- 9.x (deprecated in 9.x but still present), so every request lives in the +-- Common layer and is re-exported by every ES client module. OpenSearch does +-- not implement Watcher, so calls against an OpenSearch cluster will fail at +-- runtime. The full surface is covered: +-- +-- * @PUT /_watcher/watch/{id}@ — create/update a watch ('putWatch'). +-- * @GET /_watcher/watch/{id}@ — retrieve a watch ('getWatch'). +-- * @DELETE /_watcher/watch/{id}@ — delete a watch ('deleteWatch'). +-- * @POST /_watcher/watch/{id}/_execute@ — dry-run a watch +-- ('executeWatch' / 'executeWatchWith'). +-- * @PUT /_watcher/watch/{id}/_ack@ — acknowledge a watch's actions +-- ('ackWatch'). +-- * @PUT /_watcher/watch/{id}/_activate@ — (re)activate a watch +-- ('activateWatch'). +-- * @PUT /_watcher/watch/{id}/_deactivate@ — pause a watch +-- ('deactivateWatch'). +-- * @GET /_watcher/_stats[/{metric}]@ — cluster-wide Watcher statistics +-- ('watcherStats' / 'watcherStatsWith'). +-- * @GET /_watcher/settings@ — read Watcher cluster settings +-- ('getWatcherSettings'). +-- * @PUT /_watcher/settings@ — update Watcher cluster settings +-- ('updateWatcherSettings'). +-- * @POST /_watcher/_start@ — start the Watcher service ('startWatcher'). +-- * @POST /_watcher/_stop@ — stop the Watcher service ('stopWatcher'). + +-- | 'putWatch' creates or updates a single watch by id. Maps to +-- @PUT /_watcher/watch/{id}@ and returns 'Acknowledged' on success. The +-- 'WatchBody' is carried as an opaque 'Data.Aeson.Value' — see +-- "Database.Bloodhound.Internal.Versions.Common.Types.Watcher" for the +-- rationale (the watch DSL is large and version-evolving). +-- +-- See +-- . +putWatch :: + WatchId -> + WatchBody -> + BHRequest StatusDependant Acknowledged +putWatch (WatchId wid) body = + put ["_watcher", "watch", wid] (encode body) + +-- | 'getWatch' retrieves a single watch by id. Maps to +-- @GET /_watcher/watch/{id}@ and returns the full 'Watch' (typed envelope +-- + opaque watch DSL). A missing watch surfaces as an 'EsError' (hence +-- 'StatusDependant'). +-- +-- Watcher has no list-all-watches endpoint; every GET is by id. +-- +-- See +-- . +getWatch :: WatchId -> BHRequest StatusDependant Watch +getWatch (WatchId wid) = get ["_watcher", "watch", wid] + +-- | 'deleteWatch' deletes a single watch by id. Maps to +-- @DELETE /_watcher/watch/{id}@ and returns 'Acknowledged' on success. +-- +-- See +-- . +deleteWatch :: WatchId -> BHRequest StatusDependant Acknowledged +deleteWatch (WatchId wid) = delete ["_watcher", "watch", wid] + +-- | 'executeWatch' dry-runs the stored watch with the given id. Maps to +-- @POST /_watcher/watch/{id}/_execute@ with no body and returns the +-- execution record on success. Equivalent to +-- @'executeWatchWith' 'defaultExecuteWatchOptions' wid 'Nothing'@. +-- +-- See +-- . +executeWatch :: + WatchId -> + BHRequest StatusDependant ExecuteWatchResponse +executeWatch wid = executeWatchWith defaultExecuteWatchOptions wid Nothing + +-- | 'executeWatchWith' is the fully-parameterised form of 'executeWatch'. +-- Every URI parameter accepted by @POST /_watcher/watch/{id}/_execute@ is +-- exposed via 'ExecuteWatchOptions'; supplying a 'Just' 'ExecuteWatchRequest' +-- body runs an inline watch instead of the stored one. +executeWatchWith :: + ExecuteWatchOptions -> + WatchId -> + Maybe ExecuteWatchRequest -> + BHRequest StatusDependant ExecuteWatchResponse +executeWatchWith opts (WatchId wid) mBody = + post endpoint body + where + endpoint = + ["_watcher", "watch", wid, "_execute"] + `withQueries` executeWatchOptionsParams opts + body = maybe emptyBody (encode . unExecuteWatchRequest) mBody + +-- | 'ackWatch' acknowledges the actions of a watch by id. Maps to +-- @PUT /_watcher/watch/{id}/_ack@ and returns the watch's updated +-- acknowledge state. +-- +-- See +-- . +ackWatch :: WatchId -> BHRequest StatusDependant AckWatchResponse +ackWatch (WatchId wid) = put ["_watcher", "watch", wid, "_ack"] emptyBody + +-- | 'activateWatch' (re)activates a watch by id. Maps to +-- @PUT /_watcher/watch/{id}/_activate@ and returns the watch's updated +-- state. +-- +-- See +-- . +activateWatch :: WatchId -> BHRequest StatusDependant WatchStateResponse +activateWatch (WatchId wid) = + put ["_watcher", "watch", wid, "_activate"] emptyBody + +-- | 'deactivateWatch' pauses a watch by id. Maps to +-- @PUT /_watcher/watch/{id}/_deactivate@ and returns the watch's updated +-- state. +-- +-- See +-- . +deactivateWatch :: + WatchId -> + BHRequest StatusDependant WatchStateResponse +deactivateWatch (WatchId wid) = + put ["_watcher", "watch", wid, "_deactivate"] emptyBody + +-- | 'watcherStats' reports cluster-wide Watcher statistics. Maps to +-- @GET /_watcher/_stats@ (every metric). Equivalent to +-- @'watcherStatsWith' 'Nothing'@. +-- +-- See +-- . +watcherStats :: BHRequest StatusDependant WatcherStatsResponse +watcherStats = watcherStatsWith Nothing + +-- | 'watcherStatsWith' is the fully-parameterised form of 'watcherStats'. +-- Supplying 'Just' a 'WatcherStatsMetric' narrows the response to that +-- metric; 'Nothing' (or 'Just' 'WatcherStatsMetricAll') requests every +-- metric. +watcherStatsWith :: + Maybe WatcherStatsMetric -> + BHRequest StatusDependant WatcherStatsResponse +watcherStatsWith Nothing = get ["_watcher", "_stats"] +watcherStatsWith (Just metric) = + get ["_watcher", "_stats", watcherStatsMetricPath metric] + +-- | 'getWatcherSettings' reads the cluster-wide Watcher settings. Maps to +-- @GET /_watcher/settings@. +-- +-- See +-- . +getWatcherSettings :: + BHRequest StatusDependant WatcherSettings +getWatcherSettings = get ["_watcher", "settings"] + +-- | 'updateWatcherSettings' updates the cluster-wide Watcher settings. +-- Maps to @PUT /_watcher/settings@ and returns 'Acknowledged' on success. +-- The 'WatcherSettings' body shape is the standard persistent\/transient +-- cluster-settings envelope. +-- +-- See +-- . +updateWatcherSettings :: + WatcherSettings -> + BHRequest StatusDependant Acknowledged +updateWatcherSettings body = + put ["_watcher", "settings"] (encode body) + +-- | 'startWatcher' starts the Watcher service cluster-wide. Maps to +-- @POST /_watcher/_start@ and returns 'Acknowledged' on success. This is +-- the inverse of 'stopWatcher'. +-- +-- See +-- . +startWatcher :: BHRequest StatusDependant Acknowledged +startWatcher = post ["_watcher", "_start"] emptyBody + +-- | 'stopWatcher' stops the Watcher service cluster-wide. Maps to +-- @POST /_watcher/_stop@ and returns 'Acknowledged' on success. In-flight +-- watch executions are allowed to finish; no new watches will fire until +-- the service is restarted (via 'startWatcher'). +-- +-- See +-- . +stopWatcher :: BHRequest StatusDependant Acknowledged +stopWatcher = post ["_watcher", "_stop"] emptyBody + +------------------------------------------------------------------------------ +-- Text structure API +-- +-- /Text structure/ is the Elasticsearch text-classification surface +-- (@/_text_structure/*@) that inspects a sample of plain-text, NDJSON or +-- stored field values and infers its format, charset, delimiter, column +-- names, suggested ES mappings and ingest pipeline, and per-field stats. +-- The REST surface is identical across ES 7.17, 8.x and 9.x (it shipped +-- under the X-Pack flag on older 7.x and is part of the basic / free +-- license tier on 7.17+), so every request lives in the Common layer +-- and is re-exported by every ES client module. OpenSearch does not +-- implement these endpoints. +-- + +-- * @POST /_text_structure/find_structure@ — 'findStructure' / + +-- 'findStructureWith' (raw text body). +-- + +-- * @POST /_text_structure/find_message_structure@ — + +-- 'findMessageStructure' / 'findMessageStructureWith' (JSON +-- @{"messages":[...]}@ body). +-- + +-- * @GET /_text_structure/find_field_structure@ — + +-- 'findFieldStructure' / 'findFieldStructureWith' (no body; @index@ +-- and @field@ select the stored values to sample). +-- + +-- * @POST /_text_structure/test_grok_pattern@ — 'testGrokPattern' / + +-- 'testGrokPatternWith' (JSON body; compiles a grok pattern and +-- matches it against the supplied strings). + +-- | 'findStructure' inspects a sample of plain-text or NDJSON data and +-- returns the structure the server inferred (format, charset, +-- delimiter, suggested ES mappings, etc.). Maps to +-- @POST /_text_structure/find_structure@. +-- +-- The /request body/ is the raw sample (a lazy 'L.ByteString'), not +-- JSON — it is forwarded verbatim, so callers should hand the function +-- an NDJSON or plain-text stream directly. The /response/ is JSON and +-- is decoded into 'FindStructureResponse'. +-- +-- Equivalent to @'findStructureWith' 'defaultFindStructureOptions'@. +-- +-- See +-- . +findStructure :: + L.ByteString -> + BHRequest StatusDependant FindStructureResponse +findStructure = findStructureWith defaultFindStructureOptions + +-- | 'findStructureWith' is the fully-parameterised form of +-- 'findStructure'. Every URI parameter accepted by +-- @POST /_text_structure/find_structure@ is exposed via +-- 'FindStructureOptions'. +findStructureWith :: + FindStructureOptions -> + L.ByteString -> + BHRequest StatusDependant FindStructureResponse +findStructureWith opts sample = + post @StatusDependant endpoint sample + where + endpoint = + ["_text_structure", "find_structure"] + `withQueries` findStructureOptionsParams opts + +-- | 'findMessageStructure' classifies an explicit list of log messages +-- and returns the inferred structure. Maps to +-- @POST /_text_structure/find_message_structure@. Unlike +-- 'findStructure', the request body is JSON (@{"messages":[...]}@, +-- modelled by 'FindMessageStructureRequest'); the response reuses +-- 'FindStructureResponse'. +-- +-- Equivalent to @'findMessageStructureWith' +-- 'defaultFindMessageStructureOptions'@. +-- +-- See +-- . +findMessageStructure :: + FindMessageStructureRequest -> + BHRequest StatusDependant FindStructureResponse +findMessageStructure = + findMessageStructureWith defaultFindMessageStructureOptions + +-- | 'findMessageStructureWith' is the fully-parameterised form of +-- 'findMessageStructure'. Every URI parameter accepted by +-- @POST /_text_structure/find_message_structure@ is exposed via +-- 'FindMessageStructureOptions' (the message-classifier subset of the +-- 'FindStructureOptions' overrides). +findMessageStructureWith :: + FindMessageStructureOptions -> + FindMessageStructureRequest -> + BHRequest StatusDependant FindStructureResponse +findMessageStructureWith opts req = + post @StatusDependant endpoint (encode req) + where + endpoint = + ["_text_structure", "find_message_structure"] + `withQueries` findMessageStructureOptionsParams opts + +-- | 'findFieldStructure' samples the stored values of a field in an +-- existing index and returns the inferred structure of that field's +-- contents. Maps to @GET /_text_structure/find_field_structure@. There +-- is no request body: the @index@ and @field@ to sample are supplied as +-- URI parameters. The response reuses 'FindStructureResponse'. +-- +-- This convenience sets every classifier override to its default; use +-- 'findFieldStructureWith' to pass @documents_to_sample@, format +-- overrides, @explain@, @timeout@, etc. +-- +-- See +-- . +findFieldStructure :: + Text -> + Text -> + BHRequest StatusDependant FindStructureResponse +findFieldStructure index field = + findFieldStructureWith + defaultFindFieldStructureOptions + { ffsoIndex = Just index, + ffsoField = Just field + } + +-- | 'findFieldStructureWith' is the fully-parameterised form of +-- 'findFieldStructure'. 'FindFieldStructureOptions' carries the +-- required @index@ \/ @field@ selectors plus the same classifier +-- overrides as the other text-structure endpoints. +findFieldStructureWith :: + FindFieldStructureOptions -> + BHRequest StatusDependant FindStructureResponse +findFieldStructureWith opts = + get @StatusDependant endpoint + where + endpoint = + ["_text_structure", "find_field_structure"] + `withQueries` findFieldStructureOptionsParams opts + +-- | 'testGrokPattern' compiles a grok pattern and matches it against +-- the supplied strings, returning the per-input match descriptors. +-- Maps to @POST /_text_structure/test_grok_pattern@. The request body +-- is 'TestGrokPatternRequest' (@grok_pattern@ + @text@ array); the +-- response is 'TestGrokPatternResponse' (@matches@ array). +-- +-- Equivalent to @'testGrokPatternWith' +-- 'defaultTestGrokPatternOptions'@. +-- +-- See +-- . +testGrokPattern :: + TestGrokPatternRequest -> + BHRequest StatusDependant TestGrokPatternResponse +testGrokPattern = testGrokPatternWith defaultTestGrokPatternOptions + +-- | 'testGrokPatternWith' is the fully-parameterised form of +-- 'testGrokPattern'. 'TestGrokPatternOptions' carries the +-- @ecs_compatibility@ URI parameter (@disabled@ or @v1@), which selects +-- the Elastic Common Schema grok pattern set the server prepends to the +-- caller's pattern. +testGrokPatternWith :: + TestGrokPatternOptions -> + TestGrokPatternRequest -> + BHRequest StatusDependant TestGrokPatternResponse +testGrokPatternWith opts req = + post @StatusDependant endpoint (encode req) + where + endpoint = + ["_text_structure", "test_grok_pattern"] + `withQueries` testGrokPatternOptionsParams opts + +------------------------------------------------------------------------------ +-- Transform API +-- +-- /Transform/ is the Elasticsearch X-Pack feature that continuously or on a +-- schedule materialises a destination index from a pivot (aggregation) or a +-- latest-selection over one or more source indices. Available on +-- Elasticsearch 7.x\/8.x\/9.x (basic licence since 7.2), so every request +-- lives in the Common layer and is re-exported by every ES client module. +-- OpenSearch ships a /different/ transform plugin under +-- @\/_plugins\/_transform\/*@; calls against an OpenSearch cluster using +-- these endpoints will fail at runtime. The full surface is covered: +-- + +-- * @PUT /_transform/{transform_id}@ — 'putTransform' \/ 'putTransformWith' + +-- * @POST /_transform/{transform_id}/_update@ — 'updateTransform' \/ 'updateTransformWith' + +-- * @GET /_transform[/{transform_id}]@ — 'getTransforms' \/ 'getTransformsWith' + +-- * @DELETE /_transform/{transform_id}@ — 'deleteTransform' \/ 'deleteTransformWith' + +-- * @POST /_transform/{transform_id}/_start@ — 'startTransform' \/ 'startTransformWith' + +-- * @POST /_transform/{transform_id}/_stop@ — 'stopTransform' \/ 'stopTransformWith' + +-- * @POST /_transform/_preview@ — 'previewTransform' \/ 'previewTransformWith' + +-- * @GET /_transform/_stats[/{transform_id}]@ — 'getTransformStats' \/ 'getTransformStatsWith' + +-- * @GET /_transform/{transform_id}/_explain@ — 'explainTransform' + +-- | 'putTransform' creates a transform. Maps to +-- @PUT /_transform/{transform_id}@ with 'defaultPutTransformOptions' and +-- returns 'PutTransformResponse' on success. The 'TransformConfig' body +-- carries the source, destination and either the @pivot@ or @latest@ +-- selection. Use 'putTransformWith' to forward the @defer_validation@ or +-- @timeout@ query parameters. +-- +-- See +-- . +putTransform :: + TransformId -> + TransformConfig -> + BHRequest StatusDependant PutTransformResponse +putTransform tid config = + putTransformWith tid config defaultPutTransformOptions + +-- | Like 'putTransform' but accepts 'PutTransformOptions' carrying the +-- documented @defer_validation@ and @timeout@ query parameters. +-- +-- See +-- . +putTransformWith :: + TransformId -> + TransformConfig -> + PutTransformOptions -> + BHRequest StatusDependant PutTransformResponse +putTransformWith (TransformId tid) config opts = + put + (["_transform", tid] `withQueries` putTransformOptionsParams opts) + (encode config) + +-- | 'updateTransform' updates an existing transform. Maps to +-- @POST /_transform/{transform_id}/_update@ with +-- 'defaultUpdateTransformOptions' and returns 'Acknowledged' on success. +-- Use 'updateTransformWith' to forward the @defer_validation@ query +-- parameter. +-- +-- See +-- . +updateTransform :: + TransformId -> + TransformConfig -> + BHRequest StatusDependant Acknowledged +updateTransform tid config = + updateTransformWith tid config defaultUpdateTransformOptions + +-- | Like 'updateTransform' but accepts 'UpdateTransformOptions' carrying +-- the documented @defer_validation@ query parameter. +-- +-- See +-- . +updateTransformWith :: + TransformId -> + TransformConfig -> + UpdateTransformOptions -> + BHRequest StatusDependant Acknowledged +updateTransformWith (TransformId tid) config opts = + post + (["_transform", tid, "_update"] `withQueries` updateTransformOptionsParams opts) + (encode config) + +-- | 'getTransforms' lists transforms. +-- +-- * @'Nothing'@ → @GET /_transform@ returns every transform on the cluster. +-- * @'Just' tid@ → @GET /_transform/{tid}@ returns just that one (as a +-- single-element @transforms@ array). +-- +-- Equivalent to @'getTransformsWith' mId 'defaultGetTransformsOptions'@. +-- +-- See +-- . +getTransforms :: + Maybe TransformId -> + BHRequest StatusDependant TransformsResponse +getTransforms = (`getTransformsWith` defaultGetTransformsOptions) + +-- | Like 'getTransforms' but accepts 'GetTransformsOptions' carrying the +-- documented @from@, @size@, @allow_no_match@ and @exclude_generated@ +-- query parameters. +-- +-- See +-- . +getTransformsWith :: + Maybe TransformId -> + GetTransformsOptions -> + BHRequest StatusDependant TransformsResponse +getTransformsWith mTid opts = + get (path `withQueries` getTransformsOptionsParams opts) + where + path = case mTid of + Nothing -> ["_transform"] + Just (TransformId tid) -> ["_transform", tid] + +-- | 'deleteTransform' deletes a transform by id. Maps to +-- @DELETE /_transform/{transform_id}@ with +-- 'defaultDeleteTransformOptions' and returns 'DeleteTransformResponse' +-- on success. Use 'deleteTransformWith' to forward the @force@ or (ES 8+) +-- @delete_dest_index@ query parameters. +-- +-- See +-- . +deleteTransform :: + TransformId -> + BHRequest StatusDependant DeleteTransformResponse +deleteTransform = (`deleteTransformWith` defaultDeleteTransformOptions) + +-- | Like 'deleteTransform' but accepts 'DeleteTransformOptions' carrying +-- the documented @force@ and @delete_dest_index@ query parameters. +-- +-- See +-- . +deleteTransformWith :: + TransformId -> + DeleteTransformOptions -> + BHRequest StatusDependant DeleteTransformResponse +deleteTransformWith (TransformId tid) opts = + delete + (["_transform", tid] `withQueries` deleteTransformOptionsParams opts) + +-- | 'startTransform' starts a transform. Maps to +-- @POST /_transform/{transform_id}/_start@ with +-- 'defaultStartTransformOptions' and returns 'Acknowledged' on success. +-- Use 'startTransformWith' to forward the @defer_validation@ or @timeout@ +-- query parameters. +-- +-- See +-- . +startTransform :: + TransformId -> + BHRequest StatusDependant Acknowledged +startTransform = (`startTransformWith` defaultStartTransformOptions) + +-- | Like 'startTransform' but accepts 'StartTransformOptions' carrying +-- the documented @defer_validation@ and @timeout@ query parameters. +-- +-- See +-- . +startTransformWith :: + TransformId -> + StartTransformOptions -> + BHRequest StatusDependant Acknowledged +startTransformWith (TransformId tid) opts = + post + (["_transform", tid, "_start"] `withQueries` startTransformOptionsParams opts) + emptyBody + +-- | 'stopTransform' stops a transform. Maps to +-- @POST /_transform/{transform_id}/_stop@ with +-- 'defaultStopTransformOptions' and returns 'StopTransformResponse' on +-- success. Use 'stopTransformWith' to forward the @wait_for_checkpoint@, +-- @wait_for_completion@, @timeout@ or @allow_no_match@ query parameters. +-- +-- See +-- . +stopTransform :: + TransformId -> + BHRequest StatusDependant StopTransformResponse +stopTransform = (`stopTransformWith` defaultStopTransformOptions) + +-- | Like 'stopTransform' but accepts 'StopTransformOptions' carrying the +-- documented @wait_for_checkpoint@, @wait_for_completion@, @timeout@ and +-- @allow_no_match@ query parameters. +-- +-- See +-- . +stopTransformWith :: + TransformId -> + StopTransformOptions -> + BHRequest StatusDependant StopTransformResponse +stopTransformWith (TransformId tid) opts = + post + (["_transform", tid, "_stop"] `withQueries` stopTransformOptionsParams opts) + emptyBody + +-- | 'previewTransform' previews a transform configuration. Maps to +-- @POST /_transform/_preview@ with 'defaultPreviewTransformOptions' and +-- returns 'PreviewTransformResponse' on success. The 'TransformConfig' +-- body is the configuration to preview (it need not yet exist on the +-- cluster). Use 'previewTransformWith' to forward the @timeout@ query +-- parameter. +-- +-- See +-- . +previewTransform :: + TransformConfig -> + BHRequest StatusDependant PreviewTransformResponse +previewTransform = (`previewTransformWith` defaultPreviewTransformOptions) + +-- | Like 'previewTransform' but accepts 'PreviewTransformOptions' carrying +-- the documented @timeout@ query parameter. +-- +-- See +-- . +previewTransformWith :: + TransformConfig -> + PreviewTransformOptions -> + BHRequest StatusDependant PreviewTransformResponse +previewTransformWith config opts = + post + (["_transform", "_preview"] `withQueries` previewTransformOptionsParams opts) + (encode config) + +-- | 'getTransformStats' reports execution statistics for transforms. +-- +-- * @'Nothing'@ → @GET /_transform/_stats@ returns stats for every transform. +-- * @'Just' tid@ → @GET /_transform/{tid}/_stats@ returns stats for one. +-- +-- Equivalent to @'getTransformStatsWith' mId 'defaultGetTransformStatsOptions'@. +-- +-- See +-- . +getTransformStats :: + Maybe TransformId -> + BHRequest StatusDependant TransformStatsResponse +getTransformStats = (`getTransformStatsWith` defaultGetTransformStatsOptions) + +-- | Like 'getTransformStats' but accepts 'GetTransformStatsOptions' +-- carrying the documented @from@, @size@ and @allow_no_match@ query +-- parameters. +-- +-- See +-- . +getTransformStatsWith :: + Maybe TransformId -> + GetTransformStatsOptions -> + BHRequest StatusDependant TransformStatsResponse +getTransformStatsWith mTid opts = + get (path `withQueries` getTransformStatsOptionsParams opts) + where + path = case mTid of + Nothing -> ["_transform", "_stats"] + Just (TransformId tid) -> ["_transform", tid, "_stats"] + +-- | 'explainTransform' explains the state of a transform. Maps to +-- @GET /_transform/{transform_id}/_explain@ and returns +-- 'TransformExplainResponse'. The explain payload is highly +-- version-dependent, so each entry carries the transform @id@ plus an +-- extras catch-all for the @state@\/@checkpointing@ sub-objects. +-- +-- See +-- . +explainTransform :: + TransformId -> + BHRequest StatusDependant TransformExplainResponse +explainTransform (TransformId tid) = + get ["_transform", tid, "_explain"] + +-- -------------------------------------------------------------------------- +-- Migration +------------------------------------------------------------------------------ + +-- $migration +-- +-- /Migration Assistance/ is the Elasticsearch-native tooling for planning +-- and executing major-version upgrades. Available on Elasticsearch 6.1 +-- and later (deprecations) / 7.16 and later (system_features), so every +-- request lives in the Common layer and is re-exported by every ES +-- client module. The full surface is covered: +-- +-- * @GET /_migration/deprecations@ (and @GET /{index}/_migration/deprecations@) +-- — list deprecations affecting the next upgrade ('getMigrationDeprecations'). +-- * @GET /_migration/system_features@ — check feature upgrade status +-- ('getSystemFeatures'). +-- * @POST /_migration/system_features@ — trigger the feature upgrade +-- ('upgradeSystemFeatures'). + +-- | 'getMigrationDeprecations' lists the deprecation warnings that would +-- affect a major-version upgrade. +-- +-- * @'Nothing'@ → @GET /_migration/deprecations@ scans every index, +-- data stream, template, ILM policy and cluster\/node\/ML setting. +-- * @'Just' ix@ → @GET /{ix}/_migration/deprecations@ restricts the +-- @index_settings@ section to the supplied index (or index pattern). +-- +-- The wire format is identical across ES 7.x, 8.x and 9.x, so the +-- request builder lives in the Common layer and is re-exported by every +-- ES client module. +-- +-- See +-- . +getMigrationDeprecations :: + Maybe IndexName -> + BHRequest StatusDependant MigrationDeprecations +getMigrationDeprecations mIndex = + get endpoint + where + endpoint = case mIndex of + Nothing -> ["_migration", "deprecations"] + Just ix -> [unIndexName ix, "_migration", "deprecations"] + +-- | 'getSystemFeatures' reports the migration status of every ES +-- feature that stores versioned configuration (async_search, enrich, +-- fleet, machine_learning, security, ...). Maps to +-- @GET /_migration/system_features@. +-- +-- See +-- . +getSystemFeatures :: + BHRequest StatusDependant FeatureUpgradeStatus +getSystemFeatures = get ["_migration", "system_features"] + +-- | 'upgradeSystemFeatures' kicks off the feature upgrade. Maps to +-- @POST /_migration/system_features@ and returns 'Acknowledged' on +-- success. The upgrade runs in the background; poll +-- 'getSystemFeatures' to observe progress. Mutates cluster state — +-- call deliberately. +-- +-- See +-- . +upgradeSystemFeatures :: BHRequest StatusDependant Acknowledged +upgradeSystemFeatures = post ["_migration", "system_features"] emptyBody + +-- -------------------------------------------------------------------------- +-- Ingest Pipelines +------------------------------------------------------------------------------ + +-- $ingest +-- +-- /Ingest pipelines/ parse, enrich and transform documents before they +-- are indexed (a chain of @processors@: @grok@, @set@, @uppercase@, +-- @script@, ...). Available on Elasticsearch 5.0 and later, and on every +-- OpenSearch version, so the request builders live in the Common layer +-- and are re-exported by every client module. +-- +-- The surface covered: +-- +-- * @PUT /_ingest/pipeline/{id}@ — create/update a pipeline ('putIngestPipeline'). +-- * @GET /_ingest/pipeline[/{id}]@ — list one or all pipelines ('getIngestPipeline'). +-- * @DELETE /_ingest/pipeline/{id}@ — delete a pipeline ('deleteIngestPipeline'). +-- * @POST /_ingest/pipeline[/{id}]/_simulate@ — simulate a pipeline +-- ('simulateIngestPipeline'). +-- * @GET /_ingest/processor/grok@ — list built-in grok patterns +-- ('getGrokPatterns'). + +-- | 'putIngestPipeline' creates or updates a single ingest pipeline by id. +-- Maps to @PUT /_ingest/pipeline/{id}@ and returns 'Acknowledged' on +-- success. The 'IngestPipeline' body is sent as-is at the top level of the +-- request — ingest, unlike ILM, does @not@ wrap the pipeline under a +-- @pipeline@ key (the same shape SLM uses). +-- +-- The wire format is identical across ES 7.x, 8.x, 9.x and OS 1.x, 2.x, +-- 3.x, so the request builder lives in the Common layer and is +-- re-exported by every client module. +-- +-- See +-- +-- and +-- . +putIngestPipeline :: + PipelineId -> + IngestPipeline -> + BHRequest StatusDependant Acknowledged +putIngestPipeline (PipelineId pid) pipeline = + put ["_ingest", "pipeline", pid] (encode pipeline) + +-- | 'getIngestPipeline' lists ingest pipelines. +-- +-- * @'Nothing'@ → @GET /_ingest/pipeline@ returns every pipeline on the cluster. +-- * @'Just' pid@ → @GET /_ingest/pipeline/{pid}@ returns just that one (as a +-- singleton list). +-- +-- The response is a JSON object keyed by pipeline id, so the body decoder +-- walks the keys and folds each one into the corresponding +-- 'IngestPipelineInfo' (overriding the placeholder id set by its own +-- 'FromJSON' instance — the same trick 'getILMPolicy' uses). +-- +-- /Empty-cluster handling:/ OpenSearch (and a fresh Elasticsearch +-- cluster with no built-in pipelines) responds to the list-all form +-- with HTTP 404 and an empty @{}@ body when no pipelines exist, +-- rather than a 200 with @{}@. The parser for the @'Nothing'@ branch +-- treats such a 404 as an empty list so callers see a uniform @Right +-- []@; the @'Just' pid@ branch still surfaces 404 as 'EsError' (an +-- unknown id is genuinely an error there). +-- +-- See +-- +-- and +-- . +getIngestPipeline :: + Maybe PipelineId -> + BHRequest StatusDependant [IngestPipelineInfo] +getIngestPipeline mPipelineId = baseReq {bhRequestParser = parser} + where + baseReq = unIngestPipelines <$> get @StatusDependant endpoint + endpoint = case mPipelineId of + Nothing -> ["_ingest", "pipeline"] + Just (PipelineId pid) -> ["_ingest", "pipeline", pid] + parser resp + | isNothing mPipelineId && statusCodeIs (404, 404) resp = + case decode (responseBody (getResponse resp)) of + Just ips -> Right (Right (unIngestPipelines ips)) + Nothing -> bhRequestParser baseReq resp + | otherwise = bhRequestParser baseReq resp + +-- | 'deleteIngestPipeline' deletes a single ingest pipeline by id. Maps to +-- @DELETE /_ingest/pipeline/{id}@ and returns 'Acknowledged' on success. +-- Deleting a pipeline that does not exist fails with an HTTP error (hence +-- 'StatusDependant'), surfaced as an 'EsError'. +-- +-- See +-- +-- and +-- . +deleteIngestPipeline :: + PipelineId -> + BHRequest StatusDependant Acknowledged +deleteIngestPipeline (PipelineId pid) = + delete ["_ingest", "pipeline", pid] + +-- | 'simulateIngestPipeline' runs the supplied documents through an ingest +-- pipeline without indexing anything, returning the per-document +-- transformed results. Maps to @POST /_ingest/pipeline[\/{id}]\/_simulate@. +-- +-- The first argument is the pipeline id: +-- +-- * @'Nothing'@ → @POST /_ingest/pipeline/_simulate@ runs the supplied +-- 'IngestPipeline' body. +-- * @'Just' pid@ → @POST /_ingest/pipeline/{pid}/_simulate@ runs the +-- pipeline /stored/ at @pid@; the supplied 'IngestPipeline' argument is +-- serialized into the request body's @pipeline@ field but Elasticsearch +-- /ignores/ it in favor of the stored pipeline. To simulate an inline +-- pipeline body, pass 'Nothing' for the first argument. +-- +-- The public API forces the caller to supply an 'IngestPipeline' (per the +-- bead spec) even though it is functionally ignored when a 'Just pid' is +-- given. This is deliberate (the bead locks the signature) and tracked as +-- a follow-up: a @simulateIngestPipelineById :: MonadBH m => PipelineId -> +-- [Value] -> m SimulateResult@ variant would not need a body argument at +-- all. +-- +-- See +-- +-- and +-- . +simulateIngestPipeline :: + Maybe PipelineId -> + IngestPipeline -> + [Value] -> + BHRequest StatusDependant SimulateResult +simulateIngestPipeline mPipelineId pipeline docs = + post @StatusDependant endpoint (encode body) + where + endpoint = case mPipelineId of + Nothing -> ["_ingest", "pipeline", "_simulate"] + Just (PipelineId pid) -> ["_ingest", "pipeline", pid, "_simulate"] + body = SimulateIngestPipelineRequest (Just pipeline) docs + +-- | 'getGrokPatterns' lists the built-in grok patterns shipped with the +-- grok ingest processor. Maps to @GET /_ingest/processor/grok@ and +-- returns a 'GrokPatterns' (a flat map from pattern name to its grok +-- definition). Useful for inspecting the patterns your +-- @grok@-processor pipelines may reference. +-- +-- The endpoint also accepts the optional @ecs_compatibility@ and @s@ +-- (sort) query parameters; selecting ECS-compatible patterns and +-- sorting the response by key respectively. They are not yet exposed +-- here — tracked as a follow-up. +-- +-- See +-- . +getGrokPatterns :: + BHRequest StatusDependant GrokPatterns +getGrokPatterns = get ["_ingest", "processor", "grok"] + +-- -------------------------------------------------------------------------- +-- Async Search +----------------------------------------------------------------------------- + +-- | 'deleteAsyncSearch' deletes an async search result and its context by id. +-- Maps to @DELETE /_async_search/{id}@ and returns 'Acknowledged' on success. +-- +-- Available on Elasticsearch 7.7 and later, so the request lives in the +-- Common layer and is re-exported by every ES client module. +-- +-- See +-- . +deleteAsyncSearch :: + AsyncSearchId -> + BHRequest StatusIndependant Acknowledged +deleteAsyncSearch (AsyncSearchId i) = + delete ["_async_search", i] + +-- | 'submitAsyncSearch' submits a 'Search' for asynchronous execution. +-- Maps to @POST /_async_search@ and returns immediately with an id and +-- partial results (see 'AsyncSearchResult'). Poll the returned id with +-- @GET /_async_search/{id}@ until 'asyncSearchIsRunning' is @False@. +-- +-- Equivalent to @'submitAsyncSearchWith' 'defaultAsyncSearchSubmitOptions'@ +-- — it forwards no URI parameters, matching the documented defaults +-- (@wait_for_completion=false@, @keep_on_completion=false@, +-- @keep_alive=5d@). +-- +-- Available on Elasticsearch 7.7 and later, so the request lives in the +-- Common layer and is re-exported by every ES client module. +-- +-- See +-- . +submitAsyncSearch :: + (FromJSON a) => + Search -> + BHRequest StatusDependant (AsyncSearchResult a) +submitAsyncSearch = submitAsyncSearchWith defaultAsyncSearchSubmitOptions + +-- | Like 'submitAsyncSearch' but accepts 'AsyncSearchSubmitOptions' +-- carrying the URI parameters documented for @POST /_async_search@: +-- @wait_for_completion@ (set @'Just' 'True'@ to block), +-- @keep_on_completion@ (set @'Just' 'True'@ to persist on completion), +-- @keep_alive@ (retention window, as a typed 'KeepAlive' value), +-- @batched_reduce_size@, and @ccs_minimize_roundtrips@. +-- 'defaultAsyncSearchSubmitOptions' makes this byte-for-byte equivalent +-- to 'submitAsyncSearch'. +-- +-- See +-- . +submitAsyncSearchWith :: + (FromJSON a) => + AsyncSearchSubmitOptions -> + Search -> + BHRequest StatusDependant (AsyncSearchResult a) +submitAsyncSearchWith opts search = + post (["_async_search"] `withQueries` asyncSearchSubmitOptionsParams opts) (encode search) + +------------------------------------------------------------------------------ +-- Enrich policy API +-- + +-- * @PUT /_enrich/policy/{policy_id}@ — 'putEnrichPolicy' + +-- * @DELETE /_enrich/policy/{policy_id}@ — 'deleteEnrichPolicy' + +-- * @GET /_enrich/policy[/{policy_id}]@ — 'getEnrichPolicy' + +-- * @POST /_enrich/policy/{policy_id}/_execute@ — 'executeEnrichPolicy' + +-- * @GET /_enrich/_execute_stats@ — 'getEnrichExecuteStats' + +-- * @GET /_enrich/policy/{policy_id}/_execute_stats@ — 'getEnrichPolicyExecuteStats' + +-- | 'putEnrichPolicy' creates or replaces an enrich policy by id. Maps to +-- @PUT /_enrich/policy/{policy_id}@ and returns 'Acknowledged' on +-- success. The 'EnrichPolicy' body is encoded verbatim — its top-level +-- object key is the policy type (@match@, @geo_match@, @range@) and its +-- value is the 'EnrichPolicyConfig'. +-- +-- Enrich is part of the free (basic) X-Pack tier and is available across +-- ES 7.x\/8.x\/9.x with the same wire surface, so the request lives in +-- the Common layer and is re-exported by every ES client module. +-- OpenSearch does not implement the enrich API. +-- +-- See +-- . +putEnrichPolicy :: + EnrichPolicyId -> + EnrichPolicy -> + BHRequest StatusDependant Acknowledged +putEnrichPolicy (EnrichPolicyId pid) policy = + put ["_enrich", "policy", pid] (encode policy) + +-- | 'getEnrichPolicy' lists enrich policies. +-- +-- * @'Nothing'@ → @GET /_enrich/policy@ returns every policy on the cluster. +-- * @'Just' pid@ → @GET /_enrich/policy/{pid}@ returns just that one (as +-- a singleton list inside the 'EnrichPoliciesResponse'). +-- +-- See +-- . +getEnrichPolicy :: + Maybe EnrichPolicyId -> + BHRequest StatusDependant EnrichPoliciesResponse +getEnrichPolicy mPolicyId = + get @StatusDependant endpoint + where + endpoint = case mPolicyId of + Nothing -> ["_enrich", "policy"] + Just (EnrichPolicyId pid) -> ["_enrich", "policy", pid] + +-- | 'deleteEnrichPolicy' deletes a single enrich policy by id. Maps to +-- @DELETE /_enrich/policy/{policy_id}@ and returns 'Acknowledged' on +-- success. +-- +-- See +-- . +deleteEnrichPolicy :: + EnrichPolicyId -> + BHRequest StatusDependant Acknowledged +deleteEnrichPolicy (EnrichPolicyId pid) = + delete ["_enrich", "policy", pid] + +-- | 'executeEnrichPolicy' triggers a synchronous execution of an enrich +-- policy — ES creates (or refreshes) the @.enrich-{policy_id}-{version}@ +-- follower index used by @enrich@ processor queries. Maps to +-- @POST /_enrich/policy/{policy_id}/_execute@ with +-- @wait_for_completion@ defaulted to @true@ by the server, returning +-- 'Acknowledged' on success. Use 'executeEnrichPolicyWith' to set +-- @wait_for_completion=false@ (the response then becomes a task handle, +-- which is outside the typed envelope and must be decoded separately). +-- +-- See +-- . +executeEnrichPolicy :: + EnrichPolicyId -> + BHRequest StatusDependant Acknowledged +executeEnrichPolicy pid = + executeEnrichPolicyWith pid defaultEnrichExecuteOptions + +-- | Like 'executeEnrichPolicy' but accepts 'EnrichExecuteOptions' carrying +-- the documented URI parameter @wait_for_completion@. +-- 'defaultEnrichExecuteOptions' makes this byte-for-byte equivalent to +-- 'executeEnrichPolicy'. +-- +-- See +-- . +executeEnrichPolicyWith :: + EnrichPolicyId -> + EnrichExecuteOptions -> + BHRequest StatusDependant Acknowledged +executeEnrichPolicyWith (EnrichPolicyId pid) opts = + post + (["_enrich", "policy", pid, "_execute"] `withQueries` enrichExecuteOptionsParams opts) + emptyBody + +-- | 'getEnrichExecuteStats' reports the executor pool and per-policy +-- execution statistics across the cluster. Maps to +-- @GET /_enrich/_execute_stats@. +-- +-- See +-- . +getEnrichExecuteStats :: + BHRequest StatusDependant EnrichExecuteStatsResponse +getEnrichExecuteStats = + get ["_enrich", "_execute_stats"] + +-- | 'getEnrichPolicyExecuteStats' reports the executor pool and execution +-- statistics for a single enrich policy. Maps to +-- @GET /_enrich/policy/{policy_id}/_execute_stats@ (the per-policy variant +-- added in ES 7.16). The response shape is identical to +-- 'getEnrichExecuteStats' but the @execute_stats@ array is filtered to +-- the requested policy. +-- +-- See +-- . +getEnrichPolicyExecuteStats :: + EnrichPolicyId -> + BHRequest StatusDependant EnrichExecuteStatsResponse +getEnrichPolicyExecuteStats (EnrichPolicyId pid) = + get ["_enrich", "policy", pid, "_execute_stats"] + +------------------------------------------------------------------------------ +-- Autoscaling API +-- +-- The autoscaling endpoints live in the X-Pack tier and are designed for +-- indirect use by cloud orchestrators (Elasticsearch Service, ECE, ECK). +-- They share the ES 7.x\/8.x\/9.x wire surface, so the requests live in the +-- Common layer alongside SLM\/Enrich. Endpoint reference (see +-- "Database.Bloodhound.Internal.Versions.Common.Types.Autoscaling" for the +-- request/response shapes): + +-- * @PUT /_autoscaling/policy/{name}@ — 'putAutoscalingPolicy' + +-- * @GET /_autoscaling/policy/{name}@ — 'getAutoscalingPolicy' + +-- * @DELETE /_autoscaling/policy/{name}@ — 'deleteAutoscalingPolicy' + +-- * @GET /_autoscaling/capacity@ — 'getAutoscalingCapacity' + +-- | 'putAutoscalingPolicy' creates or replaces an autoscaling policy by name. +-- Maps to @PUT /_autoscaling/policy/{name}@ and returns 'Acknowledged' on +-- success. The 'AutoscalingPolicy' body is encoded verbatim — its top level +-- is a @roles@ array and a @deciders@ object. +-- +-- Autoscaling is part of the X-Pack tier and is available across ES +-- 7.x\/8.x\/9.x with the same wire surface, so the request lives in the Common +-- layer and is re-exported by every ES client module. OpenSearch does not +-- implement the autoscaling API. +-- +-- See +-- . +putAutoscalingPolicy :: + AutoscalingPolicyName -> + AutoscalingPolicy -> + BHRequest StatusDependant Acknowledged +putAutoscalingPolicy (AutoscalingPolicyName name) policy = + put ["_autoscaling", "policy", name] (encode policy) + +-- | 'getAutoscalingPolicy' retrieves a single autoscaling policy by name. +-- Maps to @GET /_autoscaling/policy/{name}@ and returns the bare +-- 'AutoscalingPolicy' body (ES returns @roles@ and @deciders@ directly, +-- without an envelope). +-- +-- See +-- . +getAutoscalingPolicy :: + AutoscalingPolicyName -> + BHRequest StatusDependant AutoscalingPolicy +getAutoscalingPolicy (AutoscalingPolicyName name) = + get ["_autoscaling", "policy", name] + +-- | 'deleteAutoscalingPolicy' deletes a single autoscaling policy by name. +-- Maps to @DELETE /_autoscaling/policy/{name}@ and returns 'Acknowledged' on +-- success. +-- +-- See +-- . +deleteAutoscalingPolicy :: + AutoscalingPolicyName -> + BHRequest StatusDependant Acknowledged +deleteAutoscalingPolicy (AutoscalingPolicyName name) = + delete ["_autoscaling", "policy", name] + +-- | 'getAutoscalingCapacity' reports the current autoscaling capacity for +-- every configured policy — the storage\/memory ES says each tier needs +-- versus what it currently has, plus the nodes and per-decider results used +-- to derive it. Maps to @GET /_autoscaling/capacity@. +-- +-- See +-- . +getAutoscalingCapacity :: + BHRequest StatusDependant AutoscalingCapacity +getAutoscalingCapacity = + get ["_autoscaling", "capacity"] + +------------------------------------------------------------------------------ +-- Security API (/_security/*) +-- +-- X-Pack Security covers users, roles, role mappings and API keys. The +-- surface is shared across ES 7.x\/8.x\/9.x, so these live in the Common +-- layer (OpenSearch implements security via a separate plugin at +-- @/_plugins/_security@, not covered here). Privileges and OIDC/SAML tokens +-- are tracked in follow-up beads. + +------------------------------------------------------------------------------ +-- Security — roles (/_security/role/*) + +-- | 'putRole' creates or replaces a role by name. Maps to +-- @PUT /_security/role/{name}@ and returns 'RoleCreatedResponse'. +putRole :: RoleName -> Role -> BHRequest StatusDependant RoleCreatedResponse +putRole (RoleName name) role = + put ["_security", "role", name] (encode role) + +-- | 'getRoles' lists every role on the cluster. Maps to +-- @GET /_security/role@. +getRoles :: BHRequest StatusDependant RolesListResponse +getRoles = get ["_security", "role"] + +-- | 'getRole' fetches a single role by name. Maps to +-- @GET /_security/role/{name}@; the response is a singleton +-- 'RolesListResponse' (empty if the role does not exist). +getRole :: RoleName -> BHRequest StatusDependant RolesListResponse +getRole (RoleName name) = get ["_security", "role", name] + +-- | 'deleteRole' deletes a role by name. Maps to +-- @DELETE /_security/role/{name}@. +deleteRole :: + RoleName -> BHRequest StatusDependant RoleDeletedResponse +deleteRole (RoleName name) = delete ["_security", "role", name] + +-- | 'clearRoleCache' evicts a role from the security cache. Maps to +-- @POST /_security/role/{name}/_clear_cache@. +clearRoleCache :: + RoleName -> BHRequest StatusDependant ClearRoleCacheResponse +clearRoleCache (RoleName name) = + post ["_security", "role", name, "_clear_cache"] emptyBody + +------------------------------------------------------------------------------ +-- Security — role mappings (/_security/role_mapping/*) + +-- | 'putRoleMapping' creates or replaces a role mapping. Maps to +-- @PUT /_security/role_mapping/{name}@. +putRoleMapping :: + RoleMappingName -> + RoleMapping -> + BHRequest StatusDependant Acknowledged +putRoleMapping (RoleMappingName name) rm = + put ["_security", "role_mapping", name] (encode rm) + +-- | 'getRoleMappings' lists every role mapping. +getRoleMappings :: + BHRequest StatusDependant RoleMappingsListResponse +getRoleMappings = get ["_security", "role_mapping"] + +-- | 'getRoleMapping' fetches a single role mapping by name. +getRoleMapping :: + RoleMappingName -> + BHRequest StatusDependant RoleMappingsListResponse +getRoleMapping (RoleMappingName name) = get ["_security", "role_mapping", name] + +-- | 'deleteRoleMapping' deletes a role mapping by name. +deleteRoleMapping :: RoleMappingName -> BHRequest StatusDependant Acknowledged +deleteRoleMapping (RoleMappingName name) = + delete ["_security", "role_mapping", name] + +------------------------------------------------------------------------------ +-- Security — users (/_security/user/*) + +-- | 'putUser' creates or updates a user. Maps to +-- @PUT /_security/user/{username}@ and returns 'UserCreatedResponse'. +putUser :: + UserName -> + UserCreateBody -> + BHRequest StatusDependant UserCreatedResponse +putUser (UserName username) body = + put ["_security", "user", username] (encode body) + +-- | 'getUsers' lists every user. Maps to @GET /_security/user@. +getUsers :: BHRequest StatusDependant UsersListResponse +getUsers = get ["_security", "user"] + +-- | 'getUser' fetches a single user by username. +getUser :: UserName -> BHRequest StatusDependant UsersListResponse +getUser (UserName username) = get ["_security", "user", username] + +-- | 'deleteUser' deletes a user by username. Maps to +-- @DELETE /_security/user/{username}@. +deleteUser :: + UserName -> BHRequest StatusDependant UserDeletedResponse +deleteUser (UserName username) = delete ["_security", "user", username] + +-- | 'enableUser' enables a user. Maps to +-- @PUT /_security/user/{username}/_enable@. +enableUser :: UserName -> BHRequest StatusDependant Acknowledged +enableUser (UserName username) = + put ["_security", "user", username, "_enable"] emptyBody + +-- | 'disableUser' disables a user. Maps to +-- @PUT /_security/user/{username}/_disable@. +disableUser :: UserName -> BHRequest StatusDependant Acknowledged +disableUser (UserName username) = + put ["_security", "user", username, "_disable"] emptyBody + +-- | 'changeUserPassword' changes a user's password. Maps to +-- @POST /_security/user/{username}/_password@. +changeUserPassword :: + UserName -> + ChangePasswordBody -> + BHRequest StatusDependant Acknowledged +changeUserPassword (UserName username) body = + post ["_security", "user", username, "_password"] (encode body) + +-- | 'userHasPrivileges' checks the privileges held by a named user. +-- Maps to @POST /_security/user/{username}/_has_privileges@. +userHasPrivileges :: + UserName -> + HasPrivilegesRequest -> + BHRequest StatusDependant HasPrivilegesResponse +userHasPrivileges (UserName username) req = + post ["_security", "user", username, "_has_privileges"] (encode req) + +-- | 'selfHasPrivileges' checks the privileges held by the current user. +-- Maps to @POST /_security/user/_has_privileges@. +selfHasPrivileges :: + HasPrivilegesRequest -> + BHRequest StatusDependant HasPrivilegesResponse +selfHasPrivileges req = + post ["_security", "user", "_has_privileges"] (encode req) + +-- | 'getUserPrivileges' lists the current user's effective privileges. +-- Maps to @GET /_security/user/_privileges@. +getUserPrivileges :: BHRequest StatusDependant UserPrivileges +getUserPrivileges = get ["_security", "user", "_privileges"] + +------------------------------------------------------------------------------ +-- Security — API keys (/_security/api_key) + +-- | 'createApiKey' mints a new API key. Maps to @POST /_security/api_key@. +createApiKey :: + CreateApiKeyRequest -> + BHRequest StatusDependant ApiKeyCreatedResponse +createApiKey req = post ["_security", "api_key"] (encode req) + +-- | 'grantApiKey' mints an API key on behalf of another principal. Maps +-- to @POST /_security/api_key/grant@. +grantApiKey :: + GrantApiKeyRequest -> + BHRequest StatusDependant ApiKeyCreatedResponse +grantApiKey req = post ["_security", "api_key", "grant"] (encode req) + +-- | 'getApiKey' retrieves API keys matching the filter. Maps to +-- @GET /_security/api_key@. The request is sent as a body (ES accepts a +-- GET body here), so this uses 'getWithBody'. +getApiKey :: + RetrieveApiKeyRequest -> + BHRequest StatusDependant ApiKeyRetrievalResponse +getApiKey req = getWithBody ["_security", "api_key"] (encode req) + +-- | 'invalidateApiKey' revokes API keys matching the filter. Maps to +-- @DELETE /_security/api_key@ with a body, so this uses 'deleteWithBody'. +invalidateApiKey :: + InvalidateApiKeyRequest -> + BHRequest StatusDependant InvalidateApiKeyResponse +invalidateApiKey req = + deleteWithBody ["_security", "api_key"] (encode req) + +-- | 'updateApiKey' updates a key's role descriptors and/or metadata. +-- Maps to @PUT /_security/api_key/{id}@. +updateApiKey :: + ApiKeyId -> + UpdateApiKeyRequest -> + BHRequest StatusDependant Acknowledged +updateApiKey (ApiKeyId apiKeyId) body = + put ["_security", "api_key", apiKeyId] (encode body) + +------------------------------------------------------------------------------ +-- Security — API key query (ES 7.16+ / 8.x: /_security/_query/api_key) + +-- | 'queryApiKey' lists API keys via the Query-DSL paginated endpoint. +-- Maps to @POST /_security/_query/api_key@. Unlike 'getApiKey' (a fixed +-- set of scalar filters on the ES 7.x surface), this endpoint accepts a +-- Query-DSL @query@ plus pagination \/ sort \/ aggregations and does not +-- exist on ES 7.x. +-- +-- See +-- . +queryApiKey :: + QueryApiKeyRequest -> + BHRequest StatusDependant QueryApiKeyResponse +queryApiKey req = post ["_security", "_query", "api_key"] (encode req) + +-- | Variant of 'queryApiKey' that also sets the @with_limited_by@, +-- @with_profile_uid@, and @typed_keys@ URI parameters. Calling with +-- 'defaultQueryApiKeyOptions' is byte-for-byte identical to 'queryApiKey'. +queryApiKeyWith :: + QueryApiKeyRequest -> + QueryApiKeyOptions -> + BHRequest StatusDependant QueryApiKeyResponse +queryApiKeyWith req opts = + post + (["_security", "_query", "api_key"] `withQueries` queryApiKeyOptionsParams opts) + (encode req) + +-- | URI parameters for 'queryApiKeyWith'. +data QueryApiKeyOptions = QueryApiKeyOptions + { qkoWithLimitedBy :: Maybe Bool, + qkoWithProfileUid :: Maybe Bool, + qkoTypedKeys :: Maybe Bool + } + +-- | All-'Nothing' options — produces no query string. +defaultQueryApiKeyOptions :: QueryApiKeyOptions +defaultQueryApiKeyOptions = + QueryApiKeyOptions + { qkoWithLimitedBy = Nothing, + qkoWithProfileUid = Nothing, + qkoTypedKeys = Nothing + } + +-- | Render 'QueryApiKeyOptions' as @(key, value)@ pairs for 'withQueries'. +queryApiKeyOptionsParams :: QueryApiKeyOptions -> [(Text, Maybe Text)] +queryApiKeyOptionsParams opts = + catMaybes + [ ("with_limited_by",) . Just . boolQP <$> qkoWithLimitedBy opts, + ("with_profile_uid",) . Just . boolQP <$> qkoWithProfileUid opts, + ("typed_keys",) . Just . boolQP <$> qkoTypedKeys opts + ] + +------------------------------------------------------------------------------ +-- Security — authentication (/_security/_authenticate) + +-- | 'authenticate' returns information about the credentials the request +-- was made with. Maps to @GET /_security/_authenticate@. When the request +-- carries an API key (@Authorization: ApiKey @), the response +-- describes that API key — this is how a caller validates a token (there +-- is no separate @/_security/api_key/_authenticate@ endpoint). +-- +-- See +-- . +authenticate :: BHRequest StatusDependant AuthenticateResponse +authenticate = get ["_security", "_authenticate"] + +-- | 'whoami' returns the identity of the current authenticated user +-- (ES 7.16+). Maps to @GET /_security/_whoami@. +-- +-- See +-- . +whoami :: BHRequest StatusDependant WhoAmIResponse +whoami = get ["_security", "_whoami"] + +-- | 'logout' logs out of a SAML/OIDC SSO token. Maps to +-- @POST /_security/_logout@ with the 'LogoutRequest' body (the SSO access +-- token to invalidate); 'loChanged' is @false@ when no token matched. +-- +-- See +-- . +logout :: + LogoutRequest -> + BHRequest StatusDependant LogoutResponse +logout req = + post ["_security", "_logout"] (encode req) + +------------------------------------------------------------------------------ +-- Security — service accounts (/_security/service/*) +-- +-- Service accounts are reserved principals (@/@, e.g. +-- @elastic/fleet-server@) authenticated by service tokens. The ES 7.17 +-- wire path is @/_security/service*@ with a @credential@ segment for +-- tokens. Service tokens never expire. + +-- | 'getServiceAccounts' lists every service account. Maps to +-- @GET /_security/service@. +getServiceAccounts :: + BHRequest StatusDependant ServiceAccountsListResponse +getServiceAccounts = get ["_security", "service"] + +-- | 'getServiceAccountsInNamespace' lists the service accounts in a +-- namespace. Maps to @GET /_security/service/{namespace}@. +getServiceAccountsInNamespace :: + ServiceAccountNamespace -> + BHRequest StatusDependant ServiceAccountsListResponse +getServiceAccountsInNamespace (ServiceAccountNamespace namespace) = + get ["_security", "service", namespace] + +-- | 'getServiceAccount' retrieves a single service account. Maps to +-- @GET /_security/service/{namespace}/{service}@. +getServiceAccount :: + ServiceAccountNamespace -> + ServiceAccountService -> + BHRequest StatusDependant ServiceAccountsListResponse +getServiceAccount + (ServiceAccountNamespace namespace) + (ServiceAccountService service) = + get ["_security", "service", namespace, service] + +-- | 'createServiceToken' creates a service account token. Maps to +-- @POST /_security/service/{namespace}/{service}/credential/token@ when +-- the token name is 'Nothing' (ES assigns a random name), or +-- @.../credential/token/{token_name}@ when it is 'Just'. The secret token +-- @value@ is returned exactly once in the response. +createServiceToken :: + ServiceAccountNamespace -> + ServiceAccountService -> + Maybe ServiceTokenName -> + BHRequest StatusDependant CreateServiceTokenResponse +createServiceToken + (ServiceAccountNamespace namespace) + (ServiceAccountService service) + maybeTokenName = + post endpoint emptyBody + where + endpoint = + case maybeTokenName of + Nothing -> ["_security", "service", namespace, service, "credential", "token"] + Just (ServiceTokenName tokenName) -> + ["_security", "service", namespace, service, "credential", "token", tokenName] + +-- | 'getServiceCredentials' lists the credentials (tokens) of a service +-- account. Maps to +-- @GET /_security/service/{namespace}/{service}/credential@. Secret token +-- values are not returned; only the index-backed @tokens@ names and the +-- file-backed @nodes_credentials@. +getServiceCredentials :: + ServiceAccountNamespace -> + ServiceAccountService -> + BHRequest StatusDependant GetServiceCredentialsResponse +getServiceCredentials + (ServiceAccountNamespace namespace) + (ServiceAccountService service) = + get ["_security", "service", namespace, service, "credential"] + +-- | 'deleteServiceToken' deletes a service account token. Maps to +-- @DELETE /_security/service/{namespace}/{service}/credential/token/{token_name}@. +-- A missing token yields 404 with @found=false@ (surfaced via +-- 'StatusDependant'). +deleteServiceToken :: + ServiceAccountNamespace -> + ServiceAccountService -> + ServiceTokenName -> + BHRequest StatusDependant ServiceTokenDeletedResponse +deleteServiceToken + (ServiceAccountNamespace namespace) + (ServiceAccountService service) + (ServiceTokenName tokenName) = + delete ["_security", "service", namespace, service, "credential", "token", tokenName] + +------------------------------------------------------------------------------ +-- Security — SSO / token (/_security/oauth2, /_security/oidc, /_security/saml) + +-- | 'getToken' mints an OAuth2 bearer token. Maps to +-- @POST /_security/oauth2/token@. The grant type (password, _kerberos, +-- client_credentials, refresh_token) selects which fields of the +-- 'GetTokenRequest' are consulted. +getToken :: + GetTokenRequest -> + BHRequest StatusDependant GetTokenResponse +getToken req = post ["_security", "oauth2", "token"] (encode req) + +-- | 'invalidateToken' revokes an access/refresh token (or every token +-- for a realm/user). Maps to @DELETE /_security/oauth2/token@ with a +-- body, so this uses 'deleteWithBody'. +invalidateToken :: + InvalidateTokenRequest -> + BHRequest StatusDependant InvalidateTokenResponse +invalidateToken req = + deleteWithBody ["_security", "oauth2", "token"] (encode req) + +-- | 'prepareSamlAuthentication' mints a SAML @@ redirect +-- URL. Maps to @POST /_security/saml/prepare@. The returned 'sppId' +-- must be echoed back via 'sarIds' at authenticate time. +prepareSamlAuthentication :: + SamlPrepareRequest -> + BHRequest StatusDependant SamlPrepareResponse +prepareSamlAuthentication req = + post ["_security", "saml", "prepare"] (encode req) + +-- | 'authenticateSaml' exchanges a SAML @@ for an ES access +-- and refresh token. Maps to @POST /_security/saml/authenticate@. +authenticateSaml :: + SamlAuthenticateRequest -> + BHRequest StatusDependant SsoTokenResponse +authenticateSaml req = + post ["_security", "saml", "authenticate"] (encode req) + +-- | 'logoutSaml' invalidates a SAML-issued token pair. Maps to +-- @POST /_security/saml/logout@. +logoutSaml :: + SamlLogoutRequest -> + BHRequest StatusDependant SsoRedirectResponse +logoutSaml req = + post ["_security", "saml", "logout"] (encode req) + +-- | 'prepareOidcAuthentication' mints an OpenID Connect authentication +-- request URL. Maps to @POST /_security/oidc/prepare@. The returned +-- state and nonce must be echoed back at authenticate time. +prepareOidcAuthentication :: + OidcPrepareRequest -> + BHRequest StatusDependant OidcPrepareResponse +prepareOidcAuthentication req = + post ["_security", "oidc", "prepare"] (encode req) + +-- | 'authenticateOidc' exchanges an OpenID Connect authentication +-- response for an ES access and refresh token. Maps to +-- @POST /_security/oidc/authenticate@. +authenticateOidc :: + OidcAuthenticateRequest -> + BHRequest StatusDependant SsoTokenResponse +authenticateOidc req = + post ["_security", "oidc", "authenticate"] (encode req) + +-- | 'logoutOidc' invalidates an OIDC-issued token pair. Maps to +-- @POST /_security/oidc/logout@. +logoutOidc :: + OidcLogoutRequest -> + BHRequest StatusDependant SsoRedirectResponse +logoutOidc req = + post ["_security", "oidc", "logout"] (encode req) + +------------------------------------------------------------------------------ +-- Security — application privileges (/_security/privilege/*) +-- +-- Application privileges /as definitions/: each privilege is identified by +-- an @@\/@@ pair and grants a list of @actions@ +-- (distinct from the role-binding application privilege, which references +-- privilege names + resources). The wire path is +-- @/_security/privilege/[/]@, with a trailing +-- @_clear_cache@ segment for cache eviction. ES echoes PUT/DELETE results +-- in a two-level @{app:{name:leaf}}@ envelope, projected to the leaf by +-- the response types below. + +-- | 'putPrivilege' creates or updates a single application privilege. Maps +-- to @PUT /_security/privilege/{application}/{privilege}@ with an +-- 'ApplicationPrivilegeDefinition' body. Returns 'PrivilegeCreatedResponse' +-- (@created@ is @false@ when an existing privilege was updated). +putPrivilege :: + ApplicationName -> + ApplicationPrivilegeName -> + ApplicationPrivilegeDefinition -> + BHRequest StatusDependant PrivilegeCreatedResponse +putPrivilege + (ApplicationName application) + (ApplicationPrivilegeName privilege) + definition = + put ["_security", "privilege", application, privilege] (encode definition) + +-- | 'getPrivileges' lists every application privilege. Maps to +-- @GET /_security/privilege@. +getPrivileges :: BHRequest StatusDependant PrivilegesListResponse +getPrivileges = get ["_security", "privilege"] + +-- | 'getPrivilegesInApplication' lists every privilege for one +-- application. Maps to @GET /_security/privilege/{application}@. +getPrivilegesInApplication :: + ApplicationName -> + BHRequest StatusDependant PrivilegesListResponse +getPrivilegesInApplication (ApplicationName application) = + get ["_security", "privilege", application] + +-- | 'getPrivilege' fetches a single privilege. Maps to +-- @GET /_security/privilege/{application}/{privilege}@; the response is a +-- singleton 'PrivilegesListResponse' (a 404 is surfaced via +-- 'StatusDependant' when the privilege is undefined). +getPrivilege :: + ApplicationName -> + ApplicationPrivilegeName -> + BHRequest StatusDependant PrivilegesListResponse +getPrivilege + (ApplicationName application) + (ApplicationPrivilegeName privilege) = + get ["_security", "privilege", application, privilege] + +-- | 'deletePrivilege' deletes a single application privilege. Maps to +-- @DELETE /_security/privilege/{application}/{privilege}@. +deletePrivilege :: + ApplicationName -> + ApplicationPrivilegeName -> + BHRequest StatusDependant PrivilegeDeletedResponse +deletePrivilege + (ApplicationName application) + (ApplicationPrivilegeName privilege) = + delete ["_security", "privilege", application, privilege] + +-- | 'clearPrivilegeCache' evicts application privileges from the native +-- privilege cache. Maps to +-- @POST /_security/privilege/{applications}/_clear_cache@ where +-- @applications@ is the comma-joined list of application names; pass +-- @"*"@ (via 'IsString') to clear every application. +clearPrivilegeCache :: + NonEmpty ApplicationName -> + BHRequest StatusDependant ClearPrivilegeCacheResponse +clearPrivilegeCache applications = + post ["_security", "privilege", applicationsSpec, "_clear_cache"] emptyBody + where + applicationsSpec = + T.intercalate "," (map unApplicationName (toList applications)) + +------------------------------------------------------------------------------ +-- Fleet API +-- +-- The Fleet endpoints are experimental and exist so Fleet Server can use +-- Elasticsearch as its data store. They share the ES 7.x\/8.x\/9.x wire +-- surface, so the requests live in the Common layer alongside SLM\/Enrich. +-- Endpoint reference (see +-- "Database.Bloodhound.Internal.Versions.Common.Types.Fleet" for the +-- request/response shapes): +-- + +-- * @GET /{index}/_fleet/global_checkpoints@ — 'getFleetGlobalCheckpoints' + +-- * @POST /{index}/_fleet/_fleet_search@ — 'fleetSearch' + +-- * @POST /{index}/_fleet/_fleet_msearch@ — 'fleetMultiSearch' + +-- | 'getFleetGlobalCheckpoints' returns the current global checkpoints for +-- a single index. Maps to @GET /{index}/_fleet/global_checkpoints@ with +-- 'defaultFleetGlobalCheckpointsOptions' (returns immediately). Use +-- 'getFleetGlobalCheckpointsWith' to poll until the checkpoints advance. +-- +-- See +-- . +getFleetGlobalCheckpoints :: + IndexName -> + BHRequest StatusDependant FleetGlobalCheckpointsResponse +getFleetGlobalCheckpoints indexName = + getFleetGlobalCheckpointsWith indexName defaultFleetGlobalCheckpointsOptions + +-- | Like 'getFleetGlobalCheckpoints' but accepts 'FleetGlobalCheckpointsOptions'. +-- Set 'fgcoWaitForAdvance' to poll until the checkpoints advance past +-- 'fgcoCheckpoints' (up to 'fgcoTimeout'). +-- +-- See +-- . +getFleetGlobalCheckpointsWith :: + IndexName -> + FleetGlobalCheckpointsOptions -> + BHRequest StatusDependant FleetGlobalCheckpointsResponse +getFleetGlobalCheckpointsWith indexName opts = + get + ( [unIndexName indexName, "_fleet", "global_checkpoints"] + `withQueries` fleetGlobalCheckpointsOptionsParams opts + ) + +-- | 'fleetSearch' runs a search against a single index that is only +-- executed once the supplied checkpoints are visible for search. Maps to +-- @POST /{index}/_fleet/_fleet_search@ with 'defaultFleetSearchOptions' +-- (no query parameters). The request body and response are the standard +-- 'Search' \/ 'SearchResult' shapes. The target index must resolve to a +-- single concrete index. +-- +-- See +-- . +fleetSearch :: + (FromJSON a) => + IndexName -> + Search -> + BHRequest StatusDependant (SearchResult a) +fleetSearch indexName = + fleetSearchWith indexName defaultFleetSearchOptions + +-- | Like 'fleetSearch' but accepts 'FleetSearchOptions' carrying the +-- documented URI parameters @wait_for_checkpoints@ and +-- @allow_partial_search_results@. 'defaultFleetSearchOptions' makes this +-- byte-for-byte equivalent to 'fleetSearch'. +-- +-- See +-- . +fleetSearchWith :: + (FromJSON a) => + IndexName -> + FleetSearchOptions -> + Search -> + BHRequest StatusDependant (SearchResult a) +fleetSearchWith indexName opts search = + post url' (encode search) + where + url' = + [unIndexName indexName, "_fleet", "_fleet_search"] + `withQueries` fleetSearchOptionsParams opts + +-- | 'fleetMultiSearch' runs several fleet searches in a single request, +-- following the same NDJSON body shape as @_msearch@. Maps to +-- @POST /{index}/_fleet/_fleet_msearch@ with 'defaultFleetSearchOptions'. +-- Each sub-request is a 'MultiSearchItem' (header + 'Search'); the index +-- pinned by the URL applies to every sub-request. +-- +-- See +-- . +fleetMultiSearch :: + (FromJSON a) => + IndexName -> + NonEmpty MultiSearchItem -> + BHRequest StatusDependant (MultiSearchResponse a) +fleetMultiSearch indexName = + fleetMultiSearchWith indexName defaultFleetSearchOptions + +-- | Like 'fleetMultiSearch' but accepts 'FleetSearchOptions' carrying the +-- documented URI parameters @wait_for_checkpoints@ and +-- @allow_partial_search_results@. +-- +-- See +-- . +fleetMultiSearchWith :: + (FromJSON a) => + IndexName -> + FleetSearchOptions -> + NonEmpty MultiSearchItem -> + BHRequest StatusDependant (MultiSearchResponse a) +fleetMultiSearchWith indexName opts items = + post url' (encodeMultiSearchItems items) + where + url' = + [unIndexName indexName, "_fleet", "_fleet_msearch"] + `withQueries` fleetSearchOptionsParams opts + +-- Repositories metering API +-- + +-- * @GET /_nodes/_repositories_metering@ — 'getRepositoriesMetering' + +-- (cluster-wide) + +-- * @GET /_nodes/{selection}/_repositories_metering@ — scoped to a + +-- 'NodeSelection' + +-- * @DELETE /_nodes/_repositories_metering@ — 'deleteRepositoriesMetering' + +-- (resets the metering counters, returns 'Acknowledged') + +-- * @DELETE /_nodes/{selection}/_repositories_metering@ — scoped + +-- | 'getRepositoriesMetering' reports the repository metering counters +-- (snapshot creation\/deletion throughput and counts) for each +-- cloud-backed repository on each node. Maps to +-- @GET /_nodes/_repositories_metering@ when @Nothing@, or +-- @GET /_nodes/{seg}/_repositories_metering@ scoped to a +-- 'NodeSelection' when @'Just'@ (the segment rendered by +-- 'nodeSelectionSeg': @_local@, @_all@, or a comma-joined selector list). +-- +-- * @'Nothing'@ → @GET /_nodes/_repositories_metering@ +-- * @'Just' 'LocalNode'@ → @GET /_nodes/_local/_repositories_metering@ +-- * @'Just' 'AllNodes'@ → @GET /_nodes/_all/_repositories_metering@ +-- * @'Just' ('NodeList' ...)@ → @GET /_nodes/{csv}/_repositories_metering@ +-- +-- Repositories metering is part of the free (basic) X-Pack tier and is +-- available across ES 7.x\/8.x\/9.x with the same wire surface, so the +-- request lives in the Common layer and is re-exported by every ES +-- client module. OpenSearch does not implement this API. +-- +-- See +-- . +getRepositoriesMetering :: + Maybe NodeSelection -> + BHRequest StatusDependant RepositoriesMeteringResponse +getRepositoriesMetering mSelection = + get @StatusDependant endpoint + where + endpoint = case mSelection of + Nothing -> ["_nodes", "_repositories_metering"] + Just sel -> ["_nodes", nodeSelectionSeg sel, "_repositories_metering"] + +-- | 'deleteRepositoriesMetering' resets the repository metering counters +-- to zero across the cluster (@'Nothing'@) or on a node selection +-- (@'Just'@). Maps to @DELETE /_nodes/_repositories_metering@ or +-- @DELETE /_nodes/{seg}/_repositories_metering@ and returns +-- 'Acknowledged' on success. +-- +-- * @'Nothing'@ → @DELETE /_nodes/_repositories_metering@ +-- * @'Just' 'LocalNode'@ → @DELETE /_nodes/_local/_repositories_metering@ +-- * @'Just' 'AllNodes'@ → @DELETE /_nodes/_all/_repositories_metering@ +-- * @'Just' ('NodeList' ...)@ → @DELETE /_nodes/{csv}/_repositories_metering@ +-- +-- See +-- . +deleteRepositoriesMetering :: + Maybe NodeSelection -> + BHRequest StatusDependant Acknowledged +deleteRepositoriesMetering mSelection = + delete endpoint + where + endpoint = case mSelection of + Nothing -> ["_nodes", "_repositories_metering"] + Just sel -> ["_nodes", nodeSelectionSeg sel, "_repositories_metering"] + +------------------------------------------------------------------------------ +-- Searchable snapshots API +-- + +-- * @POST /_snapshot/{repository}/{snapshot}/_mount@ — 'mountSearchableSnapshot' + +-- * @GET /_searchable_snapshots/stats@ — 'getSearchableSnapshotsStats' + +-- * @POST /_searchable_snapshots/{index}/_cache_stats@ — 'getSearchableSnapshotsCacheStats' + +-- * @POST /_searchable_snapshots/{index}/_clear_cache@ — 'clearSearchableSnapshotsCache' + +-- | 'mountSearchableSnapshot' mounts a snapshot as a searchable index. +-- Maps to @POST /_snapshot/{repository}/{snapshot}/_mount@ with the +-- default options (no query parameters). The 'SearchableSnapshotMount' +-- body names the mounted index (@index@) and may override +-- @renamed_index@, @index_settings@ and @ignore_index_settings@. The +-- response is a 'SearchableSnapshotMountResponse'; when +-- @wait_for_completion@ is @true@ (the default) it carries the full +-- snapshot-restore object under @snapshot@. +-- +-- Use 'mountSearchableSnapshotWith' to set @master_timeout@, +-- @wait_for_completion@ or @storage@. +-- +-- Searchable snapshots are part of the X-Pack tier and are available +-- across ES 7.x\/8.x\/9.x with the same wire surface, so the request +-- lives in the Common layer and is re-exported by every ES client +-- module. OpenSearch does not implement this API. +-- +-- See +-- . +mountSearchableSnapshot :: + SnapshotRepoName -> + SnapshotName -> + SearchableSnapshotMount -> + BHRequest StatusDependant SearchableSnapshotMountResponse +mountSearchableSnapshot repo snap body = + mountSearchableSnapshotWith repo snap body defaultSearchableSnapshotMountOptions + +-- | Like 'mountSearchableSnapshot' but accepts 'SearchableSnapshotMountOptions' +-- carrying the documented URI parameters @master_timeout@, +-- @wait_for_completion@ and @storage@. 'defaultSearchableSnapshotMountOptions' +-- makes this byte-for-byte equivalent to 'mountSearchableSnapshot'. +-- +-- See +-- . +mountSearchableSnapshotWith :: + SnapshotRepoName -> + SnapshotName -> + SearchableSnapshotMount -> + SearchableSnapshotMountOptions -> + BHRequest StatusDependant SearchableSnapshotMountResponse +mountSearchableSnapshotWith repo snap body opts = + post + (["_snapshot", snapshotRepoName repo, snapshotName snap, "_mount"] `withQueries` searchableSnapshotMountOptionsParams opts) + (encode body) + +-- | 'getSearchableSnapshotsStats' reports cluster-wide and per-index +-- (and per-node) statistics for searchable snapshots. Maps to +-- @GET /_searchable_snapshots/stats@. +-- +-- See +-- . +getSearchableSnapshotsStats :: + BHRequest StatusDependant SearchableSnapshotsStatsResponse +getSearchableSnapshotsStats = + get ["_searchable_snapshots", "stats"] + +-- | 'getSearchableSnapshotsCacheStats' reports cache statistics for a +-- single searchable-snapshot index. Maps to +-- @POST /_searchable_snapshots/{index}/_cache_stats@. +-- +-- See +-- . +getSearchableSnapshotsCacheStats :: + IndexName -> + BHRequest StatusDependant SearchableSnapshotsCacheStatsResponse +getSearchableSnapshotsCacheStats indexName = + post ["_searchable_snapshots", unIndexName indexName, "_cache_stats"] emptyBody + +-- | 'clearSearchableSnapshotsCache' evicts the node cache for a single +-- searchable-snapshot index. Maps to +-- @POST /_searchable_snapshots/{index}/_clear_cache@ and returns +-- 'Acknowledged' on success. +-- +-- See +-- . +clearSearchableSnapshotsCache :: + IndexName -> + BHRequest StatusDependant Acknowledged +clearSearchableSnapshotsCache indexName = + post ["_searchable_snapshots", unIndexName indexName, "_clear_cache"] emptyBody + +------------------------------------------------------------------------------ +-- Rollup API +-- +-- The rollup endpoints live in the X-Pack tier and share the +-- ES 7.x\/8.x\/9.x wire surface, so the requests live in the Common layer +-- alongside SLM\/Enrich. Endpoint reference (see +-- "Database.Bloodhound.Internal.Versions.Common.Types.Rollup" for the +-- request/response shapes): + +-- * @PUT /_rollup/job/{job_id}@ — 'putRollupJob' + +-- * @GET /_rollup/job[/{job_id}|_all]@ — 'getRollupJob' + +-- * @DELETE /_rollup/job/{job_id}@ — 'deleteRollupJob' + +-- * @POST /_rollup/job/{job_id}/_start@ — 'startRollupJob' + +-- * @POST /_rollup/job/{job_id}/_stop@ — 'stopRollupJob' / 'stopRollupJobWith' + +-- * @GET /_rollup/job[/{job_id}|_all]/_stats@ — 'getRollupJobStats' + +-- * @GET /_rollup/data/{index}@ — 'getRollupCapabilities' + +-- * @GET /{target}/_rollup/data@ — 'getRollupIndexCapabilities' + +-- * @GET /{index}/_rollup_search@ — 'rollupSearchByIndex' + +-- | 'putRollupJob' creates or replaces a rollup job by id. Maps to +-- @PUT /_rollup/job/{job_id}@ and returns 'Acknowledged' on success. The +-- 'RollupJobConfig' body is encoded verbatim. +-- +-- Rollup is part of the X-Pack tier and is available across ES +-- 7.x\/8.x\/9.x (deprecated in 8.x but still functional) with the same wire +-- surface, so the request lives in the Common layer and is re-exported by +-- every ES client module. OpenSearch does not implement the X-Pack rollup +-- API. +-- +-- See +-- . +putRollupJob :: + RollupJobId -> + RollupJobConfig -> + BHRequest StatusDependant Acknowledged +putRollupJob (RollupJobId jobId) config = + put ["_rollup", "job", jobId] (encode config) + +-- | 'getRollupJob' retrieves the configuration, status, and stats of +-- rollup jobs. +-- +-- * @'Nothing'@ → @GET /_rollup/job@ returns every job on the cluster. +-- * @'Just' jid@ → @GET /_rollup/job/{jid}@ returns just that one (as a +-- singleton list inside the 'GetRollupJobsResponse'). +-- +-- See +-- . +getRollupJob :: + Maybe RollupJobId -> + BHRequest StatusDependant GetRollupJobsResponse +getRollupJob mJobId = + get @StatusDependant endpoint + where + endpoint = case mJobId of + Nothing -> ["_rollup", "job"] + Just (RollupJobId jobId) -> ["_rollup", "job", jobId] + +-- | 'deleteRollupJob' deletes a single rollup job by id. Maps to +-- @DELETE /_rollup/job/{job_id}@ and returns 'Acknowledged' on success. +-- +-- See +-- . +deleteRollupJob :: + RollupJobId -> + BHRequest StatusDependant Acknowledged +deleteRollupJob (RollupJobId jobId) = + delete ["_rollup", "job", jobId] + +-- | 'startRollupJob' starts an existing, stopped rollup job. Maps to +-- @POST /_rollup/job/{job_id}/_start@ and returns 'RollupJobStarted'. +-- +-- See +-- . +startRollupJob :: + RollupJobId -> + BHRequest StatusDependant RollupJobStarted +startRollupJob (RollupJobId jobId) = + postNoBody ["_rollup", "job", jobId, "_start"] + +-- | 'stopRollupJob' stops an existing, started rollup job asynchronously. +-- Maps to @POST /_rollup/job/{job_id}/_stop@ and returns 'RollupJobStopped'. +-- Use 'stopRollupJobWith' to block until the job has fully stopped +-- (@wait_for_completion=true@) or to override the @timeout@. +-- +-- See +-- . +stopRollupJob :: + RollupJobId -> + BHRequest StatusDependant RollupJobStopped +stopRollupJob jobId = + stopRollupJobWith jobId defaultStopRollupJobOptions + +-- | Like 'stopRollupJob' but accepts 'StopRollupJobOptions' carrying the +-- documented URI parameters @wait_for_completion@ and @timeout@. +-- 'defaultStopRollupJobOptions' makes this byte-for-byte equivalent to +-- 'stopRollupJob'. +-- +-- See +-- . +stopRollupJobWith :: + RollupJobId -> + StopRollupJobOptions -> + BHRequest StatusDependant RollupJobStopped +stopRollupJobWith (RollupJobId jobId) opts = + postNoBody + (["_rollup", "job", jobId, "_stop"] `withQueries` stopRollupJobOptionsParams opts) + +-- | 'getRollupJobStats' retrieves the transient statistics (and current +-- state) of rollup jobs. Maps to @GET /_rollup/job[/{job_id}|_all]/_stats@. +-- +-- * @'Nothing'@ → @GET /_rollup/job/_stats@ returns every job's stats. +-- * @'Just' jid@ → @GET /_rollup/job/{jid}/_stats@ returns just that one. +-- +-- See +-- . +getRollupJobStats :: + Maybe RollupJobId -> + BHRequest StatusDependant GetRollupJobStatsResponse +getRollupJobStats mJobId = + get @StatusDependant endpoint + where + endpoint = case mJobId of + Nothing -> ["_rollup", "job", "_stats"] + Just (RollupJobId jobId) -> ["_rollup", "job", jobId, "_stats"] + +-- | 'getRollupCapabilities' returns the capabilities of any rollup jobs +-- configured for a given index or index pattern. Maps to +-- @GET /_rollup/data/{index}@. Use @_all@ to fetch capabilities from all +-- jobs. +-- +-- See +-- . +getRollupCapabilities :: + IndexPattern -> + BHRequest StatusDependant RollupCapabilitiesResponse +getRollupCapabilities (IndexPattern indexPattern) = + get ["_rollup", "data", indexPattern] + +-- | 'getRollupIndexCapabilities' returns the rollup capabilities of all +-- jobs stored inside a rollup index (or index pattern). Maps to +-- @GET /{target}/_rollup/data@. +-- +-- See +-- . +getRollupIndexCapabilities :: + IndexName -> + BHRequest StatusDependant RollupCapabilitiesResponse +getRollupIndexCapabilities indexName = + get [unIndexName indexName, "_rollup", "data"] + +-- | 'rollupSearchByIndex' runs a standard 'Search' against rolled-up data. +-- Maps to @GET /{index}/_rollup_search@ with the search body carried in +-- the request body (the method is GET per the ES docs; 'getWithBody' is +-- used so the body survives proxies that strip it from a body-less GET). +-- The response shape is the standard 'SearchResult'; hits are always +-- empty (@size@ must be @0@ or omitted), so callers typically inspect +-- 'aggregations' instead. +-- +-- At least one index (or pattern) must be specified; omitting the target +-- or using @_all@ is not permitted by the rollup search endpoint. +-- +-- See +-- . +rollupSearchByIndex :: + (FromJSON a) => + IndexName -> + Search -> + BHRequest StatusDependant (SearchResult a) +rollupSearchByIndex indexName = + rollupSearchByIndexWith indexName defaultSearchOptions + +-- | Like 'rollupSearchByIndex' but accepts a 'SearchOptions' record for +-- URI-level parameters such as @preference@ and @routing@. +rollupSearchByIndexWith :: + (FromJSON a) => + IndexName -> + SearchOptions -> + Search -> + BHRequest StatusDependant (SearchResult a) +rollupSearchByIndexWith indexName opts search = + getWithBody + ([unIndexName indexName, "_rollup_search"] `withQueries` searchOptionsParams opts (searchType search)) + (encode search) diff --git a/src/Database/Bloodhound/Common/Types.hs b/src/Database/Bloodhound/Common/Types.hs --- a/src/Database/Bloodhound/Common/Types.hs +++ b/src/Database/Bloodhound/Common/Types.hs @@ -17,19 +17,159 @@ import Database.Bloodhound.Internal.Client.BHRequest as Reexport import Database.Bloodhound.Internal.Client.Doc as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Aggregation as Reexport + ( Aggregation (..), + AggregationResults, + Aggregations, + AvgAggregation (..), + AvgBucketAggregation, + Bucket (..), + BucketAggregation (..), + CardinalityAggregation (..), + CollectionMode (..), + CompositeAggregation (..), + CumulativeSumAggregation, + DateHistogramAggregation (..), + DateHistogramResult (..), + DateMathAnchor (..), + DateMathExpr (..), + DateMathModifier (..), + DateMathUnit (..), + DateRangeAggRange (..), + DateRangeAggregation (..), + DateRangeResult (..), + DerivativeAggregation, + ExecutionHint (..), + FilterAggregation (..), + Hdr, + HistogramAggregation, + HistogramExtendedBounds, + HistogramHardBounds, + Hit (..), + HitsTotal (..), + HitsTotalRelation (..), + MaxAggregation, + MaxBucketAggregation, + MedianAbsoluteDeviationAggregation (..), + MinAggregation, + MinBucketAggregation, + MissingAggregation (..), + MissingResult (..), + NestedAggregation, + PercentileAggregation, + RangeAggregation, + RangeAggregationRange (..), + SearchHits (..), + StatisticsAggregation (..), + StatsBucketAggregation, + SumBucketAggregation, + Tdigested, + TermsAggregation (..), + TermsResult (..), + TopHitResult (..), + TopHitsAggregation (..), + ValueCountAggregation (..), + emptyAggregations, + hitDocIdLens, + hitFieldsLens, + hitHighlightLens, + hitIndexLens, + hitInnerHitsLens, + hitScoreLens, + hitSortLens, + hitSourceLens, + hitsTotalRelationLens, + hitsTotalValueLens, + mkAggregations, + mkAvgBucketAggregation, + mkCardinalityAggregation, + mkCumulativeSumAggregation, + mkDateHistogram, + mkDerivativeAggregation, + mkHistogramAggregation, + mkHistogramExtendedBoundsMax, + mkHistogramExtendedBoundsMin, + mkHistogramHardBoundsMax, + mkHistogramHardBoundsMin, + mkMaxAggregation, + mkMaxBucketAggregation, + mkMinAggregation, + mkMinBucketAggregation, + mkNestedAggregation, + mkPercentileAggregation, + mkRangeAggregation, + mkRangeAggregationRangeFrom, + mkRangeAggregationRangeTo, + mkStatsAggregation, + mkStatsBucketAggregation, + mkSumBucketAggregation, + mkTermsAggregation, + searchHitsHitsTotalLens, + searchHitsMaxScoreLens, + toDateHistogram, + toTerms, + ) import Database.Bloodhound.Internal.Versions.Common.Types.Analysis as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Analyze as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.AsyncSearch as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Autoscaling as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Bulk as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Cat as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Cluster as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.ClusterSettings as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.ClusterState as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.ClusterStats as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Count as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Dangling as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.DiskUsage as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Document as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Enrich as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Explain as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.FieldCaps as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.FieldUsageStats as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Fleet as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Highlight as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.ILM as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Indices as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Ingest as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.KeepAlive as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Knn as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Logstash as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Migration as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.MultiGet as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.MultiSearch as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.MultiSearchTemplate as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Nodes as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.OpType as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.PendingTask as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.PointInTime as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Query as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.RankEval as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Refresh as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Reindex as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.ReloadSearchAnalyzers as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.RemoteClusterInfo as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.RepositoriesMetering as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Reroute as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Retriever as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Rollup as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.SLM as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.ScriptContexts as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.ScriptLanguages as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Search as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.SearchShards as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.SearchableSnapshots as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Security as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Snapshots as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Sort as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Suggest as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Task as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.TermVectors as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.TextStructure as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Transform as Reexport import Database.Bloodhound.Internal.Versions.Common.Types.Units as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Validate as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.VectorTile as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.VersionType as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.VotingConfigExclusion as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Watcher as Reexport diff --git a/src/Database/Bloodhound/Dynamic/Client.hs b/src/Database/Bloodhound/Dynamic/Client.hs --- a/src/Database/Bloodhound/Dynamic/Client.hs +++ b/src/Database/Bloodhound/Dynamic/Client.hs @@ -22,17 +22,24 @@ guessBackendType, withFetchedBackendType, pitSearch, + pitSearchWith, + listAllPITs, ) where import Data.Aeson import Data.Maybe (fromMaybe, listToMaybe) -import qualified Data.Versions as Versions +import Data.Versions qualified as Versions import Database.Bloodhound.Client.Cluster import Database.Bloodhound.Common.Client as Reexport -import qualified Database.Bloodhound.ElasticSearch7.Client as ClientES2 -import qualified Database.Bloodhound.OpenSearch2.Client as ClientOS2 -import Database.Bloodhound.OpenSearch2.Types +import Database.Bloodhound.Common.Types +import Database.Bloodhound.ElasticSearch7.Client qualified as ClientES7 +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch9.Client qualified as ClientES9 +import Database.Bloodhound.OpenSearch2.Client qualified as ClientOS2 +import Database.Bloodhound.OpenSearch2.Types (PITInfo (pitInfoId, pitInfoKeepAlive)) +import Database.Bloodhound.OpenSearch3.Client qualified as ClientOS3 +import Database.Bloodhound.OpenSearch3.Types qualified as OS3Types import Lens.Micro (toListOf) import Prelude hiding (filter, head) @@ -52,27 +59,104 @@ let backend = fromMaybe Dynamic $ listToMaybe (nodesInfo nodeInfo) >>= guessBackendType withDynamicBH backend $ StaticBH . f --- | 'pitSearch' uses the point in time (PIT) API of elastic, for a given --- 'IndexName'. Requires Elasticsearch >=7.10 or OpenSearch >=2. Note that this will consume the --- entire search result set and will be doing O(n) list appends so this may --- not be suitable for large result sets. In that case, the point in time API --- should be used directly with `openPointInTime` and `closePointInTime`. +-- | 'pitSearch' uses the point in time (PIT) API, for a given +-- 'IndexName'. Requires Elasticsearch >=7.10 or OpenSearch >=2. The supplied +-- 'KeepAlive' duration is forwarded to every PIT open\/extend call. Note that +-- this will consume the entire search result set and will be doing O(n) list +-- appends so this may not be suitable for large result sets. In that case, the +-- point in time API should be used directly with `openPointInTime` and +-- `closePointInTime`. -- +-- This is a convenience wrapper around 'pitSearchWith' that lifts the +-- single 'IndexName' into an 'IndexPattern'. To search across multiple +-- comma-joined indices or a wildcard pattern, use 'pitSearchWith' +-- directly with an 'IndexPattern'. +-- -- Note that 'pitSearch' utilizes the 'search_after' parameter under the hood, -- which requires a non-empty 'sortBody' field in the provided 'Search' value. -- Otherwise, 'pitSearch' will fail to return all matching documents. -- -- For more information see --- . +-- . pitSearch :: forall a m backend. (FromJSON a, MonadBH m) => SBackendType backend -> IndexName -> + KeepAlive -> Search -> m [Hit a] -pitSearch backend indexName search = +pitSearch backend indexName keepAlive search = + pitSearchWith backend (IndexPattern (unIndexName indexName)) keepAlive search + +-- | 'pitSearchWith' is the parameterized variant of 'pitSearch': it +-- takes an 'IndexPattern' as the target, which may be a single index +-- name, a comma-separated list of indices, or a wildcard pattern +-- (e.g. @\"logs-*\"@, @\"logs-2024,logs-2025\"@). Otherwise behaves +-- exactly like 'pitSearch'. Requires Elasticsearch >=7.10 or OpenSearch +-- >=2; OpenSearch 1 lacks a PIT API and throws. See +-- 'openPointInTimeWith' for the target rendering. +-- +-- For more information see +-- . +pitSearchWith :: + forall a m backend. + (FromJSON a, MonadBH m) => + SBackendType backend -> + IndexPattern -> + KeepAlive -> + Search -> + m [Hit a] +pitSearchWith backend indexPattern keepAlive search = case backend of - SElasticSearch7 -> unsafePerformBH @'ElasticSearch7 $ ClientES2.pitSearch indexName search + SElasticSearch7 -> unsafePerformBH @'ElasticSearch7 $ ClientES7.pitSearchWith indexPattern keepAlive search + SElasticSearch8 -> unsafePerformBH @'ElasticSearch8 $ ClientES8.pitSearchWith indexPattern keepAlive search + SElasticSearch9 -> unsafePerformBH @'ElasticSearch9 $ ClientES9.pitSearchWith indexPattern keepAlive search SOpenSearch1 -> throwEsError $ EsError Nothing "pitSearch is not supported by OpenSearch1" - SOpenSearch2 -> unsafePerformBH @'OpenSearch2 $ ClientOS2.pitSearch indexName search + SOpenSearch2 -> unsafePerformBH @'OpenSearch2 $ ClientOS2.pitSearchWith indexPattern keepAlive search + SOpenSearch3 -> unsafePerformBH @'OpenSearch3 $ ClientOS3.pitSearchWith indexPattern keepAlive search + +-- | 'listAllPITs' lists every currently-open point in time on the +-- cluster, normalizing the OpenSearch response into a common +-- 'PITSummary'. Only OpenSearch 2 and 3 support a list-all-PITs endpoint +-- (@GET /_search\/point_in_time\/_all@); OpenSearch 1 lacks a PIT API +-- entirely and throws. +-- +-- Elasticsearch throws on /every/ major version: the ES point-in-time +-- API only ever documented @POST \/{index}\/_pit@ (open) and +-- @DELETE \/_pit@ (close). @GET \/_pit@ was never an ES operation — +-- verified live (bloodhound-cfv), the server returns @405 Method Not +-- Allowed@ with @Allow: POST,DELETE@ on ES 7.17.25, 8.19.16 and 9.4.2. +-- Use the nodes stats API (@GET \/_nodes\/stats\/indices\/search@) for +-- an aggregate count of open search contexts on ES, or migrate to +-- OpenSearch for per-PIT listing. +-- +-- For more information see the OpenSearch docs: +-- . +listAllPITs :: + forall m backend. + (MonadBH m) => + SBackendType backend -> + m [PITSummary] +listAllPITs backend = + case backend of + SElasticSearch7 -> throwEsError $ EsError Nothing "listAllPITs is not supported by any Elasticsearch version (GET /_pit returns 405 on ES 7.17/8.x/9.x; only POST/DELETE are documented)" + SElasticSearch8 -> throwEsError $ EsError Nothing "listAllPITs is not supported by any Elasticsearch version (GET /_pit returns 405 on ES 7.17/8.x/9.x; only POST/DELETE are documented)" + SElasticSearch9 -> throwEsError $ EsError Nothing "listAllPITs is not supported by any Elasticsearch version (GET /_pit returns 405 on ES 7.17/8.x/9.x; only POST/DELETE are documented)" + SOpenSearch1 -> throwEsError $ EsError Nothing "listAllPITs is not supported by OpenSearch1" + SOpenSearch2 -> summarizeOS2 <$> (unsafePerformBH @'OpenSearch2 ClientOS2.listAllPITs) + SOpenSearch3 -> summarizeOS3 <$> (unsafePerformBH @'OpenSearch3 ClientOS3.listAllPITs) + +-- | Collapse an OpenSearch 2 'PITInfo' into the backend-agnostic +-- 'PITSummary'. The OS list-all-PITs response surfaces @keep_alive@ (as a +-- millisecond count, parsed into a 'KeepAlive'), so it is 'Just'; +-- @creation_time@ is dropped. +summarizeOS2 :: [PITInfo] -> [PITSummary] +summarizeOS2 pits = + [PITSummary (pitInfoId p) (Just (pitInfoKeepAlive p)) | p <- pits] + +-- | Collapse an OpenSearch 3 'PITInfo' into the backend-agnostic +-- 'PITSummary'. Same field semantics as 'summarizeOS2'. +summarizeOS3 :: [OS3Types.PITInfo] -> [PITSummary] +summarizeOS3 pits = + [PITSummary (OS3Types.pitInfoId p) (Just (OS3Types.pitInfoKeepAlive p)) | p <- pits] diff --git a/src/Database/Bloodhound/ElasticSearch7/Client.hs b/src/Database/Bloodhound/ElasticSearch7/Client.hs --- a/src/Database/Bloodhound/ElasticSearch7/Client.hs +++ b/src/Database/Bloodhound/ElasticSearch7/Client.hs @@ -2,48 +2,118 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +-- | +-- Module : Database.Bloodhound.ElasticSearch7.Client +-- Description : Elasticsearch 7 client (re-exports Common + ES7-specific APIs) +-- +-- The Elasticsearch 7 client. Re-exports the version-agnostic "Database.Bloodhound.Common.Client" +-- surface and adds ES7-specific features: point in time (PIT), data streams, +-- EQL search, and the terms enum API. module Database.Bloodhound.ElasticSearch7.Client ( module Reexport, pitSearch, + pitSearchWith, openPointInTime, + openPointInTimeWith, + openPointInTimeWithBody, closePointInTime, + getDataStreams, + getDataStreamStats, + createDataStream, + dataStreamExists, + deleteDataStream, + migrateToDataStream, + promoteDataStream, + modifyDataStream, + eqlSearch, + eqlSearchWith, + getEQLSearch, + getEQLStatus, + deleteEQLSearch, + getTermsEnum, + getTermsEnumWith, + TermValue (..), + TermsEnumRequest (..), + defaultTermsEnumRequest, + TermsEnumOptions (..), + defaultTermsEnumOptions, + termsEnumOptionsParams, + TermsEnumResponse (..), + SyncedFlushResult (..), + SyncedFlushShardGroup (..), + SyncedFlushFailure (..), + SyncedFlushOptions (..), + defaultSyncedFlushOptions, + syncedFlushOptionsParams, + syncedFlushIndex, + syncedFlushIndexWith, + freezeIndex, + unfreezeIndex, ) where import Control.Monad import Data.Aeson import Data.Monoid +import Data.Text (Text) import Database.Bloodhound.Client.Cluster import Database.Bloodhound.Common.Client as Reexport -import qualified Database.Bloodhound.ElasticSearch7.Requests as Requests +import Database.Bloodhound.ElasticSearch7.Requests qualified as Requests import Database.Bloodhound.ElasticSearch7.Types import Prelude hiding (filter, head) -- | 'pitSearch' uses the point in time (PIT) API of elastic, for a given --- 'IndexName'. Requires Elasticsearch >=7.10. Note that this will consume the --- entire search result set and will be doing O(n) list appends so this may --- not be suitable for large result sets. In that case, the point in time API --- should be used directly with `openPointInTime` and `closePointInTime`. +-- 'IndexName'. Requires Elasticsearch >=7.10. The supplied 'KeepAlive' +-- duration is forwarded to every PIT open\/extend call. Note that this will +-- consume the entire search result set and will be doing O(n) list appends so +-- this may not be suitable for large result sets. In that case, the point in +-- time API should be used directly with `openPointInTime` and +-- `closePointInTime`. -- +-- This is a convenience wrapper around 'pitSearchWith' that lifts the +-- single 'IndexName' into an 'IndexPattern'. To search across multiple +-- comma-joined indices or a wildcard pattern, use 'pitSearchWith' +-- directly with an 'IndexPattern'. +-- -- Note that 'pitSearch' utilizes the 'search_after' parameter under the hood, -- which requires a non-empty 'sortBody' field in the provided 'Search' value. -- Otherwise, 'pitSearch' will fail to return all matching documents. -- -- For more information see --- . +-- . pitSearch :: forall a m. (FromJSON a, MonadBH m, WithBackend ElasticSearch7 m) => IndexName -> + KeepAlive -> Search -> m [Hit a] -pitSearch indexName search = do - openResp <- openPointInTime indexName +pitSearch indexName = pitSearchWith (IndexPattern (unIndexName indexName)) + +-- | 'pitSearchWith' is the parameterized variant of 'pitSearch': it +-- takes an 'IndexPattern' as the target, which may be a single index +-- name, a comma-separated list of indices, or a wildcard pattern +-- (e.g. @\"logs-*\"@, @\"logs-2024,logs-2025\"@). Otherwise behaves +-- exactly like 'pitSearch'. See 'openPointInTimeWith' for the target +-- rendering. +-- +-- For more information see +-- . +pitSearchWith :: + forall a m. + (FromJSON a, MonadBH m, WithBackend ElasticSearch7 m) => + IndexPattern -> + KeepAlive -> + Search -> + m [Hit a] +pitSearchWith indexPattern keepAlive search = do + openResp <- openPointInTimeWith indexPattern keepAlive defaultPITOptions case openResp of Left e -> throwEsError e Right OpenPointInTimeResponse {..} -> do - let searchPIT = search {pointInTime = Just (PointInTime oPitId "1m")} + let searchPIT = search {pointInTime = Just (PointInTime oPitId (Just keepAlive))} hits <- pitAccumulator searchPIT [] closeResp <- closePointInTime (ClosePointInTime oPitId) case closeResp of @@ -67,29 +137,366 @@ (Just lastSort, Just pitId') -> do let newSearch = search' - { pointInTime = Just (PointInTime pitId' "1m"), + { pointInTime = Just (PointInTime pitId' (Just keepAlive)), searchAfterKey = Just lastSort } pitAccumulator newSearch (oldHits <> newHits) --- | 'openPointInTime' opens a point in time for an index given an 'IndexName'. --- Note that the point in time should be closed with 'closePointInTime' as soon --- as it is no longer needed. +-- | 'openPointInTime' opens a point in time for an index given an 'IndexName' +-- and a 'KeepAlive' duration (e.g. @keepAliveMinutes 1@). Note that the point +-- in time should be closed with 'closePointInTime' as soon as it is no longer +-- needed. -- +-- Equivalent to 'openPointInTimeWith' with +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.defaultPITOptions' +-- (no optional URI parameters). +-- -- For more information see --- . +-- . openPointInTime :: (MonadBH m, WithBackend ElasticSearch7 m) => IndexName -> + KeepAlive -> m (ParsedEsResponse OpenPointInTimeResponse) -openPointInTime indexName = performBHRequest $ Requests.openPointInTime indexName +openPointInTime indexName keepAlive = performBHRequest $ Requests.openPointInTime indexName keepAlive +-- | 'openPointInTimeWith' is the parameterized variant of +-- 'openPointInTime': it takes an 'IndexPattern' target (single name, +-- comma-list, or wildcard) and forwards the supplied 'PITOptions' as +-- query-string parameters in addition to the mandatory @keep_alive@. +-- See 'Database.Bloodhound.ElasticSearch7.Requests.openPointInTimeWith' +-- for which parameters are emitted. +-- +-- For more information see +-- . +openPointInTimeWith :: + (MonadBH m, WithBackend ElasticSearch7 m) => + IndexPattern -> + KeepAlive -> + PITOptions -> + m (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWith indexPattern keepAlive opts = + performBHRequest $ Requests.openPointInTimeWith indexPattern keepAlive opts + +-- | 'openPointInTimeWithBody' is the body-carrying variant of +-- 'openPointInTimeWith': it sends the supplied 'OpenPointInTimeBody' as +-- the JSON request body (the only way to supply an @index_filter@ +-- query), in addition to the 'PITOptions' URI parameters and the +-- mandatory @keep_alive@. The 'IndexPattern' target follows the same +-- rules as 'openPointInTimeWith'. See +-- 'Database.Bloodhound.ElasticSearch7.Requests.openPointInTimeWithBody'. +-- +-- For more information see +-- . +openPointInTimeWithBody :: + (MonadBH m, WithBackend ElasticSearch7 m) => + IndexPattern -> + KeepAlive -> + OpenPointInTimeBody -> + PITOptions -> + m (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWithBody indexPattern keepAlive body opts = + performBHRequest $ Requests.openPointInTimeWithBody indexPattern keepAlive body opts + -- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'. -- -- For more information see --- . +-- . closePointInTime :: (MonadBH m, WithBackend ElasticSearch7 m) => ClosePointInTime -> m (ParsedEsResponse ClosePointInTimeResponse) closePointInTime q = performBHRequest $ Requests.closePointInTime q + +-- | 'getDataStreams' lists data streams. The wire format is identical +-- across ES 7.x, 8.x and 9.x, so this implementation is shared via the +-- ES8 and ES9 client modules. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream@ returns every data +-- stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}@ returns +-- only the named data streams. +-- +-- See +-- . +getDataStreams :: + (MonadBH m, WithBackend ElasticSearch7 m) => + Maybe [DataStreamName] -> + m [DataStreamInfo] +getDataStreams = performBHRequest . Requests.getDataStreams + +-- | 'getDataStreamStats' returns statistics about data streams +-- (document counts, store sizes, shard counts, etc.). The wire format +-- is identical across ES 7.x, 8.x and 9.x, so this implementation is +-- shared via the ES8 and ES9 client modules. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream/_stats@ returns +-- statistics for every data stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}/_stats@ +-- returns statistics for only the named data streams. +-- +-- See +-- . +getDataStreamStats :: + (MonadBH m, WithBackend ElasticSearch7 m) => + Maybe [DataStreamName] -> + m DataStreamStats +getDataStreamStats = performBHRequest . Requests.getDataStreamStats + +-- | 'createDataStream' creates a data stream with the given name. The +-- stream's configuration is derived from the matching index template +-- (which must already exist and declare a @data_stream@ object). The +-- wire format is identical across ES 7.x, 8.x and 9.x, so this +-- implementation is shared via the ES8 and ES9 client modules. +-- +-- See +-- . +createDataStream :: + (MonadBH m, WithBackend ElasticSearch7 m) => + DataStreamName -> + m Acknowledged +createDataStream = performBHRequest . Requests.createDataStream + +-- | 'dataStreamExists' checks whether a data stream with the given +-- name exists. Returns 'True' if the stream exists, 'False' +-- otherwise (any non-2xx status, including @404@, decodes to +-- 'False'; no 'EsError' is raised). The wire format is identical +-- across ES 7.x, 8.x and 9.x, so this implementation is shared via +-- the ES8 and ES9 client modules. +-- +-- See +-- . +dataStreamExists :: + (MonadBH m, WithBackend ElasticSearch7 m) => + DataStreamName -> + m Bool +dataStreamExists = performBHRequest . Requests.dataStreamExists + +-- | 'deleteDataStream' deletes a data stream and its backing indices. +-- Deleting a non-existent stream surfaces as an 'EsError'. The wire +-- format is identical across ES 7.x, 8.x and 9.x, so this +-- implementation is shared via the ES8 and ES9 client modules. +-- +-- See +-- . +deleteDataStream :: + (MonadBH m, WithBackend ElasticSearch7 m) => + DataStreamName -> + m Acknowledged +deleteDataStream = performBHRequest . Requests.deleteDataStream + +-- | 'migrateToDataStream' converts an existing alias (whose write index +-- is a hidden or data-stream-compatible backing index) into a data +-- stream. The alias and its write index must already be set up +-- correctly; an ineligible alias surfaces as an 'EsError'. The wire +-- format is identical across ES 7.x, 8.x and 9.x, so this +-- implementation is shared via the ES8 and ES9 client modules. +-- +-- See +-- . +migrateToDataStream :: + (MonadBH m, WithBackend ElasticSearch7 m) => + IndexAliasName -> + m Acknowledged +migrateToDataStream = performBHRequest . Requests.migrateToDataStream + +-- | 'promoteDataStream' promotes a frozen or cloned data stream back to a +-- regular data stream (disaster recovery). A stream that is not +-- currently frozen surfaces as an 'EsError'. The wire format is +-- identical to ES 7.x, 8.x and 9.x, so this implementation is shared via +-- the ES8 and ES9 client modules. +-- +-- See +-- . +promoteDataStream :: + (MonadBH m, WithBackend ElasticSearch7 m) => + DataStreamName -> + m Acknowledged +promoteDataStream = performBHRequest . Requests.promoteDataStream + +-- | 'modifyDataStream' changes the backing indices of one or more data +-- streams (batched add\/remove backing index). Referencing a +-- non-existent stream or an ineligible index surfaces as an 'EsError'. +-- The wire format is identical across ES 7.x, 8.x and 9.x, so this +-- implementation is shared via the ES8 and ES9 client modules. +-- +-- See +-- . +modifyDataStream :: + (MonadBH m, WithBackend ElasticSearch7 m) => + ModifyDataStreamRequest -> + m Acknowledged +modifyDataStream = performBHRequest . Requests.modifyDataStream + +-- | 'eqlSearch' submits an EQL (Event Query Language) search via +-- @POST /{index}/_eql/search@ (Elasticsearch >= 7.10). The result is +-- parameterized by the document-source type @a@. +-- +-- The wire format is identical across ES 7.x, 8.x and 9.x, so this +-- implementation is shared via the ES8 and ES9 client modules. +-- +-- For more information see +-- . +eqlSearch :: + (FromJSON a, MonadBH m, WithBackend ElasticSearch7 m) => + IndexName -> + EQLRequest -> + m (ParsedEsResponse (EQLResult a)) +eqlSearch indexName req = performBHRequest $ Requests.eqlSearch indexName req + +-- | 'eqlSearchWith' is the fully-parameterised form of 'eqlSearch'. Every +-- URI parameter accepted by @/{index}/_eql/search@ is exposed via +-- 'EQLSearchOptions'; the 'EQLRequest' body carries the @query@ and every +-- other body parameter. 'defaultEQLSearchOptions' makes this +-- byte-for-byte identical to the simple form (modulo the extra body +-- fields you set). +-- +-- For more information see +-- . +eqlSearchWith :: + (FromJSON a, MonadBH m, WithBackend ElasticSearch7 m) => + IndexName -> + EQLSearchOptions -> + EQLRequest -> + m (ParsedEsResponse (EQLResult a)) +eqlSearchWith indexName opts req = + performBHRequest $ Requests.eqlSearchWith indexName opts req + +-- | 'getEQLSearch' fetches the deferred results of an async EQL search +-- via @GET /_eql/search\/{id}@ (Elasticsearch >= 7.10). The result is +-- parameterized by the document-source type @a@. The optional 'Text' +-- sets @wait_for_completion_timeout@ as a query parameter; 'Nothing' +-- returns immediately with the current state (useful for status-only +-- polling), a duration string such as @"5s"@ long-polls for completion. +-- +-- For more information see +-- . +getEQLSearch :: + (FromJSON a, MonadBH m, WithBackend ElasticSearch7 m) => + EQLSearchId -> + Maybe Text -> + m (ParsedEsResponse (EQLResult a)) +getEQLSearch sid = performBHRequest . Requests.getEQLSearch sid + +-- | 'getEQLStatus' returns only the status of an async EQL search via +-- @GET /_eql/search/status\/{id}@ (Elasticsearch >= 7.10) without +-- fetching the results. The result is an 'EQLStatus' carrying +-- 'eqlStatusIsRunning', 'eqlStatusIsPartial', and (once complete) +-- 'eqlStatusCompletionStatus'. +-- +-- The wire format is identical across ES 7.x, 8.x and 9.x, so this +-- implementation is shared via the ES8 and ES9 client modules. +-- +-- For more information see +-- . +getEQLStatus :: + (MonadBH m, WithBackend ElasticSearch7 m) => + EQLSearchId -> + m EQLStatus +getEQLStatus = performBHRequest . Requests.getEQLStatus + +-- | 'deleteEQLSearch' deletes an async EQL search result and its +-- context by id via @DELETE /_eql/search/{id}@ (Elasticsearch >= 7.10) +-- and returns 'Acknowledged' on success. +-- +-- The wire format is identical across ES 7.x, 8.x and 9.x, so this +-- implementation is shared via the ES8 and ES9 client modules. +-- +-- For more information see +-- . +deleteEQLSearch :: + (MonadBH m, WithBackend ElasticSearch7 m) => + EQLSearchId -> + m Acknowledged +deleteEQLSearch = performBHRequest . Requests.deleteEQLSearch + +-- | 'getTermsEnum' returns a list of terms in a field for auto-complete +-- use cases via @GET \/{index}\/_terms_enum@ (Elasticsearch >= 7.10). +-- Pass a non-empty index list to target; the optional 'Text' is the +-- @string@ prefix to match (auto-complete seed). +-- +-- The wire format is identical across ES 7.x, 8.x and 9.x, so this +-- implementation is shared via the ES8 and ES9 client modules. +-- +-- For more information see +-- . +getTermsEnum :: + (MonadBH m, WithBackend ElasticSearch7 m) => + Maybe [IndexName] -> + FieldName -> + Maybe Text -> + m TermsEnumResponse +getTermsEnum mIndices field mString = + performBHRequest $ Requests.getTermsEnum mIndices field mString + +-- | 'getTermsEnumWith' is the fully-parameterised form of +-- 'getTermsEnum'. Every URI parameter accepted by +-- @/{index}/_terms_enum@ is exposed via 'TermsEnumOptions'; the +-- 'TermsEnumRequest' body carries the @field@, the optional @string@ +-- prefix and every other body parameter. 'defaultTermsEnumOptions' +-- makes this byte-for-byte identical to the simple form (modulo the +-- extra body fields you set). +-- +-- For more information see +-- . +getTermsEnumWith :: + (MonadBH m, WithBackend ElasticSearch7 m) => + Maybe [IndexName] -> + TermsEnumOptions -> + TermsEnumRequest -> + m TermsEnumResponse +getTermsEnumWith mIndices opts req = + performBHRequest $ Requests.getTermsEnumWith mIndices opts req + +-- | 'syncedFlushIndex' performs a synced flush on an index. Maps to the +-- deprecated @POST \/{index}/_flush/synced@ endpoint (deprecated in +-- 7.6, removed in 8.0). Prefer +-- 'Database.Bloodhound.Common.Client.flushIndex' for new code. +-- +-- Equivalent to +-- @'syncedFlushIndexWith' 'defaultSyncedFlushOptions'@. +-- +-- @since 0.26.0.0 +{-# DEPRECATED syncedFlushIndex "Synced flush was deprecated in ES 7.6 and removed in 8.0. Use flushIndex instead. See " #-} +syncedFlushIndex :: + (MonadBH m, WithBackend ElasticSearch7 m) => + IndexName -> + m SyncedFlushResult +syncedFlushIndex = syncedFlushIndexWith defaultSyncedFlushOptions + +-- | 'syncedFlushIndexWith' is the fully-parameterised form of +-- 'syncedFlushIndex'. +-- +-- @since 0.26.0.0 +{-# DEPRECATED syncedFlushIndexWith "Synced flush was deprecated in ES 7.6 and removed in 8.0. Use flushIndex instead. See " #-} +syncedFlushIndexWith :: + (MonadBH m, WithBackend ElasticSearch7 m) => + SyncedFlushOptions -> + IndexName -> + m SyncedFlushResult +syncedFlushIndexWith opts indexName = + performBHRequest $ Requests.syncedFlushIndexWith opts indexName + +-- | 'freezeIndex' freezes an index. Maps to the deprecated +-- @POST \/{index}/_freeze@ endpoint (deprecated in 7.14, removed in +-- 8.0). Avoid this in new code. +-- +-- @since 0.26.0.0 +{-# DEPRECATED freezeIndex "Freeze index was deprecated in ES 7.14 and removed in 8.0. See " #-} +freezeIndex :: + (MonadBH m, WithBackend ElasticSearch7 m) => + IndexName -> + m ShardsResult +freezeIndex indexName = performBHRequest $ Requests.freezeIndex indexName + +-- | 'unfreezeIndex' unfreezes an index. Maps to the deprecated +-- @POST \/{index}/_unfreeze@ endpoint (deprecated in 7.14, removed in +-- 8.0). Avoid this in new code. +-- +-- @since 0.26.0.0 +{-# DEPRECATED unfreezeIndex "Unfreeze index was deprecated in ES 7.14 and removed in 8.0. See " #-} +unfreezeIndex :: + (MonadBH m, WithBackend ElasticSearch7 m) => + IndexName -> + m ShardsResult +unfreezeIndex indexName = performBHRequest $ Requests.unfreezeIndex indexName diff --git a/src/Database/Bloodhound/ElasticSearch7/Requests.hs b/src/Database/Bloodhound/ElasticSearch7/Requests.hs --- a/src/Database/Bloodhound/ElasticSearch7/Requests.hs +++ b/src/Database/Bloodhound/ElasticSearch7/Requests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -5,35 +6,595 @@ module Database.Bloodhound.ElasticSearch7.Requests ( module Reexport, openPointInTime, + openPointInTimeWith, + openPointInTimeWithBody, closePointInTime, + getDataStreams, + getDataStreamStats, + createDataStream, + dataStreamExists, + deleteDataStream, + migrateToDataStream, + promoteDataStream, + modifyDataStream, + eqlSearch, + eqlSearchWith, + getEQLSearch, + getEQLStatus, + deleteEQLSearch, + getTermsEnum, + getTermsEnumWith, + + -- * Deprecated index endpoints (ES 7.x only, removed in 8.0) + syncedFlushIndex, + syncedFlushIndexWith, + freezeIndex, + unfreezeIndex, ) where import Data.Aeson +import Data.Text qualified as T import Database.Bloodhound.Client.Cluster import Database.Bloodhound.Common.Requests as Reexport import Database.Bloodhound.ElasticSearch7.Types import Database.Bloodhound.Internal.Utils.Requests import Prelude hiding (filter, head) --- | 'openPointInTime' opens a point in time for an index given an 'IndexName'. --- Note that the point in time should be closed with 'closePointInTime' as soon --- as it is no longer needed. +-- | 'openPointInTime' opens a point in time for a single index given an +-- 'IndexName', using the supplied 'KeepAlive' duration (e.g. +-- @keepAliveMinutes 1@). Note that the point in time should be closed +-- with 'closePointInTime' as soon as it is no longer needed. -- +-- This is a convenience wrapper around 'openPointInTimeWith' that lifts +-- the single 'IndexName' into an 'IndexPattern'. To target multiple +-- comma-joined indices or a wildcard pattern (e.g. @\"logs-*,app-*\"@), +-- use 'openPointInTimeWith' directly with an 'IndexPattern'. +-- -- For more information see --- . +-- . openPointInTime :: IndexName -> + KeepAlive -> BHRequest StatusDependant (ParsedEsResponse OpenPointInTimeResponse) -openPointInTime indexName = - withBHResponseParsedEsResponse $ post @StatusDependant [unIndexName indexName, "_pit?keep_alive=1m"] emptyBody +openPointInTime indexName keepAlive = + openPointInTimeWith (IndexPattern (unIndexName indexName)) keepAlive defaultPITOptions +-- | 'openPointInTimeWith' is the parameterized variant of +-- 'openPointInTime': it takes an 'IndexPattern' as the target, which may +-- be a single index name, a comma-separated list of indices, or a +-- wildcard pattern (e.g. @\"logs-*\"@, @\"logs-2024,logs-2025\"@). It +-- forwards the supplied 'PITOptions' as query-string parameters in +-- addition to the mandatory @keep_alive@. Only the parameters accepted +-- by the Elasticsearch PIT endpoint are emitted (@routing@, +-- @preference@, @expand_wildcards@, @ignore_unavailable@, +-- @allow_partial_search_results@, @max_concurrent_shard_requests@); the +-- OpenSearch-only +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.pitoAllowPartialPITCreation' +-- field is silently dropped by this builder. Pass +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.defaultPITOptions' +-- to reproduce the wire shape of 'openPointInTime'. To send an +-- @index_filter@ body, use 'openPointInTimeWithBody'. +-- +-- For more information see +-- . +openPointInTimeWith :: + IndexPattern -> + KeepAlive -> + PITOptions -> + BHRequest StatusDependant (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWith indexPattern keepAlive opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint emptyBody + where + endpoint = + [unIndexPattern indexPattern, "_pit"] + `withQueries` (("keep_alive", Just (keepAliveToText keepAlive)) : pitOptionsParams opts) + +-- | 'openPointInTimeWithBody' is the body-carrying variant of +-- 'openPointInTimeWith' on Elasticsearch 7: in addition to the +-- 'PITOptions' URI parameters (forwarded exactly as in +-- 'openPointInTimeWith') and the mandatory @keep_alive@, it sends the +-- supplied 'OpenPointInTimeBody' as the JSON request body. This is the +-- only way to supply an @index_filter@ query, which filters indices out +-- of the PIT when it rewrites to @match_none@ on every shard. The +-- 'IndexPattern' target follows the same rules as 'openPointInTimeWith' +-- (single name, comma-list, or wildcard). Pass +-- 'defaultOpenPointInTimeBody' to send an empty (@{}@) body. +-- +-- For more information see +-- . +openPointInTimeWithBody :: + IndexPattern -> + KeepAlive -> + OpenPointInTimeBody -> + PITOptions -> + BHRequest StatusDependant (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWithBody indexPattern keepAlive body opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode body) + where + endpoint = + [unIndexPattern indexPattern, "_pit"] + `withQueries` (("keep_alive", Just (keepAliveToText keepAlive)) : pitOptionsParams opts) + -- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'. -- -- For more information see --- . +-- . closePointInTime :: ClosePointInTime -> BHRequest StatusDependant (ParsedEsResponse ClosePointInTimeResponse) closePointInTime q = do withBHResponseParsedEsResponse $ deleteWithBody @StatusDependant ["_pit"] (encode q) + +-- $dataStreams +-- +-- /Data Streams/ are the recommended way to model time-series and +-- append-only data in Elasticsearch 7.x, 8.x and 9.x. The wire format is +-- identical across all three versions, so the request builder lives +-- here and is re-exported by the ES8 and ES9 client modules. + +-- | 'getDataStreams' lists data streams. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream@ returns every data +-- stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}@ returns +-- only the named data streams (comma-joined path segment, mirroring +-- the @GET /_ilm/policy/{id}@ multi-id convention). +-- +-- The response is wrapped in a @data_streams@ array, so the body +-- decoder unwraps 'GetDataStreamsResponse' and returns a flat list of +-- 'DataStreamInfo' (a type alias for 'DataStream'). +-- +-- See +-- . +getDataStreams :: + Maybe [DataStreamName] -> + BHRequest StatusDependant [DataStreamInfo] +getDataStreams mDataStreamNames = + dataStreams <$> get @StatusDependant endpoint + where + endpoint = case mDataStreamNames of + Nothing -> ["_data_stream"] + Just [] -> ["_data_stream"] + Just (first : rest) -> + ["_data_stream", T.intercalate "," (renderDataStreamName <$> (first : rest))] + renderDataStreamName (DataStreamName dsName) = dsName + +-- | 'getDataStreamStats' returns statistics about one or more data +-- streams (document counts, store sizes, shard counts, etc.). +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream/_stats@ returns +-- statistics for every data stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}/_stats@ +-- returns statistics for only the named data streams (comma-joined +-- path segment, mirroring 'getDataStreams'). +-- +-- The response carries the @_shards@ summary, cluster-wide aggregates +-- (@data_stream_count@, @backing_indices@, @total_store_size_bytes@, +-- @total_store_size@) and a per-stream breakdown in @data_streams@. +-- +-- See +-- . +getDataStreamStats :: + Maybe [DataStreamName] -> + BHRequest StatusDependant DataStreamStats +getDataStreamStats mDataStreamNames = + get @StatusDependant endpoint + where + endpoint = case mDataStreamNames of + Nothing -> ["_data_stream", "_stats"] + Just [] -> ["_data_stream", "_stats"] + Just (first : rest) -> + ["_data_stream", T.intercalate "," (renderDataStreamName <$> (first : rest)), "_stats"] + renderDataStreamName (DataStreamName dsName) = dsName + +-- | 'createDataStream' creates a data stream with the given name. The +-- request carries no body: Elasticsearch derives the stream's +-- configuration (mappings, settings, lifecycle) from the matching index +-- template, which must already define a @data_stream@ object. Returns +-- 'Acknowledged' on success. +-- +-- Requires Elasticsearch >= 7.9. The wire format is identical across +-- ES 7.x, 8.x and 9.x, so the request builder lives here and is +-- re-exported by the ES8 and ES9 client modules. +-- +-- See +-- . +createDataStream :: + DataStreamName -> + BHRequest StatusDependant Acknowledged +createDataStream (DataStreamName dsName) = + put @StatusDependant ["_data_stream", dsName] emptyBody + +-- | 'dataStreamExists' checks whether a data stream with the given +-- name exists. Issues a @HEAD /_data_stream\/{name}@ request and +-- returns 'True' on any 2xx response, 'False' otherwise. The wire +-- format is identical across ES 7.x, 8.x and 9.x, so the request +-- builder lives here and is re-exported by the ES8 and ES9 client +-- modules. +-- +-- Requires Elasticsearch >= 7.9. +-- +-- See +-- . +dataStreamExists :: + DataStreamName -> + BHRequest StatusDependant Bool +dataStreamExists (DataStreamName dsName) = + doesExist ["_data_stream", dsName] + +-- | 'deleteDataStream' deletes a data stream and its backing indices. +-- Returns 'Acknowledged' on success. Deleting a non-existent stream +-- fails with an HTTP error (hence 'StatusDependant'), surfaced as an +-- 'EsError' rather than being swallowed. +-- +-- Requires Elasticsearch >= 7.9. The wire format is identical across +-- ES 7.x, 8.x and 9.x, so the request builder lives here and is +-- re-exported by the ES8 and ES9 client modules. +-- +-- See +-- . +deleteDataStream :: + DataStreamName -> + BHRequest StatusDependant Acknowledged +deleteDataStream (DataStreamName dsName) = + delete @StatusDependant ["_data_stream", dsName] + +-- | 'migrateToDataStream' converts an existing alias (whose write index +-- is a hidden or data-stream-compatible backing index) into a data +-- stream. The request carries no body: Elasticsearch derives the +-- stream's configuration from the alias and its write index, which +-- must already be set up correctly. Returns 'Acknowledged' on success. +-- +-- Migrating an alias that does not exist, or whose write index is not +-- eligible, fails with an HTTP error (hence 'StatusDependant'), +-- surfaced as an 'EsError'. +-- +-- Requires Elasticsearch >= 7.9. The wire format is identical across +-- ES 7.x, 8.x and 9.x, so the request builder lives here and is +-- re-exported by the ES8 and ES9 client modules. +-- +-- See +-- . +migrateToDataStream :: + IndexAliasName -> + BHRequest StatusDependant Acknowledged +migrateToDataStream aliasName = + post @StatusDependant ["_data_stream", "_migrate", unIndexName (indexAliasName aliasName)] emptyBody + +-- | 'promoteDataStream' promotes a frozen or cloned data stream back to a +-- regular data stream. Used during disaster recovery: a stream that was +-- fenced (e.g. cloned during failover) is read-only until promoted. The +-- request carries no body. Returns 'Acknowledged' on success. +-- +-- Promoting a non-existent stream, or a stream that is not currently +-- frozen, fails with an HTTP error (hence 'StatusDependant'), surfaced +-- as an 'EsError'. +-- +-- Requires Elasticsearch >= 7.9. The wire format is identical across +-- ES 7.x, 8.x and 9.x, so the request builder lives here and is +-- re-exported by the ES8 and ES9 client modules. +-- +-- See +-- . +promoteDataStream :: + DataStreamName -> + BHRequest StatusDependant Acknowledged +promoteDataStream (DataStreamName dsName) = + post @StatusDependant ["_data_stream", "_promote", dsName] emptyBody + +-- | 'modifyDataStream' changes the backing indices of one or more data +-- streams in a single batched request. The body carries a list of +-- 'ModifyDataStreamAction's (add\/remove backing index); each action +-- references its own 'DataStreamName', so the path carries no stream +-- name. Returns 'Acknowledged' on success. +-- +-- Referencing a non-existent data stream, or adding\/removing an index +-- that is not eligible, fails with an HTTP error (hence +-- 'StatusDependant'), surfaced as an 'EsError'. An empty actions list +-- is rejected by the server. +-- +-- Requires Elasticsearch >= 7.16. The wire format is identical across +-- ES 7.x, 8.x and 9.x, so the request builder lives here and is +-- re-exported by the ES8 and ES9 client modules. +-- +-- See +-- . +modifyDataStream :: + ModifyDataStreamRequest -> + BHRequest StatusDependant Acknowledged +modifyDataStream req = + post @StatusDependant ["_data_stream", "_modify"] (encode req) + +-- $eql +-- +-- /Event Query Language/ (EQL) is an event-based query language for +-- sequences and time-series data. The synchronous search endpoint +-- @POST /{index}/_eql/search@ was added in Elasticsearch 7.10. The wire +-- shape is /almost/ identical across ES 7.x, 8.x and 9.x: 8.x added the +-- @allow_partial_search_results@, @allow_partial_sequence_results@ and +-- @case_sensitive@ body fields plus the two URI parameters +-- @allow_partial_search_results@ and @allow_partial_sequence_results@. +-- The ES7 builder in this module gates those out via the +-- 'EQLRequestBodyES7' newtype and 'eqlSearchOptionsParams7'; the ES8 and +-- ES9 client modules ship their own 'eqlSearchWith' that emits them. + +-- | 'eqlSearch' builds the 'BHRequest' for the EQL +-- @POST /{index}/_eql/search@ endpoint (Elasticsearch >= 7.10). The body +-- is the encoded 'EQLRequest' (whose 'eqlQuery' field holds the EQL +-- source); the response is parsed into 'EQLResult'. +-- +-- The result is parameterized by the document-source type @a@: pass the +-- concrete type you want @_source@ decoded into (e.g. +-- @eqlSearch \@MyEvent ...@). +-- +-- Equivalent to @'eqlSearchWith' indexName 'defaultEQLSearchOptions' req@. +-- For URI query parameters (@allow_no_indices@, @expand_wildcards@, +-- @ignore_unavailable@, @ccs_minimize_roundtrips@, @keep_alive@, +-- @keep_on_completion@, @wait_for_completion_timeout@), use +-- 'eqlSearchWith'. The 8.x-only @allow_partial_search_results@ and +-- @allow_partial_sequence_results@ URI parameters are not emitted on the +-- ES7 wire; see 'eqlSearchWith' for details. +-- +-- For more information see +-- . +eqlSearch :: + (FromJSON a) => + IndexName -> + EQLRequest -> + BHRequest StatusDependant (ParsedEsResponse (EQLResult a)) +eqlSearch indexName = eqlSearchWith indexName defaultEQLSearchOptions + +-- | 'eqlSearchWith' is the fully-parameterised form of 'eqlSearch'. Every +-- URI parameter accepted by @/{index}/_eql/search@ is exposed via +-- 'EQLSearchOptions'; the 'EQLRequest' body carries the @query@ and every +-- other body parameter. 'defaultEQLSearchOptions' makes this +-- byte-for-byte identical to the simple form (modulo the extra body +-- fields you set). +-- +-- The body is encoded via the 'EQLRequestBodyES7' newtype, which omits +-- the three 8.x-only body keys (@allow_partial_search_results@, +-- @allow_partial_sequence_results@, @case_sensitive@) so the wire shape +-- matches the 7.17 spec. The URI parameters are rendered with +-- 'eqlSearchOptionsParams7', which likewise omits the 8.x-only URI +-- parameters. The ES8\/ES9 'eqlSearchWith' variants use the 8-form +-- encoders. +-- +-- The result is parameterized by the document-source type @a@: pass the +-- concrete type you want @_source@ decoded into (e.g. +-- @eqlSearchWith \@MyEvent ...@). +-- +-- For more information see +-- . +eqlSearchWith :: + (FromJSON a) => + IndexName -> + EQLSearchOptions -> + EQLRequest -> + BHRequest StatusDependant (ParsedEsResponse (EQLResult a)) +eqlSearchWith indexName opts req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (EQLRequestBodyES7 req)) + where + endpoint = + mkEndpoint [unIndexName indexName, "_eql", "search"] + `withQueries` eqlSearchOptionsParams7 opts + +-- | 'getEQLSearch' builds the 'BHRequest' for the async EQL +-- @GET /_eql/search\/{id}@ endpoint (Elasticsearch >= 7.10), which +-- fetches the deferred results of an EQL search whose +-- 'eqlWaitForCompletionTimeout' elapsed before completion. +-- +-- The @id@ is the 'EQLSearchId' returned in the initial 'eqlSearch' +-- response; the result is the same 'EQLResult' shape, parameterized by +-- the document-source type @a@ (pass the concrete type with +-- @getEQLSearch \@MyEvent ...@). +-- +-- The optional 'Text' sets @wait_for_completion_timeout@ as a query +-- parameter (duration string such as @"5s"@); 'Nothing' uses the +-- server default (return immediately with the current state). This +-- matches the 'getAsyncESQL' polling primitive so callers can long-poll +-- a still-running search instead of tight-looping. +-- +-- For more information see +-- . +getEQLSearch :: + (FromJSON a) => + EQLSearchId -> + Maybe T.Text -> + BHRequest StatusDependant (ParsedEsResponse (EQLResult a)) +getEQLSearch (EQLSearchId searchId) mTimeout = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_eql", "search", searchId] + `withQueries` eqlWaitForCompletionTimeoutQuery mTimeout + +-- | Render the @wait_for_completion_timeout@ query parameter used by +-- @GET /_eql/search\/{id}@. 'Nothing' omits the parameter entirely, +-- letting Elasticsearch apply its own default. The analogous async +-- ES|QL poll ('Database.Bloodhound.ElasticSearch8.Requests.getAsyncESQLWith') +-- renders its parameters via 'Database.Bloodhound.ElasticSearch8.Types.GetAsyncESQLOptions'. +eqlWaitForCompletionTimeoutQuery :: Maybe T.Text -> [(T.Text, Maybe T.Text)] +eqlWaitForCompletionTimeoutQuery = \case + Nothing -> [] + Just t -> [("wait_for_completion_timeout", Just t)] + +-- | 'getEQLStatus' builds the 'BHRequest' for the async EQL +-- @GET /_eql/search/status\/{id}@ endpoint (Elasticsearch >= 7.10), +-- which returns only the status of an async EQL search without fetching +-- the results. +-- +-- The @id@ is the 'EQLSearchId' returned in the initial 'eqlSearch' +-- response. The response is an 'EQLStatus' carrying 'eqlStatusIsRunning', +-- 'eqlStatusIsPartial', and (once complete) 'eqlStatusCompletionStatus'. +-- +-- The wire format is identical across ES 7.x, 8.x and 9.x, so the +-- request builder lives here and is re-exported by the ES8 and ES9 +-- client modules. +-- +-- For more information see +-- . +getEQLStatus :: + EQLSearchId -> + BHRequest StatusDependant EQLStatus +getEQLStatus (EQLSearchId searchId) = + get @StatusDependant (mkEndpoint ["_eql", "search", "status", searchId]) + +-- | 'deleteEQLSearch' builds the 'BHRequest' for the EQL +-- @DELETE /_eql/search/{id}@ endpoint (Elasticsearch >= 7.10), which +-- deletes an async EQL search result and its context by id. Returns +-- 'Acknowledged' on success. +-- +-- The wire format is identical across ES 7.x, 8.x and 9.x, so the +-- request builder lives here and is re-exported by the ES8 and ES9 +-- client modules. +-- +-- For more information see +-- . +deleteEQLSearch :: + EQLSearchId -> + BHRequest StatusIndependant Acknowledged +deleteEQLSearch (EQLSearchId i) = + delete (mkEndpoint ["_eql", "search", i]) + +-- $termsEnum +-- +-- /Terms Enum/ (Elasticsearch >= 7.10) returns the terms of a field +-- for auto-complete use cases. The endpoint is @GET \/{index}\/_terms_enum@ +-- and carries its parameters (the @field@ to inspect, an optional +-- @string@ prefix, @size@, @timeout@, @case_insensitive@, @index_filter@, +-- @search_after@) in the request body — see 'getWithBody'. The wire format is identical across +-- ES 7.x, 8.x and 9.x, so the request builders live here and are +-- re-exported by the ES8 and ES9 client modules. + +-- | 'getTermsEnum' returns a list of terms in @field@ for +-- auto-complete use cases. Pass a non-empty index list (or a single +-- index) to target; @'Nothing'@ or @'Just' []@ produces the bare +-- @GET /_terms_enum@ path, which Elasticsearch rejects because a +-- @@ path segment is mandatory — callers should therefore +-- always pass a non-empty list. The optional 'Text' is the @string@ +-- prefix to match (auto-complete seed); 'Nothing' asks for any term +-- the server is willing to return. +-- +-- Equivalent to @'getTermsEnumWith' mIndices 'defaultTermsEnumOptions' req@ +-- with @req@ carrying only the @field@ and the optional @string@. For +-- @size@, @timeout@, @case_insensitive@, @index_filter@ or +-- @search_after@, use 'getTermsEnumWith'. +-- +-- For more information see +-- . +getTermsEnum :: + Maybe [IndexName] -> + FieldName -> + Maybe T.Text -> + BHRequest StatusDependant TermsEnumResponse +getTermsEnum mIndices field mString = + getTermsEnumWith mIndices defaultTermsEnumOptions req + where + req = + (defaultTermsEnumRequest field) + { termsEnumRequestString = mString + } + +-- | 'getTermsEnumWith' is the fully-parameterised form of +-- 'getTermsEnum'. Every URI parameter accepted by +-- @/{index}/_terms_enum@ is exposed via 'TermsEnumOptions' +-- (@allow_no_indices@, @expand_wildcards@, @ignore_unavailable@); the +-- 'TermsEnumRequest' body carries the @field@, the optional @string@ +-- prefix and every other body parameter. 'defaultTermsEnumOptions' +-- makes this byte-for-byte identical to the simple form (modulo the +-- extra body fields you set). +getTermsEnumWith :: + Maybe [IndexName] -> + TermsEnumOptions -> + TermsEnumRequest -> + BHRequest StatusDependant TermsEnumResponse +getTermsEnumWith mIndices opts req = + getWithBody @StatusDependant endpoint (encode req) + where + endpoint = path `withQueries` termsEnumOptionsParams opts + path = + case mIndices of + Nothing -> ["_terms_enum"] + Just [] -> ["_terms_enum"] + Just (first : rest) -> + [T.intercalate "," (map unIndexName (first : rest)), "_terms_enum"] + +-- | 'syncedFlushIndex' performs a synced flush on an index. Maps to the +-- deprecated @POST \/{index}/_flush/synced@ endpoint, which was +-- deprecated in 7.6 and /removed in Elasticsearch 8.0/. A regular +-- 'Database.Bloodhound.Common.Requests.flushIndex' has the same effect +-- on 7.6+; prefer it for new code. +-- +-- Equivalent to +-- @'syncedFlushIndexWith' 'defaultSyncedFlushOptions'@. Use the @With@ +-- variant to pass @ignore_unavailable@, @allow_no_indices@ or +-- @expand_wildcards@. +-- +-- Returns 'SyncedFlushResult' (a top-level @_shards@ summary plus a +-- per-index breakdown of how many shards sync-flushed cleanly). +-- +-- See +-- . +-- +-- @since 0.26.0.0 +{-# DEPRECATED syncedFlushIndex "Synced flush was deprecated in ES 7.6 and removed in 8.0. Use flushIndex instead. See " #-} +syncedFlushIndex :: + IndexName -> + BHRequest StatusDependant SyncedFlushResult +syncedFlushIndex = syncedFlushIndexWith defaultSyncedFlushOptions + +-- | 'syncedFlushIndexWith' is the fully-parameterised form of +-- 'syncedFlushIndex'. Every URI parameter accepted by +-- @POST \/{index}/_flush/synced@ is exposed via 'SyncedFlushOptions'; +-- pass 'defaultSyncedFlushOptions' to reproduce the parameterless +-- behaviour. +-- +-- See +-- . +-- +-- @since 0.26.0.0 +{-# DEPRECATED syncedFlushIndexWith "Synced flush was deprecated in ES 7.6 and removed in 8.0. Use flushIndex instead. See " #-} +syncedFlushIndexWith :: + SyncedFlushOptions -> + IndexName -> + BHRequest StatusDependant SyncedFlushResult +syncedFlushIndexWith opts indexName = + post endpoint emptyBody + where + endpoint = + [unIndexName indexName, "_flush", "synced"] + `withQueries` syncedFlushOptionsParams opts + +-- | 'freezeIndex' freezes an index. Maps to the deprecated +-- @POST \/{index}/_freeze@ endpoint, which was deprecated in 7.14 and +-- /removed in Elasticsearch 8.0/. Frozen indices are not supported on +-- newer versions; avoid this in new code. +-- +-- Returns 'ShardsResult' (the @{\"_shards\": {...}}@ envelope). +-- +-- See +-- +-- and the freeze API notes. +-- +-- @since 0.26.0.0 +{-# DEPRECATED freezeIndex "Freeze index was deprecated in ES 7.14 and removed in 8.0. See " #-} +freezeIndex :: IndexName -> BHRequest StatusDependant ShardsResult +freezeIndex indexName = + post [unIndexName indexName, "_freeze"] emptyBody + +-- | 'unfreezeIndex' unfreezes an index. Maps to the deprecated +-- @POST \/{index}/_unfreeze@ endpoint, which was deprecated in 7.14 and +-- /removed in Elasticsearch 8.0\. Avoid this in new code. +-- +-- Returns 'ShardsResult' (the @{\"_shards\": {...}}@ envelope). +-- +-- @since 0.26.0.0 +{-# DEPRECATED unfreezeIndex "Unfreeze index was deprecated in ES 7.14 and removed in 8.0. See " #-} +unfreezeIndex :: IndexName -> BHRequest StatusDependant ShardsResult +unfreezeIndex indexName = + post [unIndexName indexName, "_unfreeze"] emptyBody diff --git a/src/Database/Bloodhound/ElasticSearch7/Types.hs b/src/Database/Bloodhound/ElasticSearch7/Types.hs --- a/src/Database/Bloodhound/ElasticSearch7/Types.hs +++ b/src/Database/Bloodhound/ElasticSearch7/Types.hs @@ -1,7 +1,118 @@ module Database.Bloodhound.ElasticSearch7.Types ( module Reexport, + EQLRequest (..), + EQLResult (..), + EQLHits (..), + EQLHit (..), + EQLTotal (..), + EQLTotalRelation (..), + EQLResultPosition (..), + EQLSearchId (..), + EQLSequence (..), + EQLStatus (..), + EQLSearchOptions (..), + defaultEQLSearchOptions, + eqlSearchOptionsParams7, + eqlSearchOptionsParams8, + EQLRequestBodyES7 (..), + EQLRequestBodyES8 (..), + eqlQueryLens, + eqlWaitForCompletionTimeoutLens, + eqlKeepOnCompletionLens, + eqlKeepAliveLens, + eqlSizeLens, + eqlFetchSizeLens, + eqlFieldsLens, + eqlFilterLens, + eqlResultPositionLens, + eqlTiebreakerFieldLens, + eqlEventCategoryFieldLens, + eqlTimestampFieldLens, + eqlRuntimeMappingsLens, + eqlAllowPartialSearchResultsLens, + eqlAllowPartialSequenceResultsLens, + eqlCaseSensitiveLens, + esoAllowNoIndicesLens, + esoAllowPartialSearchResultsLens, + esoAllowPartialSequenceResultsLens, + esoExpandWildcardsLens, + esoIgnoreUnavailableLens, + esoCcsMinimizeRoundtripsLens, + esoKeepAliveLens, + esoKeepOnCompletionLens, + esoWaitForCompletionTimeoutLens, + eqlIdLens, + eqlIsRunningLens, + eqlIsPartialLens, + eqlTimedOutLens, + eqlTookLens, + eqlHitsLens, + eqlHitsTotalLens, + eqlHitsEventsLens, + eqlHitsSequencesLens, + eqlSequenceEventsLens, + eqlSequenceJoinKeysLens, + eqlHitIndexLens, + eqlHitDocIdLens, + eqlHitScoreLens, + eqlHitSourceLens, + eqlHitVersionLens, + eqlHitSeqNoLens, + eqlHitPrimaryTermLens, + eqlHitFieldsLens, + eqlTotalValueLens, + eqlTotalRelationLens, + eqlSearchIdLens, + eqlStatusIdLens, + eqlStatusIsRunningLens, + eqlStatusIsPartialLens, + eqlStatusStartTimeInMillisLens, + eqlStatusCompletionStatusLens, + eqlStatusExpirationTimeInMillisLens, + resultPositionToText, + resultPositionFromText, + + -- * Data Streams + -- $dataStreams + + -- * Terms Enum + TermValue (..), + TermsEnumRequest (..), + defaultTermsEnumRequest, + TermsEnumOptions (..), + defaultTermsEnumOptions, + termsEnumOptionsParams, + TermsEnumResponse (..), + termsEnumRequestFieldLens, + termsEnumRequestStringLens, + termsEnumRequestSizeLens, + termsEnumRequestTimeoutLens, + termsEnumRequestCaseInsensitiveLens, + termsEnumRequestIndexFilterLens, + termsEnumRequestSearchAfterLens, + teoAllowNoIndicesLens, + teoExpandWildcardsLens, + teoIgnoreUnavailableLens, + termsEnumResponseShardsLens, + termsEnumResponseTermsLens, + termsEnumResponseCompleteLens, ) where import Database.Bloodhound.Common.Types as Reexport +import Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.DataStream as Reexport +import Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.EventQueryLanguage import Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.PointInTime as Reexport +import Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.SyncedFlush as Reexport +import Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.TermsEnum + +-- $dataStreams +-- +-- The "Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.DataStream" +-- module defines types for representing ES Data Streams ('DataStream', +-- 'DataStreamName', 'DataStreamStatus', etc.). These types are re-exported +-- here so they are reachable from the public API. The full Data Streams +-- client API (create / exists / get / delete, migrate, promote, stats, +-- lifecycle) lives in +-- "Database.Bloodhound.ElasticSearch7.Requests" and is re-exported by the +-- ES8 and ES9 client modules. diff --git a/src/Database/Bloodhound/ElasticSearch8/Client.hs b/src/Database/Bloodhound/ElasticSearch8/Client.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/ElasticSearch8/Client.hs @@ -0,0 +1,1684 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Database.Bloodhound.ElasticSearch8.Client +-- Description : Elasticsearch 8 client (re-exports Common + ES8-specific APIs) +-- +-- The Elasticsearch 8 client. Re-exports the version-agnostic "Database.Bloodhound.Common.Client" +-- surface and adds ES8-specific features: k-NN search, point in time (PIT), ES|QL +-- and EQL (sync and async, plus ES|QL views), data streams and lifecycles, query +-- rulesets, search applications, inference endpoints, and the terms enum API. +module Database.Bloodhound.ElasticSearch8.Client + ( module Reexport, + esql, + esqlWith, + eqlSearch, + eqlSearchWith, + getEQLSearch, + getEQLStatus, + deleteEQLSearch, + esqlAsync, + esqlAsyncWith, + getAsyncESQL, + getAsyncESQLWith, + deleteAsyncESQL, + stopAsyncESQL, + getDataStreams, + getDataStreamStats, + createDataStream, + dataStreamExists, + deleteDataStream, + migrateToDataStream, + promoteDataStream, + putDataStreamLifecycle, + putDataStreamsLifecycle, + getDataStreamLifecycle, + deleteDataStreamLifecycle, + modifyDataStream, + getDataStreamOptions, + updateDataStreamOptions, + deleteDataStreamOptions, + getDataStreamLifecycleStats, + explainDataStreamLifecycle, + explainDataStreamLifecycleWith, + ExplainDataStreamLifecycleOptions (..), + defaultExplainDataStreamLifecycleOptions, + knnSearch, + pitSearch, + pitSearchWith, + openPointInTime, + openPointInTimeWith, + openPointInTimeWithBody, + closePointInTime, + putInferenceEndpoint, + putInferenceEndpointWith, + updateInferenceEndpoint, + getInferenceEndpoints, + deleteInferenceEndpoint, + deleteInferenceEndpointWith, + runInference, + runInferenceWith, + streamCompletionInference, + streamCompletionInferenceWith, + streamChatCompletionInference, + streamChatCompletionInferenceWith, + putQueryRuleset, + getQueryRuleset, + deleteQueryRuleset, + testQueryRuleset, + putSearchApplication, + putSearchApplicationWith, + getSearchApplication, + deleteSearchApplication, + searchApplication, + searchApplicationWith, + listSearchApplications, + listSearchApplicationsWith, + renderSearchApplicationQuery, + putSynonymsSet, + getSynonymsSet, + getSynonymsSetWith, + deleteSynonymsSet, + getAnalyticsCollections, + putAnalyticsCollection, + deleteAnalyticsCollection, + postAnalyticsEvent, + postAnalyticsEventWith, + createConnector, + putConnector, + getConnector, + deleteConnector, + deleteConnectorWith, + listConnectors, + listConnectorsWith, + checkInConnector, + updateConnectorApiKeyId, + updateConnectorConfiguration, + updateConnectorError, + updateConnectorFeatures, + updateConnectorFiltering, + updateConnectorDraftFilteringValidation, + activateConnectorDraftFiltering, + updateConnectorIndexName, + updateConnectorNameDescription, + updateConnectorNative, + updateConnectorPipeline, + updateConnectorScheduling, + updateConnectorServiceType, + updateConnectorStatus, + createConnectorSyncJob, + getConnectorSyncJob, + listConnectorSyncJobs, + listConnectorSyncJobsWith, + deleteConnectorSyncJob, + cancelConnectorSyncJob, + checkInConnectorSyncJob, + claimConnectorSyncJob, + setConnectorSyncJobError, + setConnectorSyncJobStats, + migrateReindex, + cancelMigrateReindex, + getMigrateReindexStatus, + createIndexFrom, + createIndexFromWith, + MigrateReindexMode (..), + MigrateReindexSource (..), + MigrateReindexRequest (..), + mkMigrateReindexRequest, + MigrateReindexInProgress (..), + MigrateReindexError (..), + MigrateReindexStatus (..), + CreateIndexFromBody (..), + defaultCreateIndexFromBody, + CreateIndexFromResponse (..), + getTermsEnum, + getTermsEnumWith, + TermValue (..), + TermsEnumRequest (..), + defaultTermsEnumRequest, + TermsEnumOptions (..), + defaultTermsEnumOptions, + termsEnumOptionsParams, + TermsEnumResponse (..), + ) +where + +import Control.Monad +import Data.Aeson +import Data.ByteString.Lazy qualified as L +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Database.Bloodhound.Client.Cluster +import Database.Bloodhound.Common.Client as Reexport +import Database.Bloodhound.Common.Requests as Requests +import Database.Bloodhound.ElasticSearch7.Requests qualified as Requests7 +import Database.Bloodhound.ElasticSearch7.Types +import Database.Bloodhound.ElasticSearch8.Requests qualified as Requests8 +import Database.Bloodhound.ElasticSearch8.Types +import Database.Bloodhound.Internal.Utils.Requests +import Prelude hiding (filter, head) + +-- | 'pitSearch' uses the point in time (PIT) API of elastic, for a given +-- 'IndexName'. Requires Elasticsearch >=7.10. The supplied 'KeepAlive' +-- duration is forwarded to every PIT open\/extend call. Note that this will +-- consume the entire search result set and will be doing O(n) list appends so +-- this may not be suitable for large result sets. In that case, the point in +-- time API should be used directly with `openPointInTime` and `closePointInTime`. +-- +-- This is a convenience wrapper around 'pitSearchWith' that lifts the +-- single 'IndexName' into an 'IndexPattern'. To search across multiple +-- comma-joined indices or a wildcard pattern, use 'pitSearchWith' +-- directly with an 'IndexPattern'. +-- +-- Note that 'pitSearch' utilizes the 'search_after' parameter under the hood, +-- which requires a non-empty 'sortBody' field in the provided 'Search' value. +-- Otherwise, 'pitSearch' will fail to return all matching documents. +-- +-- For more information see +-- . +pitSearch :: + forall a m. + (FromJSON a, MonadBH m, WithBackend ElasticSearch8 m) => + IndexName -> + KeepAlive -> + Search -> + m [Hit a] +pitSearch indexName = pitSearchWith (IndexPattern (unIndexName indexName)) + +-- | 'pitSearchWith' is the parameterized variant of 'pitSearch': it +-- takes an 'IndexPattern' as the target, which may be a single index +-- name, a comma-separated list of indices, or a wildcard pattern +-- (e.g. @\"logs-*\"@, @\"logs-2024,logs-2025\"@). Otherwise behaves +-- exactly like 'pitSearch'. See 'openPointInTimeWith' for the target +-- rendering. +-- +-- For more information see +-- . +pitSearchWith :: + forall a m. + (FromJSON a, MonadBH m, WithBackend ElasticSearch8 m) => + IndexPattern -> + KeepAlive -> + Search -> + m [Hit a] +pitSearchWith indexPattern keepAlive search = do + openResp <- openPointInTimeWith indexPattern keepAlive defaultPITOptions + case openResp of + Left e -> throwEsError e + Right OpenPointInTimeResponse {..} -> do + let searchPIT = search {pointInTime = Just (PointInTime oPitId (Just keepAlive))} + hits <- pitAccumulator searchPIT [] + closeResp <- closePointInTime (ClosePointInTime oPitId) + case closeResp of + Left _ -> return [] + Right (ClosePointInTimeResponse False _) -> + error "failed to close point in time (PIT)" + Right (ClosePointInTimeResponse True _) -> return hits + where + pitAccumulator :: Search -> [Hit a] -> m [Hit a] + pitAccumulator search' oldHits = do + resp <- tryPerformBHRequest $ Requests.searchAll search' + case resp of + Left _ -> return [] + Right searchResult -> case hits (searchHits searchResult) of + [] -> return oldHits + newHits -> case (hitSort $ last newHits, pitId searchResult) of + (Nothing, Nothing) -> + error "no point in time (PIT) ID or last sort value" + (Just _, Nothing) -> error "no point in time (PIT) ID" + (Nothing, _) -> return (oldHits <> newHits) + (Just lastSort, Just pitId') -> do + let newSearch = + search' + { pointInTime = Just (PointInTime pitId' (Just keepAlive)), + searchAfterKey = Just lastSort + } + pitAccumulator newSearch (oldHits <> newHits) + +-- | 'openPointInTime' opens a point in time for an index given an 'IndexName' +-- and a 'KeepAlive' duration (e.g. @keepAliveMinutes 1@). Note that the point +-- in time should be closed with 'closePointInTime' as soon as it is no longer +-- needed. +-- +-- Equivalent to 'openPointInTimeWith' with +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.defaultPITOptions' +-- (no optional URI parameters). +-- +-- For more information see +-- . +openPointInTime :: + (MonadBH m, WithBackend ElasticSearch8 m) => + IndexName -> + KeepAlive -> + m (ParsedEsResponse OpenPointInTimeResponse) +openPointInTime indexName keepAlive = performBHRequest $ Requests7.openPointInTime indexName keepAlive + +-- | 'openPointInTimeWith' is the parameterized variant of +-- 'openPointInTime': it takes an 'IndexPattern' target (single name, +-- comma-list, or wildcard) and forwards the supplied 'PITOptions' as +-- query-string parameters in addition to the mandatory @keep_alive@. +-- Delegates to the ES7 request builder because the wire format is +-- identical across ES 7.x, 8.x and 9.x. See +-- 'Database.Bloodhound.ElasticSearch7.Requests.openPointInTimeWith' +-- for which parameters are emitted. +-- +-- For more information see +-- . +openPointInTimeWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + IndexPattern -> + KeepAlive -> + PITOptions -> + m (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWith indexPattern keepAlive opts = + performBHRequest $ Requests7.openPointInTimeWith indexPattern keepAlive opts + +-- | 'openPointInTimeWithBody' is the body-carrying variant of +-- 'openPointInTimeWith': it sends the supplied 'OpenPointInTimeBody' as +-- the JSON request body (the only way to supply an @index_filter@ +-- query), in addition to the 'PITOptions' URI parameters and the +-- mandatory @keep_alive@. The 'IndexPattern' target follows the same +-- rules as 'openPointInTimeWith'. Delegates to the ES7 request builder +-- because the wire format is identical across ES 7.x, 8.x and 9.x. See +-- 'Database.Bloodhound.ElasticSearch7.Requests.openPointInTimeWithBody'. +-- +-- For more information see +-- . +openPointInTimeWithBody :: + (MonadBH m, WithBackend ElasticSearch8 m) => + IndexPattern -> + KeepAlive -> + OpenPointInTimeBody -> + PITOptions -> + m (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWithBody indexPattern keepAlive body opts = + performBHRequest $ Requests7.openPointInTimeWithBody indexPattern keepAlive body opts + +-- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'. +-- +-- For more information see +-- . +closePointInTime :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ClosePointInTime -> + m (ParsedEsResponse ClosePointInTimeResponse) +closePointInTime q = performBHRequest $ Requests7.closePointInTime q + +-- | knnSearch executes a k-NN vector search request for Elasticsearch 8+. +-- +-- In ES8 the standalone @\/{index}\/_knn_search@ endpoint no longer exists: +-- kNN is a top-level @\"knn\"@ clause inside a standard +-- @POST \/{index}\/_search@ body. This function injects the supplied +-- 'KnnQuery' as a single-element @\"knn\"@ array on the body of the given +-- 'Search' and POSTs it to @\/{index}\/_search@. +-- +-- For more information see +-- . +knnSearch :: + (FromJSON a) => + IndexName -> + KnnQuery -> + Search -> + BHRequest StatusDependant (SearchResult a) +knnSearch indexName knnQuery search = + post @StatusDependant endpoint (encode searchWithKnn) + where + endpoint = mkEndpoint [unIndexName indexName, "_search"] + searchWithKnn = search {knnBody = Just [knnQuery]} + +-- | 'esql' executes an ES|QL query synchronously via @POST /_query@ +-- (Elasticsearch 8.11+). The result is returned as an 'ESQLResult' containing +-- column descriptors and row values. +-- +-- For more information see +-- . +esql :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ESQLRequest -> + m (ParsedEsResponse ESQLResult) +esql = performBHRequest . Requests8.esql + +-- | 'esqlWith' executes an ES|QL query synchronously via @POST /_query@ +-- (Elasticsearch 8.11+) with the documented URI query parameters +-- ('ESQLQueryOptions'). Pass 'defaultESQLQueryOptions' to behave +-- identically to 'esql'. +-- +-- For more information see +-- . +esqlWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ESQLRequest -> + ESQLQueryOptions -> + m (ParsedEsResponse ESQLResult) +esqlWith req = performBHRequest . Requests8.esqlWith req + +-- | 'esqlAsync' submits a long-running ES|QL query via @POST /_query/async@ +-- (Elasticsearch 8.11+). The 'AsyncESQLRequest' carries both the base +-- query and the async-only body parameters (@wait_for_completion_timeout@, +-- @keep_alive@, @keep_on_completion@, ...). Construct one with +-- 'mkAsyncESQLRequest' from a plain 'ESQLRequest', then populate the +-- async fields via their lenses. Poll the returned id with 'getAsyncESQL'. +-- +-- For more information see +-- . +esqlAsync :: + (MonadBH m, WithBackend ElasticSearch8 m) => + AsyncESQLRequest -> + m (ParsedEsResponse AsyncESQLResult) +esqlAsync = performBHRequest . Requests8.esqlAsync + +-- | 'esqlAsyncWith' submits a long-running ES|QL query via +-- @POST /_query/async@ (Elasticsearch 8.11+) with the documented URI +-- query parameters ('ESQLQueryOptions') — the same parameter surface as +-- the synchronous 'esqlWith', minus @format@. The body is built as for +-- 'esqlAsync'. Pass 'defaultESQLQueryOptions' to behave identically to +-- 'esqlAsync'. +-- +-- For more information see +-- . +esqlAsyncWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + AsyncESQLRequest -> + ESQLQueryOptions -> + m (ParsedEsResponse AsyncESQLResult) +esqlAsyncWith req = performBHRequest . Requests8.esqlAsyncWith req + +-- | 'getAsyncESQL' polls an async ES|QL query by id, returning its current +-- state and (partial or final) results. Maps to +-- @GET /_query/async/{id}@. The optional 'Text' sets +-- @wait_for_completion_timeout@ as a duration-string query parameter +-- (e.g. @"5s"@). +-- +-- For more information see +-- . +getAsyncESQL :: + (MonadBH m, WithBackend ElasticSearch8 m) => + AsyncESQLId -> + Maybe Text -> + m (ParsedEsResponse AsyncESQLResult) +getAsyncESQL = (performBHRequest .) . Requests8.getAsyncESQL + +-- | 'getAsyncESQLWith' is the fully-parameterised form of 'getAsyncESQL', +-- exposing every URI parameter accepted by @GET /_query/async/{id}@ via +-- 'GetAsyncESQLOptions' (@wait_for_completion_timeout@, @keep_alive@, +-- @drop_null_columns@). Pass 'defaultGetAsyncESQLOptions' to reproduce +-- the behaviour of @'getAsyncESQL' id 'Nothing'@. +-- +-- For more information see +-- . +getAsyncESQLWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + AsyncESQLId -> + GetAsyncESQLOptions -> + m (ParsedEsResponse AsyncESQLResult) +getAsyncESQLWith = (performBHRequest .) . Requests8.getAsyncESQLWith + +-- | 'deleteAsyncESQL' deletes an async ES|QL result and its context by id. +-- Maps to @DELETE /_query/async/{id}@ and returns 'Acknowledged' on success. +-- Deleting a non-existent or already-purged async id surfaces as an +-- 'EsError' (a @404@ with an error body); wrap with 'tryEsError' for +-- miss-tolerant deletion. +-- +-- For more information see +-- . +deleteAsyncESQL :: + (MonadBH m, WithBackend ElasticSearch8 m) => + AsyncESQLId -> + m Acknowledged +deleteAsyncESQL = performBHRequest . Requests8.deleteAsyncESQL + +-- | 'stopAsyncESQL' requests the server to stop a running async ES|QL +-- query by id. Maps to @POST /_query/async/{id}/stop@ (Elasticsearch +-- 8.11+) and returns the final 'AsyncESQLResult' — @is_running@ will be +-- @False@ and @columns@\/@values@ carry whatever the query produced +-- before being stopped. +-- +-- For more information see +-- . +stopAsyncESQL :: + (MonadBH m, WithBackend ElasticSearch8 m) => + AsyncESQLId -> + m (ParsedEsResponse AsyncESQLResult) +stopAsyncESQL = performBHRequest . Requests8.stopAsyncESQL + +-- | 'putInferenceEndpoint' creates or updates an inference endpoint via +-- @PUT \/_inference\/{task_type}\/{inference_id}@ (Elasticsearch 8.12+). +-- The 'InferenceProvider' inside the 'InferenceConfig' selects the backing +-- service (OpenAI, Cohere, ELSER, or a generic provider). +-- +-- For more information see +-- . +putInferenceEndpoint :: + (MonadBH m, WithBackend ElasticSearch8 m) => + TaskType -> + InferenceId -> + InferenceConfig -> + m (ParsedEsResponse InferencePutResponse) +putInferenceEndpoint taskType' inferenceId config = + performBHRequest $ Requests8.putInferenceEndpoint taskType' inferenceId config + +-- | Fully-parameterised form of 'putInferenceEndpoint'. Pass +-- 'PutInferenceOptions' to attach the @timeout@ query parameter; see +-- 'Requests.putInferenceEndpointWith'. +-- +-- For more information see +-- . +putInferenceEndpointWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + TaskType -> + InferenceId -> + InferenceConfig -> + PutInferenceOptions -> + m (ParsedEsResponse InferencePutResponse) +putInferenceEndpointWith taskType' inferenceId config opts = + performBHRequest $ Requests8.putInferenceEndpointWith taskType' inferenceId config opts + +-- | 'updateInferenceEndpoint' partially updates an existing inference +-- endpoint via @PUT \/_inference\/{task_type}\/{inference_id}\/_update@ +-- (Elasticsearch 8.12+). Unlike 'putInferenceEndpoint', omitted fields in +-- the 'InferenceConfig' are left unchanged rather than replaced. The +-- updated endpoint is returned as an 'InferenceInfo'. +-- +-- For more information see +-- . +updateInferenceEndpoint :: + (MonadBH m, WithBackend ElasticSearch8 m) => + TaskType -> + InferenceId -> + InferenceConfig -> + m (ParsedEsResponse InferenceInfo) +updateInferenceEndpoint taskType' inferenceId config = + performBHRequest $ Requests8.updateInferenceEndpoint taskType' inferenceId config + +-- | 'getInferenceEndpoints' lists configured inference endpoints via the +-- @GET \/_inference@ family (Elasticsearch 8.12+). Both filters are +-- optional: +-- +-- * @'Nothing'@ task type → list every endpoint; +-- * @'Just' tt@, no id → list endpoints of the given task type; +-- * @'Just' tt@, @'Just' iid@ → fetch a single endpoint. +-- +-- Passing @'Just' iid@ without a task type is not a valid Elasticsearch +-- URL; the builder falls back to listing every endpoint in that case. +-- +-- For more information see +-- . +getInferenceEndpoints :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe TaskType -> + Maybe InferenceId -> + m [InferenceInfo] +getInferenceEndpoints mTaskType mInferenceId = + performBHRequest $ Requests8.getInferenceEndpoints mTaskType mInferenceId + +-- | 'deleteInferenceEndpoint' deletes an inference endpoint via +-- @DELETE \/_inference\/{task_type}\/{inference_id}@ (Elasticsearch 8.12+). +-- Deleting a non-existent endpoint surfaces as an 'EsError' (the underlying +-- request builder is 'StatusDependant'); wrap with 'tryPerformBHRequest' for +-- miss-tolerant deletion. +-- +-- For more information see +-- . +deleteInferenceEndpoint :: + (MonadBH m, WithBackend ElasticSearch8 m) => + TaskType -> + InferenceId -> + m Acknowledged +deleteInferenceEndpoint taskType' inferenceId = + performBHRequest $ Requests8.deleteInferenceEndpoint taskType' inferenceId + +-- | Fully-parameterised form of 'deleteInferenceEndpoint'. Pass +-- 'DeleteInferenceOptions' to attach the @dry_run@ and @force@ query +-- parameters; see 'Requests.deleteInferenceEndpointWith'. +-- +-- For more information see +-- . +deleteInferenceEndpointWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + TaskType -> + InferenceId -> + DeleteInferenceOptions -> + m Acknowledged +deleteInferenceEndpointWith taskType' inferenceId opts = + performBHRequest $ Requests8.deleteInferenceEndpointWith taskType' inferenceId opts + +-- | 'runInference' performs inference against an existing endpoint via +-- @POST \/_inference\/{task_type}\/{inference_id}@ (Elasticsearch 8.12+). +-- +-- For more information see +-- . +runInference :: + (MonadBH m, WithBackend ElasticSearch8 m) => + TaskType -> + InferenceId -> + InferenceInput -> + m (ParsedEsResponse InferenceResult) +runInference taskType' inferenceId input = + performBHRequest $ Requests8.runInference taskType' inferenceId input + +-- | Fully-parameterised form of 'runInference'. Pass 'RunInferenceOptions' +-- to attach the @timeout@ query parameter; see 'Requests.runInferenceWith'. +-- +-- For more information see +-- . +runInferenceWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + TaskType -> + InferenceId -> + InferenceInput -> + RunInferenceOptions -> + m (ParsedEsResponse InferenceResult) +runInferenceWith taskType' inferenceId input opts = + performBHRequest $ Requests8.runInferenceWith taskType' inferenceId input opts + +-- | 'streamCompletionInference' streams completion chunks from an existing +-- completion endpoint via +-- @POST \/_inference\/completion\/{inference_id}\/_stream@ (Elasticsearch +-- 8.12+). The full buffered NDJSON stream is returned as a lazy +-- 'L.ByteString'; callers split it into newline-delimited JSON chunks and +-- decode each. +-- +-- For more information see +-- . +streamCompletionInference :: + (MonadBH m, WithBackend ElasticSearch8 m) => + InferenceId -> + InferenceInput -> + m L.ByteString +streamCompletionInference inferenceId input = + performBHRequest $ Requests8.streamCompletionInference inferenceId input + +-- | Fully-parameterised form of 'streamCompletionInference'. Pass +-- 'StreamCompletionInferenceOptions' to attach the @timeout@ query +-- parameter; see 'Requests.streamCompletionInferenceWith'. +-- +-- For more information see +-- . +streamCompletionInferenceWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + InferenceId -> + InferenceInput -> + StreamCompletionInferenceOptions -> + m L.ByteString +streamCompletionInferenceWith inferenceId input opts = + performBHRequest $ Requests8.streamCompletionInferenceWith inferenceId input opts + +-- | 'streamChatCompletionInference' streams chat-completion chunks from an +-- existing chat endpoint via +-- @POST \/_inference\/chat_completion\/{inference_id}\/_stream@ +-- (Elasticsearch 8.18+). The full buffered NDJSON stream is returned as a +-- lazy 'L.ByteString'; callers split it into newline-delimited JSON chunks +-- and decode each. +-- +-- For more information see +-- . +streamChatCompletionInference :: + (MonadBH m, WithBackend ElasticSearch8 m) => + InferenceId -> + ChatCompletionRequest -> + m L.ByteString +streamChatCompletionInference inferenceId request = + performBHRequest $ Requests8.streamChatCompletionInference inferenceId request + +-- | Fully-parameterised form of 'streamChatCompletionInference'. Pass +-- 'StreamChatCompletionInferenceOptions' to attach the @timeout@ query +-- parameter; see 'Requests.streamChatCompletionInferenceWith'. +-- +-- For more information see +-- . +streamChatCompletionInferenceWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + InferenceId -> + ChatCompletionRequest -> + StreamChatCompletionInferenceOptions -> + m L.ByteString +streamChatCompletionInferenceWith inferenceId request opts = + performBHRequest $ Requests8.streamChatCompletionInferenceWith inferenceId request opts + +-- | 'putQueryRuleset' creates or updates a query ruleset via +-- @PUT \/_query_rules\/{ruleset_id}@ (Elasticsearch 8.9+). The +-- 'QueryRuleset' body carries an ordered list of 'Rule's; ES +-- evaluates them top-down and applies the actions of the first match. +-- +-- For more information see +-- . +putQueryRuleset :: + (MonadBH m, WithBackend ElasticSearch8 m) => + RulesetId -> + QueryRuleset -> + m QueryRulesetPutResponse +putQueryRuleset rulesetId ruleset = + performBHRequest $ Requests8.putQueryRuleset rulesetId ruleset + +-- | 'getQueryRuleset' fetches a query ruleset by id via +-- @GET \/_query_rules\/{ruleset_id}@ (Elasticsearch 8.9+), returning +-- a 'QueryRulesetInfo' (@ruleset_id@ and @rules@). A @404@ for a +-- missing ruleset surfaces as an 'EsError'; wrap with +-- 'tryPerformBHRequest' for miss-tolerant reads. +-- +-- For more information see +-- . +getQueryRuleset :: + (MonadBH m, WithBackend ElasticSearch8 m) => + RulesetId -> + m QueryRulesetInfo +getQueryRuleset = performBHRequest . Requests8.getQueryRuleset + +-- | 'deleteQueryRuleset' deletes a query ruleset by id via +-- @DELETE \/_query_rules\/{ruleset_id}@ (Elasticsearch 8.9+). +-- Deleting a non-existent ruleset surfaces as an 'EsError'; wrap with +-- 'tryPerformBHRequest' for miss-tolerant deletion. +-- +-- For more information see +-- . +deleteQueryRuleset :: + (MonadBH m, WithBackend ElasticSearch8 m) => + RulesetId -> + m Acknowledged +deleteQueryRuleset = performBHRequest . Requests8.deleteQueryRuleset + +-- | 'testQueryRuleset' evaluates the supplied 'QueryRulesetTest' match +-- criteria against every rule in the stored ruleset via +-- @POST \/_query_rules\/{ruleset_id}\/_test@ (Elasticsearch 8.10+). +-- The server returns a 'QueryRulesetTestResponse' whose +-- 'qrtMatched' field lists the @ruleset_id@\/@rule_id@ pairs that +-- fired. Useful for validating pinned\/exclude rules in development +-- without issuing a real search. +-- +-- For more information see +-- . +testQueryRuleset :: + (MonadBH m, WithBackend ElasticSearch8 m) => + RulesetId -> + QueryRulesetTest -> + m QueryRulesetTestResponse +testQueryRuleset rulesetId body = + performBHRequest $ Requests8.testQueryRuleset rulesetId body + +-- | 'putSearchApplication' creates or updates a search application via +-- @PUT \/_application\/search_application\/{name}@ (Elasticsearch 8.6+). +-- The body declares the target indices and optionally an analytics +-- collection name and\/or a template. The server returns +-- 'SearchApplicationPutResponse', whose @result@ field is @"created"@ +-- or @"updated"@. +-- +-- For more information see +-- . +putSearchApplication :: + (MonadBH m, WithBackend ElasticSearch8 m) => + SearchApplicationName -> + SearchApplication -> + m SearchApplicationPutResponse +putSearchApplication appName app = + performBHRequest $ Requests8.putSearchApplication appName app + +-- | 'putSearchApplicationWith' is the fully-parameterised form of +-- 'putSearchApplication'. 'SearchApplicationPutOptions' carries the +-- @create@ query parameter: @'Just' 'True'@ emits @?create=true@, which +-- makes the request fail if the search application already exists. +-- Passing 'defaultSearchApplicationPutOptions' is byte-for-byte +-- identical to 'putSearchApplication'. +-- +-- For more information see +-- . +putSearchApplicationWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + SearchApplicationName -> + SearchApplicationPutOptions -> + SearchApplication -> + m SearchApplicationPutResponse +putSearchApplicationWith appName opts app = + performBHRequest $ Requests8.putSearchApplicationWith appName opts app + +-- | 'getSearchApplication' fetches a search application by name via +-- @GET \/_application\/search_application\/{name}@ (Elasticsearch 8.6+). +-- The response includes the stored body plus the path-echoed @name@ and +-- an optional @updated_at_millis@ timestamp. A @404@ for a missing +-- application surfaces as an 'EsError'; wrap with +-- 'tryPerformBHRequest' for miss-tolerant reads. +-- +-- For more information see +-- . +getSearchApplication :: + (MonadBH m, WithBackend ElasticSearch8 m) => + SearchApplicationName -> + m SearchApplicationInfo +getSearchApplication = performBHRequest . Requests8.getSearchApplication + +-- | 'deleteSearchApplication' deletes a search application by name via +-- @DELETE \/_application\/search_application\/{name}@ (Elasticsearch +-- 8.6+). Deleting a non-existent application surfaces as an 'EsError'; +-- wrap with 'tryPerformBHRequest' for miss-tolerant deletion. +-- +-- For more information see +-- . +deleteSearchApplication :: + (MonadBH m, WithBackend ElasticSearch8 m) => + SearchApplicationName -> + m Acknowledged +deleteSearchApplication = performBHRequest . Requests8.deleteSearchApplication + +-- | 'searchApplication' runs a search application's stored template +-- against its indices via +-- @POST \/_application\/search_application\/{name}\/_search@ +-- (Elasticsearch 8.6+). The optional 'SearchApplicationSearchParams' +-- carries per-request template parameter overrides; 'Nothing' runs the +-- template with its defaults. The response is a regular 'SearchResult' +-- parameterized by the document-source type @a@. +-- +-- For more information see +-- . +searchApplication :: + (FromJSON a, MonadBH m, WithBackend ElasticSearch8 m) => + SearchApplicationName -> + Maybe SearchApplicationSearchParams -> + m (ParsedEsResponse (SearchResult a)) +searchApplication appName mParams = + performBHRequest $ Requests8.searchApplication appName mParams + +-- | Fully-parameterised form of 'searchApplication'. Pass +-- 'SearchApplicationOptions' to attach the @typed_keys@ query parameter; +-- see 'Requests.searchApplicationWith'. +-- +-- For more information see +-- . +searchApplicationWith :: + (MonadBH m, WithBackend ElasticSearch8 m, FromJSON a) => + SearchApplicationName -> + Maybe SearchApplicationSearchParams -> + SearchApplicationOptions -> + m (ParsedEsResponse (SearchResult a)) +searchApplicationWith appName mParams opts = + performBHRequest $ Requests8.searchApplicationWith appName mParams opts + +-- | 'listSearchApplications' lists configured search applications via +-- @GET \/_application\/search_application@ (Elasticsearch 8.6+). Returns +-- a 'SearchApplicationListResponse' whose @results@ each reuse the +-- 'SearchApplicationInfo' shape (typically carrying only @name@ and +-- @updated_at_millis@ per item). Use 'listSearchApplicationsWith' to +-- attach the @q@\/@from@\/@size@ query parameters. +-- +-- For more information see +-- . +listSearchApplications :: + (MonadBH m, WithBackend ElasticSearch8 m) => + m SearchApplicationListResponse +listSearchApplications = + performBHRequest Requests8.listSearchApplications + +-- | Fully-parameterised form of 'listSearchApplications'. Pass +-- 'SearchApplicationListOptions' to attach the @q@ (Lucene query-string +-- filter), @from@ (offset) and @size@ (max results) query parameters; +-- see 'Requests.listSearchApplicationsWith'. +-- +-- For more information see +-- . +listSearchApplicationsWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + SearchApplicationListOptions -> + m SearchApplicationListResponse +listSearchApplicationsWith opts = + performBHRequest $ Requests8.listSearchApplicationsWith opts + +-- | 'renderSearchApplicationQuery' renders a search application's stored +-- template against the supplied parameters and returns the resulting +-- Elasticsearch query body /without/ executing the search, via +-- @POST \/_application\/search_application\/{name}\/_render_query@ +-- (Elasticsearch 8.6+). The optional 'SearchApplicationSearchParams' +-- carries per-request template parameter overrides; 'Nothing' renders +-- the template with its defaults. The response is the rendered +-- search-request body as an opaque 'Value'. +-- +-- For more information see +-- . +renderSearchApplicationQuery :: + (MonadBH m, WithBackend ElasticSearch8 m) => + SearchApplicationName -> + Maybe SearchApplicationSearchParams -> + m Value +renderSearchApplicationQuery appName mParams = + performBHRequest $ Requests8.renderSearchApplicationQuery appName mParams + +-- | 'putSynonymsSet' creates or updates a synonyms set via +-- @PUT \/_synonyms\/{synonyms_set_id}@ (Elasticsearch 8.10+). The +-- 'SynonymsSet' body carries an ordered list of 'SynonymRule's. +-- +-- For more information see +-- . +putSynonymsSet :: + (MonadBH m, WithBackend ElasticSearch8 m) => + SynonymsSetId -> + SynonymsSet -> + m SynonymsSetPutResponse +putSynonymsSet setId body = + performBHRequest $ Requests8.putSynonymsSet setId body + +-- | 'getSynonymsSet' fetches a synonyms set by id via +-- @GET \/_synonyms\/{synonyms_set_id}@ (Elasticsearch 8.10+), +-- returning a 'SynonymsSetInfo' (@count@ and the @synonyms_set@ +-- rules). Equivalent to @'getSynonymsSetWith' setId +-- 'defaultSynonymsGetOptions'@. A @404@ for a missing set surfaces as +-- an 'EsError'; wrap with 'tryPerformBHRequest' for miss-tolerant +-- reads. +-- +-- For more information see +-- . +getSynonymsSet :: + (MonadBH m, WithBackend ElasticSearch8 m) => + SynonymsSetId -> + m SynonymsSetInfo +getSynonymsSet = performBHRequest . Requests8.getSynonymsSet + +-- | 'getSynonymsSetWith' is the fully-parameterised variant of +-- 'getSynonymsSet', accepting 'SynonymsGetOptions' (@from@\/@size@). +getSynonymsSetWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + SynonymsSetId -> + SynonymsGetOptions -> + m SynonymsSetInfo +getSynonymsSetWith setId opts = + performBHRequest $ Requests8.getSynonymsSetWith setId opts + +-- | 'deleteSynonymsSet' deletes a synonyms set by id via +-- @DELETE \/_synonyms\/{synonyms_set_id}@ (Elasticsearch 8.10+). +-- Deleting a non-existent set surfaces as an 'EsError'; wrap with +-- 'tryPerformBHRequest' for miss-tolerant deletion. +-- +-- For more information see +-- . +deleteSynonymsSet :: + (MonadBH m, WithBackend ElasticSearch8 m) => + SynonymsSetId -> + m Acknowledged +deleteSynonymsSet = performBHRequest . Requests8.deleteSynonymsSet + +-- | 'getAnalyticsCollections' lists behavioral analytics collections +-- (Elasticsearch 8.7+). @'Nothing'@ lists every collection; +-- @'Just' name@ fetches a single one. See +-- 'Requests8.getAnalyticsCollections'. +-- +-- For more information see +-- . +getAnalyticsCollections :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe AnalyticsCollectionName -> + m [AnalyticsCollection] +getAnalyticsCollections = + performBHRequest . Requests8.getAnalyticsCollections + +-- | 'putAnalyticsCollection' creates or replaces a behavioral analytics +-- collection (Elasticsearch 8.7+). See 'Requests8.putAnalyticsCollection'. +putAnalyticsCollection :: + (MonadBH m, WithBackend ElasticSearch8 m) => + AnalyticsCollectionName -> + m AnalyticsCollectionPutResponse +putAnalyticsCollection = + performBHRequest . Requests8.putAnalyticsCollection + +-- | 'deleteAnalyticsCollection' deletes a behavioral analytics +-- collection and its backing index (Elasticsearch 8.7+). See +-- 'Requests8.deleteAnalyticsCollection'. +deleteAnalyticsCollection :: + (MonadBH m, WithBackend ElasticSearch8 m) => + AnalyticsCollectionName -> + m Acknowledged +deleteAnalyticsCollection = + performBHRequest . Requests8.deleteAnalyticsCollection + +-- | 'postAnalyticsEvent' ingests a single behavioral event +-- (Elasticsearch 8.7+). See 'Requests8.postAnalyticsEvent'. +postAnalyticsEvent :: + (MonadBH m, WithBackend ElasticSearch8 m) => + AnalyticsCollectionName -> + AnalyticsEventType -> + Value -> + m AnalyticsEventResponse +postAnalyticsEvent coll evType payload = + performBHRequest $ Requests8.postAnalyticsEvent coll evType payload + +-- | 'postAnalyticsEventWith' is the fully-parameterised form of +-- 'postAnalyticsEvent'; pass 'AnalyticsEventOptions' to set @?debug=true@. +postAnalyticsEventWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + AnalyticsEventOptions -> + AnalyticsCollectionName -> + AnalyticsEventType -> + Value -> + m AnalyticsEventResponse +postAnalyticsEventWith opts coll evType payload = + performBHRequest $ + Requests8.postAnalyticsEventWith opts coll evType payload + +------------------------------------------------------------------------------ +-- Connectors (Elasticsearch 8.8+) +------------------------------------------------------------------------------ + +-- | 'createConnector' creates a connector (@POST /_connector@). See +-- 'Requests8.createConnector'. +createConnector :: + (MonadBH m, WithBackend ElasticSearch8 m) => + CreateConnectorRequest -> + m ConnectorCreateResponse +createConnector = performBHRequest . Requests8.createConnector + +-- | 'putConnector' creates or fully replaces a connector by id +-- (@PUT /_connector/{id}@). +putConnector :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + CreateConnectorRequest -> + m ConnectorCreateResponse +putConnector cid = performBHRequest . Requests8.putConnector cid + +-- | 'getConnector' fetches a connector by id. +getConnector :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + m Connector +getConnector = performBHRequest . Requests8.getConnector + +-- | 'deleteConnector' deletes a connector by id. +deleteConnector :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + m Acknowledged +deleteConnector = performBHRequest . Requests8.deleteConnector + +-- | 'deleteConnectorWith' deletes a connector, optionally also deleting +-- its pending sync jobs (@?delete_sync_jobs=true@). +deleteConnectorWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe Bool -> + ConnectorId -> + m Acknowledged +deleteConnectorWith mDeleteSyncJobs cid = + performBHRequest $ Requests8.deleteConnectorWith mDeleteSyncJobs cid + +-- | 'listConnectors' lists configured connectors. +listConnectors :: + (MonadBH m, WithBackend ElasticSearch8 m) => + m ConnectorListResponse +listConnectors = performBHRequest Requests8.listConnectors + +-- | 'listConnectorsWith' is the fully-parameterised form of +-- 'listConnectors'. +listConnectorsWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorListOptions -> + m ConnectorListResponse +listConnectorsWith = + performBHRequest . Requests8.listConnectorsWith + +-- | 'checkInConnector' records a connector heartbeat +-- (@PUT /_connector/{id}/_check_in@). +checkInConnector :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + m ConnectorMutationResult +checkInConnector = performBHRequest . Requests8.checkInConnector + +-- | 'updateConnectorApiKeyId' sets the connector API key id + secret id. +updateConnectorApiKeyId :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorApiKeyRequest -> + m ConnectorMutationResult +updateConnectorApiKeyId cid = + performBHRequest . Requests8.updateConnectorApiKeyId cid + +-- | 'updateConnectorConfiguration' updates the connector configuration. +updateConnectorConfiguration :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorConfigurationRequest -> + m ConnectorMutationResult +updateConnectorConfiguration cid = + performBHRequest . Requests8.updateConnectorConfiguration cid + +-- | 'updateConnectorError' sets or clears the connector error field. +updateConnectorError :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorErrorRequest -> + m ConnectorMutationResult +updateConnectorError cid = + performBHRequest . Requests8.updateConnectorError cid + +-- | 'updateConnectorFeatures' overrides connector features. +updateConnectorFeatures :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorFeaturesRequest -> + m ConnectorMutationResult +updateConnectorFeatures cid = + performBHRequest . Requests8.updateConnectorFeatures cid + +-- | 'updateConnectorFiltering' updates the draft filtering. +updateConnectorFiltering :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorFilteringRequest -> + m ConnectorMutationResult +updateConnectorFiltering cid = + performBHRequest . Requests8.updateConnectorFiltering cid + +-- | 'updateConnectorDraftFilteringValidation' updates draft filtering +-- validation info. +updateConnectorDraftFilteringValidation :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorFilteringValidationRequest -> + m ConnectorMutationResult +updateConnectorDraftFilteringValidation cid = + performBHRequest . Requests8.updateConnectorDraftFilteringValidation cid + +-- | 'activateConnectorDraftFiltering' activates the valid draft filter. +activateConnectorDraftFiltering :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + m ConnectorMutationResult +activateConnectorDraftFiltering = + performBHRequest . Requests8.activateConnectorDraftFiltering + +-- | 'updateConnectorIndexName' sets or clears the destination index. +updateConnectorIndexName :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorIndexNameRequest -> + m ConnectorMutationResult +updateConnectorIndexName cid = + performBHRequest . Requests8.updateConnectorIndexName cid + +-- | 'updateConnectorNameDescription' updates name and description. +updateConnectorNameDescription :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorNameDescriptionRequest -> + m ConnectorMutationResult +updateConnectorNameDescription cid = + performBHRequest . Requests8.updateConnectorNameDescription cid + +-- | 'updateConnectorNative' toggles the @is_native@ flag. +updateConnectorNative :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorNativeRequest -> + m ConnectorMutationResult +updateConnectorNative cid = + performBHRequest . Requests8.updateConnectorNative cid + +-- | 'updateConnectorPipeline' updates the ingest pipeline. +updateConnectorPipeline :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorPipelineRequest -> + m ConnectorMutationResult +updateConnectorPipeline cid = + performBHRequest . Requests8.updateConnectorPipeline cid + +-- | 'updateConnectorScheduling' updates the scheduling. +updateConnectorScheduling :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorSchedulingRequest -> + m ConnectorMutationResult +updateConnectorScheduling cid = + performBHRequest . Requests8.updateConnectorScheduling cid + +-- | 'updateConnectorServiceType' updates the service type. +updateConnectorServiceType :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorServiceTypeRequest -> + m ConnectorMutationResult +updateConnectorServiceType cid = + performBHRequest . Requests8.updateConnectorServiceType cid + +-- | 'updateConnectorStatus' updates the status. +updateConnectorStatus :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorId -> + UpdateConnectorStatusRequest -> + m ConnectorMutationResult +updateConnectorStatus cid = + performBHRequest . Requests8.updateConnectorStatus cid + +-- | 'createConnectorSyncJob' creates a sync job +-- (@POST /_connector/_sync_job@). +createConnectorSyncJob :: + (MonadBH m, WithBackend ElasticSearch8 m) => + CreateConnectorSyncJobRequest -> + m ConnectorSyncJobCreateResponse +createConnectorSyncJob = + performBHRequest . Requests8.createConnectorSyncJob + +-- | 'getConnectorSyncJob' fetches a sync job by id. +getConnectorSyncJob :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorSyncJobId -> + m ConnectorSyncJob +getConnectorSyncJob = + performBHRequest . Requests8.getConnectorSyncJob + +-- | 'listConnectorSyncJobs' lists sync jobs. +listConnectorSyncJobs :: + (MonadBH m, WithBackend ElasticSearch8 m) => + m ConnectorSyncJobListResponse +listConnectorSyncJobs = + performBHRequest Requests8.listConnectorSyncJobs + +-- | 'listConnectorSyncJobsWith' is the fully-parameterised form of +-- 'listConnectorSyncJobs'. +listConnectorSyncJobsWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorSyncJobListOptions -> + m ConnectorSyncJobListResponse +listConnectorSyncJobsWith = + performBHRequest . Requests8.listConnectorSyncJobsWith + +-- | 'deleteConnectorSyncJob' deletes a sync job by id. +deleteConnectorSyncJob :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorSyncJobId -> + m Acknowledged +deleteConnectorSyncJob = + performBHRequest . Requests8.deleteConnectorSyncJob + +-- | 'cancelConnectorSyncJob' requests cancellation of a sync job. +cancelConnectorSyncJob :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorSyncJobId -> + m ConnectorMutationResult +cancelConnectorSyncJob = + performBHRequest . Requests8.cancelConnectorSyncJob + +-- | 'checkInConnectorSyncJob' records a sync-job heartbeat. The response +-- is undocumented and returned as an opaque 'Value'. +checkInConnectorSyncJob :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorSyncJobId -> + m Value +checkInConnectorSyncJob = + performBHRequest . Requests8.checkInConnectorSyncJob + +-- | 'claimConnectorSyncJob' claims a sync job for a worker. The response +-- is undocumented and returned as an opaque 'Value'. +claimConnectorSyncJob :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorSyncJobId -> + ClaimConnectorSyncJobRequest -> + m Value +claimConnectorSyncJob jid = + performBHRequest . Requests8.claimConnectorSyncJob jid + +-- | 'setConnectorSyncJobError' sets the error on a sync job. The +-- response is undocumented and returned as an opaque 'Value'. +setConnectorSyncJobError :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorSyncJobId -> + SetConnectorSyncJobErrorRequest -> + m Value +setConnectorSyncJobError jid = + performBHRequest . Requests8.setConnectorSyncJobError jid + +-- | 'setConnectorSyncJobStats' updates the per-run counters of a sync +-- job. The response is undocumented and returned as an opaque 'Value'. +setConnectorSyncJobStats :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ConnectorSyncJobId -> + SetConnectorSyncJobStatsRequest -> + m Value +setConnectorSyncJobStats jid = + performBHRequest . Requests8.setConnectorSyncJobStats jid + +-- | 'eqlSearch' submits an EQL (Event Query Language) search via +-- @POST /{index}/_eql/search@ (Elasticsearch 8.x). The result is +-- parameterized by the document-source type @a@. +-- +-- The wire format is identical to ES 7.10+, so the ES8 request builder +-- delegates to the ES7 implementation. +-- +-- For more information see +-- . +eqlSearch :: + (FromJSON a, MonadBH m, WithBackend ElasticSearch8 m) => + IndexName -> + EQLRequest -> + m (ParsedEsResponse (EQLResult a)) +eqlSearch indexName req = performBHRequest $ Requests8.eqlSearch indexName req + +-- | 'eqlSearchWith' is the fully-parameterised form of 'eqlSearch'. The +-- wire format is identical to ES 7.10+, so the ES8 request builder +-- delegates to the ES7 implementation. See 'EQLSearchOptions' for the +-- available URI parameters. +-- +-- For more information see +-- . +eqlSearchWith :: + (FromJSON a, MonadBH m, WithBackend ElasticSearch8 m) => + IndexName -> + EQLSearchOptions -> + EQLRequest -> + m (ParsedEsResponse (EQLResult a)) +eqlSearchWith indexName opts req = + performBHRequest $ Requests8.eqlSearchWith indexName opts req + +-- | 'getEQLSearch' fetches the deferred results of an async EQL search +-- via @GET /_eql/search\/{id}@ (Elasticsearch 8.x). The result is +-- parameterized by the document-source type @a@. The optional 'Text' +-- sets @wait_for_completion_timeout@ as a query parameter; 'Nothing' +-- returns immediately with the current state. +-- +-- The wire format is identical to ES 7.10+, so the ES8 request builder +-- delegates to the ES7 implementation. +-- +-- For more information see +-- . +getEQLSearch :: + (FromJSON a, MonadBH m, WithBackend ElasticSearch8 m) => + EQLSearchId -> + Maybe Text -> + m (ParsedEsResponse (EQLResult a)) +getEQLSearch sid = performBHRequest . Requests8.getEQLSearch sid + +-- | 'getEQLStatus' returns only the status of an async EQL search via +-- @GET /_eql/search/status\/{id}@ (Elasticsearch 8.x) without fetching +-- the results. +-- +-- The wire format is identical to ES 7.10+, so the ES8 request builder +-- delegates to the ES7 implementation. +-- +-- For more information see +-- . +getEQLStatus :: + (MonadBH m, WithBackend ElasticSearch8 m) => + EQLSearchId -> + m EQLStatus +getEQLStatus = performBHRequest . Requests8.getEQLStatus + +-- | 'getDataStreams' lists data streams. The wire format is identical +-- across ES 7.x, 8.x and 9.x, so the ES7 request builder is reused +-- verbatim. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream@ returns every data +-- stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}@ returns +-- only the named data streams. +-- +-- See +-- . +getDataStreams :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe [DataStreamName] -> + m [DataStreamInfo] +getDataStreams = performBHRequest . Requests7.getDataStreams + +-- | 'getDataStreamStats' returns statistics about data streams +-- (document counts, store sizes, shard counts, etc.). The wire format +-- is identical to ES7, so the ES7 request builder is reused verbatim. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream/_stats@ returns +-- statistics for every data stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}/_stats@ +-- returns statistics for only the named data streams. +-- +-- See +-- . +getDataStreamStats :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe [DataStreamName] -> + m DataStreamStats +getDataStreamStats = performBHRequest . Requests7.getDataStreamStats + +-- | 'createDataStream' creates a data stream with the given name. The +-- stream's configuration is derived from the matching index template +-- (which must already exist and declare a @data_stream@ object). The +-- wire format is identical to ES7, so the ES7 request builder is reused +-- verbatim. +-- +-- See +-- . +createDataStream :: + (MonadBH m, WithBackend ElasticSearch8 m) => + DataStreamName -> + m Acknowledged +createDataStream = performBHRequest . Requests7.createDataStream + +-- | 'dataStreamExists' checks whether a data stream with the given +-- name exists. Returns 'True' if the stream exists, 'False' +-- otherwise (any non-2xx status, including @404@, decodes to +-- 'False'; no 'EsError' is raised). The wire format is identical to +-- ES7, so the ES7 request builder is reused verbatim. +-- +-- See +-- . +dataStreamExists :: + (MonadBH m, WithBackend ElasticSearch8 m) => + DataStreamName -> + m Bool +dataStreamExists = performBHRequest . Requests7.dataStreamExists + +-- | 'deleteDataStream' deletes a data stream and its backing indices. +-- Deleting a non-existent stream surfaces as an 'EsError'. The wire +-- format is identical to ES7, so the ES7 request builder is reused +-- verbatim. +-- +-- See +-- . +deleteDataStream :: + (MonadBH m, WithBackend ElasticSearch8 m) => + DataStreamName -> + m Acknowledged +deleteDataStream = performBHRequest . Requests7.deleteDataStream + +-- | 'migrateToDataStream' converts an existing alias (whose write index +-- is a hidden or data-stream-compatible backing index) into a data +-- stream. The alias and its write index must already be set up +-- correctly; an ineligible alias surfaces as an 'EsError'. The wire +-- format is identical to ES7, so the ES7 request builder is reused +-- verbatim. +-- +-- See +-- . +migrateToDataStream :: + (MonadBH m, WithBackend ElasticSearch8 m) => + IndexAliasName -> + m Acknowledged +migrateToDataStream = performBHRequest . Requests7.migrateToDataStream + +-- | 'promoteDataStream' promotes a frozen or cloned data stream back to a +-- regular data stream (disaster recovery). A stream that is not +-- currently frozen surfaces as an 'EsError'. The wire format is +-- identical to ES7, so the ES7 request builder is reused verbatim. +-- +-- See +-- . +promoteDataStream :: + (MonadBH m, WithBackend ElasticSearch8 m) => + DataStreamName -> + m Acknowledged +promoteDataStream = performBHRequest . Requests7.promoteDataStream + +-- | 'putDataStreamLifecycle' sets or updates the lifecycle of a data +-- stream (retention, downsampling, enabled toggle). The request +-- builder lives in the ES8 module and is re-exported by the ES9 +-- client module. +-- +-- See +-- . +putDataStreamLifecycle :: + (MonadBH m, WithBackend ElasticSearch8 m) => + DataStreamName -> + DataStreamLifecycle -> + m Acknowledged +putDataStreamLifecycle = (performBHRequest .) . Requests8.putDataStreamLifecycle + +-- | 'putDataStreamsLifecycle' sets or updates the lifecycle of +-- multiple data streams in a single bulk request (see +-- 'PutDataStreamsLifecycleRequest'). The request builder lives in +-- the ES8 module and is re-exported by the ES9 client module. +-- +-- See +-- . +putDataStreamsLifecycle :: + (MonadBH m, WithBackend ElasticSearch8 m) => + PutDataStreamsLifecycleRequest -> + m Acknowledged +putDataStreamsLifecycle = performBHRequest . Requests8.putDataStreamsLifecycle + +-- | 'getDataStreamLifecycle' retrieves the lifecycle configuration of +-- one or more data streams. The request builder lives in the ES8 +-- module and is re-exported by the ES9 client module. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream/_lifecycle@ +-- returns the lifecycle of every data stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}/_lifecycle@ +-- returns only the lifecycles of the named data streams. +-- +-- Streams that are not managed by a lifecycle appear with their +-- @lifecycle@ field decoded as 'Nothing'. +-- +-- See +-- . +getDataStreamLifecycle :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe [DataStreamName] -> + m GetDataStreamLifecyclesResponse +getDataStreamLifecycle = performBHRequest . Requests8.getDataStreamLifecycle + +-- | 'deleteDataStreamLifecycle' removes the lifecycle configuration +-- from a data stream, rendering it unmanaged by the data stream +-- lifecycle. The request builder lives in the ES8 module and is +-- re-exported by the ES9 client module. +-- +-- See +-- . +deleteDataStreamLifecycle :: + (MonadBH m, WithBackend ElasticSearch8 m) => + DataStreamName -> + m Acknowledged +deleteDataStreamLifecycle = performBHRequest . Requests8.deleteDataStreamLifecycle + +-- | 'modifyDataStream' changes the backing indices of one or more data +-- streams (batched add\/remove backing index). Referencing a +-- non-existent stream or an ineligible index surfaces as an 'EsError'. +-- The wire format is identical to ES7, so the ES7 request builder is +-- reused verbatim. +-- +-- See +-- . +modifyDataStream :: + (MonadBH m, WithBackend ElasticSearch8 m) => + ModifyDataStreamRequest -> + m Acknowledged +modifyDataStream = performBHRequest . Requests7.modifyDataStream + +-- | 'getDataStreamOptions' retrieves the options (e.g. failure store +-- configuration) of one or more data streams. Requires +-- Elasticsearch >= 8.19. The request builder lives in the ES8 module +-- and is re-exported by the ES9 client module. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream/_options@ +-- returns the options of every data stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}/_options@ +-- returns only the options of the named data streams. +-- +-- See +-- . +getDataStreamOptions :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe [DataStreamName] -> + m GetDataStreamOptionsResponse +getDataStreamOptions = performBHRequest . Requests8.getDataStreamOptions + +-- | 'updateDataStreamOptions' sets the options (e.g. failure store +-- configuration) of one or more data streams. Referencing a +-- non-existent stream surfaces as an 'EsError'. Requires +-- Elasticsearch >= 8.19. The request builder lives in the ES8 module +-- and is re-exported by the ES9 client module. +-- +-- See +-- . +updateDataStreamOptions :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe [DataStreamName] -> + UpdateDataStreamOptionsRequest -> + m Acknowledged +updateDataStreamOptions = (performBHRequest .) . Requests8.updateDataStreamOptions + +-- | 'deleteDataStreamOptions' removes the options (e.g. failure store +-- configuration) from one or more data streams, resetting them to +-- their defaults. Deleting the options of a non-existent stream +-- surfaces as an 'EsError'. Requires Elasticsearch >= 8.19. The +-- request builder lives in the ES8 module and is re-exported by the +-- ES9 client module. +-- +-- See +-- . +deleteDataStreamOptions :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe [DataStreamName] -> + m Acknowledged +deleteDataStreamOptions = performBHRequest . Requests8.deleteDataStreamOptions + +-- | 'getDataStreamLifecycleStats' retrieves cluster-wide runtime +-- statistics for the data stream lifecycle service via +-- @GET /_lifecycle/stats@ (Elasticsearch 8.12+). The response carries +-- aggregate timing information plus a per-stream breakdown of +-- backing-index health. The wire format is identical across ES 8.x +-- and 9.x, so the request builder lives in the ES8 module and is +-- re-exported by the ES9 client module. +-- +-- See +-- . +getDataStreamLifecycleStats :: + (MonadBH m, WithBackend ElasticSearch8 m) => + m DataStreamLifecycleStats +getDataStreamLifecycleStats = performBHRequest Requests8.getDataStreamLifecycleStats + +-- | 'explainDataStreamLifecycle' retrieves the per-index lifecycle +-- status for one or more backing indices via +-- @GET /{index}/_lifecycle/explain@ (Elasticsearch 8.11+). Equivalent +-- to @'explainDataStreamLifecycleWith' indices 'defaultExplainDataStreamLifecycleOptions'@. +-- +-- Note the path parameter is an @index@ (typically a backing index of +-- the form @.ds---@), not a data-stream +-- name. The wire format is identical across ES 8.x and 9.x, so the +-- request builder lives in the ES8 module and is re-exported by the +-- ES9 client module. +-- +-- See +-- . +explainDataStreamLifecycle :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe [IndexName] -> + m ExplainDataStreamLifecycleResponse +explainDataStreamLifecycle = performBHRequest . Requests8.explainDataStreamLifecycle + +-- | 'explainDataStreamLifecycleWith' is the fully-parameterised form +-- of 'explainDataStreamLifecycle'. +explainDataStreamLifecycleWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe [IndexName] -> + ExplainDataStreamLifecycleOptions -> + m ExplainDataStreamLifecycleResponse +explainDataStreamLifecycleWith indices = + performBHRequest . Requests8.explainDataStreamLifecycleWith indices + +-- | 'deleteEQLSearch' deletes an async EQL search result and its +-- context by id via @DELETE /_eql/search/{id}@ (Elasticsearch 7.10+) +-- and returns 'Acknowledged' on success. The wire format is identical +-- across ES 7.x, 8.x and 9.x. +-- +-- For more information see +-- . +deleteEQLSearch :: + (MonadBH m, WithBackend ElasticSearch8 m) => + EQLSearchId -> + m Acknowledged +deleteEQLSearch = performBHRequest . Requests8.deleteEQLSearch + +-- | 'getTermsEnum' returns a list of terms in a field for auto-complete +-- use cases via @GET \/{index}\/_terms_enum@ (Elasticsearch >= 7.10). +-- The wire format is identical to ES 7.10+, so the ES7 request builder +-- is reused via the ES8 requests module. +-- +-- For more information see +-- . +getTermsEnum :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe [IndexName] -> + FieldName -> + Maybe Text -> + m TermsEnumResponse +getTermsEnum mIndices field mString = + performBHRequest $ Requests8.getTermsEnum mIndices field mString + +-- | 'getTermsEnumWith' is the fully-parameterised form of +-- 'getTermsEnum' (ES >= 7.10). Forwards 'TermsEnumOptions' (URI +-- parameters) and a full 'TermsEnumRequest' body. +-- +-- For more information see +-- . +getTermsEnumWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + Maybe [IndexName] -> + TermsEnumOptions -> + TermsEnumRequest -> + m TermsEnumResponse +getTermsEnumWith mIndices opts req = + performBHRequest $ Requests8.getTermsEnumWith mIndices opts req + +------------------------------------------------------------------------------ +-- Migration reindex (/_migration/reindex, /_create_from) +------------------------------------------------------------------------------ + +-- | 'migrateReindex' reindexes all legacy backing indices of a data +-- stream via @POST /_migration/reindex@ (ES 8.18+). The reindex runs in +-- a persistent task; the endpoint returns 'Acknowledged' immediately. +-- Poll 'getMigrateReindexStatus' to observe progress. Mutates cluster +-- state — call deliberately. +-- +-- For more information see +-- . +migrateReindex :: + (MonadBH m, WithBackend ElasticSearch8 m) => + MigrateReindexRequest -> + m Acknowledged +migrateReindex req = performBHRequest $ Requests8.migrateReindex req + +-- | 'cancelMigrateReindex' cancels an in-progress migration reindex +-- attempt via @POST /_migration/reindex/{index}/_cancel@ (ES 8.18+). +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +cancelMigrateReindex :: + (MonadBH m, WithBackend ElasticSearch8 m) => + NonEmpty IndexName -> + m Acknowledged +cancelMigrateReindex indices = + performBHRequest $ Requests8.cancelMigrateReindex indices + +-- | 'getMigrateReindexStatus' reports the status of a migration reindex +-- attempt via @GET /_migration/reindex/{index}/_status@ (ES 8.18+). The +-- response is decoded into 'MigrateReindexStatus'. +-- +-- For more information see +-- . +getMigrateReindexStatus :: + (MonadBH m, WithBackend ElasticSearch8 m) => + NonEmpty IndexName -> + m MigrateReindexStatus +getMigrateReindexStatus indices = + performBHRequest $ Requests8.getMigrateReindexStatus indices + +-- | 'createIndexFrom' copies the mappings and settings from a source +-- index into a fresh destination index via +-- @POST /_create_from/{source}/{dest}@ (ES 8.18+), with no overrides. +-- Returns 'CreateIndexFromResponse' on success. Mutates cluster state. +-- +-- For more information see +-- . +createIndexFrom :: + (MonadBH m, WithBackend ElasticSearch8 m) => + IndexName -> + IndexName -> + m CreateIndexFromResponse +createIndexFrom source dest = + performBHRequest $ Requests8.createIndexFrom source dest + +-- | 'createIndexFromWith' is the fully-parameterised variant of +-- 'createIndexFrom', accepting an optional 'CreateIndexFromBody' whose +-- @mappings_override@ and @settings_override@ replace the source values. +createIndexFromWith :: + (MonadBH m, WithBackend ElasticSearch8 m) => + IndexName -> + IndexName -> + Maybe CreateIndexFromBody -> + m CreateIndexFromResponse +createIndexFromWith source dest mBody = + performBHRequest $ Requests8.createIndexFromWith source dest mBody diff --git a/src/Database/Bloodhound/ElasticSearch8/Requests.hs b/src/Database/Bloodhound/ElasticSearch8/Requests.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/ElasticSearch8/Requests.hs @@ -0,0 +1,1822 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.ElasticSearch8.Requests + ( module Reexport, + esql, + esqlWith, + esqlAsync, + esqlAsyncWith, + getAsyncESQL, + getAsyncESQLWith, + deleteAsyncESQL, + stopAsyncESQL, + putInferenceEndpoint, + putInferenceEndpointWith, + updateInferenceEndpoint, + getInferenceEndpoints, + deleteInferenceEndpoint, + deleteInferenceEndpointWith, + runInference, + runInferenceWith, + streamCompletionInference, + streamCompletionInferenceWith, + streamChatCompletionInference, + streamChatCompletionInferenceWith, + putQueryRuleset, + getQueryRuleset, + deleteQueryRuleset, + testQueryRuleset, + putSearchApplication, + putSearchApplicationWith, + getSearchApplication, + deleteSearchApplication, + searchApplication, + searchApplicationWith, + listSearchApplications, + listSearchApplicationsWith, + renderSearchApplicationQuery, + putDataStreamLifecycle, + putDataStreamsLifecycle, + getDataStreamLifecycle, + deleteDataStreamLifecycle, + getDataStreamOptions, + updateDataStreamOptions, + deleteDataStreamOptions, + getDataStreamLifecycleStats, + explainDataStreamLifecycle, + explainDataStreamLifecycleWith, + eqlSearch, + eqlSearchWith, + getEQLSearch, + getEQLStatus, + deleteEQLSearch, + getTermsEnum, + getTermsEnumWith, + putSynonymsSet, + getSynonymsSet, + getSynonymsSetWith, + deleteSynonymsSet, + getAnalyticsCollections, + putAnalyticsCollection, + deleteAnalyticsCollection, + postAnalyticsEvent, + postAnalyticsEventWith, + createConnector, + putConnector, + getConnector, + deleteConnector, + deleteConnectorWith, + listConnectors, + listConnectorsWith, + checkInConnector, + updateConnectorApiKeyId, + updateConnectorConfiguration, + updateConnectorError, + updateConnectorFeatures, + updateConnectorFiltering, + updateConnectorDraftFilteringValidation, + activateConnectorDraftFiltering, + updateConnectorIndexName, + updateConnectorNameDescription, + updateConnectorNative, + updateConnectorPipeline, + updateConnectorScheduling, + updateConnectorServiceType, + updateConnectorStatus, + createConnectorSyncJob, + getConnectorSyncJob, + listConnectorSyncJobs, + listConnectorSyncJobsWith, + deleteConnectorSyncJob, + cancelConnectorSyncJob, + checkInConnectorSyncJob, + claimConnectorSyncJob, + setConnectorSyncJobError, + setConnectorSyncJobStats, + migrateReindex, + cancelMigrateReindex, + getMigrateReindexStatus, + createIndexFrom, + createIndexFromWith, + ) +where + +import Data.Aeson (FromJSON, Value, encode) +import Data.ByteString.Lazy qualified as L +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster +import Database.Bloodhound.Common.Requests as Reexport +import Database.Bloodhound.ElasticSearch7.Requests qualified as Requests7 +import Database.Bloodhound.ElasticSearch8.Types +import Database.Bloodhound.Internal.Utils.Requests + +-- | 'esql' builds the 'BHRequest' for the ES|QL @POST /_query@ endpoint +-- (Elasticsearch 8.11+). The body is the encoded 'ESQLRequest'; the response +-- is parsed into 'ESQLResult'. +-- +-- Equivalent to @'esqlWith' req 'defaultESQLQueryOptions'@ — emits no +-- query string. +-- +-- For more information see +-- . +esql :: + ESQLRequest -> + BHRequest StatusDependant (ParsedEsResponse ESQLResult) +esql = flip esqlWith defaultESQLQueryOptions + +-- | 'esqlWith' builds the 'BHRequest' for the ES|QL @POST /_query@ +-- endpoint (Elasticsearch 8.11+) with the documented URI query +-- parameters ('ESQLQueryOptions'). The body is the encoded +-- 'ESQLRequest'; the response is parsed into 'ESQLResult'. +-- +-- Pass 'defaultESQLQueryOptions' to emit no query string (identical +-- wire shape to 'esql'). +-- +-- For more information see +-- . +esqlWith :: + ESQLRequest -> + ESQLQueryOptions -> + BHRequest StatusDependant (ParsedEsResponse ESQLResult) +esqlWith req opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = + mkEndpoint ["_query"] + `withQueries` esqlOptionsParams opts + +-- | 'esqlAsync' builds the 'BHRequest' for the async ES|QL +-- @POST /_query\/async@ endpoint (Elasticsearch 8.11+, identical wire +-- format in ES9). The body is the encoded 'AsyncESQLRequest' — unlike +-- async search, ES|QL async carries @wait_for_completion_timeout@, +-- @keep_alive@, @keep_on_completion@, etc. as JSON body fields, /not/ +-- as query parameters. +-- +-- Equivalent to @'esqlAsyncWith' req 'defaultESQLQueryOptions'@ — emits +-- no query string. +-- +-- For more information see +-- . +esqlAsync :: + AsyncESQLRequest -> + BHRequest StatusDependant (ParsedEsResponse AsyncESQLResult) +esqlAsync = flip esqlAsyncWith defaultESQLQueryOptions + +-- | 'esqlAsyncWith' builds the 'BHRequest' for the async ES|QL +-- @POST /_query\/async@ endpoint (Elasticsearch 8.11+) with the +-- documented URI query parameters ('ESQLQueryOptions') — the same +-- parameter surface as the synchronous 'esqlWith', minus @format@ +-- (see the note at 'ESQLQueryOptions'). The body is the encoded +-- 'AsyncESQLRequest'; the response is parsed into 'AsyncESQLResult'. +-- +-- Pass 'defaultESQLQueryOptions' to emit no query string (identical +-- wire shape to 'esqlAsync'). +-- +-- For more information see +-- . +esqlAsyncWith :: + AsyncESQLRequest -> + ESQLQueryOptions -> + BHRequest StatusDependant (ParsedEsResponse AsyncESQLResult) +esqlAsyncWith req opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = + mkEndpoint ["_query", "async"] + `withQueries` esqlOptionsParams opts + +-- | 'getAsyncESQL' builds the 'BHRequest' for +-- @GET /_query\/async\/{id}@ — polling the state and (partial or final) +-- results of an async ES|QL query. The optional 'Text' sets +-- @wait_for_completion_timeout@ as a query parameter (duration string +-- such as @"5s"@); 'Nothing' uses the server default (return immediately +-- with the current state). +-- +-- This is the common-case convenience for the single most-used +-- parameter; for the full polling parameter surface (@keep_alive@, +-- @drop_null_columns@) see 'getAsyncESQLWith'. +-- +-- Equivalent to +-- @'getAsyncESQLWith' id ('defaultGetAsyncESQLOptions' { 'gaesqloWaitForCompletionTimeout' = mTimeout })@. +-- +-- For more information see +-- . +getAsyncESQL :: + AsyncESQLId -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse AsyncESQLResult) +getAsyncESQL searchId mTimeout = + getAsyncESQLWith + searchId + ( defaultGetAsyncESQLOptions + { gaesqloWaitForCompletionTimeout = mTimeout + } + ) + +-- | 'getAsyncESQLWith' is the fully-parameterised form of +-- 'getAsyncESQL', exposing every URI parameter accepted by +-- @GET /_query\/async\/{id}@ via 'GetAsyncESQLOptions' +-- (@wait_for_completion_timeout@, @keep_alive@, @drop_null_columns@). +-- Pass 'defaultGetAsyncESQLOptions' to reproduce the legacy behaviour +-- (no query string). +-- +-- For more information see +-- . +getAsyncESQLWith :: + AsyncESQLId -> + GetAsyncESQLOptions -> + BHRequest StatusDependant (ParsedEsResponse AsyncESQLResult) +getAsyncESQLWith (AsyncESQLId searchId) opts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_query", "async", searchId] + `withQueries` getAsyncESQLOptionsParams opts + +-- | 'deleteAsyncESQL' builds the 'BHRequest' for +-- @DELETE /_query\/async\/{id}@ — deleting an async ES|QL result and its +-- context. Returns 'Acknowledged' on success. +-- +-- The endpoint is 'StatusDependant' — consistent with the other delete +-- functions in this module ('deleteInferenceEndpoint', +-- 'deleteQueryRuleset', 'deleteSearchApplication'): deleting a +-- non-existent or already-purged async id surfaces as an 'EsError' +-- (a @404@ with an error body); wrap with 'tryPerformBHRequest' for +-- miss-tolerant deletion. +-- +-- Note: the analogous async-result delete 'deleteEQLSearch' +-- (@DELETE /_eql\/search\/{id}@) is still 'StatusIndependant' and on a +-- missing id yields only a generic @\"Unable to parse body\"@ 'EsError' +-- rather than the structured server error decoded here; aligning it is +-- out of scope. +-- +-- For more information see +-- . +deleteAsyncESQL :: + AsyncESQLId -> + BHRequest StatusDependant Acknowledged +deleteAsyncESQL (AsyncESQLId searchId) = + delete (mkEndpoint ["_query", "async", searchId]) + +-- | 'stopAsyncESQL' builds the 'BHRequest' for +-- @POST /_query\/async\/{id}\/stop@ — requesting the server to stop a +-- running async ES|QL query (Elasticsearch 8.11+). The response is the +-- full 'AsyncESQLResult' for the stopped query: @is_running@ flips to +-- @False@, and @columns@\/@values@ carry whatever the query produced +-- before being stopped. +-- +-- For more information see +-- . +stopAsyncESQL :: + AsyncESQLId -> + BHRequest StatusDependant (ParsedEsResponse AsyncESQLResult) +stopAsyncESQL (AsyncESQLId searchId) = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint emptyBody + where + endpoint = mkEndpoint ["_query", "async", searchId, "stop"] + +-- | 'putInferenceEndpoint' builds the 'BHRequest' for +-- @PUT \/_inference\/{task_type}\/{inference_id}@ (Elasticsearch 8.12+), +-- which creates or updates an inference endpoint for a provider such as +-- OpenAI, Cohere or ELSER. The same PUT path is used for both create and +-- full replacement; for a partial update use 'updateInferenceEndpoint' +-- (the dedicated @\/_update@ endpoint), which does not require re-sending +-- every required field. +-- +-- For more information see +-- . +putInferenceEndpoint :: + TaskType -> + InferenceId -> + InferenceConfig -> + BHRequest StatusDependant (ParsedEsResponse InferencePutResponse) +putInferenceEndpoint taskType' inferenceId config = + putInferenceEndpointWith taskType' inferenceId config defaultPutInferenceOptions + +-- | 'putInferenceEndpointWith' is the fully-parameterised form of +-- 'putInferenceEndpoint'. 'PutInferenceOptions' carries the @timeout@ +-- query parameter documented at +-- : +-- an upper bound on the time the server spends on the create\/update. +-- Passing 'defaultPutInferenceOptions' yields a request byte-for-byte +-- identical to 'putInferenceEndpoint'. +-- +-- For more information see +-- . +putInferenceEndpointWith :: + TaskType -> + InferenceId -> + InferenceConfig -> + PutInferenceOptions -> + BHRequest StatusDependant (ParsedEsResponse InferencePutResponse) +putInferenceEndpointWith taskType' inferenceId config opts = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode config) + where + endpoint = + mkEndpoint + [ "_inference", + taskTypeToText taskType', + unInferenceId inferenceId + ] + `withQueries` putInferenceOptionsParams opts + +-- | 'updateInferenceEndpoint' builds the 'BHRequest' for +-- @PUT \/_inference\/{task_type}\/{inference_id}\/_update@ +-- (Elasticsearch 8.12+, @operation-inference-update@), which partially +-- updates an existing inference endpoint. The request body has the same +-- shape as 'InferenceConfig' (the @service@ + @service_settings@ + +-- @task_settings@ + @chunking_settings@ envelope) but the server treats +-- omitted fields as \"leave unchanged\" rather than requiring the full +-- create payload. The response is the updated endpoint as a bare +-- 'InferenceInfo' (the @InferenceEndpointInfo@ object, without the +-- @\/@ key wrapper used by the list APIs). +-- +-- For more information see +-- . +updateInferenceEndpoint :: + TaskType -> + InferenceId -> + InferenceConfig -> + BHRequest StatusDependant (ParsedEsResponse InferenceInfo) +updateInferenceEndpoint taskType' inferenceId config = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode config) + where + endpoint = + mkEndpoint + [ "_inference", + taskTypeToText taskType', + unInferenceId inferenceId, + "_update" + ] + +-- | 'deleteInferenceEndpoint' builds the 'BHRequest' for +-- @DELETE \/_inference\/{task_type}\/{inference_id}@ (Elasticsearch 8.12+), +-- which deletes a previously-configured inference endpoint. The endpoint is +-- 'StatusDependant': a @404@ for a missing inference endpoint surfaces as an +-- 'EsError'; wrap with 'tryPerformBHRequest' for miss-tolerant deletion. +-- +-- For more information see +-- . +deleteInferenceEndpoint :: + TaskType -> + InferenceId -> + BHRequest StatusDependant Acknowledged +deleteInferenceEndpoint taskType' inferenceId = + delete endpoint + where + endpoint = + mkEndpoint + [ "_inference", + taskTypeToText taskType', + unInferenceId inferenceId + ] + +-- | 'deleteInferenceEndpointWith' is the fully-parameterised form of +-- 'deleteInferenceEndpoint'. It attaches the @dry_run@ and @force@ query +-- parameters described by 'DeleteInferenceOptions': +-- +-- * @dry_run=true@ previews the deletion (and the conflict checks) without +-- actually removing the endpoint. +-- * @force=true@ deletes the endpoint even when it is in use (referenced by +-- other configurations); without it the delete can fail. +-- +-- 'deleteInferenceEndpoint' emits no query string at all; the two are +-- semantically equivalent when 'defaultDeleteInferenceOptions' is passed +-- (the server treats an absent flag as @false@). +-- +-- For more information see +-- . +deleteInferenceEndpointWith :: + TaskType -> + InferenceId -> + DeleteInferenceOptions -> + BHRequest StatusDependant Acknowledged +deleteInferenceEndpointWith taskType' inferenceId opts = + delete (endpoint `withQueries` deleteInferenceOptionsParams opts) + where + endpoint = + mkEndpoint + [ "_inference", + taskTypeToText taskType', + unInferenceId inferenceId + ] + +-- | 'getInferenceEndpoints' builds the 'BHRequest' for the +-- @GET \/_inference@ family (Elasticsearch 8.12+), which lists configured +-- inference endpoints. The path narrows the response server-side: +-- +-- * @'Nothing'@ task type → @GET \/_inference@ returns every endpoint. +-- * @'Just' tt@, no id → @GET \/_inference\/{task_type}\/_all@ returns +-- the endpoints of that task type. +-- * @'Just' tt@, @'Just' iid@ → @GET \/_inference\/{task_type}\/{inference_id}@ +-- returns a single endpoint. +-- +-- Passing @'Just' iid@ without a task type is not a valid Elasticsearch +-- URL; in that case the builder falls back to @GET \/_inference@ (lists +-- every endpoint) rather than synthesising an unsupported path. +-- +-- The response is a JSON object keyed by @\/@; +-- the 'FromJSON' instance of 'InferenceEndpointsResponse' splits each +-- key and flattens the map into an 'InferenceEndpointsResponse', which +-- 'getInferenceEndpoints' unwraps via 'unInferenceEndpointsResponse'. +-- +-- For more information see +-- . +getInferenceEndpoints :: + Maybe TaskType -> + Maybe InferenceId -> + BHRequest StatusDependant [InferenceInfo] +getInferenceEndpoints mTaskType mInferenceId = + unInferenceEndpointsResponse <$> get @StatusDependant endpoint + where + endpoint = case (mTaskType, mInferenceId) of + (Just tt, Just iid) -> + mkEndpoint ["_inference", taskTypeToText tt, unInferenceId iid] + (Just tt, Nothing) -> + mkEndpoint ["_inference", taskTypeToText tt, "_all"] + (Nothing, Just _) -> + mkEndpoint ["_inference"] + (Nothing, Nothing) -> + mkEndpoint ["_inference"] + +-- | 'runInference' builds the 'BHRequest' for +-- @POST \/_inference\/{task_type}\/{inference_id}@ (Elasticsearch 8.12+), +-- which performs inference against a previously-configured endpoint. +-- +-- For more information see +-- . +runInference :: + TaskType -> + InferenceId -> + InferenceInput -> + BHRequest StatusDependant (ParsedEsResponse InferenceResult) +runInference taskType' inferenceId input = + runInferenceWith taskType' inferenceId input defaultRunInferenceOptions + +-- | 'runInferenceWith' is the fully-parameterised form of 'runInference'. +-- 'RunInferenceOptions' carries the @timeout@ query parameter documented at +-- : +-- an upper bound on the time the server spends on the inference call (useful, +-- as inference can be slow). Passing 'defaultRunInferenceOptions' yields a +-- request byte-for-byte identical to 'runInference'. +-- +-- For more information see +-- . +runInferenceWith :: + TaskType -> + InferenceId -> + InferenceInput -> + RunInferenceOptions -> + BHRequest StatusDependant (ParsedEsResponse InferenceResult) +runInferenceWith taskType' inferenceId input opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode input) + where + endpoint = + mkEndpoint + [ "_inference", + taskTypeToText taskType', + unInferenceId inferenceId + ] + `withQueries` runInferenceOptionsParams opts + +-- | 'streamCompletionInference' builds the 'BHRequest' for +-- @POST \/_inference\/completion\/{inference_id}\/_stream@ +-- (Elasticsearch 8.12+, @operation-inference-stream-completion@), which +-- streams completion chunks (NDJSON, the opaque @_types.StreamResult@) +-- from a previously-configured completion endpoint. The full buffered +-- response body is returned as a lazy 'L.ByteString'; callers split it +-- into newline-delimited JSON chunks and decode each. The request body +-- reuses 'InferenceInput' (the @input@ \/ @task_settings@ envelope); the +-- @query@ \/ @input_type@ fields are optional and omitted when 'Nothing'. +-- +-- For more information see +-- . +streamCompletionInference :: + InferenceId -> + InferenceInput -> + BHRequest StatusDependant L.ByteString +streamCompletionInference inferenceId input = + streamCompletionInferenceWith inferenceId input defaultStreamCompletionInferenceOptions + +-- | 'streamCompletionInferenceWith' is the fully-parameterised form of +-- 'streamCompletionInference'. 'StreamCompletionInferenceOptions' carries +-- the @timeout@ query parameter: an upper bound on the time the server +-- spends establishing the stream. Passing +-- 'defaultStreamCompletionInferenceOptions' yields a request byte-for-byte +-- identical to 'streamCompletionInference'. +-- +-- For more information see +-- . +streamCompletionInferenceWith :: + InferenceId -> + InferenceInput -> + StreamCompletionInferenceOptions -> + BHRequest StatusDependant L.ByteString +streamCompletionInferenceWith inferenceId input opts = + postRaw endpoint (encode input) + where + endpoint = + mkEndpoint + [ "_inference", + "completion", + unInferenceId inferenceId, + "_stream" + ] + `withQueries` streamCompletionInferenceOptionsParams opts + +-- | 'streamChatCompletionInference' builds the 'BHRequest' for +-- @POST \/_inference\/chat_completion\/{inference_id}\/_stream@ +-- (Elasticsearch 8.18+, @operation-inference-chat-completion-unified@), +-- which streams chat-completion chunks (NDJSON, the opaque +-- @_types.StreamResult@) from a previously-configured chat endpoint. The +-- full buffered response body is returned as a lazy 'L.ByteString'; callers +-- split it into newline-delimited JSON chunks and decode each. The request +-- body is a 'ChatCompletionRequest' (messages + optional model + +-- opaque task_settings for @tools@ \/ @reasoning@ \/ ...). +-- +-- For more information see +-- . +streamChatCompletionInference :: + InferenceId -> + ChatCompletionRequest -> + BHRequest StatusDependant L.ByteString +streamChatCompletionInference inferenceId request = + streamChatCompletionInferenceWith inferenceId request defaultStreamChatCompletionInferenceOptions + +-- | 'streamChatCompletionInferenceWith' is the fully-parameterised form of +-- 'streamChatCompletionInference'. 'StreamChatCompletionInferenceOptions' +-- carries the @timeout@ query parameter: an upper bound on the time the +-- server spends establishing the stream. Passing +-- 'defaultStreamChatCompletionInferenceOptions' yields a request +-- byte-for-byte identical to 'streamChatCompletionInference'. +-- +-- For more information see +-- . +streamChatCompletionInferenceWith :: + InferenceId -> + ChatCompletionRequest -> + StreamChatCompletionInferenceOptions -> + BHRequest StatusDependant L.ByteString +streamChatCompletionInferenceWith inferenceId request opts = + postRaw endpoint (encode request) + where + endpoint = + mkEndpoint + [ "_inference", + "chat_completion", + unInferenceId inferenceId, + "_stream" + ] + `withQueries` streamChatCompletionInferenceOptionsParams opts + +-- $dataStreamLifecycle +-- +-- /Data Stream Lifecycle/ (ES 8.x+, also in ES 9.x) manages retention +-- and downsampling for a data stream without a full ILM policy. The +-- three builders below cover the PUT (set\/update), GET (retrieve) and +-- DELETE (remove) lifecycle endpoints. The wire format is identical +-- across ES 8.x and 9.x, so the request builders live here and are +-- re-exported by the ES9 client module. + +-- | 'putDataStreamLifecycle' sets or updates the lifecycle of a data +-- stream. The body carries the lifecycle configuration +-- ('DataStreamLifecycle'); the path carries the stream name. Returns +-- 'Acknowledged' on success. +-- +-- Setting a lifecycle on a non-existent stream fails with an HTTP error +-- (hence 'StatusDependant'), surfaced as an 'EsError'. +-- +-- See +-- . +putDataStreamLifecycle :: + DataStreamName -> + DataStreamLifecycle -> + BHRequest StatusDependant Acknowledged +putDataStreamLifecycle (DataStreamName dsName) lifecycle = + put @StatusDependant ["_data_stream", dsName, "_lifecycle"] (encode lifecycle) + +-- | 'putDataStreamsLifecycle' sets or updates the lifecycle of multiple +-- data streams in a single request. Issues a bulk +-- @PUT /_data_stream/_lifecycle@ with a body of the form +-- @{"data_streams":[{name,lifecycle},\u2026]}@ (see +-- 'PutDataStreamsLifecycleRequest'). Returns 'Acknowledged' on success. +-- +-- Each 'DataStreamLifecycleInfo' in the request pairs a stream name +-- with its 'DataStreamLifecycle'; the @lifecycle@ field of an entry +-- may be 'Nothing' to disable lifecycle management for that stream. +-- Setting a lifecycle on a non-existent stream fails with an HTTP +-- error (hence 'StatusDependant'), surfaced as an 'EsError'. +-- +-- See +-- . +putDataStreamsLifecycle :: + PutDataStreamsLifecycleRequest -> + BHRequest StatusDependant Acknowledged +putDataStreamsLifecycle = + put @StatusDependant ["_data_stream", "_lifecycle"] . encode + +-- | 'getDataStreamLifecycle' retrieves the lifecycle configuration of +-- one or more data streams. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream/_lifecycle@ +-- returns the lifecycle of every data stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}/_lifecycle@ +-- returns only the lifecycles of the named data streams (comma-joined +-- path segment, mirroring 'getDataStreams'). +-- +-- Streams that are not managed by a lifecycle appear in the response +-- with their @lifecycle@ field decoded as 'Nothing'. +-- +-- See +-- . +getDataStreamLifecycle :: + Maybe [DataStreamName] -> + BHRequest StatusDependant GetDataStreamLifecyclesResponse +getDataStreamLifecycle mDataStreamNames = + get @StatusDependant endpoint + where + endpoint = case mDataStreamNames of + Nothing -> ["_data_stream", "_lifecycle"] + Just [] -> ["_data_stream", "_lifecycle"] + Just (first : rest) -> + ["_data_stream", T.intercalate "," (renderDataStreamName <$> (first : rest)), "_lifecycle"] + renderDataStreamName (DataStreamName dsName) = dsName + +-- | 'deleteDataStreamLifecycle' removes the lifecycle configuration +-- from a data stream, rendering it unmanaged by the data stream +-- lifecycle. Returns 'Acknowledged' on success. +-- +-- Deleting the lifecycle of a non-existent stream fails with an HTTP +-- error (hence 'StatusDependant'), surfaced as an 'EsError'. +-- +-- See +-- . +deleteDataStreamLifecycle :: + DataStreamName -> + BHRequest StatusDependant Acknowledged +deleteDataStreamLifecycle (DataStreamName dsName) = + delete @StatusDependant ["_data_stream", dsName, "_lifecycle"] + +-- $dataStreamOptions +-- +-- /Data Stream Options/ (ES 8.19+, also in ES 9.x) expose per-stream +-- feature toggles that live outside the lifecycle and ILM machinery +-- (currently just the @failure_store@). The wire format is identical +-- across ES 8.19+ and 9.x, so the request builders live here and are +-- re-exported by the ES9 client module. +-- +-- /Path-segment asymmetry/: 'getDataStreamOptions' omits the name +-- segment when given @'Nothing'@ or @'Just' []@ (matching +-- 'getDataStreams'); 'updateDataStreamOptions' and +-- 'deleteDataStreamOptions' substitute the wildcard @*@ in that case, +-- because the ES API requires the @{name}@ segment on PUT and DELETE. +-- The wildcard is a cluster-wide fan-out — see the @CAUTION@ haddock +-- on each builder. + +-- | 'getDataStreamOptions' retrieves the options (e.g. failure store +-- configuration) of one or more data streams. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream/_options@ +-- returns the options of every data stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}/_options@ +-- returns only the options of the named data streams (comma-joined +-- path segment, mirroring 'getDataStreams'). Wildcards (@*@) and +-- @_all@ are accepted by the server in place of literal names. +-- +-- Streams that have no options set appear in the response with their +-- @options@ field decoded as 'Nothing'. +-- +-- See +-- . +getDataStreamOptions :: + Maybe [DataStreamName] -> + BHRequest StatusDependant GetDataStreamOptionsResponse +getDataStreamOptions mDataStreamNames = + get @StatusDependant endpoint + where + endpoint = case mDataStreamNames of + Nothing -> ["_data_stream", "_options"] + Just [] -> ["_data_stream", "_options"] + Just (first : rest) -> + ["_data_stream", T.intercalate "," (renderDataStreamName <$> (first : rest)), "_options"] + renderDataStreamName (DataStreamName dsName) = dsName + +-- | 'updateDataStreamOptions' sets the options (e.g. failure store +-- configuration) of one or more data streams. The body carries an +-- 'UpdateDataStreamOptionsRequest'; the @failure_store@ override it +-- describes is applied to every stream resolved by the path's +-- name expression (literal names, comma-separated lists or +-- wildcards — see 'getDataStreamOptions'). +-- +-- /CAUTION/: when given @'Nothing'@ or @'Just' []@, the builder +-- substitutes the wildcard @*@ for the @{name}@ path segment, so the +-- @failure_store@ override is applied to /every/ data stream on the +-- cluster. Pass an explicit 'DataStreamName' list if you want to +-- scope the update. +-- +-- Referencing a non-existent stream surfaces as an 'EsError'. The +-- server's reaction to an empty PUT body (@{ }@, no @failure_store@ +-- key) is not specified by the ES docs and may be rejected; prefer +-- sending an explicit 'DataStreamFailureStore'. +-- +-- See +-- . +updateDataStreamOptions :: + Maybe [DataStreamName] -> + UpdateDataStreamOptionsRequest -> + BHRequest StatusDependant Acknowledged +updateDataStreamOptions mDataStreamNames req = + put @StatusDependant endpoint (encode req) + where + endpoint = case mDataStreamNames of + Nothing -> ["_data_stream", "*", "_options"] + Just [] -> ["_data_stream", "*", "_options"] + Just (first : rest) -> + ["_data_stream", T.intercalate "," (renderDataStreamName <$> (first : rest)), "_options"] + renderDataStreamName (DataStreamName dsName) = dsName + +-- | 'deleteDataStreamOptions' removes the options (e.g. failure store +-- configuration) from one or more data streams, resetting them to +-- their defaults. Returns 'Acknowledged' on success. The path's name +-- expression follows the same comma-separated\/wildcard rules as +-- 'getDataStreamOptions'. +-- +-- /CAUTION/: when given @'Nothing'@ or @'Just' []@, the builder +-- substitutes the wildcard @*@ for the @{name}@ path segment, so the +-- options are reset on /every/ data stream on the cluster. Pass an +-- explicit 'DataStreamName' list if you want to scope the deletion. +-- +-- Deleting the options of a non-existent stream fails with an HTTP +-- error (hence 'StatusDependant'), surfaced as an 'EsError'. +-- +-- See +-- . +deleteDataStreamOptions :: + Maybe [DataStreamName] -> + BHRequest StatusDependant Acknowledged +deleteDataStreamOptions mDataStreamNames = + delete @StatusDependant endpoint + where + endpoint = case mDataStreamNames of + Nothing -> ["_data_stream", "*", "_options"] + Just [] -> ["_data_stream", "*", "_options"] + Just (first : rest) -> + ["_data_stream", T.intercalate "," (renderDataStreamName <$> (first : rest)), "_options"] + renderDataStreamName (DataStreamName dsName) = dsName + +-- $dataStreamLifecycleStatsAndExplain +-- +-- /Data Stream Lifecycle Stats and Explain/ (ES 8.11+ for explain, +-- 8.12+ for stats, also in ES 9.x) report runtime status of the data +-- stream lifecycle service. Both endpoints live at the index level +-- (no @_data_stream@ path segment) because the lifecycle service +-- operates on backing indices rather than on streams directly. The +-- wire format is identical across ES 8.x and 9.x, so the request +-- builders live here and are re-exported by the ES9 client module. + +-- | 'getDataStreamLifecycleStats' retrieves cluster-wide runtime +-- statistics for the data stream lifecycle service. Issues +-- @GET /_lifecycle/stats@. The response carries aggregate timing +-- information plus a per-stream breakdown of backing-index health +-- (see 'DataStreamLifecycleStats'). +-- +-- The endpoint takes no path or query parameters; the response is +-- always a JSON body with the stats payload. +-- +-- See +-- . +getDataStreamLifecycleStats :: + BHRequest StatusDependant DataStreamLifecycleStats +getDataStreamLifecycleStats = + get @StatusDependant ["_lifecycle", "stats"] + +-- | URI query parameters accepted by +-- @GET /{index}/_lifecycle/explain@. The 'ExplainDataStreamLifecycleOptions' +-- record is defined in "Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.DataStream" +-- (alongside the rest of the lifecycle types); this helper renders it +-- as a list of @(key, value)@ query parameters suitable for 'withQueries'. +-- 'Nothing' fields are omitted; booleans render as @"true"@\/@"false"@. +explainDataStreamLifecycleOptionsParams :: ExplainDataStreamLifecycleOptions -> [(Text, Maybe Text)] +explainDataStreamLifecycleOptionsParams opts = + catMaybes + [ ("include_defaults",) . Just . boolQP <$> explainDataStreamLifecycleOptionsIncludeDefaults opts, + ("master_timeout",) . Just <$> explainDataStreamLifecycleOptionsMasterTimeout opts + ] + where + boolQP True = "true" + boolQP False = "false" + +-- | 'explainDataStreamLifecycle' retrieves the per-index lifecycle +-- status for one or more backing indices. Equivalent to +-- @'explainDataStreamLifecycleWith' indices 'defaultExplainDataStreamLifecycleOptions'@. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_lifecycle/explain@ (the +-- server interprets the missing @{index}@ segment as \"all +-- lifecycle-managed indices\"). +-- * @'Just' names@ → @GET /{a,b,c}/_lifecycle/explain@ +-- explains only the named backing indices (comma-joined path +-- segment). Backing index names typically look like +-- @.ds---@. +-- +-- See 'ExplainDataStreamLifecycleResponse' for the @indices@-map +-- response shape, and the operation docs at +-- . +explainDataStreamLifecycle :: + Maybe [IndexName] -> + BHRequest StatusDependant ExplainDataStreamLifecycleResponse +explainDataStreamLifecycle indices = + explainDataStreamLifecycleWith indices defaultExplainDataStreamLifecycleOptions + +-- | 'explainDataStreamLifecycleWith' is the fully-parameterised form +-- of 'explainDataStreamLifecycle'. Pass +-- 'defaultExplainDataStreamLifecycleOptions' to reproduce a +-- parameterless call. +explainDataStreamLifecycleWith :: + Maybe [IndexName] -> + ExplainDataStreamLifecycleOptions -> + BHRequest StatusDependant ExplainDataStreamLifecycleResponse +explainDataStreamLifecycleWith mIndices opts = + get @StatusDependant (endpoint `withQueries` explainDataStreamLifecycleOptionsParams opts) + where + endpoint = case mIndices of + Nothing -> ["_lifecycle", "explain"] + Just [] -> ["_lifecycle", "explain"] + Just (first : rest) -> + [T.intercalate "," (unIndexName <$> (first : rest)), "_lifecycle", "explain"] + +-- | 'eqlSearch' builds the 'BHRequest' for the EQL +-- @POST /{index}/_eql/search@ endpoint (Elasticsearch 8.x). The endpoint +-- path is identical to ES 7.10+, but the 8.x spec adds the +-- @allow_partial_search_results@, @allow_partial_sequence_results@ and +-- @case_sensitive@ body fields (plus the matching URI parameters), so the +-- ES8 builder uses the 'EQLRequestBodyES8' newtype and +-- 'eqlSearchOptionsParams8' rather than the ES7 'Requests7.eqlSearch'. +-- +-- For more information see +-- . +eqlSearch :: + (FromJSON a) => + IndexName -> + EQLRequest -> + BHRequest StatusDependant (ParsedEsResponse (EQLResult a)) +eqlSearch indexName = eqlSearchWith indexName defaultEQLSearchOptions + +-- | 'eqlSearchWith' is the fully-parameterised form of 'eqlSearch' +-- (Elasticsearch 8.x). The endpoint path matches ES 7.10+, but the body +-- is encoded via the 'EQLRequestBodyES8' newtype (which emits the 8.x +-- body fields @allow_partial_search_results@, +-- @allow_partial_sequence_results@ and @case_sensitive@) and the URI +-- parameters are rendered with 'eqlSearchOptionsParams8' (which emits +-- the 8.x-only @allow_partial_search_results@ and +-- @allow_partial_sequence_results@). See 'Requests7.eqlSearchWith' for +-- the ES7 variant that gates these out. +-- +-- For more information see +-- . +eqlSearchWith :: + (FromJSON a) => + IndexName -> + EQLSearchOptions -> + EQLRequest -> + BHRequest StatusDependant (ParsedEsResponse (EQLResult a)) +eqlSearchWith indexName opts req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (EQLRequestBodyES8 req)) + where + endpoint = + mkEndpoint [unIndexName indexName, "_eql", "search"] + `withQueries` eqlSearchOptionsParams8 opts + +-- | 'getEQLSearch' builds the 'BHRequest' for the async EQL +-- @GET /_eql/search\/{id}@ endpoint (Elasticsearch 8.x). The wire format +-- is identical to ES 7.10+, so the ES7 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +getEQLSearch :: + (FromJSON a) => + EQLSearchId -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse (EQLResult a)) +getEQLSearch = Requests7.getEQLSearch + +-- | 'getEQLStatus' builds the 'BHRequest' for the async EQL status +-- @GET /_eql/search/status\/{id}@ endpoint (Elasticsearch 8.x). The wire +-- format is identical to ES 7.10+, so the ES7 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +getEQLStatus :: + EQLSearchId -> + BHRequest StatusDependant EQLStatus +getEQLStatus = Requests7.getEQLStatus + +-- | 'deleteEQLSearch' builds the 'BHRequest' for the EQL +-- @DELETE /_eql/search/{id}@ endpoint on Elasticsearch 8. The wire +-- format is identical to ES 7.10+, so the ES7 request builder is +-- reused verbatim. +-- +-- For more information see +-- . +deleteEQLSearch :: + EQLSearchId -> + BHRequest StatusIndependant Acknowledged +deleteEQLSearch = Requests7.deleteEQLSearch + +-- | 'getTermsEnum' builds the 'BHRequest' for the terms enum +-- @GET \/{index}\/_terms_enum@ endpoint (Elasticsearch >= 7.10). The +-- wire format is identical to ES 7.10+, so the ES7 request builder is +-- reused verbatim. +-- +-- For more information see +-- . +getTermsEnum :: + Maybe [IndexName] -> + FieldName -> + Maybe Text -> + BHRequest StatusDependant TermsEnumResponse +getTermsEnum = Requests7.getTermsEnum + +-- | 'getTermsEnumWith' is the fully-parameterised variant of +-- 'getTermsEnum' (ES >= 7.10). The wire format is identical to +-- ES 7.10+, so the ES7 request builder is reused verbatim. +getTermsEnumWith :: + Maybe [IndexName] -> + TermsEnumOptions -> + TermsEnumRequest -> + BHRequest StatusDependant TermsEnumResponse +getTermsEnumWith = Requests7.getTermsEnumWith + +-- | 'putQueryRuleset' builds the 'BHRequest' for +-- @PUT \/_query_rules\/{ruleset_id}@ (Elasticsearch 8.9+), which +-- creates or replaces a query ruleset. The body is the encoded +-- 'QueryRuleset'; the server returns a 'QueryRulesetPutResponse' +-- whose @result@ field is @"created"@ or @"updated"@. +-- +-- For more information see +-- . +putQueryRuleset :: + RulesetId -> + QueryRuleset -> + BHRequest StatusDependant QueryRulesetPutResponse +putQueryRuleset rulesetId ruleset = + put @StatusDependant endpoint (encode ruleset) + where + endpoint = mkEndpoint ["_query_rules", unRulesetId rulesetId] + +-- | 'getQueryRuleset' builds the 'BHRequest' for +-- @GET \/_query_rules\/{ruleset_id}@ (Elasticsearch 8.9+), which +-- returns the stored ruleset and its metadata. A @404@ for a missing +-- ruleset surfaces as an 'EsError'; wrap with 'tryPerformBHRequest' +-- for miss-tolerant reads. +-- +-- For more information see +-- . +getQueryRuleset :: + RulesetId -> + BHRequest StatusDependant QueryRulesetInfo +getQueryRuleset rulesetId = + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_query_rules", unRulesetId rulesetId] + +-- | 'deleteQueryRuleset' builds the 'BHRequest' for +-- @DELETE \/_query_rules\/{ruleset_id}@ (Elasticsearch 8.9+), which +-- removes a ruleset. Returns 'Acknowledged' on success. Deleting a +-- non-existent ruleset surfaces as an 'EsError'; wrap with +-- 'tryPerformBHRequest' for miss-tolerant deletion. +-- +-- For more information see +-- . +deleteQueryRuleset :: + RulesetId -> + BHRequest StatusDependant Acknowledged +deleteQueryRuleset rulesetId = + delete (mkEndpoint ["_query_rules", unRulesetId rulesetId]) + +-- | 'testQueryRuleset' builds the 'BHRequest' for +-- @POST \/_query_rules\/{ruleset_id}\/_test@ (Elasticsearch 8.10+), +-- which evaluates the supplied 'QueryRulesetTest' match criteria +-- against every rule in the stored ruleset and reports the matching +-- rule identifiers. The body is the encoded 'QueryRulesetTest'; the +-- server returns a 'QueryRulesetTestResponse'. +-- +-- For more information see +-- . +testQueryRuleset :: + RulesetId -> + QueryRulesetTest -> + BHRequest StatusDependant QueryRulesetTestResponse +testQueryRuleset rulesetId body = + post @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_query_rules", unRulesetId rulesetId, "_test"] + +-- | 'putSearchApplication' builds the 'BHRequest' for +-- @PUT \/_application\/search_application\/{name}@ (Elasticsearch 8.6+), +-- which creates or replaces a search application. The body is a +-- 'SearchApplication' record: its 'saIndices' field (a non-empty list of +-- 'IndexName', encoded as the @indices@ JSON array) is required and +-- names the search application's target indices, while +-- 'saAnalyticsCollectionName' (encoded as @analytics_collection_name@) +-- and 'saTemplate' (encoded as @template@) are optional. The server +-- returns a 'SearchApplicationPutResponse' whose @result@ field is +-- @"created"@ or @"updated"@. +-- +-- For more information see +-- . +putSearchApplication :: + SearchApplicationName -> + SearchApplication -> + BHRequest StatusDependant SearchApplicationPutResponse +putSearchApplication appName app = + putSearchApplicationWith appName defaultSearchApplicationPutOptions app + +-- | 'putSearchApplicationWith' is the fully-parameterised form of +-- 'putSearchApplication'. 'SearchApplicationPutOptions' carries the +-- @create@ query parameter documented at +-- : +-- passing @'Just' 'True'@ emits @?create=true@, which makes the request +-- fail if the search application already exists. Passing +-- 'defaultSearchApplicationPutOptions' yields a request byte-for-byte +-- identical to 'putSearchApplication'. +putSearchApplicationWith :: + SearchApplicationName -> + SearchApplicationPutOptions -> + SearchApplication -> + BHRequest StatusDependant SearchApplicationPutResponse +putSearchApplicationWith appName opts app = + put @StatusDependant endpoint (encode app) + where + endpoint = + mkEndpoint ["_application", "search_application", unSearchApplicationName appName] + `withQueries` queries + queries = + catMaybes + [ ("create",) . Just . boolText <$> sapoCreate opts + ] + boolText :: Bool -> Text + boolText True = "true" + boolText False = "false" + +-- | 'getSearchApplication' builds the 'BHRequest' for +-- @GET \/_application\/search_application\/{name}@ (Elasticsearch 8.6+), +-- which returns the stored search application and its metadata. A @404@ +-- for a missing application surfaces as an 'EsError'; wrap with +-- 'tryPerformBHRequest' for miss-tolerant reads. +-- +-- For more information see +-- . +getSearchApplication :: + SearchApplicationName -> + BHRequest StatusDependant SearchApplicationInfo +getSearchApplication appName = + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_application", "search_application", unSearchApplicationName appName] + +-- | 'deleteSearchApplication' builds the 'BHRequest' for +-- @DELETE \/_application\/search_application\/{name}@ (Elasticsearch +-- 8.6+), which removes a search application. Returns 'Acknowledged' on +-- success. Deleting a non-existent application surfaces as an +-- 'EsError'; wrap with 'tryPerformBHRequest' for miss-tolerant +-- deletion. +-- +-- For more information see +-- . +deleteSearchApplication :: + SearchApplicationName -> + BHRequest StatusDependant Acknowledged +deleteSearchApplication appName = + delete (mkEndpoint ["_application", "search_application", unSearchApplicationName appName]) + +-- | 'searchApplication' builds the 'BHRequest' for +-- @POST \/_application\/search_application\/{name}\/_search@ +-- (Elasticsearch 8.6+), which runs the search application's stored +-- template against its indices. The optional +-- 'SearchApplicationSearchParams' carries per-request template +-- parameter overrides; 'Nothing' runs the template with its defaults. +-- The response is a regular 'SearchResult' parameterized by the +-- document-source type @a@. +-- +-- For more information see +-- . +searchApplication :: + (FromJSON a) => + SearchApplicationName -> + Maybe SearchApplicationSearchParams -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult a)) +searchApplication appName mParams = + searchApplicationWith appName mParams defaultSearchApplicationOptions + +-- | 'searchApplicationWith' is the fully-parameterised form of +-- 'searchApplication'. 'SearchApplicationOptions' carries the @typed_keys@ +-- query parameter documented at +-- : +-- when @'Just' 'True'@ the response returns aggregation names prefixed with +-- their type (e.g. @aggregations#terms@). Passing +-- 'defaultSearchApplicationOptions' yields a request byte-for-byte identical +-- to 'searchApplication'. +-- +-- For more information see +-- . +searchApplicationWith :: + (FromJSON a) => + SearchApplicationName -> + Maybe SearchApplicationSearchParams -> + SearchApplicationOptions -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult a)) +searchApplicationWith appName mParams opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = + mkEndpoint ["_application", "search_application", unSearchApplicationName appName, "_search"] + `withQueries` searchApplicationOptionsParams opts + body = maybe L.empty encode mParams + +-- | 'listSearchApplications' builds the 'BHRequest' for +-- @GET \/_application\/search_application@ (Elasticsearch 8.6+), which +-- lists configured search applications. Returns a +-- 'SearchApplicationListResponse' whose @results@ each reuse the +-- 'SearchApplicationInfo' shape (typically carrying only @name@ and +-- @updated_at_millis@ per item). Passing +-- 'listSearchApplicationsWith' with 'defaultSearchApplicationListOptions' +-- is byte-for-byte identical to this function; use it to attach the +-- @q@\/@from@\/@size@ query parameters. +-- +-- For more information see +-- . +listSearchApplications :: + BHRequest StatusDependant SearchApplicationListResponse +listSearchApplications = + listSearchApplicationsWith defaultSearchApplicationListOptions + +-- | 'listSearchApplicationsWith' is the fully-parameterised form of +-- 'listSearchApplications'. 'SearchApplicationListOptions' carries the +-- @q@ (Lucene query-string filter), @from@ (offset) and @size@ (max +-- results) query parameters documented at +-- . +-- Passing 'defaultSearchApplicationListOptions' yields a request +-- byte-for-byte identical to 'listSearchApplications'. +-- +-- For more information see +-- . +listSearchApplicationsWith :: + SearchApplicationListOptions -> + BHRequest StatusDependant SearchApplicationListResponse +listSearchApplicationsWith opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_application", "search_application"] + `withQueries` searchApplicationListOptionsParams opts + +-- | 'renderSearchApplicationQuery' builds the 'BHRequest' for +-- @POST \/_application\/search_application\/{name}\/_render_query@ +-- (Elasticsearch 8.6+), which renders the search application's stored +-- template against the supplied parameters and returns the resulting +-- Elasticsearch query body /without/ executing the search. The optional +-- 'SearchApplicationSearchParams' carries per-request template parameter +-- overrides — the same body shape as 'searchApplication' — and +-- 'Nothing' renders the template with its defaults. The response is the +-- rendered search-request body (e.g. @from@, @size@, @query@, @explain@) +-- returned as an opaque 'Value', mirroring how +-- 'SearchApplicationScriptBody' keeps inline search bodies untyped. +-- +-- For more information see +-- . +renderSearchApplicationQuery :: + SearchApplicationName -> + Maybe SearchApplicationSearchParams -> + BHRequest StatusDependant Value +renderSearchApplicationQuery appName mParams = + post @StatusDependant endpoint body + where + endpoint = + mkEndpoint ["_application", "search_application", unSearchApplicationName appName, "_render_query"] + body = maybe L.empty encode mParams + +-- | 'putSynonymsSet' builds the 'BHRequest' for +-- @PUT \/_synonyms\/{synonyms_set_id}@ (Elasticsearch 8.10+), which +-- creates or replaces a synonyms set. The body is the encoded +-- 'SynonymsSet'; the server returns a 'SynonymsSetPutResponse' whose +-- @acknowledged@ and/or @result@ fields are populated depending on +-- whether analyzer reloading occurred. +-- +-- For more information see +-- . +putSynonymsSet :: + SynonymsSetId -> + SynonymsSet -> + BHRequest StatusDependant SynonymsSetPutResponse +putSynonymsSet setId body = + put @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_synonyms", unSynonymsSetId setId] + +-- | 'getSynonymsSet' builds the 'BHRequest' for +-- @GET \/_synonyms\/{synonyms_set_id}@ (Elasticsearch 8.10+), which +-- returns the stored synonyms set. Equivalent to +-- @'getSynonymsSetWith' setId 'defaultSynonymsGetOptions'@ — emits no +-- query string and relies on the server-side @from@\/@size@ defaults +-- (@0@ and @10@). A @404@ for a missing set surfaces as an 'EsError'; +-- wrap with 'tryPerformBHRequest' for miss-tolerant reads. +-- +-- For more information see +-- . +getSynonymsSet :: + SynonymsSetId -> + BHRequest StatusDependant SynonymsSetInfo +getSynonymsSet setId = + getSynonymsSetWith setId defaultSynonymsGetOptions + +-- | 'getSynonymsSetWith' is the fully-parameterised variant of +-- 'getSynonymsSet'. 'SynonymsGetOptions' carries the @from@ (offset) +-- and @size@ (max synonym rules) query parameters documented at +-- . +-- Passing 'defaultSynonymsGetOptions' yields a request byte-for-byte +-- identical to 'getSynonymsSet'. +getSynonymsSetWith :: + SynonymsSetId -> + SynonymsGetOptions -> + BHRequest StatusDependant SynonymsSetInfo +getSynonymsSetWith setId opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_synonyms", unSynonymsSetId setId] + `withQueries` synonymsGetOptionsParams opts + +-- | 'deleteSynonymsSet' builds the 'BHRequest' for +-- @DELETE \/_synonyms\/{synonyms_set_id}@ (Elasticsearch 8.10+), which +-- removes a synonyms set. Returns 'Acknowledged' on success. Deleting +-- a non-existent set surfaces as an 'EsError'; wrap with +-- 'tryPerformBHRequest' for miss-tolerant deletion. +-- +-- For more information see +-- . +deleteSynonymsSet :: + SynonymsSetId -> + BHRequest StatusDependant Acknowledged +deleteSynonymsSet setId = + delete (mkEndpoint ["_synonyms", unSynonymsSetId setId]) + +------------------------------------------------------------------------------ +-- Behavioral analytics (/_application/analytics/*) +------------------------------------------------------------------------------ + +-- $behavioralAnalytics +-- +-- /Behavioral analytics/ (Elasticsearch 8.7+) backs the search-curator +-- feature: a named /collection/ is a sink for client-side search events +-- (searches, clicks, page views), backed by an Elasticsearch index. +-- +-- * @GET /_application/analytics@ — list every collection +-- ('getAnalyticsCollections' with 'Nothing'). +-- * @GET /_application/analytics/{name}@ — fetch a single collection +-- ('getAnalyticsCollections' with @'Just' name@). +-- * @PUT /_application/analytics/{name}@ — create or replace a +-- collection ('putAnalyticsCollection'). +-- * @DELETE /_application/analytics/{name}@ — delete a collection and +-- its backing index ('deleteAnalyticsCollection'). +-- * @POST /_application/analytics/{collection_name}/event/{event_type}@ — +-- ingest a single behavioral event ('postAnalyticsEvent' / +-- 'postAnalyticsEventWith'). + +-- | 'getAnalyticsCollections' lists behavioral analytics collections. +-- Maps to the @GET /_application/analytics@ family: +-- +-- * @'Nothing'@ → @GET /_application/analytics@ returns every +-- collection. +-- * @'Just' name@ → @GET /_application/analytics/{name}@ returns only +-- the named collection. +-- +-- The server always answers with a JSON object keyed by collection +-- name; the 'AnalyticsCollectionsResponse' decoder flattens that map +-- into a list of 'AnalyticsCollection' (each carrying its name). +getAnalyticsCollections :: + Maybe AnalyticsCollectionName -> + BHRequest StatusDependant [AnalyticsCollection] +getAnalyticsCollections mName = + unAnalyticsCollectionsResponse <$> get @StatusDependant endpoint + where + endpoint = case mName of + Nothing -> mkEndpoint ["_application", "analytics"] + Just (AnalyticsCollectionName n) -> + mkEndpoint ["_application", "analytics", n] + +-- | 'putAnalyticsCollection' creates or replaces a behavioral analytics +-- collection. Maps to @PUT /_application/analytics/{name}@. The endpoint +-- takes no request body in its documented shape; the server mints the +-- backing index from the collection name. +putAnalyticsCollection :: + AnalyticsCollectionName -> + BHRequest StatusDependant AnalyticsCollectionPutResponse +putAnalyticsCollection (AnalyticsCollectionName n) = + put @StatusDependant ["_application", "analytics", n] emptyBody + +-- | 'deleteAnalyticsCollection' deletes a behavioral analytics +-- collection and its backing index. Maps to +-- @DELETE /_application/analytics/{name}@. Deleting a non-existent +-- collection surfaces as an 'EsError'; wrap with 'tryPerformBHRequest' +-- for miss-tolerant deletion. +deleteAnalyticsCollection :: + AnalyticsCollectionName -> + BHRequest StatusDependant Acknowledged +deleteAnalyticsCollection (AnalyticsCollectionName n) = + delete (mkEndpoint ["_application", "analytics", n]) + +-- | 'postAnalyticsEvent' ingests a single behavioral event. Maps to +-- @POST /_application/analytics/{collection_name}/event/{event_type}@. +-- The event payload is an opaque 'Value' (the schema is event-type +-- specific and caller-defined). Equivalent to +-- @'postAnalyticsEventWith' 'defaultAnalyticsEventOptions'@. +postAnalyticsEvent :: + AnalyticsCollectionName -> + AnalyticsEventType -> + Value -> + BHRequest StatusDependant AnalyticsEventResponse +postAnalyticsEvent = + postAnalyticsEventWith defaultAnalyticsEventOptions + +-- | 'postAnalyticsEventWith' is the fully-parameterised form of +-- 'postAnalyticsEvent'. 'AnalyticsEventOptions' carries the @debug@ +-- query parameter: @'Just' 'True'@ validates the event without +-- persisting it. +postAnalyticsEventWith :: + AnalyticsEventOptions -> + AnalyticsCollectionName -> + AnalyticsEventType -> + Value -> + BHRequest StatusDependant AnalyticsEventResponse +postAnalyticsEventWith opts (AnalyticsCollectionName coll) (AnalyticsEventType evType) payload = + post @StatusDependant endpoint (encode payload) + where + endpoint = + mkEndpoint ["_application", "analytics", coll, "event", evType] + `withQueries` analyticsEventOptionsParams opts + +------------------------------------------------------------------------------ +-- Connectors (/_connector/*) +------------------------------------------------------------------------------ + +-- $connectors +-- +-- /Connectors/ (Elasticsearch 8.8+) are the configuration entities the +-- Elastic Connector Framework uses to sync an external data source into +-- an Elasticsearch index. The API splits into connector CRUD + +-- per-field @update-*@ endpoints (under @/_connector/{id}@) and a +-- parallel sync-job surface (under @/_connector/_sync_job/{id}@). ES8 +-- only — no ES7 nor OpenSearch equivalent on this path. +-- +-- The response envelopes are intentionally not uniform (see +-- "Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Connectors"): +-- GET returns the bare entity; create returns @{"result","id"}@; +-- mutations return @{"result"}@ or an opaque object; DELETE returns +-- @{"acknowledged"}@; list returns @{"count","results"}@. + +-- Connector path helpers. Each returns a ready-to-use 'Endpoint' (the +-- verb functions expect an 'Endpoint', and 'OverloadedLists' only +-- rewrites list /literals/, not list-typed values, so the helpers apply +-- 'mkEndpoint' themselves). +connectorPath :: ConnectorId -> [Text] -> Endpoint +connectorPath (ConnectorId cid) suffix = + mkEndpoint (["_connector", cid] <> suffix) + +syncJobPath :: ConnectorSyncJobId -> [Text] -> Endpoint +syncJobPath (ConnectorSyncJobId jid) suffix = + mkEndpoint (["_connector", "_sync_job", jid] <> suffix) + +-- | 'createConnector' creates a connector. Maps to @POST /_connector@. +-- The server mints the id and returns 'ConnectorCreateResponse'. +createConnector :: + CreateConnectorRequest -> + BHRequest StatusDependant ConnectorCreateResponse +createConnector body = + post @StatusDependant ["_connector"] (encode body) + +-- | 'putConnector' creates or fully replaces a connector by id. Maps to +-- @PUT /_connector/{connector_id}@. +putConnector :: + ConnectorId -> + CreateConnectorRequest -> + BHRequest StatusDependant ConnectorCreateResponse +putConnector cid body = + put @StatusDependant (connectorPath cid []) (encode body) + +-- | 'getConnector' fetches a connector by id. Maps to +-- @GET /_connector/{connector_id}@. +getConnector :: + ConnectorId -> + BHRequest StatusDependant Connector +getConnector cid = get @StatusDependant (connectorPath cid []) + +-- | 'deleteConnector' deletes a connector by id. Maps to +-- @DELETE /_connector/{connector_id}@. Equivalent to +-- @'deleteConnectorWith' 'Nothing'@. +deleteConnector :: + ConnectorId -> + BHRequest StatusDependant Acknowledged +deleteConnector = deleteConnectorWith Nothing + +-- | 'deleteConnectorWith' is the fully-parameterised form of +-- 'deleteConnector'. Setting @'Just' 'True'@ also deletes the +-- connector's pending sync jobs (@?delete_sync_jobs=true@). +deleteConnectorWith :: + Maybe Bool -> + ConnectorId -> + BHRequest StatusDependant Acknowledged +deleteConnectorWith mDeleteSyncJobs cid = + delete (connectorPath cid [] `withQueries` qs) + where + qs = catMaybes [("delete_sync_jobs",) . Just . boolQP <$> mDeleteSyncJobs] + boolQP True = "true" + boolQP False = "false" + +-- | 'listConnectors' lists configured connectors. Maps to +-- @GET /_connector@. Equivalent to @'listConnectorsWith' +-- 'defaultConnectorListOptions'@. +listConnectors :: + BHRequest StatusDependant ConnectorListResponse +listConnectors = listConnectorsWith defaultConnectorListOptions + +-- | 'listConnectorsWith' is the fully-parameterised form of +-- 'listConnectors'. +listConnectorsWith :: + ConnectorListOptions -> + BHRequest StatusDependant ConnectorListResponse +listConnectorsWith opts = + get @StatusDependant + (mkEndpoint ["_connector"] `withQueries` connectorListOptionsParams opts) + +-- | 'checkInConnector' records a connector heartbeat. Maps to +-- @PUT /_connector/{connector_id}/_check_in@ and returns +-- 'ConnectorMutationResult'. +checkInConnector :: + ConnectorId -> + BHRequest StatusDependant ConnectorMutationResult +checkInConnector cid = + put @StatusDependant (connectorPath cid ["_check_in"]) emptyBody + +-- | 'updateConnectorApiKeyId' sets the connector's API key id + secret +-- id. Maps to @PUT /_connector/{connector_id}/_api_key_id@. +updateConnectorApiKeyId :: + ConnectorId -> + UpdateConnectorApiKeyRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorApiKeyId cid body = + put @StatusDependant (connectorPath cid ["_api_key_id"]) (encode body) + +-- | 'updateConnectorConfiguration' updates the connector configuration +-- field. Maps to @PUT /_connector/{connector_id}/_configuration@. +updateConnectorConfiguration :: + ConnectorId -> + UpdateConnectorConfigurationRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorConfiguration cid body = + put @StatusDependant (connectorPath cid ["_configuration"]) (encode body) + +-- | 'updateConnectorError' sets or clears the connector error field. +-- Maps to @PUT /_connector/{connector_id}/_error@. +updateConnectorError :: + ConnectorId -> + UpdateConnectorErrorRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorError cid body = + put @StatusDependant (connectorPath cid ["_error"]) (encode body) + +-- | 'updateConnectorFeatures' overrides DLS / incremental / sync-rule +-- features. Maps to @PUT /_connector/{connector_id}/_features@. +updateConnectorFeatures :: + ConnectorId -> + UpdateConnectorFeaturesRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorFeatures cid body = + put @StatusDependant (connectorPath cid ["_features"]) (encode body) + +-- | 'updateConnectorFiltering' updates the connector draft filtering. +-- Maps to @PUT /_connector/{connector_id}/_filtering@. +updateConnectorFiltering :: + ConnectorId -> + UpdateConnectorFilteringRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorFiltering cid body = + put @StatusDependant (connectorPath cid ["_filtering"]) (encode body) + +-- | 'updateConnectorDraftFilteringValidation' updates the draft +-- filtering validation info. Maps to +-- @PUT /_connector/{connector_id}/_filtering/_validation@. +updateConnectorDraftFilteringValidation :: + ConnectorId -> + UpdateConnectorFilteringValidationRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorDraftFilteringValidation cid body = + put + @StatusDependant + (connectorPath cid ["_filtering", "_validation"]) + (encode body) + +-- | 'activateConnectorDraftFiltering' activates the valid draft filter. +-- Maps to @PUT /_connector/{connector_id}/_filtering/_activate@. +activateConnectorDraftFiltering :: + ConnectorId -> + BHRequest StatusDependant ConnectorMutationResult +activateConnectorDraftFiltering cid = + put + @StatusDependant + (connectorPath cid ["_filtering", "_activate"]) + emptyBody + +-- | 'updateConnectorIndexName' sets (or, with 'Nothing', clears) the +-- destination index name. Maps to +-- @PUT /_connector/{connector_id}/_index_name@. +updateConnectorIndexName :: + ConnectorId -> + UpdateConnectorIndexNameRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorIndexName cid body = + put @StatusDependant (connectorPath cid ["_index_name"]) (encode body) + +-- | 'updateConnectorNameDescription' updates the connector name and +-- description. Maps to @PUT /_connector/{connector_id}/_name@. +updateConnectorNameDescription :: + ConnectorId -> + UpdateConnectorNameDescriptionRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorNameDescription cid body = + put @StatusDependant (connectorPath cid ["_name"]) (encode body) + +-- | 'updateConnectorNative' toggles the @is_native@ flag. Maps to +-- @PUT /_connector/{connector_id}/_native@. +updateConnectorNative :: + ConnectorId -> + UpdateConnectorNativeRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorNative cid body = + put @StatusDependant (connectorPath cid ["_native"]) (encode body) + +-- | 'updateConnectorPipeline' updates the ingest pipeline. Maps to +-- @PUT /_connector/{connector_id}/_pipeline@. +updateConnectorPipeline :: + ConnectorId -> + UpdateConnectorPipelineRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorPipeline cid body = + put @StatusDependant (connectorPath cid ["_pipeline"]) (encode body) + +-- | 'updateConnectorScheduling' updates the scheduling. Maps to +-- @PUT /_connector/{connector_id}/_scheduling@. +updateConnectorScheduling :: + ConnectorId -> + UpdateConnectorSchedulingRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorScheduling cid body = + put @StatusDependant (connectorPath cid ["_scheduling"]) (encode body) + +-- | 'updateConnectorServiceType' updates the service type. Maps to +-- @PUT /_connector/{connector_id}/_service_type@. +updateConnectorServiceType :: + ConnectorId -> + UpdateConnectorServiceTypeRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorServiceType cid body = + put @StatusDependant (connectorPath cid ["_service_type"]) (encode body) + +-- | 'updateConnectorStatus' updates the status. Maps to +-- @PUT /_connector/{connector_id}/_status@. +updateConnectorStatus :: + ConnectorId -> + UpdateConnectorStatusRequest -> + BHRequest StatusDependant ConnectorMutationResult +updateConnectorStatus cid body = + put @StatusDependant (connectorPath cid ["_status"]) (encode body) + +------------------------------------------------------------------------------ +-- Connector sync jobs (/_connector/_sync_job/*) +------------------------------------------------------------------------------ + +-- | 'createConnectorSyncJob' creates a sync job. Maps to +-- @POST /_connector/_sync_job@. The server returns +-- 'ConnectorSyncJobCreateResponse' (a bare id — no @result@ field, +-- unlike connector create). +createConnectorSyncJob :: + CreateConnectorSyncJobRequest -> + BHRequest StatusDependant ConnectorSyncJobCreateResponse +createConnectorSyncJob body = + post @StatusDependant ["_connector", "_sync_job"] (encode body) + +-- | 'getConnectorSyncJob' fetches a sync job by id. Maps to +-- @GET /_connector/_sync_job/{connector_sync_job_id}@. +getConnectorSyncJob :: + ConnectorSyncJobId -> + BHRequest StatusDependant ConnectorSyncJob +getConnectorSyncJob jid = get @StatusDependant (syncJobPath jid []) + +-- | 'listConnectorSyncJobs' lists sync jobs. Maps to +-- @GET /_connector/_sync_job@. Equivalent to +-- @'listConnectorSyncJobsWith' 'defaultConnectorSyncJobListOptions'@. +listConnectorSyncJobs :: + BHRequest StatusDependant ConnectorSyncJobListResponse +listConnectorSyncJobs = + listConnectorSyncJobsWith defaultConnectorSyncJobListOptions + +-- | 'listConnectorSyncJobsWith' is the fully-parameterised form of +-- 'listConnectorSyncJobs'. +listConnectorSyncJobsWith :: + ConnectorSyncJobListOptions -> + BHRequest StatusDependant ConnectorSyncJobListResponse +listConnectorSyncJobsWith opts = + get + @StatusDependant + ( mkEndpoint ["_connector", "_sync_job"] + `withQueries` connectorSyncJobListOptionsParams opts + ) + +-- | 'deleteConnectorSyncJob' deletes a sync job by id. Maps to +-- @DELETE /_connector/_sync_job/{connector_sync_job_id}@. +deleteConnectorSyncJob :: + ConnectorSyncJobId -> + BHRequest StatusDependant Acknowledged +deleteConnectorSyncJob jid = + delete (syncJobPath jid []) + +-- | 'cancelConnectorSyncJob' requests cancellation of a sync job. Maps +-- to @PUT /_connector/_sync_job/{id}/_cancel@ and returns +-- 'ConnectorMutationResult'. +cancelConnectorSyncJob :: + ConnectorSyncJobId -> + BHRequest StatusDependant ConnectorMutationResult +cancelConnectorSyncJob jid = + put @StatusDependant (syncJobPath jid ["_cancel"]) emptyBody + +-- | 'checkInConnectorSyncJob' records a sync-job heartbeat. Maps to +-- @PUT /_connector/_sync_job/{id}/_check_in@. The response schema is +-- undocumented, so it is returned as an opaque 'Value'. +checkInConnectorSyncJob :: + ConnectorSyncJobId -> + BHRequest StatusDependant Value +checkInConnectorSyncJob jid = + put @StatusDependant (syncJobPath jid ["_check_in"]) emptyBody + +-- | 'claimConnectorSyncJob' claims a sync job for a worker. Maps to +-- @PUT /_connector/_sync_job/{id}/_claim@. The response schema is +-- undocumented, so it is returned as an opaque 'Value'. +claimConnectorSyncJob :: + ConnectorSyncJobId -> + ClaimConnectorSyncJobRequest -> + BHRequest StatusDependant Value +claimConnectorSyncJob jid body = + put @StatusDependant (syncJobPath jid ["_claim"]) (encode body) + +-- | 'setConnectorSyncJobError' sets the error on a sync job. Maps to +-- @PUT /_connector/_sync_job/{id}/_error@. The response schema is +-- undocumented, so it is returned as an opaque 'Value'. +setConnectorSyncJobError :: + ConnectorSyncJobId -> + SetConnectorSyncJobErrorRequest -> + BHRequest StatusDependant Value +setConnectorSyncJobError jid body = + put @StatusDependant (syncJobPath jid ["_error"]) (encode body) + +-- | 'setConnectorSyncJobStats' updates the per-run counters of a sync +-- job. Maps to @PUT /_connector/_sync_job/{id}/_stats@. The response +-- schema is undocumented, so it is returned as an opaque 'Value'. +setConnectorSyncJobStats :: + ConnectorSyncJobId -> + SetConnectorSyncJobStatsRequest -> + BHRequest StatusDependant Value +setConnectorSyncJobStats jid body = + put @StatusDependant (syncJobPath jid ["_stats"]) (encode body) + +------------------------------------------------------------------------------ +-- Migration reindex (/_migration/reindex, /_create_from) +------------------------------------------------------------------------------ + +-- $migrationReindex +-- +-- /Migration reindex/ endpoints (GA since ES 8.18.0, unchanged in 9.x) +-- upgrade the legacy backing indices of a data stream as part of a +-- major-version migration. Four operations: +-- +-- * @POST /_migration/reindex@ — kicks off the background reindex +-- ('migrateReindex'); returns 'Acknowledged'. +-- * @POST /_migration/reindex/{index}/_cancel@ — cancels an in-progress +-- attempt ('cancelMigrateReindex'); returns 'Acknowledged'. +-- * @GET /_migration/reindex/{index}/_status@ — observes progress +-- ('getMigrateReindexStatus'); returns 'MigrateReindexStatus'. +-- * @POST /_create_from/{source}/{dest}@ — copies mappings and settings +-- from a source index into a fresh destination index +-- ('createIndexFrom' \/ 'createIndexFromWith'); returns +-- 'CreateIndexFromResponse'. +-- +-- The @{index}@ path segment accepts one or more comma-separated names +-- (the ES @_types.Indices@ type); the builders below take a 'NonEmpty' +-- 'IndexName' and render it comma-joined. + +-- | Render a 'NonEmpty' 'IndexName' as the comma-joined @{index}@ path +-- segment used by the cancel and status endpoints. +renderMigrationReindexIndices :: NonEmpty IndexName -> Text +renderMigrationReindexIndices = T.intercalate "," . map unIndexName . toList + +-- | 'migrateReindex' builds the 'BHRequest' for +-- @POST /_migration/reindex@ (ES 8.18+), which reindexes all legacy +-- backing indices of a data stream. The body is the encoded +-- 'MigrateReindexRequest' (use 'mkMigrateReindexRequest' to build the +-- canonical @upgrade@ request for a given data stream). The reindex runs +-- in a persistent task, so the endpoint returns 'Acknowledged' +-- immediately rather than a 'ReindexResponse'; poll +-- 'getMigrateReindexStatus' to observe progress. +-- +-- For more information see +-- . +migrateReindex :: + MigrateReindexRequest -> + BHRequest StatusDependant Acknowledged +migrateReindex req = + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_migration", "reindex"] + +-- | 'cancelMigrateReindex' builds the 'BHRequest' for +-- @POST /_migration/reindex/{index}/_cancel@ (ES 8.18+), which cancels +-- an in-progress migration reindex attempt for the given data stream(s) +-- or index(es). Carries no body; returns 'Acknowledged' on success. +-- +-- For more information see +-- . +cancelMigrateReindex :: + NonEmpty IndexName -> + BHRequest StatusDependant Acknowledged +cancelMigrateReindex indices = + post @StatusDependant endpoint emptyBody + where + endpoint = + mkEndpoint + ["_migration", "reindex", renderMigrationReindexIndices indices, "_cancel"] + +-- | 'getMigrateReindexStatus' builds the 'BHRequest' for +-- @GET /_migration/reindex/{index}/_status@ (ES 8.18+), which reports the +-- status of a migration reindex attempt for the given data stream(s) or +-- index(es). Carries no body; the response is decoded into +-- 'MigrateReindexStatus'. +-- +-- For more information see +-- . +getMigrateReindexStatus :: + NonEmpty IndexName -> + BHRequest StatusDependant MigrateReindexStatus +getMigrateReindexStatus indices = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint + ["_migration", "reindex", renderMigrationReindexIndices indices, "_status"] + +-- | 'createIndexFrom' builds the 'BHRequest' for +-- @POST /_create_from/{source}/{dest}@ (ES 8.18+), which copies the +-- mappings and settings from a source index into a fresh destination +-- index. Equivalent to @'createIndexFromWith' source dest Nothing@ — no +-- overrides, no body (the server applies its own defaults, including +-- @remove_index_blocks = true@). Returns 'CreateIndexFromResponse' on +-- success. +-- +-- For more information see +-- . +createIndexFrom :: + IndexName -> + IndexName -> + BHRequest StatusDependant CreateIndexFromResponse +createIndexFrom source dest = createIndexFromWith source dest Nothing + +-- | 'createIndexFromWith' is the fully-parameterised variant of +-- 'createIndexFrom', accepting an optional 'CreateIndexFromBody' whose +-- @mappings_override@ and @settings_override@ override the source +-- values. Pass 'Nothing' to send no body — wire-semantically equivalent +-- to 'createIndexFrom' (the server applies its own defaults, including +-- @remove_index_blocks = true@). +createIndexFromWith :: + IndexName -> + IndexName -> + Maybe CreateIndexFromBody -> + BHRequest StatusDependant CreateIndexFromResponse +createIndexFromWith source dest mBody = + post @StatusDependant endpoint (maybe emptyBody encode mBody) + where + endpoint = + mkEndpoint ["_create_from", unIndexName source, unIndexName dest] diff --git a/src/Database/Bloodhound/ElasticSearch8/Types.hs b/src/Database/Bloodhound/ElasticSearch8/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/ElasticSearch8/Types.hs @@ -0,0 +1,513 @@ +module Database.Bloodhound.ElasticSearch8.Types + ( module Reexport, + ESQLRequest (..), + ESQLResult (..), + ESQLColumn (..), + AsyncESQLRequest (..), + mkAsyncESQLRequest, + AsyncESQLId (..), + AsyncESQLResult (..), + ESQLQueryOptions (..), + defaultESQLQueryOptions, + esqlOptionsParams, + GetAsyncESQLOptions (..), + defaultGetAsyncESQLOptions, + getAsyncESQLOptionsParams, + EsqlClusters (..), + EsqlClusterDetails (..), + EsqlClusterStatus (..), + esqlClusterStatusToText, + esqlClusterStatusFromText, + EsqlProfile (..), + EsqlProfileSection (..), + esqlQueryLens, + esqlLocaleLens, + esqlFilterLens, + esqlParamsLens, + esqlColumnarLens, + esqlProfileLens, + esqlTablesLens, + esqlIncludeCcsMetadataLens, + esqloDelimiterLens, + esqloDropNullColumnsLens, + esqloAllowPartialResultsLens, + gaesqloWaitForCompletionTimeoutLens, + gaesqloKeepAliveLens, + gaesqloDropNullColumnsLens, + esqlIsPartialLens, + esqlAllColumnsLens, + esqlClustersLens, + esqlProfileValueLens, + esqlColumnsLens, + esqlValuesLens, + esqlTookLens, + esqlColumnNameLens, + esqlColumnTypeLens, + esqlClustersTotalLens, + esqlClustersSuccessfulLens, + esqlClustersRunningLens, + esqlClustersSkippedLens, + esqlClustersPartialLens, + esqlClustersFailedLens, + esqlClustersDetailsLens, + esqlClustersOtherLens, + esqlClusterDetailsStatusLens, + esqlClusterDetailsIndicesLens, + esqlClusterDetailsShardsLens, + esqlClusterDetailsFailuresLens, + esqlClusterDetailsOtherLens, + esqlProfileShardsLens, + esqlProfileProfilesLens, + esqlProfileOtherLens, + esqlProfileSectionPhaseLens, + esqlProfileSectionDescriptionLens, + esqlProfileSectionTimeLens, + esqlProfileSectionChildrenLens, + esqlProfileSectionOtherLens, + EQLRequest (..), + EQLResult (..), + EQLHits (..), + EQLHit (..), + EQLTotal (..), + EQLTotalRelation (..), + EQLResultPosition (..), + EQLSearchId (..), + EQLSequence (..), + EQLStatus (..), + EQLSearchOptions (..), + defaultEQLSearchOptions, + eqlSearchOptionsParams7, + eqlSearchOptionsParams8, + EQLRequestBodyES7 (..), + EQLRequestBodyES8 (..), + eqlQueryLens, + eqlWaitForCompletionTimeoutLens, + eqlKeepOnCompletionLens, + eqlKeepAliveLens, + eqlSizeLens, + eqlFetchSizeLens, + eqlFieldsLens, + eqlFilterLens, + eqlResultPositionLens, + eqlTiebreakerFieldLens, + eqlEventCategoryFieldLens, + eqlTimestampFieldLens, + eqlRuntimeMappingsLens, + eqlAllowPartialSearchResultsLens, + eqlAllowPartialSequenceResultsLens, + eqlCaseSensitiveLens, + esoAllowNoIndicesLens, + esoAllowPartialSearchResultsLens, + esoAllowPartialSequenceResultsLens, + esoExpandWildcardsLens, + esoIgnoreUnavailableLens, + esoCcsMinimizeRoundtripsLens, + esoKeepAliveLens, + esoKeepOnCompletionLens, + esoWaitForCompletionTimeoutLens, + eqlIdLens, + eqlIsRunningLens, + eqlIsPartialLens, + eqlTimedOutLens, + eqlTookLens, + eqlHitsLens, + eqlHitsTotalLens, + eqlHitsEventsLens, + eqlHitsSequencesLens, + eqlSequenceEventsLens, + eqlSequenceJoinKeysLens, + eqlHitIndexLens, + eqlHitDocIdLens, + eqlHitScoreLens, + eqlHitSourceLens, + eqlHitVersionLens, + eqlHitSeqNoLens, + eqlHitPrimaryTermLens, + eqlHitFieldsLens, + eqlTotalValueLens, + eqlTotalRelationLens, + eqlSearchIdLens, + eqlStatusIdLens, + eqlStatusIsRunningLens, + eqlStatusIsPartialLens, + eqlStatusStartTimeInMillisLens, + eqlStatusCompletionStatusLens, + eqlStatusExpirationTimeInMillisLens, + resultPositionToText, + resultPositionFromText, + asyncESQLRequestBaseLens, + asyncESQLRequestWaitForCompletionTimeoutLens, + asyncESQLRequestKeepAliveLens, + asyncESQLRequestKeepOnCompletionLens, + asyncESQLIdLens, + asyncESQLResultIdLens, + asyncESQLResultIsRunningLens, + asyncESQLResultIsPartialLens, + asyncESQLResultStartTimeInMillisLens, + asyncESQLResultExpirationTimeInMillisLens, + asyncESQLResultCompletionTimeInMillisLens, + asyncESQLResultTookLens, + asyncESQLResultDocumentsFoundLens, + asyncESQLResultValuesLoadedLens, + asyncESQLResultColumnsLens, + asyncESQLResultValuesLens, + asyncESQLResultClustersLens, + asyncESQLResultProfileLens, + TaskType (..), + taskTypeToText, + taskTypeFromText, + InferenceId (..), + unInferenceId, + InferenceProvider (..), + OpenAIServiceSettings (..), + OpenAITaskSettings (..), + CohereServiceSettings (..), + CohereTaskSettings (..), + ElserServiceSettings (..), + AdaptiveAllocations (..), + RateLimit (..), + Similarity (..), + CohereEmbeddingType (..), + CohereInputType (..), + CohereTruncate (..), + ChunkingSettings (..), + NvidiaInputType (..), + JinaAiElementType (..), + JinaAiInputType (..), + AmazonSageMakerApi (..), + AmazonSageMakerElementType (..), + GoogleModelGardenProvider (..), + ThinkingConfig (..), + Ai21ServiceSettings (..), + MistralServiceSettings (..), + AnthropicServiceSettings (..), + AnthropicTaskSettings (..), + DeepSeekServiceSettings (..), + NvidiaServiceSettings (..), + NvidiaTaskSettings (..), + ContextualAiServiceSettings (..), + ContextualAiTaskSettings (..), + FireworksAiServiceSettings (..), + FireworksAiTaskSettings (..), + GoogleAiStudioServiceSettings (..), + GoogleVertexAiServiceSettings (..), + GoogleVertexAiTaskSettings (..), + GroqServiceSettings (..), + HuggingFaceServiceSettings (..), + HuggingFaceTaskSettings (..), + JinaAiServiceSettings (..), + JinaAiTaskSettings (..), + LlamaServiceSettings (..), + OpenShiftAiServiceSettings (..), + OpenShiftAiTaskSettings (..), + VoyageAiServiceSettings (..), + VoyageAiTaskSettings (..), + ElasticsearchServiceSettings (..), + ElasticsearchTaskSettings (..), + AlibabaCloudServiceSettings (..), + AlibabaCloudTaskSettings (..), + AmazonBedrockServiceSettings (..), + AmazonBedrockTaskSettings (..), + AmazonSageMakerServiceSettings (..), + AmazonSageMakerTaskSettings (..), + AzureAiStudioServiceSettings (..), + AzureAiStudioTaskSettings (..), + AzureOpenAiServiceSettings (..), + AzureOpenAiTaskSettings (..), + CustomServiceSettings (..), + CustomTaskSettings (..), + WatsonxServiceSettings (..), + InferenceConfig (..), + InferencePutResponse (..), + InferenceInput (..), + InferenceResult (..), + EmbeddingFormat (..), + DenseEmbeddingItem (..), + SparseEmbeddingItem (..), + CompletionItem (..), + RerankItem (..), + ChatMessage (..), + ChatCompletionRequest (..), + InferenceInfo (..), + InferenceEndpointsResponse (..), + -- | Re-exported so callers can name the field type of + -- 'CustomServiceSettings.customssSecretParameters'. + SecretValue (..), + inferenceIdLens, + inferenceConfigProviderLens, + inferenceConfigChunkingSettingsLens, + inferencePutResponseInferenceIdLens, + inferencePutResponseTaskTypeLens, + inferencePutResponseServiceLens, + inferenceInputInputLens, + inferenceInputQueryLens, + denseEmbeddingItemEmbeddingLens, + sparseEmbeddingItemEmbeddingLens, + completionItemResultLens, + rerankItemIndexLens, + rerankItemRelevanceScoreLens, + rerankItemTextLens, + inferenceInfoTaskTypeLens, + inferenceInfoInferenceIdLens, + inferenceInfoServiceLens, + inferenceInfoServiceSettingsLens, + inferenceInfoTaskSettingsLens, + inferenceInfoChunkingSettingsLens, + DeleteInferenceOptions (..), + defaultDeleteInferenceOptions, + deleteInferenceOptionsParams, + dioDryRunLens, + dioForceLens, + PutInferenceOptions (..), + defaultPutInferenceOptions, + putInferenceOptionsParams, + pioTimeoutLens, + RunInferenceOptions (..), + defaultRunInferenceOptions, + runInferenceOptionsParams, + rnioTimeoutLens, + StreamCompletionInferenceOptions (..), + defaultStreamCompletionInferenceOptions, + streamCompletionInferenceOptionsParams, + scioTimeoutLens, + StreamChatCompletionInferenceOptions (..), + defaultStreamChatCompletionInferenceOptions, + streamChatCompletionInferenceOptionsParams, + sccioTimeoutLens, + + -- * Query Rules + RulesetId (..), + unRulesetId, + RuleId (..), + unRuleId, + QueryRuleset (..), + Rule (..), + RuleType (..), + ruleTypeToText, + ruleTypeFromText, + Criterion (..), + PinnedDoc (..), + PinnedActions (..), + QueryRulesetInfo (..), + QueryRulesetPutResponse (..), + QueryRulesetTest (..), + QueryRulesetTestResponse (..), + QueryRulesetTestMatchedRule (..), + rulesetIdLens, + ruleIdLens, + queryRulesetRulesLens, + ruleRuleIdLens, + ruleTypeLens, + ruleCriteriaLens, + ruleActionsLens, + rulePriorityLens, + pinnedDocIndexLens, + pinnedDocIdLens, + pinnedActionsDocsLens, + pinnedActionsIdsLens, + queryRulesetInfoIdLens, + queryRulesetInfoRulesLens, + queryRulesetPutResponseResultLens, + queryRulesetTestMatchCriteriaLens, + queryRulesetTestResponseTotalLens, + queryRulesetTestResponseMatchedLens, + queryRulesetTestMatchedRuleRulesetIdLens, + queryRulesetTestMatchedRuleRuleIdLens, + + -- * Search Applications + SearchApplicationName (..), + unSearchApplicationName, + SearchApplicationScriptBody (..), + SearchApplicationTemplateScript (..), + SearchApplicationTemplate (..), + SearchApplication (..), + SearchApplicationInfo (..), + SearchApplicationPutResponse (..), + SearchApplicationPutOptions (..), + defaultSearchApplicationPutOptions, + SearchApplicationOptions (..), + defaultSearchApplicationOptions, + searchApplicationOptionsParams, + SearchApplicationSearchParams (..), + SearchApplicationListOptions (..), + defaultSearchApplicationListOptions, + searchApplicationListOptionsParams, + SearchApplicationListResponse (..), + searchApplicationNameLens, + searchApplicationTemplateScriptBodyLens, + searchApplicationTemplateScriptParamsLens, + searchApplicationTemplateScriptLangLens, + searchApplicationTemplateScriptOptionsLens, + searchApplicationTemplateScriptLens, + searchApplicationIndicesLens, + searchApplicationAnalyticsCollectionNameLens, + searchApplicationTemplateLens, + searchApplicationInfoNameLens, + searchApplicationInfoIndicesLens, + searchApplicationInfoAnalyticsCollectionNameLens, + searchApplicationInfoTemplateLens, + searchApplicationInfoUpdatedAtMillisLens, + searchApplicationSearchParamsParamsLens, + searchApplicationPutResponseResultLens, + searchApplicationPutOptionsCreateLens, + searchApplicationOptionsTypedKeysLens, + searchApplicationListOptionsQLens, + searchApplicationListOptionsFromLens, + searchApplicationListOptionsSizeLens, + searchApplicationListResponseCountLens, + searchApplicationListResponseResultsLens, + + -- * Terms Enum + TermValue (..), + TermsEnumRequest (..), + defaultTermsEnumRequest, + TermsEnumOptions (..), + defaultTermsEnumOptions, + termsEnumOptionsParams, + TermsEnumResponse (..), + termsEnumRequestFieldLens, + termsEnumRequestStringLens, + termsEnumRequestSizeLens, + termsEnumRequestTimeoutLens, + termsEnumRequestCaseInsensitiveLens, + termsEnumRequestIndexFilterLens, + termsEnumRequestSearchAfterLens, + teoAllowNoIndicesLens, + teoExpandWildcardsLens, + teoIgnoreUnavailableLens, + termsEnumResponseShardsLens, + termsEnumResponseTermsLens, + termsEnumResponseCompleteLens, + + -- * Synonyms + SynonymsSetId (..), + unSynonymsSetId, + SynonymRule (..), + SynonymsSet (..), + SynonymsSetInfo (..), + SynonymsSetPutResponse (..), + SynonymsGetOptions (..), + defaultSynonymsGetOptions, + synonymsGetOptionsParams, + synonymsSetIdLens, + synonymRuleIdLens, + synonymRuleSynonymsLens, + synonymsSetRulesLens, + synonymsSetInfoCountLens, + synonymsSetInfoRulesLens, + synonymsSetPutResponseAcknowledgedLens, + synonymsSetPutResponseResultLens, + synonymsGetOptionsFromLens, + synonymsGetOptionsSizeLens, + + -- * Behavioral analytics + AnalyticsCollectionName (..), + unAnalyticsCollectionName, + AnalyticsEventType (..), + unAnalyticsEventType, + analyticsEventTypeSearch, + analyticsEventTypeSearchClick, + analyticsEventTypePageView, + AnalyticsCollection (..), + AnalyticsCollectionsResponse (..), + AnalyticsCollectionPutResponse (..), + AnalyticsEventResponse (..), + AnalyticsEventOptions (..), + defaultAnalyticsEventOptions, + analyticsEventOptionsParams, + analyticsCollectionNameLens, + analyticsEventTypeLens, + analyticsCollectionPutResponseAcknowledgedLens, + analyticsCollectionPutResponseNameLens, + analyticsEventResponseAcceptedLens, + analyticsEventResponseEventLens, + analyticsEventOptionsDebugLens, + + -- * Connectors + ConnectorId (..), + unConnectorId, + ConnectorSyncJobId (..), + unConnectorSyncJobId, + Connector (..), + ConnectorSyncJob (..), + ConnectorMutationResult (..), + ConnectorCreateResponse (..), + ConnectorSyncJobCreateResponse (..), + ConnectorListResponse (..), + ConnectorSyncJobListResponse (..), + ConnectorListOptions (..), + defaultConnectorListOptions, + connectorListOptionsParams, + ConnectorSyncJobListOptions (..), + defaultConnectorSyncJobListOptions, + connectorSyncJobListOptionsParams, + CreateConnectorRequest (..), + defaultCreateConnectorRequest, + UpdateConnectorApiKeyRequest (..), + UpdateConnectorConfigurationRequest (..), + UpdateConnectorErrorRequest (..), + UpdateConnectorFeaturesRequest (..), + UpdateConnectorFilteringRequest (..), + UpdateConnectorFilteringValidationRequest (..), + UpdateConnectorIndexNameRequest (..), + UpdateConnectorNameDescriptionRequest (..), + UpdateConnectorNativeRequest (..), + UpdateConnectorPipelineRequest (..), + UpdateConnectorSchedulingRequest (..), + UpdateConnectorServiceTypeRequest (..), + UpdateConnectorStatusRequest (..), + CreateConnectorSyncJobRequest (..), + ClaimConnectorSyncJobRequest (..), + SetConnectorSyncJobErrorRequest (..), + SetConnectorSyncJobStatsRequest (..), + + -- * Migration reindex (POST /_migration/reindex, /_cancel, /_status, /_create_from) + MigrateReindexMode (..), + MigrateReindexSource (..), + MigrateReindexRequest (..), + mkMigrateReindexRequest, + MigrateReindexInProgress (..), + MigrateReindexError (..), + MigrateReindexStatus (..), + CreateIndexFromBody (..), + defaultCreateIndexFromBody, + CreateIndexFromResponse (..), + migrateReindexSourceIndexLens, + migrateReindexRequestSourceLens, + migrateReindexRequestModeLens, + migrateReindexInProgressIndexLens, + migrateReindexInProgressTotalDocCountLens, + migrateReindexInProgressReindexedDocCountLens, + migrateReindexErrorIndexLens, + migrateReindexErrorMessageLens, + migrateReindexStatusStartTimeLens, + migrateReindexStatusStartTimeMillisLens, + migrateReindexStatusCompleteLens, + migrateReindexStatusTotalIndicesInDataStreamLens, + migrateReindexStatusTotalIndicesRequiringUpgradeLens, + migrateReindexStatusSuccessesLens, + migrateReindexStatusInProgressLens, + migrateReindexStatusPendingLens, + migrateReindexStatusErrorsLens, + migrateReindexStatusExceptionLens, + createIndexFromBodyMappingsOverrideLens, + createIndexFromBodySettingsOverrideLens, + createIndexFromBodyRemoveIndexBlocksLens, + createIndexFromResponseAcknowledgedLens, + createIndexFromResponseIndexLens, + createIndexFromResponseShardsAcknowledgedLens, + ) +where + +import Database.Bloodhound.Common.Types as Reexport +import Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.DataStream as Reexport +import Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.EventQueryLanguage +import Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.TermsEnum +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.BehavioralAnalytics +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Connectors +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.EsQueryLanguage +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Inference +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.MigrationReindex +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.QueryRules +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.SearchApplications +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Synonyms diff --git a/src/Database/Bloodhound/ElasticSearch9/Client.hs b/src/Database/Bloodhound/ElasticSearch9/Client.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/ElasticSearch9/Client.hs @@ -0,0 +1,2799 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Database.Bloodhound.ElasticSearch9.Client +-- Description : Elasticsearch 9 client (re-exports Common + ES9-specific APIs) +-- +-- The Elasticsearch 9 client. Re-exports the version-agnostic "Database.Bloodhound.Common.Client" +-- surface and adds ES9-specific features: k-NN search, point in time (PIT), ES|QL +-- and EQL (sync and async, plus ES|QL views), data streams and lifecycles, query +-- rulesets, search applications, inference endpoints, and the terms enum API. +module Database.Bloodhound.ElasticSearch9.Client + ( module Reexport, + knnSearch, + pitSearch, + pitSearchWith, + openPointInTime, + openPointInTimeWith, + openPointInTimeWithBody, + closePointInTime, + esql, + esqlWith, + eqlSearch, + eqlSearchWith, + getEQLSearch, + getEQLStatus, + deleteEQLSearch, + esqlAsync, + esqlAsyncWith, + getAsyncESQL, + getAsyncESQLWith, + deleteAsyncESQL, + stopAsyncESQL, + putESQLView, + getESQLView, + deleteESQLView, + getESQLQuery, + getESQLQueries, + getDataStreams, + getDataStreamStats, + createDataStream, + dataStreamExists, + deleteDataStream, + migrateToDataStream, + promoteDataStream, + putDataStreamLifecycle, + putDataStreamsLifecycle, + getDataStreamLifecycle, + deleteDataStreamLifecycle, + modifyDataStream, + getDataStreamOptions, + updateDataStreamOptions, + deleteDataStreamOptions, + getDataStreamLifecycleStats, + explainDataStreamLifecycle, + explainDataStreamLifecycleWith, + getDataStreamMappings, + getDataStreamMappingsWith, + putDataStreamMappings, + putDataStreamMappingsWith, + getDataStreamSettings, + getDataStreamSettingsWith, + putDataStreamSettings, + putDataStreamSettingsWith, + putInferenceEndpoint, + putInferenceEndpointWith, + updateInferenceEndpoint, + getInferenceEndpoints, + deleteInferenceEndpoint, + deleteInferenceEndpointWith, + runInference, + runInferenceWith, + streamCompletionInference, + streamCompletionInferenceWith, + streamChatCompletionInference, + streamChatCompletionInferenceWith, + putQueryRuleset, + getQueryRuleset, + deleteQueryRuleset, + testQueryRuleset, + putSearchApplication, + putSearchApplicationWith, + getSearchApplication, + deleteSearchApplication, + searchApplication, + searchApplicationWith, + listSearchApplications, + listSearchApplicationsWith, + renderSearchApplicationQuery, + getTermsEnum, + getTermsEnumWith, + resolveCluster, + resolveClusterWith, + getHealthReport, + getHealthReportWith, + getFeatures, + getFeaturesWith, + resetFeatures, + resetFeaturesWith, + putMlDataFrameAnalytics, + putMlDataFrameAnalyticsWith, + getMlDataFrameAnalytics, + getMlDataFrameAnalyticsWith, + updateMlDataFrameAnalytics, + updateMlDataFrameAnalyticsWith, + deleteMlDataFrameAnalytics, + deleteMlDataFrameAnalyticsWith, + startMlDataFrameAnalytics, + startMlDataFrameAnalyticsWith, + stopMlDataFrameAnalytics, + stopMlDataFrameAnalyticsWith, + getMlDataFrameAnalyticsStats, + getMlDataFrameAnalyticsStatsWith, + previewMlDataFrameAnalytics, + MlDataFrameAnalyticsId (..), + MlDataFrameAnalyticsPutBody (..), + defaultMlDataFrameAnalyticsPutBody, + MlDataFrameAnalyticsUpdateBody (..), + defaultMlDataFrameAnalyticsUpdateBody, + MlDataFrameAnalyticsPreviewRequest (..), + MlDataFrameAnalyticsOptions (..), + defaultMlDataFrameAnalyticsOptions, + MlDataFrameAnalyticsGetResponse (..), + MlDataFrameAnalyticsStatsResponse (..), + MlDataFrameAnalyticsPreviewResponse (..), + putMlTrainedModel, + putMlTrainedModelWith, + getMlTrainedModels, + getMlTrainedModelsWith, + getMlTrainedModelDefinition, + getMlTrainedModelDefinitionWith, + updateMlTrainedModel, + updateMlTrainedModelWith, + deleteMlTrainedModel, + deleteMlTrainedModelWith, + deployMlTrainedModel, + deployMlTrainedModelWith, + undeployMlTrainedModel, + undeployMlTrainedModelWith, + startMlTrainedModelDeployment, + startMlTrainedModelDeploymentWith, + stopMlTrainedModelDeployment, + stopMlTrainedModelDeploymentWith, + getMlTrainedModelStats, + getMlTrainedModelStatsWith, + inferMlTrainedModel, + MlTrainedModelId (..), + MlTrainedModelPutBody (..), + defaultMlTrainedModelPutBody, + MlTrainedModelUpdateBody (..), + defaultMlTrainedModelUpdateBody, + MlTrainedModelInferRequest (..), + MlTrainedModelOptions (..), + defaultMlTrainedModelOptions, + MlTrainedModelsResponse (..), + MlTrainedModelDefinition (..), + MlTrainedModelStatsResponse (..), + MlTrainedModelInferResponse (..), + putMlAnomalyJob, + getMlAnomalyJobs, + getMlAnomalyJobsWith, + updateMlAnomalyJob, + deleteMlAnomalyJob, + deleteMlAnomalyJobWith, + openMlAnomalyJob, + closeMlAnomalyJob, + forecastMlAnomalyJob, + flushMlAnomalyJob, + validateMlAnomalyJob, + getMlAnomalyJobStats, + getMlAnomalyJobStatsWith, + getMlAnomalyJobResults, + getMlAnomalyJobResultsWith, + getMlModelSnapshots, + getMlModelSnapshotsWith, + getMlModelSnapshot, + getMlModelSnapshotWith, + updateMlModelSnapshot, + deleteMlModelSnapshot, + deleteMlModelSnapshotWith, + revertMlModelSnapshot, + revertMlModelSnapshotWith, + putMlDatafeed, + getMlDatafeeds, + getMlDatafeedsWith, + updateMlDatafeed, + deleteMlDatafeed, + startMlDatafeed, + stopMlDatafeed, + previewMlDatafeed, + putMlFilter, + getMlFilters, + getMlFiltersWith, + deleteMlFilter, + putMlCalendar, + getMlCalendars, + getMlCalendarsWith, + deleteMlCalendar, + setMlScheduledEvents, + getMlScheduledEvents, + MlJobId (..), + MlModelSnapshotId (..), + MlAnomalyResultType (..), + MlAnomalyJob (..), + defaultMlAnomalyJob, + MlAnomalyJobUpdate (..), + defaultMlAnomalyJobUpdate, + MlForecastOptions (..), + defaultMlForecastOptions, + MlFlushOptions (..), + defaultMlFlushOptions, + MlAnomalyJobOptions (..), + defaultMlAnomalyJobOptions, + MlAnomalyJobsResponse (..), + MlAnomalyJobStatsResponse (..), + MlForecastResponse (..), + MlFlushResponse (..), + MlValidateResponse (..), + MlAnomalyJobResults (..), + MlModelSnapshotsResponse (..), + MlRevertSnapshotResponse (..), + MlDatafeedId (..), + MlDatafeed (..), + defaultMlDatafeed, + MlDatafeedUpdate (..), + defaultMlDatafeedUpdate, + MlDatafeedOptions (..), + defaultMlDatafeedOptions, + MlDatafeedsResponse (..), + MlDatafeedPreviewResponse (..), + MlFilterId (..), + MlFilter (..), + defaultMlFilter, + MlFiltersResponse (..), + MlCalendarId (..), + MlCalendar (..), + defaultMlCalendar, + MlCalendarsResponse (..), + MlScheduledEvents (..), + MlScheduledEventsResponse (..), + TermValue (..), + TermsEnumRequest (..), + defaultTermsEnumRequest, + TermsEnumOptions (..), + defaultTermsEnumOptions, + termsEnumOptionsParams, + TermsEnumResponse (..), + getStreamsStatus, + getStreamsStatusWith, + enableStream, + enableStreamWith, + disableStream, + disableStreamWith, + downsampleIndex, + downsampleIndexWith, + StreamName (..), + StreamStatus (..), + StreamsStatusResponse (..), + streamStatusFor, + GetStreamsStatusOptions (..), + defaultGetStreamsStatusOptions, + getStreamsStatusOptionsParams, + StreamsActionOptions (..), + defaultStreamsActionOptions, + getGeoIpStats, + getGeoIpDatabases, + getGeoIpDatabase, + putGeoIpDatabase, + deleteGeoIpDatabase, + getIpLocationDatabases, + getIpLocationDatabase, + putIpLocationDatabase, + deleteIpLocationDatabase, + GeoIpDatabaseId (..), + GeoIpDatabasePutBody (..), + IpLocationDatabasePutBody (..), + GeoIpMaxmindConfig (..), + GeoIpDatabasesResponse (..), + GeoIpDatabaseInfo (..), + GeoIpStatsResponse (..), + GeoIpStats (..), + simulateIngest, + simulateIngestWith, + simulateIngestIndex, + simulateIngestIndexWith, + simulateIngestGet, + simulateIngestWithGet, + simulateIngestIndexGet, + simulateIngestIndexWithGet, + SimulateIngestRequest (..), + SimulateIngestDoc (..), + SimulateIngestOptions (..), + defaultSimulateIngestOptions, + SimulateIngestResponse (..), + SimulateIngestMergeType (..), + migrateReindex, + cancelMigrateReindex, + getMigrateReindexStatus, + createIndexFrom, + createIndexFromWith, + MigrateReindexMode (..), + MigrateReindexSource (..), + MigrateReindexRequest (..), + mkMigrateReindexRequest, + MigrateReindexInProgress (..), + MigrateReindexError (..), + MigrateReindexStatus (..), + CreateIndexFromBody (..), + defaultCreateIndexFromBody, + CreateIndexFromResponse (..), + ) +where + +import Control.Monad +import Data.Aeson +import Data.ByteString.Lazy qualified as L +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Database.Bloodhound.Client.Cluster +import Database.Bloodhound.Common.Client as Reexport +import Database.Bloodhound.Common.Requests as Requests +import Database.Bloodhound.ElasticSearch7.Requests qualified as Requests7 +import Database.Bloodhound.ElasticSearch9.Requests qualified as Requests9 +import Database.Bloodhound.ElasticSearch9.Types +import Database.Bloodhound.Internal.Utils.Requests +import Prelude hiding (filter, head) + +-- | 'pitSearch' uses the point in time (PIT) API of elastic, for a given +-- 'IndexName'. Requires Elasticsearch 9. The supplied 'KeepAlive' +-- duration is forwarded to every PIT open\/extend call. Note that this will +-- consume the entire search result set and will be doing O(n) list appends so +-- this may not be suitable for large result sets. In that case, the point in +-- time API should be used directly with `openPointInTime` and `closePointInTime`. +-- +-- This is a convenience wrapper around 'pitSearchWith' that lifts the +-- single 'IndexName' into an 'IndexPattern'. To search across multiple +-- comma-joined indices or a wildcard pattern, use 'pitSearchWith' +-- directly with an 'IndexPattern'. +-- +-- Note that 'pitSearch' utilizes the 'search_after' parameter under the hood, +-- which requires a non-empty 'sortBody' field in the provided 'Search' value. +-- Otherwise, 'pitSearch' will fail to return all matching documents. +-- +-- For more information see +-- . +pitSearch :: + forall a m. + (FromJSON a, MonadBH m, WithBackend ElasticSearch9 m) => + IndexName -> + KeepAlive -> + Search -> + m [Hit a] +pitSearch indexName = pitSearchWith (IndexPattern (unIndexName indexName)) + +-- | 'pitSearchWith' is the parameterized variant of 'pitSearch': it +-- takes an 'IndexPattern' as the target, which may be a single index +-- name, a comma-separated list of indices, or a wildcard pattern +-- (e.g. @\"logs-*\"@, @\"logs-2024,logs-2025\"@). Otherwise behaves +-- exactly like 'pitSearch'. See 'openPointInTimeWith' for the target +-- rendering. +-- +-- For more information see +-- . +pitSearchWith :: + forall a m. + (FromJSON a, MonadBH m, WithBackend ElasticSearch9 m) => + IndexPattern -> + KeepAlive -> + Search -> + m [Hit a] +pitSearchWith indexPattern keepAlive search = do + openResp <- openPointInTimeWith indexPattern keepAlive defaultPITOptions + case openResp of + Left e -> throwEsError e + Right OpenPointInTimeResponse {..} -> do + let searchPIT = search {pointInTime = Just (PointInTime oes9PitId (Just keepAlive))} + hits <- pitAccumulator searchPIT [] + closeResp <- closePointInTime (ClosePointInTime oes9PitId) + case closeResp of + Left _ -> return [] + Right (ClosePointInTimeResponse False _) -> + error "failed to close point in time (PIT)" + Right (ClosePointInTimeResponse True _) -> return hits + where + pitAccumulator :: Search -> [Hit a] -> m [Hit a] + pitAccumulator search' oldHits = do + resp <- tryPerformBHRequest $ Requests.searchAll search' + case resp of + Left _ -> return [] + Right searchResult -> case hits (searchHits searchResult) of + [] -> return oldHits + newHits -> case (hitSort $ last newHits, pitId searchResult) of + (Nothing, Nothing) -> + error "no point in time (PIT) ID or last sort value" + (Just _, Nothing) -> error "no point in time (PIT) ID" + (Nothing, _) -> return (oldHits <> newHits) + (Just lastSort, Just pitId') -> do + let newSearch = + search' + { pointInTime = Just (PointInTime pitId' (Just keepAlive)), + searchAfterKey = Just lastSort + } + pitAccumulator newSearch (oldHits <> newHits) + +-- | 'openPointInTime' opens a point in time for an index given an 'IndexName' +-- and a 'KeepAlive' duration (e.g. @keepAliveMinutes 1@). Note that the point +-- in time should be closed with 'closePointInTime' as soon as it is no longer +-- needed. +-- +-- Equivalent to 'openPointInTimeWith' with +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.defaultPITOptions' +-- (no optional URI parameters). +-- +-- For more information see +-- . +openPointInTime :: + (MonadBH m, WithBackend ElasticSearch9 m) => + IndexName -> + KeepAlive -> + m (ParsedEsResponse OpenPointInTimeResponse) +openPointInTime indexName keepAlive = performBHRequest $ Requests9.openPointInTime indexName keepAlive + +-- | 'openPointInTimeWith' is the parameterized variant of +-- 'openPointInTime': it takes an 'IndexPattern' target (single name, +-- comma-list, or wildcard) and forwards the supplied 'PITOptions' as +-- query-string parameters in addition to the mandatory @keep_alive@. +-- Delegates to the ES9 request builder (which is local to ES9, not +-- shared with ES7). See +-- 'Database.Bloodhound.ElasticSearch9.Requests.openPointInTimeWith' +-- for which parameters are emitted. +-- +-- For more information see +-- . +openPointInTimeWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + IndexPattern -> + KeepAlive -> + PITOptions -> + m (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWith indexPattern keepAlive opts = + performBHRequest $ Requests9.openPointInTimeWith indexPattern keepAlive opts + +-- | 'openPointInTimeWithBody' is the body-carrying variant of +-- 'openPointInTimeWith': it sends the supplied 'OpenPointInTimeBody' as +-- the JSON request body (the only way to supply an @index_filter@ +-- query), in addition to the 'PITOptions' URI parameters and the +-- mandatory @keep_alive@. The 'IndexPattern' target follows the same +-- rules as 'openPointInTimeWith'. Delegates to the ES9 request builder. +-- See +-- 'Database.Bloodhound.ElasticSearch9.Requests.openPointInTimeWithBody'. +-- +-- For more information see +-- . +openPointInTimeWithBody :: + (MonadBH m, WithBackend ElasticSearch9 m) => + IndexPattern -> + KeepAlive -> + OpenPointInTimeBody -> + PITOptions -> + m (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWithBody indexPattern keepAlive body opts = + performBHRequest $ Requests9.openPointInTimeWithBody indexPattern keepAlive body opts + +-- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'. +-- +-- For more information see +-- . +closePointInTime :: + (MonadBH m, WithBackend ElasticSearch9 m) => + ClosePointInTime -> + m (ParsedEsResponse ClosePointInTimeResponse) +closePointInTime q = performBHRequest $ Requests9.closePointInTime q + +-- | 'esql' executes an ES|QL query synchronously via @POST /_query@ +-- (Elasticsearch 9.x). The result is returned as an 'ESQLResult' containing +-- column descriptors and row values. +-- +-- For more information see +-- . +esql :: + (MonadBH m, WithBackend ElasticSearch9 m) => + ESQLRequest -> + m (ParsedEsResponse ESQLResult) +esql = performBHRequest . Requests9.esql + +-- | 'esqlWith' executes an ES|QL query synchronously via @POST /_query@ +-- (Elasticsearch 9.x) with the documented URI query parameters +-- ('ESQLQueryOptions'). Pass 'defaultESQLQueryOptions' to behave +-- identically to 'esql'. +-- +-- For more information see +-- . +esqlWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + ESQLRequest -> + ESQLQueryOptions -> + m (ParsedEsResponse ESQLResult) +esqlWith req = performBHRequest . Requests9.esqlWith req + +-- | 'eqlSearch' submits an EQL (Event Query Language) search via +-- @POST /{index}/_eql/search@ (Elasticsearch 9.x). The result is +-- parameterized by the document-source type @a@. +-- +-- The wire format is identical to ES 7.10+\/8.x, so the ES9 request +-- builder delegates to the ES8 implementation. +-- +-- For more information see +-- . +eqlSearch :: + (FromJSON a, MonadBH m, WithBackend ElasticSearch9 m) => + IndexName -> + EQLRequest -> + m (ParsedEsResponse (EQLResult a)) +eqlSearch indexName req = performBHRequest $ Requests9.eqlSearch indexName req + +-- | 'eqlSearchWith' is the fully-parameterised form of 'eqlSearch'. The +-- wire format is identical to ES 7.10+\/8.x, so the ES9 request builder +-- delegates to the ES8 implementation. See 'EQLSearchOptions' for the +-- available URI parameters. +-- +-- For more information see +-- . +eqlSearchWith :: + (FromJSON a, MonadBH m, WithBackend ElasticSearch9 m) => + IndexName -> + EQLSearchOptions -> + EQLRequest -> + m (ParsedEsResponse (EQLResult a)) +eqlSearchWith indexName opts req = + performBHRequest $ Requests9.eqlSearchWith indexName opts req + +-- | 'getEQLSearch' fetches the deferred results of an async EQL search +-- via @GET /_eql/search\/{id}@ (Elasticsearch 9.x). The result is +-- parameterized by the document-source type @a@. The optional 'Text' +-- sets @wait_for_completion_timeout@ as a query parameter; 'Nothing' +-- returns immediately with the current state. +-- +-- The wire format is identical to ES 7.10+\/8.x, so the ES9 request +-- builder delegates to the ES8 implementation. +-- +-- For more information see +-- . +getEQLSearch :: + (FromJSON a, MonadBH m, WithBackend ElasticSearch9 m) => + EQLSearchId -> + Maybe Text -> + m (ParsedEsResponse (EQLResult a)) +getEQLSearch sid = performBHRequest . Requests9.getEQLSearch sid + +-- | 'getEQLStatus' returns only the status of an async EQL search via +-- @GET /_eql/search/status\/{id}@ (Elasticsearch 9.x) without fetching +-- the results. +-- +-- The wire format is identical to ES 7.10+\/8.x, so the ES9 request +-- builder delegates to the ES8 implementation (which delegates to ES7). +-- +-- For more information see +-- . +getEQLStatus :: + (MonadBH m, WithBackend ElasticSearch9 m) => + EQLSearchId -> + m EQLStatus +getEQLStatus = performBHRequest . Requests9.getEQLStatus + +-- | 'esqlAsync' submits a long-running ES|QL query via @POST /_query/async@ +-- on Elasticsearch 9. The wire format is identical to ES8. See +-- "Database.Bloodhound.ElasticSearch8.Client"#esqlAsync for details. +-- +-- For more information see +-- . +esqlAsync :: + (MonadBH m, WithBackend ElasticSearch9 m) => + AsyncESQLRequest -> + m (ParsedEsResponse AsyncESQLResult) +esqlAsync = performBHRequest . Requests9.esqlAsync + +-- | 'esqlAsyncWith' submits a long-running ES|QL query via +-- @POST /_query/async@ on Elasticsearch 9 with the documented URI query +-- parameters. The wire format is identical to ES8. See +-- "Database.Bloodhound.ElasticSearch8.Client"#esqlAsyncWith for details. +-- +-- For more information see +-- . +esqlAsyncWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + AsyncESQLRequest -> + ESQLQueryOptions -> + m (ParsedEsResponse AsyncESQLResult) +esqlAsyncWith req = performBHRequest . Requests9.esqlAsyncWith req + +-- | 'getAsyncESQL' polls an async ES|QL query by id on Elasticsearch 9. +-- The wire format is identical to ES8. See +-- "Database.Bloodhound.ElasticSearch8.Client"#getAsyncESQL for details. +-- +-- For more information see +-- . +getAsyncESQL :: + (MonadBH m, WithBackend ElasticSearch9 m) => + AsyncESQLId -> + Maybe Text -> + m (ParsedEsResponse AsyncESQLResult) +getAsyncESQL = (performBHRequest .) . Requests9.getAsyncESQL + +-- | 'getAsyncESQLWith' is the fully-parameterised form of 'getAsyncESQL' +-- on Elasticsearch 9. The wire format is identical to ES8. See +-- "Database.Bloodhound.ElasticSearch8.Client"#getAsyncESQLWith for details. +-- +-- For more information see +-- . +getAsyncESQLWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + AsyncESQLId -> + GetAsyncESQLOptions -> + m (ParsedEsResponse AsyncESQLResult) +getAsyncESQLWith = (performBHRequest .) . Requests9.getAsyncESQLWith + +-- | 'deleteAsyncESQL' deletes an async ES|QL result and its context by id +-- on Elasticsearch 9. The wire format is identical to ES8. Deleting a +-- non-existent or already-purged async id surfaces as an 'EsError' (a +-- @404@ with an error body); wrap with 'tryEsError' for miss-tolerant +-- deletion. +-- +-- For more information see +-- . +deleteAsyncESQL :: + (MonadBH m, WithBackend ElasticSearch9 m) => + AsyncESQLId -> + m Acknowledged +deleteAsyncESQL = performBHRequest . Requests9.deleteAsyncESQL + +-- | 'stopAsyncESQL' requests the server to stop a running async ES|QL +-- query by id on Elasticsearch 9. Maps to @POST /_query/async/{id}/stop@ +-- (Elasticsearch 8.11+) and returns the final 'AsyncESQLResult' — +-- @is_running@ will be @False@ and @columns@\/@values@ carry whatever +-- the query produced before being stopped. The wire format is identical +-- to ES8. +-- +-- For more information see +-- . +stopAsyncESQL :: + (MonadBH m, WithBackend ElasticSearch9 m) => + AsyncESQLId -> + m (ParsedEsResponse AsyncESQLResult) +stopAsyncESQL = performBHRequest . Requests9.stopAsyncESQL + +-- | 'putInferenceEndpoint' creates or updates an inference endpoint via +-- @PUT \/_inference\/{task_type}\/{inference_id}@ on Elasticsearch 9. The +-- wire format is identical to ES8. +-- +-- For more information see +-- . +putInferenceEndpoint :: + (MonadBH m, WithBackend ElasticSearch9 m) => + TaskType -> + InferenceId -> + InferenceConfig -> + m (ParsedEsResponse InferencePutResponse) +putInferenceEndpoint taskType' inferenceId config = + performBHRequest $ Requests9.putInferenceEndpoint taskType' inferenceId config + +-- | Fully-parameterised form of 'putInferenceEndpoint'. The wire format is +-- identical to ES8. Pass 'PutInferenceOptions' to attach the @timeout@ query +-- parameter; see 'Requests9.putInferenceEndpointWith'. +-- +-- For more information see +-- . +putInferenceEndpointWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + TaskType -> + InferenceId -> + InferenceConfig -> + PutInferenceOptions -> + m (ParsedEsResponse InferencePutResponse) +putInferenceEndpointWith taskType' inferenceId config opts = + performBHRequest $ Requests9.putInferenceEndpointWith taskType' inferenceId config opts + +-- | 'updateInferenceEndpoint' partially updates an existing inference +-- endpoint via @PUT \/_inference\/{task_type}\/{inference_id}\/_update@ on +-- Elasticsearch 9. The wire format is identical to ES8. +-- +-- For more information see +-- . +updateInferenceEndpoint :: + (MonadBH m, WithBackend ElasticSearch9 m) => + TaskType -> + InferenceId -> + InferenceConfig -> + m (ParsedEsResponse InferenceInfo) +updateInferenceEndpoint taskType' inferenceId config = + performBHRequest $ Requests9.updateInferenceEndpoint taskType' inferenceId config + +-- | 'getInferenceEndpoints' lists configured inference endpoints via the +-- @GET \/_inference@ family on Elasticsearch 9. The wire format is +-- identical to ES8. See "Database.Bloodhound.ElasticSearch8.Client" for +-- the filter semantics. +-- +-- For more information see +-- . +getInferenceEndpoints :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe TaskType -> + Maybe InferenceId -> + m [InferenceInfo] +getInferenceEndpoints mTaskType mInferenceId = + performBHRequest $ Requests9.getInferenceEndpoints mTaskType mInferenceId + +-- | 'deleteInferenceEndpoint' deletes an inference endpoint via +-- @DELETE \/_inference\/{task_type}\/{inference_id}@ on Elasticsearch 9. The +-- wire format is identical to ES8. Deleting a non-existent endpoint surfaces +-- as an 'EsError'; wrap with 'tryPerformBHRequest' for miss-tolerant deletion. +-- +-- For more information see +-- . +deleteInferenceEndpoint :: + (MonadBH m, WithBackend ElasticSearch9 m) => + TaskType -> + InferenceId -> + m Acknowledged +deleteInferenceEndpoint taskType' inferenceId = + performBHRequest $ Requests9.deleteInferenceEndpoint taskType' inferenceId + +-- | Fully-parameterised form of 'deleteInferenceEndpoint'. Pass +-- 'DeleteInferenceOptions' to attach the @dry_run@ and @force@ query +-- parameters. The wire format is identical to ES8; see +-- 'Requests9.deleteInferenceEndpointWith'. +-- +-- For more information see +-- . +deleteInferenceEndpointWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + TaskType -> + InferenceId -> + DeleteInferenceOptions -> + m Acknowledged +deleteInferenceEndpointWith taskType' inferenceId opts = + performBHRequest $ Requests9.deleteInferenceEndpointWith taskType' inferenceId opts + +-- | 'runInference' performs inference against an existing endpoint via +-- @POST \/_inference\/{task_type}\/{inference_id}@ on Elasticsearch 9. The +-- wire format is identical to ES8. +-- +-- For more information see +-- . +runInference :: + (MonadBH m, WithBackend ElasticSearch9 m) => + TaskType -> + InferenceId -> + InferenceInput -> + m (ParsedEsResponse InferenceResult) +runInference taskType' inferenceId input = + performBHRequest $ Requests9.runInference taskType' inferenceId input + +-- | Fully-parameterised form of 'runInference'. The wire format is identical +-- to ES8. Pass 'RunInferenceOptions' to attach the @timeout@ query parameter; +-- see 'Requests9.runInferenceWith'. +-- +-- For more information see +-- . +runInferenceWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + TaskType -> + InferenceId -> + InferenceInput -> + RunInferenceOptions -> + m (ParsedEsResponse InferenceResult) +runInferenceWith taskType' inferenceId input opts = + performBHRequest $ Requests9.runInferenceWith taskType' inferenceId input opts + +-- | 'streamCompletionInference' streams completion chunks from an existing +-- completion endpoint via +-- @POST \/_inference\/completion\/{inference_id}\/_stream@ on Elasticsearch 9. +-- The wire format is identical to ES8. +-- +-- For more information see +-- . +streamCompletionInference :: + (MonadBH m, WithBackend ElasticSearch9 m) => + InferenceId -> + InferenceInput -> + m L.ByteString +streamCompletionInference inferenceId input = + performBHRequest $ Requests9.streamCompletionInference inferenceId input + +-- | Fully-parameterised form of 'streamCompletionInference'. The wire format +-- is identical to ES8. Pass 'StreamCompletionInferenceOptions' to attach the +-- @timeout@ query parameter; see 'Requests9.streamCompletionInferenceWith'. +-- +-- For more information see +-- . +streamCompletionInferenceWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + InferenceId -> + InferenceInput -> + StreamCompletionInferenceOptions -> + m L.ByteString +streamCompletionInferenceWith inferenceId input opts = + performBHRequest $ Requests9.streamCompletionInferenceWith inferenceId input opts + +-- | 'streamChatCompletionInference' streams chat-completion chunks from an +-- existing chat endpoint via +-- @POST \/_inference\/chat_completion\/{inference_id}\/_stream@ on +-- Elasticsearch 9. The wire format is identical to ES8. +-- +-- For more information see +-- . +streamChatCompletionInference :: + (MonadBH m, WithBackend ElasticSearch9 m) => + InferenceId -> + ChatCompletionRequest -> + m L.ByteString +streamChatCompletionInference inferenceId request = + performBHRequest $ Requests9.streamChatCompletionInference inferenceId request + +-- | Fully-parameterised form of 'streamChatCompletionInference'. The wire +-- format is identical to ES8. Pass 'StreamChatCompletionInferenceOptions' to +-- attach the @timeout@ query parameter; see +-- 'Requests9.streamChatCompletionInferenceWith'. +-- +-- For more information see +-- . +streamChatCompletionInferenceWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + InferenceId -> + ChatCompletionRequest -> + StreamChatCompletionInferenceOptions -> + m L.ByteString +streamChatCompletionInferenceWith inferenceId request opts = + performBHRequest $ Requests9.streamChatCompletionInferenceWith inferenceId request opts + +-- | 'putQueryRuleset' creates or updates a query ruleset via +-- @PUT \/_query_rules\/{ruleset_id}@ on Elasticsearch 9. The wire +-- format is identical to ES8. +-- +-- For more information see +-- . +putQueryRuleset :: + (MonadBH m, WithBackend ElasticSearch9 m) => + RulesetId -> + QueryRuleset -> + m QueryRulesetPutResponse +putQueryRuleset rulesetId ruleset = + performBHRequest $ Requests9.putQueryRuleset rulesetId ruleset + +-- | 'getQueryRuleset' fetches a query ruleset by id via +-- @GET \/_query_rules\/{ruleset_id}@ on Elasticsearch 9. The wire +-- format is identical to ES8. A @404@ surfaces as an 'EsError'; wrap +-- with 'tryPerformBHRequest' for miss-tolerant reads. +-- +-- For more information see +-- . +getQueryRuleset :: + (MonadBH m, WithBackend ElasticSearch9 m) => + RulesetId -> + m QueryRulesetInfo +getQueryRuleset = performBHRequest . Requests9.getQueryRuleset + +-- | 'deleteQueryRuleset' deletes a query ruleset by id via +-- @DELETE \/_query_rules\/{ruleset_id}@ on Elasticsearch 9. The wire +-- format is identical to ES8. Deleting a non-existent ruleset surfaces +-- as an 'EsError'; wrap with 'tryPerformBHRequest' for miss-tolerant +-- deletion. +-- +-- For more information see +-- . +deleteQueryRuleset :: + (MonadBH m, WithBackend ElasticSearch9 m) => + RulesetId -> + m Acknowledged +deleteQueryRuleset = performBHRequest . Requests9.deleteQueryRuleset + +-- | 'testQueryRuleset' evaluates match criteria against a stored +-- ruleset via @POST \/_query_rules\/{ruleset_id}\/_test@ on +-- Elasticsearch 9. The wire format is identical to ES8. +-- +-- For more information see +-- . +testQueryRuleset :: + (MonadBH m, WithBackend ElasticSearch9 m) => + RulesetId -> + QueryRulesetTest -> + m QueryRulesetTestResponse +testQueryRuleset rulesetId body = + performBHRequest $ Requests9.testQueryRuleset rulesetId body + +-- | 'putSearchApplication' creates or updates a search application via +-- @PUT \/_application\/search_application\/{name}@ on Elasticsearch 9. +-- The wire format is identical to ES8. +-- +-- For more information see +-- . +putSearchApplication :: + (MonadBH m, WithBackend ElasticSearch9 m) => + SearchApplicationName -> + SearchApplication -> + m SearchApplicationPutResponse +putSearchApplication appName app = + performBHRequest $ Requests9.putSearchApplication appName app + +-- | 'putSearchApplicationWith' is the fully-parameterised form of +-- 'putSearchApplication' on Elasticsearch 9. The wire format is +-- identical to ES8. 'SearchApplicationPutOptions' carries the @create@ +-- query parameter: @'Just' 'True'@ emits @?create=true@. +-- +-- For more information see +-- . +putSearchApplicationWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + SearchApplicationName -> + SearchApplicationPutOptions -> + SearchApplication -> + m SearchApplicationPutResponse +putSearchApplicationWith appName opts app = + performBHRequest $ Requests9.putSearchApplicationWith appName opts app + +-- | 'getSearchApplication' fetches a search application by name via +-- @GET \/_application\/search_application\/{name}@ on Elasticsearch 9. +-- The wire format is identical to ES8. A @404@ surfaces as an +-- 'EsError'; wrap with 'tryPerformBHRequest' for miss-tolerant reads. +-- +-- For more information see +-- . +getSearchApplication :: + (MonadBH m, WithBackend ElasticSearch9 m) => + SearchApplicationName -> + m SearchApplicationInfo +getSearchApplication = performBHRequest . Requests9.getSearchApplication + +-- | 'deleteSearchApplication' deletes a search application by name via +-- @DELETE \/_application\/search_application\/{name}@ on Elasticsearch 9. +-- The wire format is identical to ES8. Deleting a non-existent +-- application surfaces as an 'EsError'; wrap with +-- 'tryPerformBHRequest' for miss-tolerant deletion. +-- +-- For more information see +-- . +deleteSearchApplication :: + (MonadBH m, WithBackend ElasticSearch9 m) => + SearchApplicationName -> + m Acknowledged +deleteSearchApplication = performBHRequest . Requests9.deleteSearchApplication + +-- | 'searchApplication' runs a search application's stored template +-- against its indices via +-- @POST \/_application\/search_application\/{name}\/_search@ on +-- Elasticsearch 9. The wire format is identical to ES8. +-- +-- For more information see +-- . +searchApplication :: + (FromJSON a, MonadBH m, WithBackend ElasticSearch9 m) => + SearchApplicationName -> + Maybe SearchApplicationSearchParams -> + m (ParsedEsResponse (SearchResult a)) +searchApplication appName mParams = + performBHRequest $ Requests9.searchApplication appName mParams + +-- | Fully-parameterised form of 'searchApplication'. The wire format is +-- identical to ES8. Pass 'SearchApplicationOptions' to attach the @typed_keys@ +-- query parameter; see 'Requests9.searchApplicationWith'. +-- +-- For more information see +-- . +searchApplicationWith :: + (MonadBH m, WithBackend ElasticSearch9 m, FromJSON a) => + SearchApplicationName -> + Maybe SearchApplicationSearchParams -> + SearchApplicationOptions -> + m (ParsedEsResponse (SearchResult a)) +searchApplicationWith appName mParams opts = + performBHRequest $ Requests9.searchApplicationWith appName mParams opts + +-- | 'listSearchApplications' lists configured search applications via +-- @GET \/_application\/search_application@ on Elasticsearch 9. The wire +-- format is identical to ES8. Use 'listSearchApplicationsWith' to attach +-- the @q@\/@from@\/@size@ query parameters. +-- +-- For more information see +-- . +listSearchApplications :: + (MonadBH m, WithBackend ElasticSearch9 m) => + m SearchApplicationListResponse +listSearchApplications = + performBHRequest Requests9.listSearchApplications + +-- | Fully-parameterised form of 'listSearchApplications'. Pass +-- 'SearchApplicationListOptions' to attach the @q@\/@from@\/@size@ query +-- parameters; see 'Requests9.listSearchApplicationsWith'. +-- +-- For more information see +-- . +listSearchApplicationsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + SearchApplicationListOptions -> + m SearchApplicationListResponse +listSearchApplicationsWith opts = + performBHRequest $ Requests9.listSearchApplicationsWith opts + +-- | 'renderSearchApplicationQuery' renders a search application's stored +-- template against the supplied parameters and returns the resulting +-- Elasticsearch query body /without/ executing the search, via +-- @POST \/_application\/search_application\/{name}\/_render_query@ on +-- Elasticsearch 9. The wire format is identical to ES8. The response is +-- the rendered search-request body as an opaque 'Value'. +-- +-- For more information see +-- . +renderSearchApplicationQuery :: + (MonadBH m, WithBackend ElasticSearch9 m) => + SearchApplicationName -> + Maybe SearchApplicationSearchParams -> + m Value +renderSearchApplicationQuery appName mParams = + performBHRequest $ Requests9.renderSearchApplicationQuery appName mParams + +-- | knnSearch executes a k-NN vector search request for Elasticsearch 9. +-- +-- ES9 (like ES8) has no standalone @\/{index}\/_knn_search@ endpoint: kNN +-- is a top-level @\"knn\"@ clause in a standard @POST \/{index}\/_search@ +-- body. This function injects the supplied 'KnnQuery' as a single-element +-- @\"knn\"@ array on the body of the given 'Search' and POSTs it to +-- @\/{index}\/_search@. +-- +-- For more information see +-- . +knnSearch :: + (FromJSON a) => + IndexName -> + KnnQuery -> + Search -> + BHRequest StatusDependant (SearchResult a) +knnSearch indexName knnQuery search = + post @StatusDependant endpoint (encode searchWithKnn) + where + endpoint = mkEndpoint [unIndexName indexName, "_search"] + searchWithKnn = search {knnBody = Just [knnQuery]} + +-- | 'getDataStreams' lists data streams. The wire format is identical +-- across ES 7.x, 8.x and 9.x, so the ES7 request builder is reused +-- verbatim. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream@ returns every data +-- stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}@ returns +-- only the named data streams. +-- +-- See +-- . +getDataStreams :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [DataStreamName] -> + m [DataStreamInfo] +getDataStreams = performBHRequest . Requests7.getDataStreams + +-- | 'getDataStreamStats' returns statistics about data streams +-- (document counts, store sizes, shard counts, etc.). The wire format +-- is identical to ES7, so the ES7 request builder is reused verbatim. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream/_stats@ returns +-- statistics for every data stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}/_stats@ +-- returns statistics for only the named data streams. +-- +-- See +-- . +getDataStreamStats :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [DataStreamName] -> + m DataStreamStats +getDataStreamStats = performBHRequest . Requests7.getDataStreamStats + +-- | 'createDataStream' creates a data stream with the given name. The +-- stream's configuration is derived from the matching index template +-- (which must already exist and declare a @data_stream@ object). The +-- wire format is identical to ES7, so the ES7 request builder is reused +-- verbatim. +-- +-- See +-- . +createDataStream :: + (MonadBH m, WithBackend ElasticSearch9 m) => + DataStreamName -> + m Acknowledged +createDataStream = performBHRequest . Requests7.createDataStream + +-- | 'dataStreamExists' checks whether a data stream with the given +-- name exists. Returns 'True' if the stream exists, 'False' +-- otherwise (any non-2xx status, including @404@, decodes to +-- 'False'; no 'EsError' is raised). The wire format is identical to +-- ES7, so the ES7 request builder is reused verbatim. +-- +-- See +-- . +dataStreamExists :: + (MonadBH m, WithBackend ElasticSearch9 m) => + DataStreamName -> + m Bool +dataStreamExists = performBHRequest . Requests7.dataStreamExists + +-- | 'deleteDataStream' deletes a data stream and its backing indices. +-- Deleting a non-existent stream surfaces as an 'EsError'. The wire +-- format is identical to ES7, so the ES7 request builder is reused +-- verbatim. +-- +-- See +-- . +deleteDataStream :: + (MonadBH m, WithBackend ElasticSearch9 m) => + DataStreamName -> + m Acknowledged +deleteDataStream = performBHRequest . Requests7.deleteDataStream + +-- | 'migrateToDataStream' converts an existing alias (whose write index +-- is a hidden or data-stream-compatible backing index) into a data +-- stream. The alias and its write index must already be set up +-- correctly; an ineligible alias surfaces as an 'EsError'. The wire +-- format is identical to ES7, so the ES7 request builder is reused +-- verbatim. +-- +-- See +-- . +migrateToDataStream :: + (MonadBH m, WithBackend ElasticSearch9 m) => + IndexAliasName -> + m Acknowledged +migrateToDataStream = performBHRequest . Requests7.migrateToDataStream + +-- | 'promoteDataStream' promotes a frozen or cloned data stream back to a +-- regular data stream (disaster recovery). A stream that is not +-- currently frozen surfaces as an 'EsError'. The wire format is +-- identical to ES7, so the ES7 request builder is reused verbatim. +-- +-- See +-- . +promoteDataStream :: + (MonadBH m, WithBackend ElasticSearch9 m) => + DataStreamName -> + m Acknowledged +promoteDataStream = performBHRequest . Requests7.promoteDataStream + +-- | 'putDataStreamLifecycle' sets or updates the lifecycle of a data +-- stream (retention, downsampling, enabled toggle). The wire format +-- is identical to ES8, so the ES9 request builder delegates to ES8. +-- +-- See +-- . +putDataStreamLifecycle :: + (MonadBH m, WithBackend ElasticSearch9 m) => + DataStreamName -> + DataStreamLifecycle -> + m Acknowledged +putDataStreamLifecycle = (performBHRequest .) . Requests9.putDataStreamLifecycle + +-- | 'putDataStreamsLifecycle' sets or updates the lifecycle of +-- multiple data streams in a single bulk request (see +-- 'PutDataStreamsLifecycleRequest'). The wire format is identical to +-- ES8, so the ES9 request builder delegates to ES8. +-- +-- See +-- . +putDataStreamsLifecycle :: + (MonadBH m, WithBackend ElasticSearch9 m) => + PutDataStreamsLifecycleRequest -> + m Acknowledged +putDataStreamsLifecycle = performBHRequest . Requests9.putDataStreamsLifecycle + +-- | 'getDataStreamLifecycle' retrieves the lifecycle configuration of +-- one or more data streams. The wire format is identical to ES8, so +-- the ES9 request builder delegates to ES8. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream/_lifecycle@ +-- returns the lifecycle of every data stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}/_lifecycle@ +-- returns only the lifecycles of the named data streams. +-- +-- Streams that are not managed by a lifecycle appear with their +-- @lifecycle@ field decoded as 'Nothing'. +-- +-- See +-- . +getDataStreamLifecycle :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [DataStreamName] -> + m GetDataStreamLifecyclesResponse +getDataStreamLifecycle = performBHRequest . Requests9.getDataStreamLifecycle + +-- | 'deleteDataStreamLifecycle' removes the lifecycle configuration +-- from a data stream, rendering it unmanaged by the data stream +-- lifecycle. The wire format is identical to ES8, so the ES9 request +-- builder delegates to ES8. +-- +-- See +-- . +deleteDataStreamLifecycle :: + (MonadBH m, WithBackend ElasticSearch9 m) => + DataStreamName -> + m Acknowledged +deleteDataStreamLifecycle = performBHRequest . Requests9.deleteDataStreamLifecycle + +-- | 'modifyDataStream' changes the backing indices of one or more data +-- streams (batched add\/remove backing index). Referencing a +-- non-existent stream or an ineligible index surfaces as an 'EsError'. +-- The wire format is identical to ES7, so the ES7 request builder is +-- reused verbatim. +-- +-- See +-- . +modifyDataStream :: + (MonadBH m, WithBackend ElasticSearch9 m) => + ModifyDataStreamRequest -> + m Acknowledged +modifyDataStream = performBHRequest . Requests7.modifyDataStream + +-- | 'getDataStreamOptions' retrieves the options (e.g. failure store +-- configuration) of one or more data streams. Requires Elasticsearch +-- >= 8.19. The wire format is identical to ES8, so the ES9 request +-- builder delegates to ES8. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream/_options@ +-- returns the options of every data stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}/_options@ +-- returns only the options of the named data streams. +-- +-- See +-- . +getDataStreamOptions :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [DataStreamName] -> + m GetDataStreamOptionsResponse +getDataStreamOptions = performBHRequest . Requests9.getDataStreamOptions + +-- | 'updateDataStreamOptions' sets the options (e.g. failure store +-- configuration) of one or more data streams. Referencing a +-- non-existent stream surfaces as an 'EsError'. Requires Elasticsearch +-- >= 8.19. The wire format is identical to ES8, so the ES9 request +-- builder delegates to ES8. +-- +-- See +-- . +updateDataStreamOptions :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [DataStreamName] -> + UpdateDataStreamOptionsRequest -> + m Acknowledged +updateDataStreamOptions = (performBHRequest .) . Requests9.updateDataStreamOptions + +-- | 'deleteDataStreamOptions' removes the options (e.g. failure store +-- configuration) from one or more data streams, resetting them to +-- their defaults. Deleting the options of a non-existent stream +-- surfaces as an 'EsError'. Requires Elasticsearch >= 8.19. The wire +-- format is identical to ES8, so the ES9 request builder delegates +-- to ES8. +-- +-- See +-- . +deleteDataStreamOptions :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [DataStreamName] -> + m Acknowledged +deleteDataStreamOptions = performBHRequest . Requests9.deleteDataStreamOptions + +-- | 'getDataStreamLifecycleStats' retrieves cluster-wide runtime +-- statistics for the data stream lifecycle service via +-- @GET /_lifecycle/stats@ (Elasticsearch 8.12+, also in ES 9). +-- +-- See +-- . +getDataStreamLifecycleStats :: + (MonadBH m, WithBackend ElasticSearch9 m) => + m DataStreamLifecycleStats +getDataStreamLifecycleStats = performBHRequest Requests9.getDataStreamLifecycleStats + +-- | 'explainDataStreamLifecycle' retrieves the per-index lifecycle +-- status for one or more backing indices via +-- @GET /{index}/_lifecycle/explain@ (Elasticsearch 8.11+, also in ES 9). +-- Equivalent to +-- @'explainDataStreamLifecycleWith' indices 'defaultExplainDataStreamLifecycleOptions'@. +-- +-- See +-- . +explainDataStreamLifecycle :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [IndexName] -> + m ExplainDataStreamLifecycleResponse +explainDataStreamLifecycle = performBHRequest . Requests9.explainDataStreamLifecycle + +-- | 'explainDataStreamLifecycleWith' is the fully-parameterised form +-- of 'explainDataStreamLifecycle'. +explainDataStreamLifecycleWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [IndexName] -> + ExplainDataStreamLifecycleOptions -> + m ExplainDataStreamLifecycleResponse +explainDataStreamLifecycleWith indices = + performBHRequest . Requests9.explainDataStreamLifecycleWith indices + +-- | 'getDataStreamMappings' retrieves the mapping configuration of +-- one or more data streams via @GET /_data_stream\/{name}/_mappings@ +-- (Elasticsearch 9.1+). Equivalent to +-- @'getDataStreamMappingsWith' names 'defaultGetDataStreamMappingsOptions'@. +-- +-- See +-- . +getDataStreamMappings :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [DataStreamName] -> + m GetDataStreamMappingsResponse +getDataStreamMappings = performBHRequest . Requests9.getDataStreamMappings + +-- | 'getDataStreamMappingsWith' is the fully-parameterised form of +-- 'getDataStreamMappings'. +getDataStreamMappingsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [DataStreamName] -> + GetDataStreamMappingsOptions -> + m GetDataStreamMappingsResponse +getDataStreamMappingsWith names = + performBHRequest . Requests9.getDataStreamMappingsWith names + +-- | 'putDataStreamMappings' updates the mapping configuration of one +-- or more data streams via @PUT /_data_stream\/{name}/_mappings@ +-- (Elasticsearch 9.2+). Equivalent to +-- @'putDataStreamMappingsWith' names mapping 'defaultUpdateDataStreamMappingsOptions'@. +-- The body is any 'ToJSON'able mapping object. +-- +-- /CAUTION/: when given @'Nothing'@ or @'Just' []@, the wildcard @*@ +-- is substituted for the @{name}@ segment, applying the override to +-- every data stream on the cluster. +-- +-- See +-- . +putDataStreamMappings :: + (MonadBH m, WithBackend ElasticSearch9 m, ToJSON mapping) => + Maybe [DataStreamName] -> + mapping -> + m UpdateDataStreamMappingsResponse +putDataStreamMappings names = performBHRequest . Requests9.putDataStreamMappings names + +-- | 'putDataStreamMappingsWith' is the fully-parameterised form of +-- 'putDataStreamMappings'. +putDataStreamMappingsWith :: + (MonadBH m, WithBackend ElasticSearch9 m, ToJSON mapping) => + Maybe [DataStreamName] -> + mapping -> + UpdateDataStreamMappingsOptions -> + m UpdateDataStreamMappingsResponse +putDataStreamMappingsWith names mapping = + performBHRequest . Requests9.putDataStreamMappingsWith names mapping + +-- | 'getDataStreamSettings' retrieves the settings configuration of +-- one or more data streams via @GET /_data_stream\/{name}/_settings@ +-- (Elasticsearch 9.1+). Equivalent to +-- @'getDataStreamSettingsWith' names 'defaultGetDataStreamSettingsOptions'@. +-- +-- See +-- . +getDataStreamSettings :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [DataStreamName] -> + m GetDataStreamSettingsResponse +getDataStreamSettings = performBHRequest . Requests9.getDataStreamSettings + +-- | 'getDataStreamSettingsWith' is the fully-parameterised form of +-- 'getDataStreamSettings'. +getDataStreamSettingsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [DataStreamName] -> + GetDataStreamSettingsOptions -> + m GetDataStreamSettingsResponse +getDataStreamSettingsWith names = + performBHRequest . Requests9.getDataStreamSettingsWith names + +-- | 'putDataStreamSettings' updates the settings configuration of one +-- or more data streams via @PUT /_data_stream\/{name}/_settings@ +-- (Elasticsearch 9.1+, also documented as available in 8.19). +-- Equivalent to +-- @'putDataStreamSettingsWith' names settings 'defaultUpdateDataStreamSettingsOptions'@. +-- The body is any 'ToJSON'able settings object. +-- +-- /CAUTION/: when given @'Nothing'@ or @'Just' []@, the wildcard @*@ +-- is substituted for the @{name}@ segment, applying the override to +-- every data stream on the cluster. +-- +-- See +-- . +putDataStreamSettings :: + (MonadBH m, WithBackend ElasticSearch9 m, ToJSON settings) => + Maybe [DataStreamName] -> + settings -> + m UpdateDataStreamSettingsResponse +putDataStreamSettings names = performBHRequest . Requests9.putDataStreamSettings names + +-- | 'putDataStreamSettingsWith' is the fully-parameterised form of +-- 'putDataStreamSettings'. +putDataStreamSettingsWith :: + (MonadBH m, WithBackend ElasticSearch9 m, ToJSON settings) => + Maybe [DataStreamName] -> + settings -> + UpdateDataStreamSettingsOptions -> + m UpdateDataStreamSettingsResponse +putDataStreamSettingsWith names settings = + performBHRequest . Requests9.putDataStreamSettingsWith names settings + +-- | 'deleteEQLSearch' deletes an async EQL search result and its +-- context by id via @DELETE /_eql/search/{id}@ (Elasticsearch 7.10+) +-- and returns 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteEQLSearch :: + (MonadBH m, WithBackend ElasticSearch9 m) => + EQLSearchId -> + m Acknowledged +deleteEQLSearch = performBHRequest . Requests9.deleteEQLSearch + +-- | 'putESQLView' creates or updates an ES|QL view via +-- @PUT \/_query\/view\/{name}@ on Elasticsearch 9 (9.4+, +-- experimental). This endpoint does not exist on Elasticsearch 8.x, so +-- the canonical request builder lives only in the ES9 module (see +-- "Database.Bloodhound.ElasticSearch9.Requests"). +-- +-- For more information see +-- . +putESQLView :: + (MonadBH m, WithBackend ElasticSearch9 m) => + ESQLViewName -> + Text -> + m Acknowledged +putESQLView viewName query = + performBHRequest $ Requests9.putESQLView viewName query + +-- | 'getESQLView' fetches an ES|QL view by name via +-- @GET \/_query\/view\/{name}@ on Elasticsearch 9 (9.4+, +-- experimental). This endpoint does not exist on Elasticsearch 8.x, so +-- the canonical request builder lives only in the ES9 module. +-- +-- For more information see +-- . +getESQLView :: + (MonadBH m, WithBackend ElasticSearch9 m) => + ESQLViewName -> + m ESQLView +getESQLView = performBHRequest . Requests9.getESQLView + +-- | 'deleteESQLView' deletes an ES|QL view by name via +-- @DELETE \/_query\/view\/{name}@ on Elasticsearch 9 (9.4+, +-- experimental). This endpoint does not exist on Elasticsearch 8.x, so +-- the canonical request builder lives only in the ES9 module. +-- +-- For more information see +-- . +deleteESQLView :: + (MonadBH m, WithBackend ElasticSearch9 m) => + ESQLViewName -> + m Acknowledged +deleteESQLView = performBHRequest . Requests9.deleteESQLView + +-- | 'getESQLQuery' fetches information about a currently-running ES|QL +-- query via @GET \/_query\/queries\/{id}@ on Elasticsearch 9 (9.1+, +-- experimental). This endpoint does not exist on Elasticsearch 8.x, so +-- the canonical request builder lives only in the ES9 module. +-- +-- For more information see +-- . +getESQLQuery :: + (MonadBH m, WithBackend ElasticSearch9 m) => + AsyncESQLId -> + m ESQLQueryInfo +getESQLQuery = performBHRequest . Requests9.getESQLQuery + +-- | 'getESQLQueries' lists every currently-running ES|QL query via +-- @GET \/_query\/queries@ on Elasticsearch 9 (9.1+, experimental). +-- This endpoint does not exist on Elasticsearch 8.x, so the canonical +-- request builder lives only in the ES9 module (and shares its builder +-- with 'getESQLQuery'). The response is keyed on the wire by each +-- query's encoded async-id; this wrapper flattens it into +-- @[(AsyncESQLId, ESQLQueryInfo)]@. +-- +-- For more information see +-- . +getESQLQueries :: + (MonadBH m, WithBackend ElasticSearch9 m) => + m [(AsyncESQLId, ESQLQueryInfo)] +getESQLQueries = performBHRequest Requests9.getESQLQueries + +-- | 'getTermsEnum' returns a list of terms in a field for auto-complete +-- use cases via @GET \/{index}\/_terms_enum@ on Elasticsearch 9. The +-- wire format is identical to ES 7.10+\/8.x, so the ES8 request builder +-- is reused verbatim (which itself delegates to ES7). +-- +-- For more information see +-- . +getTermsEnum :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [IndexName] -> + FieldName -> + Maybe Text -> + m TermsEnumResponse +getTermsEnum mIndices field mString = + performBHRequest $ Requests9.getTermsEnum mIndices field mString + +-- | 'getTermsEnumWith' is the fully-parameterised form of +-- 'getTermsEnum' on Elasticsearch 9. Forwards 'TermsEnumOptions' (URI +-- parameters) and a full 'TermsEnumRequest' body. +-- +-- For more information see +-- . +getTermsEnumWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [IndexName] -> + TermsEnumOptions -> + TermsEnumRequest -> + m TermsEnumResponse +getTermsEnumWith mIndices opts req = + performBHRequest $ Requests9.getTermsEnumWith mIndices opts req + +-- | 'getStreamsStatus' returns the enabled state of every named stream +-- (e.g. @logs@, @logs.otel@, @logs.ecs@) via @GET /_streams/status@ +-- (Elasticsearch 9.1+, experimental). The result is a +-- 'StreamsStatusResponse' map; use 'streamStatusFor' to look up a +-- specific stream. Equivalent to +-- @'getStreamsStatusWith' 'defaultGetStreamsStatusOptions'@. +-- +-- For more information see +-- . +getStreamsStatus :: + (MonadBH m, WithBackend ElasticSearch9 m) => + m StreamsStatusResponse +getStreamsStatus = getStreamsStatusWith defaultGetStreamsStatusOptions + +-- | 'getStreamsStatusWith' is the fully-parameterised variant of +-- 'getStreamsStatus', forwarding the @master_timeout@ query parameter +-- via 'GetStreamsStatusOptions'. +getStreamsStatusWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + GetStreamsStatusOptions -> + m StreamsStatusResponse +getStreamsStatusWith opts = + performBHRequest $ Requests9.getStreamsStatusWith opts + +-- | 'enableStream' enables a named stream via +-- @POST /_streams/{name}/_enable@ (Elasticsearch 9.1+, experimental). +-- Returns 'Acknowledged' on success. Equivalent to +-- @'enableStreamWith' name 'defaultStreamsActionOptions'@. +-- +-- For more information see +-- . +enableStream :: + (MonadBH m, WithBackend ElasticSearch9 m) => + StreamName -> + m Acknowledged +enableStream name = performBHRequest $ Requests9.enableStream name + +-- | 'enableStreamWith' is the fully-parameterised variant of +-- 'enableStream', forwarding the @master_timeout@ \/ @timeout@ query +-- parameters via 'StreamsActionOptions'. +enableStreamWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + StreamName -> + StreamsActionOptions -> + m Acknowledged +enableStreamWith name opts = + performBHRequest $ Requests9.enableStreamWith name opts + +-- | 'disableStream' disables a named stream via +-- @POST /_streams/{name}/_disable@ (Elasticsearch 9.1+, experimental). +-- Returns 'Acknowledged' on success. Equivalent to +-- @'disableStreamWith' name 'defaultStreamsActionOptions'@. +-- +-- For more information see +-- . +disableStream :: + (MonadBH m, WithBackend ElasticSearch9 m) => + StreamName -> + m Acknowledged +disableStream name = performBHRequest $ Requests9.disableStream name + +-- | 'disableStreamWith' is the fully-parameterised variant of +-- 'disableStream', forwarding the @master_timeout@ \/ @timeout@ query +-- parameters via 'StreamsActionOptions'. +disableStreamWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + StreamName -> + StreamsActionOptions -> + m Acknowledged +disableStreamWith name opts = + performBHRequest $ Requests9.disableStreamWith name opts + +-- | 'downsampleIndex' rolls up an existing time-series index into a new, +-- coarser-grained index via +-- @POST /{index}/_downsample/{target_index}@ (Elasticsearch 9.x). The +-- @targetIndex@ names the new downsampled index (mandatory path +-- segment). The 'DownsampleRequest' carries the rollup 'FixedInterval' +-- and the optional @sampling_method@. Equivalent to +-- @'downsampleIndexWith' index targetIndex body 'defaultDownsampleOptions'@. +-- +-- For more information see +-- . +downsampleIndex :: + (MonadBH m, WithBackend ElasticSearch9 m) => + IndexName -> + IndexName -> + DownsampleRequest -> + m DownsampleResponse +downsampleIndex index targetIndex body = + performBHRequest $ Requests9.downsampleIndex index targetIndex body + +-- | 'downsampleIndexWith' is the fully-parameterised variant of +-- 'downsampleIndex', forwarding the @wait_for_active_shards@, +-- @master_timeout@ and @timeout@ query parameters via 'DownsampleOptions'. +downsampleIndexWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + IndexName -> + IndexName -> + DownsampleRequest -> + DownsampleOptions -> + m DownsampleResponse +downsampleIndexWith index targetIndex body opts = + performBHRequest $ Requests9.downsampleIndexWith index targetIndex body opts + +-- | 'getGeoIpStats' returns GeoIP downloader statistics via +-- @GET /_ingest/geoip/stats@: aggregate download counts plus the +-- per-node list of cached database files. +-- +-- For more information see +-- . +getGeoIpStats :: + (MonadBH m, WithBackend ElasticSearch9 m) => + m GeoIpStatsResponse +getGeoIpStats = performBHRequest Requests9.getGeoIpStats + +-- | 'getGeoIpDatabases' returns every GeoIP database configuration via +-- @GET /_ingest/geoip/database@. For a single id use 'getGeoIpDatabase'. +-- +-- For more information see +-- . +getGeoIpDatabases :: + (MonadBH m, WithBackend ElasticSearch9 m) => + m GeoIpDatabasesResponse +getGeoIpDatabases = performBHRequest Requests9.getGeoIpDatabases + +-- | 'getGeoIpDatabase' returns one or more GeoIP database +-- configurations via @GET /_ingest/geoip/database/{id}@. The +-- 'GeoIpDatabaseId' may be a single id, a comma-separated list, or the +-- wildcard @"*"@. +getGeoIpDatabase :: + (MonadBH m, WithBackend ElasticSearch9 m) => + GeoIpDatabaseId -> + m GeoIpDatabasesResponse +getGeoIpDatabase = performBHRequest . Requests9.getGeoIpDatabase + +-- | 'putGeoIpDatabase' creates or updates a GeoIP database configuration +-- via @PUT /_ingest/geoip/database/{id}@. The 'GeoIpDatabasePutBody' +-- carries the required @maxmind@ provider. Returns 'Acknowledged' on +-- success. +putGeoIpDatabase :: + (MonadBH m, WithBackend ElasticSearch9 m) => + GeoIpDatabaseId -> + GeoIpDatabasePutBody -> + m Acknowledged +putGeoIpDatabase dbId body = + performBHRequest $ Requests9.putGeoIpDatabase dbId body + +-- | 'deleteGeoIpDatabase' deletes one or more GeoIP database +-- configurations via @DELETE /_ingest/geoip/database/{id}@. The +-- 'GeoIpDatabaseId' may be a single id, a comma-separated list, or the +-- wildcard @"*"@. +deleteGeoIpDatabase :: + (MonadBH m, WithBackend ElasticSearch9 m) => + GeoIpDatabaseId -> + m Acknowledged +deleteGeoIpDatabase = performBHRequest . Requests9.deleteGeoIpDatabase + +-- | 'getIpLocationDatabases' returns every IP-location database +-- configuration via @GET /_ingest/ip_location/database@. +getIpLocationDatabases :: + (MonadBH m, WithBackend ElasticSearch9 m) => + m GeoIpDatabasesResponse +getIpLocationDatabases = + performBHRequest Requests9.getIpLocationDatabases + +-- | 'getIpLocationDatabase' returns one or more IP-location database +-- configurations via @GET /_ingest/ip_location/database/{id}@. +getIpLocationDatabase :: + (MonadBH m, WithBackend ElasticSearch9 m) => + GeoIpDatabaseId -> + m GeoIpDatabasesResponse +getIpLocationDatabase = performBHRequest . Requests9.getIpLocationDatabase + +-- | 'putIpLocationDatabase' creates or updates an IP-location database +-- configuration via @PUT /_ingest/ip_location/database/{id}@. The +-- 'IpLocationDatabasePutBody' should carry exactly one of @maxmind@ or +-- @ipinfo@. Returns 'Acknowledged' on success. +putIpLocationDatabase :: + (MonadBH m, WithBackend ElasticSearch9 m) => + GeoIpDatabaseId -> + IpLocationDatabasePutBody -> + m Acknowledged +putIpLocationDatabase dbId body = + performBHRequest $ Requests9.putIpLocationDatabase dbId body + +-- | 'deleteIpLocationDatabase' deletes one or more IP-location database +-- configurations via @DELETE /_ingest/ip_location/database/{id}@. +deleteIpLocationDatabase :: + (MonadBH m, WithBackend ElasticSearch9 m) => + GeoIpDatabaseId -> + m Acknowledged +deleteIpLocationDatabase = + performBHRequest . Requests9.deleteIpLocationDatabase + +-- | 'simulateIngest' runs the simulate-ingest v2 pipeline resolution +-- against the supplied documents via @POST /_ingest/_simulate@. +-- Equivalent to @'simulateIngestWith' body 'defaultSimulateIngestOptions'@. +-- +-- For more information see +-- . +simulateIngest :: + (MonadBH m, WithBackend ElasticSearch9 m) => + SimulateIngestRequest -> + m SimulateIngestResponse +simulateIngest body = + performBHRequest $ Requests9.simulateIngest body + +-- | 'simulateIngestWith' is the fully-parameterised variant of +-- 'simulateIngest', forwarding the @pipeline@ and @merge_type@ query +-- parameters via 'SimulateIngestOptions'. +simulateIngestWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + SimulateIngestRequest -> + SimulateIngestOptions -> + m SimulateIngestResponse +simulateIngestWith body opts = + performBHRequest $ Requests9.simulateIngestWith body opts + +-- | 'simulateIngestIndex' runs the index-scoped simulate-ingest v2 +-- resolution via @POST /_ingest/{index}/_simulate@. Equivalent to +-- @'simulateIngestIndexWith' indexName body 'defaultSimulateIngestOptions'@. +simulateIngestIndex :: + (MonadBH m, WithBackend ElasticSearch9 m) => + IndexName -> + SimulateIngestRequest -> + m SimulateIngestResponse +simulateIngestIndex indexName body = + performBHRequest $ Requests9.simulateIngestIndex indexName body + +-- | 'simulateIngestIndexWith' is the fully-parameterised variant of +-- 'simulateIngestIndex', forwarding the @pipeline@ and @merge_type@ +-- query parameters via 'SimulateIngestOptions'. +simulateIngestIndexWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + IndexName -> + SimulateIngestRequest -> + SimulateIngestOptions -> + m SimulateIngestResponse +simulateIngestIndexWith indexName body opts = + performBHRequest $ Requests9.simulateIngestIndexWith indexName body opts + +-- | 'simulateIngestGet' is the GET-form counterpart of 'simulateIngest', +-- running the simulate-ingest v2 pipeline resolution against the +-- supplied documents via @GET /_ingest/_simulate@. The Elasticsearch +-- operation documents both GET and POST for this path; they are +-- semantically identical (the body is sent with the GET). Prefer +-- 'simulateIngest' (POST) unless a GET is specifically required. +-- Equivalent to @'simulateIngestWithGet' body 'defaultSimulateIngestOptions'@. +-- +-- For more information see +-- . +simulateIngestGet :: + (MonadBH m, WithBackend ElasticSearch9 m) => + SimulateIngestRequest -> + m SimulateIngestResponse +simulateIngestGet body = + performBHRequest $ Requests9.simulateIngestGet body + +-- | 'simulateIngestWithGet' is the fully-parameterised GET-form variant +-- of 'simulateIngestGet', forwarding the @pipeline@ and @merge_type@ +-- query parameters via 'SimulateIngestOptions'. +simulateIngestWithGet :: + (MonadBH m, WithBackend ElasticSearch9 m) => + SimulateIngestRequest -> + SimulateIngestOptions -> + m SimulateIngestResponse +simulateIngestWithGet body opts = + performBHRequest $ Requests9.simulateIngestWithGet body opts + +-- | 'simulateIngestIndexGet' is the GET-form counterpart of +-- 'simulateIngestIndex', running the index-scoped simulate-ingest v2 +-- resolution via @GET /_ingest/{index}/_simulate@. See +-- 'simulateIngestGet' for the GET/POST equivalence note. Equivalent to +-- @'simulateIngestIndexWithGet' indexName body 'defaultSimulateIngestOptions'@. +simulateIngestIndexGet :: + (MonadBH m, WithBackend ElasticSearch9 m) => + IndexName -> + SimulateIngestRequest -> + m SimulateIngestResponse +simulateIngestIndexGet indexName body = + performBHRequest $ Requests9.simulateIngestIndexGet indexName body + +-- | 'simulateIngestIndexWithGet' is the fully-parameterised GET-form +-- variant of 'simulateIngestIndexGet', forwarding the @pipeline@ and +-- @merge_type@ query parameters via 'SimulateIngestOptions'. +simulateIngestIndexWithGet :: + (MonadBH m, WithBackend ElasticSearch9 m) => + IndexName -> + SimulateIngestRequest -> + SimulateIngestOptions -> + m SimulateIngestResponse +simulateIngestIndexWithGet indexName body opts = + performBHRequest $ Requests9.simulateIngestIndexWithGet indexName body opts + +-- | 'resolveCluster' resolves the cluster-alias component of index +-- expressions via @GET /_resolve/cluster[\/{name}]@ on Elasticsearch 9. +-- See 'Requests9.resolveCluster' for the request-builder semantics. +-- +-- For more information see +-- . +resolveCluster :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [Text] -> + m ResolveClusterResponse +resolveCluster = performBHRequest . Requests9.resolveCluster + +-- | 'resolveClusterWith' is the fully-parameterised form of +-- 'resolveCluster'. +resolveClusterWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + ResolveClusterOptions -> + Maybe [Text] -> + m ResolveClusterResponse +resolveClusterWith opts mPatterns = + performBHRequest $ Requests9.resolveClusterWith opts mPatterns + +-- | 'getHealthReport' fetches the cluster health summary via +-- @GET /_health_report[\/{feature}]@ on Elasticsearch 9. See +-- 'Requests9.getHealthReport' for the request-builder semantics. +-- +-- For more information see +-- . +getHealthReport :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe [Text] -> + m HealthReport +getHealthReport = performBHRequest . Requests9.getHealthReport + +-- | 'getHealthReportWith' is the fully-parameterised form of +-- 'getHealthReport'. +getHealthReportWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + HealthReportOptions -> + Maybe [Text] -> + m HealthReport +getHealthReportWith opts mFeatures = + performBHRequest $ Requests9.getHealthReportWith opts mFeatures + +-- | 'getFeatures' lists the installed features via @GET /_features@ on +-- Elasticsearch 9. +-- +-- For more information see +-- . +getFeatures :: + (MonadBH m, WithBackend ElasticSearch9 m) => + m FeaturesResponse +getFeatures = performBHRequest Requests9.getFeatures + +-- | 'getFeaturesWith' is the fully-parameterised form of 'getFeatures'. +getFeaturesWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + FeaturesOptions -> + m FeaturesResponse +getFeaturesWith opts = + performBHRequest $ Requests9.getFeaturesWith opts + +-- | 'resetFeatures' resets the state of every feature via +-- @POST /_features/_reset@ on Elasticsearch 9. This endpoint is +-- experimental and mutating — intended for development/testing clusters. +-- +-- For more information see +-- . +resetFeatures :: + (MonadBH m, WithBackend ElasticSearch9 m) => + m ResetFeaturesResponse +resetFeatures = performBHRequest Requests9.resetFeatures + +-- | 'resetFeaturesWith' is the fully-parameterised form of 'resetFeatures'. +resetFeaturesWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + FeaturesOptions -> + m ResetFeaturesResponse +resetFeaturesWith opts = + performBHRequest $ Requests9.resetFeaturesWith opts + +------------------------------------------------------------------------------ +-- Migration reindex (/_migration/reindex, /_create_from) +------------------------------------------------------------------------------ + +-- | 'migrateReindex' reindexes all legacy backing indices of a data +-- stream via @POST /_migration/reindex@ (ES 8.18+, identical wire format +-- in ES9). The reindex runs in a persistent task; the endpoint returns +-- 'Acknowledged' immediately. Poll 'getMigrateReindexStatus' to observe +-- progress. Mutates cluster state — call deliberately. +-- +-- For more information see +-- . +migrateReindex :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MigrateReindexRequest -> + m Acknowledged +migrateReindex req = performBHRequest $ Requests9.migrateReindex req + +-- | 'cancelMigrateReindex' cancels an in-progress migration reindex +-- attempt via @POST /_migration/reindex/{index}/_cancel@ (ES 8.18+, +-- identical wire format in ES9). Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +cancelMigrateReindex :: + (MonadBH m, WithBackend ElasticSearch9 m) => + NonEmpty IndexName -> + m Acknowledged +cancelMigrateReindex indices = + performBHRequest $ Requests9.cancelMigrateReindex indices + +-- | 'getMigrateReindexStatus' reports the status of a migration reindex +-- attempt via @GET /_migration/reindex/{index}/_status@ (ES 8.18+, +-- identical wire format in ES9). The response is decoded into +-- 'MigrateReindexStatus'. +-- +-- For more information see +-- . +getMigrateReindexStatus :: + (MonadBH m, WithBackend ElasticSearch9 m) => + NonEmpty IndexName -> + m MigrateReindexStatus +getMigrateReindexStatus indices = + performBHRequest $ Requests9.getMigrateReindexStatus indices + +-- | 'createIndexFrom' copies the mappings and settings from a source +-- index into a fresh destination index via +-- @POST /_create_from/{source}/{dest}@ (ES 8.18+, identical wire format +-- in ES9), with no overrides. Returns 'CreateIndexFromResponse' on +-- success. Mutates cluster state. +-- +-- For more information see +-- . +createIndexFrom :: + (MonadBH m, WithBackend ElasticSearch9 m) => + IndexName -> + IndexName -> + m CreateIndexFromResponse +createIndexFrom source dest = + performBHRequest $ Requests9.createIndexFrom source dest + +-- | 'createIndexFromWith' is the fully-parameterised variant of +-- 'createIndexFrom', accepting an optional 'CreateIndexFromBody' whose +-- @mappings_override@ and @settings_override@ replace the source values. +createIndexFromWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + IndexName -> + IndexName -> + Maybe CreateIndexFromBody -> + m CreateIndexFromResponse +createIndexFromWith source dest mBody = + performBHRequest $ Requests9.createIndexFromWith source dest mBody + +-- ========================================================================= +-- ML data frame analytics (X-Pack) +-- ========================================================================= + +-- | 'putMlDataFrameAnalytics' creates a data frame analytics job via +-- @PUT /_ml/data_frame/analytics/{id}@ on Elasticsearch 9. See +-- 'Requests9.putMlDataFrameAnalytics' for the request-builder semantics. +-- +-- For more information see +-- . +putMlDataFrameAnalytics :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsPutBody -> + m Acknowledged +putMlDataFrameAnalytics id' body = + performBHRequest $ Requests9.putMlDataFrameAnalytics id' body + +-- | 'putMlDataFrameAnalyticsWith' is the fully-parameterised form of +-- 'putMlDataFrameAnalytics'. +putMlDataFrameAnalyticsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsPutBody -> + MlDataFrameAnalyticsOptions -> + m Acknowledged +putMlDataFrameAnalyticsWith id' body opts = + performBHRequest $ Requests9.putMlDataFrameAnalyticsWith id' body opts + +-- | 'getMlDataFrameAnalytics' fetches one (or every) data frame +-- analytics job via @GET /_ml/data_frame/analytics[/{id}]@. Pass +-- 'Nothing' for the id to list every job. +-- +-- For more information see +-- . +getMlDataFrameAnalytics :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlDataFrameAnalyticsId -> + m MlDataFrameAnalyticsGetResponse +getMlDataFrameAnalytics = performBHRequest . Requests9.getMlDataFrameAnalytics + +-- | 'getMlDataFrameAnalyticsWith' is the fully-parameterised form of +-- 'getMlDataFrameAnalytics'. +getMlDataFrameAnalyticsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsOptions -> + m MlDataFrameAnalyticsGetResponse +getMlDataFrameAnalyticsWith mid opts = + performBHRequest $ Requests9.getMlDataFrameAnalyticsWith mid opts + +-- | 'updateMlDataFrameAnalytics' updates a data frame analytics job via +-- @POST /_ml/data_frame/analytics/{id}/_update@. +-- +-- For more information see +-- . +updateMlDataFrameAnalytics :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsUpdateBody -> + m Acknowledged +updateMlDataFrameAnalytics id' body = + performBHRequest $ Requests9.updateMlDataFrameAnalytics id' body + +-- | 'updateMlDataFrameAnalyticsWith' is the fully-parameterised form of +-- 'updateMlDataFrameAnalytics'. +updateMlDataFrameAnalyticsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsUpdateBody -> + MlDataFrameAnalyticsOptions -> + m Acknowledged +updateMlDataFrameAnalyticsWith id' body opts = + performBHRequest $ Requests9.updateMlDataFrameAnalyticsWith id' body opts + +-- | 'deleteMlDataFrameAnalytics' deletes a data frame analytics job via +-- @DELETE /_ml/data_frame/analytics/{id}@. +-- +-- For more information see +-- . +deleteMlDataFrameAnalytics :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDataFrameAnalyticsId -> + m Acknowledged +deleteMlDataFrameAnalytics = performBHRequest . Requests9.deleteMlDataFrameAnalytics + +-- | 'deleteMlDataFrameAnalyticsWith' is the fully-parameterised form of +-- 'deleteMlDataFrameAnalytics'. +deleteMlDataFrameAnalyticsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsOptions -> + m Acknowledged +deleteMlDataFrameAnalyticsWith id' opts = + performBHRequest $ Requests9.deleteMlDataFrameAnalyticsWith id' opts + +-- | 'startMlDataFrameAnalytics' starts a data frame analytics job via +-- @POST /_ml/data_frame/analytics/{id}/_start@. +-- +-- For more information see +-- . +startMlDataFrameAnalytics :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDataFrameAnalyticsId -> + m Acknowledged +startMlDataFrameAnalytics = performBHRequest . Requests9.startMlDataFrameAnalytics + +-- | 'startMlDataFrameAnalyticsWith' is the fully-parameterised form of +-- 'startMlDataFrameAnalytics'. +startMlDataFrameAnalyticsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsOptions -> + m Acknowledged +startMlDataFrameAnalyticsWith id' opts = + performBHRequest $ Requests9.startMlDataFrameAnalyticsWith id' opts + +-- | 'stopMlDataFrameAnalytics' stops a data frame analytics job via +-- @POST /_ml/data_frame/analytics/{id}/_stop@. +-- +-- For more information see +-- . +stopMlDataFrameAnalytics :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDataFrameAnalyticsId -> + m Acknowledged +stopMlDataFrameAnalytics = performBHRequest . Requests9.stopMlDataFrameAnalytics + +-- | 'stopMlDataFrameAnalyticsWith' is the fully-parameterised form of +-- 'stopMlDataFrameAnalytics'. +stopMlDataFrameAnalyticsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsOptions -> + m Acknowledged +stopMlDataFrameAnalyticsWith id' opts = + performBHRequest $ Requests9.stopMlDataFrameAnalyticsWith id' opts + +-- | 'getMlDataFrameAnalyticsStats' fetches usage statistics for one (or +-- every) data frame analytics job via +-- @GET /_ml/data_frame/analytics/{id}/_stats@. Pass 'Nothing' for the id +-- to fetch stats for every job. +-- +-- For more information see +-- . +getMlDataFrameAnalyticsStats :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlDataFrameAnalyticsId -> + m MlDataFrameAnalyticsStatsResponse +getMlDataFrameAnalyticsStats = + performBHRequest . Requests9.getMlDataFrameAnalyticsStats + +-- | 'getMlDataFrameAnalyticsStatsWith' is the fully-parameterised form +-- of 'getMlDataFrameAnalyticsStats'. +getMlDataFrameAnalyticsStatsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsOptions -> + m MlDataFrameAnalyticsStatsResponse +getMlDataFrameAnalyticsStatsWith mid opts = + performBHRequest $ Requests9.getMlDataFrameAnalyticsStatsWith mid opts + +-- | 'previewMlDataFrameAnalytics' simulates a data frame analytics +-- config via @POST /_ml/data_frame/analytics/_preview@, returning the +-- would-be destination rows. +-- +-- For more information see +-- . +previewMlDataFrameAnalytics :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDataFrameAnalyticsPreviewRequest -> + m MlDataFrameAnalyticsPreviewResponse +previewMlDataFrameAnalytics = + performBHRequest . Requests9.previewMlDataFrameAnalytics + +-- ========================================================================= +-- ML trained models (X-Pack) +-- ========================================================================= + +-- | 'putMlTrainedModel' creates a trained model via +-- @PUT /_ml/trained_models/{model_id}@ on Elasticsearch 9. See +-- 'Requests9.putMlTrainedModel' for the request-builder semantics. +-- +-- For more information see +-- . +putMlTrainedModel :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + MlTrainedModelPutBody -> + m Acknowledged +putMlTrainedModel id' body = + performBHRequest $ Requests9.putMlTrainedModel id' body + +-- | 'putMlTrainedModelWith' is the fully-parameterised form of +-- 'putMlTrainedModel'. +putMlTrainedModelWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + MlTrainedModelPutBody -> + MlTrainedModelOptions -> + m Acknowledged +putMlTrainedModelWith id' body opts = + performBHRequest $ Requests9.putMlTrainedModelWith id' body opts + +-- | 'getMlTrainedModels' fetches one (or every) trained model via +-- @GET /_ml/trained_models[/{model_id}]@. Pass 'Nothing' to list every +-- model. +-- +-- For more information see +-- . +getMlTrainedModels :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlTrainedModelId -> + m MlTrainedModelsResponse +getMlTrainedModels = performBHRequest . Requests9.getMlTrainedModels + +-- | 'getMlTrainedModelsWith' is the fully-parameterised form of +-- 'getMlTrainedModels'. +getMlTrainedModelsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlTrainedModelId -> + MlTrainedModelOptions -> + m MlTrainedModelsResponse +getMlTrainedModelsWith mid opts = + performBHRequest $ Requests9.getMlTrainedModelsWith mid opts + +-- | 'getMlTrainedModelDefinition' fetches the (streamed) model definition +-- via @GET /_ml/trained_models/{model_id}/definition@. +-- +-- For more information see +-- . +getMlTrainedModelDefinition :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + m MlTrainedModelDefinition +getMlTrainedModelDefinition = + performBHRequest . Requests9.getMlTrainedModelDefinition + +-- | 'getMlTrainedModelDefinitionWith' is the fully-parameterised form of +-- 'getMlTrainedModelDefinition'. +getMlTrainedModelDefinitionWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + MlTrainedModelOptions -> + m MlTrainedModelDefinition +getMlTrainedModelDefinitionWith id' opts = + performBHRequest $ Requests9.getMlTrainedModelDefinitionWith id' opts + +-- | 'updateMlTrainedModel' updates a trained model's metadata via +-- @POST /_ml/trained_models/{model_id}/_update@. +-- +-- For more information see +-- . +updateMlTrainedModel :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + MlTrainedModelUpdateBody -> + m Acknowledged +updateMlTrainedModel id' body = + performBHRequest $ Requests9.updateMlTrainedModel id' body + +-- | 'updateMlTrainedModelWith' is the fully-parameterised form of +-- 'updateMlTrainedModel'. +updateMlTrainedModelWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + MlTrainedModelUpdateBody -> + MlTrainedModelOptions -> + m Acknowledged +updateMlTrainedModelWith id' body opts = + performBHRequest $ Requests9.updateMlTrainedModelWith id' body opts + +-- | 'deleteMlTrainedModel' deletes a trained model via +-- @DELETE /_ml/trained_models/{model_id}@. +-- +-- For more information see +-- . +deleteMlTrainedModel :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + m Acknowledged +deleteMlTrainedModel = performBHRequest . Requests9.deleteMlTrainedModel + +-- | 'deleteMlTrainedModelWith' is the fully-parameterised form of +-- 'deleteMlTrainedModel'. +deleteMlTrainedModelWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + MlTrainedModelOptions -> + m Acknowledged +deleteMlTrainedModelWith id' opts = + performBHRequest $ Requests9.deleteMlTrainedModelWith id' opts + +-- | 'deployMlTrainedModel' deploys a trained model to the native +-- process via @POST /_ml/trained_models/{model_id}/deployment/_deploy@. +-- +-- For more information see +-- . +deployMlTrainedModel :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + m Acknowledged +deployMlTrainedModel = performBHRequest . Requests9.deployMlTrainedModel + +-- | 'deployMlTrainedModelWith' is the fully-parameterised form of +-- 'deployMlTrainedModel'. +deployMlTrainedModelWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + MlTrainedModelOptions -> + m Acknowledged +deployMlTrainedModelWith id' opts = + performBHRequest $ Requests9.deployMlTrainedModelWith id' opts + +-- | 'undeployMlTrainedModel' releases a deployed model from memory via +-- @POST /_ml/trained_models/{model_id}/deployment/_undeploy@. +-- +-- For more information see +-- . +undeployMlTrainedModel :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + m Acknowledged +undeployMlTrainedModel = + performBHRequest . Requests9.undeployMlTrainedModel + +-- | 'undeployMlTrainedModelWith' is the fully-parameterised form of +-- 'undeployMlTrainedModel'. +undeployMlTrainedModelWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + MlTrainedModelOptions -> + m Acknowledged +undeployMlTrainedModelWith id' opts = + performBHRequest $ Requests9.undeployMlTrainedModelWith id' opts + +-- | 'startMlTrainedModelDeployment' starts a model deployment via +-- @POST /_ml/trained_models/{model_id}/deployment/_start@ (the 8.12+ +-- alias of 'deployMlTrainedModel'). +-- +-- For more information see +-- . +startMlTrainedModelDeployment :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + m Acknowledged +startMlTrainedModelDeployment = + performBHRequest . Requests9.startMlTrainedModelDeployment + +-- | 'startMlTrainedModelDeploymentWith' is the fully-parameterised form +-- of 'startMlTrainedModelDeployment'. +startMlTrainedModelDeploymentWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + MlTrainedModelOptions -> + m Acknowledged +startMlTrainedModelDeploymentWith id' opts = + performBHRequest $ Requests9.startMlTrainedModelDeploymentWith id' opts + +-- | 'stopMlTrainedModelDeployment' stops a model deployment via +-- @POST /_ml/trained_models/{model_id}/deployment/_stop@ (the 8.12+ alias +-- of 'undeployMlTrainedModel'). +-- +-- For more information see +-- . +stopMlTrainedModelDeployment :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + m Acknowledged +stopMlTrainedModelDeployment = + performBHRequest . Requests9.stopMlTrainedModelDeployment + +-- | 'stopMlTrainedModelDeploymentWith' is the fully-parameterised form +-- of 'stopMlTrainedModelDeployment'. +stopMlTrainedModelDeploymentWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + MlTrainedModelOptions -> + m Acknowledged +stopMlTrainedModelDeploymentWith id' opts = + performBHRequest $ Requests9.stopMlTrainedModelDeploymentWith id' opts + +-- | 'getMlTrainedModelStats' fetches usage statistics for one (or every) +-- trained model via @GET /_ml/trained_models/{model_id}/_stats@. Pass +-- 'Nothing' to fetch stats for every model. +-- +-- For more information see +-- . +getMlTrainedModelStats :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlTrainedModelId -> + m MlTrainedModelStatsResponse +getMlTrainedModelStats = + performBHRequest . Requests9.getMlTrainedModelStats + +-- | 'getMlTrainedModelStatsWith' is the fully-parameterised form of +-- 'getMlTrainedModelStats'. +getMlTrainedModelStatsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlTrainedModelId -> + MlTrainedModelOptions -> + m MlTrainedModelStatsResponse +getMlTrainedModelStatsWith mid opts = + performBHRequest $ Requests9.getMlTrainedModelStatsWith mid opts + +-- | 'inferMlTrainedModel' runs inference against a deployed model via +-- @POST /_ml/trained_models/{model_id}/_infer@. +-- +-- For more information see +-- . +inferMlTrainedModel :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlTrainedModelId -> + MlTrainedModelInferRequest -> + m MlTrainedModelInferResponse +inferMlTrainedModel id' req = + performBHRequest $ Requests9.inferMlTrainedModel id' req + +-- ========================================================================= +-- ML anomaly jobs (X-Pack) +-- ========================================================================= + +-- | 'putMlAnomalyJob' creates an anomaly detection job via +-- @PUT /_ml/anomaly_detectors/{job_id}@. +-- +-- For more information see +-- . +putMlAnomalyJob :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlAnomalyJob -> + m Acknowledged +putMlAnomalyJob id' body = + performBHRequest $ Requests9.putMlAnomalyJob id' body + +-- | 'getMlAnomalyJobs' fetches one (or every) anomaly job via +-- @GET /_ml/anomaly_detectors[/{job_id}]@. Pass 'Nothing' to list every +-- job. +getMlAnomalyJobs :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlJobId -> + m MlAnomalyJobsResponse +getMlAnomalyJobs = performBHRequest . Requests9.getMlAnomalyJobs + +-- | 'getMlAnomalyJobsWith' is the fully-parameterised form of +-- 'getMlAnomalyJobs'. +getMlAnomalyJobsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlJobId -> + MlAnomalyJobOptions -> + m MlAnomalyJobsResponse +getMlAnomalyJobsWith mid opts = + performBHRequest $ Requests9.getMlAnomalyJobsWith mid opts + +-- | 'updateMlAnomalyJob' updates an anomaly job via +-- @POST /_ml/anomaly_detectors/{job_id}/_update@. +updateMlAnomalyJob :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlAnomalyJobUpdate -> + m Acknowledged +updateMlAnomalyJob id' body = + performBHRequest $ Requests9.updateMlAnomalyJob id' body + +-- | 'deleteMlAnomalyJob' deletes an anomaly job via +-- @DELETE /_ml/anomaly_detectors/{job_id}@. +deleteMlAnomalyJob :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + m Acknowledged +deleteMlAnomalyJob = performBHRequest . Requests9.deleteMlAnomalyJob + +-- | 'deleteMlAnomalyJobWith' is the fully-parameterised form of +-- 'deleteMlAnomalyJob'. +deleteMlAnomalyJobWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlAnomalyJobOptions -> + m Acknowledged +deleteMlAnomalyJobWith id' opts = + performBHRequest $ Requests9.deleteMlAnomalyJobWith id' opts + +-- | 'openMlAnomalyJob' opens an anomaly job via +-- @POST /_ml/anomaly_detectors/{job_id}/_open@. +openMlAnomalyJob :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + m Acknowledged +openMlAnomalyJob = performBHRequest . Requests9.openMlAnomalyJob + +-- | 'closeMlAnomalyJob' closes an anomaly job via +-- @POST /_ml/anomaly_detectors/{job_id}/_close@. +closeMlAnomalyJob :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + m Acknowledged +closeMlAnomalyJob = performBHRequest . Requests9.closeMlAnomalyJob + +-- | 'forecastMlAnomalyJob' produces a forecast for a started job via +-- @POST /_ml/anomaly_detectors/{job_id}/_forecast@. +forecastMlAnomalyJob :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlForecastOptions -> + m MlForecastResponse +forecastMlAnomalyJob id' opts = + performBHRequest $ Requests9.forecastMlAnomalyJob id' opts + +-- | 'flushMlAnomalyJob' flushes interim results via +-- @POST /_ml/anomaly_detectors/{job_id}/_flush@. +flushMlAnomalyJob :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlFlushOptions -> + m MlFlushResponse +flushMlAnomalyJob id' opts = + performBHRequest $ Requests9.flushMlAnomalyJob id' opts + +-- | 'validateMlAnomalyJob' validates a job configuration via +-- @POST /_ml/anomaly_detectors/_validate@ without creating it. +validateMlAnomalyJob :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlAnomalyJob -> + m MlValidateResponse +validateMlAnomalyJob = performBHRequest . Requests9.validateMlAnomalyJob + +-- | 'getMlAnomalyJobStats' fetches usage statistics for one (or every) +-- anomaly job via @GET /_ml/anomaly_detectors[/{job_id}]/_stats@. +getMlAnomalyJobStats :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlJobId -> + m MlAnomalyJobStatsResponse +getMlAnomalyJobStats = + performBHRequest . Requests9.getMlAnomalyJobStats + +-- | 'getMlAnomalyJobStatsWith' is the fully-parameterised form of +-- 'getMlAnomalyJobStats'. +getMlAnomalyJobStatsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlJobId -> + MlAnomalyJobOptions -> + m MlAnomalyJobStatsResponse +getMlAnomalyJobStatsWith mid opts = + performBHRequest $ Requests9.getMlAnomalyJobStatsWith mid opts + +-- | 'getMlAnomalyJobResults' fetches read-only results +-- (buckets\/records\/categories\/influencers\/overall_buckets) via +-- @GET /_ml/anomaly_detectors/{job_id}/_results/{kind}@. +getMlAnomalyJobResults :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlAnomalyResultType -> + m MlAnomalyJobResults +getMlAnomalyJobResults id' kind = + performBHRequest $ Requests9.getMlAnomalyJobResults id' kind + +-- | 'getMlAnomalyJobResultsWith' is the fully-parameterised form of +-- 'getMlAnomalyJobResults'. +getMlAnomalyJobResultsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlAnomalyResultType -> + MlAnomalyJobOptions -> + m MlAnomalyJobResults +getMlAnomalyJobResultsWith id' kind opts = + performBHRequest $ Requests9.getMlAnomalyJobResultsWith id' kind opts + +-- | 'getMlModelSnapshots' lists model snapshots for a job via +-- @GET /_ml/anomaly_detectors/{job_id}/_model_snapshots@. +getMlModelSnapshots :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + m MlModelSnapshotsResponse +getMlModelSnapshots = performBHRequest . Requests9.getMlModelSnapshots + +-- | 'getMlModelSnapshotsWith' is the fully-parameterised form of +-- 'getMlModelSnapshots'. +getMlModelSnapshotsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlAnomalyJobOptions -> + m MlModelSnapshotsResponse +getMlModelSnapshotsWith id' opts = + performBHRequest $ Requests9.getMlModelSnapshotsWith id' opts + +-- | 'getMlModelSnapshot' fetches a single model snapshot via +-- @GET /_ml/anomaly_detectors/{job_id}/_model_snapshots/{snapshot_id}@. +getMlModelSnapshot :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlModelSnapshotId -> + m MlModelSnapshotsResponse +getMlModelSnapshot id' snap = + performBHRequest $ Requests9.getMlModelSnapshot id' snap + +-- | 'getMlModelSnapshotWith' is the fully-parameterised form of +-- 'getMlModelSnapshot'. +getMlModelSnapshotWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlModelSnapshotId -> + MlAnomalyJobOptions -> + m MlModelSnapshotsResponse +getMlModelSnapshotWith id' snap opts = + performBHRequest $ Requests9.getMlModelSnapshotWith id' snap opts + +-- | 'updateMlModelSnapshot' updates snapshot metadata via +-- @PUT /_ml/anomaly_detectors/{job_id}/_model_snapshots/{snapshot_id}@. +updateMlModelSnapshot :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlModelSnapshotId -> + Value -> + m Acknowledged +updateMlModelSnapshot id' snap body = + performBHRequest $ Requests9.updateMlModelSnapshot id' snap body + +-- | 'deleteMlModelSnapshot' deletes a model snapshot via +-- @DELETE /_ml/anomaly_detectors/{job_id}/_model_snapshots/{snapshot_id}@. +deleteMlModelSnapshot :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlModelSnapshotId -> + m Acknowledged +deleteMlModelSnapshot id' snap = + performBHRequest $ Requests9.deleteMlModelSnapshot id' snap + +-- | 'deleteMlModelSnapshotWith' is the fully-parameterised form of +-- 'deleteMlModelSnapshot'. +deleteMlModelSnapshotWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlModelSnapshotId -> + MlAnomalyJobOptions -> + m Acknowledged +deleteMlModelSnapshotWith id' snap opts = + performBHRequest $ Requests9.deleteMlModelSnapshotWith id' snap opts + +-- | 'revertMlModelSnapshot' reverts a job to a model snapshot via +-- @POST /_ml/anomaly_detectors/{job_id}/_model_snapshots/{snapshot_id}/_revert@. +revertMlModelSnapshot :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlModelSnapshotId -> + Value -> + m MlRevertSnapshotResponse +revertMlModelSnapshot id' snap body = + performBHRequest $ Requests9.revertMlModelSnapshot id' snap body + +-- | 'revertMlModelSnapshotWith' is the fully-parameterised form of +-- 'revertMlModelSnapshot'. +revertMlModelSnapshotWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlJobId -> + MlModelSnapshotId -> + Value -> + MlAnomalyJobOptions -> + m MlRevertSnapshotResponse +revertMlModelSnapshotWith id' snap body opts = + performBHRequest $ Requests9.revertMlModelSnapshotWith id' snap body opts + +-- ========================================================================= +-- ML datafeeds (X-Pack) +-- ========================================================================= + +-- | 'putMlDatafeed' creates a datafeed via +-- @PUT /_ml/datafeeds/{feed_id}@. +putMlDatafeed :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDatafeedId -> + MlDatafeed -> + m Acknowledged +putMlDatafeed id' body = + performBHRequest $ Requests9.putMlDatafeed id' body + +-- | 'getMlDatafeeds' fetches one (or every) datafeed via +-- @GET /_ml/datafeeds[/{feed_id}]@. +getMlDatafeeds :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlDatafeedId -> + m MlDatafeedsResponse +getMlDatafeeds = performBHRequest . Requests9.getMlDatafeeds + +-- | 'getMlDatafeedsWith' is the fully-parameterised form of +-- 'getMlDatafeeds'. +getMlDatafeedsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlDatafeedId -> + MlDatafeedOptions -> + m MlDatafeedsResponse +getMlDatafeedsWith mid opts = + performBHRequest $ Requests9.getMlDatafeedsWith mid opts + +-- | 'updateMlDatafeed' updates a datafeed via +-- @POST /_ml/datafeeds/{feed_id}/_update@. +updateMlDatafeed :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDatafeedId -> + MlDatafeedUpdate -> + m Acknowledged +updateMlDatafeed id' body = + performBHRequest $ Requests9.updateMlDatafeed id' body + +-- | 'deleteMlDatafeed' deletes a datafeed via +-- @DELETE /_ml/datafeeds/{feed_id}@. +deleteMlDatafeed :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDatafeedId -> + m Acknowledged +deleteMlDatafeed = performBHRequest . Requests9.deleteMlDatafeed + +-- | 'startMlDatafeed' starts a datafeed via +-- @POST /_ml/datafeeds/{feed_id}/_start@. The body may carry optional +-- @start@ \/ @end@ times; pass @object []@ for an empty body. +startMlDatafeed :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDatafeedId -> + Value -> + m Acknowledged +startMlDatafeed id' body = + performBHRequest $ Requests9.startMlDatafeed id' body + +-- | 'stopMlDatafeed' stops a datafeed via +-- @POST /_ml/datafeeds/{feed_id}/_stop@. +stopMlDatafeed :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDatafeedId -> + m Acknowledged +stopMlDatafeed = performBHRequest . Requests9.stopMlDatafeed + +-- | 'previewMlDatafeed' previews the documents a datafeed would send via +-- @GET /_ml/datafeeds/{feed_id}/_preview@. +previewMlDatafeed :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlDatafeedId -> + m MlDatafeedPreviewResponse +previewMlDatafeed = performBHRequest . Requests9.previewMlDatafeed + +-- ========================================================================= +-- ML filters (X-Pack) +-- ========================================================================= + +-- | 'putMlFilter' creates or updates a filter via +-- @PUT /_ml/filters/{filter_id}@. +putMlFilter :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlFilterId -> + MlFilter -> + m Acknowledged +putMlFilter id' body = + performBHRequest $ Requests9.putMlFilter id' body + +-- | 'getMlFilters' fetches one (or every) filter via +-- @GET /_ml/filters[/{filter_id}]@. +getMlFilters :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlFilterId -> + m MlFiltersResponse +getMlFilters = performBHRequest . Requests9.getMlFilters + +-- | 'getMlFiltersWith' is the fully-parameterised form of 'getMlFilters'. +getMlFiltersWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlFilterId -> + MlDatafeedOptions -> + m MlFiltersResponse +getMlFiltersWith mid opts = + performBHRequest $ Requests9.getMlFiltersWith mid opts + +-- | 'deleteMlFilter' deletes a filter via +-- @DELETE /_ml/filters/{filter_id}@. +deleteMlFilter :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlFilterId -> + m Acknowledged +deleteMlFilter = performBHRequest . Requests9.deleteMlFilter + +-- ========================================================================= +-- ML calendars and scheduled events (X-Pack) +-- ========================================================================= + +-- | 'putMlCalendar' creates or updates a calendar via +-- @PUT /_ml/calendars/{calendar_id}@. +putMlCalendar :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlCalendarId -> + MlCalendar -> + m Acknowledged +putMlCalendar id' body = + performBHRequest $ Requests9.putMlCalendar id' body + +-- | 'getMlCalendars' fetches one (or every) calendar via +-- @GET /_ml/calendars[/{calendar_id}]@. +getMlCalendars :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlCalendarId -> + m MlCalendarsResponse +getMlCalendars = performBHRequest . Requests9.getMlCalendars + +-- | 'getMlCalendarsWith' is the fully-parameterised form of +-- 'getMlCalendars'. +getMlCalendarsWith :: + (MonadBH m, WithBackend ElasticSearch9 m) => + Maybe MlCalendarId -> + MlDatafeedOptions -> + m MlCalendarsResponse +getMlCalendarsWith mid opts = + performBHRequest $ Requests9.getMlCalendarsWith mid opts + +-- | 'deleteMlCalendar' deletes a calendar via +-- @DELETE /_ml/calendars/{calendar_id}@. +deleteMlCalendar :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlCalendarId -> + m Acknowledged +deleteMlCalendar = performBHRequest . Requests9.deleteMlCalendar + +-- | 'setMlScheduledEvents' adds (or replaces) scheduled events on a +-- calendar via @POST /_ml/calendars/{calendar_id}/events@. +setMlScheduledEvents :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlCalendarId -> + MlScheduledEvents -> + m MlScheduledEventsResponse +setMlScheduledEvents id' body = + performBHRequest $ Requests9.setMlScheduledEvents id' body + +-- | 'getMlScheduledEvents' lists the scheduled events on a calendar via +-- @GET /_ml/calendars/{calendar_id}/events@. +getMlScheduledEvents :: + (MonadBH m, WithBackend ElasticSearch9 m) => + MlCalendarId -> + m MlScheduledEventsResponse +getMlScheduledEvents = performBHRequest . Requests9.getMlScheduledEvents diff --git a/src/Database/Bloodhound/ElasticSearch9/Requests.hs b/src/Database/Bloodhound/ElasticSearch9/Requests.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/ElasticSearch9/Requests.hs @@ -0,0 +1,3011 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.ElasticSearch9.Requests + ( module Reexport, + openPointInTime, + openPointInTimeWith, + openPointInTimeWithBody, + closePointInTime, + esql, + esqlWith, + esqlAsync, + esqlAsyncWith, + getAsyncESQL, + getAsyncESQLWith, + deleteAsyncESQL, + stopAsyncESQL, + putESQLView, + getESQLView, + deleteESQLView, + getESQLQuery, + getESQLQueries, + putInferenceEndpoint, + putInferenceEndpointWith, + updateInferenceEndpoint, + getInferenceEndpoints, + deleteInferenceEndpoint, + deleteInferenceEndpointWith, + runInference, + runInferenceWith, + streamCompletionInference, + streamCompletionInferenceWith, + streamChatCompletionInference, + streamChatCompletionInferenceWith, + putQueryRuleset, + getQueryRuleset, + deleteQueryRuleset, + testQueryRuleset, + putSearchApplication, + putSearchApplicationWith, + getSearchApplication, + deleteSearchApplication, + searchApplication, + searchApplicationWith, + listSearchApplications, + listSearchApplicationsWith, + renderSearchApplicationQuery, + putDataStreamLifecycle, + putDataStreamsLifecycle, + getDataStreamLifecycle, + deleteDataStreamLifecycle, + getDataStreamOptions, + updateDataStreamOptions, + deleteDataStreamOptions, + getDataStreamLifecycleStats, + explainDataStreamLifecycle, + explainDataStreamLifecycleWith, + getDataStreamMappings, + getDataStreamMappingsWith, + putDataStreamMappings, + putDataStreamMappingsWith, + getDataStreamSettings, + getDataStreamSettingsWith, + putDataStreamSettings, + putDataStreamSettingsWith, + eqlSearch, + eqlSearchWith, + getEQLSearch, + getEQLStatus, + deleteEQLSearch, + getTermsEnum, + getTermsEnumWith, + getStreamsStatus, + getStreamsStatusWith, + enableStream, + enableStreamWith, + disableStream, + disableStreamWith, + downsampleIndex, + downsampleIndexWith, + migrateReindex, + cancelMigrateReindex, + getMigrateReindexStatus, + createIndexFrom, + createIndexFromWith, + getGeoIpStats, + getGeoIpDatabases, + getGeoIpDatabase, + putGeoIpDatabase, + deleteGeoIpDatabase, + getIpLocationDatabases, + getIpLocationDatabase, + putIpLocationDatabase, + deleteIpLocationDatabase, + simulateIngest, + simulateIngestWith, + simulateIngestIndex, + simulateIngestIndexWith, + simulateIngestGet, + simulateIngestWithGet, + simulateIngestIndexGet, + simulateIngestIndexWithGet, + resolveCluster, + resolveClusterWith, + getHealthReport, + getHealthReportWith, + getFeatures, + getFeaturesWith, + resetFeatures, + resetFeaturesWith, + putMlDataFrameAnalytics, + putMlDataFrameAnalyticsWith, + getMlDataFrameAnalytics, + getMlDataFrameAnalyticsWith, + updateMlDataFrameAnalytics, + updateMlDataFrameAnalyticsWith, + deleteMlDataFrameAnalytics, + deleteMlDataFrameAnalyticsWith, + startMlDataFrameAnalytics, + startMlDataFrameAnalyticsWith, + stopMlDataFrameAnalytics, + stopMlDataFrameAnalyticsWith, + getMlDataFrameAnalyticsStats, + getMlDataFrameAnalyticsStatsWith, + previewMlDataFrameAnalytics, + putMlTrainedModel, + putMlTrainedModelWith, + getMlTrainedModels, + getMlTrainedModelsWith, + getMlTrainedModelDefinition, + getMlTrainedModelDefinitionWith, + updateMlTrainedModel, + updateMlTrainedModelWith, + deleteMlTrainedModel, + deleteMlTrainedModelWith, + deployMlTrainedModel, + deployMlTrainedModelWith, + undeployMlTrainedModel, + undeployMlTrainedModelWith, + startMlTrainedModelDeployment, + startMlTrainedModelDeploymentWith, + stopMlTrainedModelDeployment, + stopMlTrainedModelDeploymentWith, + getMlTrainedModelStats, + getMlTrainedModelStatsWith, + inferMlTrainedModel, + putMlAnomalyJob, + getMlAnomalyJobs, + getMlAnomalyJobsWith, + updateMlAnomalyJob, + deleteMlAnomalyJob, + deleteMlAnomalyJobWith, + openMlAnomalyJob, + closeMlAnomalyJob, + forecastMlAnomalyJob, + flushMlAnomalyJob, + validateMlAnomalyJob, + getMlAnomalyJobStats, + getMlAnomalyJobStatsWith, + getMlAnomalyJobResults, + getMlAnomalyJobResultsWith, + getMlModelSnapshots, + getMlModelSnapshotsWith, + getMlModelSnapshot, + getMlModelSnapshotWith, + updateMlModelSnapshot, + deleteMlModelSnapshot, + deleteMlModelSnapshotWith, + revertMlModelSnapshot, + revertMlModelSnapshotWith, + putMlDatafeed, + getMlDatafeeds, + getMlDatafeedsWith, + updateMlDatafeed, + deleteMlDatafeed, + startMlDatafeed, + stopMlDatafeed, + previewMlDatafeed, + putMlFilter, + getMlFilters, + getMlFiltersWith, + deleteMlFilter, + putMlCalendar, + getMlCalendars, + getMlCalendarsWith, + deleteMlCalendar, + setMlScheduledEvents, + getMlScheduledEvents, + ) +where + +import Data.Aeson +import Data.ByteString.Lazy qualified as L +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster +import Database.Bloodhound.Common.Requests as Reexport +import Database.Bloodhound.Common.Types +import Database.Bloodhound.ElasticSearch8.Requests qualified as Requests8 +import Database.Bloodhound.ElasticSearch9.Types +import Database.Bloodhound.Internal.Utils.Requests +import Database.Bloodhound.Internal.Versions.Common.Types.KeepAlive () +import Prelude hiding (filter, head) + +-- | 'openPointInTime' opens a point in time for a single index given an +-- 'IndexName', using the supplied 'KeepAlive' duration (e.g. +-- @keepAliveMinutes 1@). Note that the point in time should be closed +-- with 'closePointInTime' as soon as it is no longer needed. +-- +-- This is a convenience wrapper around 'openPointInTimeWith' that lifts +-- the single 'IndexName' into an 'IndexPattern'. To target multiple +-- comma-joined indices or a wildcard pattern (e.g. @\"logs-*,app-*\"@), +-- use 'openPointInTimeWith' directly with an 'IndexPattern'. +-- +-- For more information see +-- . +openPointInTime :: + IndexName -> + KeepAlive -> + BHRequest StatusDependant (ParsedEsResponse OpenPointInTimeResponse) +openPointInTime indexName keepAlive = + openPointInTimeWith (IndexPattern (unIndexName indexName)) keepAlive defaultPITOptions + +-- | 'openPointInTimeWith' is the parameterized variant of +-- 'openPointInTime' on Elasticsearch 9: it takes an 'IndexPattern' as +-- the target, which may be a single index name, a comma-separated list +-- of indices, or a wildcard pattern (e.g. @\"logs-*\"@, +-- @\"logs-2024,logs-2025\"@). It forwards the supplied 'PITOptions' as +-- query-string parameters in addition to the mandatory @keep_alive@. +-- Only the parameters accepted by the Elasticsearch PIT endpoint are +-- emitted (@routing@, @preference@, @expand_wildcards@, +-- @ignore_unavailable@, @allow_partial_search_results@, +-- @max_concurrent_shard_requests@); the OpenSearch-only +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.pitoAllowPartialPITCreation' +-- field is silently dropped by this builder. Pass +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.defaultPITOptions' +-- to reproduce the wire shape of 'openPointInTime'. To send an +-- @index_filter@ body, use 'openPointInTimeWithBody'. +-- +-- For more information see +-- . +openPointInTimeWith :: + IndexPattern -> + KeepAlive -> + PITOptions -> + BHRequest StatusDependant (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWith indexPattern keepAlive opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint emptyBody + where + endpoint = + [unIndexPattern indexPattern, "_pit"] + `withQueries` (("keep_alive", Just (keepAliveToText keepAlive)) : pitOptionsParams opts) + +-- | 'openPointInTimeWithBody' is the body-carrying variant of +-- 'openPointInTimeWith' on Elasticsearch 9: in addition to the +-- 'PITOptions' URI parameters (forwarded exactly as in +-- 'openPointInTimeWith') and the mandatory @keep_alive@, it sends the +-- supplied 'OpenPointInTimeBody' as the JSON request body. This is the +-- only way to supply an @index_filter@ query, which filters indices out +-- of the PIT when it rewrites to @match_none@ on every shard. The +-- 'IndexPattern' target follows the same rules as 'openPointInTimeWith' +-- (single name, comma-list, or wildcard). Pass +-- 'defaultOpenPointInTimeBody' to send an empty (@{}@) body. +-- +-- For more information see +-- . +openPointInTimeWithBody :: + IndexPattern -> + KeepAlive -> + OpenPointInTimeBody -> + PITOptions -> + BHRequest StatusDependant (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWithBody indexPattern keepAlive body opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode body) + where + endpoint = + [unIndexPattern indexPattern, "_pit"] + `withQueries` (("keep_alive", Just (keepAliveToText keepAlive)) : pitOptionsParams opts) + +-- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'. +-- +-- For more information see +-- . +closePointInTime :: + ClosePointInTime -> + BHRequest StatusDependant (ParsedEsResponse ClosePointInTimeResponse) +closePointInTime q = + withBHResponseParsedEsResponse $ + deleteWithBody @StatusDependant ["_pit"] (encode q) + +-- | 'esql' builds the 'BHRequest' for the ES|QL @POST /_query@ endpoint +-- (Elasticsearch 9.x). The body is the encoded ES9 'ESQLRequest', which is a +-- superset of the ES8 wire shape: it additionally carries the ES9-only +-- @time_zone@ and @include_execution_metadata@ fields when set. The response +-- is parsed into 'ESQLResult'. +-- +-- Equivalent to @'esqlWith' req 'defaultESQLQueryOptions'@ — emits no +-- query string. +-- +-- For more information see +-- . +esql :: + ESQLRequest -> + BHRequest StatusDependant (ParsedEsResponse ESQLResult) +esql = flip esqlWith defaultESQLQueryOptions + +-- | 'esqlWith' builds the 'BHRequest' for the ES|QL @POST /_query@ +-- endpoint on Elasticsearch 9 with the documented URI query parameters +-- ('ESQLQueryOptions'). The body is the encoded ES9 'ESQLRequest'; the +-- response is parsed into 'ESQLResult'. +-- +-- Pass 'defaultESQLQueryOptions' to emit no query string (identical +-- wire shape to 'esql'). +-- +-- For more information see +-- . +esqlWith :: + ESQLRequest -> + ESQLQueryOptions -> + BHRequest StatusDependant (ParsedEsResponse ESQLResult) +esqlWith req opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = + mkEndpoint ["_query"] + `withQueries` esqlOptionsParams opts + +-- | 'esqlAsync' builds the 'BHRequest' for the async ES|QL +-- @POST /_query\/async@ endpoint on Elasticsearch 9. The body is the +-- encoded 'AsyncESQLRequest' (an ES9 'ESQLRequest' plus the async-only +-- @wait_for_completion_timeout@, @keep_alive@ and @keep_on_completion@ +-- body fields). +-- +-- Equivalent to @'esqlAsyncWith' req 'defaultESQLQueryOptions'@ — emits +-- no query string. +-- +-- For more information see +-- . +esqlAsync :: + AsyncESQLRequest -> + BHRequest StatusDependant (ParsedEsResponse AsyncESQLResult) +esqlAsync = flip esqlAsyncWith defaultESQLQueryOptions + +-- | 'esqlAsyncWith' builds the 'BHRequest' for the async ES|QL +-- @POST /_query\/async@ endpoint on Elasticsearch 9 with the documented +-- URI query parameters. The body is the encoded 'AsyncESQLRequest'; the +-- response is parsed into 'AsyncESQLResult'. +-- +-- Pass 'defaultESQLQueryOptions' to emit no query string (identical +-- wire shape to 'esqlAsync'). +-- +-- For more information see +-- . +esqlAsyncWith :: + AsyncESQLRequest -> + ESQLQueryOptions -> + BHRequest StatusDependant (ParsedEsResponse AsyncESQLResult) +esqlAsyncWith req opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = + mkEndpoint ["_query", "async"] + `withQueries` esqlOptionsParams opts + +-- | 'getAsyncESQL' builds the 'BHRequest' for +-- @GET /_query\/async\/{id}@ on Elasticsearch 9. The wire format is +-- identical to ES8, so the ES8 request builder is reused verbatim. +-- +-- For more information see +-- . +getAsyncESQL :: + AsyncESQLId -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse AsyncESQLResult) +getAsyncESQL = Requests8.getAsyncESQL + +-- | 'getAsyncESQLWith' is the fully-parameterised form of +-- 'getAsyncESQL' on Elasticsearch 9. The wire format is identical to +-- ES8, so the ES8 request builder is reused verbatim. +-- +-- For more information see +-- . +getAsyncESQLWith :: + AsyncESQLId -> + GetAsyncESQLOptions -> + BHRequest StatusDependant (ParsedEsResponse AsyncESQLResult) +getAsyncESQLWith = Requests8.getAsyncESQLWith + +-- | 'deleteAsyncESQL' builds the 'BHRequest' for +-- @DELETE /_query\/async\/{id}@ on Elasticsearch 9. The wire format is +-- identical to ES8, so the ES8 request builder is reused verbatim. +-- Like the ES8 builder, this is 'StatusDependant': deleting a +-- non-existent or already-purged async id surfaces as an 'EsError'; +-- wrap with 'tryPerformBHRequest' for miss-tolerant deletion. +-- +-- For more information see +-- . +deleteAsyncESQL :: + AsyncESQLId -> + BHRequest StatusDependant Acknowledged +deleteAsyncESQL = Requests8.deleteAsyncESQL + +-- | 'stopAsyncESQL' builds the 'BHRequest' for +-- @POST /_query\/async\/{id}\/stop@ (Elasticsearch 8.11+) on +-- Elasticsearch 9. The wire format is identical to ES8, so the ES8 +-- request builder is reused verbatim. +-- +-- For more information see +-- . +stopAsyncESQL :: + AsyncESQLId -> + BHRequest StatusDependant (ParsedEsResponse AsyncESQLResult) +stopAsyncESQL = Requests8.stopAsyncESQL + +-- | 'putESQLView' builds the 'BHRequest' for +-- @PUT \/_query\/view\/{name}@ (Elasticsearch 9.4+, experimental), +-- which creates or replaces an ES|QL view — a stored, named ES|QL +-- query string that can be referenced from other queries via +-- @FROM @. The body is a single required @query@ field; +-- the response is the shared 'Acknowledged' wrapper +-- (@{\"acknowledged\": true\}@). +-- +-- This endpoint does not exist on Elasticsearch 8.x (it returns a +-- @404@ against any ES8 cluster), so the canonical builder lives here +-- in the ES9 module rather than in +-- "Database.Bloodhound.ElasticSearch8.Requests". +-- +-- For more information see +-- . +putESQLView :: + ESQLViewName -> + Text -> + BHRequest StatusDependant Acknowledged +putESQLView viewName query = + put @StatusDependant endpoint (encode (object ["query" .= query])) + where + endpoint = mkEndpoint ["_query", "view", unESQLViewName viewName] + +-- | 'getESQLView' builds the 'BHRequest' for +-- @GET \/_query\/view\/{name}@ (Elasticsearch 9.4+, experimental), +-- which returns the stored 'ESQLView' — its @name@ (echoed from the +-- path) and @query@. A @404@ for a missing view surfaces as an +-- 'EsError'; wrap with 'tryPerformBHRequest' for miss-tolerant reads. +-- +-- This endpoint does not exist on Elasticsearch 8.x, so the canonical +-- builder lives here in the ES9 module. +-- +-- For more information see +-- . +getESQLView :: + ESQLViewName -> + BHRequest StatusDependant ESQLView +getESQLView viewName = + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_query", "view", unESQLViewName viewName] + +-- | 'deleteESQLView' builds the 'BHRequest' for +-- @DELETE \/_query\/view\/{name}@ (Elasticsearch 9.4+, experimental), +-- which removes an ES|QL view. Returns 'Acknowledged' on success. +-- Deleting a non-existent view surfaces as an 'EsError'; wrap with +-- 'tryPerformBHRequest' for miss-tolerant deletion. +-- +-- This endpoint does not exist on Elasticsearch 8.x, so the canonical +-- builder lives here in the ES9 module. +-- +-- For more information see +-- . +deleteESQLView :: + ESQLViewName -> + BHRequest StatusDependant Acknowledged +deleteESQLView viewName = + delete (mkEndpoint ["_query", "view", unESQLViewName viewName]) + +-- | 'getESQLQuery' builds the 'BHRequest' for +-- @GET \/_query\/queries\/{id}@ (Elasticsearch 9.1+, experimental), +-- which returns information about a currently-running ES|QL query — +-- its numeric task id, the node running it, start time and running +-- time, the query source, and the coordinating\/data nodes involved. +-- +-- The @id@ path segment is the same encoded async-id string returned +-- by @POST \/_query\/async@ (wrapped as 'AsyncESQLId' here); the +-- response's numeric @id@ field is the underlying task identifier, not +-- the encoded string. A query that has already completed and been +-- purged surfaces as a 500 'EsError'; callers typically use this +-- endpoint to inspect a specific query discovered via 'getESQLQueries'. +-- +-- This endpoint does not exist on Elasticsearch 8.x, so the canonical +-- builder lives here in the ES9 module. +-- +-- For more information see +-- . +getESQLQuery :: + AsyncESQLId -> + BHRequest StatusDependant ESQLQueryInfo +getESQLQuery (AsyncESQLId queryId) = + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_query", "queries", queryId] + +-- | 'getESQLQueries' builds the 'BHRequest' for +-- @GET \/_query\/queries@ (Elasticsearch 9.1+, experimental), the +-- list-all sibling of 'getESQLQuery'. It returns information about every +-- currently-running ES|QL query. +-- +-- The response is a JSON object keyed by each query's encoded async-id +-- (the same string 'AsyncESQLId' wraps); each value carries the +-- 'ESQLQueryInfo' for that query. The decoder flattens this into +-- @[(AsyncESQLId, ESQLQueryInfo)]@ so the caller keeps the id it needs to +-- subsequently 'getESQLQuery', 'stopAsyncESQL' or 'deleteAsyncESQL' a +-- listed query. +-- +-- This endpoint does not exist on Elasticsearch 8.x, so the canonical +-- builder lives here in the ES9 module. +-- +-- For more information see +-- . +getESQLQueries :: + BHRequest StatusDependant [(AsyncESQLId, ESQLQueryInfo)] +getESQLQueries = + unESQLQueryListResponse <$> get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_query", "queries"] + +-- | 'putInferenceEndpoint' builds the 'BHRequest' for +-- @PUT \/_inference\/{task_type}\/{inference_id}@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused verbatim. +-- +-- For more information see +-- . +putInferenceEndpoint :: + TaskType -> + InferenceId -> + InferenceConfig -> + BHRequest StatusDependant (ParsedEsResponse InferencePutResponse) +putInferenceEndpoint = Requests8.putInferenceEndpoint + +-- | 'putInferenceEndpointWith' is the fully-parameterised form of +-- 'putInferenceEndpoint' on Elasticsearch 9. The wire format is identical +-- to ES8, so the ES8 request builder is reused verbatim. See +-- 'Requests8.putInferenceEndpointWith' for the semantics of the @timeout@ +-- query parameter. +-- +-- For more information see +-- . +putInferenceEndpointWith :: + TaskType -> + InferenceId -> + InferenceConfig -> + PutInferenceOptions -> + BHRequest StatusDependant (ParsedEsResponse InferencePutResponse) +putInferenceEndpointWith = Requests8.putInferenceEndpointWith + +-- | 'updateInferenceEndpoint' builds the 'BHRequest' for +-- @PUT \/_inference\/{task_type}\/{inference_id}\/_update@ on Elasticsearch 9. +-- The wire format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +updateInferenceEndpoint :: + TaskType -> + InferenceId -> + InferenceConfig -> + BHRequest StatusDependant (ParsedEsResponse InferenceInfo) +updateInferenceEndpoint = Requests8.updateInferenceEndpoint + +-- | 'getInferenceEndpoints' builds the 'BHRequest' for the +-- @GET \/_inference@ family on Elasticsearch 9. The wire format is +-- identical to ES8, so the ES8 request builder is reused verbatim. +-- +-- For more information see +-- . +getInferenceEndpoints :: + Maybe TaskType -> + Maybe InferenceId -> + BHRequest StatusDependant [InferenceInfo] +getInferenceEndpoints = Requests8.getInferenceEndpoints + +-- | 'deleteInferenceEndpoint' builds the 'BHRequest' for +-- @DELETE \/_inference\/{task_type}\/{inference_id}@ on Elasticsearch 9. The +-- wire format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +deleteInferenceEndpoint :: + TaskType -> + InferenceId -> + BHRequest StatusDependant Acknowledged +deleteInferenceEndpoint = Requests8.deleteInferenceEndpoint + +-- | 'deleteInferenceEndpointWith' is the fully-parameterised form of +-- 'deleteInferenceEndpoint' on Elasticsearch 9. The wire format is identical +-- to ES8, so the ES8 request builder is reused verbatim. See +-- 'Requests8.deleteInferenceEndpointWith' for the semantics of the +-- @dry_run@ and @force@ query parameters. +-- +-- For more information see +-- . +deleteInferenceEndpointWith :: + TaskType -> + InferenceId -> + DeleteInferenceOptions -> + BHRequest StatusDependant Acknowledged +deleteInferenceEndpointWith = Requests8.deleteInferenceEndpointWith + +-- | 'runInference' builds the 'BHRequest' for +-- @POST \/_inference\/{task_type}\/{inference_id}@ on Elasticsearch 9. The +-- wire format is identical to ES8, so the ES8 request builder is reused. +-- +-- For more information see +-- . +runInference :: + TaskType -> + InferenceId -> + InferenceInput -> + BHRequest StatusDependant (ParsedEsResponse InferenceResult) +runInference = Requests8.runInference + +-- | 'runInferenceWith' is the fully-parameterised form of 'runInference' on +-- Elasticsearch 9. The wire format is identical to ES8, so the ES8 request +-- builder is reused verbatim. See 'Requests8.runInferenceWith' for the +-- semantics of the @timeout@ query parameter. +-- +-- For more information see +-- . +runInferenceWith :: + TaskType -> + InferenceId -> + InferenceInput -> + RunInferenceOptions -> + BHRequest StatusDependant (ParsedEsResponse InferenceResult) +runInferenceWith = Requests8.runInferenceWith + +-- | 'streamCompletionInference' builds the 'BHRequest' for +-- @POST \/_inference\/completion\/{inference_id}\/_stream@ on Elasticsearch 9. +-- The wire format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +streamCompletionInference :: + InferenceId -> + InferenceInput -> + BHRequest StatusDependant L.ByteString +streamCompletionInference = Requests8.streamCompletionInference + +-- | 'streamCompletionInferenceWith' is the fully-parameterised form of +-- 'streamCompletionInference' on Elasticsearch 9. The wire format is identical +-- to ES8, so the ES8 request builder is reused verbatim. See +-- 'Requests8.streamCompletionInferenceWith' for the semantics of the @timeout@ +-- query parameter. +-- +-- For more information see +-- . +streamCompletionInferenceWith :: + InferenceId -> + InferenceInput -> + StreamCompletionInferenceOptions -> + BHRequest StatusDependant L.ByteString +streamCompletionInferenceWith = Requests8.streamCompletionInferenceWith + +-- | 'streamChatCompletionInference' builds the 'BHRequest' for +-- @POST \/_inference\/chat_completion\/{inference_id}\/_stream@ on +-- Elasticsearch 9. The wire format is identical to ES8, so the ES8 request +-- builder is reused verbatim. +-- +-- For more information see +-- . +streamChatCompletionInference :: + InferenceId -> + ChatCompletionRequest -> + BHRequest StatusDependant L.ByteString +streamChatCompletionInference = Requests8.streamChatCompletionInference + +-- | 'streamChatCompletionInferenceWith' is the fully-parameterised form of +-- 'streamChatCompletionInference' on Elasticsearch 9. The wire format is +-- identical to ES8, so the ES8 request builder is reused verbatim. See +-- 'Requests8.streamChatCompletionInferenceWith' for the semantics of the +-- @timeout@ query parameter. +-- +-- For more information see +-- . +streamChatCompletionInferenceWith :: + InferenceId -> + ChatCompletionRequest -> + StreamChatCompletionInferenceOptions -> + BHRequest StatusDependant L.ByteString +streamChatCompletionInferenceWith = Requests8.streamChatCompletionInferenceWith + +-- | 'putDataStreamLifecycle' builds the 'BHRequest' for +-- @PUT /_data_stream\/{name}/_lifecycle@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +putDataStreamLifecycle :: + DataStreamName -> + DataStreamLifecycle -> + BHRequest StatusDependant Acknowledged +putDataStreamLifecycle = Requests8.putDataStreamLifecycle + +-- | 'putDataStreamsLifecycle' builds the 'BHRequest' for the bulk +-- @PUT /_data_stream/_lifecycle@ on Elasticsearch 9. The wire format +-- is identical to ES8, so the ES8 request builder is reused verbatim. +-- +-- For more information see +-- . +putDataStreamsLifecycle :: + PutDataStreamsLifecycleRequest -> + BHRequest StatusDependant Acknowledged +putDataStreamsLifecycle = Requests8.putDataStreamsLifecycle + +-- | 'getDataStreamLifecycle' builds the 'BHRequest' for +-- @GET /_data_stream\/{name}/_lifecycle@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +getDataStreamLifecycle :: + Maybe [DataStreamName] -> + BHRequest StatusDependant GetDataStreamLifecyclesResponse +getDataStreamLifecycle = Requests8.getDataStreamLifecycle + +-- | 'deleteDataStreamLifecycle' builds the 'BHRequest' for +-- @DELETE /_data_stream\/{name}/_lifecycle@ on Elasticsearch 9. The +-- wire format is identical to ES8, so the ES8 request builder is +-- reused verbatim. +-- +-- For more information see +-- . +deleteDataStreamLifecycle :: + DataStreamName -> + BHRequest StatusDependant Acknowledged +deleteDataStreamLifecycle = Requests8.deleteDataStreamLifecycle + +-- | 'getDataStreamOptions' builds the 'BHRequest' for +-- @GET /_data_stream\/{name}/_options@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +getDataStreamOptions :: + Maybe [DataStreamName] -> + BHRequest StatusDependant GetDataStreamOptionsResponse +getDataStreamOptions = Requests8.getDataStreamOptions + +-- | 'updateDataStreamOptions' builds the 'BHRequest' for +-- @PUT /_data_stream\/{name}/_options@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +updateDataStreamOptions :: + Maybe [DataStreamName] -> + UpdateDataStreamOptionsRequest -> + BHRequest StatusDependant Acknowledged +updateDataStreamOptions = Requests8.updateDataStreamOptions + +-- | 'deleteDataStreamOptions' builds the 'BHRequest' for +-- @DELETE /_data_stream\/{name}/_options@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +deleteDataStreamOptions :: + Maybe [DataStreamName] -> + BHRequest StatusDependant Acknowledged +deleteDataStreamOptions = Requests8.deleteDataStreamOptions + +-- $dataStreamLifecycleStatsAndExplain +-- +-- /Data Stream Lifecycle Stats and Explain/ are available on ES 9.x +-- (and ES 8.11+\/8.12+). The wire format is identical across versions, +-- so the ES8 request builders are reused verbatim. + +-- | 'getDataStreamLifecycleStats' builds the 'BHRequest' for +-- @GET /_lifecycle/stats@ on Elasticsearch 9. The wire format is +-- identical to ES8, so the ES8 request builder is reused verbatim. +-- +-- For more information see +-- . +getDataStreamLifecycleStats :: + BHRequest StatusDependant DataStreamLifecycleStats +getDataStreamLifecycleStats = Requests8.getDataStreamLifecycleStats + +-- | 'explainDataStreamLifecycle' builds the 'BHRequest' for +-- @GET /{index}/_lifecycle/explain@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +explainDataStreamLifecycle :: + Maybe [IndexName] -> + BHRequest StatusDependant ExplainDataStreamLifecycleResponse +explainDataStreamLifecycle = Requests8.explainDataStreamLifecycle + +-- | 'explainDataStreamLifecycleWith' is the fully-parameterised form +-- of 'explainDataStreamLifecycle'. The wire format is identical to +-- ES8, so the ES8 request builder is reused verbatim. +explainDataStreamLifecycleWith :: + Maybe [IndexName] -> + ExplainDataStreamLifecycleOptions -> + BHRequest StatusDependant ExplainDataStreamLifecycleResponse +explainDataStreamLifecycleWith = Requests8.explainDataStreamLifecycleWith + +-- $dataStreamMappings +-- +-- /Data Stream Mappings/ (ES 9.1+ for GET, 9.2+ for PUT) expose and +-- override the mapping configuration at the data-stream level. The +-- endpoints live under @/_data_stream\/{name}/_mappings@ (note the +-- plural @_mappings@ segment). These are ES9-new endpoints; the +-- request builders are defined here rather than delegated to ES8. + +-- | Render 'GetDataStreamMappingsOptions' as a list of @(key, value)@ +-- query parameters suitable for 'withQueries'. 'Nothing' fields are +-- omitted. +getDataStreamMappingsOptionsParams :: GetDataStreamMappingsOptions -> [(Text, Maybe Text)] +getDataStreamMappingsOptionsParams opts = + catMaybes + [ ("master_timeout",) . Just <$> getDataStreamMappingsOptionsMasterTimeout opts + ] + +-- | 'getDataStreamMappings' retrieves the mapping configuration of +-- one or more data streams. Equivalent to +-- @'getDataStreamMappingsWith' names 'defaultGetDataStreamMappingsOptions'@. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream/_mappings@ +-- returns mappings for every data stream on the cluster. +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}/_mappings@ +-- returns only the mappings of the named data streams (comma-joined +-- path segment). Wildcards (@*@) are accepted by the server. +-- +-- See +-- . +getDataStreamMappings :: + Maybe [DataStreamName] -> + BHRequest StatusDependant GetDataStreamMappingsResponse +getDataStreamMappings names = + getDataStreamMappingsWith names defaultGetDataStreamMappingsOptions + +-- | 'getDataStreamMappingsWith' is the fully-parameterised form of +-- 'getDataStreamMappings'. Pass 'defaultGetDataStreamMappingsOptions' +-- to reproduce a parameterless call. +getDataStreamMappingsWith :: + Maybe [DataStreamName] -> + GetDataStreamMappingsOptions -> + BHRequest StatusDependant GetDataStreamMappingsResponse +getDataStreamMappingsWith mNames opts = + get @StatusDependant (endpoint `withQueries` getDataStreamMappingsOptionsParams opts) + where + endpoint = renderGetDataStreamNameEndpoint mNames "_mappings" + +-- | 'putDataStreamMappings' updates the mapping configuration of one +-- or more data streams. Equivalent to +-- @'putDataStreamMappingsWith' names mapping 'defaultUpdateDataStreamMappingsOptions'@. +-- The body is any 'ToJSON'able mapping object (the ES mapping schema +-- is open-ended); see 'GetDataStreamMappingsEntry' for the response +-- shape. +-- +-- /CAUTION/: when given @'Nothing'@ or @'Just' []@, the builder +-- substitutes the wildcard @*@ for the @{name}@ path segment, so the +-- mapping override is applied to /every/ data stream on the cluster. +-- Pass an explicit 'DataStreamName' list if you want to scope the +-- update. +-- +-- The override takes precedence over the template's mappings and is +-- applied to the write index on the next rollover (no existing +-- backing indices are changed). +-- +-- See +-- . +putDataStreamMappings :: + (ToJSON mapping) => + Maybe [DataStreamName] -> + mapping -> + BHRequest StatusDependant UpdateDataStreamMappingsResponse +putDataStreamMappings names mapping = + putDataStreamMappingsWith names mapping defaultUpdateDataStreamMappingsOptions + +-- | 'putDataStreamMappingsWith' is the fully-parameterised form of +-- 'putDataStreamMappings'. Pass +-- 'defaultUpdateDataStreamMappingsOptions' to reproduce a +-- parameterless call. The @dry_run@ option simulates the update +-- without applying it; the response carries the mappings that /would/ +-- result from the change. +putDataStreamMappingsWith :: + (ToJSON mapping) => + Maybe [DataStreamName] -> + mapping -> + UpdateDataStreamMappingsOptions -> + BHRequest StatusDependant UpdateDataStreamMappingsResponse +putDataStreamMappingsWith mNames mapping opts = + put @StatusDependant (endpoint `withQueries` updateDataStreamMappingsOptionsParams opts) (encode mapping) + where + endpoint = renderPutDataStreamNameEndpoint mNames "_mappings" + +-- | Render 'UpdateDataStreamMappingsOptions' as a list of +-- @(key, value)@ query parameters. 'Nothing' fields are omitted; +-- booleans render as @"true"@\/@"false"@. +updateDataStreamMappingsOptionsParams :: UpdateDataStreamMappingsOptions -> [(Text, Maybe Text)] +updateDataStreamMappingsOptionsParams opts = + catMaybes + [ ("dry_run",) . Just . boolQP <$> updateDataStreamMappingsOptionsDryRun opts, + ("master_timeout",) . Just <$> updateDataStreamMappingsOptionsMasterTimeout opts, + ("timeout",) . Just <$> updateDataStreamMappingsOptionsTimeout opts + ] + where + boolQP True = "true" + boolQP False = "false" + +-- $dataStreamSettings +-- +-- /Data Stream Settings/ (ES 9.1+ for GET and PUT; PUT also +-- documented as available in 8.19) expose and override the +-- index-settings configuration at the data-stream level. The +-- endpoints live under @/_data_stream\/{name}/_settings@. + +-- | Render 'GetDataStreamSettingsOptions' as a list of @(key, value)@ +-- query parameters. 'Nothing' fields are omitted. +getDataStreamSettingsOptionsParams :: GetDataStreamSettingsOptions -> [(Text, Maybe Text)] +getDataStreamSettingsOptionsParams opts = + catMaybes + [ ("master_timeout",) . Just <$> getDataStreamSettingsOptionsMasterTimeout opts + ] + +-- | 'getDataStreamSettings' retrieves the settings configuration of +-- one or more data streams. Equivalent to +-- @'getDataStreamSettingsWith' names 'defaultGetDataStreamSettingsOptions'@. +-- +-- * @'Nothing'@ or @'Just' []@ → @GET /_data_stream/_settings@ +-- * @'Just' names@ → @GET /_data_stream\/{a,b,c}/_settings@ +-- +-- /Numeric-as-string/: ES returns numeric settings values as JSON +-- strings inside the @settings@ object; the opaque 'Value' preserves +-- them verbatim. +-- +-- See +-- . +getDataStreamSettings :: + Maybe [DataStreamName] -> + BHRequest StatusDependant GetDataStreamSettingsResponse +getDataStreamSettings names = + getDataStreamSettingsWith names defaultGetDataStreamSettingsOptions + +-- | 'getDataStreamSettingsWith' is the fully-parameterised form of +-- 'getDataStreamSettings'. +getDataStreamSettingsWith :: + Maybe [DataStreamName] -> + GetDataStreamSettingsOptions -> + BHRequest StatusDependant GetDataStreamSettingsResponse +getDataStreamSettingsWith mNames opts = + get @StatusDependant (endpoint `withQueries` getDataStreamSettingsOptionsParams opts) + where + endpoint = renderGetDataStreamNameEndpoint mNames "_settings" + +-- | 'putDataStreamSettings' updates the settings configuration of one +-- or more data streams. Equivalent to +-- @'putDataStreamSettingsWith' names settings 'defaultUpdateDataStreamSettingsOptions'@. +-- The body is any 'ToJSON'able settings object (flat dotted keys like +-- @"index.lifecycle.name"@ are accepted alongside nested objects). +-- +-- /CAUTION/: when given @'Nothing'@ or @'Just' []@, the builder +-- substitutes the wildcard @*@ for the @{name}@ path segment, so the +-- settings override is applied to /every/ data stream on the cluster. +-- Pass an explicit 'DataStreamName' list if you want to scope the +-- update. +-- +-- See +-- . +putDataStreamSettings :: + (ToJSON settings) => + Maybe [DataStreamName] -> + settings -> + BHRequest StatusDependant UpdateDataStreamSettingsResponse +putDataStreamSettings names settings = + putDataStreamSettingsWith names settings defaultUpdateDataStreamSettingsOptions + +-- | 'putDataStreamSettingsWith' is the fully-parameterised form of +-- 'putDataStreamSettings'. Pass +-- 'defaultUpdateDataStreamSettingsOptions' to reproduce a +-- parameterless call. +putDataStreamSettingsWith :: + (ToJSON settings) => + Maybe [DataStreamName] -> + settings -> + UpdateDataStreamSettingsOptions -> + BHRequest StatusDependant UpdateDataStreamSettingsResponse +putDataStreamSettingsWith mNames settings opts = + put @StatusDependant (endpoint `withQueries` updateDataStreamSettingsOptionsParams opts) (encode settings) + where + endpoint = renderPutDataStreamNameEndpoint mNames "_settings" + +-- | Render 'UpdateDataStreamSettingsOptions' as a list of +-- @(key, value)@ query parameters. 'Nothing' fields are omitted; +-- booleans render as @"true"@\/@"false"@. +updateDataStreamSettingsOptionsParams :: UpdateDataStreamSettingsOptions -> [(Text, Maybe Text)] +updateDataStreamSettingsOptionsParams opts = + catMaybes + [ ("dry_run",) . Just . boolQP <$> updateDataStreamSettingsOptionsDryRun opts, + ("master_timeout",) . Just <$> updateDataStreamSettingsOptionsMasterTimeout opts, + ("timeout",) . Just <$> updateDataStreamSettingsOptionsTimeout opts + ] + where + boolQP True = "true" + boolQP False = "false" + +-- | Shared path builder for the GET @/_data_stream\/{name}/_@ +-- endpoints (mappings, settings). When given @'Nothing'@ or +-- @'Just' []@, the @{name}@ segment is omitted entirely (yielding +-- @/_data_stream/_@), matching 'getDataStreamOptions'. Pass +-- an explicit name list (which may include the wildcard +-- @'DataStreamName \"*\"'@) to scope the response. +renderGetDataStreamNameEndpoint :: + Maybe [DataStreamName] -> + Text -> + Endpoint +renderGetDataStreamNameEndpoint mNames suffix = case mNames of + Nothing -> ["_data_stream", suffix] + Just [] -> ["_data_stream", suffix] + Just (first : rest) -> + ["_data_stream", T.intercalate "," (renderName <$> (first : rest)), suffix] + where + renderName (DataStreamName n) = n + +-- | Shared path builder for the PUT @/_data_stream\/{name}/_@ +-- endpoints (mappings, settings). The ES API requires the @{name}@ +-- segment on PUT, so when given @'Nothing'@ or @'Just' []@ the +-- wildcard @*@ is substituted (cluster-wide fan-out) — matching +-- 'updateDataStreamOptions'. Pass an explicit 'DataStreamName' list +-- if you want to scope the update. +renderPutDataStreamNameEndpoint :: + Maybe [DataStreamName] -> + Text -> + Endpoint +renderPutDataStreamNameEndpoint mNames suffix = case mNames of + Nothing -> ["_data_stream", "*", suffix] + Just [] -> ["_data_stream", "*", suffix] + Just (first : rest) -> + ["_data_stream", T.intercalate "," (renderName <$> (first : rest)), suffix] + where + renderName (DataStreamName n) = n + +-- | 'eqlSearch' builds the 'BHRequest' for the EQL +-- @POST /{index}/_eql/search@ endpoint on Elasticsearch 9. The wire +-- format is identical to ES 7.10+\/8.x, so the ES8 request builder is +-- reused verbatim. +-- +-- For more information see +-- . +eqlSearch :: + (FromJSON a) => + IndexName -> + EQLRequest -> + BHRequest StatusDependant (ParsedEsResponse (EQLResult a)) +eqlSearch = Requests8.eqlSearch + +-- | 'eqlSearchWith' is the fully-parameterised form of 'eqlSearch' on +-- Elasticsearch 9. The wire format is identical to ES 7.10+\/8.x, so the +-- ES8 request builder is reused verbatim. See 'Requests8.eqlSearchWith' +-- for the parameter semantics. +-- +-- For more information see +-- . +eqlSearchWith :: + (FromJSON a) => + IndexName -> + EQLSearchOptions -> + EQLRequest -> + BHRequest StatusDependant (ParsedEsResponse (EQLResult a)) +eqlSearchWith = Requests8.eqlSearchWith + +-- | 'getEQLSearch' builds the 'BHRequest' for the async EQL +-- @GET /_eql/search\/{id}@ endpoint on Elasticsearch 9. The wire format +-- is identical to ES 7.10+\/8.x, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +getEQLSearch :: + (FromJSON a) => + EQLSearchId -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse (EQLResult a)) +getEQLSearch = Requests8.getEQLSearch + +-- | 'getEQLStatus' builds the 'BHRequest' for the async EQL status +-- @GET /_eql/search/status\/{id}@ endpoint on Elasticsearch 9. The wire +-- format is identical to ES 7.10+\/8.x, so the ES8 request builder is +-- reused verbatim (which itself delegates to ES7). +-- +-- For more information see +-- . +getEQLStatus :: + EQLSearchId -> + BHRequest StatusDependant EQLStatus +getEQLStatus = Requests8.getEQLStatus + +-- | 'deleteEQLSearch' builds the 'BHRequest' for the EQL +-- @DELETE /_eql/search/{id}@ endpoint on Elasticsearch 9. The wire +-- format is identical to ES 7.10+, so the ES8 request builder is +-- reused verbatim (which itself delegates to ES7). +-- +-- For more information see +-- . +deleteEQLSearch :: + EQLSearchId -> + BHRequest StatusIndependant Acknowledged +deleteEQLSearch = Requests8.deleteEQLSearch + +-- | 'putQueryRuleset' builds the 'BHRequest' for +-- @PUT \/_query_rules\/{ruleset_id}@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +putQueryRuleset :: + RulesetId -> + QueryRuleset -> + BHRequest StatusDependant QueryRulesetPutResponse +putQueryRuleset = Requests8.putQueryRuleset + +-- | 'getQueryRuleset' builds the 'BHRequest' for +-- @GET \/_query_rules\/{ruleset_id}@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +getQueryRuleset :: + RulesetId -> + BHRequest StatusDependant QueryRulesetInfo +getQueryRuleset = Requests8.getQueryRuleset + +-- | 'deleteQueryRuleset' builds the 'BHRequest' for +-- @DELETE \/_query_rules\/{ruleset_id}@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +deleteQueryRuleset :: + RulesetId -> + BHRequest StatusDependant Acknowledged +deleteQueryRuleset = Requests8.deleteQueryRuleset + +-- | 'testQueryRuleset' builds the 'BHRequest' for +-- @POST \/_query_rules\/{ruleset_id}\/_test@ on Elasticsearch 9. The +-- wire format is identical to ES8, so the ES8 request builder is +-- reused verbatim. +-- +-- For more information see +-- . +testQueryRuleset :: + RulesetId -> + QueryRulesetTest -> + BHRequest StatusDependant QueryRulesetTestResponse +testQueryRuleset = Requests8.testQueryRuleset + +-- | 'putSearchApplication' builds the 'BHRequest' for +-- @PUT \/_application\/search_application\/{name}@ on Elasticsearch 9. +-- The wire format is identical to ES8, so the ES8 request builder is +-- reused verbatim. The body is a 'SearchApplication' record whose +-- required @indices@ field names the target indices; see +-- "Database.Bloodhound.ElasticSearch8.Requests" for full semantics. +-- +-- For more information see +-- . +putSearchApplication :: + SearchApplicationName -> + SearchApplication -> + BHRequest StatusDependant SearchApplicationPutResponse +putSearchApplication = Requests8.putSearchApplication + +-- | 'putSearchApplicationWith' is the fully-parameterised form of +-- 'putSearchApplication' on Elasticsearch 9. The wire format is +-- identical to ES8, so the ES8 request builder is reused verbatim. +-- +-- For more information see +-- . +putSearchApplicationWith :: + SearchApplicationName -> + SearchApplicationPutOptions -> + SearchApplication -> + BHRequest StatusDependant SearchApplicationPutResponse +putSearchApplicationWith = Requests8.putSearchApplicationWith + +-- | 'getSearchApplication' builds the 'BHRequest' for +-- @GET \/_application\/search_application\/{name}@ on Elasticsearch 9. +-- The wire format is identical to ES8, so the ES8 request builder is +-- reused verbatim. +-- +-- For more information see +-- . +getSearchApplication :: + SearchApplicationName -> + BHRequest StatusDependant SearchApplicationInfo +getSearchApplication = Requests8.getSearchApplication + +-- | 'deleteSearchApplication' builds the 'BHRequest' for +-- @DELETE \/_application\/search_application\/{name}@ on Elasticsearch 9. +-- The wire format is identical to ES8, so the ES8 request builder is +-- reused verbatim. +-- +-- For more information see +-- . +deleteSearchApplication :: + SearchApplicationName -> + BHRequest StatusDependant Acknowledged +deleteSearchApplication = Requests8.deleteSearchApplication + +-- | 'searchApplication' builds the 'BHRequest' for +-- @POST \/_application\/search_application\/{name}\/_search@ on +-- Elasticsearch 9. The wire format is identical to ES8, so the ES8 +-- request builder is reused verbatim. +-- +-- For more information see +-- . +searchApplication :: + (FromJSON a) => + SearchApplicationName -> + Maybe SearchApplicationSearchParams -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult a)) +searchApplication = Requests8.searchApplication + +-- | 'searchApplicationWith' is the fully-parameterised form of +-- 'searchApplication' on Elasticsearch 9. The wire format is identical to +-- ES8, so the ES8 request builder is reused verbatim. See +-- 'Requests8.searchApplicationWith' for the semantics of the @typed_keys@ +-- query parameter. +-- +-- For more information see +-- . +searchApplicationWith :: + (FromJSON a) => + SearchApplicationName -> + Maybe SearchApplicationSearchParams -> + SearchApplicationOptions -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult a)) +searchApplicationWith = Requests8.searchApplicationWith + +-- | 'listSearchApplications' builds the 'BHRequest' for +-- @GET \/_application\/search_application@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused +-- verbatim. See 'Requests8.listSearchApplications' for semantics. +-- +-- For more information see +-- . +listSearchApplications :: + BHRequest StatusDependant SearchApplicationListResponse +listSearchApplications = Requests8.listSearchApplications + +-- | 'listSearchApplicationsWith' is the fully-parameterised form of +-- 'listSearchApplications' on Elasticsearch 9. The wire format is +-- identical to ES8, so the ES8 request builder is reused verbatim. See +-- 'Requests8.listSearchApplicationsWith' for the semantics of the +-- @q@\/@from@\/@size@ query parameters. +-- +-- For more information see +-- . +listSearchApplicationsWith :: + SearchApplicationListOptions -> + BHRequest StatusDependant SearchApplicationListResponse +listSearchApplicationsWith = Requests8.listSearchApplicationsWith + +-- | 'renderSearchApplicationQuery' builds the 'BHRequest' for +-- @POST \/_application\/search_application\/{name}\/_render_query@ on +-- Elasticsearch 9. The wire format is identical to ES8, so the ES8 +-- request builder is reused verbatim. See +-- 'Requests8.renderSearchApplicationQuery' for semantics. +-- +-- For more information see +-- . +renderSearchApplicationQuery :: + SearchApplicationName -> + Maybe SearchApplicationSearchParams -> + BHRequest StatusDependant Value +renderSearchApplicationQuery = Requests8.renderSearchApplicationQuery + +-- | 'getTermsEnum' builds the 'BHRequest' for the terms enum +-- @GET \/{index}\/_terms_enum@ endpoint on Elasticsearch 9. The wire +-- format is identical to ES 7.10+\/8.x, so the ES8 request builder is +-- reused verbatim (which itself delegates to ES7). +-- +-- For more information see +-- . +getTermsEnum :: + Maybe [IndexName] -> + FieldName -> + Maybe Text -> + BHRequest StatusDependant TermsEnumResponse +getTermsEnum = Requests8.getTermsEnum + +-- | 'getTermsEnumWith' is the fully-parameterised variant of +-- 'getTermsEnum' on Elasticsearch 9. The wire format is identical to +-- ES 7.10+\/8.x, so the ES8 request builder is reused verbatim. +getTermsEnumWith :: + Maybe [IndexName] -> + TermsEnumOptions -> + TermsEnumRequest -> + BHRequest StatusDependant TermsEnumResponse +getTermsEnumWith = Requests8.getTermsEnumWith + +-- | 'getStreamsStatus' builds the 'BHRequest' for +-- @GET /_streams/status@ (Elasticsearch 9.1+, experimental), which +-- returns the enabled state of every named stream (e.g. @logs@, +-- @logs.otel@, @logs.ecs@). The response is decoded into a +-- 'StreamsStatusResponse' (a 'Map' from stream name to 'StreamStatus'). +-- Equivalent to @'getStreamsStatusWith' 'defaultGetStreamsStatusOptions'@ +-- — emits no query string. +-- +-- For more information see +-- . +getStreamsStatus :: + BHRequest StatusDependant StreamsStatusResponse +getStreamsStatus = getStreamsStatusWith defaultGetStreamsStatusOptions + +-- | 'getStreamsStatusWith' is the fully-parameterised variant of +-- 'getStreamsStatus', forwarding the @master_timeout@ query parameter +-- via 'GetStreamsStatusOptions'. +getStreamsStatusWith :: + GetStreamsStatusOptions -> + BHRequest StatusDependant StreamsStatusResponse +getStreamsStatusWith opts = + get @StatusDependant (endpoint `withQueries` getStreamsStatusOptionsParams opts) + where + endpoint = mkEndpoint ["_streams", "status"] + +-- | 'enableStream' builds the 'BHRequest' for +-- @POST /_streams/{name}/_enable@ (Elasticsearch 9.1+, experimental), +-- which enables a named stream. Equivalent to +-- @'enableStreamWith' name 'defaultStreamsActionOptions'@ — emits no +-- query string. Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +enableStream :: + StreamName -> + BHRequest StatusDependant Acknowledged +enableStream name = enableStreamWith name defaultStreamsActionOptions + +-- | 'enableStreamWith' is the fully-parameterised variant of +-- 'enableStream', forwarding the @master_timeout@ \/ @timeout@ query +-- parameters via 'StreamsActionOptions'. +enableStreamWith :: + StreamName -> + StreamsActionOptions -> + BHRequest StatusDependant Acknowledged +enableStreamWith name opts = + post @StatusDependant endpoint emptyBody + where + endpoint = + mkEndpoint ["_streams", unStreamName name, "_enable"] + `withQueries` streamsActionOptionsParams opts + +-- | 'disableStream' builds the 'BHRequest' for +-- @POST /_streams/{name}/_disable@ (Elasticsearch 9.1+, experimental), +-- which disables a named stream. Equivalent to +-- @'disableStreamWith' name 'defaultStreamsActionOptions'@. Returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +disableStream :: + StreamName -> + BHRequest StatusDependant Acknowledged +disableStream name = disableStreamWith name defaultStreamsActionOptions + +-- | 'disableStreamWith' is the fully-parameterised variant of +-- 'disableStream', forwarding the @master_timeout@ \/ @timeout@ query +-- parameters via 'StreamsActionOptions'. +disableStreamWith :: + StreamName -> + StreamsActionOptions -> + BHRequest StatusDependant Acknowledged +disableStreamWith name opts = + post @StatusDependant endpoint emptyBody + where + endpoint = + mkEndpoint ["_streams", unStreamName name, "_disable"] + `withQueries` streamsActionOptionsParams opts + +-- | 'downsampleIndex' builds the 'BHRequest' for +-- @POST /{index}/_downsample/{target_index}@ (Elasticsearch 9.x), which +-- rolls up an existing time-series index into a new, coarser-grained +-- index at the supplied 'FixedInterval'. The @targetIndex@ is the name +-- of the new downsampled index and is a mandatory path segment. +-- Equivalent to +-- @'downsampleIndexWith' index targetIndex body 'defaultDownsampleOptions'@ +-- — emits no query string. Returns 'DownsampleResponse' on success. +-- +-- For more information see +-- . +downsampleIndex :: + IndexName -> + IndexName -> + DownsampleRequest -> + BHRequest StatusDependant DownsampleResponse +downsampleIndex index targetIndex body = + downsampleIndexWith index targetIndex body defaultDownsampleOptions + +-- | 'downsampleIndexWith' is the fully-parameterised variant of +-- 'downsampleIndex', forwarding the @master_timeout@ \/ @timeout@ query +-- parameters via 'DownsampleOptions'. +downsampleIndexWith :: + IndexName -> + IndexName -> + DownsampleRequest -> + DownsampleOptions -> + BHRequest StatusDependant DownsampleResponse +downsampleIndexWith index targetIndex body opts = + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint [unIndexName index, "_downsample", unIndexName targetIndex] + `withQueries` downsampleOptionsParams opts + +-- | 'getGeoIpStats' builds the 'BHRequest' for +-- @GET /_ingest/geoip/stats@, which returns GeoIP downloader +-- statistics as a 'GeoIpStatsResponse' (aggregate counts plus per-node +-- cached database files). +-- +-- For more information see +-- . +getGeoIpStats :: + BHRequest StatusDependant GeoIpStatsResponse +getGeoIpStats = + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_ingest", "geoip", "stats"] + +-- | 'getGeoIpDatabases' builds the 'BHRequest' for +-- @GET /_ingest/geoip/database@ (no id), returning every GeoIP database +-- configuration as a 'GeoIpDatabasesResponse'. For a single id, use +-- 'getGeoIpDatabase'. +-- +-- For more information see +-- . +getGeoIpDatabases :: + BHRequest StatusDependant GeoIpDatabasesResponse +getGeoIpDatabases = + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_ingest", "geoip", "database"] + +-- | 'getGeoIpDatabase' builds the 'BHRequest' for +-- @GET /_ingest/geoip/database/{id}@. The 'GeoIpDatabaseId' may be a +-- single id, a comma-separated list, or the wildcard @"*"@ (the latter +-- is equivalent to 'getGeoIpDatabases'). +-- +-- For more information see +-- . +getGeoIpDatabase :: + GeoIpDatabaseId -> + BHRequest StatusDependant GeoIpDatabasesResponse +getGeoIpDatabase dbId = + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_ingest", "geoip", "database", unGeoIpDatabaseId dbId] + +-- | 'putGeoIpDatabase' builds the 'BHRequest' for +-- @PUT /_ingest/geoip/database/{id}@, creating or updating a GeoIP +-- database configuration. The 'GeoIpDatabasePutBody' carries the +-- required @maxmind@ provider. Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +putGeoIpDatabase :: + GeoIpDatabaseId -> + GeoIpDatabasePutBody -> + BHRequest StatusDependant Acknowledged +putGeoIpDatabase dbId body = + put @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_ingest", "geoip", "database", unGeoIpDatabaseId dbId] + +-- | 'deleteGeoIpDatabase' builds the 'BHRequest' for +-- @DELETE /_ingest/geoip/database/{id}@. The 'GeoIpDatabaseId' may be a +-- single id, a comma-separated list, or the wildcard @"*"@. Returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteGeoIpDatabase :: + GeoIpDatabaseId -> + BHRequest StatusDependant Acknowledged +deleteGeoIpDatabase dbId = + delete endpoint + where + endpoint = mkEndpoint ["_ingest", "geoip", "database", unGeoIpDatabaseId dbId] + +-- | 'getIpLocationDatabases' builds the 'BHRequest' for +-- @GET /_ingest/ip_location/database@ (no id), returning every +-- IP-location database configuration. +-- +-- For more information see +-- . +getIpLocationDatabases :: + BHRequest StatusDependant GeoIpDatabasesResponse +getIpLocationDatabases = + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_ingest", "ip_location", "database"] + +-- | 'getIpLocationDatabase' builds the 'BHRequest' for +-- @GET /_ingest/ip_location/database/{id}@. The 'GeoIpDatabaseId' may +-- be a single id, a comma-separated list, or the wildcard @"*"@. +-- +-- For more information see +-- . +getIpLocationDatabase :: + GeoIpDatabaseId -> + BHRequest StatusDependant GeoIpDatabasesResponse +getIpLocationDatabase dbId = + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_ingest", "ip_location", "database", unGeoIpDatabaseId dbId] + +-- | 'putIpLocationDatabase' builds the 'BHRequest' for +-- @PUT /_ingest/ip_location/database/{id}@, creating or updating an +-- IP-location database configuration. The 'IpLocationDatabasePutBody' +-- should carry exactly one of @maxmind@ or @ipinfo@. Returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +putIpLocationDatabase :: + GeoIpDatabaseId -> + IpLocationDatabasePutBody -> + BHRequest StatusDependant Acknowledged +putIpLocationDatabase dbId body = + put @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_ingest", "ip_location", "database", unGeoIpDatabaseId dbId] + +-- | 'deleteIpLocationDatabase' builds the 'BHRequest' for +-- @DELETE /_ingest/ip_location/database/{id}@. The 'GeoIpDatabaseId' +-- may be a single id, a comma-separated list, or the wildcard @"*"@. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteIpLocationDatabase :: + GeoIpDatabaseId -> + BHRequest StatusDependant Acknowledged +deleteIpLocationDatabase dbId = + delete endpoint + where + endpoint = mkEndpoint ["_ingest", "ip_location", "database", unGeoIpDatabaseId dbId] + +-- | 'simulateIngest' builds the 'BHRequest' for +-- @POST /_ingest/_simulate@ (simulate-ingest v2), which resolves +-- templates and mappings against the supplied documents. Equivalent to +-- @'simulateIngestWith' body 'defaultSimulateIngestOptions'@. +-- +-- For more information see +-- . +simulateIngest :: + SimulateIngestRequest -> + BHRequest StatusDependant SimulateIngestResponse +simulateIngest body = + simulateIngestWith body defaultSimulateIngestOptions + +-- | 'simulateIngestWith' is the fully-parameterised variant of +-- 'simulateIngest', forwarding the @pipeline@ and @merge_type@ query +-- parameters via 'SimulateIngestOptions'. +simulateIngestWith :: + SimulateIngestRequest -> + SimulateIngestOptions -> + BHRequest StatusDependant SimulateIngestResponse +simulateIngestWith body opts = + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint ["_ingest", "_simulate"] + `withQueries` simulateIngestOptionsParams opts + +-- | 'simulateIngestIndex' builds the 'BHRequest' for the index-scoped +-- @POST /_ingest/{index}/_simulate@. Equivalent to +-- @'simulateIngestIndexWith' indexName body 'defaultSimulateIngestOptions'@. +simulateIngestIndex :: + IndexName -> + SimulateIngestRequest -> + BHRequest StatusDependant SimulateIngestResponse +simulateIngestIndex indexName body = + simulateIngestIndexWith indexName body defaultSimulateIngestOptions + +-- | 'simulateIngestIndexWith' is the fully-parameterised variant of +-- 'simulateIngestIndex', forwarding the @pipeline@ and @merge_type@ +-- query parameters via 'SimulateIngestOptions'. +simulateIngestIndexWith :: + IndexName -> + SimulateIngestRequest -> + SimulateIngestOptions -> + BHRequest StatusDependant SimulateIngestResponse +simulateIngestIndexWith indexName body opts = + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint ["_ingest", unIndexName indexName, "_simulate"] + `withQueries` simulateIngestOptionsParams opts + +-- | 'simulateIngestGet' is the GET-form counterpart of 'simulateIngest', +-- building the 'BHRequest' for @GET /_ingest/_simulate@ (simulate-ingest +-- v2). The Elasticsearch operation documents both GET and POST for this +-- path; the two are semantically identical — the request body is sent +-- with the GET (see 'getWithBody'). POST remains the canonical form, so +-- prefer 'simulateIngest' unless a GET is specifically required. +-- Equivalent to @'simulateIngestWithGet' body 'defaultSimulateIngestOptions'@. +-- +-- For more information see +-- . +simulateIngestGet :: + SimulateIngestRequest -> + BHRequest StatusDependant SimulateIngestResponse +simulateIngestGet body = + simulateIngestWithGet body defaultSimulateIngestOptions + +-- | 'simulateIngestWithGet' is the fully-parameterised GET-form variant +-- of 'simulateIngestGet', forwarding the @pipeline@ and @merge_type@ +-- query parameters via 'SimulateIngestOptions'. +simulateIngestWithGet :: + SimulateIngestRequest -> + SimulateIngestOptions -> + BHRequest StatusDependant SimulateIngestResponse +simulateIngestWithGet body opts = + getWithBody @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint ["_ingest", "_simulate"] + `withQueries` simulateIngestOptionsParams opts + +-- | 'simulateIngestIndexGet' is the GET-form counterpart of +-- 'simulateIngestIndex', building the 'BHRequest' for the index-scoped +-- @GET /_ingest/{index}/_simulate@. See 'simulateIngestGet' for the +-- GET/POST equivalence note. Equivalent to +-- @'simulateIngestIndexWithGet' indexName body 'defaultSimulateIngestOptions'@. +simulateIngestIndexGet :: + IndexName -> + SimulateIngestRequest -> + BHRequest StatusDependant SimulateIngestResponse +simulateIngestIndexGet indexName body = + simulateIngestIndexWithGet indexName body defaultSimulateIngestOptions + +-- | 'simulateIngestIndexWithGet' is the fully-parameterised GET-form +-- variant of 'simulateIngestIndexGet', forwarding the @pipeline@ and +-- @merge_type@ query parameters via 'SimulateIngestOptions'. +simulateIngestIndexWithGet :: + IndexName -> + SimulateIngestRequest -> + SimulateIngestOptions -> + BHRequest StatusDependant SimulateIngestResponse +simulateIngestIndexWithGet indexName body opts = + getWithBody @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint ["_ingest", unIndexName indexName, "_simulate"] + `withQueries` simulateIngestOptionsParams opts + +-- ---------------------------------------------------------------------- +-- Resolve cluster / Health report / Features (bloodhound-d5kl) +-- ---------------------------------------------------------------------- + +-- | 'resolveCluster' builds the 'BHRequest' for the +-- @GET /_resolve/cluster[\/{name}]@ endpoint (indices-resolve-cluster), +-- new in Elasticsearch 9. It resolves the cluster-alias component of +-- index expressions — including @\:\@ remote-cluster +-- references — into the connected remote clusters the caller can search. +-- +-- * @'Nothing'@ → @GET /_resolve/cluster@, which returns information +-- about every configured remote cluster without doing index matching. +-- * @'Just' pats@ → @GET /_resolve/cluster\/{name}@, which additionally +-- reports, per cluster, whether @pats@ matches any index there. The +-- patterns are joined with @,@ into a single path segment (matching +-- the server's comma-separated multi-target syntax). +-- +-- Equivalent to @'resolveClusterWith' 'defaultResolveClusterOptions'@. +-- Use the @With@ variant to pass @expand_wildcards@, +-- @ignore_unavailable@, @allow_no_indices@ or @timeout@. +-- +-- For more information see +-- . +resolveCluster :: + Maybe [Text] -> + BHRequest StatusDependant ResolveClusterResponse +resolveCluster = resolveClusterWith defaultResolveClusterOptions + +-- | 'resolveClusterWith' is the fully-parameterised form of +-- 'resolveCluster'. See 'ResolveClusterOptions' for the parameter +-- semantics; pass 'defaultResolveClusterOptions' to emit a request +-- byte-for-byte identical to 'resolveCluster'. +resolveClusterWith :: + ResolveClusterOptions -> + Maybe [Text] -> + BHRequest StatusDependant ResolveClusterResponse +resolveClusterWith opts mPatterns = + get @StatusDependant (endpoint `withQueries` resolveClusterOptionsParams opts) + where + endpoint = case mPatterns of + Nothing -> mkEndpoint ["_resolve", "cluster"] + Just patterns -> mkEndpoint ["_resolve", "cluster", T.intercalate "," patterns] + +-- | 'getHealthReport' builds the 'BHRequest' for the +-- @GET /_health_report[\/{feature}]@ endpoint (health-report), new in +-- Elasticsearch 9. It returns a high-level health summary of the cluster +-- broken down by indicator (@master_is_stable@, @disk@, @ilm@, ...). +-- +-- * @'Nothing'@ → @GET /_health_report@ reports every indicator. +-- * @'Just' feats@ → @GET /_health_report\/{feature}@ restricts the +-- report to the named indicators. The features are joined with @,@. +-- +-- Equivalent to @'getHealthReportWith' 'defaultHealthReportOptions'@. +-- Use the @With@ variant to pass @verbose@, @size@ or @timeout@. +-- +-- For more information see +-- . +getHealthReport :: + Maybe [Text] -> + BHRequest StatusDependant HealthReport +getHealthReport = getHealthReportWith defaultHealthReportOptions + +-- | 'getHealthReportWith' is the fully-parameterised form of +-- 'getHealthReport'. See 'HealthReportOptions' for the parameter +-- semantics; pass 'defaultHealthReportOptions' to emit a request +-- byte-for-byte identical to 'getHealthReport'. +getHealthReportWith :: + HealthReportOptions -> + Maybe [Text] -> + BHRequest StatusDependant HealthReport +getHealthReportWith opts mFeatures = + get @StatusDependant (endpoint `withQueries` healthReportOptionsParams opts) + where + endpoint = case mFeatures of + Nothing -> mkEndpoint ["_health_report"] + Just features -> mkEndpoint ["_health_report", T.intercalate "," features] + +-- | 'getFeatures' builds the 'BHRequest' for the @GET /_features@ +-- endpoint (features-get-features). It returns the list of installed +-- features, each as a @name@ + @description@ pair. +-- +-- Equivalent to @'getFeaturesWith' 'defaultFeaturesOptions'@. +-- +-- For more information see +-- . +getFeatures :: + BHRequest StatusDependant FeaturesResponse +getFeatures = getFeaturesWith defaultFeaturesOptions + +-- | 'getFeaturesWith' is the fully-parameterised form of 'getFeatures'. +-- See 'FeaturesOptions' for the parameter semantics; pass +-- 'defaultFeaturesOptions' to emit a request byte-for-byte identical to +-- 'getFeatures'. +getFeaturesWith :: + FeaturesOptions -> + BHRequest StatusDependant FeaturesResponse +getFeaturesWith opts = + get @StatusDependant (endpoint `withQueries` featuresOptionsParams opts) + where + endpoint = mkEndpoint ["_features"] + +-- | 'resetFeatures' builds the 'BHRequest' for the +-- @POST /_features/_reset@ endpoint (features-reset-features). It resets +-- the state of every feature. The response carries the per-feature +-- outcome; because the documented example differs from the schema, +-- 'ResetFeaturesItem' tolerates both shapes. +-- +-- This endpoint is /experimental and mutating/ — it is intended for +-- development/testing clusters, not production. Equivalent to +-- @'resetFeaturesWith' 'defaultFeaturesOptions'@. +-- +-- For more information see +-- . +resetFeatures :: + BHRequest StatusDependant ResetFeaturesResponse +resetFeatures = resetFeaturesWith defaultFeaturesOptions + +-- | 'resetFeaturesWith' is the fully-parameterised form of 'resetFeatures'. +-- See 'FeaturesOptions' for the parameter semantics; pass +-- 'defaultFeaturesOptions' to emit a request byte-for-byte identical to +-- 'resetFeatures'. +resetFeaturesWith :: + FeaturesOptions -> + BHRequest StatusDependant ResetFeaturesResponse +resetFeaturesWith opts = + post @StatusDependant (endpoint `withQueries` featuresOptionsParams opts) emptyBody + where + endpoint = mkEndpoint ["_features", "_reset"] + +------------------------------------------------------------------------------ +-- Migration reindex (re-uses the ES8 builders; identical wire format) +------------------------------------------------------------------------------ + +-- | 'migrateReindex' builds the 'BHRequest' for +-- @POST /_migration/reindex@ on Elasticsearch 9. The wire format is +-- identical to ES8 (the endpoint shipped in 8.18.0), so the ES8 request +-- builder is reused verbatim. +-- +-- For more information see +-- . +migrateReindex :: + MigrateReindexRequest -> + BHRequest StatusDependant Acknowledged +migrateReindex = Requests8.migrateReindex + +-- | 'cancelMigrateReindex' builds the 'BHRequest' for +-- @POST /_migration/reindex/{index}/_cancel@ on Elasticsearch 9. The +-- wire format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +cancelMigrateReindex :: + NonEmpty IndexName -> + BHRequest StatusDependant Acknowledged +cancelMigrateReindex = Requests8.cancelMigrateReindex + +-- | 'getMigrateReindexStatus' builds the 'BHRequest' for +-- @GET /_migration/reindex/{index}/_status@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +getMigrateReindexStatus :: + NonEmpty IndexName -> + BHRequest StatusDependant MigrateReindexStatus +getMigrateReindexStatus = Requests8.getMigrateReindexStatus + +-- | 'createIndexFrom' builds the 'BHRequest' for +-- @POST /_create_from/{source}/{dest}@ on Elasticsearch 9. The wire +-- format is identical to ES8, so the ES8 request builder is reused +-- verbatim. +-- +-- For more information see +-- . +createIndexFrom :: + IndexName -> + IndexName -> + BHRequest StatusDependant CreateIndexFromResponse +createIndexFrom = Requests8.createIndexFrom + +-- | 'createIndexFromWith' is the fully-parameterised variant of +-- 'createIndexFrom' on Elasticsearch 9. The wire format is identical to +-- ES8, so the ES8 request builder is reused verbatim. +createIndexFromWith :: + IndexName -> + IndexName -> + Maybe CreateIndexFromBody -> + BHRequest StatusDependant CreateIndexFromResponse +createIndexFromWith = Requests8.createIndexFromWith + +-- ========================================================================= +-- ML data frame analytics (X-Pack) +-- ========================================================================= + +-- | 'putMlDataFrameAnalytics' builds the 'BHRequest' for +-- @PUT /_ml/data_frame/analytics/{id}@ (ml-put-data-frame-analytics), +-- creating a data frame analytics job. Equivalent to +-- @'putMlDataFrameAnalyticsWith' id body 'defaultMlDataFrameAnalyticsOptions'@. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +putMlDataFrameAnalytics :: + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsPutBody -> + BHRequest StatusDependant Acknowledged +putMlDataFrameAnalytics id' body = + putMlDataFrameAnalyticsWith id' body defaultMlDataFrameAnalyticsOptions + +-- | 'putMlDataFrameAnalyticsWith' is the fully-parameterised variant of +-- 'putMlDataFrameAnalytics', forwarding the query parameters via +-- 'MlDataFrameAnalyticsOptions' (e.g. @allow_lazy_start@). +putMlDataFrameAnalyticsWith :: + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsPutBody -> + MlDataFrameAnalyticsOptions -> + BHRequest StatusDependant Acknowledged +putMlDataFrameAnalyticsWith id' body opts = + put @StatusDependant (endpoint `withQueries` mlDataFrameAnalyticsOptionsParams opts) (encode body) + where + endpoint = + mkEndpoint ["_ml", "data_frame", "analytics", unMlDataFrameAnalyticsId id'] + +-- | 'getMlDataFrameAnalytics' builds the 'BHRequest' for +-- @GET /_ml/data_frame/analytics[/{id}]@ (ml-get-data-frame-analytics). +-- Pass 'Nothing' for the id to list every job, or @'Just' id@ for a +-- single job (the id may also be a comma-separated list or wildcard +-- @"*"@). Equivalent to +-- @'getMlDataFrameAnalyticsWith' mid 'defaultMlDataFrameAnalyticsOptions'@. +-- +-- For more information see +-- . +getMlDataFrameAnalytics :: + Maybe MlDataFrameAnalyticsId -> + BHRequest StatusDependant MlDataFrameAnalyticsGetResponse +getMlDataFrameAnalytics mid = + getMlDataFrameAnalyticsWith mid defaultMlDataFrameAnalyticsOptions + +-- | 'getMlDataFrameAnalyticsWith' is the fully-parameterised variant of +-- 'getMlDataFrameAnalytics', forwarding the @from@ \/ @size@ query +-- parameters via 'MlDataFrameAnalyticsOptions'. +getMlDataFrameAnalyticsWith :: + Maybe MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsOptions -> + BHRequest StatusDependant MlDataFrameAnalyticsGetResponse +getMlDataFrameAnalyticsWith mid opts = + get @StatusDependant (endpoint `withQueries` mlDataFrameAnalyticsOptionsParams opts) + where + endpoint = + mkEndpoint $ + ["_ml", "data_frame", "analytics"] + ++ maybe [] (\(MlDataFrameAnalyticsId x) -> [x]) mid + +-- | 'updateMlDataFrameAnalytics' builds the 'BHRequest' for +-- @POST /_ml/data_frame/analytics/{id}/_update@ +-- (ml-update-data-frame-analytics). Equivalent to +-- @'updateMlDataFrameAnalyticsWith' id body 'defaultMlDataFrameAnalyticsOptions'@. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +updateMlDataFrameAnalytics :: + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsUpdateBody -> + BHRequest StatusDependant Acknowledged +updateMlDataFrameAnalytics id' body = + updateMlDataFrameAnalyticsWith id' body defaultMlDataFrameAnalyticsOptions + +-- | 'updateMlDataFrameAnalyticsWith' is the fully-parameterised variant +-- of 'updateMlDataFrameAnalytics'. +updateMlDataFrameAnalyticsWith :: + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsUpdateBody -> + MlDataFrameAnalyticsOptions -> + BHRequest StatusDependant Acknowledged +updateMlDataFrameAnalyticsWith id' body opts = + post @StatusDependant (endpoint `withQueries` mlDataFrameAnalyticsOptionsParams opts) (encode body) + where + endpoint = + mkEndpoint ["_ml", "data_frame", "analytics", unMlDataFrameAnalyticsId id', "_update"] + +-- | 'deleteMlDataFrameAnalytics' builds the 'BHRequest' for +-- @DELETE /_ml/data_frame/analytics/{id}@ (ml-delete-data-frame-analytics). +-- Equivalent to +-- @'deleteMlDataFrameAnalyticsWith' id 'defaultMlDataFrameAnalyticsOptions'@. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteMlDataFrameAnalytics :: + MlDataFrameAnalyticsId -> + BHRequest StatusDependant Acknowledged +deleteMlDataFrameAnalytics id' = + deleteMlDataFrameAnalyticsWith id' defaultMlDataFrameAnalyticsOptions + +-- | 'deleteMlDataFrameAnalyticsWith' is the fully-parameterised variant +-- of 'deleteMlDataFrameAnalytics', forwarding the @force@ query +-- parameter via 'MlDataFrameAnalyticsOptions'. +deleteMlDataFrameAnalyticsWith :: + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsOptions -> + BHRequest StatusDependant Acknowledged +deleteMlDataFrameAnalyticsWith id' opts = + delete (endpoint `withQueries` mlDataFrameAnalyticsOptionsParams opts) + where + endpoint = + mkEndpoint ["_ml", "data_frame", "analytics", unMlDataFrameAnalyticsId id'] + +-- | 'startMlDataFrameAnalytics' builds the 'BHRequest' for +-- @POST /_ml/data_frame/analytics/{id}/_start@ +-- (ml-start-data-frame-analytics). Equivalent to +-- @'startMlDataFrameAnalyticsWith' id 'defaultMlDataFrameAnalyticsOptions'@. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +startMlDataFrameAnalytics :: + MlDataFrameAnalyticsId -> + BHRequest StatusDependant Acknowledged +startMlDataFrameAnalytics id' = + startMlDataFrameAnalyticsWith id' defaultMlDataFrameAnalyticsOptions + +-- | 'startMlDataFrameAnalyticsWith' is the fully-parameterised variant of +-- 'startMlDataFrameAnalytics'. +startMlDataFrameAnalyticsWith :: + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsOptions -> + BHRequest StatusDependant Acknowledged +startMlDataFrameAnalyticsWith id' opts = + post @StatusDependant (endpoint `withQueries` mlDataFrameAnalyticsOptionsParams opts) emptyBody + where + endpoint = + mkEndpoint ["_ml", "data_frame", "analytics", unMlDataFrameAnalyticsId id', "_start"] + +-- | 'stopMlDataFrameAnalytics' builds the 'BHRequest' for +-- @POST /_ml/data_frame/analytics/{id}/_stop@ +-- (ml-stop-data-frame-analytics). Equivalent to +-- @'stopMlDataFrameAnalyticsWith' id 'defaultMlDataFrameAnalyticsOptions'@. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +stopMlDataFrameAnalytics :: + MlDataFrameAnalyticsId -> + BHRequest StatusDependant Acknowledged +stopMlDataFrameAnalytics id' = + stopMlDataFrameAnalyticsWith id' defaultMlDataFrameAnalyticsOptions + +-- | 'stopMlDataFrameAnalyticsWith' is the fully-parameterised variant of +-- 'stopMlDataFrameAnalytics', forwarding the @force@ \/ @timeout@ query +-- parameters via 'MlDataFrameAnalyticsOptions'. +stopMlDataFrameAnalyticsWith :: + MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsOptions -> + BHRequest StatusDependant Acknowledged +stopMlDataFrameAnalyticsWith id' opts = + post @StatusDependant (endpoint `withQueries` mlDataFrameAnalyticsOptionsParams opts) emptyBody + where + endpoint = + mkEndpoint ["_ml", "data_frame", "analytics", unMlDataFrameAnalyticsId id', "_stop"] + +-- | 'getMlDataFrameAnalyticsStats' builds the 'BHRequest' for +-- @GET /_ml/data_frame/analytics/{id}/_stats@ +-- (ml-get-data-frame-analytics-stats). Pass 'Nothing' for the id to +-- fetch stats for every job. Equivalent to +-- @'getMlDataFrameAnalyticsStatsWith' mid 'defaultMlDataFrameAnalyticsOptions'@. +-- +-- For more information see +-- . +getMlDataFrameAnalyticsStats :: + Maybe MlDataFrameAnalyticsId -> + BHRequest StatusDependant MlDataFrameAnalyticsStatsResponse +getMlDataFrameAnalyticsStats mid = + getMlDataFrameAnalyticsStatsWith mid defaultMlDataFrameAnalyticsOptions + +-- | 'getMlDataFrameAnalyticsStatsWith' is the fully-parameterised variant +-- of 'getMlDataFrameAnalyticsStats', forwarding the @verbose@ query +-- parameter via 'MlDataFrameAnalyticsOptions'. +getMlDataFrameAnalyticsStatsWith :: + Maybe MlDataFrameAnalyticsId -> + MlDataFrameAnalyticsOptions -> + BHRequest StatusDependant MlDataFrameAnalyticsStatsResponse +getMlDataFrameAnalyticsStatsWith mid opts = + get @StatusDependant (endpoint `withQueries` mlDataFrameAnalyticsOptionsParams opts) + where + endpoint = + mkEndpoint $ + ["_ml", "data_frame", "analytics"] + ++ maybe [] (\(MlDataFrameAnalyticsId x) -> [x]) mid + ++ ["_stats"] + +-- | 'previewMlDataFrameAnalytics' builds the 'BHRequest' for +-- @POST /_ml/data_frame/analytics/_preview@ (ml-preview-data-frame-analytics), +-- which simulates a data frame analytics config against a source index +-- and returns the would-be destination rows. The +-- 'MlDataFrameAnalyticsPreviewRequest' carries the config (or an +-- existing-id reference) as an opaque 'Value'. +-- +-- For more information see +-- . +previewMlDataFrameAnalytics :: + MlDataFrameAnalyticsPreviewRequest -> + BHRequest StatusDependant MlDataFrameAnalyticsPreviewResponse +previewMlDataFrameAnalytics req = + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_ml", "data_frame", "analytics", "_preview"] + +-- ========================================================================= +-- ML trained models (X-Pack) +-- ========================================================================= + +-- | 'putMlTrainedModel' builds the 'BHRequest' for +-- @PUT /_ml/trained_models/{model_id}@ (ml-put-trained-model), creating a +-- trained model. Equivalent to +-- @'putMlTrainedModelWith' id body 'defaultMlTrainedModelOptions'@. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +putMlTrainedModel :: + MlTrainedModelId -> + MlTrainedModelPutBody -> + BHRequest StatusDependant Acknowledged +putMlTrainedModel id' body = + putMlTrainedModelWith id' body defaultMlTrainedModelOptions + +-- | 'putMlTrainedModelWith' is the fully-parameterised variant of +-- 'putMlTrainedModel'. +putMlTrainedModelWith :: + MlTrainedModelId -> + MlTrainedModelPutBody -> + MlTrainedModelOptions -> + BHRequest StatusDependant Acknowledged +putMlTrainedModelWith id' body opts = + put @StatusDependant (endpoint `withQueries` mlTrainedModelOptionsParams opts) (encode body) + where + endpoint = + mkEndpoint ["_ml", "trained_models", unMlTrainedModelId id'] + +-- | 'getMlTrainedModels' builds the 'BHRequest' for +-- @GET /_ml/trained_models[/{model_id}]@ (ml-get-trained-models). Pass +-- 'Nothing' to list every model, or @'Just' id@ for one (the id may be a +-- comma-separated list or wildcard @"*"@). Equivalent to +-- @'getMlTrainedModelsWith' mid 'defaultMlTrainedModelOptions'@. +-- +-- For more information see +-- . +getMlTrainedModels :: + Maybe MlTrainedModelId -> + BHRequest StatusDependant MlTrainedModelsResponse +getMlTrainedModels mid = + getMlTrainedModelsWith mid defaultMlTrainedModelOptions + +-- | 'getMlTrainedModelsWith' is the fully-parameterised variant of +-- 'getMlTrainedModels', forwarding the @from@ \/ @size@ \/ @include_definition@ +-- query parameters via 'MlTrainedModelOptions'. +getMlTrainedModelsWith :: + Maybe MlTrainedModelId -> + MlTrainedModelOptions -> + BHRequest StatusDependant MlTrainedModelsResponse +getMlTrainedModelsWith mid opts = + get @StatusDependant (endpoint `withQueries` mlTrainedModelOptionsParams opts) + where + endpoint = + mkEndpoint $ + ["_ml", "trained_models"] + ++ maybe [] (\(MlTrainedModelId x) -> [x]) mid + +-- | 'getMlTrainedModelDefinition' builds the 'BHRequest' for +-- @GET /_ml/trained_models/{model_id}/definition@ +-- (ml-get-trained-model-definition). Equivalent to +-- @'getMlTrainedModelDefinitionWith' id 'defaultMlTrainedModelOptions'@. +-- +-- For more information see +-- . +getMlTrainedModelDefinition :: + MlTrainedModelId -> + BHRequest StatusDependant MlTrainedModelDefinition +getMlTrainedModelDefinition id' = + getMlTrainedModelDefinitionWith id' defaultMlTrainedModelOptions + +-- | 'getMlTrainedModelDefinitionWith' is the fully-parameterised variant +-- of 'getMlTrainedModelDefinition', forwarding the @decompress_definition@ +-- query parameter via 'MlTrainedModelOptions'. +getMlTrainedModelDefinitionWith :: + MlTrainedModelId -> + MlTrainedModelOptions -> + BHRequest StatusDependant MlTrainedModelDefinition +getMlTrainedModelDefinitionWith id' opts = + get @StatusDependant (endpoint `withQueries` mlTrainedModelOptionsParams opts) + where + endpoint = + mkEndpoint ["_ml", "trained_models", unMlTrainedModelId id', "definition"] + +-- | 'updateMlTrainedModel' builds the 'BHRequest' for +-- @POST /_ml/trained_models/{model_id}/_update@ +-- (ml-update-trained-model). Equivalent to +-- @'updateMlTrainedModelWith' id body 'defaultMlTrainedModelOptions'@. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +updateMlTrainedModel :: + MlTrainedModelId -> + MlTrainedModelUpdateBody -> + BHRequest StatusDependant Acknowledged +updateMlTrainedModel id' body = + updateMlTrainedModelWith id' body defaultMlTrainedModelOptions + +-- | 'updateMlTrainedModelWith' is the fully-parameterised variant of +-- 'updateMlTrainedModel'. +updateMlTrainedModelWith :: + MlTrainedModelId -> + MlTrainedModelUpdateBody -> + MlTrainedModelOptions -> + BHRequest StatusDependant Acknowledged +updateMlTrainedModelWith id' body opts = + post @StatusDependant (endpoint `withQueries` mlTrainedModelOptionsParams opts) (encode body) + where + endpoint = + mkEndpoint ["_ml", "trained_models", unMlTrainedModelId id', "_update"] + +-- | 'deleteMlTrainedModel' builds the 'BHRequest' for +-- @DELETE /_ml/trained_models/{model_id}@ (ml-delete-trained-model). +-- Equivalent to @'deleteMlTrainedModelWith' id 'defaultMlTrainedModelOptions'@. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteMlTrainedModel :: + MlTrainedModelId -> + BHRequest StatusDependant Acknowledged +deleteMlTrainedModel id' = + deleteMlTrainedModelWith id' defaultMlTrainedModelOptions + +-- | 'deleteMlTrainedModelWith' is the fully-parameterised variant of +-- 'deleteMlTrainedModel'. +deleteMlTrainedModelWith :: + MlTrainedModelId -> + MlTrainedModelOptions -> + BHRequest StatusDependant Acknowledged +deleteMlTrainedModelWith id' opts = + delete (endpoint `withQueries` mlTrainedModelOptionsParams opts) + where + endpoint = + mkEndpoint ["_ml", "trained_models", unMlTrainedModelId id'] + +-- | 'deployMlTrainedModel' builds the 'BHRequest' for +-- @POST /_ml/trained_models/{model_id}/deployment/_deploy@ +-- (ml-deploy-trained-model). Equivalent to +-- @'deployMlTrainedModelWith' id 'defaultMlTrainedModelOptions'@. Returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +deployMlTrainedModel :: + MlTrainedModelId -> + BHRequest StatusDependant Acknowledged +deployMlTrainedModel id' = + deployMlTrainedModelWith id' defaultMlTrainedModelOptions + +-- | 'deployMlTrainedModelWith' is the fully-parameterised variant of +-- 'deployMlTrainedModel', forwarding the @wait_for_completion@ \/ +-- @priority@ \/ @threads@ query parameters via 'MlTrainedModelOptions'. +deployMlTrainedModelWith :: + MlTrainedModelId -> + MlTrainedModelOptions -> + BHRequest StatusDependant Acknowledged +deployMlTrainedModelWith id' opts = + post @StatusDependant (endpoint `withQueries` mlTrainedModelOptionsParams opts) emptyBody + where + endpoint = + mkEndpoint ["_ml", "trained_models", unMlTrainedModelId id', "deployment", "_deploy"] + +-- | 'undeployMlTrainedModel' builds the 'BHRequest' for +-- @POST /_ml/trained_models/{model_id}/deployment/_undeploy@ +-- (ml-undeploy-trained-model). Equivalent to +-- @'undeployMlTrainedModelWith' id 'defaultMlTrainedModelOptions'@. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +undeployMlTrainedModel :: + MlTrainedModelId -> + BHRequest StatusDependant Acknowledged +undeployMlTrainedModel id' = + undeployMlTrainedModelWith id' defaultMlTrainedModelOptions + +-- | 'undeployMlTrainedModelWith' is the fully-parameterised variant of +-- 'undeployMlTrainedModel', forwarding the @force@ query parameter via +-- 'MlTrainedModelOptions'. +undeployMlTrainedModelWith :: + MlTrainedModelId -> + MlTrainedModelOptions -> + BHRequest StatusDependant Acknowledged +undeployMlTrainedModelWith id' opts = + post @StatusDependant (endpoint `withQueries` mlTrainedModelOptionsParams opts) emptyBody + where + endpoint = + mkEndpoint ["_ml", "trained_models", unMlTrainedModelId id', "deployment", "_undeploy"] + +-- | 'startMlTrainedModelDeployment' builds the 'BHRequest' for +-- @POST /_ml/trained_models/{model_id}/deployment/_start@ +-- (ml-start-trained-model-deployment), the 8.12+ alias of +-- 'deployMlTrainedModel'. Equivalent to +-- @'startMlTrainedModelDeploymentWith' id 'defaultMlTrainedModelOptions'@. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +startMlTrainedModelDeployment :: + MlTrainedModelId -> + BHRequest StatusDependant Acknowledged +startMlTrainedModelDeployment id' = + startMlTrainedModelDeploymentWith id' defaultMlTrainedModelOptions + +-- | 'startMlTrainedModelDeploymentWith' is the fully-parameterised variant +-- of 'startMlTrainedModelDeployment'. +startMlTrainedModelDeploymentWith :: + MlTrainedModelId -> + MlTrainedModelOptions -> + BHRequest StatusDependant Acknowledged +startMlTrainedModelDeploymentWith id' opts = + post @StatusDependant (endpoint `withQueries` mlTrainedModelOptionsParams opts) emptyBody + where + endpoint = + mkEndpoint ["_ml", "trained_models", unMlTrainedModelId id', "deployment", "_start"] + +-- | 'stopMlTrainedModelDeployment' builds the 'BHRequest' for +-- @POST /_ml/trained_models/{model_id}/deployment/_stop@ +-- (ml-stop-trained-model-deployment), the 8.12+ alias of +-- 'undeployMlTrainedModel'. Equivalent to +-- @'stopMlTrainedModelDeploymentWith' id 'defaultMlTrainedModelOptions'@. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +stopMlTrainedModelDeployment :: + MlTrainedModelId -> + BHRequest StatusDependant Acknowledged +stopMlTrainedModelDeployment id' = + stopMlTrainedModelDeploymentWith id' defaultMlTrainedModelOptions + +-- | 'stopMlTrainedModelDeploymentWith' is the fully-parameterised variant +-- of 'stopMlTrainedModelDeployment'. +stopMlTrainedModelDeploymentWith :: + MlTrainedModelId -> + MlTrainedModelOptions -> + BHRequest StatusDependant Acknowledged +stopMlTrainedModelDeploymentWith id' opts = + post @StatusDependant (endpoint `withQueries` mlTrainedModelOptionsParams opts) emptyBody + where + endpoint = + mkEndpoint ["_ml", "trained_models", unMlTrainedModelId id', "deployment", "_stop"] + +-- | 'getMlTrainedModelStats' builds the 'BHRequest' for +-- @GET /_ml/trained_models/{model_id}/_stats@ +-- (ml-get-trained-models-stats). Pass 'Nothing' for the id to fetch stats +-- for every model. Equivalent to +-- @'getMlTrainedModelStatsWith' mid 'defaultMlTrainedModelOptions'@. +-- +-- For more information see +-- . +getMlTrainedModelStats :: + Maybe MlTrainedModelId -> + BHRequest StatusDependant MlTrainedModelStatsResponse +getMlTrainedModelStats mid = + getMlTrainedModelStatsWith mid defaultMlTrainedModelOptions + +-- | 'getMlTrainedModelStatsWith' is the fully-parameterised variant of +-- 'getMlTrainedModelStats'. +getMlTrainedModelStatsWith :: + Maybe MlTrainedModelId -> + MlTrainedModelOptions -> + BHRequest StatusDependant MlTrainedModelStatsResponse +getMlTrainedModelStatsWith mid opts = + get @StatusDependant (endpoint `withQueries` mlTrainedModelOptionsParams opts) + where + endpoint = + mkEndpoint $ + ["_ml", "trained_models"] + ++ maybe [] (\(MlTrainedModelId x) -> [x]) mid + ++ ["_stats"] + +-- | 'inferMlTrainedModel' builds the 'BHRequest' for +-- @POST /_ml/trained_models/{model_id}/_infer@ +-- (ml-infer-trained-model), running inference against a deployed model. +-- The 'MlTrainedModelInferRequest' carries the @docs@ payload as an +-- opaque 'Value'. +-- +-- For more information see +-- . +inferMlTrainedModel :: + MlTrainedModelId -> + MlTrainedModelInferRequest -> + BHRequest StatusDependant MlTrainedModelInferResponse +inferMlTrainedModel id' req = + post @StatusDependant endpoint (encode req) + where + endpoint = + mkEndpoint ["_ml", "trained_models", unMlTrainedModelId id', "_infer"] + +-- ========================================================================= +-- ML anomaly jobs (X-Pack) +-- ========================================================================= + +-- | 'putMlAnomalyJob' builds the 'BHRequest' for +-- @PUT /_ml/anomaly_detectors/{job_id}@ (ml-put-job), creating an anomaly +-- detection job. Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +putMlAnomalyJob :: + MlJobId -> + MlAnomalyJob -> + BHRequest StatusDependant Acknowledged +putMlAnomalyJob id' body = + put @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_ml", "anomaly_detectors", unMlJobId id'] + +-- | 'getMlAnomalyJobs' builds the 'BHRequest' for +-- @GET /_ml/anomaly_detectors[/{job_id}]@ (ml-get-job). Pass 'Nothing' +-- to list every job. Equivalent to +-- @'getMlAnomalyJobsWith' mid 'defaultMlAnomalyJobOptions'@. +-- +-- For more information see +-- . +getMlAnomalyJobs :: + Maybe MlJobId -> + BHRequest StatusDependant MlAnomalyJobsResponse +getMlAnomalyJobs mid = getMlAnomalyJobsWith mid defaultMlAnomalyJobOptions + +-- | 'getMlAnomalyJobsWith' is the fully-parameterised variant of +-- 'getMlAnomalyJobs'. +getMlAnomalyJobsWith :: + Maybe MlJobId -> + MlAnomalyJobOptions -> + BHRequest StatusDependant MlAnomalyJobsResponse +getMlAnomalyJobsWith mid opts = + get @StatusDependant (endpoint `withQueries` mlAnomalyJobOptionsParams opts) + where + endpoint = + mkEndpoint $ + ["_ml", "anomaly_detectors"] + ++ maybe [] (\(MlJobId x) -> [x]) mid + +-- | 'updateMlAnomalyJob' builds the 'BHRequest' for +-- @POST /_ml/anomaly_detectors/{job_id}/_update@ (ml-update-job). +-- +-- For more information see +-- . +updateMlAnomalyJob :: + MlJobId -> + MlAnomalyJobUpdate -> + BHRequest StatusDependant Acknowledged +updateMlAnomalyJob id' body = + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint ["_ml", "anomaly_detectors", unMlJobId id', "_update"] + +-- | 'deleteMlAnomalyJob' builds the 'BHRequest' for +-- @DELETE /_ml/anomaly_detectors/{job_id}@ (ml-delete-job). Equivalent to +-- @'deleteMlAnomalyJobWith' id 'defaultMlAnomalyJobOptions'@. +-- +-- For more information see +-- . +deleteMlAnomalyJob :: + MlJobId -> + BHRequest StatusDependant Acknowledged +deleteMlAnomalyJob id' = + deleteMlAnomalyJobWith id' defaultMlAnomalyJobOptions + +-- | 'deleteMlAnomalyJobWith' is the fully-parameterised variant of +-- 'deleteMlAnomalyJob', forwarding the @force@ query parameter. +deleteMlAnomalyJobWith :: + MlJobId -> + MlAnomalyJobOptions -> + BHRequest StatusDependant Acknowledged +deleteMlAnomalyJobWith id' opts = + delete (endpoint `withQueries` mlAnomalyJobOptionsParams opts) + where + endpoint = + mkEndpoint ["_ml", "anomaly_detectors", unMlJobId id'] + +-- | 'openMlAnomalyJob' builds the 'BHRequest' for +-- @POST /_ml/anomaly_detectors/{job_id}/_open@ (ml-open-job). Returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +openMlAnomalyJob :: + MlJobId -> + BHRequest StatusDependant Acknowledged +openMlAnomalyJob id' = + post @StatusDependant endpoint emptyBody + where + endpoint = + mkEndpoint ["_ml", "anomaly_detectors", unMlJobId id', "_open"] + +-- | 'closeMlAnomalyJob' builds the 'BHRequest' for +-- @POST /_ml/anomaly_detectors/{job_id}/_close@ (ml-close-job). Returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +closeMlAnomalyJob :: + MlJobId -> + BHRequest StatusDependant Acknowledged +closeMlAnomalyJob id' = + post @StatusDependant endpoint emptyBody + where + endpoint = + mkEndpoint ["_ml", "anomaly_detectors", unMlJobId id', "_close"] + +-- | 'forecastMlAnomalyJob' builds the 'BHRequest' for +-- @POST /_ml/anomaly_detectors/{job_id}/_forecast@ (ml-forecast-job), +-- producing a forecast for a started job. Pass +-- 'defaultMlForecastOptions' for an empty body. +-- +-- For more information see +-- . +forecastMlAnomalyJob :: + MlJobId -> + MlForecastOptions -> + BHRequest StatusDependant MlForecastResponse +forecastMlAnomalyJob id' body = + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint ["_ml", "anomaly_detectors", unMlJobId id', "_forecast"] + +-- | 'flushMlAnomalyJob' builds the 'BHRequest' for +-- @POST /_ml/anomaly_detectors/{job_id}/_flush@ (ml-flush-job), +-- forcing the job to flush its interim results. Pass +-- 'defaultMlFlushOptions' for an empty body. +-- +-- For more information see +-- . +flushMlAnomalyJob :: + MlJobId -> + MlFlushOptions -> + BHRequest StatusDependant MlFlushResponse +flushMlAnomalyJob id' body = + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint ["_ml", "anomaly_detectors", unMlJobId id', "_flush"] + +-- | 'validateMlAnomalyJob' builds the 'BHRequest' for +-- @POST /_ml/anomaly_detectors/_validate@ (ml-validate-job), validating +-- an anomaly job configuration without creating it. The job body is the +-- first argument. +-- +-- For more information see +-- . +validateMlAnomalyJob :: + MlAnomalyJob -> + BHRequest StatusDependant MlValidateResponse +validateMlAnomalyJob body = + post @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_ml", "anomaly_detectors", "_validate"] + +-- | 'getMlAnomalyJobStats' builds the 'BHRequest' for +-- @GET /_ml/anomaly_detectors[/{job_id}]/_stats@ (ml-get-job-stats). Pass +-- 'Nothing' to fetch stats for every job. Equivalent to +-- @'getMlAnomalyJobStatsWith' mid 'defaultMlAnomalyJobOptions'@. +-- +-- For more information see +-- . +getMlAnomalyJobStats :: + Maybe MlJobId -> + BHRequest StatusDependant MlAnomalyJobStatsResponse +getMlAnomalyJobStats mid = + getMlAnomalyJobStatsWith mid defaultMlAnomalyJobOptions + +-- | 'getMlAnomalyJobStatsWith' is the fully-parameterised variant of +-- 'getMlAnomalyJobStats'. +getMlAnomalyJobStatsWith :: + Maybe MlJobId -> + MlAnomalyJobOptions -> + BHRequest StatusDependant MlAnomalyJobStatsResponse +getMlAnomalyJobStatsWith mid opts = + get @StatusDependant (endpoint `withQueries` mlAnomalyJobOptionsParams opts) + where + endpoint = + mkEndpoint $ + ["_ml", "anomaly_detectors"] + ++ maybe [] (\(MlJobId x) -> [x]) mid + ++ ["_stats"] + +-- | 'getMlAnomalyJobResults' builds the 'BHRequest' for the read-only +-- results endpoints +-- @GET /_ml/anomaly_detectors/{job_id}/_results/{buckets,records,categories,influencers,overall_buckets}@ +-- (ml-get-buckets, ml-get-records, …). 'MlAnomalyResultType' selects the +-- results kind. Equivalent to +-- @'getMlAnomalyJobResultsWith' id kind 'defaultMlAnomalyJobOptions'@. +getMlAnomalyJobResults :: + MlJobId -> + MlAnomalyResultType -> + BHRequest StatusDependant MlAnomalyJobResults +getMlAnomalyJobResults id' kind = + getMlAnomalyJobResultsWith id' kind defaultMlAnomalyJobOptions + +-- | 'getMlAnomalyJobResultsWith' is the fully-parameterised variant of +-- 'getMlAnomalyJobResults'. +getMlAnomalyJobResultsWith :: + MlJobId -> + MlAnomalyResultType -> + MlAnomalyJobOptions -> + BHRequest StatusDependant MlAnomalyJobResults +getMlAnomalyJobResultsWith id' kind opts = + get @StatusDependant (endpoint `withQueries` mlAnomalyJobOptionsParams opts) + where + endpoint = + mkEndpoint + [ "_ml", + "anomaly_detectors", + unMlJobId id', + "_results", + mlAnomalyResultTypeSegment kind + ] + +-- | 'getMlModelSnapshots' builds the 'BHRequest' for +-- @GET /_ml/anomaly_detectors/{job_id}/_model_snapshots@ +-- (ml-get-model-snapshots). Equivalent to +-- @'getMlModelSnapshotsWith' id 'defaultMlAnomalyJobOptions'@. +getMlModelSnapshots :: + MlJobId -> + BHRequest StatusDependant MlModelSnapshotsResponse +getMlModelSnapshots id' = + getMlModelSnapshotsWith id' defaultMlAnomalyJobOptions + +-- | 'getMlModelSnapshotsWith' is the fully-parameterised variant of +-- 'getMlModelSnapshots'. +getMlModelSnapshotsWith :: + MlJobId -> + MlAnomalyJobOptions -> + BHRequest StatusDependant MlModelSnapshotsResponse +getMlModelSnapshotsWith id' opts = + get @StatusDependant (endpoint `withQueries` mlAnomalyJobOptionsParams opts) + where + endpoint = + mkEndpoint ["_ml", "anomaly_detectors", unMlJobId id', "_model_snapshots"] + +-- | 'getMlModelSnapshot' builds the 'BHRequest' for +-- @GET /_ml/anomaly_detectors/{job_id}/_model_snapshots/{snapshot_id}@ +-- (ml-get-model-snapshot-info). Equivalent to +-- @'getMlModelSnapshotWith' id snap 'defaultMlAnomalyJobOptions'@. +getMlModelSnapshot :: + MlJobId -> + MlModelSnapshotId -> + BHRequest StatusDependant MlModelSnapshotsResponse +getMlModelSnapshot id' snap = + getMlModelSnapshotWith id' snap defaultMlAnomalyJobOptions + +-- | 'getMlModelSnapshotWith' is the fully-parameterised variant of +-- 'getMlModelSnapshot'. +getMlModelSnapshotWith :: + MlJobId -> + MlModelSnapshotId -> + MlAnomalyJobOptions -> + BHRequest StatusDependant MlModelSnapshotsResponse +getMlModelSnapshotWith id' snap opts = + get @StatusDependant (endpoint `withQueries` mlAnomalyJobOptionsParams opts) + where + endpoint = + mkEndpoint + [ "_ml", + "anomaly_detectors", + unMlJobId id', + "_model_snapshots", + unMlModelSnapshotId snap + ] + +-- | 'updateMlModelSnapshot' builds the 'BHRequest' for +-- @PUT /_ml/anomaly_detectors/{job_id}/_model_snapshots/{snapshot_id}@ +-- (ml-update-model-snapshot), updating snapshot metadata. Returns +-- 'Acknowledged' on success. +updateMlModelSnapshot :: + MlJobId -> + MlModelSnapshotId -> + Value -> + BHRequest StatusDependant Acknowledged +updateMlModelSnapshot id' snap body = + put @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint + [ "_ml", + "anomaly_detectors", + unMlJobId id', + "_model_snapshots", + unMlModelSnapshotId snap + ] + +-- | 'deleteMlModelSnapshot' builds the 'BHRequest' for +-- @DELETE /_ml/anomaly_detectors/{job_id}/_model_snapshots/{snapshot_id}@ +-- (ml-delete-model-snapshot). Equivalent to +-- @'deleteMlModelSnapshotWith' id snap 'defaultMlAnomalyJobOptions'@. +deleteMlModelSnapshot :: + MlJobId -> + MlModelSnapshotId -> + BHRequest StatusDependant Acknowledged +deleteMlModelSnapshot id' snap = + deleteMlModelSnapshotWith id' snap defaultMlAnomalyJobOptions + +-- | 'deleteMlModelSnapshotWith' is the fully-parameterised variant of +-- 'deleteMlModelSnapshot'. +deleteMlModelSnapshotWith :: + MlJobId -> + MlModelSnapshotId -> + MlAnomalyJobOptions -> + BHRequest StatusDependant Acknowledged +deleteMlModelSnapshotWith id' snap opts = + delete (endpoint `withQueries` mlAnomalyJobOptionsParams opts) + where + endpoint = + mkEndpoint + [ "_ml", + "anomaly_detectors", + unMlJobId id', + "_model_snapshots", + unMlModelSnapshotId snap + ] + +-- | 'revertMlModelSnapshot' builds the 'BHRequest' for +-- @POST /_ml/anomaly_detectors/{job_id}/_model_snapshots/{snapshot_id}/_revert@ +-- (ml-revert-model-snapshot). The body carries the revert options (e.g. +-- @delete_intervening_results@) as an opaque 'Value'; pass @object []@ +-- for an empty body. Equivalent to +-- @'revertMlModelSnapshotWith' id snap (object []) 'defaultMlAnomalyJobOptions'@. +revertMlModelSnapshot :: + MlJobId -> + MlModelSnapshotId -> + Value -> + BHRequest StatusDependant MlRevertSnapshotResponse +revertMlModelSnapshot id' snap body = + revertMlModelSnapshotWith id' snap body defaultMlAnomalyJobOptions + +-- | 'revertMlModelSnapshotWith' is the fully-parameterised variant of +-- 'revertMlModelSnapshot'. +revertMlModelSnapshotWith :: + MlJobId -> + MlModelSnapshotId -> + Value -> + MlAnomalyJobOptions -> + BHRequest StatusDependant MlRevertSnapshotResponse +revertMlModelSnapshotWith id' snap body opts = + post @StatusDependant (endpoint `withQueries` mlAnomalyJobOptionsParams opts) (encode body) + where + endpoint = + mkEndpoint + [ "_ml", + "anomaly_detectors", + unMlJobId id', + "_model_snapshots", + unMlModelSnapshotId snap, + "_revert" + ] + +-- ========================================================================= +-- ML datafeeds (X-Pack) +-- ========================================================================= + +-- | 'putMlDatafeed' builds the 'BHRequest' for +-- @PUT /_ml/datafeeds/{feed_id}@ (ml-put-datafeed), creating a datafeed. +-- Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +putMlDatafeed :: + MlDatafeedId -> + MlDatafeed -> + BHRequest StatusDependant Acknowledged +putMlDatafeed id' body = + put @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_ml", "datafeeds", unMlDatafeedId id'] + +-- | 'getMlDatafeeds' builds the 'BHRequest' for +-- @GET /_ml/datafeeds[/{feed_id}]@ (ml-get-datafeed). Pass 'Nothing' to +-- list every datafeed. Equivalent to +-- @'getMlDatafeedsWith' mid 'defaultMlDatafeedOptions'@. +-- +-- For more information see +-- . +getMlDatafeeds :: + Maybe MlDatafeedId -> + BHRequest StatusDependant MlDatafeedsResponse +getMlDatafeeds mid = getMlDatafeedsWith mid defaultMlDatafeedOptions + +-- | 'getMlDatafeedsWith' is the fully-parameterised variant of +-- 'getMlDatafeeds'. +getMlDatafeedsWith :: + Maybe MlDatafeedId -> + MlDatafeedOptions -> + BHRequest StatusDependant MlDatafeedsResponse +getMlDatafeedsWith mid opts = + get @StatusDependant (endpoint `withQueries` mlDatafeedOptionsParams opts) + where + endpoint = + mkEndpoint $ + ["_ml", "datafeeds"] + ++ maybe [] (\(MlDatafeedId x) -> [x]) mid + +-- | 'updateMlDatafeed' builds the 'BHRequest' for +-- @POST /_ml/datafeeds/{feed_id}/_update@ (ml-update-datafeed). +-- +-- For more information see +-- . +updateMlDatafeed :: + MlDatafeedId -> + MlDatafeedUpdate -> + BHRequest StatusDependant Acknowledged +updateMlDatafeed id' body = + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint ["_ml", "datafeeds", unMlDatafeedId id', "_update"] + +-- | 'deleteMlDatafeed' builds the 'BHRequest' for +-- @DELETE /_ml/datafeeds/{feed_id}@ (ml-delete-datafeed). Returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteMlDatafeed :: + MlDatafeedId -> + BHRequest StatusDependant Acknowledged +deleteMlDatafeed id' = + delete endpoint + where + endpoint = mkEndpoint ["_ml", "datafeeds", unMlDatafeedId id'] + +-- | 'startMlDatafeed' builds the 'BHRequest' for +-- @POST /_ml/datafeeds/{feed_id}/_start@ (ml-start-datafeed). The body +-- may carry an optional @start@ \/ @end@ time; pass @object []@ for an +-- empty body. Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +startMlDatafeed :: + MlDatafeedId -> + Value -> + BHRequest StatusDependant Acknowledged +startMlDatafeed id' body = + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint ["_ml", "datafeeds", unMlDatafeedId id', "_start"] + +-- | 'stopMlDatafeed' builds the 'BHRequest' for +-- @POST /_ml/datafeeds/{feed_id}/_stop@ (ml-stop-datafeed). Returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +stopMlDatafeed :: + MlDatafeedId -> + BHRequest StatusDependant Acknowledged +stopMlDatafeed id' = + post @StatusDependant endpoint emptyBody + where + endpoint = + mkEndpoint ["_ml", "datafeeds", unMlDatafeedId id', "_stop"] + +-- | 'previewMlDatafeed' builds the 'BHRequest' for +-- @GET /_ml/datafeeds/{feed_id}/_preview@ (ml-preview-datafeed), +-- returning the documents the datafeed would currently send to its job. +-- +-- For more information see +-- . +previewMlDatafeed :: + MlDatafeedId -> + BHRequest StatusDependant MlDatafeedPreviewResponse +previewMlDatafeed id' = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_ml", "datafeeds", unMlDatafeedId id', "_preview"] + +-- ========================================================================= +-- ML filters (X-Pack) +-- ========================================================================= + +-- | 'putMlFilter' builds the 'BHRequest' for +-- @PUT /_ml/filters/{filter_id}@ (ml-put-filter), creating or updating a +-- filter. Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +putMlFilter :: + MlFilterId -> + MlFilter -> + BHRequest StatusDependant Acknowledged +putMlFilter id' body = + put @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_ml", "filters", unMlFilterId id'] + +-- | 'getMlFilters' builds the 'BHRequest' for +-- @GET /_ml/filters[/{filter_id}]@ (ml-get-filter). Pass 'Nothing' to +-- list every filter. Equivalent to +-- @'getMlFiltersWith' mid 'defaultMlDatafeedOptions'@. +-- +-- For more information see +-- . +getMlFilters :: + Maybe MlFilterId -> + BHRequest StatusDependant MlFiltersResponse +getMlFilters mid = getMlFiltersWith mid defaultMlDatafeedOptions + +-- | 'getMlFiltersWith' is the fully-parameterised variant of +-- 'getMlFilters'. +getMlFiltersWith :: + Maybe MlFilterId -> + MlDatafeedOptions -> + BHRequest StatusDependant MlFiltersResponse +getMlFiltersWith mid opts = + get @StatusDependant (endpoint `withQueries` mlDatafeedOptionsParams opts) + where + endpoint = + mkEndpoint $ + ["_ml", "filters"] + ++ maybe [] (\(MlFilterId x) -> [x]) mid + +-- | 'deleteMlFilter' builds the 'BHRequest' for +-- @DELETE /_ml/filters/{filter_id}@ (ml-delete-filter). Returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteMlFilter :: + MlFilterId -> + BHRequest StatusDependant Acknowledged +deleteMlFilter id' = + delete endpoint + where + endpoint = mkEndpoint ["_ml", "filters", unMlFilterId id'] + +-- ========================================================================= +-- ML calendars and scheduled events (X-Pack) +-- ========================================================================= + +-- | 'putMlCalendar' builds the 'BHRequest' for +-- @PUT /_ml/calendars/{calendar_id}@ (ml-put-calendar), creating or +-- updating a calendar. Returns 'Acknowledged' on success. +-- +-- For more information see +-- . +putMlCalendar :: + MlCalendarId -> + MlCalendar -> + BHRequest StatusDependant Acknowledged +putMlCalendar id' body = + put @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_ml", "calendars", unMlCalendarId id'] + +-- | 'getMlCalendars' builds the 'BHRequest' for +-- @GET /_ml/calendars[/{calendar_id}]@ (ml-get-calendars). Pass +-- 'Nothing' to list every calendar. Equivalent to +-- @'getMlCalendarsWith' mid 'defaultMlDatafeedOptions'@. +-- +-- For more information see +-- . +getMlCalendars :: + Maybe MlCalendarId -> + BHRequest StatusDependant MlCalendarsResponse +getMlCalendars mid = getMlCalendarsWith mid defaultMlDatafeedOptions + +-- | 'getMlCalendarsWith' is the fully-parameterised variant of +-- 'getMlCalendars'. +getMlCalendarsWith :: + Maybe MlCalendarId -> + MlDatafeedOptions -> + BHRequest StatusDependant MlCalendarsResponse +getMlCalendarsWith mid opts = + get @StatusDependant (endpoint `withQueries` mlDatafeedOptionsParams opts) + where + endpoint = + mkEndpoint $ + ["_ml", "calendars"] + ++ maybe [] (\(MlCalendarId x) -> [x]) mid + +-- | 'deleteMlCalendar' builds the 'BHRequest' for +-- @DELETE /_ml/calendars/{calendar_id}@ (ml-delete-calendar). Returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteMlCalendar :: + MlCalendarId -> + BHRequest StatusDependant Acknowledged +deleteMlCalendar id' = + delete endpoint + where + endpoint = mkEndpoint ["_ml", "calendars", unMlCalendarId id'] + +-- | 'setMlScheduledEvents' builds the 'BHRequest' for +-- @POST /_ml/calendars/{calendar_id}/events@ (ml-post-calendar-events), +-- adding (or replacing) scheduled events on a calendar. The response +-- echoes the stored events. +-- +-- For more information see +-- . +setMlScheduledEvents :: + MlCalendarId -> + MlScheduledEvents -> + BHRequest StatusDependant MlScheduledEventsResponse +setMlScheduledEvents id' body = + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint ["_ml", "calendars", unMlCalendarId id', "events"] + +-- | 'getMlScheduledEvents' builds the 'BHRequest' for +-- @GET /_ml/calendars/{calendar_id}/events@ +-- (ml-get-calendar-events), listing the scheduled events on a calendar. +-- +-- For more information see +-- . +getMlScheduledEvents :: + MlCalendarId -> + BHRequest StatusDependant MlScheduledEventsResponse +getMlScheduledEvents id' = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_ml", "calendars", unMlCalendarId id', "events"] diff --git a/src/Database/Bloodhound/ElasticSearch9/Types.hs b/src/Database/Bloodhound/ElasticSearch9/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/ElasticSearch9/Types.hs @@ -0,0 +1,920 @@ +module Database.Bloodhound.ElasticSearch9.Types + ( module Reexport, + OpenPointInTimeResponse (..), + ClosePointInTime (..), + ClosePointInTimeResponse (..), + openPointInTimeIdLens, + openPointInTimeShardsLens, + closePointInTimeIdLens, + closePointInTimeSucceededLens, + closePointInTimeNumFreedLens, + ESQLRequest (..), + ESQLResult (..), + ESQLColumn (..), + AsyncESQLRequest (..), + mkAsyncESQLRequest, + AsyncESQLId (..), + AsyncESQLResult (..), + ESQLQueryOptions (..), + defaultESQLQueryOptions, + esqlOptionsParams, + GetAsyncESQLOptions (..), + defaultGetAsyncESQLOptions, + getAsyncESQLOptionsParams, + EsqlClusters (..), + EsqlClusterDetails (..), + EsqlClusterStatus (..), + esqlClusterStatusToText, + esqlClusterStatusFromText, + EsqlProfile (..), + EsqlProfileSection (..), + esqlQueryLens, + esqlLocaleLens, + esqlTimeZoneLens, + esqlFilterLens, + esqlParamsLens, + esqlColumnarLens, + esqlProfileLens, + esqlTablesLens, + esqlIncludeCcsMetadataLens, + esqlIncludeExecutionMetadataLens, + esqloDelimiterLens, + esqloDropNullColumnsLens, + esqloAllowPartialResultsLens, + gaesqloWaitForCompletionTimeoutLens, + gaesqloKeepAliveLens, + gaesqloDropNullColumnsLens, + esqlIsPartialLens, + esqlAllColumnsLens, + esqlClustersLens, + esqlProfileValueLens, + esqlColumnsLens, + esqlValuesLens, + esqlTookLens, + esqlColumnNameLens, + esqlColumnTypeLens, + esqlClustersTotalLens, + esqlClustersSuccessfulLens, + esqlClustersRunningLens, + esqlClustersSkippedLens, + esqlClustersPartialLens, + esqlClustersFailedLens, + esqlClustersDetailsLens, + esqlClustersOtherLens, + esqlClusterDetailsStatusLens, + esqlClusterDetailsIndicesLens, + esqlClusterDetailsShardsLens, + esqlClusterDetailsFailuresLens, + esqlClusterDetailsOtherLens, + esqlProfileShardsLens, + esqlProfileProfilesLens, + esqlProfileOtherLens, + esqlProfileSectionPhaseLens, + esqlProfileSectionDescriptionLens, + esqlProfileSectionTimeLens, + esqlProfileSectionChildrenLens, + esqlProfileSectionOtherLens, + EQLRequest (..), + EQLResult (..), + EQLHits (..), + EQLHit (..), + EQLTotal (..), + EQLTotalRelation (..), + EQLResultPosition (..), + EQLSearchId (..), + EQLSequence (..), + EQLStatus (..), + EQLSearchOptions (..), + defaultEQLSearchOptions, + eqlSearchOptionsParams7, + eqlSearchOptionsParams8, + EQLRequestBodyES7 (..), + EQLRequestBodyES8 (..), + eqlQueryLens, + eqlWaitForCompletionTimeoutLens, + eqlKeepOnCompletionLens, + eqlKeepAliveLens, + eqlSizeLens, + eqlFetchSizeLens, + eqlFieldsLens, + eqlFilterLens, + eqlResultPositionLens, + eqlTiebreakerFieldLens, + eqlEventCategoryFieldLens, + eqlTimestampFieldLens, + eqlRuntimeMappingsLens, + eqlAllowPartialSearchResultsLens, + eqlAllowPartialSequenceResultsLens, + eqlCaseSensitiveLens, + esoAllowNoIndicesLens, + esoAllowPartialSearchResultsLens, + esoAllowPartialSequenceResultsLens, + esoExpandWildcardsLens, + esoIgnoreUnavailableLens, + esoCcsMinimizeRoundtripsLens, + esoKeepAliveLens, + esoKeepOnCompletionLens, + esoWaitForCompletionTimeoutLens, + eqlIdLens, + eqlIsRunningLens, + eqlIsPartialLens, + eqlTimedOutLens, + eqlTookLens, + eqlHitsLens, + eqlHitsTotalLens, + eqlHitsEventsLens, + eqlHitsSequencesLens, + eqlSequenceEventsLens, + eqlSequenceJoinKeysLens, + eqlHitIndexLens, + eqlHitDocIdLens, + eqlHitScoreLens, + eqlHitSourceLens, + eqlHitVersionLens, + eqlHitSeqNoLens, + eqlHitPrimaryTermLens, + eqlHitFieldsLens, + eqlTotalValueLens, + eqlTotalRelationLens, + eqlSearchIdLens, + eqlStatusIdLens, + eqlStatusIsRunningLens, + eqlStatusIsPartialLens, + eqlStatusStartTimeInMillisLens, + eqlStatusCompletionStatusLens, + eqlStatusExpirationTimeInMillisLens, + resultPositionToText, + resultPositionFromText, + asyncESQLRequestBaseLens, + asyncESQLRequestWaitForCompletionTimeoutLens, + asyncESQLRequestKeepAliveLens, + asyncESQLRequestKeepOnCompletionLens, + asyncESQLIdLens, + asyncESQLResultIdLens, + asyncESQLResultIsRunningLens, + asyncESQLResultIsPartialLens, + asyncESQLResultStartTimeInMillisLens, + asyncESQLResultExpirationTimeInMillisLens, + asyncESQLResultCompletionTimeInMillisLens, + asyncESQLResultTookLens, + asyncESQLResultDocumentsFoundLens, + asyncESQLResultValuesLoadedLens, + asyncESQLResultColumnsLens, + asyncESQLResultValuesLens, + asyncESQLResultClustersLens, + asyncESQLResultProfileLens, + + -- * ES|QL Views (ES 9.4+, experimental) + ESQLViewName (..), + ESQLView (..), + ESQLQueryInfo (..), + ESQLQueryListResponse (..), + unESQLQueryListResponse, + esqlViewNameLens, + esqlViewQueryLens, + esqlQueryInfoIdLens, + esqlQueryInfoNodeLens, + esqlQueryInfoStartTimeMillisLens, + esqlQueryInfoRunningTimeNanosLens, + esqlQueryInfoQueryLens, + esqlQueryInfoCoordinatingNodeLens, + esqlQueryInfoDataNodesLens, + TaskType (..), + taskTypeToText, + taskTypeFromText, + InferenceId (..), + unInferenceId, + InferenceProvider (..), + OpenAIServiceSettings (..), + OpenAITaskSettings (..), + CohereServiceSettings (..), + CohereTaskSettings (..), + ElserServiceSettings (..), + AdaptiveAllocations (..), + RateLimit (..), + Similarity (..), + CohereEmbeddingType (..), + CohereInputType (..), + CohereTruncate (..), + ChunkingSettings (..), + NvidiaInputType (..), + JinaAiElementType (..), + JinaAiInputType (..), + AmazonSageMakerApi (..), + AmazonSageMakerElementType (..), + GoogleModelGardenProvider (..), + ThinkingConfig (..), + Ai21ServiceSettings (..), + MistralServiceSettings (..), + AnthropicServiceSettings (..), + AnthropicTaskSettings (..), + DeepSeekServiceSettings (..), + NvidiaServiceSettings (..), + NvidiaTaskSettings (..), + ContextualAiServiceSettings (..), + ContextualAiTaskSettings (..), + FireworksAiServiceSettings (..), + FireworksAiTaskSettings (..), + GoogleAiStudioServiceSettings (..), + GoogleVertexAiServiceSettings (..), + GoogleVertexAiTaskSettings (..), + GroqServiceSettings (..), + HuggingFaceServiceSettings (..), + HuggingFaceTaskSettings (..), + JinaAiServiceSettings (..), + JinaAiTaskSettings (..), + LlamaServiceSettings (..), + OpenShiftAiServiceSettings (..), + OpenShiftAiTaskSettings (..), + VoyageAiServiceSettings (..), + VoyageAiTaskSettings (..), + ElasticsearchServiceSettings (..), + ElasticsearchTaskSettings (..), + AlibabaCloudServiceSettings (..), + AlibabaCloudTaskSettings (..), + AmazonBedrockServiceSettings (..), + AmazonBedrockTaskSettings (..), + AmazonSageMakerServiceSettings (..), + AmazonSageMakerTaskSettings (..), + AzureAiStudioServiceSettings (..), + AzureAiStudioTaskSettings (..), + AzureOpenAiServiceSettings (..), + AzureOpenAiTaskSettings (..), + CustomServiceSettings (..), + CustomTaskSettings (..), + WatsonxServiceSettings (..), + InferenceConfig (..), + InferencePutResponse (..), + InferenceInput (..), + InferenceResult (..), + EmbeddingFormat (..), + DenseEmbeddingItem (..), + SparseEmbeddingItem (..), + -- | Re-exported so callers can name the field type of + -- 'CustomServiceSettings.customssSecretParameters'. + SecretValue (..), + CompletionItem (..), + RerankItem (..), + ChatMessage (..), + ChatCompletionRequest (..), + InferenceInfo (..), + InferenceEndpointsResponse (..), + inferenceIdLens, + inferenceConfigProviderLens, + inferenceConfigChunkingSettingsLens, + inferencePutResponseInferenceIdLens, + inferencePutResponseTaskTypeLens, + inferencePutResponseServiceLens, + inferenceInputInputLens, + inferenceInputQueryLens, + denseEmbeddingItemEmbeddingLens, + sparseEmbeddingItemEmbeddingLens, + completionItemResultLens, + rerankItemIndexLens, + rerankItemRelevanceScoreLens, + rerankItemTextLens, + inferenceInfoTaskTypeLens, + inferenceInfoInferenceIdLens, + inferenceInfoServiceLens, + inferenceInfoServiceSettingsLens, + inferenceInfoTaskSettingsLens, + inferenceInfoChunkingSettingsLens, + DeleteInferenceOptions (..), + defaultDeleteInferenceOptions, + deleteInferenceOptionsParams, + dioDryRunLens, + dioForceLens, + PutInferenceOptions (..), + defaultPutInferenceOptions, + putInferenceOptionsParams, + pioTimeoutLens, + RunInferenceOptions (..), + defaultRunInferenceOptions, + runInferenceOptionsParams, + rnioTimeoutLens, + StreamCompletionInferenceOptions (..), + defaultStreamCompletionInferenceOptions, + streamCompletionInferenceOptionsParams, + scioTimeoutLens, + StreamChatCompletionInferenceOptions (..), + defaultStreamChatCompletionInferenceOptions, + streamChatCompletionInferenceOptionsParams, + sccioTimeoutLens, + + -- * Query Rules + RulesetId (..), + unRulesetId, + RuleId (..), + unRuleId, + QueryRuleset (..), + Rule (..), + RuleType (..), + ruleTypeToText, + ruleTypeFromText, + Criterion (..), + PinnedDoc (..), + PinnedActions (..), + QueryRulesetInfo (..), + QueryRulesetPutResponse (..), + QueryRulesetTest (..), + QueryRulesetTestResponse (..), + QueryRulesetTestMatchedRule (..), + rulesetIdLens, + ruleIdLens, + queryRulesetRulesLens, + ruleRuleIdLens, + ruleTypeLens, + ruleCriteriaLens, + ruleActionsLens, + rulePriorityLens, + pinnedDocIndexLens, + pinnedDocIdLens, + pinnedActionsDocsLens, + pinnedActionsIdsLens, + queryRulesetInfoIdLens, + queryRulesetInfoRulesLens, + queryRulesetPutResponseResultLens, + queryRulesetTestMatchCriteriaLens, + queryRulesetTestResponseTotalLens, + queryRulesetTestResponseMatchedLens, + queryRulesetTestMatchedRuleRulesetIdLens, + queryRulesetTestMatchedRuleRuleIdLens, + + -- * Search Applications + SearchApplicationName (..), + unSearchApplicationName, + SearchApplicationScriptBody (..), + SearchApplicationTemplateScript (..), + SearchApplicationTemplate (..), + SearchApplication (..), + SearchApplicationInfo (..), + SearchApplicationPutResponse (..), + SearchApplicationPutOptions (..), + defaultSearchApplicationPutOptions, + SearchApplicationOptions (..), + defaultSearchApplicationOptions, + searchApplicationOptionsParams, + SearchApplicationSearchParams (..), + SearchApplicationListOptions (..), + defaultSearchApplicationListOptions, + searchApplicationListOptionsParams, + SearchApplicationListResponse (..), + searchApplicationNameLens, + searchApplicationTemplateScriptBodyLens, + searchApplicationTemplateScriptParamsLens, + searchApplicationTemplateScriptLangLens, + searchApplicationTemplateScriptOptionsLens, + searchApplicationTemplateScriptLens, + searchApplicationIndicesLens, + searchApplicationAnalyticsCollectionNameLens, + searchApplicationTemplateLens, + searchApplicationInfoNameLens, + searchApplicationInfoIndicesLens, + searchApplicationInfoAnalyticsCollectionNameLens, + searchApplicationInfoTemplateLens, + searchApplicationInfoUpdatedAtMillisLens, + searchApplicationSearchParamsParamsLens, + searchApplicationPutResponseResultLens, + searchApplicationPutOptionsCreateLens, + searchApplicationOptionsTypedKeysLens, + searchApplicationListOptionsQLens, + searchApplicationListOptionsFromLens, + searchApplicationListOptionsSizeLens, + searchApplicationListResponseCountLens, + searchApplicationListResponseResultsLens, + + -- * Terms Enum + TermValue (..), + TermsEnumRequest (..), + defaultTermsEnumRequest, + TermsEnumOptions (..), + defaultTermsEnumOptions, + termsEnumOptionsParams, + TermsEnumResponse (..), + termsEnumRequestFieldLens, + termsEnumRequestStringLens, + termsEnumRequestSizeLens, + termsEnumRequestTimeoutLens, + termsEnumRequestCaseInsensitiveLens, + termsEnumRequestIndexFilterLens, + termsEnumRequestSearchAfterLens, + teoAllowNoIndicesLens, + teoExpandWildcardsLens, + teoIgnoreUnavailableLens, + termsEnumResponseShardsLens, + termsEnumResponseTermsLens, + termsEnumResponseCompleteLens, + + -- * Streams (ES 9.1+, experimental) + StreamName (..), + unStreamName, + StreamStatus (..), + streamStatusEnabledLens, + StreamsStatusResponse (..), + streamsStatusResponseLens, + streamStatusFor, + GetStreamsStatusOptions (..), + defaultGetStreamsStatusOptions, + getStreamsStatusOptionsParams, + getStreamsStatusOptionsMasterTimeoutLens, + StreamsActionOptions (..), + defaultStreamsActionOptions, + streamsActionOptionsParams, + streamsActionOptionsMasterTimeoutLens, + streamsActionOptionsTimeoutLens, + + -- * Downsample index (ES 9.x) + SamplingMethod (..), + DownsampleRequest (..), + downsampleRequestFixedIntervalLens, + downsampleRequestSamplingMethodLens, + DownsampleResponse (..), + downsampleResponseAcknowledgedLens, + downsampleResponseShardsAcknowledgedLens, + DownsampleOptions (..), + defaultDownsampleOptions, + downsampleOptionsParams, + downsampleOptionsWaitForActiveShardsLens, + downsampleOptionsMasterTimeoutLens, + downsampleOptionsTimeoutLens, + + -- * Ingest GeoIP / IP-location databases (GA 8.15+) + GeoIpDatabaseId (..), + unGeoIpDatabaseId, + GeoIpMaxmindConfig (..), + geoIpMaxmindConfigAccountIdLens, + GeoIpDatabasePutBody (..), + geoIpDatabasePutBodyNameLens, + geoIpDatabasePutBodyMaxmindLens, + IpLocationDatabasePutBody (..), + ipLocationDatabasePutBodyNameLens, + ipLocationDatabasePutBodyMaxmindLens, + ipLocationDatabasePutBodyIpInfoLens, + GeoIpDatabaseInfo (..), + geoIpDatabaseInfoIdLens, + geoIpDatabaseInfoVersionLens, + geoIpDatabaseInfoModifiedDateMillisLens, + geoIpDatabaseInfoDatabaseLens, + GeoIpDatabasesResponse (..), + geoIpDatabasesResponseDatabasesLens, + GeoIpStats (..), + geoIpStatsSuccessfulDownloadsLens, + geoIpStatsFailedDownloadsLens, + geoIpStatsTotalDownloadTimeLens, + geoIpStatsDatabasesCountLens, + geoIpStatsSkippedUpdatesLens, + geoIpStatsExpiredDatabasesLens, + GeoIpNodeDatabase (..), + geoIpNodeDatabaseNameLens, + GeoIpNodeStats (..), + geoIpNodeStatsDatabasesLens, + geoIpNodeStatsFilesInTempLens, + GeoIpStatsResponse (..), + geoIpStatsResponseStatsLens, + geoIpStatsResponseNodesLens, + + -- * Simulate ingest v2 (experimental 8.12+) + SimulateIngestMergeType (..), + simulateIngestMergeTypeToText, + simulateIngestMergeTypeFromText, + SimulateIngestOptions (..), + defaultSimulateIngestOptions, + simulateIngestOptionsParams, + simulateIngestOptionsPipelineLens, + simulateIngestOptionsMergeTypeLens, + SimulateIngestDoc (..), + simulateIngestDocIdLens, + simulateIngestDocIndexLens, + simulateIngestDocSourceLens, + SimulateIngestRequest (..), + simulateIngestRequestDocsLens, + simulateIngestRequestComponentTemplateSubstitutionsLens, + simulateIngestRequestIndexTemplateSubstitutionsLens, + simulateIngestRequestMappingAdditionLens, + SimulateIngestResponseInner (..), + simulateIngestResponseInnerIdLens, + simulateIngestResponseInnerIndexLens, + simulateIngestResponseInnerSourceLens, + simulateIngestResponseInnerExecutedPipelinesLens, + simulateIngestResponseInnerIgnoredFieldsLens, + simulateIngestResponseInnerErrorLens, + simulateIngestResponseInnerEffectiveMappingLens, + SimulateIngestResponseDoc (..), + simulateIngestResponseDocDocLens, + SimulateIngestResponse (..), + simulateIngestResponseDocsLens, + + -- * Resolve cluster (ES 9) + ResolveClusterResponse (..), + ResolveClusterInfo (..), + ResolveClusterVersion (..), + ResolveClusterOptions (..), + defaultResolveClusterOptions, + resolveClusterOptionsParams, + resolveClusterResponseEntriesLens, + rciConnectedLens, + rciSkipUnavailableLens, + rciMatchingIndicesLens, + rciErrorLens, + rciVersionLens, + rcvBuildFlavorLens, + rcvMinimumIndexCompatibilityVersionLens, + rcvMinimumWireCompatibilityVersionLens, + rcvNumberLens, + rcoExpandWildcardsLens, + rcoIgnoreUnavailableLens, + rcoAllowNoIndicesLens, + rcoIgnoreThrottledLens, + rcoTimeoutLens, + + -- * Health report (ES 9) + HealthReport (..), + HealthReportStatus (..), + healthReportStatusToText, + healthReportStatusFromText, + HealthIndicator (..), + HealthImpact (..), + HealthDiagnosis (..), + DiagnosisAffectedResources (..), + HealthReportOptions (..), + defaultHealthReportOptions, + healthReportOptionsParams, + hrClusterNameLens, + hrStatusLens, + hrIndicatorsLens, + hiStatusLens, + hiSymptomLens, + hiImpactsLens, + hiDiagnosisLens, + hiOtherLens, + himpDescriptionLens, + himpIdLens, + himpImpactAreasLens, + himpSeverityLens, + hdiagIdLens, + hdiagActionLens, + hdiagCauseLens, + hdiagHelpUrlLens, + hdiagAffectedResourcesLens, + darIndicesLens, + darNodesLens, + darSlmPoliciesLens, + darFeatureStatesLens, + darSnapshotRepositoriesLens, + hroVerboseLens, + hroSizeLens, + hroTimeoutLens, + + -- * Features (ES 9) + Feature (..), + FeaturesResponse (..), + ResetFeaturesItem (..), + ResetFeaturesResponse (..), + FeaturesOptions (..), + defaultFeaturesOptions, + featuresOptionsParams, + featureNameLens, + featureDescriptionLens, + featuresResponseFeaturesLens, + rfiFeatureNameLens, + rfiStatusLens, + rfiNameLens, + rfiDescriptionLens, + resetFeaturesResponseFeaturesLens, + foMasterTimeoutLens, + + -- * Migration reindex (POST /_migration/reindex, /_cancel, /_status, /_create_from) + MigrateReindexMode (..), + MigrateReindexSource (..), + MigrateReindexRequest (..), + mkMigrateReindexRequest, + MigrateReindexInProgress (..), + MigrateReindexError (..), + MigrateReindexStatus (..), + CreateIndexFromBody (..), + defaultCreateIndexFromBody, + CreateIndexFromResponse (..), + migrateReindexSourceIndexLens, + migrateReindexRequestSourceLens, + migrateReindexRequestModeLens, + migrateReindexInProgressIndexLens, + migrateReindexInProgressTotalDocCountLens, + migrateReindexInProgressReindexedDocCountLens, + migrateReindexErrorIndexLens, + migrateReindexErrorMessageLens, + migrateReindexStatusStartTimeLens, + migrateReindexStatusStartTimeMillisLens, + migrateReindexStatusCompleteLens, + migrateReindexStatusTotalIndicesInDataStreamLens, + migrateReindexStatusTotalIndicesRequiringUpgradeLens, + migrateReindexStatusSuccessesLens, + migrateReindexStatusInProgressLens, + migrateReindexStatusPendingLens, + migrateReindexStatusErrorsLens, + migrateReindexStatusExceptionLens, + createIndexFromBodyMappingsOverrideLens, + createIndexFromBodySettingsOverrideLens, + createIndexFromBodyRemoveIndexBlocksLens, + createIndexFromResponseAcknowledgedLens, + createIndexFromResponseIndexLens, + createIndexFromResponseShardsAcknowledgedLens, + + -- * ML data frame analytics (X-Pack) + MlDataFrameAnalyticsId (..), + unMlDataFrameAnalyticsId, + MlDataFrameAnalysisType (..), + mlDataFrameAnalysisTypeText, + MlDataFrameAnalyticsState (..), + mlDataFrameAnalyticsStateText, + MlDataFrameAnalyticsSource (..), + defaultMlDataFrameAnalyticsSource, + mlDataFrameAnalyticsSourceIndexLens, + mlDataFrameAnalyticsSourceQueryLens, + mlDataFrameAnalyticsSourceSourceLens, + MlDataFrameAnalyticsDest (..), + defaultMlDataFrameAnalyticsDest, + mlDataFrameAnalyticsDestIndexLens, + mlDataFrameAnalyticsDestResultsFieldLens, + MlDataFrameAnalyticsAnalyzedFields (..), + mlDataFrameAnalyticsAnalyzedFieldsIncludesLens, + mlDataFrameAnalyticsAnalyzedFieldsExcludesLens, + MlDataFrameAnalyticsAnalysis (..), + mlDataFrameAnalyticsAnalysisConfigLens, + MlDataFrameAnalyticsPutBody (..), + defaultMlDataFrameAnalyticsPutBody, + mlDataFrameAnalyticsPutBodySourceLens, + mlDataFrameAnalyticsPutBodyDestLens, + mlDataFrameAnalyticsPutBodyAnalysisLens, + mlDataFrameAnalyticsPutBodyAnalyzedFieldsLens, + mlDataFrameAnalyticsPutBodyDescriptionLens, + mlDataFrameAnalyticsPutBodyModelMemoryLimitLens, + mlDataFrameAnalyticsPutBodyAllowLazyStartLens, + mlDataFrameAnalyticsPutBodyFrequencyLens, + MlDataFrameAnalyticsUpdateBody (..), + defaultMlDataFrameAnalyticsUpdateBody, + mlDataFrameAnalyticsUpdateBodyDescriptionLens, + mlDataFrameAnalyticsUpdateBodyModelMemoryLimitLens, + mlDataFrameAnalyticsUpdateBodyAnalysisLens, + mlDataFrameAnalyticsUpdateBodySourceLens, + mlDataFrameAnalyticsUpdateBodyDestLens, + mlDataFrameAnalyticsUpdateBodyAnalyzedFieldsLens, + MlDataFrameAnalyticsPreviewRequest (..), + mlDataFrameAnalyticsPreviewRequestConfigLens, + MlDataFrameAnalyticsOptions (..), + defaultMlDataFrameAnalyticsOptions, + mlDataFrameAnalyticsOptionsParams, + mlDataFrameAnalyticsOptionsForceLens, + mlDataFrameAnalyticsOptionsFromLens, + mlDataFrameAnalyticsOptionsSizeLens, + mlDataFrameAnalyticsOptionsAllowLazyStartLens, + mlDataFrameAnalyticsOptionsVerboseLens, + mlDataFrameAnalyticsOptionsTimeoutLens, + MlDataFrameAnalyticsDocument (..), + mlDataFrameAnalyticsDocumentIdLens, + mlDataFrameAnalyticsDocumentStateLens, + mlDataFrameAnalyticsDocumentAnalysisTypeLens, + mlDataFrameAnalyticsDocumentCreateTimeLens, + mlDataFrameAnalyticsDocumentVersionLens, + mlDataFrameAnalyticsDocumentSourceLens, + mlDataFrameAnalyticsDocumentDestLens, + mlDataFrameAnalyticsDocumentAnalysisLens, + mlDataFrameAnalyticsDocumentExtrasLens, + MlDataFrameAnalyticsGetResponse (..), + mlDataFrameAnalyticsGetResponseCountLens, + mlDataFrameAnalyticsGetResponseAnalyticsLens, + MlDataFrameAnalyticsStats (..), + mlDataFrameAnalyticsStatsIdLens, + mlDataFrameAnalyticsStatsStateLens, + mlDataFrameAnalyticsStatsAnalysisTypeLens, + mlDataFrameAnalyticsStatsExtrasLens, + MlDataFrameAnalyticsStatsResponse (..), + mlDataFrameAnalyticsStatsResponseCountLens, + mlDataFrameAnalyticsStatsResponseStatsLens, + MlDataFrameAnalyticsPreviewRow (..), + MlDataFrameAnalyticsPreviewResponse (..), + mlDataFrameAnalyticsPreviewResponseRowsLens, + + -- * ML trained models (X-Pack) + MlTrainedModelId (..), + unMlTrainedModelId, + MlTrainedModelPutBody (..), + defaultMlTrainedModelPutBody, + mlTrainedModelPutBodyInferenceConfigLens, + mlTrainedModelPutBodyCompressedDefinitionLens, + mlTrainedModelPutBodyDefinitionLens, + mlTrainedModelPutBodyDescriptionLens, + mlTrainedModelPutBodyTagsLens, + mlTrainedModelPutBodyMetadataLens, + MlTrainedModelUpdateBody (..), + defaultMlTrainedModelUpdateBody, + mlTrainedModelUpdateBodyDescriptionLens, + mlTrainedModelUpdateBodyDeprecatedLens, + mlTrainedModelUpdateBodyMetadataLens, + MlTrainedModelInferRequest (..), + mlTrainedModelInferRequestDocsLens, + MlTrainedModelOptions (..), + defaultMlTrainedModelOptions, + mlTrainedModelOptionsParams, + mlTrainedModelOptionsFromLens, + mlTrainedModelOptionsSizeLens, + mlTrainedModelOptionsDecompressDefinitionLens, + mlTrainedModelOptionsIncludeDefinitionLens, + mlTrainedModelOptionsWaitForCompletionLens, + mlTrainedModelOptionsPriorityLens, + mlTrainedModelOptionsTimeoutLens, + mlTrainedModelOptionsForceLens, + mlTrainedModelOptionsThreadsLens, + MlTrainedModelConfig (..), + mlTrainedModelConfigModelIdLens, + mlTrainedModelConfigCreatedByLens, + mlTrainedModelConfigVersionLens, + mlTrainedModelConfigDescriptionLens, + mlTrainedModelConfigDeprecatedLens, + mlTrainedModelConfigInferenceConfigLens, + mlTrainedModelConfigExtrasLens, + MlTrainedModelsResponse (..), + mlTrainedModelsResponseCountLens, + mlTrainedModelsResponseConfigsLens, + MlTrainedModelStats (..), + mlTrainedModelStatsModelIdLens, + mlTrainedModelStatsExtrasLens, + MlTrainedModelStatsResponse (..), + mlTrainedModelStatsResponseCountLens, + mlTrainedModelStatsResponseStatsLens, + MlTrainedModelDefinition (..), + mlTrainedModelDefinitionModelIdLens, + mlTrainedModelDefinitionTotalDefinitionLengthLens, + mlTrainedModelDefinitionDefinitionLens, + mlTrainedModelDefinitionExtrasLens, + MlTrainedModelInferResponse (..), + mlTrainedModelInferResponseBodyLens, + + -- * ML anomaly jobs (X-Pack) + MlJobId (..), + unMlJobId, + MlModelSnapshotId (..), + unMlModelSnapshotId, + MlJobState (..), + mlJobStateText, + MlAnomalyResultType (..), + mlAnomalyResultTypeSegment, + MlAnomalyJob (..), + defaultMlAnomalyJob, + mlAnomalyJobAnalysisConfigLens, + mlAnomalyJobDataDescriptionLens, + mlAnomalyJobAnalysisLimitsLens, + mlAnomalyJobBackgroundPersistenceLens, + mlAnomalyJobDescriptionLens, + mlAnomalyJobGroupsLens, + mlAnomalyJobModelPlotConfigLens, + mlAnomalyJobResultsIndexNameLens, + mlAnomalyJobCustomSettingsLens, + MlAnomalyJobUpdate (..), + defaultMlAnomalyJobUpdate, + mlAnomalyJobUpdateDescriptionLens, + mlAnomalyJobUpdateAnalysisLimitsLens, + mlAnomalyJobUpdateAnalysisConfigLens, + mlAnomalyJobUpdateGroupsLens, + mlAnomalyJobUpdateModelPlotConfigLens, + mlAnomalyJobUpdateCustomSettingsLens, + MlForecastOptions (..), + defaultMlForecastOptions, + MlFlushOptions (..), + defaultMlFlushOptions, + MlAnomalyJobOptions (..), + defaultMlAnomalyJobOptions, + mlAnomalyJobOptionsParams, + MlAnomalyJobDocument (..), + mlAnomalyJobDocumentIdLens, + mlAnomalyJobDocumentStateLens, + mlAnomalyJobDocumentJobTypeLens, + mlAnomalyJobDocumentCreateTimeLens, + mlAnomalyJobDocumentExtrasLens, + MlAnomalyJobsResponse (..), + mlAnomalyJobsResponseCountLens, + mlAnomalyJobsResponseJobsLens, + MlAnomalyJobStats (..), + mlAnomalyJobStatsJobIdLens, + mlAnomalyJobStatsStateLens, + mlAnomalyJobStatsExtrasLens, + MlAnomalyJobStatsResponse (..), + mlAnomalyJobStatsResponseCountLens, + mlAnomalyJobStatsResponseStatsLens, + MlForecastResponse (..), + mlForecastResponseAcknowledgedLens, + mlForecastResponseForecastIdLens, + MlFlushResponse (..), + mlFlushResponseAcknowledgedLens, + mlFlushResponseLastFinalizedBucketEndLens, + MlValidateResponse (..), + mlValidateResponseBodyLens, + MlAnomalyJobResults (..), + mlAnomalyJobResultsCountLens, + mlAnomalyJobResultsBodyLens, + MlModelSnapshotDocument (..), + mlModelSnapshotDocumentIdLens, + mlModelSnapshotDocumentExtrasLens, + MlModelSnapshotsResponse (..), + mlModelSnapshotsResponseCountLens, + mlModelSnapshotsResponseSnapshotsLens, + MlRevertSnapshotResponse (..), + mlRevertSnapshotResponseModelLens, + mlRevertSnapshotResponseModelSnapshotIdLens, + mlRevertSnapshotResponseExtrasLens, + + -- * ML datafeeds (X-Pack) + MlDatafeedId (..), + unMlDatafeedId, + MlDatafeed (..), + defaultMlDatafeed, + mlDatafeedJobIdLens, + mlDatafeedIndicesLens, + mlDatafeedQueryLens, + mlDatafeedAggregationsLens, + mlDatafeedChunkingConfigLens, + mlDatafeedFrequencyLens, + mlDatafeedDelayedDataCheckConfigLens, + mlDatafeedIndicesOptionsLens, + mlDatafeedScrollSizeLens, + mlDatafeedRuntimeMappingsLens, + MlDatafeedUpdate (..), + defaultMlDatafeedUpdate, + mlDatafeedUpdateIndicesLens, + mlDatafeedUpdateQueryLens, + mlDatafeedUpdateAggregationsLens, + mlDatafeedUpdateChunkingConfigLens, + mlDatafeedUpdateFrequencyLens, + mlDatafeedUpdateDelayedDataCheckConfigLens, + mlDatafeedUpdateIndicesOptionsLens, + mlDatafeedUpdateScrollSizeLens, + mlDatafeedUpdateRuntimeMappingsLens, + MlDatafeedOptions (..), + defaultMlDatafeedOptions, + mlDatafeedOptionsParams, + MlDatafeedDocument (..), + mlDatafeedDocumentIdLens, + mlDatafeedDocumentJobIdLens, + mlDatafeedDocumentExtrasLens, + MlDatafeedsResponse (..), + mlDatafeedsResponseCountLens, + mlDatafeedsResponseDatafeedsLens, + MlDatafeedPreviewResponse (..), + mlDatafeedPreviewResponseBodyLens, + + -- * ML filters and calendars (X-Pack) + MlFilterId (..), + unMlFilterId, + MlFilter (..), + defaultMlFilter, + mlFilterDescriptionLens, + mlFilterItemsLens, + MlFilterDocument (..), + mlFilterDocumentIdLens, + mlFilterDocumentDescriptionLens, + mlFilterDocumentItemsLens, + mlFilterDocumentExtrasLens, + MlFiltersResponse (..), + mlFiltersResponseCountLens, + mlFiltersResponseFiltersLens, + MlCalendarId (..), + unMlCalendarId, + MlCalendar (..), + defaultMlCalendar, + mlCalendarDescriptionLens, + MlCalendarDocument (..), + mlCalendarDocumentIdLens, + mlCalendarDocumentDescriptionLens, + mlCalendarDocumentExtrasLens, + MlCalendarsResponse (..), + mlCalendarsResponseCountLens, + mlCalendarsResponseCalendarsLens, + MlScheduledEvents (..), + mlScheduledEventsEventsLens, + MlScheduledEventsResponse (..), + mlScheduledEventsResponseBodyLens, + ) +where + +import Database.Bloodhound.Common.Types as Reexport +import Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.DataStream as Reexport +import Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.EventQueryLanguage +import Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.TermsEnum +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.EsQueryViews +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Inference +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.MigrationReindex +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.QueryRules +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.SearchApplications +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.Downsample +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.EsQueryLanguage +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.Features +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.HealthReport +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.IngestGeoIp +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlAnomalyJobs +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlDataFrameAnalytics +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlDatafeeds +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlFiltersCalendars +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlTrainedModels +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.PointInTime +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.ResolveCluster +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.SimulateIngest +import Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.Streams diff --git a/src/Database/Bloodhound/Internal/Client/BHRequest.hs b/src/Database/Bloodhound/Internal/Client/BHRequest.hs --- a/src/Database/Bloodhound/Internal/Client/BHRequest.hs +++ b/src/Database/Bloodhound/Internal/Client/BHRequest.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Database.Bloodhound.Client @@ -51,6 +52,9 @@ EsProtocolException (..), EsResult (..), EsResultFound (..), + esResultFoundSeqNoLens, + esResultFoundPrimaryTermLens, + esResultFoundRoutingLens, EsError (..), -- * Common results @@ -60,25 +64,25 @@ ) where -import qualified Blaze.ByteString.Builder as BB +import Blaze.ByteString.Builder qualified as BB import Control.Applicative as A import Control.Monad import Control.Monad.Catch import Data.Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL import Data.Ix import Data.Monoid import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Typeable +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Database.Bloodhound.Internal.Client.Doc +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens) import GHC.Exts import Network.HTTP.Client -import qualified Network.HTTP.Types.Method as NHTM -import qualified Network.HTTP.Types.Status as NHTS -import qualified Network.HTTP.Types.URI as NHTU +import Network.HTTP.Types.Method qualified as NHTM +import Network.HTTP.Types.Status qualified as NHTS +import Network.HTTP.Types.URI qualified as NHTU import Prelude hiding (filter, head) -- | 'Server' is used with the client functions to point at the ES instance @@ -255,18 +259,50 @@ -- categories. If they don't, a 'EsProtocolException' will be -- thrown. If you encounter this, please report the full body it -- reports along with your Elasticsearch version. +-- +-- /Empty-body 2xx handling/: some cluster endpoints (verified: +-- @/_cluster/voting_config_exclusions@ POST and DELETE on ES 7.17) +-- return HTTP 200 with a genuinely empty body (Content-Length: 0) +-- rather than the @{\"acknowledged\":true}@ envelope their declared +-- 'Acknowledged' return type implies. To tolerate that wire shape, +-- an empty body on a 2xx response is normalised to the JSON value +-- @null@ before the decoder is invoked. Only types whose 'FromJSON' +-- instance accepts @null@ are affected — in practice just +-- 'Acknowledged', whose instance maps @null@ to 'Acknowledged' +-- @True@ (a 200 OK with no body IS the acknowledgement per the +-- server's documented semantics). All other types keep the +-- historical behaviour: their strict 'FromJSON' instances reject +-- @null@, so the empty body surfaces as an 'EsProtocolException' as +-- before. +-- +-- Note: the OpenSearch k-NN\/Neural warmup and clear-cache endpoints +-- were /suspected/ to need this handling but turn out to have +-- separate response-shape bugs (wrong method, wrong response type) +-- tracked by the pending live tests in @Test.KnnWarmupSpec@, +-- @Test.KnnClearCacheSpec@, @Test.NeuralWarmupSpec@, and +-- @Test.NeuralClearCacheSpec@. They do not return empty-body 200 and +-- are not covered by this normalisation. parseEsResponse :: (FromJSON body) => BHResponse parsingContext body -> Either EsProtocolException (ParsedEsResponse body) parseEsResponse response - | isSuccess response = case eitherDecode body of + | isSuccess response = case eitherDecode normalisedBody of Right a -> return (Right a) Left err -> tryParseError err | otherwise = tryParseError "Non-200 status code" where body = responseBody $ getResponse response + -- Normalise a genuinely empty body to the literal JSON @null@ + -- before decoding. Only affects types whose 'FromJSON' accepts + -- @null@ (e.g. 'Acknowledged'); strict types still reject it and + -- surface the original parse failure below. Error envelopes always + -- carry content, so 'tryParseError' decodes the raw 'body' rather + -- than 'normalisedBody' — a hypothetical empty 4xx body would just + -- fail to decode as 'EsError' and fall through to the original + -- error in 'explode'. + normalisedBody = if BL.null body then "null" else body tryParseError originalError = case eitherDecode body of Right e -> return (Left e) @@ -342,9 +378,18 @@ -- | 'EsResultFound' contains the document and its metadata inside of an -- 'EsResult' when the document was successfully found. +-- +-- @_seq_no@, @_primary_term@, and @_routing@ are 'Maybe' because they +-- are not always present in every response shape Bloodhound parses as +-- an 'EsResultFound' (e.g. test fixtures, the @_source=false@ case, +-- older protocol variants). Real ES7+\/OpenSearch @GET _doc@ responses +-- always include @_seq_no@ and @_primary_term@ on found documents. data EsResultFound a = EsResultFound { _version :: DocVersion, - _source :: a + _source :: a, + _seq_no :: Maybe Int, + _primary_term :: Maybe Int, + _routing :: Maybe Text } deriving stock (Eq, Show) @@ -353,7 +398,17 @@ found <- v .:? "found" .!= False fr <- if found - then parseJSON jsonVal + -- 'optional' swallows ANY parse failure of 'EsResultFound', + -- not just the missing @_source@ case. The primary trigger is + -- the caller sending @_source=false@ (or the equivalent + -- per-document filter in mget), which causes the @_source@ key + -- to be absent from the response. In that case the document + -- /was/ found but no source is available, so 'foundResult' is + -- 'Nothing'. If the caller's 'FromJSON' instance is malformed + -- or a future ES version drops @_version@, the parse failure + -- is also swallowed here — a deliberate tradeoff for keeping + -- @'_source' :: a@ non-'Maybe' in 'EsResultFound'. + then A.optional (parseJSON jsonVal) else return Nothing EsResult <$> v @@ -372,8 +427,23 @@ .: "_version" <*> v .: "_source" + <*> v + .:? "_seq_no" + <*> v + .:? "_primary_term" + <*> v + .:? "_routing" parseJSON _ = empty +esResultFoundSeqNoLens :: Lens' (EsResultFound a) (Maybe Int) +esResultFoundSeqNoLens = lens _seq_no (\x y -> x {_seq_no = y}) + +esResultFoundPrimaryTermLens :: Lens' (EsResultFound a) (Maybe Int) +esResultFoundPrimaryTermLens = lens _primary_term (\x y -> x {_primary_term = y}) + +esResultFoundRoutingLens :: Lens' (EsResultFound a) (Maybe Text) +esResultFoundRoutingLens = lens _routing (\x y -> x {_routing = y}) + -- | 'EsError' is the generic type that will be returned when there was a -- problem. If you can't parse the expected response, its a good idea to -- try parsing this. @@ -381,7 +451,7 @@ { errorStatus :: Maybe Int, errorMessage :: Text } - deriving stock (Eq, Show, Typeable) + deriving stock (Eq, Show) {-# DEPRECATED errorStatus "deprecated since ElasticSearch 6.0" #-} @@ -394,26 +464,50 @@ mempty = EsError Nothing "Monoid value, shouldn't happen" instance FromJSON EsError where - parseJSON (Object v) = p1 <|> p2 <|> p3 + parseJSON (Object v) = p1 <|> p2 <|> p3 <|> p4 where + -- Shape: {"status": , "error": ""} p1 = EsError <$> v .:? "status" <*> v .: "error" - p2 = - EsError - <$> v .:? "status" - <*> (v .: "error" >>= (.: "reason")) + -- Shape: {"status": , "error": {"reason": ..., "type": ...}} + -- The reason field is fetched loosely because some servers (e.g. + -- OpenSearch 1.3 on @GET /_script_language@) emit a 500 with + -- @reason: null@ for an internal null_pointer_exception; we fall + -- back to @type@, then a placeholder, so the decode yields a + -- proper 'EsError' rather than an 'EsProtocolException'. + p2 = do + status <- v .:? "status" + err <- v .: "error" + reason <- err .:? "reason" + typ <- err .:? "type" + return $ EsError status $ case (reason, typ) of + (Just r, _) -> r + (Nothing, Just t) -> t + _ -> "unknown error" + -- Shape: {"failures": [{"status": , "cause": {...}}]} + -- Same null-tolerant treatment of @cause.reason@, falling back + -- to @cause.type@. p3 = do failures <- v .: "failures" -- This is a bit imprecise: We're only using the first error, ignoring -- all others. case failures of - (failure : _) -> - EsError - <$> failure .:? "status" - <*> (failure .: "cause" >>= (.: "reason")) + (failure : _) -> do + status <- failure .:? "status" + cause <- failure .: "cause" + reason <- cause .:? "reason" + typ <- cause .:? "type" + return $ EsError status $ case (reason, typ) of + (Just r, _) -> r + (Nothing, Just t) -> t + _ -> "unknown failure" [] -> fail "could not find field `failure`" + -- Catch-all so that future/unknown error shapes still surface as + -- a proper 'EsError' rather than bubbling up as an + -- 'EsProtocolException' from 'parseEsResponse'. + p4 = EsError <$> v .:? "status" <*> pure "unrecognised error body" parseJSON _ = empty -- | 'EsProtocolException' will be thrown if Bloodhound cannot parse a response @@ -434,10 +528,19 @@ newtype Acknowledged = Acknowledged {isAcknowledged :: Bool} deriving stock (Eq, Show) +-- | Decodes @{"acknowledged": }@ as usual. Also accepts the +-- JSON value @null@, mapping it to 'Acknowledged' @True@: the ES +-- @/_cluster/voting_config_exclusions@ POST and DELETE endpoints +-- (at least on ES 7.17; see bead @bloodhound-vvj@) return HTTP 200 +-- with an empty body for their 'Acknowledged'-typed responses, and +-- 'parseEsResponse' normalises such empty bodies to @null@ before +-- invoking this instance. A 200 OK with no body IS the +-- acknowledgement per the server's documented semantics; treating +-- @null@ as @True@ matches that wire shape without affecting the +-- well-formed @{"acknowledged": }@ path. instance FromJSON Acknowledged where - parseJSON = - withObject "Acknowledged" $ - fmap Acknowledged . (.: "acknowledged") + parseJSON Null = return (Acknowledged True) + parseJSON v = withObject "Acknowledged" (fmap Acknowledged . (.: "acknowledged")) v newtype Accepted = Accepted {isAccepted :: Bool} deriving stock (Eq, Show) diff --git a/src/Database/Bloodhound/Internal/Client/Doc.hs b/src/Database/Bloodhound/Internal/Client/Doc.hs --- a/src/Database/Bloodhound/Internal/Client/Doc.hs +++ b/src/Database/Bloodhound/Internal/Client/Doc.hs @@ -65,20 +65,12 @@ -- a search result. InternalVersion DocVersion | -- | Use your own version numbering. Only index - -- the document if the version is strictly higher - -- OR the document doesn't exist. The given - -- version will be used as the new version number - -- for the stored document. N.B. All updates must - -- increment this number, meaning there is some - -- global, external ordering of updates. - ExternalGT ExternalDocVersion - | -- | Use your own version numbering. Only index -- the document if the version is equal or higher -- than the stored version. Will succeed if there -- is no existing document. The given version will - -- be used as the new version number for the - -- stored document. Use with care, as this could - -- result in data loss. + -- be used as the new version number + -- for the stored document. Use with care, as this + -- could result in data loss. ExternalGTE ExternalDocVersion | -- | The document will always be indexed and the -- given version will be the new version. This is diff --git a/src/Database/Bloodhound/Internal/Utils/Imports.hs b/src/Database/Bloodhound/Internal/Utils/Imports.hs --- a/src/Database/Bloodhound/Internal/Utils/Imports.hs +++ b/src/Database/Bloodhound/Internal/Utils/Imports.hs @@ -33,7 +33,7 @@ import Control.Monad.Writer as X (MonadWriter) import Data.Aeson as X import Data.Aeson.Key as X -import qualified Data.Aeson.KeyMap as X +import Data.Aeson.KeyMap qualified as X import Data.Aeson.Types as X ( Pair, Parser, @@ -43,7 +43,7 @@ typeMismatch, ) import Data.Bifunctor as X (first) -import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Lazy qualified as BL import Data.Char as X (isNumber) import Data.Hashable as X (Hashable) import Data.List as X (foldl', intercalate, nub) @@ -57,13 +57,13 @@ import Data.Scientific as X (Scientific) import Data.Semigroup as X (Semigroup (..)) import Data.Text as X (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Time.Calendar as X (Day (..), showGregorian) import Data.Time.Clock as X (NominalDiffTime, UTCTime) import Data.Time.Clock.POSIX as X -import qualified Data.Traversable as DT -import qualified Data.Vector as V -import qualified Network.HTTP.Types.Method as NHTM +import Data.Traversable qualified as DT +import Data.Vector qualified as V +import Network.HTTP.Types.Method qualified as NHTM import Optics.Core as X ( Lens', Prism', diff --git a/src/Database/Bloodhound/Internal/Utils/Requests.hs b/src/Database/Bloodhound/Internal/Utils/Requests.hs --- a/src/Database/Bloodhound/Internal/Utils/Requests.hs +++ b/src/Database/Bloodhound/Internal/Utils/Requests.hs @@ -1,9 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + module Database.Bloodhound.Internal.Utils.Requests where -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as L +import Data.Aeson (FromJSON, eitherDecode) +import Data.ByteString.Lazy.Char8 qualified as L +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Text.Encoding.Error (lenientDecode) import Database.Bloodhound.Internal.Client.BHRequest -import qualified Network.HTTP.Types.Method as NHTM +import Database.Bloodhound.Internal.Utils.Imports (showText) +import Network.HTTP.Client (responseBody, responseStatus) +import Network.HTTP.Types.Method qualified as NHTM +import Network.HTTP.Types.Status qualified as NHTS import Prelude hiding (filter, head) delete :: @@ -25,6 +35,21 @@ BHRequest contextualized body get = mkSimpleRequest NHTM.methodGet +-- | 'getWithBody' is a GET request that carries a request body. Most +-- Elasticsearch endpoints use GET without a body (and 'get' for +-- those), but a handful — notably @GET /_render/template@ and +-- @GET /_render/template\/{id}@ — require the request parameters to +-- be sent in a body even though the method is GET. Use 'get' for +-- body-less GETs and 'getWithBody' for these body-bearing GETs; for +-- symmetry with the other verb helpers it is a thin specialisation of +-- 'mkFullRequest'. +getWithBody :: + (ParseBHResponse contextualized, FromJSON body) => + Endpoint -> + L.ByteString -> + BHRequest contextualized body +getWithBody = mkFullRequest NHTM.methodGet + head' :: (ParseBHResponse contextualized, FromJSON body) => Endpoint -> @@ -44,3 +69,143 @@ L.ByteString -> BHRequest contextualized body post = mkFullRequest NHTM.methodPost + +-- | 'postNoBody' is a POST request that carries no request body. Most +-- Elasticsearch\/OpenSearch POST endpoints expect a body (and 'post' for +-- those), but a handful — notably the Alerting plugin +-- @POST /_plugins/_alerting/monitors/{monitor_id}/_execute@ — take their +-- arguments as query-string parameters and document an empty body. Use +-- 'post' for body-bearing POSTs and 'postNoBody' for these; for +-- symmetry with the other verb helpers it is a thin specialisation of +-- 'mkSimpleRequest'. +postNoBody :: + (ParseBHResponse contextualized, FromJSON body) => + Endpoint -> + BHRequest contextualized body +postNoBody = mkSimpleRequest NHTM.methodPost + +-- | Like 'get', but for endpoints that return a non-JSON, plain-text body +-- (e.g. @GET /_nodes/hot_threads@). The response body is decoded as +-- UTF-8 'Text'. Unlike 'get', this helper is pinned to 'StatusDependant' +-- because the parser branches on the HTTP status code. On non-2xx +-- responses, the body is first parsed as a JSON 'EsError' (ES error +-- format); if that also fails, a synthetic 'EsError' is produced +-- carrying the HTTP status code and the (length-bounded) raw body. +getText :: + Endpoint -> + BHRequest StatusDependant Text +getText endpoint = + BHRequest + { bhRequestMethod = NHTM.methodGet, + bhRequestEndpoint = endpoint, + bhRequestBody = Nothing, + bhRequestQueryStrings = [], + bhRequestParser = parseTextBody + } + +-- | Parser used by 'getText'. Decodes the raw body as UTF-8 'Text' on +-- success (leniently — invalid byte sequences become U+FFFD rather +-- than throwing, since the body is a diagnostic report) and routes +-- non-2xx responses through the standard 'EsError' path, falling back +-- to a status-only error carrying a bounded prefix of the raw body +-- when the body is not JSON. +parseTextBody :: + BHResponse parsingContext Text -> + Either EsProtocolException (ParsedEsResponse Text) +parseTextBody resp + | isSuccess resp = + Right (Right (TE.decodeUtf8With lenientDecode strictBody)) + | otherwise = + case eitherDecode body of + Right e -> Right (Left e) + Left aesonErr -> + Right $ + Left $ + EsError + { errorStatus = Just statusCode, + errorMessage = + "Non-2xx (" + <> showText statusCode + <> ") with non-JSON body (aeson: " + <> T.pack aesonErr + <> "): " + <> T.take maxErrorBodyPrefix (TE.decodeUtf8With lenientDecode strictBody) + } + where + body = responseBody (getResponse resp) + strictBody = L.toStrict body + statusCode = NHTS.statusCode (responseStatus (getResponse resp)) + maxErrorBodyPrefix = 512 + +-- | Like 'getWithBody', but for endpoints whose success response body +-- is /binary/ rather than JSON — notably +-- @GET \/{index}\/_mvt\/{field}\/{zoom}\/{x}\/{y}@, which returns a +-- Mapbox Vector Tile encoded as a Google Protobuf (PBF). The success +-- body is returned verbatim as a lazy 'L.ByteString'; non-2xx +-- responses are routed through the standard 'EsError' path (the server +-- returns JSON errors), falling back to a status-only error carrying a +-- bounded prefix of the raw body when the body is not JSON. Pinned to +-- 'StatusDependant' for the same reason as 'getText'. +getByteStringWithBody :: + Endpoint -> + L.ByteString -> + BHRequest StatusDependant L.ByteString +getByteStringWithBody endpoint body = + BHRequest + { bhRequestMethod = NHTM.methodGet, + bhRequestEndpoint = endpoint, + bhRequestBody = Just body, + bhRequestQueryStrings = [], + bhRequestParser = parseByteStringBody + } + +-- | Like 'getByteStringWithBody', but a POST. The success response body is +-- returned verbatim as a lazy 'L.ByteString'; non-2xx responses are routed +-- through the standard 'EsError' path via 'parseByteStringBody'. Used by +-- endpoints whose success body is a non-JSON stream — notably the inference +-- streaming endpoints (@POST \/_inference\/...\/_stream@), which emit an +-- opaque @_types.StreamResult@ stream that callers parse themselves. +postRaw :: + Endpoint -> + L.ByteString -> + BHRequest StatusDependant L.ByteString +postRaw endpoint body = + BHRequest + { bhRequestMethod = NHTM.methodPost, + bhRequestEndpoint = endpoint, + bhRequestBody = Just body, + bhRequestQueryStrings = [], + bhRequestParser = parseByteStringBody + } + +-- | Parser used by 'getByteStringWithBody'. Returns the raw response +-- body on 2xx; on non-2xx, attempts to decode the body as a JSON +-- 'EsError' (the server's standard error shape), falling back to a +-- synthetic 'EsError' carrying the HTTP status and a bounded prefix of +-- the raw body when the body is not JSON. +parseByteStringBody :: + BHResponse parsingContext L.ByteString -> + Either EsProtocolException (ParsedEsResponse L.ByteString) +parseByteStringBody resp + | isSuccess resp = Right (Right body) + | otherwise = + case eitherDecode body of + Right e -> Right (Left e) + Left aesonErr -> + Right $ + Left $ + EsError + { errorStatus = Just statusCode, + errorMessage = + "Non-2xx (" + <> showText statusCode + <> ") with non-JSON body (aeson: " + <> T.pack aesonErr + <> "): " + <> T.take maxErrorBodyPrefix (TE.decodeUtf8With lenientDecode strictBody) + } + where + body = responseBody (getResponse resp) + strictBody = L.toStrict body + statusCode = NHTS.statusCode (responseStatus (getResponse resp)) + maxErrorBodyPrefix = 512 diff --git a/src/Database/Bloodhound/Internal/Utils/SSE.hs b/src/Database/Bloodhound/Internal/Utils/SSE.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Utils/SSE.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Database.Bloodhound.Internal.Utils.SSE +-- Description : Server-Sent Events parser over an http-client BodyReader +-- +-- A small, dependency-light Server-Sent Events (SSE) parser that pulls +-- bytes incrementally from a 'Network.HTTP.Client.BodyReader' (the +-- streaming response body exposed by 'Database.Bloodhound.Client.Cluster.withStreamingResponse'). +-- It is /not/ a general-purpose SSE server; it is the minimum needed +-- to consume SSE-style responses from the OpenSearch ML Commons +-- Execute Stream Agent API +-- (@POST /_plugins/_ml/agents/{agent_id}/_execute/stream@), whose +-- wire format is one @data: \\n\\n@ frame per agent chunk. +-- +-- The parser implements the subset of the SSE specification that +-- matters for parsing a byte stream into events: +-- +-- * Lines are terminated by @\\n@, optionally with a preceding @\\r@. +-- * An event is terminated by a blank line (the canonical @\\n\\n@ +-- separator, tolerating @\\r\\n\\r\\n@). +-- * Lines starting with @:@ are comments and are ignored. +-- * A line of the form @field: value@ sets the named field; the +-- leading single space after the colon is stripped (per spec), +-- further spaces are preserved. A line with no colon sets the +-- field to the empty string with an empty value. +-- * Multiple @data:@ lines within a single event are joined with +-- @\\n@ to form the final 'sseData' (per spec). +-- * The @event@, @id@, and @retry@ fields are parsed (so a future +-- endpoint that emits them round-trips), but the Execute Stream +-- Agent API only ever emits @data:@. +-- +-- The parser yields 'SSEEvent' values one at a time; the caller +-- decides when to stop (e.g. on a chunk whose JSON carries an +-- @is_last@ flag, or an AG-UI @RUN_FINISHED@ discriminator). There is +-- no synthetic end-of-stream event: when the 'BodyReader' is +-- exhausted, 'readSSEEvent' returns 'Nothing'. +module Database.Bloodhound.Internal.Utils.SSE + ( SSEEvent (..), + SSEState, + newSSEState, + readSSEEvent, + sseSource, + ) +where + +import Conduit (ConduitT, MonadResource, liftIO, yield) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Text.Encoding.Error (lenientDecode) +import Network.HTTP.Client (BodyReader, brRead) +import Numeric (readDec) +import Prelude hiding (head, tail) + +-- | A single parsed Server-Sent Event. Mirrors the fields the spec +-- defines; 'sseEvent' is 'Nothing' when no @event:@ line was present +-- (the default-event case, which is what the Execute Stream Agent API +-- always produces). +data SSEEvent = SSEEvent + { sseEvent :: Maybe Text, + sseData :: Text, + sseId :: Maybe Text, + sseRetry :: Maybe Int + } + deriving stock (Eq, Show) + +-- | The empty event used to begin accumulating a new frame. +emptyEvent :: SSEEvent +emptyEvent = SSEEvent Nothing "" Nothing Nothing + +-- | Whether an accumulated event carries any content (at least one +-- field was set). A blank-line terminator on an empty event is a +-- keep-alive heartbeat; the parser still dispatches such events so +-- the caller can observe heartbeats if it cares, but at end-of-stream +-- a trailing empty event is dropped. +eventHasContent :: SSEEvent -> Bool +eventHasContent ev = + not (T.null (sseData ev)) + || isJust (sseEvent ev) + || isJust (sseId ev) + || isJust (sseRetry ev) + +-- | Mutable parser state: the unconsumed byte buffer (leftover bytes +-- after the last dispatched event) paired with the underlying +-- 'BodyReader'. Carrying the buffer in an 'IORef' lets 'readSSEEvent' +-- retain leftover bytes across calls without re-reading from the +-- network. +data SSEState = SSEState + { sseStateBuffer :: IORef ByteString, + sseStateReader :: BodyReader + } + +-- | Allocate a fresh parser state over a 'BodyReader'. +newSSEState :: BodyReader -> IO SSEState +newSSEState reader = SSEState <$> newIORef BS.empty <*> pure reader + +-- | Pull the next complete SSE event from the stream. Returns +-- 'Nothing' when the body is fully consumed and no partial event with +-- content remains. See module docs for the parsing rules. +readSSEEvent :: SSEState -> IO (Maybe SSEEvent) +readSSEEvent st = go emptyEvent + where + go event = do + buf <- readIORef (sseStateBuffer st) + case breakLine buf of + Just (line, rest) -> do + writeIORef (sseStateBuffer st) rest + case applyLine line event of + Dispatch ev -> pure (Just ev) + Continue ev' -> go ev' + Nothing -> do + chunk <- brRead (sseStateReader st) + if BS.null chunk + then do + -- End of stream. The buffer may still hold a trailing + -- partial line (one with no terminating @\\n@); feed it + -- through 'applyLine' as a final line before deciding + -- whether to dispatch, so an unterminated @data: ...@ + -- frame is not lost. + leftover <- readIORef (sseStateBuffer st) + let finalEvent = + if BS.null leftover + then event + else case applyLine leftover event of + Dispatch ev -> ev + Continue ev' -> ev' + if eventHasContent finalEvent + then pure (Just finalEvent) + else pure Nothing + else do + modifyIORef' (sseStateBuffer st) (<> chunk) + go event + +-- | The result of interpreting a single line: either the accumulated +-- event is complete and should be dispatched, or the accumulator +-- should be updated and parsing continue. +data LineResult + = Dispatch SSEEvent + | Continue SSEEvent + +-- | Interpret one SSE line against the current accumulator. A blank +-- line dispatches (per spec); a comment line (@:@) is a no-op +-- continue; any other line updates the named field and continues. +applyLine :: ByteString -> SSEEvent -> LineResult +applyLine line event + | BS.null line = Dispatch event + | BS.head line == colon = Continue event -- comment + | otherwise = Continue (applyField field value event) + where + (field, value) = splitField line + colon = toEnum 58 + +-- | Split a line into @(field, value)@ on the first colon. A leading +-- single space in the value is stripped per spec. A line with no colon +-- has the field as the whole line and an empty value. +splitField :: ByteString -> (ByteString, ByteString) +splitField line = + case BS.elemIndex colon line of + Just i -> + let rawValue = BS.drop (i + 1) line + value = stripOneSpace rawValue + in (BS.take i line, value) + Nothing -> (line, BS.empty) + where + colon = toEnum 58 + +stripOneSpace :: ByteString -> ByteString +stripOneSpace s = case BS.uncons s of + Just (c, rest) | c == toEnum 32 -> rest -- ' ' + _ -> s + +applyField :: ByteString -> ByteString -> SSEEvent -> SSEEvent +applyField field value event + | field == "data" = + event + { sseData = + if T.null (sseData event) + then decodeUtf8Lenient value + else sseData event <> "\n" <> decodeUtf8Lenient value + } + | field == "event" = event {sseEvent = Just (decodeUtf8Lenient value)} + | field == "id" = event {sseId = Just (decodeUtf8Lenient value)} + | field == "retry" = event {sseRetry = parseRetry value} + | otherwise = event + +decodeUtf8Lenient :: ByteString -> Text +decodeUtf8Lenient = TE.decodeUtf8With lenientDecode + +parseRetry :: ByteString -> Maybe Int +parseRetry v = case readDec (charStr v) of + (n, _) : _ -> Just n + [] -> Nothing + where + -- readDec works on String; convert losslessly. + charStr = map (toEnum . fromIntegral) . BS.unpack + +-- | Split the buffer on the first line terminator (@\\n@, optionally +-- preceded by @\\r@). Returns the line (without the terminator) and +-- the remaining buffer, or 'Nothing' if no terminator is present yet. +breakLine :: ByteString -> Maybe (ByteString, ByteString) +breakLine buf = + case BS.elemIndex newline buf of + Nothing -> Nothing + Just i -> + let termStart = if i > 0 && BS.index buf (i - 1) == carriage then i - 1 else i + line = BS.take termStart buf + rest = BS.drop (i + 1) buf + in Just (line, rest) + where + newline = toEnum 10 + carriage = toEnum 13 + +-- | A conduit source over a 'BodyReader' that yields 'SSEEvent's +-- until the body is exhausted. The caller (typically wrapped in +-- 'Data.Conduit.runConduitRes') decides when to stop consuming based +-- on event content; the source itself terminates when the body ends. +sseSource :: (MonadResource m) => BodyReader -> ConduitT () SSEEvent m () +sseSource reader = do + st <- liftIO (newSSEState reader) + loop st + where + loop st = do + next <- liftIO (readSSEEvent st) + case next of + Just ev -> yield ev >> loop st + Nothing -> pure () + +-- $setup +-- (No doctest setup; the module is exercised via @Test.MLModelSpec@.) diff --git a/src/Database/Bloodhound/Internal/Utils/Secret.hs b/src/Database/Bloodhound/Internal/Utils/Secret.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Utils/Secret.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} + +-- | +-- Module : Database.Bloodhound.Internal.Utils.Secret +-- Description : 'Show'-redacting newtypes for secret-bearing fields +-- +-- Elasticsearch request and response types routinely carry plaintext +-- credentials: API keys, passwords, OAuth2 tokens, SAML assertions, +-- cloud-provider secret keys, and the like. A stock @deriving stock +-- (Eq, Show)@ leaks these to anyone reading debug output, test diffs, +-- exception rendering, or log lines. +-- +-- 'SecretText' and 'SecretValue' wrap the leaf field types so that +-- 'show' always renders @"***"@ regardless of the payload. 'Eq', +-- 'Ord', 'ToJSON', 'FromJSON', and 'IsString' derive through the +-- newtype, so: +-- +-- * Wire JSON is byte-identical to the unwrapped @Text@ \/ @Value@ — +-- the wrapper is invisible on the network. +-- * Equality comparison still works (returns 'Bool'; never reveals +-- the value). +-- * Tests using @OverloadedStrings@ literals (@Just \"sk-xxx\"@) keep +-- compiling — the literal coerces to 'SecretText' via 'IsString'. +-- +-- The intended use is to replace @Text@ (or @Maybe Text@) on any +-- field whose value is a credential. This makes the redaction +-- compiler-enforced: every construction site is forced to wrap the +-- value, and no @show@-rendered debug path can leak it. +module Database.Bloodhound.Internal.Utils.Secret + ( SecretText (..), + SecretValue (..), + ) +where + +import Data.Aeson +import Data.String (IsString) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Hashable) + +-- | A 'Text' whose 'Show' instance always renders @"***"@. Use for +-- API keys, passwords, access tokens, refresh tokens, SAML +-- assertions, and any other opaque credential string carried over +-- the wire. +-- +-- @since 0.1 +newtype SecretText = SecretText {unSecretText :: Text} + deriving newtype + ( Eq, + Ord, + Hashable, + Semigroup, + Monoid, + IsString, + ToJSON, + FromJSON, + ToJSONKey, + FromJSONKey + ) + +-- | Always @"***"@ — never the underlying credential. +instance Show SecretText where + show _ = "***" + +-- | An aeson 'Value' whose 'Show' instance always renders @"***"@. +-- Use for opaque secret blobs whose shape is not statically known +-- (e.g. @CustomServiceSettings.secret_parameters@, where the caller +-- may pass arbitrary nested key\/value pairs containing credentials +-- for an arbitrary backend). +-- +-- @since 0.1 +newtype SecretValue = SecretValue {unSecretValue :: Value} + deriving newtype (Eq, ToJSON, FromJSON) + +-- | Always @"***"@ — never the underlying blob. +instance Show SecretValue where + show _ = "***" diff --git a/src/Database/Bloodhound/Internal/Utils/StringlyTyped.hs b/src/Database/Bloodhound/Internal/Utils/StringlyTyped.hs --- a/src/Database/Bloodhound/Internal/Utils/StringlyTyped.hs +++ b/src/Database/Bloodhound/Internal/Utils/StringlyTyped.hs @@ -2,7 +2,7 @@ module Database.Bloodhound.Internal.Utils.StringlyTyped where -import qualified Data.Text as T +import Data.Text qualified as T import Database.Bloodhound.Internal.Utils.Imports -- This whole module is a sin bucket to deal with Elasticsearch badness. diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Aggregation.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Aggregation.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Aggregation.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Aggregation.hs @@ -1,12 +1,13 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Database.Bloodhound.Internal.Versions.Common.Types.Aggregation where -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.KeyMap as X -import qualified Data.Map.Strict as M -import qualified Data.Text as T +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as X +import Data.Map.Strict qualified as M +import Data.Text qualified as T import Database.Bloodhound.Internal.Utils.Imports import Database.Bloodhound.Internal.Versions.Common.Types.Highlight (HitHighlight) import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes @@ -14,8 +15,220 @@ import Database.Bloodhound.Internal.Versions.Common.Types.Sort import Database.Bloodhound.Internal.Versions.Common.Types.Units +-- | Path to reference another aggregation or metric in pipeline aggregations +newtype BucketsPath = BucketsPath Text + deriving stock (Eq, Show) + deriving newtype (ToJSON, FromJSON) + +bucketsPathText :: BucketsPath -> Text +bucketsPathText (BucketsPath t) = t + +-- | Policy for handling gaps in pipeline aggregation data +data GapPolicy = GapPolicySkip | GapPolicyInsertZeros | GapPolicyKeepValues + deriving stock (Eq, Show) + +gapPolicyToText :: GapPolicy -> Text +gapPolicyToText GapPolicySkip = "skip" +gapPolicyToText GapPolicyInsertZeros = "insert_zeros" +gapPolicyToText GapPolicyKeepValues = "keep_values" + +gapPolicyFromText :: Text -> Maybe GapPolicy +gapPolicyFromText "skip" = Just GapPolicySkip +gapPolicyFromText "insert_zeros" = Just GapPolicyInsertZeros +gapPolicyFromText "keep_values" = Just GapPolicyKeepValues +gapPolicyFromText _ = Nothing + +instance ToJSON GapPolicy where + toJSON = toJSON . gapPolicyToText + +instance FromJSON GapPolicy where + parseJSON = withText "GapPolicy" $ \t -> case gapPolicyFromText t of + Just gp -> pure gp + Nothing -> fail $ "Invalid GapPolicy: " <> show t + +bucketsPathLens :: Lens' BucketsPath Text +bucketsPathLens = lens bucketsPathText (\_ y -> BucketsPath y) + +gapPolicyLens :: Lens' GapPolicy GapPolicy +gapPolicyLens = lens id (\_ y -> y) + type Aggregations = M.Map Key Aggregation +-- | Avg bucket aggregation +data AvgBucketAggregation = AvgBucketAggregation + { avgBucketBucketsPath :: BucketsPath, + avgBucketGapPolicy :: Maybe GapPolicy, + avgBucketFormat :: Maybe Text + } + deriving stock (Eq, Show) + +avgBucketBucketsPathLens :: Lens' AvgBucketAggregation BucketsPath +avgBucketBucketsPathLens = lens avgBucketBucketsPath (\x y -> x {avgBucketBucketsPath = y}) + +avgBucketGapPolicyLens :: Lens' AvgBucketAggregation (Maybe GapPolicy) +avgBucketGapPolicyLens = lens avgBucketGapPolicy (\x y -> x {avgBucketGapPolicy = y}) + +avgBucketFormatLens :: Lens' AvgBucketAggregation (Maybe Text) +avgBucketFormatLens = lens avgBucketFormat (\x y -> x {avgBucketFormat = y}) + +-- | Sum bucket aggregation +data SumBucketAggregation = SumBucketAggregation + { sumBucketBucketsPath :: BucketsPath, + sumBucketGapPolicy :: Maybe GapPolicy, + sumBucketFormat :: Maybe Text + } + deriving stock (Eq, Show) + +sumBucketBucketsPathLens :: Lens' SumBucketAggregation BucketsPath +sumBucketBucketsPathLens = lens sumBucketBucketsPath (\x y -> x {sumBucketBucketsPath = y}) + +sumBucketGapPolicyLens :: Lens' SumBucketAggregation (Maybe GapPolicy) +sumBucketGapPolicyLens = lens sumBucketGapPolicy (\x y -> x {sumBucketGapPolicy = y}) + +sumBucketFormatLens :: Lens' SumBucketAggregation (Maybe Text) +sumBucketFormatLens = lens sumBucketFormat (\x y -> x {sumBucketFormat = y}) + +-- | Min bucket aggregation +data MinBucketAggregation = MinBucketAggregation + { minBucketBucketsPath :: BucketsPath, + minBucketGapPolicy :: Maybe GapPolicy, + minBucketFormat :: Maybe Text + } + deriving stock (Eq, Show) + +minBucketBucketsPathLens :: Lens' MinBucketAggregation BucketsPath +minBucketBucketsPathLens = lens minBucketBucketsPath (\x y -> x {minBucketBucketsPath = y}) + +minBucketGapPolicyLens :: Lens' MinBucketAggregation (Maybe GapPolicy) +minBucketGapPolicyLens = lens minBucketGapPolicy (\x y -> x {minBucketGapPolicy = y}) + +minBucketFormatLens :: Lens' MinBucketAggregation (Maybe Text) +minBucketFormatLens = lens minBucketFormat (\x y -> x {minBucketFormat = y}) + +-- | Max bucket aggregation +data MaxBucketAggregation = MaxBucketAggregation + { maxBucketBucketsPath :: BucketsPath, + maxBucketGapPolicy :: Maybe GapPolicy, + maxBucketFormat :: Maybe Text + } + deriving stock (Eq, Show) + +maxBucketBucketsPathLens :: Lens' MaxBucketAggregation BucketsPath +maxBucketBucketsPathLens = lens maxBucketBucketsPath (\x y -> x {maxBucketBucketsPath = y}) + +maxBucketGapPolicyLens :: Lens' MaxBucketAggregation (Maybe GapPolicy) +maxBucketGapPolicyLens = lens maxBucketGapPolicy (\x y -> x {maxBucketGapPolicy = y}) + +maxBucketFormatLens :: Lens' MaxBucketAggregation (Maybe Text) +maxBucketFormatLens = lens maxBucketFormat (\x y -> x {maxBucketFormat = y}) + +-- | Stats bucket aggregation +data StatsBucketAggregation = StatsBucketAggregation + { statsBucketBucketsPath :: BucketsPath, + statsBucketGapPolicy :: Maybe GapPolicy, + statsBucketFormat :: Maybe Text + } + deriving stock (Eq, Show) + +statsBucketBucketsPathLens :: Lens' StatsBucketAggregation BucketsPath +statsBucketBucketsPathLens = lens statsBucketBucketsPath (\x y -> x {statsBucketBucketsPath = y}) + +statsBucketGapPolicyLens :: Lens' StatsBucketAggregation (Maybe GapPolicy) +statsBucketGapPolicyLens = lens statsBucketGapPolicy (\x y -> x {statsBucketGapPolicy = y}) + +statsBucketFormatLens :: Lens' StatsBucketAggregation (Maybe Text) +statsBucketFormatLens = lens statsBucketFormat (\x y -> x {statsBucketFormat = y}) + +-- | Derivative aggregation +data DerivativeAggregation = DerivativeAggregation + { derivativeBucketsPath :: BucketsPath, + derivativeGapPolicy :: Maybe GapPolicy, + derivativeFormat :: Maybe Text, + derivativeUnit :: Maybe Text + } + deriving stock (Eq, Show) + +derivativeBucketsPathLens :: Lens' DerivativeAggregation BucketsPath +derivativeBucketsPathLens = lens derivativeBucketsPath (\x y -> x {derivativeBucketsPath = y}) + +derivativeGapPolicyLens :: Lens' DerivativeAggregation (Maybe GapPolicy) +derivativeGapPolicyLens = lens derivativeGapPolicy (\x y -> x {derivativeGapPolicy = y}) + +derivativeFormatLens :: Lens' DerivativeAggregation (Maybe Text) +derivativeFormatLens = lens derivativeFormat (\x y -> x {derivativeFormat = y}) + +derivativeUnitLens :: Lens' DerivativeAggregation (Maybe Text) +derivativeUnitLens = lens derivativeUnit (\x y -> x {derivativeUnit = y}) + +-- | Cumulative sum aggregation +data CumulativeSumAggregation = CumulativeSumAggregation + { cumulativeSumBucketsPath :: BucketsPath, + cumulativeSumFormat :: Maybe Text + } + deriving stock (Eq, Show) + +cumulativeSumBucketsPathLens :: Lens' CumulativeSumAggregation BucketsPath +cumulativeSumBucketsPathLens = lens cumulativeSumBucketsPath (\x y -> x {cumulativeSumBucketsPath = y}) + +cumulativeSumFormatLens :: Lens' CumulativeSumAggregation (Maybe Text) +cumulativeSumFormatLens = lens cumulativeSumFormat (\x y -> x {cumulativeSumFormat = y}) + +instance ToJSON AvgBucketAggregation where + toJSON (AvgBucketAggregation bp gap fmt) = + omitNulls + [ "buckets_path" .= bucketsPathText bp, + "gap_policy" .= gap, + "format" .= fmt + ] + +instance ToJSON SumBucketAggregation where + toJSON (SumBucketAggregation bp gap fmt) = + omitNulls + [ "buckets_path" .= bucketsPathText bp, + "gap_policy" .= gap, + "format" .= fmt + ] + +instance ToJSON MinBucketAggregation where + toJSON (MinBucketAggregation bp gap fmt) = + omitNulls + [ "buckets_path" .= bucketsPathText bp, + "gap_policy" .= gap, + "format" .= fmt + ] + +instance ToJSON MaxBucketAggregation where + toJSON (MaxBucketAggregation bp gap fmt) = + omitNulls + [ "buckets_path" .= bucketsPathText bp, + "gap_policy" .= gap, + "format" .= fmt + ] + +instance ToJSON StatsBucketAggregation where + toJSON (StatsBucketAggregation bp gap fmt) = + omitNulls + [ "buckets_path" .= bucketsPathText bp, + "gap_policy" .= gap, + "format" .= fmt + ] + +instance ToJSON DerivativeAggregation where + toJSON (DerivativeAggregation bp gap fmt unit) = + omitNulls + [ "buckets_path" .= bucketsPathText bp, + "gap_policy" .= gap, + "format" .= fmt, + "unit" .= unit + ] + +instance ToJSON CumulativeSumAggregation where + toJSON (CumulativeSumAggregation bp fmt) = + omitNulls + [ "buckets_path" .= bucketsPathText bp, + "format" .= fmt + ] + emptyAggregations :: Aggregations emptyAggregations = M.empty @@ -36,6 +249,19 @@ | AvgAgg AvgAggregation | MedianAbsoluteDeviationAgg MedianAbsoluteDeviationAggregation | CompositeAgg CompositeAggregation + | MinAgg MinAggregation + | MaxAgg MaxAggregation + | HistogramAgg HistogramAggregation + | RangeAgg RangeAggregation + | NestedAgg NestedAggregation + | PercentileAgg PercentileAggregation + | AvgBucketAgg AvgBucketAggregation + | SumBucketAgg SumBucketAggregation + | MinBucketAgg MinBucketAggregation + | MaxBucketAgg MaxBucketAggregation + | StatsBucketAgg StatsBucketAggregation + | DerivativeAgg DerivativeAggregation + | CumulativeSumAgg CumulativeSumAggregation deriving stock (Eq, Show) aggregationTermsAggPrism :: Prism' Aggregation TermsAggregation @@ -142,6 +368,54 @@ CompositeAgg x -> Right x _ -> Left s +aggregationMinAggPrism :: Prism' Aggregation MinAggregation +aggregationMinAggPrism = prism MinAgg extract + where + extract s = + case s of + MinAgg x -> Right x + _ -> Left s + +aggregationMaxAggPrism :: Prism' Aggregation MaxAggregation +aggregationMaxAggPrism = prism MaxAgg extract + where + extract s = + case s of + MaxAgg x -> Right x + _ -> Left s + +aggregationHistogramAggPrism :: Prism' Aggregation HistogramAggregation +aggregationHistogramAggPrism = prism HistogramAgg extract + where + extract s = + case s of + HistogramAgg x -> Right x + _ -> Left s + +aggregationRangeAggPrism :: Prism' Aggregation RangeAggregation +aggregationRangeAggPrism = prism RangeAgg extract + where + extract s = + case s of + RangeAgg x -> Right x + _ -> Left s + +aggregationNestedAggPrism :: Prism' Aggregation NestedAggregation +aggregationNestedAggPrism = prism NestedAgg extract + where + extract s = + case s of + NestedAgg x -> Right x + _ -> Left s + +aggregationPercentileAggPrism :: Prism' Aggregation PercentileAggregation +aggregationPercentileAggPrism = prism PercentileAgg extract + where + extract s = + case s of + PercentileAgg x -> Right x + _ -> Left s + instance ToJSON Aggregation where toJSON (TermsAgg (TermsAggregation term include exclude order minDocCount size shardSize collectMode executionHint termAggs)) = omitNulls @@ -178,10 +452,6 @@ field interval format - preZone - postZone - preOffset - postOffset dateHistoAggs calendarInterval fixedInterval @@ -199,10 +469,6 @@ [ "field" .= field, "interval" .= interval, "format" .= format, - "pre_zone" .= preZone, - "post_zone" .= postZone, - "pre_offset" .= preOffset, - "post_offset" .= postOffset, "calendar_interval" .= calendarInterval, "fixed_interval" .= fixedInterval, "time_zone" .= timeZone, @@ -255,6 +521,69 @@ omitNulls ["median_absolute_deviation" .= omitNulls ["field" .= n], "missing" .= m] toJSON (CompositeAgg agg) = object ["composite" .= agg] + toJSON (MinAgg (MinAggregation field missing)) = + omitNulls + [ "min" + .= omitNulls + [ "field" .= field, + "missing" .= missing + ] + ] + toJSON (MaxAgg (MaxAggregation field missing)) = + omitNulls + [ "max" + .= omitNulls + [ "field" .= field, + "missing" .= missing + ] + ] + toJSON (HistogramAgg (HistogramAggregation field interval missing minDocCount extendedBounds hardBounds offset keyed subAggs)) = + omitNulls + [ "histogram" + .= omitNulls + [ "field" .= field, + "interval" .= interval, + "missing" .= missing, + "min_doc_count" .= minDocCount, + "extended_bounds" .= extendedBounds, + "hard_bounds" .= hardBounds, + "offset" .= offset, + "keyed" .= keyed + ], + "aggs" .= subAggs + ] + toJSON (RangeAgg a) = + object + [ "range" .= a + ] + toJSON (NestedAgg (NestedAggregation path subAggs)) = + omitNulls + [ "nested" + .= omitNulls + [ "path" .= path + ], + "aggs" .= subAggs + ] + toJSON (PercentileAgg (PercentileAggregation field percents tdigest hdr missing keyed subAggs)) = + omitNulls + [ "percentiles" + .= omitNulls + [ "field" .= field, + "percents" .= percents, + "tdigest" .= tdigest, + "hdr" .= hdr, + "missing" .= missing, + "keyed" .= keyed + ], + "aggs" .= subAggs + ] + toJSON (AvgBucketAgg a) = object ["avg_bucket" .= a] + toJSON (SumBucketAgg a) = object ["sum_bucket" .= a] + toJSON (MinBucketAgg a) = object ["min_bucket" .= a] + toJSON (MaxBucketAgg a) = object ["max_bucket" .= a] + toJSON (StatsBucketAgg a) = object ["stats_bucket" .= a] + toJSON (DerivativeAgg a) = object ["derivative" .= a] + toJSON (CumulativeSumAgg a) = object ["cumulative_sum" .= a] data TopHitsAggregation = TopHitsAggregation { taFrom :: Maybe From, @@ -365,11 +694,6 @@ { dateField :: FieldName, dateInterval :: Maybe Interval, dateFormat :: Maybe Text, - -- pre and post deprecated in 1.5 - datePreZone :: Maybe Text, - datePostZone :: Maybe Text, - datePreOffset :: Maybe Text, - datePostOffset :: Maybe Text, dateAggs :: Maybe Aggregations, dateCalendarInterval :: Maybe Interval, dateFixedInterval :: Maybe FixedInterval, @@ -385,24 +709,16 @@ dateHistogramAggregationFieldLens :: Lens' DateHistogramAggregation FieldName dateHistogramAggregationFieldLens = lens dateField (\x y -> x {dateField = y}) +{-# WARNING + dateHistogramAggregationIntervalLens + "The \"interval\" field of date_histogram is deprecated since Elasticsearch 7.2 and removed in 8.x (it is rejected with \"unknown field [interval]\"). It still works (deprecated) on ES 7 and OpenSearch. Prefer dateHistogramAggregationCalendarIntervalLens / dateHistogramAggregationFixedIntervalLens." + #-} dateHistogramAggregationIntervalLens :: Lens' DateHistogramAggregation (Maybe Interval) dateHistogramAggregationIntervalLens = lens dateInterval (\x y -> x {dateInterval = y}) dateHistogramAggregationFormatLens :: Lens' DateHistogramAggregation (Maybe Text) dateHistogramAggregationFormatLens = lens dateFormat (\x y -> x {dateFormat = y}) -dateHistogramAggregationPreZoneLens :: Lens' DateHistogramAggregation (Maybe Text) -dateHistogramAggregationPreZoneLens = lens datePreZone (\x y -> x {datePreZone = y}) - -dateHistogramAggregationPostZoneLens :: Lens' DateHistogramAggregation (Maybe Text) -dateHistogramAggregationPostZoneLens = lens datePostZone (\x y -> x {datePostZone = y}) - -dateHistogramAggregationPreOffsetLens :: Lens' DateHistogramAggregation (Maybe Text) -dateHistogramAggregationPreOffsetLens = lens datePreOffset (\x y -> x {datePreOffset = y}) - -dateHistogramAggregationPostOffsetLens :: Lens' DateHistogramAggregation (Maybe Text) -dateHistogramAggregationPostOffsetLens = lens datePostOffset (\x y -> x {datePostOffset = y}) - dateHistogramAggregationAggsLens :: Lens' DateHistogramAggregation (Maybe Aggregations) dateHistogramAggregationAggsLens = lens dateAggs (\x y -> x {dateAggs = y}) @@ -489,13 +805,13 @@ toJSON (DateRangeTo e) = object ["to" .= e] toJSON (DateRangeFromAndTo f t) = object ["from" .= f, "to" .= t] --- | See for more information. +-- | See for more information. data ValueCountAggregation = FieldValueCount FieldName | ScriptValueCount Script deriving stock (Eq, Show) --- | Single-bucket filter aggregations. See for more information. +-- | Single-bucket filter aggregations. See for more information. data FilterAggregation = FilterAggregation { faFilter :: Filter, faAggs :: Maybe Aggregations @@ -570,7 +886,7 @@ mkTermsScriptAggregation t = TermsAggregation (TermsAggregationTargetScript t) Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing mkDateHistogram :: FieldName -> DateHistogramAggregation -mkDateHistogram t = DateHistogramAggregation t Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +mkDateHistogram t = DateHistogramAggregation t Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing mkCardinalityAggregation :: FieldName -> CardinalityAggregation mkCardinalityAggregation t = CardinalityAggregation t Nothing Nothing @@ -581,6 +897,33 @@ mkExtendedStatsAggregation :: FieldName -> StatisticsAggregation mkExtendedStatsAggregation = StatisticsAggregation Extended +mkSumAggregation :: FieldName -> SumAggregation +mkSumAggregation (FieldName n) = SumAggregation (FieldName n) + +mkAvgAggregation :: FieldName -> AvgAggregation +mkAvgAggregation (FieldName n) = AvgAggregation (FieldName n) Nothing + +mkAvgBucketAggregation :: BucketsPath -> AvgBucketAggregation +mkAvgBucketAggregation bp = AvgBucketAggregation bp Nothing Nothing + +mkSumBucketAggregation :: BucketsPath -> SumBucketAggregation +mkSumBucketAggregation bp = SumBucketAggregation bp Nothing Nothing + +mkMinBucketAggregation :: BucketsPath -> MinBucketAggregation +mkMinBucketAggregation bp = MinBucketAggregation bp Nothing Nothing + +mkMaxBucketAggregation :: BucketsPath -> MaxBucketAggregation +mkMaxBucketAggregation bp = MaxBucketAggregation bp Nothing Nothing + +mkStatsBucketAggregation :: BucketsPath -> StatsBucketAggregation +mkStatsBucketAggregation bp = StatsBucketAggregation bp Nothing Nothing + +mkDerivativeAggregation :: BucketsPath -> DerivativeAggregation +mkDerivativeAggregation bp = DerivativeAggregation bp Nothing Nothing Nothing + +mkCumulativeSumAggregation :: BucketsPath -> CumulativeSumAggregation +mkCumulativeSumAggregation bp = CumulativeSumAggregation bp Nothing + data CompositeAggregationSourceAggregation = CompositeTermsAgg TermsAggregation | CompositeDateHistogramAgg DateHistogramAggregation @@ -652,6 +995,225 @@ mkCompositeAggregation :: [CompositeAggregationSource] -> CompositeAggregation mkCompositeAggregation sources = CompositeAggregation Nothing sources Nothing +-- | Create a MinAggregation with default values +mkMinAggregation :: FieldName -> MinAggregation +mkMinAggregation field = MinAggregation field Nothing + +-- | Create a MaxAggregation with default values +mkMaxAggregation :: FieldName -> MaxAggregation +mkMaxAggregation field = MaxAggregation field Nothing + +-- | Create a HistogramAggregation with required field and interval +mkHistogramAggregation :: FieldName -> Double -> HistogramAggregation +mkHistogramAggregation field interval = HistogramAggregation field interval Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | Create a RangeAggregation with required field and ranges +mkRangeAggregation :: FieldName -> NonEmpty RangeAggregationRange -> RangeAggregation +mkRangeAggregation field ranges = RangeAggregation field Nothing Nothing ranges Nothing + +-- | Create a NestedAggregation with required path +mkNestedAggregation :: FieldName -> NestedAggregation +mkNestedAggregation path = NestedAggregation path Nothing + +-- | Create a PercentileAggregation with default values +mkPercentileAggregation :: FieldName -> PercentileAggregation +mkPercentileAggregation field = PercentileAggregation field Nothing Nothing Nothing Nothing Nothing Nothing + +-- | Create a RangeAggregationRange from a single value (RangeFrom) +mkRangeAggregationRangeFrom :: Double -> RangeAggregationRange +mkRangeAggregationRangeFrom = RangeFrom + +-- | Create a RangeAggregationRange from a single value (RangeTo) +mkRangeAggregationRangeTo :: Double -> RangeAggregationRange +mkRangeAggregationRangeTo = RangeTo + +-- | Create a RangeAggregationRange with both from and to values +mkRangeAggregationRangeFromTo :: Double -> Double -> RangeAggregationRange +mkRangeAggregationRangeFromTo = RangeFromTo + +-- | Create a HistogramExtendedBounds with min value +mkHistogramExtendedBoundsMin :: Double -> HistogramExtendedBounds +mkHistogramExtendedBoundsMin = HistogramExtendedBoundsMin + +-- | Create a HistogramExtendedBounds with max value +mkHistogramExtendedBoundsMax :: Double -> HistogramExtendedBounds +mkHistogramExtendedBoundsMax = HistogramExtendedBoundsMax + +-- | Create a HistogramHardBounds with min value +mkHistogramHardBoundsMin :: Double -> HistogramHardBounds +mkHistogramHardBoundsMin = HistogramHardBoundsMin + +-- | Create a HistogramHardBounds with max value +mkHistogramHardBoundsMax :: Double -> HistogramHardBounds +mkHistogramHardBoundsMax = HistogramHardBoundsMax + +-- | Single-value metrics aggregation that returns the minimum value. See +data MinAggregation = MinAggregation + { minAggregationField :: FieldName, + minAggregationMissing :: Maybe Missing + } + deriving stock (Eq, Show) + +minAggregationFieldLens :: Lens' MinAggregation FieldName +minAggregationFieldLens = lens minAggregationField (\x y -> x {minAggregationField = y}) + +minAggregationMissingLens :: Lens' MinAggregation (Maybe Missing) +minAggregationMissingLens = lens minAggregationMissing (\x y -> x {minAggregationMissing = y}) + +-- | Single-value metrics aggregation that returns the maximum value. See +data MaxAggregation = MaxAggregation + { maxAggregationField :: FieldName, + maxAggregationMissing :: Maybe Missing + } + deriving stock (Eq, Show) + +maxAggregationFieldLens :: Lens' MaxAggregation FieldName +maxAggregationFieldLens = lens maxAggregationField (\x y -> x {maxAggregationField = y}) + +maxAggregationMissingLens :: Lens' MaxAggregation (Maybe Missing) +maxAggregationMissingLens = lens maxAggregationMissing (\x y -> x {maxAggregationMissing = y}) + +-- | Multi-bucket values source based aggregation for numeric values. See +data HistogramAggregation = HistogramAggregation + { histogramField :: FieldName, + histogramInterval :: Double, + histogramMissing :: Maybe Missing, + histogramMinDocCount :: Maybe Int, + histogramExtendedBounds :: Maybe HistogramExtendedBounds, + histogramHardBounds :: Maybe HistogramHardBounds, + histogramOffset :: Maybe Double, + histogramKeyed :: Maybe Keyed, + histogramAggs :: Maybe Aggregations + } + deriving stock (Eq, Show) + +histogramFieldLens :: Lens' HistogramAggregation FieldName +histogramFieldLens = lens histogramField (\x y -> x {histogramField = y}) + +histogramIntervalLens :: Lens' HistogramAggregation Double +histogramIntervalLens = lens histogramInterval (\x y -> x {histogramInterval = y}) + +histogramMissingLens :: Lens' HistogramAggregation (Maybe Missing) +histogramMissingLens = lens histogramMissing (\x y -> x {histogramMissing = y}) + +histogramMinDocCountLens :: Lens' HistogramAggregation (Maybe Int) +histogramMinDocCountLens = lens histogramMinDocCount (\x y -> x {histogramMinDocCount = y}) + +histogramExtendedBoundsLens :: Lens' HistogramAggregation (Maybe HistogramExtendedBounds) +histogramExtendedBoundsLens = lens histogramExtendedBounds (\x y -> x {histogramExtendedBounds = y}) + +histogramHardBoundsLens :: Lens' HistogramAggregation (Maybe HistogramHardBounds) +histogramHardBoundsLens = lens histogramHardBounds (\x y -> x {histogramHardBounds = y}) + +histogramOffsetLens :: Lens' HistogramAggregation (Maybe Double) +histogramOffsetLens = lens histogramOffset (\x y -> x {histogramOffset = y}) + +histogramKeyedLens :: Lens' HistogramAggregation (Maybe Keyed) +histogramKeyedLens = lens histogramKeyed (\x y -> x {histogramKeyed = y}) + +histogramAggsLens :: Lens' HistogramAggregation (Maybe Aggregations) +histogramAggsLens = lens histogramAggs (\x y -> x {histogramAggs = y}) + +data HistogramExtendedBounds = HistogramExtendedBoundsMin Double | HistogramExtendedBoundsMax Double + deriving stock (Eq, Show) + +data HistogramHardBounds = HistogramHardBoundsMin Double | HistogramHardBoundsMax Double + deriving stock (Eq, Show) + +-- | Multi-bucket value source based aggregation for numeric ranges. See +data RangeAggregationRange = RangeFrom Double | RangeTo Double | RangeFromTo Double Double | RangeFromAndTo Double Double + deriving stock (Eq, Show) + +data RangeAggregation = RangeAggregation + { rangeAggregationField :: FieldName, + rangeAggregationFormat :: Maybe Text, + rangeAggregationKeyed :: Maybe Keyed, + rangeAggregationRanges :: NonEmpty RangeAggregationRange, + rangeAggregationAggs :: Maybe Aggregations + } + deriving stock (Eq, Show) + +rangeAggregationFieldLens :: Lens' RangeAggregation FieldName +rangeAggregationFieldLens = lens rangeAggregationField (\x y -> x {rangeAggregationField = y}) + +rangeAggregationFormatLens :: Lens' RangeAggregation (Maybe Text) +rangeAggregationFormatLens = lens rangeAggregationFormat (\x y -> x {rangeAggregationFormat = y}) + +rangeAggregationKeyedLens :: Lens' RangeAggregation (Maybe Keyed) +rangeAggregationKeyedLens = lens rangeAggregationKeyed (\x y -> x {rangeAggregationKeyed = y}) + +rangeAggregationRangesLens :: Lens' RangeAggregation (NonEmpty RangeAggregationRange) +rangeAggregationRangesLens = lens rangeAggregationRanges (\x y -> x {rangeAggregationRanges = y}) + +rangeAggregationAggsLens :: Lens' RangeAggregation (Maybe Aggregations) +rangeAggregationAggsLens = lens rangeAggregationAggs (\x y -> x {rangeAggregationAggs = y}) + +-- | Bucket aggregation for nested documents. See +data NestedAggregation = NestedAggregation + { nestedPath :: FieldName, + nestedAggs :: Maybe Aggregations + } + deriving stock (Eq, Show) + +nestedPathLens :: Lens' NestedAggregation FieldName +nestedPathLens = lens nestedPath (\x y -> x {nestedPath = y}) + +nestedAggsLens :: Lens' NestedAggregation (Maybe Aggregations) +nestedAggsLens = lens nestedAggs (\x y -> x {nestedAggs = y}) + +-- | Multi-value metrics aggregation for percentiles. See +data Tdigested = Tdigested + { tdigestCompression :: Maybe Int, + tdigestExecutionHint :: Maybe Text + } + deriving stock (Eq, Show) + +tdigestCompressionLens :: Lens' Tdigested (Maybe Int) +tdigestCompressionLens = lens tdigestCompression (\x y -> x {tdigestCompression = y}) + +tdigestExecutionHintLens :: Lens' Tdigested (Maybe Text) +tdigestExecutionHintLens = lens tdigestExecutionHint (\x y -> x {tdigestExecutionHint = y}) + +data Hdr = Hdr + { hdrNumberOfSignificantValueDigits :: Maybe Int + } + deriving stock (Eq, Show) + +hdrNumberOfSignificantValueDigitsLens :: Lens' Hdr (Maybe Int) +hdrNumberOfSignificantValueDigitsLens = lens hdrNumberOfSignificantValueDigits (\x y -> x {hdrNumberOfSignificantValueDigits = y}) + +data PercentileAggregation = PercentileAggregation + { percentileAggregationField :: FieldName, + percentileAggregationPercents :: Maybe (NonEmpty Double), + percentileAggregationTdigest :: Maybe Tdigested, + percentileAggregationHdr :: Maybe Hdr, + percentileAggregationMissing :: Maybe Missing, + percentileAggregationKeyed :: Maybe Keyed, + percentileAggregationAggs :: Maybe Aggregations + } + deriving stock (Eq, Show) + +percentileAggregationFieldLens :: Lens' PercentileAggregation FieldName +percentileAggregationFieldLens = lens percentileAggregationField (\x y -> x {percentileAggregationField = y}) + +percentileAggregationPercentsLens :: Lens' PercentileAggregation (Maybe (NonEmpty Double)) +percentileAggregationPercentsLens = lens percentileAggregationPercents (\x y -> x {percentileAggregationPercents = y}) + +percentileAggregationTdigestLens :: Lens' PercentileAggregation (Maybe Tdigested) +percentileAggregationTdigestLens = lens percentileAggregationTdigest (\x y -> x {percentileAggregationTdigest = y}) + +percentileAggregationHdrLens :: Lens' PercentileAggregation (Maybe Hdr) +percentileAggregationHdrLens = lens percentileAggregationHdr (\x y -> x {percentileAggregationHdr = y}) + +percentileAggregationMissingLens :: Lens' PercentileAggregation (Maybe Missing) +percentileAggregationMissingLens = lens percentileAggregationMissing (\x y -> x {percentileAggregationMissing = y}) + +percentileAggregationKeyedLens :: Lens' PercentileAggregation (Maybe Keyed) +percentileAggregationKeyedLens = lens percentileAggregationKeyed (\x y -> x {percentileAggregationKeyed = y}) + +percentileAggregationAggsLens :: Lens' PercentileAggregation (Maybe Aggregations) +percentileAggregationAggsLens = lens percentileAggregationAggs (\x y -> x {percentileAggregationAggs = y}) + type AggregationResults = M.Map Key Value class BucketAggregation a where @@ -732,7 +1294,7 @@ toJSON GlobalOrdinals = "global_ordinals" toJSON Map = "map" --- | See for more information. +-- | See for more information. data DateMathExpr = DateMathExpr DateMathAnchor [DateMathModifier] deriving stock (Eq, Show) @@ -971,6 +1533,18 @@ HitsTotal <$> v .: "value" <*> v .: "relation" + -- When the client sends @?rest_total_hits_as_int=true@ on + -- @POST /_search/scroll@ (see 'advanceScrollWith' in + -- "Database.Bloodhound.Common.Client"), both Elasticsearch and + -- OpenSearch render @hits.total@ as a bare integer rather than the + -- @{value, relation}@ object. The relation is implicitly @eq@ in that + -- form, so we accept any integer-valued 'Number' and tag it + -- accordingly. Non-integer numbers (e.g. @5.5@) are rejected, matching + -- the object-form parser's behaviour on @{"value": 5.5}@. + parseJSON n@(Number _) = + case fromJSON n of + Success i -> pure (HitsTotal i HTR_EQ) + Error e -> fail e parseJSON _ = empty instance Semigroup HitsTotal where @@ -985,7 +1559,7 @@ hitsTotalRelationLens = lens relation (\x y -> x {relation = y}) data SearchHits a = SearchHits - { hitsTotal :: HitsTotal, + { hitsTotal :: Maybe HitsTotal, maxScore :: Score, hits :: [Hit a] } @@ -994,8 +1568,8 @@ instance (FromJSON a) => FromJSON (SearchHits a) where parseJSON (Object v) = SearchHits - <$> v .: "total" - <*> v .: "max_score" + <$> v .:? "total" + <*> v .:? "max_score" <*> v .: "hits" parseJSON _ = empty @@ -1004,10 +1578,10 @@ SearchHits (ta <> tb) (max ma mb) (ha <> hb) instance Monoid (SearchHits a) where - mempty = SearchHits (HitsTotal 0 HTR_EQ) Nothing mempty + mempty = SearchHits Nothing Nothing mempty mappend = (<>) -searchHitsHitsTotalLens :: Lens' (SearchHits a) HitsTotal +searchHitsHitsTotalLens :: Lens' (SearchHits a) (Maybe HitsTotal) searchHitsHitsTotalLens = lens hitsTotal (\x y -> x {hitsTotal = y}) searchHitsMaxScoreLens :: Lens' (SearchHits a) Score @@ -1016,11 +1590,48 @@ searchHitsHitsLens :: Lens' (SearchHits a) [Hit a] searchHitsHitsLens = lens hits (\x y -> x {hits = y}) +instance ToJSON HistogramExtendedBounds where + toJSON (HistogramExtendedBoundsMin d) = object ["min" .= d] + toJSON (HistogramExtendedBoundsMax d) = object ["max" .= d] + +instance ToJSON HistogramHardBounds where + toJSON (HistogramHardBoundsMin d) = object ["min" .= d] + toJSON (HistogramHardBoundsMax d) = object ["max" .= d] + +instance ToJSON RangeAggregationRange where + toJSON (RangeFrom d) = object ["from" .= d] + toJSON (RangeTo d) = object ["to" .= d] + toJSON (RangeFromTo d1 d2) = object ["from" .= d1, "to" .= d2] + toJSON (RangeFromAndTo d1 d2) = object ["from" .= d1, "to" .= d2] + +instance ToJSON RangeAggregation where + toJSON RangeAggregation {..} = + omitNulls + [ "field" .= rangeAggregationField, + "format" .= rangeAggregationFormat, + "keyed" .= rangeAggregationKeyed, + "ranges" .= toList rangeAggregationRanges, + "aggs" .= rangeAggregationAggs + ] + +instance ToJSON Tdigested where + toJSON Tdigested {..} = + omitNulls + [ "compression" .= tdigestCompression, + "execution_hint" .= tdigestExecutionHint + ] + +instance ToJSON Hdr where + toJSON Hdr {..} = + omitNulls + [ "number_of_significant_value_digits" .= hdrNumberOfSignificantValueDigits + ] + type SearchAfterKey = [Aeson.Value] data Hit a = Hit { hitIndex :: IndexName, - hitDocId :: DocId, + hitDocId :: Maybe DocId, hitScore :: Score, hitSource :: Maybe a, hitSort :: Maybe SearchAfterKey, @@ -1034,8 +1645,8 @@ parseJSON (Object v) = Hit <$> v .: "_index" - <*> v .: "_id" - <*> v .: "_score" + <*> v .:? "_id" + <*> v .:? "_score" <*> v .:? "_source" <*> v .:? "sort" <*> v .:? "fields" @@ -1046,7 +1657,7 @@ hitIndexLens :: Lens' (Hit a) IndexName hitIndexLens = lens hitIndex (\x y -> x {hitIndex = y}) -hitDocIdLens :: Lens' (Hit a) DocId +hitDocIdLens :: Lens' (Hit a) (Maybe DocId) hitDocIdLens = lens hitDocId (\x y -> x {hitDocId = y}) hitScoreLens :: Lens' (Hit a) Score diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Analysis.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Analysis.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Analysis.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Analysis.hs @@ -2,8 +2,8 @@ module Database.Bloodhound.Internal.Versions.Common.Types.Analysis where -import qualified Data.Map.Strict as M -import qualified Data.Text as T +import Data.Map.Strict qualified as M +import Data.Text qualified as T import Database.Bloodhound.Internal.Utils.Imports import Database.Bloodhound.Internal.Utils.StringlyTyped import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Analyze.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Analyze.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Analyze.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Analyze +-- +-- Request and response types for the @POST /_analyze@ and +-- @POST \/{index}\/_analyze@ endpoints, which run the analysis +-- pipeline (character filters, tokenizer, token filters) on text +-- without indexing it. +-- +-- The request only references analyzers, tokenizers, char filters and +-- token filters by name (built-in or already configured in an index +-- mapping or setting). Inline analyzer definitions (the +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Analysis.Analysis' +-- family of types) are not accepted here; the @explain@ variant of the +-- endpoint, which returns a different response shape, is tracked +-- separately. +-- +-- See +-- +-- and +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Analyze + ( AnalyzeRequest (..), + AnalyzeResponse (..), + AnalyzeToken (..), + TokenKind (..), + + -- * Optics + analyzeRequestTextLens, + analyzeRequestAnalyzerLens, + analyzeRequestTokenizerLens, + analyzeRequestFilterLens, + analyzeRequestCharFilterLens, + analyzeRequestFieldLens, + analyzeRequestNormalizerLens, + analyzeResponseTokensLens, + analyzeTokenTokenLens, + analyzeTokenStartOffsetLens, + analyzeTokenEndOffsetLens, + analyzeTokenTypeLens, + analyzeTokenPositionLens, + analyzeTokenKindLens, + ) +where + +import Data.Aeson +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( FieldName (..), + ) +import Optics.Lens + +-- | Body for @POST /_analyze@ and @POST /{index}/_analyze@. +-- +-- The 'analyzeRequestText' list is sent to the server as a JSON array; +-- Elasticsearch treats each element as a separate value, incrementing +-- the position counter with a gap between values. All other fields are +-- optional and reference named analyzers, tokenizers, filters or +-- normalizers (built-in or previously configured via index settings). +data AnalyzeRequest = AnalyzeRequest + { analyzeRequestText :: [Text], + analyzeRequestAnalyzer :: Maybe Text, + analyzeRequestTokenizer :: Maybe Text, + analyzeRequestFilter :: Maybe [Text], + analyzeRequestCharFilter :: Maybe [Text], + analyzeRequestField :: Maybe FieldName, + analyzeRequestNormalizer :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON AnalyzeRequest where + toJSON req = + object $ + [ "text" .= analyzeRequestText req + ] + <> catMaybes + [ ("analyzer" .=) <$> analyzeRequestAnalyzer req, + ("tokenizer" .=) <$> analyzeRequestTokenizer req, + ("filter" .=) <$> analyzeRequestFilter req, + ("char_filter" .=) <$> analyzeRequestCharFilter req, + (\(FieldName f) -> ("field" .= f)) <$> analyzeRequestField req, + ("normalizer" .=) <$> analyzeRequestNormalizer req + ] + +-- | Lenses for 'AnalyzeRequest'. +analyzeRequestTextLens :: Lens' AnalyzeRequest [Text] +analyzeRequestTextLens = lens analyzeRequestText (\x y -> x {analyzeRequestText = y}) + +analyzeRequestAnalyzerLens :: Lens' AnalyzeRequest (Maybe Text) +analyzeRequestAnalyzerLens = lens analyzeRequestAnalyzer (\x y -> x {analyzeRequestAnalyzer = y}) + +analyzeRequestTokenizerLens :: Lens' AnalyzeRequest (Maybe Text) +analyzeRequestTokenizerLens = lens analyzeRequestTokenizer (\x y -> x {analyzeRequestTokenizer = y}) + +analyzeRequestFilterLens :: Lens' AnalyzeRequest (Maybe [Text]) +analyzeRequestFilterLens = lens analyzeRequestFilter (\x y -> x {analyzeRequestFilter = y}) + +analyzeRequestCharFilterLens :: Lens' AnalyzeRequest (Maybe [Text]) +analyzeRequestCharFilterLens = lens analyzeRequestCharFilter (\x y -> x {analyzeRequestCharFilter = y}) + +analyzeRequestFieldLens :: Lens' AnalyzeRequest (Maybe FieldName) +analyzeRequestFieldLens = lens analyzeRequestField (\x y -> x {analyzeRequestField = y}) + +analyzeRequestNormalizerLens :: Lens' AnalyzeRequest (Maybe Text) +analyzeRequestNormalizerLens = lens analyzeRequestNormalizer (\x y -> x {analyzeRequestNormalizer = y}) + +-- | Response body for the @/_analyze@ endpoint. The server returns the +-- resulting token stream under the @tokens@ key. +data AnalyzeResponse = AnalyzeResponse + { analyzeResponseTokens :: [AnalyzeToken] + } + deriving stock (Eq, Show) + +instance FromJSON AnalyzeResponse where + parseJSON = + withObject "AnalyzeResponse" $ \o -> + AnalyzeResponse + <$> o + .: "tokens" + +analyzeResponseTokensLens :: Lens' AnalyzeResponse [AnalyzeToken] +analyzeResponseTokensLens = lens analyzeResponseTokens (\x y -> x {analyzeResponseTokens = y}) + +-- | A single token produced by the analysis pipeline. +data AnalyzeToken = AnalyzeToken + { analyzeTokenToken :: Text, + analyzeTokenStartOffset :: Int, + analyzeTokenEndOffset :: Int, + analyzeTokenType :: Text, + analyzeTokenPosition :: Int, + analyzeTokenKind :: TokenKind + } + deriving stock (Eq, Show) + +instance FromJSON AnalyzeToken where + parseJSON = + withObject "AnalyzeToken" $ \o -> do + analyzeTokenToken <- o .: "token" + analyzeTokenStartOffset <- o .: "start_offset" + analyzeTokenEndOffset <- o .: "end_offset" + analyzeTokenType <- o .: "type" + analyzeTokenPosition <- o .: "position" + analyzeTokenKind <- o .:? "kind" .!= TokenKindWord + pure AnalyzeToken {..} + +analyzeTokenTokenLens :: Lens' AnalyzeToken Text +analyzeTokenTokenLens = lens analyzeTokenToken (\x y -> x {analyzeTokenToken = y}) + +analyzeTokenStartOffsetLens :: Lens' AnalyzeToken Int +analyzeTokenStartOffsetLens = lens analyzeTokenStartOffset (\x y -> x {analyzeTokenStartOffset = y}) + +analyzeTokenEndOffsetLens :: Lens' AnalyzeToken Int +analyzeTokenEndOffsetLens = lens analyzeTokenEndOffset (\x y -> x {analyzeTokenEndOffset = y}) + +analyzeTokenTypeLens :: Lens' AnalyzeToken Text +analyzeTokenTypeLens = lens analyzeTokenType (\x y -> x {analyzeTokenType = y}) + +analyzeTokenPositionLens :: Lens' AnalyzeToken Int +analyzeTokenPositionLens = lens analyzeTokenPosition (\x y -> x {analyzeTokenPosition = y}) + +analyzeTokenKindLens :: Lens' AnalyzeToken TokenKind +analyzeTokenKindLens = lens analyzeTokenKind (\x y -> x {analyzeTokenKind = y}) + +-- | The @kind@ attribute reported by some backends (notably +-- OpenSearch) on each token. Defaults to 'TokenKindWord' when the +-- server omits the field, which matches Elasticsearch's response shape. +data TokenKind + = TokenKindWord + | TokenKindPunct + | TokenKindSymbol + | TokenKindOther Text + deriving stock (Eq, Show) + +instance FromJSON TokenKind where + parseJSON = + withText "TokenKind" $ \t -> case t of + "WORD" -> pure TokenKindWord + "PUNCT" -> pure TokenKindPunct + "SYMBOL" -> pure TokenKindSymbol + _ -> pure (TokenKindOther t) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/AsyncSearch.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/AsyncSearch.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/AsyncSearch.hs @@ -0,0 +1,521 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.AsyncSearch +-- Description : Types for the Elasticsearch Async Search API +-- +-- Defines the request and response shapes for the ES Async Search API +-- (@POST \/_async_search@, @GET /_async_search/{id}@, +-- @GET /_async_search/status/{id}@, @DELETE /_async_search/{id}@). Async +-- Search ships in Elasticsearch 7.7 and later (ES7\/ES8\/ES9 share the +-- same surface), which is why these types live in the Common layer. +-- +-- An async search response is shaped like a regular 'SearchResult' with +-- three extra scheduling fields (@id@, @is_running@, @is_partial@) and a +-- few timing fields (@start_time_in_millis@, @expiration_time_in_millis@, +-- @completion_time_in_millis@, @num_reduce_phases@). While the search is +-- still running, @took@, @_shards@ and @hits@ may be absent, which is why +-- every search-result field on 'AsyncSearchResult' is optional — reusing +-- 'SearchResult' directly would reject the partial bodies ES returns while +-- the search is in flight. +-- +-- /Response envelope:/ Elasticsearch (8.x\/9.x and modern 7.x patches) +-- nests the search payload — @took@, @timed_out@, @num_reduce_phases@, +-- @_shards@, @hits@, @aggregations@ — under a required top-level +-- @response@ object, alongside the scheduling fields. OpenSearch's +-- async-search plugin instead returns those fields flat at the top +-- level (the pre-7.10 ES shape). Because this type is shared across all +-- six backends, the 'FromJSON' instance reads the search fields from the +-- nested @response@ object when present and falls back to the top level +-- otherwise, so both backends decode correctly. +module Database.Bloodhound.Internal.Versions.Common.Types.AsyncSearch + ( AsyncSearchId (..), + AsyncSearchResult (..), + AsyncSearchStatus (..), + AsyncSearchSubmitOptions (..), + defaultAsyncSearchSubmitOptions, + asyncSearchSubmitOptionsParams, + osAsyncSearchSubmitOptionsParams, + AsyncSearchStatsNodes (..), + AsyncSearchNodeStats (..), + AsyncSearchStatsResponse (..), + + -- * Optics + asyncSearchIdLens, + asyncSearchResultIdLens, + asyncSearchResultIsRunningLens, + asyncSearchResultIsPartialLens, + asyncSearchResultStartTimeInMillisLens, + asyncSearchResultExpirationTimeInMillisLens, + asyncSearchResultCompletionTimeInMillisLens, + asyncSearchResultTookLens, + asyncSearchResultTimedOutLens, + asyncSearchResultNumReducePhasesLens, + asyncSearchResultShardsLens, + asyncSearchResultHitsLens, + asyncSearchResultAggregationsLens, + asyncSearchStatusIsRunningLens, + asyncSearchStatusIsPartialLens, + asyncSearchStatusStartTimeInMillisLens, + asyncSearchStatusExpirationTimeInMillisLens, + asyncSearchStatusCompletionStatusLens, + asyncSearchStatusCompletionTimeInMillisLens, + assoWaitForCompletionLens, + assoKeepOnCompletionLens, + assoKeepAliveLens, + assoBatchedReduceSizeLens, + assoCcsMinimizeRoundtripsLens, + ) +where + +import Data.Aeson +import Data.Map.Strict qualified as Map +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Aggregation + ( AggregationResults, + SearchHits, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.KeepAlive + ( KeepAlive, + keepAliveToText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes (ShardResult) + +-- | Identifies an async search context in the @\/_async_search\/{id}@ URL +-- path. Wraps 'Text' so it round-trips through JSON as a bare string. +newtype AsyncSearchId = AsyncSearchId {unAsyncSearchId :: Text} + deriving newtype (Eq, Show, ToJSON, FromJSON) + +asyncSearchIdLens :: Lens' AsyncSearchId Text +asyncSearchIdLens = lens unAsyncSearchId (\x y -> x {unAsyncSearchId = y}) + +-- | An async search response. The @id@ is absent when the search +-- completed synchronously (because @wait_for_completion@ was @true@ and +-- the search finished within the wait window); @took@, @_shards@ and +-- @hits@ are absent while the search is still running. The +-- @aggregations@ field is only populated once the final reduce phase +-- has run. @completion_time_in_millis@ is set by the server once the +-- search has finished (it stays absent while running). +data AsyncSearchResult a = AsyncSearchResult + { asyncSearchId :: Maybe AsyncSearchId, + asyncSearchIsRunning :: Bool, + asyncSearchIsPartial :: Bool, + asyncSearchStartTimeInMillis :: Maybe Int, + asyncSearchExpirationTimeInMillis :: Maybe Int, + asyncSearchCompletionTimeInMillis :: Maybe Int, + asyncSearchTook :: Maybe Int, + asyncSearchTimedOut :: Maybe Bool, + asyncSearchNumReducePhases :: Maybe Int, + asyncSearchShards :: Maybe ShardResult, + asyncSearchHits :: Maybe (SearchHits a), + asyncSearchAggregations :: Maybe AggregationResults + } + deriving stock (Eq, Show) + +instance (FromJSON a) => FromJSON (AsyncSearchResult a) where + parseJSON = withObject "AsyncSearchResult" $ \v -> do + -- Elasticsearch 8.x/9.x (and modern 7.x) nests the search payload + -- under a top-level "response" object; OpenSearch returns it flat. + -- Read from the nested object when present (a JSON @null@ collapses to + -- 'Nothing' via '.:?' and so falls back to the top level, matching + -- the absent case); otherwise fall back to the top level so both + -- backends decode. A present-but-non-object @response@ is a contract + -- violation neither backend emits, so it fails loudly rather than + -- silently dropping the search payload. + mResp <- v .:? "response" + o <- case mResp of + Nothing -> pure v + Just (Object inner) -> pure inner + Just other -> + fail $ + "AsyncSearchResult: expected 'response' to be an object, got: " + <> show other + AsyncSearchResult + <$> v .:? "id" + <*> v .:? "is_running" .!= False + <*> v .:? "is_partial" .!= True + <*> v .:? "start_time_in_millis" + <*> v .:? "expiration_time_in_millis" + <*> v .:? "completion_time_in_millis" + <*> o .:? "took" + <*> o .:? "timed_out" + <*> o .:? "num_reduce_phases" + <*> o .:? "_shards" + <*> o .:? "hits" + <*> o .:? "aggregations" + +-- Note: no 'ToJSON' instance, by precedent with 'SearchResult' — response +-- types are decode-only. 'AsyncSearchId' (a path-wrapping newtype) does +-- round-trip. + +asyncSearchResultIdLens :: Lens' (AsyncSearchResult a) (Maybe AsyncSearchId) +asyncSearchResultIdLens = lens asyncSearchId (\x y -> x {asyncSearchId = y}) + +asyncSearchResultIsRunningLens :: Lens' (AsyncSearchResult a) Bool +asyncSearchResultIsRunningLens = + lens asyncSearchIsRunning (\x y -> x {asyncSearchIsRunning = y}) + +asyncSearchResultIsPartialLens :: Lens' (AsyncSearchResult a) Bool +asyncSearchResultIsPartialLens = + lens asyncSearchIsPartial (\x y -> x {asyncSearchIsPartial = y}) + +asyncSearchResultStartTimeInMillisLens :: Lens' (AsyncSearchResult a) (Maybe Int) +asyncSearchResultStartTimeInMillisLens = + lens asyncSearchStartTimeInMillis (\x y -> x {asyncSearchStartTimeInMillis = y}) + +asyncSearchResultExpirationTimeInMillisLens :: Lens' (AsyncSearchResult a) (Maybe Int) +asyncSearchResultExpirationTimeInMillisLens = + lens asyncSearchExpirationTimeInMillis (\x y -> x {asyncSearchExpirationTimeInMillis = y}) + +asyncSearchResultCompletionTimeInMillisLens :: Lens' (AsyncSearchResult a) (Maybe Int) +asyncSearchResultCompletionTimeInMillisLens = + lens asyncSearchCompletionTimeInMillis (\x y -> x {asyncSearchCompletionTimeInMillis = y}) + +asyncSearchResultTookLens :: Lens' (AsyncSearchResult a) (Maybe Int) +asyncSearchResultTookLens = + lens asyncSearchTook (\x y -> x {asyncSearchTook = y}) + +asyncSearchResultTimedOutLens :: Lens' (AsyncSearchResult a) (Maybe Bool) +asyncSearchResultTimedOutLens = + lens asyncSearchTimedOut (\x y -> x {asyncSearchTimedOut = y}) + +asyncSearchResultNumReducePhasesLens :: Lens' (AsyncSearchResult a) (Maybe Int) +asyncSearchResultNumReducePhasesLens = + lens asyncSearchNumReducePhases (\x y -> x {asyncSearchNumReducePhases = y}) + +asyncSearchResultShardsLens :: Lens' (AsyncSearchResult a) (Maybe ShardResult) +asyncSearchResultShardsLens = + lens asyncSearchShards (\x y -> x {asyncSearchShards = y}) + +asyncSearchResultHitsLens :: Lens' (AsyncSearchResult a) (Maybe (SearchHits a)) +asyncSearchResultHitsLens = + lens asyncSearchHits (\x y -> x {asyncSearchHits = y}) + +asyncSearchResultAggregationsLens :: Lens' (AsyncSearchResult a) (Maybe AggregationResults) +asyncSearchResultAggregationsLens = + lens asyncSearchAggregations (\x y -> x {asyncSearchAggregations = y}) + +-- | The response shape returned by @GET /_async_search/status/{id}@. The +-- status endpoint reports only whether the search is running or partial, +-- the timing fields ES uses for retention, the HTTP +-- @completion_status@ code (returned since ES 7.13 once the search has +-- finished) and @completion_time_in_millis@ — it omits the @id@, @took@, +-- @timed_out@, @num_reduce_phases@, @_shards@, @hits@ and +-- @aggregations@ fields that the full 'AsyncSearchResult' carries. +-- Reusing 'AsyncSearchResult' directly would mislead callers into +-- expecting @Nothing@ on fields ES never returns here, so the status +-- endpoint has its own narrower type. +-- +-- When 'asyncSearchStatusIsRunning' is @False@, +-- 'asyncSearchStatusCompletionStatus' holds the HTTP status code of the +-- completed search (@200@ on success; @4xx@\/@5xx@ when the search +-- finished with an error). It stays absent (and decodes to @Nothing@) +-- while the search is still running. 'asyncSearchStatusCompletionTimeInMillis' +-- likewise appears only once the search has completed. +data AsyncSearchStatus = AsyncSearchStatus + { asyncSearchStatusIsRunning :: Bool, + asyncSearchStatusIsPartial :: Bool, + asyncSearchStatusStartTimeInMillis :: Maybe Int, + asyncSearchStatusExpirationTimeInMillis :: Maybe Int, + asyncSearchStatusCompletionStatus :: Maybe Int, + asyncSearchStatusCompletionTimeInMillis :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON AsyncSearchStatus where + parseJSON = withObject "AsyncSearchStatus" $ \v -> + AsyncSearchStatus + <$> v .:? "is_running" .!= False + <*> v .:? "is_partial" .!= True + <*> v .:? "start_time_in_millis" + <*> v .:? "expiration_time_in_millis" + <*> v .:? "completion_status" + <*> v .:? "completion_time_in_millis" + +-- Note: no 'ToJSON' instance, by precedent with 'AsyncSearchResult' — +-- response types are decode-only. + +asyncSearchStatusIsRunningLens :: Lens' AsyncSearchStatus Bool +asyncSearchStatusIsRunningLens = + lens asyncSearchStatusIsRunning (\x y -> x {asyncSearchStatusIsRunning = y}) + +asyncSearchStatusIsPartialLens :: Lens' AsyncSearchStatus Bool +asyncSearchStatusIsPartialLens = + lens asyncSearchStatusIsPartial (\x y -> x {asyncSearchStatusIsPartial = y}) + +asyncSearchStatusStartTimeInMillisLens :: Lens' AsyncSearchStatus (Maybe Int) +asyncSearchStatusStartTimeInMillisLens = + lens asyncSearchStatusStartTimeInMillis (\x y -> x {asyncSearchStatusStartTimeInMillis = y}) + +asyncSearchStatusExpirationTimeInMillisLens :: Lens' AsyncSearchStatus (Maybe Int) +asyncSearchStatusExpirationTimeInMillisLens = + lens asyncSearchStatusExpirationTimeInMillis (\x y -> x {asyncSearchStatusExpirationTimeInMillis = y}) + +asyncSearchStatusCompletionStatusLens :: Lens' AsyncSearchStatus (Maybe Int) +asyncSearchStatusCompletionStatusLens = + lens asyncSearchStatusCompletionStatus (\x y -> x {asyncSearchStatusCompletionStatus = y}) + +asyncSearchStatusCompletionTimeInMillisLens :: Lens' AsyncSearchStatus (Maybe Int) +asyncSearchStatusCompletionTimeInMillisLens = + lens asyncSearchStatusCompletionTimeInMillis (\x y -> x {asyncSearchStatusCompletionTimeInMillis = y}) + +-- ========================================================================= +-- Submit options (URI parameters for POST /_async_search) +-- ========================================================================= + +-- | URI parameters accepted by @POST /_async_search@ (Elasticsearch 7.7+) +-- and @POST /_plugins/_asynchronous_search@ (OpenSearch 1.x\/2.x\/3.x). Picked +-- up by 'Database.Bloodhound.Common.Requests.submitAsyncSearchWith' and +-- the per-version @submitOSAsyncSearchWith@ in +-- "Database.Bloodhound.OpenSearch1.Requests", +-- "Database.Bloodhound.OpenSearch2.Requests", and +-- "Database.Bloodhound.OpenSearch3.Requests". +-- +-- The Elasticsearch endpoint documents five parameters +-- (): +-- +-- [@wait_for_completion@] @'Just' 'True'@ blocks until the search +-- completes (or the wait window elapses) instead of returning +-- immediately with an id. Defaults to @false@ server-side when +-- omitted. +-- +-- [@keep_on_completion@] @'Just' 'True'@ persists the result on +-- completion so it can still be polled via +-- @GET /_async_search/{id}@. Defaults to @false@ server-side. +-- +-- [@keep_alive@] How long to retain the async search result, as a +-- typed 'KeepAlive' value (e.g. @'keepAliveDays' 5@). Defaults to +-- @5d@ server-side when omitted. +-- +-- [@batched_reduce_size@] /Elasticsearch only/. Count of shard +-- results to collect on the coordinating node before performing a +-- partial reduction. Increasing it speeds up large searches at the +-- cost of higher memory pressure. Silently dropped by the +-- OpenSearch request builders. +-- +-- [@ccs_minimize_roundtrips@] /Elasticsearch only/. @'Just' 'True'@ +-- minimises round-trips for cross-cluster searches. Defaults to +-- @true@ server-side. Silently dropped by the OpenSearch request +-- builders. +-- +-- 'defaultAsyncSearchSubmitOptions' sets every field to 'Nothing', +-- yielding a byte-identical request to the parameterless +-- 'Database.Bloodhound.Common.Requests.submitAsyncSearch'. +-- +-- Field shapes mirror +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.PITOptions' +-- (a peer URI-options record). +data AsyncSearchSubmitOptions = AsyncSearchSubmitOptions + { -- | @wait_for_completion@ — accepted by both ES and OS. + assoWaitForCompletion :: Maybe Bool, + -- | @keep_on_completion@ — accepted by both ES and OS. + assoKeepOnCompletion :: Maybe Bool, + -- | @keep_alive@ — accepted by both ES and OS. + assoKeepAlive :: Maybe KeepAlive, + -- | @batched_reduce_size@ — /Elasticsearch only/. Silently dropped + -- by the OpenSearch request builders. + assoBatchedReduceSize :: Maybe Word32, + -- | @ccs_minimize_roundtrips@ — /Elasticsearch only/. Silently + -- dropped by the OpenSearch request builders. + assoCcsMinimizeRoundtrips :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'AsyncSearchSubmitOptions' with every parameter set to 'Nothing'. +-- Produces no query string, so a call made with this value is +-- byte-identical to the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.submitAsyncSearch' (and to every +-- per-version @submitOSAsyncSearch@ in +-- "Database.Bloodhound.OpenSearch1.Requests", +-- "Database.Bloodhound.OpenSearch2.Requests", and +-- "Database.Bloodhound.OpenSearch3.Requests"). +defaultAsyncSearchSubmitOptions :: AsyncSearchSubmitOptions +defaultAsyncSearchSubmitOptions = + AsyncSearchSubmitOptions + { assoWaitForCompletion = Nothing, + assoKeepOnCompletion = Nothing, + assoKeepAlive = Nothing, + assoBatchedReduceSize = Nothing, + assoCcsMinimizeRoundtrips = Nothing + } + +assoWaitForCompletionLens :: Lens' AsyncSearchSubmitOptions (Maybe Bool) +assoWaitForCompletionLens = + lens assoWaitForCompletion (\x y -> x {assoWaitForCompletion = y}) + +assoKeepOnCompletionLens :: Lens' AsyncSearchSubmitOptions (Maybe Bool) +assoKeepOnCompletionLens = + lens assoKeepOnCompletion (\x y -> x {assoKeepOnCompletion = y}) + +assoKeepAliveLens :: Lens' AsyncSearchSubmitOptions (Maybe KeepAlive) +assoKeepAliveLens = + lens assoKeepAlive (\x y -> x {assoKeepAlive = y}) + +assoBatchedReduceSizeLens :: Lens' AsyncSearchSubmitOptions (Maybe Word32) +assoBatchedReduceSizeLens = + lens assoBatchedReduceSize (\x y -> x {assoBatchedReduceSize = y}) + +assoCcsMinimizeRoundtripsLens :: Lens' AsyncSearchSubmitOptions (Maybe Bool) +assoCcsMinimizeRoundtripsLens = + lens assoCcsMinimizeRoundtrips (\x y -> x {assoCcsMinimizeRoundtrips = y}) + +-- | Internal helper that renders a 'Bool' as the @true@\/@false@ literal +-- the ES\/OS query-string convention requires. Mirrors the local helpers +-- in "Database.Bloodhound.Internal.Versions.Common.Types.PointInTime" +-- and sibling modules. +boolQP :: Bool -> Text +boolQP True = "true" +boolQP False = "false" + +-- | Render the parameters shared by Elasticsearch and OpenSearch +-- (@wait_for_completion@, @keep_on_completion@, @keep_alive@). The +-- Elasticsearch-only 'assoBatchedReduceSize' and 'assoCcsMinimizeRoundtrips' +-- are /deliberately omitted/ so that the OpenSearch request builders never +-- emit undocumented parameters — see 'osAsyncSearchSubmitOptionsParams'. +-- 'Nothing' fields are omitted, so 'defaultAsyncSearchSubmitOptions' +-- produces an empty list. The order of the returned list is stable but +-- /unspecified/ — callers (including tests) should treat it as a set and +-- not pattern-match on the head. The underlying 'withQueries' is +-- order-insensitive. Mirrors the structure of +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.pitOptionsParams'. +sharedAsyncSearchSubmitOptionsParams :: AsyncSearchSubmitOptions -> [(Text, Maybe Text)] +sharedAsyncSearchSubmitOptionsParams opts = + catMaybes + [ ("wait_for_completion",) . Just . boolQP <$> assoWaitForCompletion opts, + ("keep_on_completion",) . Just . boolQP <$> assoKeepOnCompletion opts, + ("keep_alive",) . Just . keepAliveToText <$> assoKeepAlive opts + ] + +-- | Render the full set of five 'AsyncSearchSubmitOptions' parameters for +-- the Elasticsearch endpoint (@POST /_async_search@). Extends +-- 'sharedAsyncSearchSubmitOptionsParams' with the ES-only +-- @batched_reduce_size@ and @ccs_minimize_roundtrips@. 'Nothing' fields +-- are omitted, so 'defaultAsyncSearchSubmitOptions' produces an empty +-- list. The order of the returned list is stable but /unspecified/ — +-- callers (including tests) should treat it as a set and not +-- pattern-match on the head. The underlying 'withQueries' is +-- order-insensitive. +asyncSearchSubmitOptionsParams :: AsyncSearchSubmitOptions -> [(Text, Maybe Text)] +asyncSearchSubmitOptionsParams opts = + sharedAsyncSearchSubmitOptionsParams opts + <> catMaybes + [ ("batched_reduce_size",) . Just . showText <$> assoBatchedReduceSize opts, + ("ccs_minimize_roundtrips",) . Just . boolQP <$> assoCcsMinimizeRoundtrips opts + ] + +-- | Render the OpenSearch-supported subset of 'AsyncSearchSubmitOptions' +-- for the OpenSearch async search plugin endpoint +-- (@POST /_plugins/_asynchronous_search@). OpenSearch documents only +-- @wait_for_completion@, @keep_on_completion@ and @keep_alive@ — the +-- ES-only 'assoBatchedReduceSize' and 'assoCcsMinimizeRoundtrips' are +-- silently dropped so the OpenSearch request builders never emit +-- undocumented parameters. 'Nothing' fields are omitted, so +-- 'defaultAsyncSearchSubmitOptions' produces an empty list. The order of +-- the returned list is stable but /unspecified/ — callers (including +-- tests) should treat it as a set and not pattern-match on the head. +-- The underlying 'withQueries' is order-insensitive. +osAsyncSearchSubmitOptionsParams :: AsyncSearchSubmitOptions -> [(Text, Maybe Text)] +osAsyncSearchSubmitOptionsParams = sharedAsyncSearchSubmitOptionsParams + +-- ========================================================================= +-- Stats endpoint (GET /_plugins/_asynchronous_search/stats) +-- ========================================================================= + +-- | The @_nodes@ sub-object on the async-search stats response, summarising +-- how many nodes responded successfully. +data AsyncSearchStatsNodes = AsyncSearchStatsNodes + { asyncSearchStatsNodesTotal :: Int, + asyncSearchStatsNodesSuccessful :: Int, + asyncSearchStatsNodesFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON AsyncSearchStatsNodes where + parseJSON = withObject "AsyncSearchStatsNodes" $ \o -> + AsyncSearchStatsNodes + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON AsyncSearchStatsNodes where + toJSON n = + object + [ "total" .= asyncSearchStatsNodesTotal n, + "successful" .= asyncSearchStatsNodesSuccessful n, + "failed" .= asyncSearchStatsNodesFailed n + ] + +-- | The @asynchronous_search_stats@ sub-object on each node entry in the +-- async-search stats response. Nine integer counters tracking the +-- lifecycle of async searches on that node. +data AsyncSearchNodeStats = AsyncSearchNodeStats + { asyncSearchNodeStatsSubmitted :: Maybe Integer, + asyncSearchNodeStatsInitialized :: Maybe Integer, + asyncSearchNodeStatsRejected :: Maybe Integer, + asyncSearchNodeStatsSearchCompleted :: Maybe Integer, + asyncSearchNodeStatsSearchFailed :: Maybe Integer, + asyncSearchNodeStatsPersisted :: Maybe Integer, + asyncSearchNodeStatsPersistFailed :: Maybe Integer, + asyncSearchNodeStatsRunningCurrent :: Maybe Integer, + asyncSearchNodeStatsCancelled :: Maybe Integer + } + deriving stock (Eq, Show) + +instance FromJSON AsyncSearchNodeStats where + parseJSON = withObject "AsyncSearchNodeStats" $ \o -> + AsyncSearchNodeStats + <$> o .:? "submitted" + <*> o .:? "initialized" + <*> o .:? "rejected" + <*> o .:? "search_completed" + <*> o .:? "search_failed" + <*> o .:? "persisted" + <*> o .:? "persist_failed" + <*> o .:? "running_current" + <*> o .:? "cancelled" + +instance ToJSON AsyncSearchNodeStats where + toJSON s = + omitNulls + [ "submitted" .= asyncSearchNodeStatsSubmitted s, + "initialized" .= asyncSearchNodeStatsInitialized s, + "rejected" .= asyncSearchNodeStatsRejected s, + "search_completed" .= asyncSearchNodeStatsSearchCompleted s, + "search_failed" .= asyncSearchNodeStatsSearchFailed s, + "persisted" .= asyncSearchNodeStatsPersisted s, + "persist_failed" .= asyncSearchNodeStatsPersistFailed s, + "running_current" .= asyncSearchNodeStatsRunningCurrent s, + "cancelled" .= asyncSearchNodeStatsCancelled s + ] + +-- | Response body for @GET /_plugins/_asynchronous_search/stats@ +-- (@{_nodes, cluster_name, nodes: {: {asynchronous_search_stats: {...}}}}@). +-- The @nodes@ map is keyed by node id. +data AsyncSearchStatsResponse = AsyncSearchStatsResponse + { asyncSearchStatsResponseNodes_ :: Maybe AsyncSearchStatsNodes, + asyncSearchStatsResponseClusterName :: Maybe Text, + asyncSearchStatsResponseNodes :: Map.Map Text AsyncSearchNodeStats + } + deriving stock (Eq, Show) + +instance FromJSON AsyncSearchStatsResponse where + parseJSON = withObject "AsyncSearchStatsResponse" $ \o -> + AsyncSearchStatsResponse + <$> o .:? "_nodes" + <*> o .:? "cluster_name" + <*> (o .:? "nodes" .!= mempty >>= traverse parseNodeStats) + where + -- Each node value is {"asynchronous_search_stats": {...}} — unwrap + -- the inner key, then decode as 'AsyncSearchNodeStats'. Unknown + -- keys alongside @asynchronous_search_stats@ are silently dropped. + parseNodeStats = withObject "async search node entry" $ \v -> v .: "asynchronous_search_stats" + +instance ToJSON AsyncSearchStatsResponse where + toJSON r = + omitNulls + [ "_nodes" .= asyncSearchStatsResponseNodes_ r, + "cluster_name" .= asyncSearchStatsResponseClusterName r, + "nodes" .= Map.map (\s -> object ["asynchronous_search_stats" .= s]) (asyncSearchStatsResponseNodes r) + ] diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Autoscaling.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Autoscaling.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Autoscaling.hs @@ -0,0 +1,512 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Autoscaling +-- Description : Types for the Elasticsearch X-Pack Autoscaling API +-- +-- Defines the request and response shapes for the ES X-Pack Autoscaling +-- endpoints (under @\/_autoscaling\/*@). Autoscaling lets an orchestration +-- layer (Elasticsearch Service, Elastic Cloud Enterprise, Elastic Cloud on +-- Kubernetes) ask Elasticsearch how big each node tier should be; a policy +-- names a set of node @roles@ and a bag of @deciders@ that compute the +-- required capacity. +-- +-- * @PUT /_autoscaling/policy/{name}@ — create or update ('AutoscalingPolicy'), +-- returns 'Acknowledged'. +-- * @GET /_autoscaling/policy/{name}@ — 'AutoscalingPolicy'. +-- * @DELETE /_autoscaling/policy/{name}@ — returns 'Acknowledged'. +-- * @GET /_autoscaling/capacity@ — 'AutoscalingCapacity'. +-- +-- Autoscaling ships in Elasticsearch 7.x and later (X-Pack, indirect-use by +-- cloud orchestrators) and shares its wire surface across ES7\/ES8\/ES9, +-- which is why these types live in the Common layer alongside SLM\/ILM\/Enrich. +-- OpenSearch does not implement the autoscaling API, so calls against an +-- OpenSearch cluster will fail at runtime — the types are still hosted under +-- @Common@ to match the project's SLM\/Enrich precedent. +-- +-- The capacity response carries a number of loosely-specified, +-- decider-specific objects (notably @reason_details@, which the docs state is +-- not subject to backwards-compatibility guarantees). The stable, documented +-- fields are typed; volatile sibling fields are preserved in per-record +-- @extras@ 'KeyMap' catch-alls so the structure round-trips through +-- @encode . decode@ even when ES adds new optional fields. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Autoscaling + ( -- * Policy identity + AutoscalingPolicyName (..), + + -- * Policy (PUT body / GET response) + AutoscalingPolicy (..), + defaultAutoscalingPolicy, + autoscalingPolicyRolesLens, + autoscalingPolicyDecidersLens, + autoscalingPolicyExtrasLens, + + -- * Capacity (GET /_autoscaling/capacity) + AutoscalingCapacity (..), + autoscalingCapacityPoliciesLens, + AutoscalingCapacityPolicy (..), + autoscalingCapacityPolicyRequiredCapacityLens, + autoscalingCapacityPolicyCurrentCapacityLens, + autoscalingCapacityPolicyCurrentNodesLens, + autoscalingCapacityPolicyDecidersLens, + autoscalingCapacityPolicyExtrasLens, + CapacitySize (..), + capacitySizeNodeLens, + capacitySizeTotalLens, + capacitySizeExtrasLens, + AutoscalingResource (..), + autoscalingResourceStorageLens, + autoscalingResourceMemoryLens, + autoscalingResourceExtrasLens, + AutoscalingCurrentNode (..), + autoscalingCurrentNodeNameLens, + autoscalingCurrentNodeExtrasLens, + AutoscalingDeciderResult (..), + autoscalingDeciderResultRequiredCapacityLens, + autoscalingDeciderResultReasonSummaryLens, + autoscalingDeciderResultReasonDetailsLens, + autoscalingDeciderResultExtrasLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Int (Int64) +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens) + +-- | Names an autoscaling policy in the +-- @\/_autoscaling\/policy\/{name}@ URL path. Wraps 'Text' so it round-trips +-- through JSON as a bare string but is distinct at the Haskell type level +-- from other policy ids (SLM\/ILM\/Enrich). +newtype AutoscalingPolicyName = AutoscalingPolicyName + { unAutoscalingPolicyName :: Text + } + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +------------------------------------------------------------------------------ +-- Policy +------------------------------------------------------------------------------ + +-- Known keys inside the policy object — used to split the decoded 'Object' +-- into the typed fields and the @apExtras@ catch-all. +policyKnownKeys :: [Key] +policyKnownKeys = ["roles", "deciders"] + +-- | An autoscaling policy — the PUT request body for +-- @PUT /_autoscaling/policy/{name}@ and the verbatim body returned by +-- @GET /_autoscaling/policy/{name}@. +-- +-- * @roles@ names the node roles the policy governs (e.g. @"data_hot"@, +-- @"data_content"@); an empty list is a valid (if unusual) policy that +-- matches no nodes. +-- * @deciders@ maps decider names to their decider-specific config objects +-- (e.g. @{"fixed": {}}@). Carried as an opaque 'KeyMap' 'Value' because +-- each decider owns its own schema and ES may add new deciders; this +-- mirrors the SLM\/Enrich precedent for category-specific nested bodies. +-- +-- Unknown sibling fields are preserved in 'apExtras' so the structure +-- round-trips through @encode . decode@ even when ES adds new optional +-- fields. +data AutoscalingPolicy = AutoscalingPolicy + { apRoles :: [Text], + apDeciders :: KeyMap Value, + apExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | A minimal empty policy (no roles, no deciders, no extras). Intended as a +-- starting point callers then overwrite with the record lenses. ES rejects a +-- policy without @deciders@ on PUT, so callers must populate at least one +-- decider before sending. +defaultAutoscalingPolicy :: AutoscalingPolicy +defaultAutoscalingPolicy = + AutoscalingPolicy + { apRoles = [], + apDeciders = KM.empty, + apExtras = KM.empty + } + +instance FromJSON AutoscalingPolicy where + parseJSON = withObject "AutoscalingPolicy" $ \o -> do + roles <- fromMaybe [] <$> (o .:? "roles") + deciders <- fromMaybe KM.empty <$> (o .:? "deciders") + let extras = + KM.fromList $ + filter ((`notElem` policyKnownKeys) . fst) $ + KM.toList o + pure + AutoscalingPolicy + { apRoles = roles, + apDeciders = deciders, + apExtras = extras + } + +instance ToJSON AutoscalingPolicy where + toJSON AutoscalingPolicy {..} = + -- 'object' (not 'omitNulls') so the @apExtras@ catch-all survives a + -- round-trip even when it carries a @null@ or empty-array value. The two + -- known fields are emitted unconditionally per the documented wire shape; + -- @apExtras@ has already had the known keys stripped on decode. + object $ + [ "roles" .= apRoles, + "deciders" .= apDeciders + ] + <> [toPair kv | kv <- KM.toList apExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- Capacity +------------------------------------------------------------------------------ + +-- | Response body of @GET /_autoscaling/capacity@: a @policies@ map keyed by +-- policy name. Carried as a 'KeyMap' because the policy names are dynamic +-- object keys (there is no stable enumerated set). +newtype AutoscalingCapacity = AutoscalingCapacity + { acPolicies :: KeyMap AutoscalingCapacityPolicy + } + deriving stock (Eq, Show) + +instance FromJSON AutoscalingCapacity where + parseJSON = withObject "AutoscalingCapacity" $ \o -> do + policies <- fromMaybe KM.empty <$> (o .:? "policies") + pure AutoscalingCapacity {acPolicies = policies} + +instance ToJSON AutoscalingCapacity where + toJSON (AutoscalingCapacity policies) = + object ["policies" .= policies] + +-- Known keys inside a per-policy capacity object. +capacityPolicyKnownKeys :: [Key] +capacityPolicyKnownKeys = + ["required_capacity", "current_capacity", "current_nodes", "deciders"] + +-- | The capacity result for a single policy, as nested under +-- @policies.@ in the 'AutoscalingCapacity' response. +-- +-- * @required_capacity@ — the capacity ES says the tier needs (the max across +-- all enabled deciders). +-- * @current_capacity@ — the capacity of the nodes ES currently bases its +-- calculation on. +-- * @current_nodes@ — the nodes used for the capacity calculation; callers +-- should verify these match the operator's view of the cluster. +-- * @deciders@ — per-decider capacity results, useful for diagnosing how the +-- outer @required_capacity@ was derived (diagnostic only). +-- +-- Unknown sibling fields are preserved in 'acpExtras'. +data AutoscalingCapacityPolicy = AutoscalingCapacityPolicy + { acpRequiredCapacity :: Maybe CapacitySize, + acpCurrentCapacity :: Maybe CapacitySize, + acpCurrentNodes :: Maybe [AutoscalingCurrentNode], + acpDeciders :: Maybe (KeyMap AutoscalingDeciderResult), + acpExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +instance FromJSON AutoscalingCapacityPolicy where + parseJSON = withObject "AutoscalingCapacityPolicy" $ \o -> do + requiredCapacity <- o .:? "required_capacity" + currentCapacity <- o .:? "current_capacity" + currentNodes <- o .:? "current_nodes" + deciders <- o .:? "deciders" + let extras = + KM.fromList $ + filter ((`notElem` capacityPolicyKnownKeys) . fst) $ + KM.toList o + pure + AutoscalingCapacityPolicy + { acpRequiredCapacity = requiredCapacity, + acpCurrentCapacity = currentCapacity, + acpCurrentNodes = currentNodes, + acpDeciders = deciders, + acpExtras = extras + } + +instance ToJSON AutoscalingCapacityPolicy where + toJSON AutoscalingCapacityPolicy {..} = + object $ + catMaybes + [ ("required_capacity" .=) <$> acpRequiredCapacity, + ("current_capacity" .=) <$> acpCurrentCapacity, + ("current_nodes" .=) <$> acpCurrentNodes, + ("deciders" .=) <$> acpDeciders + ] + <> [toPair kv | kv <- KM.toList acpExtras] + where + toPair (k, v) = k .= v + +-- Known keys inside a capacity size object (@node@ \/ @total@ envelope). +capacitySizeKnownKeys :: [Key] +capacitySizeKnownKeys = ["node", "total"] + +-- | A capacity envelope holding a per-node and a total 'AutoscalingResource'. +-- Used for both @required_capacity@ and @current_capacity@ in +-- 'AutoscalingCapacityPolicy' and for each decider's @required_capacity@ in +-- 'AutoscalingDeciderResult'. +data CapacitySize = CapacitySize + { capNode :: Maybe AutoscalingResource, + capTotal :: Maybe AutoscalingResource, + capExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +instance FromJSON CapacitySize where + parseJSON = withObject "CapacitySize" $ \o -> do + node <- o .:? "node" + total <- o .:? "total" + let extras = + KM.fromList $ + filter ((`notElem` capacitySizeKnownKeys) . fst) $ + KM.toList o + pure + CapacitySize + { capNode = node, + capTotal = total, + capExtras = extras + } + +instance ToJSON CapacitySize where + toJSON CapacitySize {..} = + object $ + catMaybes + [ ("node" .=) <$> capNode, + ("total" .=) <$> capTotal + ] + <> [toPair kv | kv <- KM.toList capExtras] + where + toPair (k, v) = k .= v + +-- Known keys inside a resource object (@storage@ \/ @memory@ envelope). +resourceKnownKeys :: [Key] +resourceKnownKeys = ["storage", "memory"] + +-- | A storage\/memory byte pair. Both fields are optional byte counts +-- (Int64): ES omits a field when it has no opinion for that resource. +-- Unknown sibling fields are preserved in 'arExtras'. +data AutoscalingResource = AutoscalingResource + { arStorage :: Maybe Int64, + arMemory :: Maybe Int64, + arExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +instance FromJSON AutoscalingResource where + parseJSON = withObject "AutoscalingResource" $ \o -> do + storage <- o .:? "storage" + memory <- o .:? "memory" + let extras = + KM.fromList $ + filter ((`notElem` resourceKnownKeys) . fst) $ + KM.toList o + pure + AutoscalingResource + { arStorage = storage, + arMemory = memory, + arExtras = extras + } + +instance ToJSON AutoscalingResource where + toJSON AutoscalingResource {..} = + object $ + catMaybes + [ ("storage" .=) <$> arStorage, + ("memory" .=) <$> arMemory + ] + <> [toPair kv | kv <- KM.toList arExtras] + where + toPair (k, v) = k .= v + +-- Known keys inside a @current_nodes@ element. +currentNodeKnownKeys :: [Key] +currentNodeKnownKeys = ["name"] + +-- | A single entry of the @current_nodes@ array. Only @name@ is documented; +-- any sibling fields are preserved in 'acndExtras'. +data AutoscalingCurrentNode = AutoscalingCurrentNode + { acndName :: Text, + acndExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +instance FromJSON AutoscalingCurrentNode where + parseJSON = withObject "AutoscalingCurrentNode" $ \o -> do + name <- o .: "name" + let extras = + KM.fromList $ + filter ((`notElem` currentNodeKnownKeys) . fst) $ + KM.toList o + pure + AutoscalingCurrentNode + { acndName = name, + acndExtras = extras + } + +instance ToJSON AutoscalingCurrentNode where + toJSON AutoscalingCurrentNode {..} = + object $ + ["name" .= acndName] + <> [toPair kv | kv <- KM.toList acndExtras] + where + toPair (k, v) = k .= v + +-- Known keys inside a per-decider result object. +deciderResultKnownKeys :: [Key] +deciderResultKnownKeys = + ["required_capacity", "reason_summary", "reason_details"] + +-- | The capacity result for a single decider, as nested under +-- @deciders.@. @reason_summary@ is a human-readable +-- explanation; @reason_details@ is a per-decider structure the docs state +-- should not be relied on for application purposes and is not subject to +-- backwards-compatibility guarantees, hence the opaque 'Value'. Unknown +-- sibling fields are preserved in 'adrExtras'. +data AutoscalingDeciderResult = AutoscalingDeciderResult + { adrRequiredCapacity :: Maybe CapacitySize, + adrReasonSummary :: Maybe Text, + adrReasonDetails :: Maybe Value, + adrExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +instance FromJSON AutoscalingDeciderResult where + parseJSON = withObject "AutoscalingDeciderResult" $ \o -> do + requiredCapacity <- o .:? "required_capacity" + reasonSummary <- o .:? "reason_summary" + reasonDetails <- o .:? "reason_details" + let extras = + KM.fromList $ + filter ((`notElem` deciderResultKnownKeys) . fst) $ + KM.toList o + pure + AutoscalingDeciderResult + { adrRequiredCapacity = requiredCapacity, + adrReasonSummary = reasonSummary, + adrReasonDetails = reasonDetails, + adrExtras = extras + } + +instance ToJSON AutoscalingDeciderResult where + toJSON AutoscalingDeciderResult {..} = + object $ + catMaybes + [ ("required_capacity" .=) <$> adrRequiredCapacity, + ("reason_summary" .=) <$> adrReasonSummary, + ("reason_details" .=) <$> adrReasonDetails + ] + <> [toPair kv | kv <- KM.toList adrExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +autoscalingPolicyRolesLens :: Lens' AutoscalingPolicy [Text] +autoscalingPolicyRolesLens = + lens apRoles (\x y -> x {apRoles = y}) + +autoscalingPolicyDecidersLens :: + Lens' AutoscalingPolicy (KeyMap Value) +autoscalingPolicyDecidersLens = + lens apDeciders (\x y -> x {apDeciders = y}) + +autoscalingPolicyExtrasLens :: + Lens' AutoscalingPolicy (KeyMap Value) +autoscalingPolicyExtrasLens = + lens apExtras (\x y -> x {apExtras = y}) + +autoscalingCapacityPoliciesLens :: + Lens' AutoscalingCapacity (KeyMap AutoscalingCapacityPolicy) +autoscalingCapacityPoliciesLens = + lens + acPolicies + (\_ y -> AutoscalingCapacity y) + +autoscalingCapacityPolicyRequiredCapacityLens :: + Lens' AutoscalingCapacityPolicy (Maybe CapacitySize) +autoscalingCapacityPolicyRequiredCapacityLens = + lens acpRequiredCapacity (\x y -> x {acpRequiredCapacity = y}) + +autoscalingCapacityPolicyCurrentCapacityLens :: + Lens' AutoscalingCapacityPolicy (Maybe CapacitySize) +autoscalingCapacityPolicyCurrentCapacityLens = + lens acpCurrentCapacity (\x y -> x {acpCurrentCapacity = y}) + +autoscalingCapacityPolicyCurrentNodesLens :: + Lens' AutoscalingCapacityPolicy (Maybe [AutoscalingCurrentNode]) +autoscalingCapacityPolicyCurrentNodesLens = + lens acpCurrentNodes (\x y -> x {acpCurrentNodes = y}) + +autoscalingCapacityPolicyDecidersLens :: + Lens' AutoscalingCapacityPolicy (Maybe (KeyMap AutoscalingDeciderResult)) +autoscalingCapacityPolicyDecidersLens = + lens acpDeciders (\x y -> x {acpDeciders = y}) + +autoscalingCapacityPolicyExtrasLens :: + Lens' AutoscalingCapacityPolicy (KeyMap Value) +autoscalingCapacityPolicyExtrasLens = + lens acpExtras (\x y -> x {acpExtras = y}) + +capacitySizeNodeLens :: Lens' CapacitySize (Maybe AutoscalingResource) +capacitySizeNodeLens = + lens capNode (\x y -> x {capNode = y}) + +capacitySizeTotalLens :: Lens' CapacitySize (Maybe AutoscalingResource) +capacitySizeTotalLens = + lens capTotal (\x y -> x {capTotal = y}) + +capacitySizeExtrasLens :: Lens' CapacitySize (KeyMap Value) +capacitySizeExtrasLens = + lens capExtras (\x y -> x {capExtras = y}) + +autoscalingResourceStorageLens :: Lens' AutoscalingResource (Maybe Int64) +autoscalingResourceStorageLens = + lens arStorage (\x y -> x {arStorage = y}) + +autoscalingResourceMemoryLens :: Lens' AutoscalingResource (Maybe Int64) +autoscalingResourceMemoryLens = + lens arMemory (\x y -> x {arMemory = y}) + +autoscalingResourceExtrasLens :: + Lens' AutoscalingResource (KeyMap Value) +autoscalingResourceExtrasLens = + lens arExtras (\x y -> x {arExtras = y}) + +autoscalingCurrentNodeNameLens :: Lens' AutoscalingCurrentNode Text +autoscalingCurrentNodeNameLens = + lens acndName (\x y -> x {acndName = y}) + +autoscalingCurrentNodeExtrasLens :: + Lens' AutoscalingCurrentNode (KeyMap Value) +autoscalingCurrentNodeExtrasLens = + lens acndExtras (\x y -> x {acndExtras = y}) + +autoscalingDeciderResultRequiredCapacityLens :: + Lens' AutoscalingDeciderResult (Maybe CapacitySize) +autoscalingDeciderResultRequiredCapacityLens = + lens adrRequiredCapacity (\x y -> x {adrRequiredCapacity = y}) + +autoscalingDeciderResultReasonSummaryLens :: + Lens' AutoscalingDeciderResult (Maybe Text) +autoscalingDeciderResultReasonSummaryLens = + lens adrReasonSummary (\x y -> x {adrReasonSummary = y}) + +autoscalingDeciderResultReasonDetailsLens :: + Lens' AutoscalingDeciderResult (Maybe Value) +autoscalingDeciderResultReasonDetailsLens = + lens adrReasonDetails (\x y -> x {adrReasonDetails = y}) + +autoscalingDeciderResultExtrasLens :: + Lens' AutoscalingDeciderResult (KeyMap Value) +autoscalingDeciderResultExtrasLens = + lens adrExtras (\x y -> x {adrExtras = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Bulk.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Bulk.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Bulk.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Bulk.hs @@ -1,12 +1,22 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module Database.Bloodhound.Internal.Versions.Common.Types.Bulk - ( -- * Request - BulkOperation (..), + ( -- * Per-operation metadata UpsertActionMetadata (..), - UpsertPayload (..), buildUpsertActionMetadata, + UpsertPayload (..), + -- * Bulk operation + BulkOperation (..), + + -- * Bulk endpoint URI parameters + BulkSettings (..), + defaultBulkSettings, + bulkSettingsParams, + -- * Response BulkResponse (..), BulkActionItem (..), @@ -24,26 +34,97 @@ biIdLens, biStatusLens, biErrorLens, + biSeqNoLens, + biPrimaryTermLens, + biVersionLens, + biShardsLens, + biResultLens, beTypeLens, beReasonLens, + bsRefreshLens, + bsTimeoutLens, + bsWaitForActiveShardsLens, + bsRoutingLens, + bsSourceLens, + bsSourceIncludesLens, + bsSourceExcludesLens, + bsPipelineLens, + bsRequireAliasLens, ) where -import qualified Data.Aeson as A -import qualified Data.Aeson.Key as A -import qualified Data.Aeson.Types as A +import Data.Aeson qualified as A +import Data.Aeson.Key qualified as A +import Data.Aeson.Types qualified as A +import Data.Word (Word64) import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Indices + ( ActiveShardCount, + renderActiveShardCount, + ) import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( DocId, + IndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes (ShardResult) import Database.Bloodhound.Internal.Versions.Common.Types.Query +import Database.Bloodhound.Internal.Versions.Common.Types.Refresh + ( RefreshPolicy, + renderRefreshPolicy, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.VersionType + ( VersionType, + renderVersionType, + ) +-- | Metadata fields that may appear in the action-and-meta-data line of +-- a bulk NDJSON stream. These are the @routing@, @version@, +-- @version_type@, @if_seq_no@, @if_primary_term@, @require_alias@, +-- @retry_on_conflict@ entries documented at +-- . +-- +-- Note that the bulk action-line field names /do not/ carry the leading +-- underscore — only the core identity fields (@_index@, @_id@, @_source@) +-- do. This differs from the Index API URI parameters, which omit the +-- underscore by URI convention but are often documented with one. +-- +-- The list is a set of overrides — pass @[]@ if you don't need any. +-- Where a server expects two fields together (e.g. @if_seq_no@ and +-- @if_primary_term@ for optimistic concurrency), the partial pair is +-- emitted verbatim and the server returns HTTP 400 on the offending +-- sub-request rather than silently dropping the check. data UpsertActionMetadata - = UA_RetryOnConflict Int - | UA_Version Int + = -- | @routing@ — explicit shard routing value. + UA_Routing Text + | -- | @version@ — caller-supplied version (paired with + -- 'UA_VersionType' for external versioning). + UA_Version Int + | -- | @version_type@ — internal \/ external \/ external_gt \/ + -- external_gte. + UA_VersionType VersionType + | -- | @if_seq_no@ — optimistic-concurrency sequence number. + UA_IfSeqNo Word64 + | -- | @if_primary_term@ — optimistic-concurrency primary term. + UA_IfPrimaryTerm Word64 + | -- | @require_alias@ — @True@ requires the @_index@ target to be an + -- alias (used by data-stream write targets). + UA_RequireAlias Bool + | -- | @retry_on_conflict@ — number of times to retry an @update@ or + -- @upsert@ op on a version conflict before giving up. + UA_RetryOnConflict Int deriving stock (Eq, Show) -buildUpsertActionMetadata :: UpsertActionMetadata -> Pair -buildUpsertActionMetadata (UA_RetryOnConflict i) = "retry_on_conflict" .= i -buildUpsertActionMetadata (UA_Version i) = "_version" .= i +-- | Render one piece of metadata as an aeson 'Pair' suitable for the +-- action-and-meta-data JSON line. +buildUpsertActionMetadata :: UpsertActionMetadata -> A.Pair +buildUpsertActionMetadata = \case + UA_Routing r -> "routing" .= r + UA_Version n -> "version" .= n + UA_VersionType t -> "version_type" .= renderVersionType t + UA_IfSeqNo n -> "if_seq_no" .= n + UA_IfPrimaryTerm n -> "if_primary_term" .= n + UA_RequireAlias b -> "require_alias" .= b + UA_RetryOnConflict n -> "retry_on_conflict" .= n data UpsertPayload = UpsertDoc Value @@ -53,8 +134,14 @@ -- | 'BulkOperation' is a sum type for expressing the four kinds of bulk -- operation index, create, delete, and update. 'BulkIndex' behaves like an -- "upsert", 'BulkCreate' will fail if a document already exists at the DocId. --- Consult the +-- Consult the -- for further explanation. +-- +-- Every constructor takes a final @[UpsertActionMetadata]@ argument +-- that becomes part of the action-and-meta-data line of the NDJSON +-- stream (the @_routing@, @_version@, @_if_seq_no@ ... fields). Pass +-- @[]@ when no per-op metadata is needed. +-- -- Warning: Bulk operations suffixed with @Auto@ rely on Elasticsearch to -- generate the id. Often, people use auto-generated identifiers when -- Elasticsearch is the only place that their data is stored. Do not let @@ -64,23 +151,132 @@ -- discussed further on github. data BulkOperation = -- | Create the document, replacing it if it already exists. - BulkIndex IndexName DocId Value + BulkIndex IndexName DocId Value [UpsertActionMetadata] | -- | Create a document with an autogenerated id. - BulkIndexAuto IndexName Value + BulkIndexAuto IndexName Value [UpsertActionMetadata] | -- | Create a document with an autogenerated id. Use fast JSON encoding. - BulkIndexEncodingAuto IndexName Encoding + BulkIndexEncodingAuto IndexName Encoding [UpsertActionMetadata] | -- | Create a document, failing if it already exists. - BulkCreate IndexName DocId Value + BulkCreate IndexName DocId Value [UpsertActionMetadata] | -- | Create a document, failing if it already exists. Use fast JSON encoding. - BulkCreateEncoding IndexName DocId Encoding - | -- | Delete the document - BulkDelete IndexName DocId + BulkCreateEncoding IndexName DocId Encoding [UpsertActionMetadata] + | -- | Delete the document. + BulkDelete IndexName DocId [UpsertActionMetadata] | -- | Update the document, merging the new value with the existing one. - BulkUpdate IndexName DocId Value + BulkUpdate IndexName DocId Value [UpsertActionMetadata] | -- | Update the document if it already exists, otherwise insert it. BulkUpsert IndexName DocId UpsertPayload [UpsertActionMetadata] deriving stock (Eq, Show) +-- | URI-level parameters for the @POST /_bulk@ endpoint, documented at +-- . +-- +-- All fields are 'Maybe'; 'defaultBulkSettings' leaves every field +-- @Nothing@ so that 'Database.Bloodhound.Common.Requests.bulk' +-- (which uses the default) is byte-for-byte identical to the +-- pre-existing parameterless wire shape. +-- +-- The @_source*@ family mirrors the Index API's source filtering: pass +-- 'bsSource' = @Just False@ to disable source retrieval entirely, or +-- 'bsSourceIncludes' \/ 'bsSourceExcludes' with a comma-separated list +-- of field patterns (e.g. @"metadata.*,name"@) to include / exclude. +data BulkSettings = BulkSettings + { -- | @refresh@ — refresh policy after the bulk completes. + bsRefresh :: Maybe RefreshPolicy, + -- | @timeout@ — per-operation request timeout, e.g. @"5s"@ or @"1m"@. + bsTimeout :: Maybe Text, + -- | @wait_for_active_shards@ — shard copies required before each + -- operation returns. Uses the shared 'ActiveShardCount' so @"all"@ + -- and numeric counts are both representable. + bsWaitForActiveShards :: Maybe ActiveShardCount, + -- | @routing@ — default shard routing for every operation that + -- doesn't carry its own @_routing@ metadata. + bsRouting :: Maybe Text, + -- | @_source@ — enable \/ disable source retrieval for the bulk + -- response. Defaults to server-default (true). + bsSource :: Maybe Bool, + -- | @_source_includes@ — comma-separated field globs to include. + bsSourceIncludes :: Maybe Text, + -- | @_source_excludes@ — comma-separated field globs to exclude. + bsSourceExcludes :: Maybe Text, + -- | @pipeline@ — ingest pipeline id applied to every index / update + -- operation that doesn't override it. + bsPipeline :: Maybe Text, + -- | @require_alias@ — when @Just True@, every @_index@ target must + -- be an alias. Required for data-stream writes. @Nothing@ and + -- @Just False@ are equivalent on the wire and allow both concrete + -- indexes and aliases. + bsRequireAlias :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'BulkSettings' with every field set to 'Nothing'. Produces an empty +-- query-string, preserving the wire behaviour of the legacy +-- parameterless 'Database.Bloodhound.Common.Requests.bulk'. +defaultBulkSettings :: BulkSettings +defaultBulkSettings = + BulkSettings + { bsRefresh = Nothing, + bsTimeout = Nothing, + bsWaitForActiveShards = Nothing, + bsRouting = Nothing, + bsSource = Nothing, + bsSourceIncludes = Nothing, + bsSourceExcludes = Nothing, + bsPipeline = Nothing, + bsRequireAlias = Nothing + } + +-- | Render a 'BulkSettings' record as a @key=value@ list suitable for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. +-- 'Nothing' fields are omitted; the order of the list is stable but +-- unspecified — callers should treat it as a set. +bulkSettingsParams :: BulkSettings -> [(Text, Maybe Text)] +bulkSettingsParams BulkSettings {..} = + catMaybes + [ ("refresh",) . Just . renderRefreshPolicy <$> bsRefresh, + ("timeout",) . Just <$> bsTimeout, + ("wait_for_active_shards",) . Just . renderActiveShardCount <$> bsWaitForActiveShards, + ("routing",) . Just <$> bsRouting, + ("_source",) . Just . boolText <$> bsSource, + ("_source_includes",) . Just <$> bsSourceIncludes, + ("_source_excludes",) . Just <$> bsSourceExcludes, + ("pipeline",) . Just <$> bsPipeline, + ("require_alias",) . Just . boolText <$> bsRequireAlias + ] + where + boolText :: Bool -> Text + boolText True = "true" + boolText False = "false" + +bsRefreshLens :: Lens' BulkSettings (Maybe RefreshPolicy) +bsRefreshLens = lens bsRefresh (\x y -> x {bsRefresh = y}) + +bsTimeoutLens :: Lens' BulkSettings (Maybe Text) +bsTimeoutLens = lens bsTimeout (\x y -> x {bsTimeout = y}) + +bsWaitForActiveShardsLens :: Lens' BulkSettings (Maybe ActiveShardCount) +bsWaitForActiveShardsLens = + lens bsWaitForActiveShards (\x y -> x {bsWaitForActiveShards = y}) + +bsRoutingLens :: Lens' BulkSettings (Maybe Text) +bsRoutingLens = lens bsRouting (\x y -> x {bsRouting = y}) + +bsSourceLens :: Lens' BulkSettings (Maybe Bool) +bsSourceLens = lens bsSource (\x y -> x {bsSource = y}) + +bsSourceIncludesLens :: Lens' BulkSettings (Maybe Text) +bsSourceIncludesLens = lens bsSourceIncludes (\x y -> x {bsSourceIncludes = y}) + +bsSourceExcludesLens :: Lens' BulkSettings (Maybe Text) +bsSourceExcludesLens = lens bsSourceExcludes (\x y -> x {bsSourceExcludes = y}) + +bsPipelineLens :: Lens' BulkSettings (Maybe Text) +bsPipelineLens = lens bsPipeline (\x y -> x {bsPipeline = y}) + +bsRequireAliasLens :: Lens' BulkSettings (Maybe Bool) +bsRequireAliasLens = lens bsRequireAlias (\x y -> x {bsRequireAlias = y}) + data BulkResponse = BulkResponse { bulkTook :: Int, bulkErrors :: Bool, @@ -111,16 +307,24 @@ data BulkItem = BulkItem { biIndex :: Text, - biId :: Text, + biId :: Maybe Text, biStatus :: Maybe Int, - biError :: Maybe BulkError + biError :: Maybe BulkError, + -- | The following fields are only present on successful writes. + -- Backends omit them on per-item errors, and some backends also + -- omit @_shards@ / @_seq_no@ / @_primary_term@ on @delete@ results. + biSeqNo :: Maybe Int, + biPrimaryTerm :: Maybe Int, + biVersion :: Maybe Int, + biShards :: Maybe ShardResult, + biResult :: Maybe Text } deriving stock (Eq, Show) biIndexLens :: Lens' BulkItem Text biIndexLens = lens biIndex (\x y -> x {biIndex = y}) -biIdLens :: Lens' BulkItem Text +biIdLens :: Lens' BulkItem (Maybe Text) biIdLens = lens biId (\x y -> x {biId = y}) biStatusLens :: Lens' BulkItem (Maybe Int) @@ -129,6 +333,21 @@ biErrorLens :: Lens' BulkItem (Maybe BulkError) biErrorLens = lens biError (\x y -> x {biError = y}) +biSeqNoLens :: Lens' BulkItem (Maybe Int) +biSeqNoLens = lens biSeqNo (\x y -> x {biSeqNo = y}) + +biPrimaryTermLens :: Lens' BulkItem (Maybe Int) +biPrimaryTermLens = lens biPrimaryTerm (\x y -> x {biPrimaryTerm = y}) + +biVersionLens :: Lens' BulkItem (Maybe Int) +biVersionLens = lens biVersion (\x y -> x {biVersion = y}) + +biShardsLens :: Lens' BulkItem (Maybe ShardResult) +biShardsLens = lens biShards (\x y -> x {biShards = y}) + +biResultLens :: Lens' BulkItem (Maybe Text) +biResultLens = lens biResult (\x y -> x {biResult = y}) + data BulkAction = Index | Create | Delete | Update deriving stock (Eq, Show) @@ -175,11 +394,21 @@ <$> o .: "_index" <*> o - .: "_id" + .:? "_id" <*> o .:? "status" -- allegedly present but ES example shows a case where it is missing.. so.. <*> o .:? "error" + <*> o + .:? "_seq_no" + <*> o + .:? "_primary_term" + <*> o + .:? "_version" + <*> o + .:? "_shards" + <*> o + .:? "result" instance FromJSON BulkError where parseJSON = withObject "BulkError" $ diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Cat.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Cat.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Cat.hs @@ -0,0 +1,7667 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Cat +-- Copyright : (C) 2014, 2018 Chris Allen +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Chris Allen +-- Stability : provisional +-- Portability : GHC +-- +-- Types for the @_cat\/indices@ endpoint — both the URI parameters +-- accepted by @GET /_cat/indices@ (and the per-index @//_cat/indices@ +-- form) and the structured row returned when @format=json@ is set. +-- +-- The cat APIs are documented as \"human consumption\" endpoints, but +-- @format=json@ makes them machine-readable. ES renders every column +-- (including numerics) as a JSON string, e.g. +-- +-- @ +-- [{\"health\":\"green\",\"status\":\"open\",\"index\":\"logs\",\"uuid\":\"x\",\"pri\":\"1\",\"rep\":\"1\",\"docs.count\":\"42\",\"docs.deleted\":\"0\",\"store.size\":\"5kb\",\"pri.store.size\":\"5kb\"}] +-- @ +-- +-- The parsers below tolerate both string and native JSON scalars so +-- callers do not have to care which renderer the server picked. +module Database.Bloodhound.Internal.Versions.Common.Types.Cat + ( -- * @_cat\/indices@ URI parameters + CatIndicesOptions (..), + defaultCatIndicesOptions, + catIndicesOptionsParams, + + -- ** Parameter renderers + catBytesSizeText, + catHealthFilterText, + catIndicesColumnText, + catSortSpecText, + + -- ** Optics + catoBytesLens, + catoColumnsLens, + catoExpandWildcardsLens, + catoHealthLens, + catoHelpLens, + catoIncludeUnloadedSegmentsLens, + catoLocalLens, + catoMasterTimeoutLens, + catoPriLens, + catoSortLens, + catoVerboseLens, + + -- ** @_cat\/indices@ URI parameter types + CatBytesSize (..), + CatHealthFilter (..), + CatIndicesColumn (..), + CatSortSpec (..), + CatSortDirection (..), + + -- * @_cat\/indices@ response row + CatIndicesRow (..), + CatIndexHealth (..), + CatIndexStatus (..), + catIndexHealthText, + catIndexStatusText, + catSizeInBytes, + + -- ** Optics + cirDatasetLens, + cirDocsCountLens, + cirDocsDeletedLens, + cirHealthLens, + cirIndexLens, + cirOtherLens, + cirPrimaryShardsLens, + cirPrimaryStoreSizeLens, + cirReplicaCountLens, + cirStatusLens, + cirStoreSizeLens, + cirUuidLens, + + -- * @_cat\/aliases@ URI parameters + CatAliasesOptions (..), + defaultCatAliasesOptions, + catAliasesOptionsParams, + + -- ** Parameter renderers + catAliasesColumnText, + catAliasesSortSpecText, + + -- ** Optics + caaColumnsLens, + caaExpandWildcardsLens, + caaHelpLens, + caaLocalLens, + caaMasterTimeoutLens, + caaSortLens, + caaVerboseLens, + + -- ** @_cat\/aliases@ URI parameter types + CatAliasesColumn (..), + CatAliasesSortSpec (..), + + -- * @_cat\/aliases@ response row + CatAliasesRow (..), + catAliasesIsWriteIndexFromText, + catAliasesIsWriteIndexToText, + + -- ** Optics + carAliasLens, + carFilterLens, + carIndexLens, + carIsWriteIndexLens, + carOtherLens, + carRoutingIndexLens, + carRoutingSearchLens, + + -- * @_cat\/allocation@ URI parameters + CatAllocationOptions (..), + defaultCatAllocationOptions, + catAllocationOptionsParams, + + -- ** Parameter renderers + catAllocationColumnText, + catAllocationSortSpecText, + + -- ** Optics + caloBytesLens, + caloColumnsLens, + caloExpandWildcardsLens, + caloHelpLens, + caloLocalLens, + caloMasterTimeoutLens, + caloSortLens, + caloVerboseLens, + + -- ** @_cat\/allocation@ URI parameter types + CatAllocationColumn (..), + CatAllocationSortSpec (..), + + -- * @_cat\/allocation@ response row + CatAllocationRow (..), + CatShardsUndesired (..), + catShardsUndesiredFromText, + catShardsUndesiredToText, + + -- ** Optics + calrDiskAvailLens, + calrDiskIndicesLens, + calrDiskIndicesForecastLens, + calrDiskPercentLens, + calrDiskTotalLens, + calrDiskUsedLens, + calrHostLens, + calrIpLens, + calrNodeLens, + calrNodeRoleLens, + calrOtherLens, + calrShardsLens, + calrShardsUndesiredLens, + calrWriteLoadForecastLens, + + -- * @_cat\/fielddata@ URI parameters + CatFielddataOptions (..), + defaultCatFielddataOptions, + catFielddataOptionsParams, + + -- ** Parameter renderers + catFielddataColumnText, + catFielddataSortSpecText, + + -- ** Optics + cfdoBytesLens, + cfdoColumnsLens, + cfdoHelpLens, + cfdoLocalLens, + cfdoMasterTimeoutLens, + cfdoSortLens, + cfdoVerboseLens, + + -- ** @_cat\/fielddata@ URI parameter types + CatFielddataColumn (..), + CatFielddataSortSpec (..), + + -- * @_cat\/fielddata@ response row + CatFielddataRow (..), + + -- ** Optics + cfdrFieldLens, + cfdrHostLens, + cfdrIdLens, + cfdrIpLens, + cfdrNodeLens, + cfdrOtherLens, + cfdrSizeLens, + + -- * @_cat\/nodeattrs@ URI parameters + CatNodeattrsOptions (..), + defaultCatNodeattrsOptions, + catNodeattrsOptionsParams, + + -- ** Parameter renderers + catNodeattrsColumnText, + catNodeattrsSortSpecText, + + -- ** Optics + cnaoColumnsLens, + cnaoHelpLens, + cnaoLocalLens, + cnaoMasterTimeoutLens, + cnaoSortLens, + cnaoVerboseLens, + + -- ** @_cat\/nodeattrs@ URI parameter types + CatNodeattrsColumn (..), + CatNodeattrsSortSpec (..), + + -- * @_cat\/nodeattrs@ response row + CatNodeattrsRow (..), + + -- ** Optics + cnarAttrLens, + cnarHostLens, + cnarIdLens, + cnarIpLens, + cnarNodeLens, + cnarOtherLens, + cnarPidLens, + cnarPortLens, + cnarValueLens, + + -- * @_cat\/repositories@ URI parameters + CatRepositoriesOptions (..), + defaultCatRepositoriesOptions, + catRepositoriesOptionsParams, + + -- ** Parameter renderers + catRepositoriesColumnText, + catRepositoriesSortSpecText, + + -- ** Optics + creoColumnsLens, + creoHelpLens, + creoLocalLens, + creoMasterTimeoutLens, + creoSortLens, + creoVerboseLens, + + -- ** @_cat\/repositories@ URI parameter types + CatRepositoriesColumn (..), + CatRepositoriesSortSpec (..), + + -- * @_cat\/repositories@ response row + CatRepositoriesRow (..), + + -- ** Optics + crrIdLens, + crrOtherLens, + crrTypeLens, + + -- * @_cat\/shards@ URI parameters + CatShardsOptions (..), + defaultCatShardsOptions, + catShardsOptionsParams, + + -- ** Parameter renderers + catShardsColumnText, + catShardsSortSpecText, + + -- ** Optics + cshoBytesLens, + cshoColumnsLens, + cshoHelpLens, + cshoLocalLens, + cshoMasterTimeoutLens, + cshoSortLens, + cshoTimeLens, + cshoVerboseLens, + + -- ** @_cat\/shards@ URI parameter types + CatShardsColumn (..), + CatShardsSortSpec (..), + + -- * @_cat\/shards@ response row + CatShardsRow (..), + + -- ** Optics + csrDatasetLens, + csrDocsLens, + csrIndexLens, + csrNodeLens, + csrOtherLens, + csrPrirepLens, + csrShardLens, + csrStateLens, + csrStoreLens, + + -- * @_cat\/tasks@ URI parameters + CatTasksOptions (..), + defaultCatTasksOptions, + catTasksOptionsParams, + + -- ** Parameter renderers + catTasksColumnText, + catTasksSortSpecText, + + -- ** Optics + cttoActionsLens, + cttoColumnsLens, + cttoDetailedLens, + cttoHelpLens, + cttoLocalLens, + cttoMasterTimeoutLens, + cttoNodesLens, + cttoParentTaskIdLens, + cttoSortLens, + cttoVerboseLens, + + -- ** @_cat\/tasks@ URI parameter types + CatTasksColumn (..), + CatTasksSortSpec (..), + + -- * @_cat\/tasks@ response row + CatTasksRow (..), + + -- ** Optics + ctrrActionLens, + ctrrDescriptionLens, + ctrrIdLens, + ctrrIpLens, + ctrrNodeLens, + ctrrNodeIdLens, + ctrrOtherLens, + ctrrParentTaskIdLens, + ctrrPortLens, + ctrrRunningTimeLens, + ctrrRunningTimeNsLens, + ctrrStartTimeLens, + ctrrTaskIdLens, + ctrrTimestampLens, + ctrrTypeLens, + ctrrVersionLens, + ctrrXOpaqueIdLens, + + -- * @_cat\/snapshots@ URI parameters + CatSnapshotsOptions (..), + defaultCatSnapshotsOptions, + catSnapshotsOptionsParams, + + -- ** Parameter renderers + catSnapshotsColumnText, + catSnapshotsSortSpecText, + + -- ** Optics + csnoColumnsLens, + csnoHelpLens, + csnoIgnoreUnavailableLens, + csnoLocalLens, + csnoMasterTimeoutLens, + csnoSortLens, + csnoVerboseLens, + + -- ** @_cat\/snapshots@ URI parameter types + CatSnapshotsColumn (..), + CatSnapshotsSortSpec (..), + + -- * @_cat\/snapshots@ response row + CatSnapshotsRow (..), + + -- ** Optics + csnrDurationLens, + csnrEndEpochLens, + csnrEndTimeLens, + csnrFailedShardsLens, + csnrIdLens, + csnrIndicesLens, + csnrOtherLens, + csnrReasonLens, + csnrRepositoryLens, + csnrStartEpochLens, + csnrStartTimeLens, + csnrStatusLens, + csnrSuccessfulShardsLens, + csnrTotalShardsLens, + + -- * @_cat\/nodes@ URI parameters + CatNodesOptions (..), + defaultCatNodesOptions, + catNodesOptionsParams, + + -- ** Parameter renderers + catNodesColumnText, + catNodesSortSpecText, + + -- ** Optics + cnoBytesLens, + cnoColumnsLens, + cnoHelpLens, + cnoLocalLens, + cnoMasterTimeoutLens, + cnoSortLens, + cnoTimeLens, + cnoVerboseLens, + + -- ** @_cat\/nodes@ URI parameter types + CatNodesColumn (..), + CatNodesSortSpec (..), + + -- * @_cat\/nodes@ response row + CatNodesRow (..), + CatNodesMaster (..), + catNodesMasterFromText, + catNodesMasterToText, + + -- ** Optics + cnrCpuLens, + cnrDiskAvailLens, + cnrDiskTotalLens, + cnrDiskUsedLens, + cnrDiskUsedPercentLens, + cnrFileDescCurrentLens, + cnrFileDescMaxLens, + cnrFileDescPercentLens, + cnrHeapCurrentLens, + cnrHeapMaxLens, + cnrHeapPercentLens, + cnrHostLens, + cnrIdLens, + cnrIpLens, + cnrLoad15mLens, + cnrLoad1mLens, + cnrLoad5mLens, + cnrMasterLens, + cnrNameLens, + cnrNodeRoleLens, + cnrOtherLens, + cnrPidLens, + cnrPortLens, + cnrRamCurrentLens, + cnrRamMaxLens, + cnrRamPercentLens, + + -- * @_cat\/count@ URI parameters + CatCountOptions (..), + defaultCatCountOptions, + catCountOptionsParams, + + -- ** Parameter renderers + catCountColumnText, + + -- ** Optics + ccoColumnsLens, + ccoHelpLens, + ccoLocalLens, + ccoMasterTimeoutLens, + ccoVerboseLens, + + -- ** @_cat\/count@ URI parameter types + CatCountColumn (..), + + -- * @_cat\/count@ response row + CatCountRow (..), + + -- ** Optics + ccrCountLens, + ccrEpochLens, + ccrOtherLens, + ccrTimestampLens, + + -- * @_cat\/master@ URI parameters + CatMasterOptions (..), + defaultCatMasterOptions, + catMasterOptionsParams, + + -- ** Parameter renderers + catMasterColumnText, + + -- ** Optics + cmoColumnsLens, + cmoHelpLens, + cmoLocalLens, + cmoMasterTimeoutLens, + cmoVerboseLens, + + -- ** @_cat\/master@ URI parameter types + CatMasterColumn (..), + + -- * @_cat\/master@ response row + CatMasterRow (..), + + -- ** Optics + cmrHostLens, + cmrIdLens, + cmrIpLens, + cmrNodeLens, + cmrOtherLens, + + -- * @_cat\/health@ URI parameters + CatHealthOptions (..), + defaultCatHealthOptions, + catHealthOptionsParams, + + -- ** Parameter renderers + catHealthColumnText, + catHealthStatusFromText, + catHealthStatusText, + + -- ** Optics + chtoColumnsLens, + chtoHelpLens, + chtoLocalLens, + chtoMasterTimeoutLens, + chtoTsLens, + chtoVerboseLens, + + -- ** @_cat\/health@ URI parameter types + CatHealthColumn (..), + CatHealthStatus (..), + + -- * @_cat\/health@ response row + CatHealthRow (..), + + -- ** Optics + chrActiveShardsPercentLens, + chrClusterLens, + chrEpochLens, + chrInitLens, + chrMaxTaskWaitTimeLens, + chrNodeDataLens, + chrNodeTotalLens, + chrOtherLens, + chrPendingTasksLens, + chrPriLens, + chrReloLens, + chrShardsLens, + chrStatusLens, + chrTimestampLens, + chrUnassignLens, + + -- * @_cat\/pending_tasks@ URI parameters + CatPendingTasksOptions (..), + defaultCatPendingTasksOptions, + catPendingTasksOptionsParams, + + -- ** Parameter renderers + catPendingTasksColumnText, + + -- ** Optics + cptoColumnsLens, + cptoHelpLens, + cptoLocalLens, + cptoMasterTimeoutLens, + cptoVerboseLens, + + -- ** @_cat\/pending_tasks@ URI parameter types + CatPendingTasksColumn (..), + + -- * @_cat\/pending_tasks@ response row + CatPendingTasksRow (..), + + -- ** Optics + cptrInsertOrderLens, + cptrOtherLens, + cptrPriorityLens, + cptrSourceLens, + cptrTimeInQueueLens, + + -- * @_cat\/plugins@ URI parameters + CatPluginsOptions (..), + defaultCatPluginsOptions, + catPluginsOptionsParams, + + -- ** Parameter renderers + catPluginsColumnText, + + -- ** Optics + cpoColumnsLens, + cpoHelpLens, + cpoLocalLens, + cpoMasterTimeoutLens, + cpoVerboseLens, + + -- ** @_cat\/plugins@ URI parameter types + CatPluginsColumn (..), + + -- * @_cat\/plugins@ response row + CatPluginsRow (..), + + -- ** Optics + cprComponentLens, + cprDescriptionLens, + cprIdLens, + cprNameLens, + cprOtherLens, + cprTypeLens, + cprVersionLens, + + -- * @_cat\/templates@ URI parameters + CatTemplatesOptions (..), + defaultCatTemplatesOptions, + catTemplatesOptionsParams, + + -- ** Parameter renderers + catTemplatesColumnText, + + -- ** Optics + ctmoColumnsLens, + ctmoHelpLens, + ctmoLocalLens, + ctmoMasterTimeoutLens, + ctmoVerboseLens, + + -- ** @_cat\/templates@ URI parameter types + CatTemplatesColumn (..), + + -- * @_cat\/templates@ response row + CatTemplatesRow (..), + + -- ** Optics + ctprComposedOfLens, + ctprIndexPatternsLens, + ctprNameLens, + ctprOrderLens, + ctprOtherLens, + ctprVersionLens, + + -- * @_cat\/thread_pool@ URI parameters + CatThreadPoolOptions (..), + defaultCatThreadPoolOptions, + catThreadPoolOptionsParams, + + -- ** Parameter renderers + catThreadPoolColumnText, + + -- ** Optics + ctpoColumnsLens, + ctpoHelpLens, + ctpoLocalLens, + ctpoMasterTimeoutLens, + ctpoVerboseLens, + + -- ** @_cat\/thread_pool@ URI parameter types + CatThreadPoolColumn (..), + + -- * @_cat\/thread_pool@ response row + CatThreadPoolRow (..), + + -- ** Optics + ctprlActiveLens, + ctprlCompletedLens, + ctprlCoreLens, + ctprlEphemeralNodeIdLens, + ctprlHostLens, + ctprlIpLens, + ctprlKeepAliveLens, + ctprlLargestLens, + ctprlMaxLens, + ctprlNameLens, + ctprlNodeIdLens, + ctprlNodeNameLens, + ctprlOtherLens, + ctprlPidLens, + ctprlPoolSizeLens, + ctprlPortLens, + ctprlQueueLens, + ctprlQueueSizeLens, + ctprlRejectedLens, + ctprlSizeLens, + ctprlTypeLens, + + -- * @_cat\/segments@ URI parameters + CatSegmentsOptions (..), + defaultCatSegmentsOptions, + catSegmentsOptionsParams, + + -- ** Parameter renderers + catSegmentsColumnText, + catSegmentsSortSpecText, + + -- ** Optics + csgoBytesLens, + csgoColumnsLens, + csgoHelpLens, + csgoLocalLens, + csgoMasterTimeoutLens, + csgoSortLens, + csgoVerboseLens, + + -- ** @_cat\/segments@ URI parameter types + CatSegmentsColumn (..), + CatSegmentsSortSpec (..), + + -- * @_cat\/segments@ response row + CatSegmentsRow (..), + + -- ** Optics + cserCommittedLens, + cserCompoundLens, + cserDocsCountLens, + cserDocsDeletedLens, + cserGenerationLens, + cserIdLens, + cserIndexLens, + cserIpLens, + cserOtherLens, + cserPrirepLens, + cserSearchableLens, + cserSegmentLens, + cserShardLens, + cserSizeLens, + cserSizeMemoryLens, + cserVersionLens, + + -- * @_cat\/recovery@ URI parameters + CatRecoveryOptions (..), + defaultCatRecoveryOptions, + catRecoveryOptionsParams, + + -- ** Parameter renderers + catRecoveryColumnText, + catRecoverySortSpecText, + + -- ** Optics + cryoActiveOnlyLens, + cryoBytesLens, + cryoColumnsLens, + cryoDetailedLens, + cryoHelpLens, + cryoLocalLens, + cryoMasterTimeoutLens, + cryoSortLens, + cryoVerboseLens, + + -- ** @_cat\/recovery@ URI parameter types + CatRecoveryColumn (..), + CatRecoverySortSpec (..), + + -- * @_cat\/recovery@ response row + CatRecoveryRow (..), + + -- ** Optics + cryrBytesLens, + cryrBytesPercentLens, + cryrBytesRecoveredLens, + cryrBytesTotalLens, + cryrFilesLens, + cryrFilesPercentLens, + cryrFilesRecoveredLens, + cryrFilesTotalLens, + cryrIndexLens, + cryrOtherLens, + cryrRepositoryLens, + cryrShardLens, + cryrSnapshotLens, + cryrSourceHostLens, + cryrSourceNodeLens, + cryrStageLens, + cryrStartTimeLens, + cryrStartTimeMillisLens, + cryrStopTimeLens, + cryrStopTimeMillisLens, + cryrTargetHostLens, + cryrTargetNodeLens, + cryrTimeLens, + cryrTranslogOpsLens, + cryrTranslogOpsPercentLens, + cryrTranslogOpsRecoveredLens, + cryrTypeLens, + + -- * @_cat\/component_templates@ URI parameters + CatComponentTemplatesOptions (..), + defaultCatComponentTemplatesOptions, + catComponentTemplatesOptionsParams, + + -- ** Parameter renderers + catComponentTemplatesColumnText, + + -- ** Optics + cctoColumnsLens, + cctoHelpLens, + cctoLocalLens, + cctoMasterTimeoutLens, + cctoSortLens, + cctoVerboseLens, + + -- ** @_cat\/component_templates@ URI parameter types + CatComponentTemplatesColumn (..), + + -- * @_cat\/component_templates@ response row + CatComponentTemplatesRow (..), + + -- ** Optics + cctrAliasCountLens, + cctrIncludedInLens, + cctrMappingCountLens, + cctrMetadataCountLens, + cctrNameLens, + cctrOtherLens, + cctrSettingsCountLens, + cctrVersionLens, + + -- * @_cat\/circuit_breaker@ URI parameters + CatCircuitBreakersOptions (..), + defaultCatCircuitBreakersOptions, + catCircuitBreakersOptionsParams, + + -- ** Parameter renderers + catCircuitBreakersColumnText, + + -- ** Optics + ccboColumnsLens, + ccboHelpLens, + ccboLocalLens, + ccboMasterTimeoutLens, + ccboSortLens, + ccboVerboseLens, + + -- ** @_cat\/circuit_breaker@ URI parameter types + CatCircuitBreakersColumn (..), + + -- * @_cat\/circuit_breaker@ response row + CatCircuitBreakersRow (..), + + -- ** Optics + ccbrBreakerLens, + ccbrEstimatedBytesLens, + ccbrEstimatedLens, + ccbrLimitBytesLens, + ccbrLimitLens, + ccbrNodeIdLens, + ccbrNodeNameLens, + ccbrOtherLens, + ccbrOverheadLens, + ccbrTrippedLens, + + -- * @_cat\/ml\/anomaly_detectors@ URI parameters + CatMlJobsOptions (..), + defaultCatMlJobsOptions, + catMlJobsOptionsParams, + + -- ** Parameter renderers + catMlJobsColumnText, + + -- ** Optics + cmjoAllowNoMatchLens, + cmjoColumnsLens, + cmjoHelpLens, + cmjoSortLens, + cmjoVerboseLens, + + -- ** @_cat\/ml\/anomaly_detectors@ URI parameter types + CatMlJobsColumn (..), + + -- * @_cat\/ml\/anomaly_detectors@ response row + CatMlJobsRow (..), + + -- ** Optics + cmjrAssignmentExplanationLens, + cmjrBucketsCountLens, + cmjrDataInputBytesLens, + cmjrDataProcessedRecordsLens, + cmjrFailureReasonLens, + cmjrIdLens, + cmjrModelBytesLens, + cmjrModelMemoryLimitLens, + cmjrModelMemoryStatusLens, + cmjrNodeAddressLens, + cmjrNodeEphemeralIdLens, + cmjrNodeIdLens, + cmjrNodeNameLens, + cmjrOpenedTimeLens, + cmjrOtherLens, + cmjrStateLens, + + -- * @_cat\/ml\/data_frame\/analytics@ URI parameters + CatMlDataFrameAnalyticsOptions (..), + defaultCatMlDataFrameAnalyticsOptions, + catMlDataFrameAnalyticsOptionsParams, + + -- ** Parameter renderers + catMlDataFrameAnalyticsColumnText, + + -- ** Optics + cmfaoAllowNoMatchLens, + cmfaoColumnsLens, + cmfaoHelpLens, + cmfaoSortLens, + cmfaoVerboseLens, + + -- ** @_cat\/ml\/data_frame\/analytics@ URI parameter types + CatMlDataFrameAnalyticsColumn (..), + + -- * @_cat\/ml\/data_frame\/analytics@ response row + CatMlDataFrameAnalyticsRow (..), + + -- ** Optics + cmfaAssignmentExplanationLens, + cmfaCreateTimeLens, + cmfaDescriptionLens, + cmfaDestIndexLens, + cmfaFailureReasonLens, + cmfaIdLens, + cmfaModelMemoryLimitLens, + cmfaNodeAddressLens, + cmfaNodeEphemeralIdLens, + cmfaNodeIdLens, + cmfaNodeNameLens, + cmfaOtherLens, + cmfaProgressLens, + cmfaSourceIndexLens, + cmfaStateLens, + cmfaTypeLens, + cmfaVersionLens, + + -- * @_cat\/ml\/datafeeds@ URI parameters + CatMlDatafeedsOptions (..), + defaultCatMlDatafeedsOptions, + catMlDatafeedsOptionsParams, + + -- ** Parameter renderers + catMlDatafeedsColumnText, + + -- ** Optics + cmdfoAllowNoMatchLens, + cmdfoColumnsLens, + cmdfoHelpLens, + cmdfoSortLens, + cmdfoVerboseLens, + + -- ** @_cat\/ml\/datafeeds@ URI parameter types + CatMlDatafeedsColumn (..), + + -- * @_cat\/ml\/datafeeds@ response row + CatMlDatafeedsRow (..), + + -- ** Optics + cmdfAssignmentExplanationLens, + cmdfBucketsCountLens, + cmdfIdLens, + cmdfNodeAddressLens, + cmdfNodeEphemeralIdLens, + cmdfNodeIdLens, + cmdfNodeNameLens, + cmdfOtherLens, + cmdfSearchBucketAvgLens, + cmdfSearchCountLens, + cmdfSearchExpAvgHourLens, + cmdfSearchTimeLens, + cmdfStateLens, + + -- * @_cat\/ml\/trained_models@ URI parameters + CatMlTrainedModelsOptions (..), + defaultCatMlTrainedModelsOptions, + catMlTrainedModelsOptionsParams, + + -- ** Parameter renderers + catMlTrainedModelsColumnText, + + -- ** Optics + cmtoAllowNoMatchLens, + cmtoColumnsLens, + cmtoFromLens, + cmtoHelpLens, + cmtoSizeLens, + cmtoSortLens, + cmtoVerboseLens, + + -- ** @_cat\/ml\/trained_models@ URI parameter types + CatMlTrainedModelsColumn (..), + + -- * @_cat\/ml\/trained_models@ response row + CatMlTrainedModelsRow (..), + + -- ** Optics + ctmrCreateTimeLens, + ctmrCreatedByLens, + ctmrDataFrameAnalysisLens, + ctmrDataFrameCreateTimeLens, + ctmrDataFrameIdLens, + ctmrDataFrameSourceIndexLens, + ctmrDescriptionLens, + ctmrHeapSizeLens, + ctmrIdLens, + ctmrIngestCountLens, + ctmrIngestCurrentLens, + ctmrIngestFailedLens, + ctmrIngestPipelinesLens, + ctmrIngestTimeLens, + ctmrLicenseLens, + ctmrOperationsLens, + ctmrOtherLens, + ctmrTypeLens, + ctmrVersionLens, + + -- * @_cat\/transforms@ URI parameters + CatTransformsOptions (..), + defaultCatTransformsOptions, + catTransformsOptionsParams, + + -- ** Parameter renderers + catTransformsColumnText, + + -- ** Optics + ctxoAllowNoMatchLens, + ctxoColumnsLens, + ctxoFromLens, + ctxoHelpLens, + ctxoSizeLens, + ctxoSortLens, + ctxoVerboseLens, + + -- ** @_cat\/transforms@ URI parameter types + CatTransformsColumn (..), + + -- * @_cat\/transforms@ response row + CatTransformsRow (..), + + -- ** Optics + ctxrChangesLastDetectionTimeLens, + ctxrCheckpointDurationTimeExpAvgLens, + ctxrCheckpointLens, + ctxrCheckpointProgressLens, + ctxrCreateTimeLens, + ctxrDeleteTimeLens, + ctxrDescriptionLens, + ctxrDestIndexLens, + ctxrDocsPerSecondLens, + ctxrDocumentsDeletedLens, + ctxrDocumentsIndexedLens, + ctxrDocumentsProcessedLens, + ctxrDocumentsProcessedExpAvgLens, + ctxrFrequencyLens, + ctxrIdLens, + ctxrIndexedDocumentsExpAvgLens, + ctxrIndexFailureLens, + ctxrIndexTimeLens, + ctxrIndexTotalLens, + ctxrLastSearchTimeLens, + ctxrMaxPageSearchSizeLens, + ctxrOtherLens, + ctxrPagesProcessedLens, + ctxrPipelineLens, + ctxrProcessingTimeLens, + ctxrReasonLens, + ctxrSearchFailureLens, + ctxrSearchTimeLens, + ctxrSearchTotalLens, + ctxrSourceIndexLens, + ctxrStateLens, + ctxrTransformTypeLens, + ctxrTriggerCountLens, + ctxrVersionLens, + ) +where + +import Data.Aeson +import Data.Aeson.Types (Parser, typeMismatch) +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Maybe (catMaybes) +import Data.Scientific (floatingOrInteger) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports (parseReadText, readMay, showText) +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( IndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes + ( FullNodeId, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.PendingTask + ( PendingTaskPriority, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Units + ( Bytes (..), + TimeUnits, + timeUnitsSuffix, + ) +import Optics.Lens + +-- | Byte-size unit accepted by the @bytes@ query parameter of the cat +-- APIs and appearing as the suffix of columns like @store.size@. Both +-- base-10 (@b@, @k@, @m@, @g@, @t@, @p@) and base-2 (@kb@, @mb@, @gb@, +-- @tb@, @pb@) forms are accepted. The choice only affects how the +-- server /renders/ sizes; it does not affect the underlying byte count. +-- +-- See +-- and . +data CatBytesSize + = CatBytesBytes + | CatBytesK + | CatBytesKb + | CatBytesM + | CatBytesMb + | CatBytesG + | CatBytesGb + | CatBytesT + | CatBytesTb + | CatBytesP + | CatBytesPb + deriving stock (Eq, Show) + +-- | Wire string for the @bytes@ URI parameter. Single source of truth +-- used by both 'catIndicesOptionsParams' and the response parser. +catBytesSizeText :: CatBytesSize -> Text +catBytesSizeText CatBytesBytes = "b" +catBytesSizeText CatBytesK = "k" +catBytesSizeText CatBytesKb = "kb" +catBytesSizeText CatBytesM = "m" +catBytesSizeText CatBytesMb = "mb" +catBytesSizeText CatBytesG = "g" +catBytesSizeText CatBytesGb = "gb" +catBytesSizeText CatBytesT = "t" +catBytesSizeText CatBytesTb = "tb" +catBytesSizeText CatBytesP = "p" +catBytesSizeText CatBytesPb = "pb" + +-- | Parse a 'CatBytesSize' from the unit suffix of a cat size string +-- (e.g. @"kb"@ pulled out of @"5kb"@). The empty suffix and @"b"@ both +-- map to 'CatBytesBytes' — cat emits a bare number when @bytes=b@ is +-- requested, or the @b@ suffix when the humanised form happens to land +-- on whole bytes. +catBytesSizeFromSuffix :: Text -> Maybe CatBytesSize +catBytesSizeFromSuffix "" = Just CatBytesBytes +catBytesSizeFromSuffix "b" = Just CatBytesBytes +catBytesSizeFromSuffix "k" = Just CatBytesK +catBytesSizeFromSuffix "kb" = Just CatBytesKb +catBytesSizeFromSuffix "m" = Just CatBytesM +catBytesSizeFromSuffix "mb" = Just CatBytesMb +catBytesSizeFromSuffix "g" = Just CatBytesG +catBytesSizeFromSuffix "gb" = Just CatBytesGb +catBytesSizeFromSuffix "t" = Just CatBytesT +catBytesSizeFromSuffix "tb" = Just CatBytesTb +catBytesSizeFromSuffix "p" = Just CatBytesP +catBytesSizeFromSuffix "pb" = Just CatBytesPb +catBytesSizeFromSuffix _ = Nothing + +-- | The @health@ URI parameter of @_cat\/indices@ restricts the result +-- set to indices with the matching health bucket. +data CatHealthFilter + = CatHealthFilterGreen + | CatHealthFilterYellow + | CatHealthFilterRed + deriving stock (Eq, Show) + +catHealthFilterText :: CatHealthFilter -> Text +catHealthFilterText CatHealthFilterGreen = "green" +catHealthFilterText CatHealthFilterYellow = "yellow" +catHealthFilterText CatHealthFilterRed = "red" + +-- | Per-index @health@ column of @_cat\/indices@. Distinct from +-- 'CatHealthFilter' to keep the response and request types +-- independently evolvable. +-- +-- Mirrors 'Database.Bloodhound.Internal.Versions.Common.Types.Cluster.ClusterHealthStatus': +-- an unknown value (e.g. a future bucket the server starts emitting) +-- fails the whole row's parser rather than being silently dropped. +data CatIndexHealth + = CatIndexHealthGreen + | CatIndexHealthYellow + | CatIndexHealthRed + deriving stock (Eq, Show) + +catIndexHealthText :: CatIndexHealth -> Text +catIndexHealthText CatIndexHealthGreen = "green" +catIndexHealthText CatIndexHealthYellow = "yellow" +catIndexHealthText CatIndexHealthRed = "red" + +catIndexHealthFromText :: Text -> Maybe CatIndexHealth +catIndexHealthFromText "green" = Just CatIndexHealthGreen +catIndexHealthFromText "yellow" = Just CatIndexHealthYellow +catIndexHealthFromText "red" = Just CatIndexHealthRed +catIndexHealthFromText _ = Nothing + +-- | Per-index @status@ column of @_cat\/indices@. ES only documents +-- @open@ and @closed@, but newer versions emit other states for hidden +-- flavors; those are preserved verbatim via 'CatIndexStatusOther'. +data CatIndexStatus + = CatIndexStatusOpen + | CatIndexStatusClosed + | CatIndexStatusOther Text + deriving stock (Eq, Show) + +catIndexStatusText :: CatIndexStatus -> Text +catIndexStatusText CatIndexStatusOpen = "open" +catIndexStatusText CatIndexStatusClosed = "closed" +catIndexStatusText (CatIndexStatusOther t) = t + +catIndexStatusFromText :: Text -> Maybe CatIndexStatus +catIndexStatusFromText "open" = Just CatIndexStatusOpen +catIndexStatusFromText "closed" = Just CatIndexStatusClosed +catIndexStatusFromText t = Just (CatIndexStatusOther t) + +-- | A column accepted by the @h@ (header) URI parameter of the cat +-- endpoints. Every documented @_cat\/indices@ column is enumerated; +-- anything else is captured verbatim by 'CatIndicesColumnOther'. +-- +-- See +data CatIndicesColumn + = CatColHealth + | CatColStatus + | CatColIndex + | CatColUuid + | CatColPri + | CatColRep + | CatColDocsCount + | CatColDocsDeleted + | CatColStoreSize + | CatColPriStoreSize + | CatColDataset + | CatColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatIndicesColumn'. Used by 'catIndicesOptionsParams' +-- to render the @h@ parameter and by 'CatSortSpec' to render the @s@ +-- parameter. +catIndicesColumnText :: CatIndicesColumn -> Text +catIndicesColumnText CatColHealth = "health" +catIndicesColumnText CatColStatus = "status" +catIndicesColumnText CatColIndex = "index" +catIndicesColumnText CatColUuid = "uuid" +catIndicesColumnText CatColPri = "pri" +catIndicesColumnText CatColRep = "rep" +catIndicesColumnText CatColDocsCount = "docs.count" +catIndicesColumnText CatColDocsDeleted = "docs.deleted" +catIndicesColumnText CatColStoreSize = "store.size" +catIndicesColumnText CatColPriStoreSize = "pri.store.size" +catIndicesColumnText CatColDataset = "dataset" +catIndicesColumnText (CatColOther t) = t + +-- | Direction accepted by the @s@ (sort) URI parameter of the cat +-- endpoints. +data CatSortDirection + = CatSortAsc + | CatSortDesc + deriving stock (Eq, Show) + +catSortDirectionText :: CatSortDirection -> Text +catSortDirectionText CatSortAsc = "asc" +catSortDirectionText CatSortDesc = "desc" + +-- | A single @\[:\]@ term in the @s@ URI parameter. +-- ES accepts a bare column (server-default direction) or an explicit +-- column-direction pair. +data CatSortSpec = CatSortSpec + { catSortSpecColumn :: CatIndicesColumn, + catSortSpecDirection :: Maybe CatSortDirection + } + deriving stock (Eq, Show) + +-- | Render a 'CatSortSpec' as @\@ or @\:\@. +catSortSpecText :: CatSortSpec -> Text +catSortSpecText (CatSortSpec col mDir) = + case mDir of + Nothing -> catIndicesColumnText col + Just dir -> catIndicesColumnText col <> ":" <> catSortDirectionText dir + +-- | URI parameters accepted by @GET /_cat\/indices@. Every parameter +-- documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatIndicesOptions' to +-- reproduce the legacy behaviour (no parameters besides @format=json@). +-- +-- Durations are modelled as a @(unit, magnitude)@ pair, matching the +-- @time-units@ grammar shared with +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cluster.ClusterHealthOptions'. +data CatIndicesOptions = CatIndicesOptions + { -- | Display byte sizes in the requested unit. Affects the rendering + -- of @store.size@ / @pri.store.size@. + catoBytes :: Maybe CatBytesSize, + -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + catoColumns :: Maybe (NonEmpty CatIndicesColumn), + -- | Wildcard expansion control, reused from + -- 'Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards.ExpandWildcards'. + catoExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + -- | Filter the result set to indices matching the given health bucket. + catoHealth :: Maybe CatHealthFilter, + -- | Return the help table instead of data. Informational only. + catoHelp :: Maybe Bool, + -- | Include unloaded segments in the response (slower; the + -- server-side default is @false@). + catoIncludeUnloadedSegments :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + catoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + catoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Restrict the response to primary shards only. + catoPri :: Maybe Bool, + -- | Comma-separated sort specifiers (the @s@ parameter). + catoSort :: Maybe (NonEmpty CatSortSpec), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + catoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatIndicesOptions' with every parameter set to 'Nothing'. Combined +-- with @format=json@ always being added by 'catIndicesOptionsParams', +-- the resulting request is byte-identical (modulo the cleaner +-- @/_cat\/indices?format=json@ URL) to the legacy 'catIndices' call. +defaultCatIndicesOptions :: CatIndicesOptions +defaultCatIndicesOptions = + CatIndicesOptions + { catoBytes = Nothing, + catoColumns = Nothing, + catoExpandWildcards = Nothing, + catoHealth = Nothing, + catoHelp = Nothing, + catoIncludeUnloadedSegments = Nothing, + catoLocal = Nothing, + catoMasterTimeout = Nothing, + catoPri = Nothing, + catoSort = Nothing, + catoVerbose = Nothing + } + +catoBytesLens :: Lens' CatIndicesOptions (Maybe CatBytesSize) +catoBytesLens = lens catoBytes (\x y -> x {catoBytes = y}) + +catoColumnsLens :: Lens' CatIndicesOptions (Maybe (NonEmpty CatIndicesColumn)) +catoColumnsLens = lens catoColumns (\x y -> x {catoColumns = y}) + +catoExpandWildcardsLens :: Lens' CatIndicesOptions (Maybe (NonEmpty ExpandWildcards)) +catoExpandWildcardsLens = lens catoExpandWildcards (\x y -> x {catoExpandWildcards = y}) + +catoHealthLens :: Lens' CatIndicesOptions (Maybe CatHealthFilter) +catoHealthLens = lens catoHealth (\x y -> x {catoHealth = y}) + +catoHelpLens :: Lens' CatIndicesOptions (Maybe Bool) +catoHelpLens = lens catoHelp (\x y -> x {catoHelp = y}) + +catoIncludeUnloadedSegmentsLens :: Lens' CatIndicesOptions (Maybe Bool) +catoIncludeUnloadedSegmentsLens = lens catoIncludeUnloadedSegments (\x y -> x {catoIncludeUnloadedSegments = y}) + +catoLocalLens :: Lens' CatIndicesOptions (Maybe Bool) +catoLocalLens = lens catoLocal (\x y -> x {catoLocal = y}) + +catoMasterTimeoutLens :: Lens' CatIndicesOptions (Maybe (TimeUnits, Word32)) +catoMasterTimeoutLens = lens catoMasterTimeout (\x y -> x {catoMasterTimeout = y}) + +catoPriLens :: Lens' CatIndicesOptions (Maybe Bool) +catoPriLens = lens catoPri (\x y -> x {catoPri = y}) + +catoSortLens :: Lens' CatIndicesOptions (Maybe (NonEmpty CatSortSpec)) +catoSortLens = lens catoSort (\x y -> x {catoSort = y}) + +catoVerboseLens :: Lens' CatIndicesOptions (Maybe Bool) +catoVerboseLens = lens catoVerbose (\x y -> x {catoVerbose = y}) + +-- | Render 'CatIndicesOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatIndicesOptions' emits only the always-required +-- @format=json@ entry. The order is stable but /unspecified/; callers +-- should treat the result as a set. +catIndicesOptionsParams :: CatIndicesOptions -> [(Text, Maybe Text)] +catIndicesOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("bytes",) . Just . catBytesSizeText <$> catoBytes opts, + ("h",) . Just . renderColumns <$> catoColumns opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> catoExpandWildcards opts, + ("health",) . Just . catHealthFilterText <$> catoHealth opts, + ("help",) . Just . boolQP <$> catoHelp opts, + ("include_unloaded_segments",) . Just . boolQP <$> catoIncludeUnloadedSegments opts, + ("local",) . Just . boolQP <$> catoLocal opts, + ("master_timeout",) . Just . renderDuration <$> catoMasterTimeout opts, + ("pri",) . Just . boolQP <$> catoPri opts, + ("s",) . Just . renderSort <$> catoSort opts, + ("v",) . Just . boolQP <$> catoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catIndicesColumnText . toList + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + renderSort = T.intercalate "," . map catSortSpecText . toList + +-- | Structured row of @GET /_cat\/indices?format=json@. Every default +-- column documented by ES is typed; anything the server adds in future +-- (or that surfaces under non-default options) is preserved verbatim in +-- 'cirOther'. +-- +-- All fields except 'cirIndex' are 'Maybe' because: +-- +-- * the @h@ URI parameter lets the caller request a strict subset of +-- columns; +-- * ES omits some columns (notably @health@, @dataset@) on versions or +-- index flavors that don't track them. +data CatIndicesRow = CatIndicesRow + { cirHealth :: Maybe CatIndexHealth, + cirStatus :: Maybe CatIndexStatus, + cirIndex :: IndexName, + cirUuid :: Maybe Text, + cirPrimaryShards :: Maybe Word32, + cirReplicaCount :: Maybe Word32, + cirDocsCount :: Maybe Int64, + cirDocsDeleted :: Maybe Int64, + -- | The @store.size@ column parsed into a magnitude\/unit pair. The + -- magnitude is the integer part of what the server emits (cat + -- normally returns whole numbers, but fractional values can appear + -- when @bytes@ is not set and the humanised form rounds to e.g. + -- @5.2kb@). The unit is the suffix; a bare number is reported as + -- 'CatBytesBytes'. + cirStoreSize :: Maybe (Bytes, CatBytesSize), + cirPrimaryStoreSize :: Maybe (Bytes, CatBytesSize), + -- | @dataset@ column — present for TSVS-backed data streams on + -- ES 7.13+, absent on most indices. + cirDataset :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors the @*Other@ pattern established by + -- 'Database.Bloodhound.Internal.Versions.Common.Types.ClusterStats.ClusterStatsIndices'. + cirOther :: Value + } + deriving stock (Eq, Show) + +cirHealthLens :: Lens' CatIndicesRow (Maybe CatIndexHealth) +cirHealthLens = lens cirHealth (\x y -> x {cirHealth = y}) + +cirStatusLens :: Lens' CatIndicesRow (Maybe CatIndexStatus) +cirStatusLens = lens cirStatus (\x y -> x {cirStatus = y}) + +cirIndexLens :: Lens' CatIndicesRow IndexName +cirIndexLens = lens cirIndex (\x y -> x {cirIndex = y}) + +cirUuidLens :: Lens' CatIndicesRow (Maybe Text) +cirUuidLens = lens cirUuid (\x y -> x {cirUuid = y}) + +cirPrimaryShardsLens :: Lens' CatIndicesRow (Maybe Word32) +cirPrimaryShardsLens = lens cirPrimaryShards (\x y -> x {cirPrimaryShards = y}) + +cirReplicaCountLens :: Lens' CatIndicesRow (Maybe Word32) +cirReplicaCountLens = lens cirReplicaCount (\x y -> x {cirReplicaCount = y}) + +cirDocsCountLens :: Lens' CatIndicesRow (Maybe Int64) +cirDocsCountLens = lens cirDocsCount (\x y -> x {cirDocsCount = y}) + +cirDocsDeletedLens :: Lens' CatIndicesRow (Maybe Int64) +cirDocsDeletedLens = lens cirDocsDeleted (\x y -> x {cirDocsDeleted = y}) + +cirStoreSizeLens :: Lens' CatIndicesRow (Maybe (Bytes, CatBytesSize)) +cirStoreSizeLens = lens cirStoreSize (\x y -> x {cirStoreSize = y}) + +cirPrimaryStoreSizeLens :: Lens' CatIndicesRow (Maybe (Bytes, CatBytesSize)) +cirPrimaryStoreSizeLens = lens cirPrimaryStoreSize (\x y -> x {cirPrimaryStoreSize = y}) + +cirDatasetLens :: Lens' CatIndicesRow (Maybe Text) +cirDatasetLens = lens cirDataset (\x y -> x {cirDataset = y}) + +cirOtherLens :: Lens' CatIndicesRow Value +cirOtherLens = lens cirOther (\x y -> x {cirOther = y}) + +instance FromJSON CatIndicesRow where + parseJSON = withObject "CatIndicesRow" $ \o -> + CatIndicesRow + <$> (o .:? "health" >>= traverse parseHealth) + <*> (o .:? "status" >>= traverse parseStatus) + <*> o .: "index" + <*> o .:? "uuid" + <*> (o .:? "pri" >>= traverse parseWord32) + <*> (o .:? "rep" >>= traverse parseWord32) + <*> (o .:? "docs.count" >>= traverse parseInt64) + <*> (o .:? "docs.deleted" >>= traverse parseInt64) + <*> (o .:? "store.size" >>= traverse parseSize) + <*> (o .:? "pri.store.size" >>= traverse parseSize) + <*> o .:? "dataset" + <*> pure (Object o) + where + parseHealth t = maybe (fail "invalid cat health") pure (catIndexHealthFromText t) + parseStatus t = case catIndexStatusFromText t of + Just s -> pure s + Nothing -> fail ("invalid cat status: " <> T.unpack t) + parseWord32 = parseAsString "Word32" parseReadText + parseInt64 = parseAsString "Int64" parseReadText + parseSize = parseAsString "store.size" parseCatSize + +-- | Accept either a JSON string (the cat wire format — always used by +-- ES) or, defensively, a native JSON number (some OpenSearch builds +-- emit native numerics for some columns). The numeric path round-trips +-- through the supplied text parser: integer-valued 'Scientific's are +-- printed without a trailing @.0@ (so @42@ survives a round trip +-- through 'parseReadText' into 'Word32'\/'Int64'), while genuinely +-- fractional values keep their fractional text form. +parseAsString :: Text -> (Text -> Parser a) -> Value -> Parser a +parseAsString lbl f = go + where + go (String t) = f t + go (Number n) = case floatingOrInteger n :: Either Double Integer of + Right i -> f (showText i) + Left d -> f (showText d) + go v = typeMismatch (T.unpack lbl) v + +-- | Accept either a JSON string (@\"true\"@\/@\"false\"@, the cat wire +-- format) or, defensively, a native JSON 'Bool'. Used by cat endpoints +-- whose columns include boolean flags (e.g. @_cat\/segments@). +parseCatBool :: Value -> Parser Bool +parseCatBool (String t) = case T.toLower t of + "true" -> pure True + "false" -> pure False + _ -> fail ("invalid cat bool: " <> T.unpack t) +parseCatBool (Bool b) = pure b +parseCatBool v = typeMismatch "Bool" v + +-- | Convert a cat size pair (magnitude in the rendered unit, the unit +-- itself) into an actual byte count. Cat renders sizes in the unit +-- requested by the @bytes@ URI parameter (or a server-chosen +-- humanised unit when @bytes@ is unset), so the 'Bytes' component of +-- 'cirStoreSize' is /not/ directly comparable to a 'Bytes' produced by +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Units.gigabytes' +-- et al. Use this helper to normalise. +-- +-- Both base-10 (@k@, @m@, @g@, ...) and base-2 (@kb@, @mb@, ...) units +-- are handled, matching the +-- . +catSizeInBytes :: (Bytes, CatBytesSize) -> Bytes +catSizeInBytes (Bytes n, unit) = Bytes (n * multiplier unit) + where + multiplier CatBytesBytes = 1 + multiplier CatBytesK = 1000 + multiplier CatBytesKb = 1024 + multiplier CatBytesM = 1000 * 1000 + multiplier CatBytesMb = 1024 * 1024 + multiplier CatBytesG = 1000 * 1000 * 1000 + multiplier CatBytesGb = 1024 * 1024 * 1024 + multiplier CatBytesT = 1000 * 1000 * 1000 * 1000 + multiplier CatBytesTb = 1024 * 1024 * 1024 * 1024 + multiplier CatBytesP = 1000 * 1000 * 1000 * 1000 * 1000 + multiplier CatBytesPb = 1024 * 1024 * 1024 * 1024 * 1024 + +-- | Tolerant parser for a @(magnitude, unit)@ pair as emitted by cat +-- (e.g. @"5kb"@, @"208b"@, @"208"@, @"5.2gb"@). Fractional magnitudes +-- are rounded to the nearest whole byte via the 'Bytes' newtype. +parseCatSize :: Text -> Parser (Bytes, CatBytesSize) +parseCatSize raw = + case reads (T.unpack raw) :: [(Double, String)] of + ((n, unitSuffix) : _) -> + case catBytesSizeFromSuffix (T.pack unitSuffix) of + Just unit -> pure (Bytes (round n), unit) + Nothing -> + fail ("unrecognised byte-size unit in " <> show raw) + [] -> fail ("could not parse byte-size value " <> show raw) + +-- ========================================================================= +-- @_cat\/aliases@ +-- ========================================================================= +-- +-- The @_cat\/aliases@ endpoint lists the cluster's index aliases. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell — including the +-- boolean @is_write_index@ — is rendered as a JSON string when +-- @format=json@ is set, with @"-"@ used as the cat sentinel for +-- \"not applicable\" (no write index). The parsers below tolerate +-- both the string form and a native JSON scalar, matching the +-- defensive parity established by 'CatIndicesRow'. + +-- | A column accepted by the @h@ (header) and @s@ (sort) URI parameters +-- of @_cat\/aliases@. Every documented column is enumerated; anything +-- else is captured verbatim by 'CatAliasColOther'. +data CatAliasesColumn + = CatAliasColAlias + | CatAliasColIndex + | CatAliasColFilter + | CatAliasColRoutingIndex + | CatAliasColRoutingSearch + | CatAliasColIsWriteIndex + | CatAliasColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatAliasesColumn'. Used by +-- 'catAliasesOptionsParams' (for the @h@ parameter) and by +-- 'catAliasesSortSpecText' (for the @s@ parameter). +catAliasesColumnText :: CatAliasesColumn -> Text +catAliasesColumnText CatAliasColAlias = "alias" +catAliasesColumnText CatAliasColIndex = "index" +catAliasesColumnText CatAliasColFilter = "filter" +catAliasesColumnText CatAliasColRoutingIndex = "routing.index" +catAliasesColumnText CatAliasColRoutingSearch = "routing.search" +catAliasesColumnText CatAliasColIsWriteIndex = "is_write_index" +catAliasesColumnText (CatAliasColOther t) = t + +-- | A single @\[:\]@ term in the @s@ URI parameter +-- of @_cat\/aliases@. Structurally identical to 'CatSortSpec' but tied +-- to 'CatAliasesColumn' so the indices and aliases column spaces can +-- evolve independently. +data CatAliasesSortSpec = CatAliasesSortSpec + { catAliasesSortSpecColumn :: CatAliasesColumn, + catAliasesSortSpecDirection :: Maybe CatSortDirection + } + deriving stock (Eq, Show) + +-- | Render a 'CatAliasesSortSpec' as @\@ or +-- @\:\@. +catAliasesSortSpecText :: CatAliasesSortSpec -> Text +catAliasesSortSpecText (CatAliasesSortSpec col mDir) = + case mDir of + Nothing -> catAliasesColumnText col + Just dir -> catAliasesColumnText col <> ":" <> catSortDirectionText dir + +-- | URI parameters accepted by @GET /_cat\/aliases@. A subset of +-- 'CatIndicesOptions' — @_cat\/aliases@ has no byte-sized columns, +-- no health bucket, and no primary-shard toggle, so those fields are +-- absent. Every parameter documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatAliasesOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +data CatAliasesOptions = CatAliasesOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + caaColumns :: Maybe (NonEmpty CatAliasesColumn), + -- | Wildcard expansion control, reused from + -- 'Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards.ExpandWildcards'. + caaExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + -- | Return the help table instead of data. Informational only. + caaHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + caaLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + caaMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Comma-separated sort specifiers (the @s@ parameter). + caaSort :: Maybe (NonEmpty CatAliasesSortSpec), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + caaVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatAliasesOptions' with every parameter set to 'Nothing'. Combined +-- with @format=json@ always being added by 'catAliasesOptionsParams', +-- the resulting request is byte-identical (modulo the cleaner +-- @/_cat\/aliases?format=json@ URL) to a no-parameter call. +defaultCatAliasesOptions :: CatAliasesOptions +defaultCatAliasesOptions = + CatAliasesOptions + { caaColumns = Nothing, + caaExpandWildcards = Nothing, + caaHelp = Nothing, + caaLocal = Nothing, + caaMasterTimeout = Nothing, + caaSort = Nothing, + caaVerbose = Nothing + } + +caaColumnsLens :: Lens' CatAliasesOptions (Maybe (NonEmpty CatAliasesColumn)) +caaColumnsLens = lens caaColumns (\x y -> x {caaColumns = y}) + +caaExpandWildcardsLens :: Lens' CatAliasesOptions (Maybe (NonEmpty ExpandWildcards)) +caaExpandWildcardsLens = lens caaExpandWildcards (\x y -> x {caaExpandWildcards = y}) + +caaHelpLens :: Lens' CatAliasesOptions (Maybe Bool) +caaHelpLens = lens caaHelp (\x y -> x {caaHelp = y}) + +caaLocalLens :: Lens' CatAliasesOptions (Maybe Bool) +caaLocalLens = lens caaLocal (\x y -> x {caaLocal = y}) + +caaMasterTimeoutLens :: Lens' CatAliasesOptions (Maybe (TimeUnits, Word32)) +caaMasterTimeoutLens = lens caaMasterTimeout (\x y -> x {caaMasterTimeout = y}) + +caaSortLens :: Lens' CatAliasesOptions (Maybe (NonEmpty CatAliasesSortSpec)) +caaSortLens = lens caaSort (\x y -> x {caaSort = y}) + +caaVerboseLens :: Lens' CatAliasesOptions (Maybe Bool) +caaVerboseLens = lens caaVerbose (\x y -> x {caaVerbose = y}) + +-- | Render 'CatAliasesOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatAliasesOptions' emits only the always-required +-- @format=json@ entry. The order is stable but /unspecified/; callers +-- should treat the result as a set. +catAliasesOptionsParams :: CatAliasesOptions -> [(Text, Maybe Text)] +catAliasesOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> caaColumns opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> caaExpandWildcards opts, + ("help",) . Just . boolQP <$> caaHelp opts, + ("local",) . Just . boolQP <$> caaLocal opts, + ("master_timeout",) . Just . renderDuration <$> caaMasterTimeout opts, + ("s",) . Just . renderSort <$> caaSort opts, + ("v",) . Just . boolQP <$> caaVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catAliasesColumnText . toList + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + renderSort = T.intercalate "," . map catAliasesSortSpecText . toList + +-- | Structured row of @GET /_cat\/aliases?format=json@. The @alias@ +-- and @index@ columns are always present and therefore strict; every +-- other documented column is 'Maybe' because the @h@ URI parameter +-- lets the caller request a strict subset, and because some columns +-- are omitted under cluster configurations that don't track them. +-- Anything the server adds in future (or that surfaces under +-- non-default options) is preserved verbatim in 'carOther'. +data CatAliasesRow = CatAliasesRow + { carAlias :: IndexName, + carIndex :: IndexName, + -- | The @filter@ column. Cat emits @"*-*"@ when no filter is + -- attached to the alias; that sentinel is preserved verbatim so + -- callers can distinguish it from a real query body. + carFilter :: Maybe Text, + carRoutingIndex :: Maybe Text, + carRoutingSearch :: Maybe Text, + -- | The @is_write_index@ column. Cat emits @"-"@ when the value + -- is not applicable (no write index); that sentinel is decoded + -- as 'Nothing'. @"true"@\/@"false"@ (and, defensively, native + -- JSON booleans emitted by some OpenSearch builds) decode to + -- 'Just' 'True'\/'False'. + carIsWriteIndex :: Maybe Bool, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther'. + carOther :: Value + } + deriving stock (Eq, Show) + +carAliasLens :: Lens' CatAliasesRow IndexName +carAliasLens = lens carAlias (\x y -> x {carAlias = y}) + +carIndexLens :: Lens' CatAliasesRow IndexName +carIndexLens = lens carIndex (\x y -> x {carIndex = y}) + +carFilterLens :: Lens' CatAliasesRow (Maybe Text) +carFilterLens = lens carFilter (\x y -> x {carFilter = y}) + +carRoutingIndexLens :: Lens' CatAliasesRow (Maybe Text) +carRoutingIndexLens = lens carRoutingIndex (\x y -> x {carRoutingIndex = y}) + +carRoutingSearchLens :: Lens' CatAliasesRow (Maybe Text) +carRoutingSearchLens = lens carRoutingSearch (\x y -> x {carRoutingSearch = y}) + +carIsWriteIndexLens :: Lens' CatAliasesRow (Maybe Bool) +carIsWriteIndexLens = lens carIsWriteIndex (\x y -> x {carIsWriteIndex = y}) + +carOtherLens :: Lens' CatAliasesRow Value +carOtherLens = lens carOther (\x y -> x {carOther = y}) + +-- | Parse the @is_write_index@ wire string. @"-"@ is the cat sentinel +-- for \"not applicable\" and decodes to 'Nothing'; @"true"@\/@"false"@ +-- decode to 'Just'. Unknown strings fail the parser, matching the +-- defensive-strict precedent of 'catIndexHealthFromText' (a future +-- server-emitted value should surface as a parse failure rather than +-- a silent drop). +catAliasesIsWriteIndexFromText :: Text -> Maybe (Maybe Bool) +catAliasesIsWriteIndexFromText "-" = Just Nothing +catAliasesIsWriteIndexFromText "true" = Just (Just True) +catAliasesIsWriteIndexFromText "false" = Just (Just False) +catAliasesIsWriteIndexFromText _ = Nothing + +-- | Inverse of 'catAliasesIsWriteIndexFromText', useful for golden +-- tests and round-trip assertions. +catAliasesIsWriteIndexToText :: Maybe Bool -> Text +catAliasesIsWriteIndexToText Nothing = "-" +catAliasesIsWriteIndexToText (Just True) = "true" +catAliasesIsWriteIndexToText (Just False) = "false" + +instance FromJSON CatAliasesRow where + parseJSON = withObject "CatAliasesRow" $ \o -> + CatAliasesRow + <$> o .: "alias" + <*> o .: "index" + <*> o .:? "filter" + <*> o .:? "routing.index" + <*> o .:? "routing.search" + <*> (o .:? "is_write_index" >>= maybe (pure Nothing) parseIsWriteIndex) + <*> pure (Object o) + where + -- Cat emits @is_write_index@ as a JSON string (@"-"@, @"true"@, + -- @"false"@). Some OpenSearch builds emit a native JSON boolean + -- instead; tolerate both so callers do not have to care which + -- renderer the server picked (same defensive shape as the + -- numeric-column path of 'CatIndicesRow'). + parseIsWriteIndex (Bool b) = pure (Just b) + parseIsWriteIndex v = parseAsString "is_write_index" go v + go t = case catAliasesIsWriteIndexFromText t of + Just mb -> pure mb + Nothing -> fail ("invalid cat is_write_index: " <> T.unpack t) + +-- ========================================================================= +-- @_cat\/allocation@ +-- ========================================================================= +-- +-- The @_cat\/allocation@ endpoint lists the allocation of disk space for +-- indexes and the number of shards on each data node. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell — including +-- numerics — is rendered as a JSON string when @format=json@ is set, +-- with @"-1"@ used as the cat sentinel for the @shards.undesired@ +-- column when the desired-balance allocator is not in use. The parsers +-- below tolerate both the string form and a native JSON scalar, +-- matching the defensive parity established by 'CatIndicesRow'. + +-- | A column accepted by the @h@ (header) and @s@ (sort) URI parameters +-- of @_cat\/allocation@. Every documented column is enumerated; +-- anything else is captured verbatim by 'CatAllocColOther'. +-- +-- See +data CatAllocationColumn + = CatAllocColShards + | CatAllocColShardsUndesired + | CatAllocColWriteLoadForecast + | CatAllocColDiskIndicesForecast + | CatAllocColDiskIndices + | CatAllocColDiskUsed + | CatAllocColDiskAvail + | CatAllocColDiskTotal + | CatAllocColDiskPercent + | CatAllocColHost + | CatAllocColIp + | CatAllocColNode + | CatAllocColNodeRole + | CatAllocColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatAllocationColumn'. Used by +-- 'catAllocationOptionsParams' (for the @h@ parameter) and by +-- 'catAllocationSortSpecText' (for the @s@ parameter). Only the +-- canonical column names are enumerated here; cat also accepts a long +-- list of short aliases (e.g. @s@ for @shards@, @di@ for @disk.indices@, +-- @du@ for @disk.used@, @dp@ for @disk.percent@, @n@ for @node@, @r@ +-- for @node.role@, and several others — see @GET /_cat\/allocation?help@ +-- for the full alias table) which callers can pass verbatim via +-- 'CatAllocColOther'. +catAllocationColumnText :: CatAllocationColumn -> Text +catAllocationColumnText CatAllocColShards = "shards" +catAllocationColumnText CatAllocColShardsUndesired = "shards.undesired" +catAllocationColumnText CatAllocColWriteLoadForecast = "write_load.forecast" +catAllocationColumnText CatAllocColDiskIndicesForecast = "disk.indices.forecast" +catAllocationColumnText CatAllocColDiskIndices = "disk.indices" +catAllocationColumnText CatAllocColDiskUsed = "disk.used" +catAllocationColumnText CatAllocColDiskAvail = "disk.avail" +catAllocationColumnText CatAllocColDiskTotal = "disk.total" +catAllocationColumnText CatAllocColDiskPercent = "disk.percent" +catAllocationColumnText CatAllocColHost = "host" +catAllocationColumnText CatAllocColIp = "ip" +catAllocationColumnText CatAllocColNode = "node" +catAllocationColumnText CatAllocColNodeRole = "node.role" +catAllocationColumnText (CatAllocColOther t) = t + +-- | A single @\[:\]@ term in the @s@ URI parameter +-- of @_cat\/allocation@. Structurally identical to 'CatSortSpec' but +-- tied to 'CatAllocationColumn' so the column spaces can evolve +-- independently. +data CatAllocationSortSpec = CatAllocationSortSpec + { catAllocationSortSpecColumn :: CatAllocationColumn, + catAllocationSortSpecDirection :: Maybe CatSortDirection + } + deriving stock (Eq, Show) + +-- | Render a 'CatAllocationSortSpec' as @\@ or +-- @\:\@. +catAllocationSortSpecText :: CatAllocationSortSpec -> Text +catAllocationSortSpecText (CatAllocationSortSpec col mDir) = + case mDir of + Nothing -> catAllocationColumnText col + Just dir -> catAllocationColumnText col <> ":" <> catSortDirectionText dir + +-- | URI parameters accepted by @GET /_cat\/allocation@. Every parameter +-- documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatAllocationOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions' and 'CatAliasesOptions', the renderer below emits +-- @master_timeout@ for every backend (OS still accepts it as a +-- deprecated alias). A future bead may grow a per-backend override if +-- OS ever drops the alias. +data CatAllocationOptions = CatAllocationOptions + { -- | Display byte sizes in the requested unit. Affects the rendering + -- of @disk.indices@, @disk.used@, @disk.avail@, @disk.total@ and + -- the forecast variants. + caloBytes :: Maybe CatBytesSize, + -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + caloColumns :: Maybe (NonEmpty CatAllocationColumn), + -- | Wildcard expansion control, reused from + -- 'Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards.ExpandWildcards'. + caloExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + -- | Return the help table instead of data. Informational only. + caloHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + caloLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + caloMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Comma-separated sort specifiers (the @s@ parameter). + caloSort :: Maybe (NonEmpty CatAllocationSortSpec), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + caloVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatAllocationOptions' with every parameter set to 'Nothing'. +-- Combined with @format=json@ always being added by +-- 'catAllocationOptionsParams', the resulting request is byte-identical +-- (modulo the cleaner @/_cat\/allocation?format=json@ URL) to a +-- no-parameter call. +defaultCatAllocationOptions :: CatAllocationOptions +defaultCatAllocationOptions = + CatAllocationOptions + { caloBytes = Nothing, + caloColumns = Nothing, + caloExpandWildcards = Nothing, + caloHelp = Nothing, + caloLocal = Nothing, + caloMasterTimeout = Nothing, + caloSort = Nothing, + caloVerbose = Nothing + } + +caloBytesLens :: Lens' CatAllocationOptions (Maybe CatBytesSize) +caloBytesLens = lens caloBytes (\x y -> x {caloBytes = y}) + +caloColumnsLens :: Lens' CatAllocationOptions (Maybe (NonEmpty CatAllocationColumn)) +caloColumnsLens = lens caloColumns (\x y -> x {caloColumns = y}) + +caloExpandWildcardsLens :: Lens' CatAllocationOptions (Maybe (NonEmpty ExpandWildcards)) +caloExpandWildcardsLens = lens caloExpandWildcards (\x y -> x {caloExpandWildcards = y}) + +caloHelpLens :: Lens' CatAllocationOptions (Maybe Bool) +caloHelpLens = lens caloHelp (\x y -> x {caloHelp = y}) + +caloLocalLens :: Lens' CatAllocationOptions (Maybe Bool) +caloLocalLens = lens caloLocal (\x y -> x {caloLocal = y}) + +caloMasterTimeoutLens :: Lens' CatAllocationOptions (Maybe (TimeUnits, Word32)) +caloMasterTimeoutLens = lens caloMasterTimeout (\x y -> x {caloMasterTimeout = y}) + +caloSortLens :: Lens' CatAllocationOptions (Maybe (NonEmpty CatAllocationSortSpec)) +caloSortLens = lens caloSort (\x y -> x {caloSort = y}) + +caloVerboseLens :: Lens' CatAllocationOptions (Maybe Bool) +caloVerboseLens = lens caloVerbose (\x y -> x {caloVerbose = y}) + +-- | Render 'CatAllocationOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatAllocationOptions' emits only the always-required +-- @format=json@ entry. The order is stable but /unspecified/; callers +-- should treat the result as a set. +catAllocationOptionsParams :: CatAllocationOptions -> [(Text, Maybe Text)] +catAllocationOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("bytes",) . Just . catBytesSizeText <$> caloBytes opts, + ("h",) . Just . renderColumns <$> caloColumns opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> caloExpandWildcards opts, + ("help",) . Just . boolQP <$> caloHelp opts, + ("local",) . Just . boolQP <$> caloLocal opts, + ("master_timeout",) . Just . renderDuration <$> caloMasterTimeout opts, + ("s",) . Just . renderSort <$> caloSort opts, + ("v",) . Just . boolQP <$> caloVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catAllocationColumnText . toList + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + renderSort = T.intercalate "," . map catAllocationSortSpecText . toList + +-- | The @shards.undesired@ column of @_cat\/allocation@. ES emits the +-- sentinel @"-1"@ when the desired-balance allocator is /not/ in use +-- (the column is meaningless in that case); a non-negative integer +-- otherwise. The sentinel is preserved distinctly via +-- 'CatShardsUndesiredNotApplicable' so callers can tell the two cases +-- apart without inspecting the raw text. Mirrors the +-- 'catAliasesIsWriteIndexFromText' precedent. +data CatShardsUndesired + = CatShardsUndesiredCount Word32 + | CatShardsUndesiredNotApplicable + deriving stock (Eq, Show) + +-- | Parse a 'CatShardsUndesired' from its wire string. @"-1"@ maps to +-- 'CatShardsUndesiredNotApplicable'; any other non-negative integer +-- maps to 'CatShardsUndesiredCount'. Returns 'Nothing' on negative +-- values (other than the @-1@ sentinel) or non-numeric input, matching +-- the defensive-strict convention of 'catIndexHealthFromText'. +catShardsUndesiredFromText :: Text -> Maybe CatShardsUndesired +catShardsUndesiredFromText "-1" = Just CatShardsUndesiredNotApplicable +catShardsUndesiredFromText t = + case readMay (T.unpack t) :: Maybe Integer of + Just n + | n >= 0 && n <= fromIntegral (maxBound :: Word32) -> + Just (CatShardsUndesiredCount (fromIntegral n)) + | otherwise -> Nothing + Nothing -> Nothing + +-- | Inverse of 'catShardsUndesiredFromText', useful for golden tests +-- and round-trip assertions. +catShardsUndesiredToText :: CatShardsUndesired -> Text +catShardsUndesiredToText CatShardsUndesiredNotApplicable = "-1" +catShardsUndesiredToText (CatShardsUndesiredCount n) = showText n + +-- | Structured row of @GET /_cat\/allocation?format=json@. Every +-- default column documented by ES is typed; anything the server adds +-- in future (or that surfaces under non-default options) is preserved +-- verbatim in 'calrOther'. +-- +-- All fields except 'calrNode' are 'Maybe' because: +-- +-- * the @h@ URI parameter lets the caller request a strict subset of +-- columns; +-- * OS omits the ES-only forecast\/undesired\/node-role columns; +-- * the @UNASSIGNED@ pseudo-node row that ES emits for unassigned +-- shards leaves the disk columns as @null@. +data CatAllocationRow = CatAllocationRow + { -- | @shards@ — number of primary and replica shards assigned to the + -- node. + calrShards :: Maybe Word32, + -- | @shards.undesired@ — the @-1@ sentinel is decoded distinctly. + calrShardsUndesired :: Maybe CatShardsUndesired, + -- | @write_load.forecast@ — a plain 'Double' (the wire form is a + -- stringified decimal, e.g. @"0.0"@). ES-only; absent on OS. + calrWriteLoadForecast :: Maybe Double, + -- | @disk.indices.forecast@ — byte-size pair. ES-only. + calrDiskIndicesForecast :: Maybe (Bytes, CatBytesSize), + -- | @disk.indices@ — byte-size pair. ES docs note this + -- double-counts hard-linked files (shrink\/split\/clone). + calrDiskIndices :: Maybe (Bytes, CatBytesSize), + -- | @disk.used@ — byte-size pair, total disk in use on the node. + calrDiskUsed :: Maybe (Bytes, CatBytesSize), + -- | @disk.avail@ — byte-size pair, free disk space. + calrDiskAvail :: Maybe (Bytes, CatBytesSize), + -- | @disk.total@ — byte-size pair, total disk capacity. + calrDiskTotal :: Maybe (Bytes, CatBytesSize), + -- | @disk.percent@ — integer percentage @0..100@ (@disk.used\/disk.total@). + calrDiskPercent :: Maybe Word32, + -- | @host@ — network host of the node. + calrHost :: Maybe Text, + -- | @ip@ — IP address (and historically port) of the node. + calrIp :: Maybe Text, + -- | @node@ — the node name (always present, the only strict field). + calrNode :: Text, + -- | @node.role@ — compact role string (e.g. @"himrst"@). ES-only on + -- the wire; absent on OS. + calrNodeRole :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'carOther'. + calrOther :: Value + } + deriving stock (Eq, Show) + +calrShardsLens :: Lens' CatAllocationRow (Maybe Word32) +calrShardsLens = lens calrShards (\x y -> x {calrShards = y}) + +calrShardsUndesiredLens :: Lens' CatAllocationRow (Maybe CatShardsUndesired) +calrShardsUndesiredLens = lens calrShardsUndesired (\x y -> x {calrShardsUndesired = y}) + +calrWriteLoadForecastLens :: Lens' CatAllocationRow (Maybe Double) +calrWriteLoadForecastLens = lens calrWriteLoadForecast (\x y -> x {calrWriteLoadForecast = y}) + +calrDiskIndicesForecastLens :: Lens' CatAllocationRow (Maybe (Bytes, CatBytesSize)) +calrDiskIndicesForecastLens = lens calrDiskIndicesForecast (\x y -> x {calrDiskIndicesForecast = y}) + +calrDiskIndicesLens :: Lens' CatAllocationRow (Maybe (Bytes, CatBytesSize)) +calrDiskIndicesLens = lens calrDiskIndices (\x y -> x {calrDiskIndices = y}) + +calrDiskUsedLens :: Lens' CatAllocationRow (Maybe (Bytes, CatBytesSize)) +calrDiskUsedLens = lens calrDiskUsed (\x y -> x {calrDiskUsed = y}) + +calrDiskAvailLens :: Lens' CatAllocationRow (Maybe (Bytes, CatBytesSize)) +calrDiskAvailLens = lens calrDiskAvail (\x y -> x {calrDiskAvail = y}) + +calrDiskTotalLens :: Lens' CatAllocationRow (Maybe (Bytes, CatBytesSize)) +calrDiskTotalLens = lens calrDiskTotal (\x y -> x {calrDiskTotal = y}) + +calrDiskPercentLens :: Lens' CatAllocationRow (Maybe Word32) +calrDiskPercentLens = lens calrDiskPercent (\x y -> x {calrDiskPercent = y}) + +calrHostLens :: Lens' CatAllocationRow (Maybe Text) +calrHostLens = lens calrHost (\x y -> x {calrHost = y}) + +calrIpLens :: Lens' CatAllocationRow (Maybe Text) +calrIpLens = lens calrIp (\x y -> x {calrIp = y}) + +calrNodeLens :: Lens' CatAllocationRow Text +calrNodeLens = lens calrNode (\x y -> x {calrNode = y}) + +calrNodeRoleLens :: Lens' CatAllocationRow (Maybe Text) +calrNodeRoleLens = lens calrNodeRole (\x y -> x {calrNodeRole = y}) + +calrOtherLens :: Lens' CatAllocationRow Value +calrOtherLens = lens calrOther (\x y -> x {calrOther = y}) + +instance FromJSON CatAllocationRow where + parseJSON = withObject "CatAllocationRow" $ \o -> + CatAllocationRow + <$> (o .:? "shards" >>= traverse parseWord32) + <*> (o .:? "shards.undesired" >>= traverse parseShardsUndesired) + <*> (o .:? "write_load.forecast" >>= traverse parseDouble) + <*> (o .:? "disk.indices.forecast" >>= traverse parseSize) + <*> (o .:? "disk.indices" >>= traverse parseSize) + <*> (o .:? "disk.used" >>= traverse parseSize) + <*> (o .:? "disk.avail" >>= traverse parseSize) + <*> (o .:? "disk.total" >>= traverse parseSize) + <*> (o .:? "disk.percent" >>= traverse parseWord32) + <*> o .:? "host" + <*> o .:? "ip" + <*> o .: "node" + <*> o .:? "node.role" + <*> pure (Object o) + where + parseWord32 = parseAsString "Word32" parseReadText + parseDouble = parseAsString "Double" parseReadText + parseSize = parseAsString "disk size" parseCatSize + parseShardsUndesired = parseAsString "shards.undesired" goShardsUndesired + goShardsUndesired t = + case catShardsUndesiredFromText t of + Just x -> pure x + Nothing -> fail ("invalid cat shards.undesired: " <> T.unpack t) + +-- ========================================================================= +-- @_cat\/count@ +-- ========================================================================= +-- +-- The @_cat\/count@ endpoint reports the document count for the whole +-- cluster (or for one index when @/@ is appended). See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell — including the +-- @epoch@, @timestamp@ and @count@ numerics — is rendered as a JSON +-- string when @format=json@ is set. The parsers below tolerate both the +-- string form and a native JSON scalar, matching the defensive parity +-- established by 'CatIndicesRow'. + +-- | A column accepted by the @h@ (header) URI parameter of +-- @_cat\/count@. Every documented column is enumerated; anything else +-- is captured verbatim by 'CatCountColOther'. +-- +-- See +data CatCountColumn + = CatCountColEpoch + | CatCountColTimestamp + | CatCountColCount + | CatCountColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatCountColumn'. Used by 'catCountOptionsParams' +-- (for the @h@ parameter). Only the canonical column names are +-- enumerated here; cat also accepts short aliases (e.g. @t@ for +-- @timestamp@) which callers can pass verbatim via 'CatCountColOther'. +catCountColumnText :: CatCountColumn -> Text +catCountColumnText CatCountColEpoch = "epoch" +catCountColumnText CatCountColTimestamp = "timestamp" +catCountColumnText CatCountColCount = "count" +catCountColumnText (CatCountColOther t) = t + +-- | URI parameters accepted by @GET /_cat\/count@. Every parameter +-- documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatCountOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions', the renderer below emits @master_timeout@ for +-- every backend (OS still accepts it as a deprecated alias). A future +-- bead may grow a per-backend override if OS ever drops the alias. +data CatCountOptions = CatCountOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + ccoColumns :: Maybe (NonEmpty CatCountColumn), + -- | Return the help table instead of data. Informational only. + ccoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + ccoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + ccoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + ccoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatCountOptions' with every parameter set to 'Nothing'. Combined +-- with @format=json@ always being added by 'catCountOptionsParams', the +-- resulting request is byte-identical (modulo the cleaner +-- @/_cat\/count?format=json@ URL) to a no-parameter call. +defaultCatCountOptions :: CatCountOptions +defaultCatCountOptions = + CatCountOptions + { ccoColumns = Nothing, + ccoHelp = Nothing, + ccoLocal = Nothing, + ccoMasterTimeout = Nothing, + ccoVerbose = Nothing + } + +ccoColumnsLens :: Lens' CatCountOptions (Maybe (NonEmpty CatCountColumn)) +ccoColumnsLens = lens ccoColumns (\x y -> x {ccoColumns = y}) + +ccoHelpLens :: Lens' CatCountOptions (Maybe Bool) +ccoHelpLens = lens ccoHelp (\x y -> x {ccoHelp = y}) + +ccoLocalLens :: Lens' CatCountOptions (Maybe Bool) +ccoLocalLens = lens ccoLocal (\x y -> x {ccoLocal = y}) + +ccoMasterTimeoutLens :: Lens' CatCountOptions (Maybe (TimeUnits, Word32)) +ccoMasterTimeoutLens = lens ccoMasterTimeout (\x y -> x {ccoMasterTimeout = y}) + +ccoVerboseLens :: Lens' CatCountOptions (Maybe Bool) +ccoVerboseLens = lens ccoVerbose (\x y -> x {ccoVerbose = y}) + +-- | Render 'CatCountOptions' as a list of @(key, value)@ pairs suitable +-- for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatCountOptions' emits only the always-required @format=json@ +-- entry. The order is stable but /unspecified/; callers should treat +-- the result as a set. +catCountOptionsParams :: CatCountOptions -> [(Text, Maybe Text)] +catCountOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> ccoColumns opts, + ("help",) . Just . boolQP <$> ccoHelp opts, + ("local",) . Just . boolQP <$> ccoLocal opts, + ("master_timeout",) . Just . renderDuration <$> ccoMasterTimeout opts, + ("v",) . Just . boolQP <$> ccoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catCountColumnText . toList + +-- | Structured row of @GET /_cat\/count?format=json@. Every default +-- column documented by ES is typed; anything the server adds in future +-- (or that surfaces under non-default options) is preserved verbatim in +-- 'ccrOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns. +data CatCountRow = CatCountRow + { -- | @epoch@ — seconds since the Unix epoch. + ccrEpoch :: Maybe Int64, + -- | @timestamp@ — @HH:MM:SS@ wall-clock time. + ccrTimestamp :: Maybe Text, + -- | @count@ — the document count. + ccrCount :: Maybe Int64, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'calrOther'. + ccrOther :: Value + } + deriving stock (Eq, Show) + +ccrEpochLens :: Lens' CatCountRow (Maybe Int64) +ccrEpochLens = lens ccrEpoch (\x y -> x {ccrEpoch = y}) + +ccrTimestampLens :: Lens' CatCountRow (Maybe Text) +ccrTimestampLens = lens ccrTimestamp (\x y -> x {ccrTimestamp = y}) + +ccrCountLens :: Lens' CatCountRow (Maybe Int64) +ccrCountLens = lens ccrCount (\x y -> x {ccrCount = y}) + +ccrOtherLens :: Lens' CatCountRow Value +ccrOtherLens = lens ccrOther (\x y -> x {ccrOther = y}) + +instance FromJSON CatCountRow where + parseJSON = withObject "CatCountRow" $ \o -> + CatCountRow + <$> (o .:? "epoch" >>= traverse parseInt64) + <*> o .:? "timestamp" + <*> (o .:? "count" >>= traverse parseInt64) + <*> pure (Object o) + where + parseInt64 = parseAsString "Int64" parseReadText + +-- ========================================================================= +-- @_cat\/master@ +-- ========================================================================= +-- +-- The @_cat\/master@ endpoint reports the identity of the elected +-- master node. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell is rendered as a +-- JSON string when @format=json@ is set. The parsers below tolerate +-- both the string form and a native JSON scalar, matching the defensive +-- parity established by 'CatIndicesRow'. + +-- | A column accepted by the @h@ (header) URI parameter of +-- @_cat\/master@. Every documented column is enumerated; anything else +-- is captured verbatim by 'CatMasterColOther'. +-- +-- See +data CatMasterColumn + = CatMasterColId + | CatMasterColHost + | CatMasterColIp + | CatMasterColNode + | CatMasterColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatMasterColumn'. Used by 'catMasterOptionsParams' +-- (for the @h@ parameter). +catMasterColumnText :: CatMasterColumn -> Text +catMasterColumnText CatMasterColId = "id" +catMasterColumnText CatMasterColHost = "host" +catMasterColumnText CatMasterColIp = "ip" +catMasterColumnText CatMasterColNode = "node" +catMasterColumnText (CatMasterColOther t) = t + +-- | URI parameters accepted by @GET /_cat\/master@. Every parameter +-- documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatMasterOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions', the renderer below emits @master_timeout@ for +-- every backend (OS still accepts it as a deprecated alias). A future +-- bead may grow a per-backend override if OS ever drops the alias. +data CatMasterOptions = CatMasterOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + cmoColumns :: Maybe (NonEmpty CatMasterColumn), + -- | Return the help table instead of data. Informational only. + cmoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + cmoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + cmoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + cmoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatMasterOptions' with every parameter set to 'Nothing'. +defaultCatMasterOptions :: CatMasterOptions +defaultCatMasterOptions = + CatMasterOptions + { cmoColumns = Nothing, + cmoHelp = Nothing, + cmoLocal = Nothing, + cmoMasterTimeout = Nothing, + cmoVerbose = Nothing + } + +cmoColumnsLens :: Lens' CatMasterOptions (Maybe (NonEmpty CatMasterColumn)) +cmoColumnsLens = lens cmoColumns (\x y -> x {cmoColumns = y}) + +cmoHelpLens :: Lens' CatMasterOptions (Maybe Bool) +cmoHelpLens = lens cmoHelp (\x y -> x {cmoHelp = y}) + +cmoLocalLens :: Lens' CatMasterOptions (Maybe Bool) +cmoLocalLens = lens cmoLocal (\x y -> x {cmoLocal = y}) + +cmoMasterTimeoutLens :: Lens' CatMasterOptions (Maybe (TimeUnits, Word32)) +cmoMasterTimeoutLens = lens cmoMasterTimeout (\x y -> x {cmoMasterTimeout = y}) + +cmoVerboseLens :: Lens' CatMasterOptions (Maybe Bool) +cmoVerboseLens = lens cmoVerbose (\x y -> x {cmoVerbose = y}) + +-- | Render 'CatMasterOptions' as a list of @(key, value)@ pairs suitable +-- for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatMasterOptions' emits only the always-required @format=json@ +-- entry. +catMasterOptionsParams :: CatMasterOptions -> [(Text, Maybe Text)] +catMasterOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> cmoColumns opts, + ("help",) . Just . boolQP <$> cmoHelp opts, + ("local",) . Just . boolQP <$> cmoLocal opts, + ("master_timeout",) . Just . renderDuration <$> cmoMasterTimeout opts, + ("v",) . Just . boolQP <$> cmoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catMasterColumnText . toList + +-- | Structured row of @GET /_cat\/master?format=json@. Every default +-- column documented by ES is typed; anything the server adds in future +-- (or that surfaces under non-default options) is preserved verbatim in +-- 'cmrOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns. +data CatMasterRow = CatMasterRow + { -- | @id@ — the node id of the elected master. + cmrId :: Maybe FullNodeId, + -- | @host@ — network host of the master node. + cmrHost :: Maybe Text, + -- | @ip@ — IP address of the master node. + cmrIp :: Maybe Text, + -- | @node@ — the node name of the master. + cmrNode :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'calrOther'. + cmrOther :: Value + } + deriving stock (Eq, Show) + +cmrIdLens :: Lens' CatMasterRow (Maybe FullNodeId) +cmrIdLens = lens cmrId (\x y -> x {cmrId = y}) + +cmrHostLens :: Lens' CatMasterRow (Maybe Text) +cmrHostLens = lens cmrHost (\x y -> x {cmrHost = y}) + +cmrIpLens :: Lens' CatMasterRow (Maybe Text) +cmrIpLens = lens cmrIp (\x y -> x {cmrIp = y}) + +cmrNodeLens :: Lens' CatMasterRow (Maybe Text) +cmrNodeLens = lens cmrNode (\x y -> x {cmrNode = y}) + +cmrOtherLens :: Lens' CatMasterRow Value +cmrOtherLens = lens cmrOther (\x y -> x {cmrOther = y}) + +instance FromJSON CatMasterRow where + parseJSON = withObject "CatMasterRow" $ \o -> + CatMasterRow + <$> o .:? "id" + <*> o .:? "host" + <*> o .:? "ip" + <*> o .:? "node" + <*> pure (Object o) + +-- ========================================================================= +-- @_cat\/health@ +-- ========================================================================= +-- +-- The @_cat\/health@ endpoint reports a one-row-per-snapshot summary of +-- cluster health. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell — including the +-- many numerics — is rendered as a JSON string when @format=json@ is +-- set. The parsers below tolerate both the string form and a native +-- JSON scalar, matching the defensive parity established by +-- 'CatIndicesRow'. + +-- | Per-row @status@ column of @_cat\/health@. Distinct from +-- 'CatHealthFilter' (which is a request-side filter on @_cat\/indices@) +-- and from 'CatIndexHealth' to keep the response and request types +-- independently evolvable. An unknown value fails the row's parser +-- rather than being silently dropped, mirroring 'catIndexHealthFromText'. +data CatHealthStatus + = CatHealthStatusGreen + | CatHealthStatusYellow + | CatHealthStatusRed + deriving stock (Eq, Show) + +catHealthStatusText :: CatHealthStatus -> Text +catHealthStatusText CatHealthStatusGreen = "green" +catHealthStatusText CatHealthStatusYellow = "yellow" +catHealthStatusText CatHealthStatusRed = "red" + +catHealthStatusFromText :: Text -> Maybe CatHealthStatus +catHealthStatusFromText "green" = Just CatHealthStatusGreen +catHealthStatusFromText "yellow" = Just CatHealthStatusYellow +catHealthStatusFromText "red" = Just CatHealthStatusRed +catHealthStatusFromText _ = Nothing + +-- | A column accepted by the @h@ (header) URI parameter of +-- @_cat\/health@. Every documented column is enumerated; anything else +-- is captured verbatim by 'CatHealthColOther'. +-- +-- See +data CatHealthColumn + = CatHealthColEpoch + | CatHealthColTimestamp + | CatHealthColCluster + | CatHealthColStatus + | CatHealthColNodeTotal + | CatHealthColNodeData + | CatHealthColShards + | CatHealthColPri + | CatHealthColRelo + | CatHealthColInit + | CatHealthColUnassign + | CatHealthColPendingTasks + | CatHealthColMaxTaskWaitTime + | CatHealthColActiveShardsPercent + | CatHealthColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatHealthColumn'. Used by 'catHealthOptionsParams' +-- (for the @h@ parameter). Note the canonical name of the @relo@ column +-- is @relo@ (not @reloc@). +catHealthColumnText :: CatHealthColumn -> Text +catHealthColumnText CatHealthColEpoch = "epoch" +catHealthColumnText CatHealthColTimestamp = "timestamp" +catHealthColumnText CatHealthColCluster = "cluster" +catHealthColumnText CatHealthColStatus = "status" +catHealthColumnText CatHealthColNodeTotal = "node.total" +catHealthColumnText CatHealthColNodeData = "node.data" +catHealthColumnText CatHealthColShards = "shards" +catHealthColumnText CatHealthColPri = "pri" +catHealthColumnText CatHealthColRelo = "relo" +catHealthColumnText CatHealthColInit = "init" +catHealthColumnText CatHealthColUnassign = "unassign" +catHealthColumnText CatHealthColPendingTasks = "pending_tasks" +catHealthColumnText CatHealthColMaxTaskWaitTime = "max_task_wait_time" +catHealthColumnText CatHealthColActiveShardsPercent = "active_shards_percent" +catHealthColumnText (CatHealthColOther t) = t + +-- | URI parameters accepted by @GET /_cat\/health@. Every parameter +-- documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatHealthOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions', the renderer below emits @master_timeout@ for +-- every backend (OS still accepts it as a deprecated alias). A future +-- bead may grow a per-backend override if OS ever drops the alias. +data CatHealthOptions = CatHealthOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + chtoColumns :: Maybe (NonEmpty CatHealthColumn), + -- | Return the help table instead of data. Informational only. + chtoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + chtoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + chtoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Show\/hide the @timestamp@ column (the @ts@ parameter). + chtoTs :: Maybe Bool, + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + chtoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatHealthOptions' with every parameter set to 'Nothing'. +defaultCatHealthOptions :: CatHealthOptions +defaultCatHealthOptions = + CatHealthOptions + { chtoColumns = Nothing, + chtoHelp = Nothing, + chtoLocal = Nothing, + chtoMasterTimeout = Nothing, + chtoTs = Nothing, + chtoVerbose = Nothing + } + +chtoColumnsLens :: Lens' CatHealthOptions (Maybe (NonEmpty CatHealthColumn)) +chtoColumnsLens = lens chtoColumns (\x y -> x {chtoColumns = y}) + +chtoHelpLens :: Lens' CatHealthOptions (Maybe Bool) +chtoHelpLens = lens chtoHelp (\x y -> x {chtoHelp = y}) + +chtoLocalLens :: Lens' CatHealthOptions (Maybe Bool) +chtoLocalLens = lens chtoLocal (\x y -> x {chtoLocal = y}) + +chtoMasterTimeoutLens :: Lens' CatHealthOptions (Maybe (TimeUnits, Word32)) +chtoMasterTimeoutLens = lens chtoMasterTimeout (\x y -> x {chtoMasterTimeout = y}) + +chtoTsLens :: Lens' CatHealthOptions (Maybe Bool) +chtoTsLens = lens chtoTs (\x y -> x {chtoTs = y}) + +chtoVerboseLens :: Lens' CatHealthOptions (Maybe Bool) +chtoVerboseLens = lens chtoVerbose (\x y -> x {chtoVerbose = y}) + +-- | Render 'CatHealthOptions' as a list of @(key, value)@ pairs suitable +-- for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatHealthOptions' emits only the always-required @format=json@ +-- entry. +catHealthOptionsParams :: CatHealthOptions -> [(Text, Maybe Text)] +catHealthOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> chtoColumns opts, + ("help",) . Just . boolQP <$> chtoHelp opts, + ("local",) . Just . boolQP <$> chtoLocal opts, + ("master_timeout",) . Just . renderDuration <$> chtoMasterTimeout opts, + ("ts",) . Just . boolQP <$> chtoTs opts, + ("v",) . Just . boolQP <$> chtoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catHealthColumnText . toList + +-- | Structured row of @GET /_cat\/health?format=json@. Every default +-- column documented by ES is typed; anything the server adds in future +-- (or that surfaces under non-default options) is preserved verbatim in +-- 'chrOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns. The @max_task_wait_time@ column +-- is kept as plain 'Text' because cat emits the literal @"-"@ sentinel +-- when no task is waiting. +data CatHealthRow = CatHealthRow + { -- | @epoch@ — seconds since the Unix epoch. + chrEpoch :: Maybe Int64, + -- | @timestamp@ — @HH:MM:SS@ wall-clock time. + chrTimestamp :: Maybe Text, + -- | @cluster@ — cluster name. + chrCluster :: Maybe Text, + -- | @status@ — coarse health bucket. + chrStatus :: Maybe CatHealthStatus, + -- | @node.total@ — total number of nodes. + chrNodeTotal :: Maybe Word32, + -- | @node.data@ — number of data nodes. + chrNodeData :: Maybe Word32, + -- | @shards@ — total shard count. + chrShards :: Maybe Word32, + -- | @pri@ — primary shard count. + chrPri :: Maybe Word32, + -- | @relo@ — number of relocating shards. + chrRelo :: Maybe Word32, + -- | @init@ — number of initializing shards. + chrInit :: Maybe Word32, + -- | @unassign@ — number of unassigned shards. + chrUnassign :: Maybe Word32, + -- | @pending_tasks@ — number of pending cluster tasks. + chrPendingTasks :: Maybe Word32, + -- | @max_task_wait_time@ — wait time of the longest-pending task + -- (cat emits @"-"@ when nothing is waiting). + chrMaxTaskWaitTime :: Maybe Text, + -- | @active_shards_percent@ — percentage of active shards, rendered + -- by cat as e.g. @"100.0%"@. + chrActiveShardsPercent :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'calrOther'. + chrOther :: Value + } + deriving stock (Eq, Show) + +chrEpochLens :: Lens' CatHealthRow (Maybe Int64) +chrEpochLens = lens chrEpoch (\x y -> x {chrEpoch = y}) + +chrTimestampLens :: Lens' CatHealthRow (Maybe Text) +chrTimestampLens = lens chrTimestamp (\x y -> x {chrTimestamp = y}) + +chrClusterLens :: Lens' CatHealthRow (Maybe Text) +chrClusterLens = lens chrCluster (\x y -> x {chrCluster = y}) + +chrStatusLens :: Lens' CatHealthRow (Maybe CatHealthStatus) +chrStatusLens = lens chrStatus (\x y -> x {chrStatus = y}) + +chrNodeTotalLens :: Lens' CatHealthRow (Maybe Word32) +chrNodeTotalLens = lens chrNodeTotal (\x y -> x {chrNodeTotal = y}) + +chrNodeDataLens :: Lens' CatHealthRow (Maybe Word32) +chrNodeDataLens = lens chrNodeData (\x y -> x {chrNodeData = y}) + +chrShardsLens :: Lens' CatHealthRow (Maybe Word32) +chrShardsLens = lens chrShards (\x y -> x {chrShards = y}) + +chrPriLens :: Lens' CatHealthRow (Maybe Word32) +chrPriLens = lens chrPri (\x y -> x {chrPri = y}) + +chrReloLens :: Lens' CatHealthRow (Maybe Word32) +chrReloLens = lens chrRelo (\x y -> x {chrRelo = y}) + +chrInitLens :: Lens' CatHealthRow (Maybe Word32) +chrInitLens = lens chrInit (\x y -> x {chrInit = y}) + +chrUnassignLens :: Lens' CatHealthRow (Maybe Word32) +chrUnassignLens = lens chrUnassign (\x y -> x {chrUnassign = y}) + +chrPendingTasksLens :: Lens' CatHealthRow (Maybe Word32) +chrPendingTasksLens = lens chrPendingTasks (\x y -> x {chrPendingTasks = y}) + +chrMaxTaskWaitTimeLens :: Lens' CatHealthRow (Maybe Text) +chrMaxTaskWaitTimeLens = lens chrMaxTaskWaitTime (\x y -> x {chrMaxTaskWaitTime = y}) + +chrActiveShardsPercentLens :: Lens' CatHealthRow (Maybe Text) +chrActiveShardsPercentLens = lens chrActiveShardsPercent (\x y -> x {chrActiveShardsPercent = y}) + +chrOtherLens :: Lens' CatHealthRow Value +chrOtherLens = lens chrOther (\x y -> x {chrOther = y}) + +instance FromJSON CatHealthRow where + parseJSON = withObject "CatHealthRow" $ \o -> + CatHealthRow + <$> (o .:? "epoch" >>= traverse parseInt64) + <*> o .:? "timestamp" + <*> o .:? "cluster" + <*> (o .:? "status" >>= traverse parseStatus) + <*> (o .:? "node.total" >>= traverse parseWord32) + <*> (o .:? "node.data" >>= traverse parseWord32) + <*> (o .:? "shards" >>= traverse parseWord32) + <*> (o .:? "pri" >>= traverse parseWord32) + <*> (o .:? "relo" >>= traverse parseWord32) + <*> (o .:? "init" >>= traverse parseWord32) + <*> (o .:? "unassign" >>= traverse parseWord32) + <*> (o .:? "pending_tasks" >>= traverse parseWord32) + <*> o .:? "max_task_wait_time" + <*> o .:? "active_shards_percent" + <*> pure (Object o) + where + parseWord32 = parseAsString "Word32" parseReadText + parseInt64 = parseAsString "Int64" parseReadText + parseStatus = parseAsString "CatHealthStatus" goStatus + goStatus t = + case catHealthStatusFromText t of + Just x -> pure x + Nothing -> fail ("invalid cat health status: " <> T.unpack t) + +-- ========================================================================= +-- @_cat\/pending_tasks@ +-- ========================================================================= +-- +-- The @_cat\/pending_tasks@ endpoint lists the cluster-level tasks +-- waiting to be executed. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell is rendered as a +-- JSON string when @format=json@ is set. The @priority@ column reuses +-- the 'PendingTaskPriority' sum type (whose 'FromJSON' already matches +-- the upper-case wire string). The result list is empty when the +-- cluster is idle. + +-- | A column accepted by the @h@ (header) URI parameter of +-- @_cat\/pending_tasks@. Every documented column is enumerated; +-- anything else is captured verbatim by 'CatPendingTasksColOther'. +-- +-- See +data CatPendingTasksColumn + = CatPendingTasksColInsertOrder + | CatPendingTasksColTimeInQueue + | CatPendingTasksColPriority + | CatPendingTasksColSource + | CatPendingTasksColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatPendingTasksColumn'. Used by +-- 'catPendingTasksOptionsParams' (for the @h@ parameter). +catPendingTasksColumnText :: CatPendingTasksColumn -> Text +catPendingTasksColumnText CatPendingTasksColInsertOrder = "insertOrder" +catPendingTasksColumnText CatPendingTasksColTimeInQueue = "timeInQueue" +catPendingTasksColumnText CatPendingTasksColPriority = "priority" +catPendingTasksColumnText CatPendingTasksColSource = "source" +catPendingTasksColumnText (CatPendingTasksColOther t) = t + +-- | URI parameters accepted by @GET /_cat\/pending_tasks@. Every +-- parameter documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatPendingTasksOptions' +-- to reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions', the renderer below emits @master_timeout@ for +-- every backend (OS still accepts it as a deprecated alias). A future +-- bead may grow a per-backend override if OS ever drops the alias. +data CatPendingTasksOptions = CatPendingTasksOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + cptoColumns :: Maybe (NonEmpty CatPendingTasksColumn), + -- | Return the help table instead of data. Informational only. + cptoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + cptoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + cptoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + cptoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatPendingTasksOptions' with every parameter set to 'Nothing'. +defaultCatPendingTasksOptions :: CatPendingTasksOptions +defaultCatPendingTasksOptions = + CatPendingTasksOptions + { cptoColumns = Nothing, + cptoHelp = Nothing, + cptoLocal = Nothing, + cptoMasterTimeout = Nothing, + cptoVerbose = Nothing + } + +cptoColumnsLens :: Lens' CatPendingTasksOptions (Maybe (NonEmpty CatPendingTasksColumn)) +cptoColumnsLens = lens cptoColumns (\x y -> x {cptoColumns = y}) + +cptoHelpLens :: Lens' CatPendingTasksOptions (Maybe Bool) +cptoHelpLens = lens cptoHelp (\x y -> x {cptoHelp = y}) + +cptoLocalLens :: Lens' CatPendingTasksOptions (Maybe Bool) +cptoLocalLens = lens cptoLocal (\x y -> x {cptoLocal = y}) + +cptoMasterTimeoutLens :: Lens' CatPendingTasksOptions (Maybe (TimeUnits, Word32)) +cptoMasterTimeoutLens = lens cptoMasterTimeout (\x y -> x {cptoMasterTimeout = y}) + +cptoVerboseLens :: Lens' CatPendingTasksOptions (Maybe Bool) +cptoVerboseLens = lens cptoVerbose (\x y -> x {cptoVerbose = y}) + +-- | Render 'CatPendingTasksOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatPendingTasksOptions' emits only the always-required +-- @format=json@ entry. +catPendingTasksOptionsParams :: CatPendingTasksOptions -> [(Text, Maybe Text)] +catPendingTasksOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> cptoColumns opts, + ("help",) . Just . boolQP <$> cptoHelp opts, + ("local",) . Just . boolQP <$> cptoLocal opts, + ("master_timeout",) . Just . renderDuration <$> cptoMasterTimeout opts, + ("v",) . Just . boolQP <$> cptoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catPendingTasksColumnText . toList + +-- | Structured row of @GET /_cat\/pending_tasks?format=json@. Every +-- default column documented by ES is typed; anything the server adds in +-- future (or that surfaces under non-default options) is preserved +-- verbatim in 'cptrOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns. +data CatPendingTasksRow = CatPendingTasksRow + { -- | @insertOrder@ — the insertion order of the task. + cptrInsertOrder :: Maybe Word32, + -- | @timeInQueue@ — how long the task has been queued (e.g. + -- @"500ms"@, @"1s"@). + cptrTimeInQueue :: Maybe Text, + -- | @priority@ — the task priority. Reuses 'PendingTaskPriority', + -- whose 'FromJSON' matches the upper-case wire string directly. + cptrPriority :: Maybe PendingTaskPriority, + -- | @source@ — a human-readable description of the task source. + cptrSource :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'calrOther'. + cptrOther :: Value + } + deriving stock (Eq, Show) + +cptrInsertOrderLens :: Lens' CatPendingTasksRow (Maybe Word32) +cptrInsertOrderLens = lens cptrInsertOrder (\x y -> x {cptrInsertOrder = y}) + +cptrTimeInQueueLens :: Lens' CatPendingTasksRow (Maybe Text) +cptrTimeInQueueLens = lens cptrTimeInQueue (\x y -> x {cptrTimeInQueue = y}) + +cptrPriorityLens :: Lens' CatPendingTasksRow (Maybe PendingTaskPriority) +cptrPriorityLens = lens cptrPriority (\x y -> x {cptrPriority = y}) + +cptrSourceLens :: Lens' CatPendingTasksRow (Maybe Text) +cptrSourceLens = lens cptrSource (\x y -> x {cptrSource = y}) + +cptrOtherLens :: Lens' CatPendingTasksRow Value +cptrOtherLens = lens cptrOther (\x y -> x {cptrOther = y}) + +instance FromJSON CatPendingTasksRow where + parseJSON = withObject "CatPendingTasksRow" $ \o -> + CatPendingTasksRow + <$> (o .:? "insertOrder" >>= traverse parseWord32) + <*> o .:? "timeInQueue" + <*> o .:? "priority" + <*> o .:? "source" + <*> pure (Object o) + where + parseWord32 = parseAsString "Word32" parseReadText + +-- ========================================================================= +-- @_cat\/plugins@ +-- ========================================================================= +-- +-- The @_cat\/plugins@ endpoint lists the plugins installed on each +-- node. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell is rendered as a +-- JSON string when @format=json@ is set. The result list is empty on a +-- cluster with no plugins installed. + +-- | A column accepted by the @h@ (header) URI parameter of +-- @_cat\/plugins@. Every documented column is enumerated; anything else +-- is captured verbatim by 'CatPluginsColOther'. The @type@ column is +-- ES-only on newer versions and absent on OS. +-- +-- See +data CatPluginsColumn + = CatPluginsColId + | CatPluginsColName + | CatPluginsColComponent + | CatPluginsColVersion + | CatPluginsColDescription + | CatPluginsColType + | CatPluginsColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatPluginsColumn'. Used by +-- 'catPluginsOptionsParams' (for the @h@ parameter). +catPluginsColumnText :: CatPluginsColumn -> Text +catPluginsColumnText CatPluginsColId = "id" +catPluginsColumnText CatPluginsColName = "name" +catPluginsColumnText CatPluginsColComponent = "component" +catPluginsColumnText CatPluginsColVersion = "version" +catPluginsColumnText CatPluginsColDescription = "description" +catPluginsColumnText CatPluginsColType = "type" +catPluginsColumnText (CatPluginsColOther t) = t + +-- | URI parameters accepted by @GET /_cat\/plugins@. Every parameter +-- documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatPluginsOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions', the renderer below emits @master_timeout@ for +-- every backend (OS still accepts it as a deprecated alias). A future +-- bead may grow a per-backend override if OS ever drops the alias. +data CatPluginsOptions = CatPluginsOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + cpoColumns :: Maybe (NonEmpty CatPluginsColumn), + -- | Return the help table instead of data. Informational only. + cpoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + cpoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + cpoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + cpoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatPluginsOptions' with every parameter set to 'Nothing'. +defaultCatPluginsOptions :: CatPluginsOptions +defaultCatPluginsOptions = + CatPluginsOptions + { cpoColumns = Nothing, + cpoHelp = Nothing, + cpoLocal = Nothing, + cpoMasterTimeout = Nothing, + cpoVerbose = Nothing + } + +cpoColumnsLens :: Lens' CatPluginsOptions (Maybe (NonEmpty CatPluginsColumn)) +cpoColumnsLens = lens cpoColumns (\x y -> x {cpoColumns = y}) + +cpoHelpLens :: Lens' CatPluginsOptions (Maybe Bool) +cpoHelpLens = lens cpoHelp (\x y -> x {cpoHelp = y}) + +cpoLocalLens :: Lens' CatPluginsOptions (Maybe Bool) +cpoLocalLens = lens cpoLocal (\x y -> x {cpoLocal = y}) + +cpoMasterTimeoutLens :: Lens' CatPluginsOptions (Maybe (TimeUnits, Word32)) +cpoMasterTimeoutLens = lens cpoMasterTimeout (\x y -> x {cpoMasterTimeout = y}) + +cpoVerboseLens :: Lens' CatPluginsOptions (Maybe Bool) +cpoVerboseLens = lens cpoVerbose (\x y -> x {cpoVerbose = y}) + +-- | Render 'CatPluginsOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatPluginsOptions' emits only the always-required +-- @format=json@ entry. +catPluginsOptionsParams :: CatPluginsOptions -> [(Text, Maybe Text)] +catPluginsOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> cpoColumns opts, + ("help",) . Just . boolQP <$> cpoHelp opts, + ("local",) . Just . boolQP <$> cpoLocal opts, + ("master_timeout",) . Just . renderDuration <$> cpoMasterTimeout opts, + ("v",) . Just . boolQP <$> cpoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catPluginsColumnText . toList + +-- | Structured row of @GET /_cat\/plugins?format=json@. Every default +-- column documented by ES is typed; anything the server adds in future +-- (or that surfaces under non-default options) is preserved verbatim in +-- 'cprOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns, and the @type@ column is absent +-- on some backends. +data CatPluginsRow = CatPluginsRow + { -- | @id@ — the node id running the plugin. + cprId :: Maybe FullNodeId, + -- | @name@ — the node name running the plugin. + cprName :: Maybe Text, + -- | @component@ — the plugin component name. + cprComponent :: Maybe Text, + -- | @version@ — the plugin version. + cprVersion :: Maybe Text, + -- | @description@ — the plugin description. + cprDescription :: Maybe Text, + -- | @type@ — the plugin type (ES-only on newer versions). + cprType :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'calrOther'. + cprOther :: Value + } + deriving stock (Eq, Show) + +cprIdLens :: Lens' CatPluginsRow (Maybe FullNodeId) +cprIdLens = lens cprId (\x y -> x {cprId = y}) + +cprNameLens :: Lens' CatPluginsRow (Maybe Text) +cprNameLens = lens cprName (\x y -> x {cprName = y}) + +cprComponentLens :: Lens' CatPluginsRow (Maybe Text) +cprComponentLens = lens cprComponent (\x y -> x {cprComponent = y}) + +cprVersionLens :: Lens' CatPluginsRow (Maybe Text) +cprVersionLens = lens cprVersion (\x y -> x {cprVersion = y}) + +cprDescriptionLens :: Lens' CatPluginsRow (Maybe Text) +cprDescriptionLens = lens cprDescription (\x y -> x {cprDescription = y}) + +cprTypeLens :: Lens' CatPluginsRow (Maybe Text) +cprTypeLens = lens cprType (\x y -> x {cprType = y}) + +cprOtherLens :: Lens' CatPluginsRow Value +cprOtherLens = lens cprOther (\x y -> x {cprOther = y}) + +instance FromJSON CatPluginsRow where + parseJSON = withObject "CatPluginsRow" $ \o -> + CatPluginsRow + <$> o .:? "id" + <*> o .:? "name" + <*> o .:? "component" + <*> o .:? "version" + <*> o .:? "description" + <*> o .:? "type" + <*> pure (Object o) + +-- ========================================================================= +-- @_cat\/templates@ +-- ========================================================================= +-- +-- The @_cat\/templates@ endpoint lists the cluster's index templates. +-- See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell — including the +-- @order@ and @version@ numerics — is rendered as a JSON string when +-- @format=json@ is set. The @index_patterns@ and @composed_of@ columns +-- are rendered as /stringified/ lists (e.g. @"[a, b]"@, or @""@\/"@"[]" +-- when empty) and are kept here as plain 'Text' rather than parsed +-- collections, matching the cat wire shape. The parsers below tolerate +-- both the string form and a native JSON scalar for the numeric +-- columns, matching the defensive parity established by 'CatIndicesRow'. + +-- | A column accepted by the @h@ (header) URI parameter of +-- @_cat\/templates@. Every documented column is enumerated; anything +-- else is captured verbatim by 'CatTemplatesColOther'. +-- +-- See +data CatTemplatesColumn + = CatTemplatesColName + | CatTemplatesColIndexPatterns + | CatTemplatesColOrder + | CatTemplatesColVersion + | CatTemplatesColComposedOf + | CatTemplatesColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatTemplatesColumn'. Used by +-- 'catTemplatesOptionsParams' (for the @h@ parameter). +catTemplatesColumnText :: CatTemplatesColumn -> Text +catTemplatesColumnText CatTemplatesColName = "name" +catTemplatesColumnText CatTemplatesColIndexPatterns = "index_patterns" +catTemplatesColumnText CatTemplatesColOrder = "order" +catTemplatesColumnText CatTemplatesColVersion = "version" +catTemplatesColumnText CatTemplatesColComposedOf = "composed_of" +catTemplatesColumnText (CatTemplatesColOther t) = t + +-- | URI parameters accepted by @GET /_cat\/templates@. Every parameter +-- documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatTemplatesOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions', the renderer below emits @master_timeout@ for +-- every backend (OS still accepts it as a deprecated alias). A future +-- bead may grow a per-backend override if OS ever drops the alias. +data CatTemplatesOptions = CatTemplatesOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + ctmoColumns :: Maybe (NonEmpty CatTemplatesColumn), + -- | Return the help table instead of data. Informational only. + ctmoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + ctmoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + ctmoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + ctmoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatTemplatesOptions' with every parameter set to 'Nothing'. +defaultCatTemplatesOptions :: CatTemplatesOptions +defaultCatTemplatesOptions = + CatTemplatesOptions + { ctmoColumns = Nothing, + ctmoHelp = Nothing, + ctmoLocal = Nothing, + ctmoMasterTimeout = Nothing, + ctmoVerbose = Nothing + } + +ctmoColumnsLens :: Lens' CatTemplatesOptions (Maybe (NonEmpty CatTemplatesColumn)) +ctmoColumnsLens = lens ctmoColumns (\x y -> x {ctmoColumns = y}) + +ctmoHelpLens :: Lens' CatTemplatesOptions (Maybe Bool) +ctmoHelpLens = lens ctmoHelp (\x y -> x {ctmoHelp = y}) + +ctmoLocalLens :: Lens' CatTemplatesOptions (Maybe Bool) +ctmoLocalLens = lens ctmoLocal (\x y -> x {ctmoLocal = y}) + +ctmoMasterTimeoutLens :: Lens' CatTemplatesOptions (Maybe (TimeUnits, Word32)) +ctmoMasterTimeoutLens = lens ctmoMasterTimeout (\x y -> x {ctmoMasterTimeout = y}) + +ctmoVerboseLens :: Lens' CatTemplatesOptions (Maybe Bool) +ctmoVerboseLens = lens ctmoVerbose (\x y -> x {ctmoVerbose = y}) + +-- | Render 'CatTemplatesOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatTemplatesOptions' emits only the always-required +-- @format=json@ entry. +catTemplatesOptionsParams :: CatTemplatesOptions -> [(Text, Maybe Text)] +catTemplatesOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> ctmoColumns opts, + ("help",) . Just . boolQP <$> ctmoHelp opts, + ("local",) . Just . boolQP <$> ctmoLocal opts, + ("master_timeout",) . Just . renderDuration <$> ctmoMasterTimeout opts, + ("v",) . Just . boolQP <$> ctmoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catTemplatesColumnText . toList + +-- | Structured row of @GET /_cat\/templates?format=json@. Every +-- default column documented by ES is typed; anything the server adds in +-- future (or that surfaces under non-default options) is preserved +-- verbatim in 'ctprOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns. +data CatTemplatesRow = CatTemplatesRow + { -- | @name@ — the template name. + ctprName :: Maybe Text, + -- | @index_patterns@ — stringified list of index patterns (e.g. + -- @"[logs-*]"@), kept verbatim as cat renders it. + ctprIndexPatterns :: Maybe Text, + -- | @order@ — template order. + ctprOrder :: Maybe Int64, + -- | @version@ — template version. + ctprVersion :: Maybe Int64, + -- | @composed_of@ — stringified list of component templates, kept + -- verbatim as cat renders it (empty string when none). + ctprComposedOf :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'calrOther'. + ctprOther :: Value + } + deriving stock (Eq, Show) + +ctprNameLens :: Lens' CatTemplatesRow (Maybe Text) +ctprNameLens = lens ctprName (\x y -> x {ctprName = y}) + +ctprIndexPatternsLens :: Lens' CatTemplatesRow (Maybe Text) +ctprIndexPatternsLens = lens ctprIndexPatterns (\x y -> x {ctprIndexPatterns = y}) + +ctprOrderLens :: Lens' CatTemplatesRow (Maybe Int64) +ctprOrderLens = lens ctprOrder (\x y -> x {ctprOrder = y}) + +ctprVersionLens :: Lens' CatTemplatesRow (Maybe Int64) +ctprVersionLens = lens ctprVersion (\x y -> x {ctprVersion = y}) + +ctprComposedOfLens :: Lens' CatTemplatesRow (Maybe Text) +ctprComposedOfLens = lens ctprComposedOf (\x y -> x {ctprComposedOf = y}) + +ctprOtherLens :: Lens' CatTemplatesRow Value +ctprOtherLens = lens ctprOther (\x y -> x {ctprOther = y}) + +instance FromJSON CatTemplatesRow where + parseJSON = withObject "CatTemplatesRow" $ \o -> + CatTemplatesRow + <$> o .:? "name" + <*> o .:? "index_patterns" + <*> (o .:? "order" >>= traverse parseInt64) + <*> (o .:? "version" >>= traverse parseInt64) + <*> o .:? "composed_of" + <*> pure (Object o) + where + parseInt64 = parseAsString "Int64" parseReadText + +-- ========================================================================= +-- @_cat\/thread_pool@ +-- ========================================================================= +-- +-- The @_cat\/thread_pool@ endpoint lists the thread pools of each node. +-- See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell — including all +-- the integer counters — is rendered as a JSON string when +-- @format=json@ is set, with @null@ used for the @core@, @max@ and +-- @keep_alive@ columns when the pool type is not @fixed@. The parsers +-- below tolerate both the string form and a native JSON scalar, +-- matching the defensive parity established by 'CatIndicesRow'. + +-- | A column accepted by the @h@ (header) URI parameter of +-- @_cat\/thread_pool@. Every documented column is enumerated; anything +-- else is captured verbatim by 'CatThreadPoolColOther'. +-- +-- See +data CatThreadPoolColumn + = CatThreadPoolColNodeName + | CatThreadPoolColNodeId + | CatThreadPoolColEphemeralNodeId + | CatThreadPoolColPid + | CatThreadPoolColHost + | CatThreadPoolColIp + | CatThreadPoolColPort + | CatThreadPoolColName + | CatThreadPoolColType + | CatThreadPoolColActive + | CatThreadPoolColPoolSize + | CatThreadPoolColQueue + | CatThreadPoolColQueueSize + | CatThreadPoolColRejected + | CatThreadPoolColLargest + | CatThreadPoolColCompleted + | CatThreadPoolColCore + | CatThreadPoolColMax + | CatThreadPoolColSize + | CatThreadPoolColKeepAlive + | CatThreadPoolColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatThreadPoolColumn'. Used by +-- 'catThreadPoolOptionsParams' (for the @h@ parameter). +catThreadPoolColumnText :: CatThreadPoolColumn -> Text +catThreadPoolColumnText CatThreadPoolColNodeName = "node_name" +catThreadPoolColumnText CatThreadPoolColNodeId = "node_id" +catThreadPoolColumnText CatThreadPoolColEphemeralNodeId = "ephemeral_node_id" +catThreadPoolColumnText CatThreadPoolColPid = "pid" +catThreadPoolColumnText CatThreadPoolColHost = "host" +catThreadPoolColumnText CatThreadPoolColIp = "ip" +catThreadPoolColumnText CatThreadPoolColPort = "port" +catThreadPoolColumnText CatThreadPoolColName = "name" +catThreadPoolColumnText CatThreadPoolColType = "type" +catThreadPoolColumnText CatThreadPoolColActive = "active" +catThreadPoolColumnText CatThreadPoolColPoolSize = "pool_size" +catThreadPoolColumnText CatThreadPoolColQueue = "queue" +catThreadPoolColumnText CatThreadPoolColQueueSize = "queue_size" +catThreadPoolColumnText CatThreadPoolColRejected = "rejected" +catThreadPoolColumnText CatThreadPoolColLargest = "largest" +catThreadPoolColumnText CatThreadPoolColCompleted = "completed" +catThreadPoolColumnText CatThreadPoolColCore = "core" +catThreadPoolColumnText CatThreadPoolColMax = "max" +catThreadPoolColumnText CatThreadPoolColSize = "size" +catThreadPoolColumnText CatThreadPoolColKeepAlive = "keep_alive" +catThreadPoolColumnText (CatThreadPoolColOther t) = t + +-- | URI parameters accepted by @GET /_cat\/thread_pool@. Every +-- parameter documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatThreadPoolOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions', the renderer below emits @master_timeout@ for +-- every backend (OS still accepts it as a deprecated alias). A future +-- bead may grow a per-backend override if OS ever drops the alias. +data CatThreadPoolOptions = CatThreadPoolOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + ctpoColumns :: Maybe (NonEmpty CatThreadPoolColumn), + -- | Return the help table instead of data. Informational only. + ctpoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + ctpoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + ctpoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + ctpoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatThreadPoolOptions' with every parameter set to 'Nothing'. +defaultCatThreadPoolOptions :: CatThreadPoolOptions +defaultCatThreadPoolOptions = + CatThreadPoolOptions + { ctpoColumns = Nothing, + ctpoHelp = Nothing, + ctpoLocal = Nothing, + ctpoMasterTimeout = Nothing, + ctpoVerbose = Nothing + } + +ctpoColumnsLens :: Lens' CatThreadPoolOptions (Maybe (NonEmpty CatThreadPoolColumn)) +ctpoColumnsLens = lens ctpoColumns (\x y -> x {ctpoColumns = y}) + +ctpoHelpLens :: Lens' CatThreadPoolOptions (Maybe Bool) +ctpoHelpLens = lens ctpoHelp (\x y -> x {ctpoHelp = y}) + +ctpoLocalLens :: Lens' CatThreadPoolOptions (Maybe Bool) +ctpoLocalLens = lens ctpoLocal (\x y -> x {ctpoLocal = y}) + +ctpoMasterTimeoutLens :: Lens' CatThreadPoolOptions (Maybe (TimeUnits, Word32)) +ctpoMasterTimeoutLens = lens ctpoMasterTimeout (\x y -> x {ctpoMasterTimeout = y}) + +ctpoVerboseLens :: Lens' CatThreadPoolOptions (Maybe Bool) +ctpoVerboseLens = lens ctpoVerbose (\x y -> x {ctpoVerbose = y}) + +-- | Render 'CatThreadPoolOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatThreadPoolOptions' emits only the always-required +-- @format=json@ entry. +catThreadPoolOptionsParams :: CatThreadPoolOptions -> [(Text, Maybe Text)] +catThreadPoolOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> ctpoColumns opts, + ("help",) . Just . boolQP <$> ctpoHelp opts, + ("local",) . Just . boolQP <$> ctpoLocal opts, + ("master_timeout",) . Just . renderDuration <$> ctpoMasterTimeout opts, + ("v",) . Just . boolQP <$> ctpoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catThreadPoolColumnText . toList + +-- | Structured row of @GET /_cat\/thread_pool?format=json@. Every +-- default column documented by ES is typed; anything the server adds in +-- future (or that surfaces under non-default options) is preserved +-- verbatim in 'ctprlOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns, and the @core@, @max@ and +-- @keep_alive@ columns are emitted as @null@ for non-@fixed@ pool types. +data CatThreadPoolRow = CatThreadPoolRow + { -- | @node_name@ — the node name. + ctprlNodeName :: Maybe Text, + -- | @node_id@ — the stable node id. + ctprlNodeId :: Maybe Text, + -- | @ephemeral_node_id@ — the ephemeral node id. + ctprlEphemeralNodeId :: Maybe Text, + -- | @pid@ — the OS process id. + ctprlPid :: Maybe Word32, + -- | @host@ — network host of the node. + ctprlHost :: Maybe Text, + -- | @ip@ — IP address of the node. + ctprlIp :: Maybe Text, + -- | @port@ — the transport port. + ctprlPort :: Maybe Word32, + -- | @name@ — the thread pool name (e.g. @analyze@, @search@). + ctprlName :: Maybe Text, + -- | @type@ — the thread pool type (e.g. @fixed@, @scaling@). + ctprlType :: Maybe Text, + -- | @active@ — number of active threads. + ctprlActive :: Maybe Word32, + -- | @pool_size@ — number of threads in the pool. + ctprlPoolSize :: Maybe Word32, + -- | @queue@ — number of tasks in the queue. + ctprlQueue :: Maybe Word32, + -- | @queue_size@ — maximum queue size. + ctprlQueueSize :: Maybe Word32, + -- | @rejected@ — number of rejected tasks. + ctprlRejected :: Maybe Word32, + -- | @largest@ — largest number of threads ever observed. + ctprlLargest :: Maybe Word32, + -- | @completed@ — number of completed tasks. + ctprlCompleted :: Maybe Word32, + -- | @core@ — core pool size (@null@ for non-scaling types). + ctprlCore :: Maybe Word32, + -- | @max@ — maximum pool size (@null@ for non-scaling types). + ctprlMax :: Maybe Word32, + -- | @size@ — current pool size. + ctprlSize :: Maybe Word32, + -- | @keep_alive@ — keep-alive duration string (@null@ for fixed). + ctprlKeepAlive :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'calrOther'. + ctprlOther :: Value + } + deriving stock (Eq, Show) + +ctprlNodeNameLens :: Lens' CatThreadPoolRow (Maybe Text) +ctprlNodeNameLens = lens ctprlNodeName (\x y -> x {ctprlNodeName = y}) + +ctprlNodeIdLens :: Lens' CatThreadPoolRow (Maybe Text) +ctprlNodeIdLens = lens ctprlNodeId (\x y -> x {ctprlNodeId = y}) + +ctprlEphemeralNodeIdLens :: Lens' CatThreadPoolRow (Maybe Text) +ctprlEphemeralNodeIdLens = lens ctprlEphemeralNodeId (\x y -> x {ctprlEphemeralNodeId = y}) + +ctprlPidLens :: Lens' CatThreadPoolRow (Maybe Word32) +ctprlPidLens = lens ctprlPid (\x y -> x {ctprlPid = y}) + +ctprlHostLens :: Lens' CatThreadPoolRow (Maybe Text) +ctprlHostLens = lens ctprlHost (\x y -> x {ctprlHost = y}) + +ctprlIpLens :: Lens' CatThreadPoolRow (Maybe Text) +ctprlIpLens = lens ctprlIp (\x y -> x {ctprlIp = y}) + +ctprlPortLens :: Lens' CatThreadPoolRow (Maybe Word32) +ctprlPortLens = lens ctprlPort (\x y -> x {ctprlPort = y}) + +ctprlNameLens :: Lens' CatThreadPoolRow (Maybe Text) +ctprlNameLens = lens ctprlName (\x y -> x {ctprlName = y}) + +ctprlTypeLens :: Lens' CatThreadPoolRow (Maybe Text) +ctprlTypeLens = lens ctprlType (\x y -> x {ctprlType = y}) + +ctprlActiveLens :: Lens' CatThreadPoolRow (Maybe Word32) +ctprlActiveLens = lens ctprlActive (\x y -> x {ctprlActive = y}) + +ctprlPoolSizeLens :: Lens' CatThreadPoolRow (Maybe Word32) +ctprlPoolSizeLens = lens ctprlPoolSize (\x y -> x {ctprlPoolSize = y}) + +ctprlQueueLens :: Lens' CatThreadPoolRow (Maybe Word32) +ctprlQueueLens = lens ctprlQueue (\x y -> x {ctprlQueue = y}) + +ctprlQueueSizeLens :: Lens' CatThreadPoolRow (Maybe Word32) +ctprlQueueSizeLens = lens ctprlQueueSize (\x y -> x {ctprlQueueSize = y}) + +ctprlRejectedLens :: Lens' CatThreadPoolRow (Maybe Word32) +ctprlRejectedLens = lens ctprlRejected (\x y -> x {ctprlRejected = y}) + +ctprlLargestLens :: Lens' CatThreadPoolRow (Maybe Word32) +ctprlLargestLens = lens ctprlLargest (\x y -> x {ctprlLargest = y}) + +ctprlCompletedLens :: Lens' CatThreadPoolRow (Maybe Word32) +ctprlCompletedLens = lens ctprlCompleted (\x y -> x {ctprlCompleted = y}) + +ctprlCoreLens :: Lens' CatThreadPoolRow (Maybe Word32) +ctprlCoreLens = lens ctprlCore (\x y -> x {ctprlCore = y}) + +ctprlMaxLens :: Lens' CatThreadPoolRow (Maybe Word32) +ctprlMaxLens = lens ctprlMax (\x y -> x {ctprlMax = y}) + +ctprlSizeLens :: Lens' CatThreadPoolRow (Maybe Word32) +ctprlSizeLens = lens ctprlSize (\x y -> x {ctprlSize = y}) + +ctprlKeepAliveLens :: Lens' CatThreadPoolRow (Maybe Text) +ctprlKeepAliveLens = lens ctprlKeepAlive (\x y -> x {ctprlKeepAlive = y}) + +ctprlOtherLens :: Lens' CatThreadPoolRow Value +ctprlOtherLens = lens ctprlOther (\x y -> x {ctprlOther = y}) + +instance FromJSON CatThreadPoolRow where + parseJSON = withObject "CatThreadPoolRow" $ \o -> + CatThreadPoolRow + <$> o .:? "node_name" + <*> o .:? "node_id" + <*> o .:? "ephemeral_node_id" + <*> (o .:? "pid" >>= traverse parseWord32) + <*> o .:? "host" + <*> o .:? "ip" + <*> (o .:? "port" >>= traverse parseWord32) + <*> o .:? "name" + <*> o .:? "type" + <*> (o .:? "active" >>= traverse parseWord32) + <*> (o .:? "pool_size" >>= traverse parseWord32) + <*> (o .:? "queue" >>= traverse parseWord32) + <*> (o .:? "queue_size" >>= traverse parseWord32) + <*> (o .:? "rejected" >>= traverse parseWord32) + <*> (o .:? "largest" >>= traverse parseWord32) + <*> (o .:? "completed" >>= traverse parseWord32) + <*> (o .:? "core" >>= traverse parseWord32) + <*> (o .:? "max" >>= traverse parseWord32) + <*> (o .:? "size" >>= traverse parseWord32) + <*> o .:? "keep_alive" + <*> pure (Object o) + where + parseWord32 = parseAsString "Word32" parseReadText + +-- ========================================================================= +-- @_cat\/fielddata@ +-- ========================================================================= +-- +-- The @_cat\/fielddata@ endpoint lists the amount of heap memory +-- currently used by the field data cache, per field per node. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell — including the +-- numeric @size@ — is rendered as a JSON string when @format=json@ is +-- set (e.g. @"5kb"@). The parsers below tolerate both the string form +-- and a native JSON scalar, matching the defensive parity established +-- by 'CatIndicesRow'. + +-- | A column accepted by the @h@ (header) and @s@ (sort) URI parameters +-- of @_cat\/fielddata@. Every documented column is enumerated; anything +-- else is captured verbatim by 'CatFielddataColOther'. +data CatFielddataColumn + = CatFielddataColId + | CatFielddataColHost + | CatFielddataColIp + | CatFielddataColNode + | CatFielddataColField + | CatFielddataColSize + | CatFielddataColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatFielddataColumn'. Used by +-- 'catFielddataOptionsParams' (for the @h@ parameter) and by +-- 'catFielddataSortSpecText' (for the @s@ parameter). +catFielddataColumnText :: CatFielddataColumn -> Text +catFielddataColumnText CatFielddataColId = "id" +catFielddataColumnText CatFielddataColHost = "host" +catFielddataColumnText CatFielddataColIp = "ip" +catFielddataColumnText CatFielddataColNode = "node" +catFielddataColumnText CatFielddataColField = "field" +catFielddataColumnText CatFielddataColSize = "size" +catFielddataColumnText (CatFielddataColOther t) = t + +-- | A single @\[:\]@ term in the @s@ URI parameter +-- of @_cat\/fielddata@. Structurally identical to 'CatSortSpec' but tied +-- to 'CatFielddataColumn' so the column spaces can evolve independently. +data CatFielddataSortSpec = CatFielddataSortSpec + { catFielddataSortSpecColumn :: CatFielddataColumn, + catFielddataSortSpecDirection :: Maybe CatSortDirection + } + deriving stock (Eq, Show) + +-- | Render a 'CatFielddataSortSpec' as @\@ or +-- @\:\@. +catFielddataSortSpecText :: CatFielddataSortSpec -> Text +catFielddataSortSpecText (CatFielddataSortSpec col mDir) = + case mDir of + Nothing -> catFielddataColumnText col + Just dir -> catFielddataColumnText col <> ":" <> catSortDirectionText dir + +-- | URI parameters accepted by @GET /_cat\/fielddata@. A subset of +-- 'CatAllocationOptions' — @_cat\/fielddata@ is not index-scoped, so it +-- has no wildcard-expansion parameter. Every parameter documented by +-- both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatFielddataOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +data CatFielddataOptions = CatFielddataOptions + { -- | Display the @size@ byte value in the requested unit. + cfdoBytes :: Maybe CatBytesSize, + -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + cfdoColumns :: Maybe (NonEmpty CatFielddataColumn), + -- | Return the help table instead of data. Informational only. + cfdoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + cfdoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + cfdoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Comma-separated sort specifiers (the @s@ parameter). + cfdoSort :: Maybe (NonEmpty CatFielddataSortSpec), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + cfdoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatFielddataOptions' with every parameter set to 'Nothing'. +-- Combined with @format=json@ always being added by +-- 'catFielddataOptionsParams', the resulting request is byte-identical +-- (modulo the cleaner @/_cat\/fielddata?format=json@ URL) to a +-- no-parameter call. +defaultCatFielddataOptions :: CatFielddataOptions +defaultCatFielddataOptions = + CatFielddataOptions + { cfdoBytes = Nothing, + cfdoColumns = Nothing, + cfdoHelp = Nothing, + cfdoLocal = Nothing, + cfdoMasterTimeout = Nothing, + cfdoSort = Nothing, + cfdoVerbose = Nothing + } + +cfdoBytesLens :: Lens' CatFielddataOptions (Maybe CatBytesSize) +cfdoBytesLens = lens cfdoBytes (\x y -> x {cfdoBytes = y}) + +cfdoColumnsLens :: Lens' CatFielddataOptions (Maybe (NonEmpty CatFielddataColumn)) +cfdoColumnsLens = lens cfdoColumns (\x y -> x {cfdoColumns = y}) + +cfdoHelpLens :: Lens' CatFielddataOptions (Maybe Bool) +cfdoHelpLens = lens cfdoHelp (\x y -> x {cfdoHelp = y}) + +cfdoLocalLens :: Lens' CatFielddataOptions (Maybe Bool) +cfdoLocalLens = lens cfdoLocal (\x y -> x {cfdoLocal = y}) + +cfdoMasterTimeoutLens :: Lens' CatFielddataOptions (Maybe (TimeUnits, Word32)) +cfdoMasterTimeoutLens = lens cfdoMasterTimeout (\x y -> x {cfdoMasterTimeout = y}) + +cfdoSortLens :: Lens' CatFielddataOptions (Maybe (NonEmpty CatFielddataSortSpec)) +cfdoSortLens = lens cfdoSort (\x y -> x {cfdoSort = y}) + +cfdoVerboseLens :: Lens' CatFielddataOptions (Maybe Bool) +cfdoVerboseLens = lens cfdoVerbose (\x y -> x {cfdoVerbose = y}) + +-- | Render 'CatFielddataOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatFielddataOptions' emits only the always-required +-- @format=json@ entry. The order is stable but /unspecified/; callers +-- should treat the result as a set. +catFielddataOptionsParams :: CatFielddataOptions -> [(Text, Maybe Text)] +catFielddataOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("bytes",) . Just . catBytesSizeText <$> cfdoBytes opts, + ("h",) . Just . renderColumns <$> cfdoColumns opts, + ("help",) . Just . boolQP <$> cfdoHelp opts, + ("local",) . Just . boolQP <$> cfdoLocal opts, + ("master_timeout",) . Just . renderDuration <$> cfdoMasterTimeout opts, + ("s",) . Just . renderSort <$> cfdoSort opts, + ("v",) . Just . boolQP <$> cfdoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catFielddataColumnText . toList + renderSort = T.intercalate "," . map catFielddataSortSpecText . toList + +-- | Structured row of @GET /_cat\/fielddata?format=json@. The @node@ +-- and @field@ columns are always present and therefore strict; every +-- other documented column is 'Maybe' because the @h@ URI parameter lets +-- the caller request a strict subset, and because some columns are +-- omitted under cluster configurations that don't track them. The +-- @size@ column is decoded into a @(magnitude, unit)@ pair via +-- 'parseCatSize'; use 'catSizeInBytes' to normalise it to an actual +-- byte count. Anything the server adds in future is preserved verbatim +-- in 'cfdrOther'. +data CatFielddataRow = CatFielddataRow + { -- | @id@ — the unique node id. + cfdrId :: Maybe Text, + -- | @host@ — network host of the node. + cfdrHost :: Maybe Text, + -- | @ip@ — IP address of the node. + cfdrIp :: Maybe Text, + -- | @node@ — the node name (always present). + cfdrNode :: Text, + -- | @field@ — the field name (always present). + cfdrField :: Text, + -- | @size@ — heap memory used by the field's fielddata cache, + -- rendered by the server in the unit requested by @bytes@ (or a + -- server-chosen humanised unit when @bytes@ is unset). + cfdrSize :: Maybe (Bytes, CatBytesSize), + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'carOther' / 'calrOther'. + cfdrOther :: Value + } + deriving stock (Eq, Show) + +cfdrIdLens :: Lens' CatFielddataRow (Maybe Text) +cfdrIdLens = lens cfdrId (\x y -> x {cfdrId = y}) + +cfdrHostLens :: Lens' CatFielddataRow (Maybe Text) +cfdrHostLens = lens cfdrHost (\x y -> x {cfdrHost = y}) + +cfdrIpLens :: Lens' CatFielddataRow (Maybe Text) +cfdrIpLens = lens cfdrIp (\x y -> x {cfdrIp = y}) + +cfdrNodeLens :: Lens' CatFielddataRow Text +cfdrNodeLens = lens cfdrNode (\x y -> x {cfdrNode = y}) + +cfdrFieldLens :: Lens' CatFielddataRow Text +cfdrFieldLens = lens cfdrField (\x y -> x {cfdrField = y}) + +cfdrSizeLens :: Lens' CatFielddataRow (Maybe (Bytes, CatBytesSize)) +cfdrSizeLens = lens cfdrSize (\x y -> x {cfdrSize = y}) + +cfdrOtherLens :: Lens' CatFielddataRow Value +cfdrOtherLens = lens cfdrOther (\x y -> x {cfdrOther = y}) + +instance FromJSON CatFielddataRow where + parseJSON = withObject "CatFielddataRow" $ \o -> + CatFielddataRow + <$> o .:? "id" + <*> o .:? "host" + <*> o .:? "ip" + <*> o .: "node" + <*> o .: "field" + <*> (o .:? "size" >>= traverse parseSize) + <*> pure (Object o) + where + parseSize = parseAsString "size" parseCatSize + +-- ========================================================================= +-- @_cat\/nodeattrs@ +-- ========================================================================= +-- +-- The @_cat\/nodeattrs@ endpoint lists custom node attributes (the +-- attributes that drive shard-allocation filtering, e.g. +-- @box_type@). See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell — including the +-- numeric @pid@ and @port@ — is rendered as a JSON string when +-- @format=json@ is set. The parsers below tolerate both the string form +-- and a native JSON scalar, matching the defensive parity established by +-- 'CatIndicesRow'. + +-- | A column accepted by the @h@ (header) and @s@ (sort) URI parameters +-- of @_cat\/nodeattrs@. Every documented column is enumerated; anything +-- else is captured verbatim by 'CatNodeattrsColOther'. +-- +-- See +data CatNodeattrsColumn + = CatNodeattrsColNode + | CatNodeattrsColId + | CatNodeattrsColPid + | CatNodeattrsColHost + | CatNodeattrsColIp + | CatNodeattrsColPort + | CatNodeattrsColAttr + | CatNodeattrsColValue + | CatNodeattrsColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatNodeattrsColumn'. Used by +-- 'catNodeattrsOptionsParams' (for the @h@ parameter) and by +-- 'catNodeattrsSortSpecText' (for the @s@ parameter). Only the +-- canonical column names are enumerated here; cat also accepts short +-- aliases (e.g. @n@ for @node@, @i@ for @ip@, @po@ for @port@, and the +-- dotted aliases @attr.name@ \/ @attr.value@ — see +-- @GET /_cat\/nodeattrs?help@ for the full alias table) which callers +-- can pass verbatim via 'CatNodeattrsColOther'. +catNodeattrsColumnText :: CatNodeattrsColumn -> Text +catNodeattrsColumnText CatNodeattrsColNode = "node" +catNodeattrsColumnText CatNodeattrsColId = "id" +catNodeattrsColumnText CatNodeattrsColPid = "pid" +catNodeattrsColumnText CatNodeattrsColHost = "host" +catNodeattrsColumnText CatNodeattrsColIp = "ip" +catNodeattrsColumnText CatNodeattrsColPort = "port" +catNodeattrsColumnText CatNodeattrsColAttr = "attr" +catNodeattrsColumnText CatNodeattrsColValue = "value" +catNodeattrsColumnText (CatNodeattrsColOther t) = t + +-- | A single @\[:\]@ term in the @s@ URI parameter +-- of @_cat\/nodeattrs@. Structurally identical to 'CatSortSpec' but +-- tied to 'CatNodeattrsColumn' so the column spaces can evolve +-- independently. +data CatNodeattrsSortSpec = CatNodeattrsSortSpec + { catNodeattrsSortSpecColumn :: CatNodeattrsColumn, + catNodeattrsSortSpecDirection :: Maybe CatSortDirection + } + deriving stock (Eq, Show) + +-- | Render a 'CatNodeattrsSortSpec' as @\@ or +-- @\:\@. +catNodeattrsSortSpecText :: CatNodeattrsSortSpec -> Text +catNodeattrsSortSpecText (CatNodeattrsSortSpec col mDir) = + case mDir of + Nothing -> catNodeattrsColumnText col + Just dir -> catNodeattrsColumnText col <> ":" <> catSortDirectionText dir + +-- | URI parameters accepted by @GET /_cat\/nodeattrs@. Every parameter +-- documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatNodeattrsOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions' and 'CatAliasesOptions', the renderer below emits +-- @master_timeout@ for every backend (OS still accepts it as a +-- deprecated alias). A future bead may grow a per-backend override if +-- OS ever drops the alias. +data CatNodeattrsOptions = CatNodeattrsOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set (@node, host, ip, + -- attr, value@) is decided by the server when this is 'Nothing'. + cnaoColumns :: Maybe (NonEmpty CatNodeattrsColumn), + -- | Return the help table instead of data. Informational only. + cnaoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + cnaoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + cnaoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Comma-separated sort specifiers (the @s@ parameter). + cnaoSort :: Maybe (NonEmpty CatNodeattrsSortSpec), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + cnaoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatNodeattrsOptions' with every parameter set to 'Nothing'. +-- Combined with @format=json@ always being added by +-- 'catNodeattrsOptionsParams', the resulting request is byte-identical +-- (modulo the cleaner @/_cat\/nodeattrs?format=json@ URL) to a +-- no-parameter call. +defaultCatNodeattrsOptions :: CatNodeattrsOptions +defaultCatNodeattrsOptions = + CatNodeattrsOptions + { cnaoColumns = Nothing, + cnaoHelp = Nothing, + cnaoLocal = Nothing, + cnaoMasterTimeout = Nothing, + cnaoSort = Nothing, + cnaoVerbose = Nothing + } + +cnaoColumnsLens :: Lens' CatNodeattrsOptions (Maybe (NonEmpty CatNodeattrsColumn)) +cnaoColumnsLens = lens cnaoColumns (\x y -> x {cnaoColumns = y}) + +cnaoHelpLens :: Lens' CatNodeattrsOptions (Maybe Bool) +cnaoHelpLens = lens cnaoHelp (\x y -> x {cnaoHelp = y}) + +cnaoLocalLens :: Lens' CatNodeattrsOptions (Maybe Bool) +cnaoLocalLens = lens cnaoLocal (\x y -> x {cnaoLocal = y}) + +cnaoMasterTimeoutLens :: Lens' CatNodeattrsOptions (Maybe (TimeUnits, Word32)) +cnaoMasterTimeoutLens = lens cnaoMasterTimeout (\x y -> x {cnaoMasterTimeout = y}) + +cnaoSortLens :: Lens' CatNodeattrsOptions (Maybe (NonEmpty CatNodeattrsSortSpec)) +cnaoSortLens = lens cnaoSort (\x y -> x {cnaoSort = y}) + +cnaoVerboseLens :: Lens' CatNodeattrsOptions (Maybe Bool) +cnaoVerboseLens = lens cnaoVerbose (\x y -> x {cnaoVerbose = y}) + +-- | Render 'CatNodeattrsOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatNodeattrsOptions' emits only the always-required +-- @format=json@ entry. The order is stable but /unspecified/; callers +-- should treat the result as a set. +catNodeattrsOptionsParams :: CatNodeattrsOptions -> [(Text, Maybe Text)] +catNodeattrsOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> cnaoColumns opts, + ("help",) . Just . boolQP <$> cnaoHelp opts, + ("local",) . Just . boolQP <$> cnaoLocal opts, + ("master_timeout",) . Just . renderDuration <$> cnaoMasterTimeout opts, + ("s",) . Just . renderSort <$> cnaoSort opts, + ("v",) . Just . boolQP <$> cnaoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catNodeattrsColumnText . toList + renderSort = T.intercalate "," . map catNodeattrsSortSpecText . toList + +-- | Structured row of @GET /_cat\/nodeattrs?format=json@. Every +-- documented column is typed as 'Maybe'; anything the server adds in +-- future (or that surfaces under non-default options) is preserved +-- verbatim in 'cnarOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns, and because the default column +-- set (@node, host, ip, attr, value@) omits @id@, @pid@ and @port@ — +-- those only appear when explicitly requested via @h@. +data CatNodeattrsRow = CatNodeattrsRow + { -- | @node@ — the node name. + cnarNode :: Maybe Text, + -- | @id@ — the unique node identifier. + cnarId :: Maybe Text, + -- | @pid@ — the operating-system process identifier. + cnarPid :: Maybe Word32, + -- | @host@ — network host of the node. + cnarHost :: Maybe Text, + -- | @ip@ — IP address of the node. + cnarIp :: Maybe Text, + -- | @port@ — bound transport port. + cnarPort :: Maybe Word32, + -- | @attr@ — the custom attribute name (e.g. @box_type@). + cnarAttr :: Maybe Text, + -- | @value@ — the custom attribute value. + cnarValue :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'calrOther' / 'cfdrOther'. + cnarOther :: Value + } + deriving stock (Eq, Show) + +cnarNodeLens :: Lens' CatNodeattrsRow (Maybe Text) +cnarNodeLens = lens cnarNode (\x y -> x {cnarNode = y}) + +cnarIdLens :: Lens' CatNodeattrsRow (Maybe Text) +cnarIdLens = lens cnarId (\x y -> x {cnarId = y}) + +cnarPidLens :: Lens' CatNodeattrsRow (Maybe Word32) +cnarPidLens = lens cnarPid (\x y -> x {cnarPid = y}) + +cnarHostLens :: Lens' CatNodeattrsRow (Maybe Text) +cnarHostLens = lens cnarHost (\x y -> x {cnarHost = y}) + +cnarIpLens :: Lens' CatNodeattrsRow (Maybe Text) +cnarIpLens = lens cnarIp (\x y -> x {cnarIp = y}) + +cnarPortLens :: Lens' CatNodeattrsRow (Maybe Word32) +cnarPortLens = lens cnarPort (\x y -> x {cnarPort = y}) + +cnarAttrLens :: Lens' CatNodeattrsRow (Maybe Text) +cnarAttrLens = lens cnarAttr (\x y -> x {cnarAttr = y}) + +cnarValueLens :: Lens' CatNodeattrsRow (Maybe Text) +cnarValueLens = lens cnarValue (\x y -> x {cnarValue = y}) + +cnarOtherLens :: Lens' CatNodeattrsRow Value +cnarOtherLens = lens cnarOther (\x y -> x {cnarOther = y}) + +instance FromJSON CatNodeattrsRow where + parseJSON = withObject "CatNodeattrsRow" $ \o -> + CatNodeattrsRow + <$> o .:? "node" + <*> o .:? "id" + <*> (o .:? "pid" >>= traverse parseWord32) + <*> o .:? "host" + <*> o .:? "ip" + <*> (o .:? "port" >>= traverse parseWord32) + <*> o .:? "attr" + <*> o .:? "value" + <*> pure (Object o) + where + parseWord32 = parseAsString "Word32" parseReadText + +-- ========================================================================= +-- @_cat\/repositories@ +-- ========================================================================= +-- +-- The @_cat\/repositories@ endpoint lists snapshot repositories +-- registered on the cluster. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell is rendered as a +-- JSON string when @format=json@ is set. The parsers below tolerate +-- both the string form and a native JSON scalar (no numerics appear in +-- the default column set, but the @h@ parameter can pull in future +-- numeric columns), matching the defensive parity established by +-- 'CatIndicesRow'. + +-- | A column accepted by the @h@ (header) and @s@ (sort) URI parameters +-- of @_cat\/repositories@. Every documented column is enumerated; +-- anything else is captured verbatim by 'CatRepositoriesColOther'. +-- +-- See +data CatRepositoriesColumn + = CatRepositoriesColId + | CatRepositoriesColType + | CatRepositoriesColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatRepositoriesColumn'. Used by +-- 'catRepositoriesOptionsParams' (for the @h@ parameter) and by +-- 'catRepositoriesSortSpecText' (for the @s@ parameter). Only the +-- canonical column names are enumerated here; cat also accepts short +-- aliases which callers can pass verbatim via 'CatRepositoriesColOther'. +catRepositoriesColumnText :: CatRepositoriesColumn -> Text +catRepositoriesColumnText CatRepositoriesColId = "id" +catRepositoriesColumnText CatRepositoriesColType = "type" +catRepositoriesColumnText (CatRepositoriesColOther t) = t + +-- | A single @\[:\]@ term in the @s@ URI parameter +-- of @_cat\/repositories@. Structurally identical to 'CatSortSpec' but +-- tied to 'CatRepositoriesColumn' so the column spaces can evolve +-- independently. +data CatRepositoriesSortSpec = CatRepositoriesSortSpec + { catRepositoriesSortSpecColumn :: CatRepositoriesColumn, + catRepositoriesSortSpecDirection :: Maybe CatSortDirection + } + deriving stock (Eq, Show) + +-- | Render a 'CatRepositoriesSortSpec' as @\@ or +-- @\:\@. +catRepositoriesSortSpecText :: CatRepositoriesSortSpec -> Text +catRepositoriesSortSpecText (CatRepositoriesSortSpec col mDir) = + case mDir of + Nothing -> catRepositoriesColumnText col + Just dir -> catRepositoriesColumnText col <> ":" <> catSortDirectionText dir + +-- | URI parameters accepted by @GET /_cat\/repositories@. Every +-- parameter documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatRepositoriesOptions' +-- to reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions' and 'CatAliasesOptions', the renderer below emits +-- @master_timeout@ for every backend (OS still accepts it as a +-- deprecated alias). A future bead may grow a per-backend override if +-- OS ever drops the alias. +data CatRepositoriesOptions = CatRepositoriesOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set (@id, type@) is + -- decided by the server when this is 'Nothing'. + creoColumns :: Maybe (NonEmpty CatRepositoriesColumn), + -- | Return the help table instead of data. Informational only. + creoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + creoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + creoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Comma-separated sort specifiers (the @s@ parameter). + creoSort :: Maybe (NonEmpty CatRepositoriesSortSpec), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + creoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatRepositoriesOptions' with every parameter set to 'Nothing'. +-- Combined with @format=json@ always being added by +-- 'catRepositoriesOptionsParams', the resulting request is byte-identical +-- (modulo the cleaner @/_cat\/repositories?format=json@ URL) to a +-- no-parameter call. +defaultCatRepositoriesOptions :: CatRepositoriesOptions +defaultCatRepositoriesOptions = + CatRepositoriesOptions + { creoColumns = Nothing, + creoHelp = Nothing, + creoLocal = Nothing, + creoMasterTimeout = Nothing, + creoSort = Nothing, + creoVerbose = Nothing + } + +creoColumnsLens :: Lens' CatRepositoriesOptions (Maybe (NonEmpty CatRepositoriesColumn)) +creoColumnsLens = lens creoColumns (\x y -> x {creoColumns = y}) + +creoHelpLens :: Lens' CatRepositoriesOptions (Maybe Bool) +creoHelpLens = lens creoHelp (\x y -> x {creoHelp = y}) + +creoLocalLens :: Lens' CatRepositoriesOptions (Maybe Bool) +creoLocalLens = lens creoLocal (\x y -> x {creoLocal = y}) + +creoMasterTimeoutLens :: Lens' CatRepositoriesOptions (Maybe (TimeUnits, Word32)) +creoMasterTimeoutLens = lens creoMasterTimeout (\x y -> x {creoMasterTimeout = y}) + +creoSortLens :: Lens' CatRepositoriesOptions (Maybe (NonEmpty CatRepositoriesSortSpec)) +creoSortLens = lens creoSort (\x y -> x {creoSort = y}) + +creoVerboseLens :: Lens' CatRepositoriesOptions (Maybe Bool) +creoVerboseLens = lens creoVerbose (\x y -> x {creoVerbose = y}) + +-- | Render 'CatRepositoriesOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatRepositoriesOptions' emits only the always-required +-- @format=json@ entry. The order is stable but /unspecified/; callers +-- should treat the result as a set. +catRepositoriesOptionsParams :: CatRepositoriesOptions -> [(Text, Maybe Text)] +catRepositoriesOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> creoColumns opts, + ("help",) . Just . boolQP <$> creoHelp opts, + ("local",) . Just . boolQP <$> creoLocal opts, + ("master_timeout",) . Just . renderDuration <$> creoMasterTimeout opts, + ("s",) . Just . renderSort <$> creoSort opts, + ("v",) . Just . boolQP <$> creoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catRepositoriesColumnText . toList + renderSort = T.intercalate "," . map catRepositoriesSortSpecText . toList + +-- | Structured row of @GET /_cat\/repositories?format=json@. Every +-- documented column is typed; anything the server adds in future (or +-- that surfaces under non-default options) is preserved verbatim in +-- 'crrOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns. +data CatRepositoriesRow = CatRepositoriesRow + { -- | @id@ — the unique repository identifier. + crrId :: Maybe Text, + -- | @type@ — the repository type (e.g. @fs@, @s3@, @gcs@). + crrType :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'calrOther' / 'cnarOther'. + crrOther :: Value + } + deriving stock (Eq, Show) + +crrIdLens :: Lens' CatRepositoriesRow (Maybe Text) +crrIdLens = lens crrId (\x y -> x {crrId = y}) + +crrTypeLens :: Lens' CatRepositoriesRow (Maybe Text) +crrTypeLens = lens crrType (\x y -> x {crrType = y}) + +crrOtherLens :: Lens' CatRepositoriesRow Value +crrOtherLens = lens crrOther (\x y -> x {crrOther = y}) + +instance FromJSON CatRepositoriesRow where + parseJSON = withObject "CatRepositoriesRow" $ \o -> + CatRepositoriesRow + <$> o .:? "id" + <*> o .:? "type" + <*> pure (Object o) + +-- ========================================================================= +-- @_cat\/shards@ +-- ========================================================================= +-- +-- The @_cat\/shards@ endpoint lists the state of every primary and +-- replica shard in the cluster, optionally narrowed to a single index +-- (or index pattern) via @GET /_cat\/shards\/@. See +-- +-- and +-- . +-- +-- The wire shape follows the rest of the cat family: every cell — +-- including numerics — is rendered as a JSON string when +-- @format=json@ is set, with @"-"@ used as the sentinel for \"not +-- applicable\" (e.g. the @node@ column of an unassigned shard). The +-- parsers below reuse the tolerant helpers ('parseAsString', +-- 'parseCatSize') established by 'CatIndicesRow' so that callers do +-- not have to care which renderer the server picked. + +-- | A column accepted by the @h@ (header) and @s@ (sort) URI parameters +-- of @_cat\/shards@. The default column set emitted by ES is +-- @index, shard, prirep, state, docs, store, dataset, node@ (the +-- @dataset@ column is ES 8+ only); OpenSearch emits the same minus +-- @dataset@. Additional documented columns (e.g. @ip@, @sync_id@, +-- @unassigned.reason@, @recoverysource.type@) are not enumerated here +-- but can be passed through verbatim via 'CatShardsColOther'. +data CatShardsColumn + = CatShardsColIndex + | CatShardsColShard + | CatShardsColPrirep + | CatShardsColState + | CatShardsColDocs + | CatShardsColStore + | CatShardsColDataset + | CatShardsColNode + | CatShardsColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatShardsColumn'. Used by +-- 'catShardsOptionsParams' (for the @h@ parameter) and by +-- 'catShardsSortSpecText' (for the @s@ parameter). Only the canonical +-- column names are enumerated here; cat also accepts short aliases +-- which callers can pass verbatim via 'CatShardsColOther'. +catShardsColumnText :: CatShardsColumn -> Text +catShardsColumnText CatShardsColIndex = "index" +catShardsColumnText CatShardsColShard = "shard" +catShardsColumnText CatShardsColPrirep = "prirep" +catShardsColumnText CatShardsColState = "state" +catShardsColumnText CatShardsColDocs = "docs" +catShardsColumnText CatShardsColStore = "store" +catShardsColumnText CatShardsColDataset = "dataset" +catShardsColumnText CatShardsColNode = "node" +catShardsColumnText (CatShardsColOther t) = t + +-- | A single @\[:\]@ term in the @s@ URI parameter +-- of @_cat\/shards@. Structurally identical to 'CatSortSpec' but tied +-- to 'CatShardsColumn' so the column spaces can evolve independently. +data CatShardsSortSpec = CatShardsSortSpec + { catShardsSortSpecColumn :: CatShardsColumn, + catShardsSortSpecDirection :: Maybe CatSortDirection + } + deriving stock (Eq, Show) + +-- | Render a 'CatShardsSortSpec' as @\@ or +-- @\:\@. +catShardsSortSpecText :: CatShardsSortSpec -> Text +catShardsSortSpecText (CatShardsSortSpec col mDir) = + case mDir of + Nothing -> catShardsColumnText col + Just dir -> catShardsColumnText col <> ":" <> catSortDirectionText dir + +-- | URI parameters accepted by @GET /_cat\/shards@. Every parameter +-- documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatShardsOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions' and 'CatRepositoriesOptions', the renderer below +-- emits @master_timeout@ for every backend (OS still accepts it as a +-- deprecated alias). +data CatShardsOptions = CatShardsOptions + { -- | Unit used to render byte-sized columns (the @bytes@ parameter), + -- e.g. @'CatBytesKb'@. Affects only display; the underlying byte + -- count is unaffected. See 'CatBytesSize'. + cshoBytes :: Maybe CatBytesSize, + -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + cshoColumns :: Maybe (NonEmpty CatShardsColumn), + -- | Return the help table instead of data. Informational only. + cshoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + cshoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + cshoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Comma-separated sort specifiers (the @s@ parameter). + cshoSort :: Maybe (NonEmpty CatShardsSortSpec), + -- | Unit used to render time-valued columns (the @time@ parameter), + -- e.g. @('TimeUnitSeconds', 5)@ renders as @5s@. + cshoTime :: Maybe (TimeUnits, Word32), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + cshoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatShardsOptions' with every parameter set to 'Nothing'. Combined +-- with @format=json@ always being added by 'catShardsOptionsParams', +-- the resulting request is byte-identical (modulo the cleaner +-- @/_cat\/shards?format=json@ URL) to a no-parameter call. +defaultCatShardsOptions :: CatShardsOptions +defaultCatShardsOptions = + CatShardsOptions + { cshoBytes = Nothing, + cshoColumns = Nothing, + cshoHelp = Nothing, + cshoLocal = Nothing, + cshoMasterTimeout = Nothing, + cshoSort = Nothing, + cshoTime = Nothing, + cshoVerbose = Nothing + } + +cshoBytesLens :: Lens' CatShardsOptions (Maybe CatBytesSize) +cshoBytesLens = lens cshoBytes (\x y -> x {cshoBytes = y}) + +cshoColumnsLens :: Lens' CatShardsOptions (Maybe (NonEmpty CatShardsColumn)) +cshoColumnsLens = lens cshoColumns (\x y -> x {cshoColumns = y}) + +cshoHelpLens :: Lens' CatShardsOptions (Maybe Bool) +cshoHelpLens = lens cshoHelp (\x y -> x {cshoHelp = y}) + +cshoLocalLens :: Lens' CatShardsOptions (Maybe Bool) +cshoLocalLens = lens cshoLocal (\x y -> x {cshoLocal = y}) + +cshoMasterTimeoutLens :: Lens' CatShardsOptions (Maybe (TimeUnits, Word32)) +cshoMasterTimeoutLens = lens cshoMasterTimeout (\x y -> x {cshoMasterTimeout = y}) + +cshoSortLens :: Lens' CatShardsOptions (Maybe (NonEmpty CatShardsSortSpec)) +cshoSortLens = lens cshoSort (\x y -> x {cshoSort = y}) + +cshoTimeLens :: Lens' CatShardsOptions (Maybe (TimeUnits, Word32)) +cshoTimeLens = lens cshoTime (\x y -> x {cshoTime = y}) + +cshoVerboseLens :: Lens' CatShardsOptions (Maybe Bool) +cshoVerboseLens = lens cshoVerbose (\x y -> x {cshoVerbose = y}) + +-- | Render 'CatShardsOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatShardsOptions' emits only the always-required +-- @format=json@ entry. The order is stable but /unspecified/; callers +-- should treat the result as a set. +catShardsOptionsParams :: CatShardsOptions -> [(Text, Maybe Text)] +catShardsOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("bytes",) . Just . catBytesSizeText <$> cshoBytes opts, + ("h",) . Just . renderColumns <$> cshoColumns opts, + ("help",) . Just . boolQP <$> cshoHelp opts, + ("local",) . Just . boolQP <$> cshoLocal opts, + ("master_timeout",) . Just . renderDuration <$> cshoMasterTimeout opts, + ("s",) . Just . renderSort <$> cshoSort opts, + ("time",) . Just . renderDuration <$> cshoTime opts, + ("v",) . Just . boolQP <$> cshoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catShardsColumnText . toList + renderSort = T.intercalate "," . map catShardsSortSpecText . toList + +-- | Structured row of @GET /_cat\/shards?format=json@. Every default +-- column is typed; anything the server adds in future (or that +-- surfaces under non-default options) is preserved verbatim in +-- 'csrOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns, and because unassigned shards +-- emit @"-"@ sentinels for columns like @node@ that do not apply. +data CatShardsRow = CatShardsRow + { -- | @index@ — the name of the index the shard belongs to. + csrIndex :: Maybe Text, + -- | @shard@ — the shard number (a non-negative integer). + csrShard :: Maybe Word32, + -- | @prirep@ — @p@ for primary, @r@ for replica. Kept as 'Text' + -- -- with the @p@\/@r@ convention documented by both ES and OS -- + -- so the column space can evolve without a typed wrapper. + csrPrirep :: Maybe Text, + -- | @state@ — @STARTED@, @RELOCATING@, @INITIALIZING@, or + -- @UNASSIGNED@. Kept as 'Text' for the same forward-compat + -- reason as 'csrPrirep'. + csrState :: Maybe Text, + -- | @docs@ — the number of documents in the shard. The @"-"@ + -- sentinel is preserved as 'Nothing' (e.g. for unassigned + -- shards). + csrDocs :: Maybe Int64, + -- | @store@ — the shard size on disk, parsed via 'parseCatSize'. + -- The unit pairs the @bytes@ URI parameter with the server-chosen + -- humanised suffix; use 'catSizeInBytes' to normalise. + csrStore :: Maybe (Bytes, CatBytesSize), + -- | @dataset@ — the dataset type (ES 8+ only; absent on OS and + -- on older ES versions). + csrDataset :: Maybe Text, + -- | @node@ — the node name the shard is allocated to, or + -- 'Nothing' when the shard is unassigned. + csrNode :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'calrOther' / 'crrOther'. + csrOther :: Value + } + deriving stock (Eq, Show) + +csrIndexLens :: Lens' CatShardsRow (Maybe Text) +csrIndexLens = lens csrIndex (\x y -> x {csrIndex = y}) + +csrShardLens :: Lens' CatShardsRow (Maybe Word32) +csrShardLens = lens csrShard (\x y -> x {csrShard = y}) + +csrPrirepLens :: Lens' CatShardsRow (Maybe Text) +csrPrirepLens = lens csrPrirep (\x y -> x {csrPrirep = y}) + +csrStateLens :: Lens' CatShardsRow (Maybe Text) +csrStateLens = lens csrState (\x y -> x {csrState = y}) + +csrDocsLens :: Lens' CatShardsRow (Maybe Int64) +csrDocsLens = lens csrDocs (\x y -> x {csrDocs = y}) + +csrStoreLens :: Lens' CatShardsRow (Maybe (Bytes, CatBytesSize)) +csrStoreLens = lens csrStore (\x y -> x {csrStore = y}) + +csrDatasetLens :: Lens' CatShardsRow (Maybe Text) +csrDatasetLens = lens csrDataset (\x y -> x {csrDataset = y}) + +csrNodeLens :: Lens' CatShardsRow (Maybe Text) +csrNodeLens = lens csrNode (\x y -> x {csrNode = y}) + +csrOtherLens :: Lens' CatShardsRow Value +csrOtherLens = lens csrOther (\x y -> x {csrOther = y}) + +instance FromJSON CatShardsRow where + parseJSON = withObject "CatShardsRow" $ \o -> + CatShardsRow + <$> o .:? "index" + <*> (o .:? "shard" >>= optionalParse parseWord32) + <*> o .:? "prirep" + <*> o .:? "state" + <*> (o .:? "docs" >>= optionalParse parseInt64) + <*> (o .:? "store" >>= optionalParse parseSize) + <*> o .:? "dataset" + <*> dashText "node" o + <*> pure (Object o) + where + parseWord32 = parseAsString "Word32" parseReadText + parseInt64 = parseAsString "Int64" parseReadText + parseSize = parseAsString "store" parseCatSize + -- Cat emits @"-"@ as the sentinel for \"not applicable\". For + -- @_cat\/shards@ this is documented for @docs@, @store@ (numeric + -- columns an unassigned shard has no value for), and @node@ (no + -- node is assigned). Treat the sentinel the same as a missing + -- key rather than failing the row's parser (numeric) or + -- surfacing it to the caller (text). + optionalParse :: (Value -> Parser a) -> Maybe Value -> Parser (Maybe a) + optionalParse _ Nothing = pure Nothing + optionalParse _ (Just (String "-")) = pure Nothing + optionalParse p (Just v) = Just <$> p v + dashText :: Key -> Object -> Parser (Maybe Text) + dashText name obj = do + mT <- obj .:? name + pure $ case mT of + Just "-" -> Nothing + other -> other + +-- ========================================================================= +-- @_cat\/tasks@ +-- ========================================================================= +-- +-- The @_cat\/tasks@ endpoint lists the tasks currently executing on the +-- cluster. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell is rendered as a +-- JSON string when @format=json@ is set. The result list is empty when +-- the cluster is idle. + +-- | A column accepted by the @h@ (header) URI parameter of +-- @_cat\/tasks@. Every documented column is enumerated; anything else +-- is captured verbatim by 'CatTasksColOther'. The ES default column +-- set is wider than the OS default; @id@, @node_id@, @port@, +-- @version@, @x_opaque_id@, @description@ and @running_time_ns@ are +-- ES-only on newer versions and absent on OS. +-- +-- See +data CatTasksColumn + = CatTasksColId + | CatTasksColAction + | CatTasksColTaskId + | CatTasksColParentTaskId + | CatTasksColType + | CatTasksColStartTime + | CatTasksColTimestamp + | CatTasksColRunningTime + | CatTasksColRunningTimeNs + | CatTasksColNodeId + | CatTasksColIp + | CatTasksColPort + | CatTasksColNode + | CatTasksColVersion + | CatTasksColXOpaqueId + | CatTasksColDescription + | CatTasksColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatTasksColumn'. Used by 'catTasksOptionsParams' +-- (for the @h@ parameter) and by 'catTasksSortSpecText' (for the @s@ +-- parameter). Only the canonical column names are enumerated here; cat +-- also accepts short aliases which callers can pass verbatim via +-- 'CatTasksColOther'. +catTasksColumnText :: CatTasksColumn -> Text +catTasksColumnText CatTasksColId = "id" +catTasksColumnText CatTasksColAction = "action" +catTasksColumnText CatTasksColTaskId = "task_id" +catTasksColumnText CatTasksColParentTaskId = "parent_task_id" +catTasksColumnText CatTasksColType = "type" +catTasksColumnText CatTasksColStartTime = "start_time" +catTasksColumnText CatTasksColTimestamp = "timestamp" +catTasksColumnText CatTasksColRunningTime = "running_time" +catTasksColumnText CatTasksColRunningTimeNs = "running_time_ns" +catTasksColumnText CatTasksColNodeId = "node_id" +catTasksColumnText CatTasksColIp = "ip" +catTasksColumnText CatTasksColPort = "port" +catTasksColumnText CatTasksColNode = "node" +catTasksColumnText CatTasksColVersion = "version" +catTasksColumnText CatTasksColXOpaqueId = "x_opaque_id" +catTasksColumnText CatTasksColDescription = "description" +catTasksColumnText (CatTasksColOther t) = t + +-- | A single @\[:\]@ term in the @s@ URI parameter +-- of @_cat\/tasks@. Structurally identical to 'CatSortSpec' but tied to +-- 'CatTasksColumn' so the column spaces can evolve independently. +data CatTasksSortSpec = CatTasksSortSpec + { catTasksSortSpecColumn :: CatTasksColumn, + catTasksSortSpecDirection :: Maybe CatSortDirection + } + deriving stock (Eq, Show) + +-- | Render a 'CatTasksSortSpec' as @\@ or +-- @\:\@. +catTasksSortSpecText :: CatTasksSortSpec -> Text +catTasksSortSpecText (CatTasksSortSpec col mDir) = + case mDir of + Nothing -> catTasksColumnText col + Just dir -> catTasksColumnText col <> ":" <> catSortDirectionText dir + +-- | URI parameters accepted by @GET /_cat\/tasks@. Every parameter +-- documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatTasksOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions' and 'CatAliasesOptions', the renderer below emits +-- @master_timeout@ for every backend (OS still accepts it as a +-- deprecated alias). A future bead may grow a per-backend override if +-- OS ever drops the alias. +data CatTasksOptions = CatTasksOptions + { -- | Comma-separated list of task actions (the @actions@ parameter) + -- used to filter the result, e.g. @cluster:monitor\/tasks\/lists*@. + cttoActions :: Maybe (NonEmpty Text), + -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + cttoColumns :: Maybe (NonEmpty CatTasksColumn), + -- | Whether to return detailed task descriptions (the @detailed@ + -- parameter). When @true@ the @description@ column is populated + -- for user-defined tasks. + cttoDetailed :: Maybe Bool, + -- | Return the help table instead of data. Informational only. + cttoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + cttoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + cttoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Comma-separated list of node IDs or names (the @nodes@ + -- parameter) used to filter the result. + cttoNodes :: Maybe (NonEmpty Text), + -- | The task identifier of the parent task (the @parent_task_id@ + -- parameter). Format is @\:\@. + cttoParentTaskId :: Maybe Text, + -- | Comma-separated sort specifiers (the @s@ parameter). + cttoSort :: Maybe (NonEmpty CatTasksSortSpec), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + cttoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatTasksOptions' with every parameter set to 'Nothing'. Combined +-- with @format=json@ always being added by 'catTasksOptionsParams', the +-- resulting request is byte-identical (modulo the cleaner +-- @/_cat\/tasks?format=json@ URL) to a no-parameter call. +defaultCatTasksOptions :: CatTasksOptions +defaultCatTasksOptions = + CatTasksOptions + { cttoActions = Nothing, + cttoColumns = Nothing, + cttoDetailed = Nothing, + cttoHelp = Nothing, + cttoLocal = Nothing, + cttoMasterTimeout = Nothing, + cttoNodes = Nothing, + cttoParentTaskId = Nothing, + cttoSort = Nothing, + cttoVerbose = Nothing + } + +cttoActionsLens :: Lens' CatTasksOptions (Maybe (NonEmpty Text)) +cttoActionsLens = lens cttoActions (\x y -> x {cttoActions = y}) + +cttoColumnsLens :: Lens' CatTasksOptions (Maybe (NonEmpty CatTasksColumn)) +cttoColumnsLens = lens cttoColumns (\x y -> x {cttoColumns = y}) + +cttoDetailedLens :: Lens' CatTasksOptions (Maybe Bool) +cttoDetailedLens = lens cttoDetailed (\x y -> x {cttoDetailed = y}) + +cttoHelpLens :: Lens' CatTasksOptions (Maybe Bool) +cttoHelpLens = lens cttoHelp (\x y -> x {cttoHelp = y}) + +cttoLocalLens :: Lens' CatTasksOptions (Maybe Bool) +cttoLocalLens = lens cttoLocal (\x y -> x {cttoLocal = y}) + +cttoMasterTimeoutLens :: Lens' CatTasksOptions (Maybe (TimeUnits, Word32)) +cttoMasterTimeoutLens = lens cttoMasterTimeout (\x y -> x {cttoMasterTimeout = y}) + +cttoNodesLens :: Lens' CatTasksOptions (Maybe (NonEmpty Text)) +cttoNodesLens = lens cttoNodes (\x y -> x {cttoNodes = y}) + +cttoParentTaskIdLens :: Lens' CatTasksOptions (Maybe Text) +cttoParentTaskIdLens = lens cttoParentTaskId (\x y -> x {cttoParentTaskId = y}) + +cttoSortLens :: Lens' CatTasksOptions (Maybe (NonEmpty CatTasksSortSpec)) +cttoSortLens = lens cttoSort (\x y -> x {cttoSort = y}) + +cttoVerboseLens :: Lens' CatTasksOptions (Maybe Bool) +cttoVerboseLens = lens cttoVerbose (\x y -> x {cttoVerbose = y}) + +-- | Render 'CatTasksOptions' as a list of @(key, value)@ pairs suitable +-- for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatTasksOptions' emits only the always-required @format=json@ +-- entry. The order is stable but /unspecified/; callers should treat +-- the result as a set. +catTasksOptionsParams :: CatTasksOptions -> [(Text, Maybe Text)] +catTasksOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("actions",) . Just . renderList <$> cttoActions opts, + ("h",) . Just . renderColumns <$> cttoColumns opts, + ("detailed",) . Just . boolQP <$> cttoDetailed opts, + ("help",) . Just . boolQP <$> cttoHelp opts, + ("local",) . Just . boolQP <$> cttoLocal opts, + ("master_timeout",) . Just . renderDuration <$> cttoMasterTimeout opts, + ("nodes",) . Just . renderList <$> cttoNodes opts, + ("parent_task_id",) . Just <$> cttoParentTaskId opts, + ("s",) . Just . renderSort <$> cttoSort opts, + ("v",) . Just . boolQP <$> cttoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderList = T.intercalate "," . toList + renderColumns = T.intercalate "," . map catTasksColumnText . toList + renderSort = T.intercalate "," . map catTasksSortSpecText . toList + +-- | Structured row of @GET /_cat\/tasks?format=json@. Every default +-- column documented by ES is typed; anything the server adds in future +-- (or that surfaces under non-default options) is preserved verbatim in +-- 'ctrrOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns. Every cell is rendered as a JSON +-- string by the server, including the numerically-valued @start_time@ +-- (epoch millis) and @running_time_ns@ (nanos) columns; both are kept +-- as 'Text' here so the parser does not impose a precision. Callers +-- may parse further with e.g. @'Data.Read.readMaybe' . 'Data.Text.unpack'@. +data CatTasksRow = CatTasksRow + { -- | @id@ — the node-local task sequence number. ES only. + ctrrId :: Maybe Text, + -- | @action@ — the task action name (e.g. + -- @cluster:monitor\/tasks\/lists[n]@). + ctrrAction :: Maybe Text, + -- | @task_id@ — the cluster-unique task identifier in + -- @\:\@ form. + ctrrTaskId :: Maybe Text, + -- | @parent_task_id@ — the parent task identifier, or @"-"@ when the + -- task has no parent. + ctrrParentTaskId :: Maybe Text, + -- | @type@ — the task transport type (e.g. @transport@, @direct@). + ctrrType :: Maybe Text, + -- | @start_time@ — the task start time as epoch millis (string). + ctrrStartTime :: Maybe Text, + -- | @timestamp@ — the task start time as @HH:MM:SS@. + ctrrTimestamp :: Maybe Text, + -- | @running_time@ — the task wall-clock duration with unit suffix + -- (e.g. @"44.1micros"@, @"489.5ms"@). + ctrrRunningTime :: Maybe Text, + -- | @running_time_ns@ — the task duration in nanoseconds (string of + -- digits). ES only. + ctrrRunningTimeNs :: Maybe Text, + -- | @node_id@ — the unique node identifier. ES only. + ctrrNodeId :: Maybe Text, + -- | @ip@ — the node's address as @IP:port@. + ctrrIp :: Maybe Text, + -- | @port@ — the node's publish port. ES only. + ctrrPort :: Maybe Text, + -- | @node@ — the node name. + ctrrNode :: Maybe Text, + -- | @version@ — the node's ES version. ES only. + ctrrVersion :: Maybe Text, + -- | @x_opaque_id@ — the X-Opaque-ID header of the request, if any. + -- ES only. + ctrrXOpaqueId :: Maybe Text, + -- | @description@ — the detailed task description (only populated + -- when the @detailed@ parameter is set). ES only. + ctrrDescription :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'calrOther' / 'crrOther'. + ctrrOther :: Value + } + deriving stock (Eq, Show) + +ctrrIdLens :: Lens' CatTasksRow (Maybe Text) +ctrrIdLens = lens ctrrId (\x y -> x {ctrrId = y}) + +ctrrActionLens :: Lens' CatTasksRow (Maybe Text) +ctrrActionLens = lens ctrrAction (\x y -> x {ctrrAction = y}) + +ctrrTaskIdLens :: Lens' CatTasksRow (Maybe Text) +ctrrTaskIdLens = lens ctrrTaskId (\x y -> x {ctrrTaskId = y}) + +ctrrParentTaskIdLens :: Lens' CatTasksRow (Maybe Text) +ctrrParentTaskIdLens = lens ctrrParentTaskId (\x y -> x {ctrrParentTaskId = y}) + +ctrrTypeLens :: Lens' CatTasksRow (Maybe Text) +ctrrTypeLens = lens ctrrType (\x y -> x {ctrrType = y}) + +ctrrStartTimeLens :: Lens' CatTasksRow (Maybe Text) +ctrrStartTimeLens = lens ctrrStartTime (\x y -> x {ctrrStartTime = y}) + +ctrrTimestampLens :: Lens' CatTasksRow (Maybe Text) +ctrrTimestampLens = lens ctrrTimestamp (\x y -> x {ctrrTimestamp = y}) + +ctrrRunningTimeLens :: Lens' CatTasksRow (Maybe Text) +ctrrRunningTimeLens = lens ctrrRunningTime (\x y -> x {ctrrRunningTime = y}) + +ctrrRunningTimeNsLens :: Lens' CatTasksRow (Maybe Text) +ctrrRunningTimeNsLens = lens ctrrRunningTimeNs (\x y -> x {ctrrRunningTimeNs = y}) + +ctrrNodeIdLens :: Lens' CatTasksRow (Maybe Text) +ctrrNodeIdLens = lens ctrrNodeId (\x y -> x {ctrrNodeId = y}) + +ctrrIpLens :: Lens' CatTasksRow (Maybe Text) +ctrrIpLens = lens ctrrIp (\x y -> x {ctrrIp = y}) + +ctrrPortLens :: Lens' CatTasksRow (Maybe Text) +ctrrPortLens = lens ctrrPort (\x y -> x {ctrrPort = y}) + +ctrrNodeLens :: Lens' CatTasksRow (Maybe Text) +ctrrNodeLens = lens ctrrNode (\x y -> x {ctrrNode = y}) + +ctrrVersionLens :: Lens' CatTasksRow (Maybe Text) +ctrrVersionLens = lens ctrrVersion (\x y -> x {ctrrVersion = y}) + +ctrrXOpaqueIdLens :: Lens' CatTasksRow (Maybe Text) +ctrrXOpaqueIdLens = lens ctrrXOpaqueId (\x y -> x {ctrrXOpaqueId = y}) + +ctrrDescriptionLens :: Lens' CatTasksRow (Maybe Text) +ctrrDescriptionLens = lens ctrrDescription (\x y -> x {ctrrDescription = y}) + +ctrrOtherLens :: Lens' CatTasksRow Value +ctrrOtherLens = lens ctrrOther (\x y -> x {ctrrOther = y}) + +instance FromJSON CatTasksRow where + parseJSON = withObject "CatTasksRow" $ \o -> + CatTasksRow + <$> o .:? "id" + <*> o .:? "action" + <*> o .:? "task_id" + <*> o .:? "parent_task_id" + <*> o .:? "type" + <*> o .:? "start_time" + <*> o .:? "timestamp" + <*> o .:? "running_time" + <*> o .:? "running_time_ns" + <*> o .:? "node_id" + <*> o .:? "ip" + <*> o .:? "port" + <*> o .:? "node" + <*> o .:? "version" + <*> o .:? "x_opaque_id" + <*> o .:? "description" + <*> pure (Object o) + +-- ========================================================================= +-- @_cat\/snapshots@ +-- ========================================================================= +-- +-- The @_cat\/snapshots@ endpoint lists the snapshots stored in one or +-- more snapshot repositories. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell is rendered as a +-- JSON string when @format=json@ is set, including the numerically +-- concept-typed @start_epoch@\/@end_epoch@ (epoch seconds) and +-- @successful_shards@\/@failed_shards@\/@total_shards@ counts. The +-- result list is empty when the repository holds no snapshots. + +-- | A column accepted by the @h@ (header) URI parameter of +-- @_cat\/snapshots@. Every documented column is enumerated; anything +-- else is captured verbatim by 'CatSnapshotsColOther'. +-- +-- See +data CatSnapshotsColumn + = CatSnapshotsColId + | CatSnapshotsColRepository + | CatSnapshotsColStatus + | CatSnapshotsColStartEpoch + | CatSnapshotsColStartTime + | CatSnapshotsColEndEpoch + | CatSnapshotsColEndTime + | CatSnapshotsColDuration + | CatSnapshotsColIndices + | CatSnapshotsColSuccessfulShards + | CatSnapshotsColFailedShards + | CatSnapshotsColTotalShards + | CatSnapshotsColReason + | CatSnapshotsColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatSnapshotsColumn'. Used by +-- 'catSnapshotsOptionsParams' (for the @h@ parameter) and by +-- 'catSnapshotsSortSpecText' (for the @s@ parameter). Only the +-- canonical column names are enumerated here; cat also accepts short +-- aliases (e.g. @re@ for @repository@, @ste@ for @start_epoch@) which +-- callers can pass verbatim via 'CatSnapshotsColOther'. +catSnapshotsColumnText :: CatSnapshotsColumn -> Text +catSnapshotsColumnText CatSnapshotsColId = "id" +catSnapshotsColumnText CatSnapshotsColRepository = "repository" +catSnapshotsColumnText CatSnapshotsColStatus = "status" +catSnapshotsColumnText CatSnapshotsColStartEpoch = "start_epoch" +catSnapshotsColumnText CatSnapshotsColStartTime = "start_time" +catSnapshotsColumnText CatSnapshotsColEndEpoch = "end_epoch" +catSnapshotsColumnText CatSnapshotsColEndTime = "end_time" +catSnapshotsColumnText CatSnapshotsColDuration = "duration" +catSnapshotsColumnText CatSnapshotsColIndices = "indices" +catSnapshotsColumnText CatSnapshotsColSuccessfulShards = "successful_shards" +catSnapshotsColumnText CatSnapshotsColFailedShards = "failed_shards" +catSnapshotsColumnText CatSnapshotsColTotalShards = "total_shards" +catSnapshotsColumnText CatSnapshotsColReason = "reason" +catSnapshotsColumnText (CatSnapshotsColOther t) = t + +-- | A single @\[:\]@ term in the @s@ URI parameter +-- of @_cat\/snapshots@. Structurally identical to 'CatSortSpec' but +-- tied to 'CatSnapshotsColumn' so the column spaces can evolve +-- independently. +data CatSnapshotsSortSpec = CatSnapshotsSortSpec + { catSnapshotsSortSpecColumn :: CatSnapshotsColumn, + catSnapshotsSortSpecDirection :: Maybe CatSortDirection + } + deriving stock (Eq, Show) + +-- | Render a 'CatSnapshotsSortSpec' as @\@ or +-- @\:\@. +catSnapshotsSortSpecText :: CatSnapshotsSortSpec -> Text +catSnapshotsSortSpecText (CatSnapshotsSortSpec col mDir) = + case mDir of + Nothing -> catSnapshotsColumnText col + Just dir -> catSnapshotsColumnText col <> ":" <> catSortDirectionText dir + +-- | URI parameters accepted by @GET /_cat\/snapshots@. Every parameter +-- documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatSnapshotsOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions' and 'CatAliasesOptions', the renderer below emits +-- @master_timeout@ for every backend (OS still accepts it as a +-- deprecated alias). A future bead may grow a per-backend override if +-- OS ever drops the alias. +data CatSnapshotsOptions = CatSnapshotsOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + csnoColumns :: Maybe (NonEmpty CatSnapshotsColumn), + -- | Return the help table instead of data. Informational only. + csnoHelp :: Maybe Bool, + -- | Whether to omit unavailable snapshots from the response (the + -- @ignore_unavailable@ parameter). + csnoIgnoreUnavailable :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + csnoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + csnoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Comma-separated sort specifiers (the @s@ parameter). + csnoSort :: Maybe (NonEmpty CatSnapshotsSortSpec), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + csnoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatSnapshotsOptions' with every parameter set to 'Nothing'. +-- Combined with @format=json@ always being added by +-- 'catSnapshotsOptionsParams', the resulting request is byte-identical +-- (modulo the cleaner @/_cat\/snapshots?format=json@ URL) to a +-- no-parameter call. +defaultCatSnapshotsOptions :: CatSnapshotsOptions +defaultCatSnapshotsOptions = + CatSnapshotsOptions + { csnoColumns = Nothing, + csnoHelp = Nothing, + csnoIgnoreUnavailable = Nothing, + csnoLocal = Nothing, + csnoMasterTimeout = Nothing, + csnoSort = Nothing, + csnoVerbose = Nothing + } + +csnoColumnsLens :: Lens' CatSnapshotsOptions (Maybe (NonEmpty CatSnapshotsColumn)) +csnoColumnsLens = lens csnoColumns (\x y -> x {csnoColumns = y}) + +csnoHelpLens :: Lens' CatSnapshotsOptions (Maybe Bool) +csnoHelpLens = lens csnoHelp (\x y -> x {csnoHelp = y}) + +csnoIgnoreUnavailableLens :: Lens' CatSnapshotsOptions (Maybe Bool) +csnoIgnoreUnavailableLens = lens csnoIgnoreUnavailable (\x y -> x {csnoIgnoreUnavailable = y}) + +csnoLocalLens :: Lens' CatSnapshotsOptions (Maybe Bool) +csnoLocalLens = lens csnoLocal (\x y -> x {csnoLocal = y}) + +csnoMasterTimeoutLens :: Lens' CatSnapshotsOptions (Maybe (TimeUnits, Word32)) +csnoMasterTimeoutLens = lens csnoMasterTimeout (\x y -> x {csnoMasterTimeout = y}) + +csnoSortLens :: Lens' CatSnapshotsOptions (Maybe (NonEmpty CatSnapshotsSortSpec)) +csnoSortLens = lens csnoSort (\x y -> x {csnoSort = y}) + +csnoVerboseLens :: Lens' CatSnapshotsOptions (Maybe Bool) +csnoVerboseLens = lens csnoVerbose (\x y -> x {csnoVerbose = y}) + +-- | Render 'CatSnapshotsOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatSnapshotsOptions' emits only the always-required +-- @format=json@ entry. The order is stable but /unspecified/; callers +-- should treat the result as a set. +catSnapshotsOptionsParams :: CatSnapshotsOptions -> [(Text, Maybe Text)] +catSnapshotsOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> csnoColumns opts, + ("help",) . Just . boolQP <$> csnoHelp opts, + ("ignore_unavailable",) . Just . boolQP <$> csnoIgnoreUnavailable opts, + ("local",) . Just . boolQP <$> csnoLocal opts, + ("master_timeout",) . Just . renderDuration <$> csnoMasterTimeout opts, + ("s",) . Just . renderSort <$> csnoSort opts, + ("v",) . Just . boolQP <$> csnoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catSnapshotsColumnText . toList + renderSort = T.intercalate "," . map catSnapshotsSortSpecText . toList + +-- | Structured row of @GET /_cat\/snapshots?format=json@. Every +-- default column documented by ES is typed; anything the server adds +-- in future (or that surfaces under non-default options) is preserved +-- verbatim in 'csnrOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns. Every cell is rendered as a JSON +-- string by the server, including the numerically-valued +-- @start_epoch@\/@end_epoch@ (epoch seconds) and shard-count columns; +-- all are kept as 'Text' here so the parser does not impose a +-- precision (mirroring 'CatRepositoriesRow' and 'CatTasksRow'). +-- Callers may parse further with e.g. +-- @'Data.Read.readMaybe' . 'Data.Text.unpack'@. +data CatSnapshotsRow = CatSnapshotsRow + { -- | @id@ — the snapshot identifier. + csnrId :: Maybe Text, + -- | @repository@ — the repository name. + csnrRepository :: Maybe Text, + -- | @status@ — the snapshot status (e.g. @SUCCESS@, @FAILED@, + -- @IN_PROGRESS@, @PARTIAL@, @INCOMPATIBLE@). + csnrStatus :: Maybe Text, + -- | @start_epoch@ — the snapshot start time as epoch seconds + -- (string of digits). + csnrStartEpoch :: Maybe Text, + -- | @start_time@ — the snapshot start time as @HH:MM:SS@. + csnrStartTime :: Maybe Text, + -- | @end_epoch@ — the snapshot end time as epoch seconds (string of + -- digits). + csnrEndEpoch :: Maybe Text, + -- | @end_time@ — the snapshot end time as @HH:MM:SS@. + csnrEndTime :: Maybe Text, + -- | @duration@ — the snapshot wall-clock duration with unit suffix + -- (e.g. @"4.6m"@, @"12.5s"@). + csnrDuration :: Maybe Text, + -- | @indices@ — the number of indices in the snapshot (string of + -- digits). + csnrIndices :: Maybe Text, + -- | @successful_shards@ — the number of shards snapshotted + -- successfully (string of digits). + csnrSuccessfulShards :: Maybe Text, + -- | @failed_shards@ — the number of shards that failed (string of + -- digits). + csnrFailedShards :: Maybe Text, + -- | @total_shards@ — the total number of shards in the snapshot + -- (string of digits). + csnrTotalShards :: Maybe Text, + -- | @reason@ — the failure reason for @FAILED@\/@PARTIAL@ snapshots. + csnrReason :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'crrOther' / 'ctrrOther'. + csnrOther :: Value + } + deriving stock (Eq, Show) + +csnrIdLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrIdLens = lens csnrId (\x y -> x {csnrId = y}) + +csnrRepositoryLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrRepositoryLens = lens csnrRepository (\x y -> x {csnrRepository = y}) + +csnrStatusLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrStatusLens = lens csnrStatus (\x y -> x {csnrStatus = y}) + +csnrStartEpochLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrStartEpochLens = lens csnrStartEpoch (\x y -> x {csnrStartEpoch = y}) + +csnrStartTimeLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrStartTimeLens = lens csnrStartTime (\x y -> x {csnrStartTime = y}) + +csnrEndEpochLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrEndEpochLens = lens csnrEndEpoch (\x y -> x {csnrEndEpoch = y}) + +csnrEndTimeLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrEndTimeLens = lens csnrEndTime (\x y -> x {csnrEndTime = y}) + +csnrDurationLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrDurationLens = lens csnrDuration (\x y -> x {csnrDuration = y}) + +csnrIndicesLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrIndicesLens = lens csnrIndices (\x y -> x {csnrIndices = y}) + +csnrSuccessfulShardsLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrSuccessfulShardsLens = lens csnrSuccessfulShards (\x y -> x {csnrSuccessfulShards = y}) + +csnrFailedShardsLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrFailedShardsLens = lens csnrFailedShards (\x y -> x {csnrFailedShards = y}) + +csnrTotalShardsLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrTotalShardsLens = lens csnrTotalShards (\x y -> x {csnrTotalShards = y}) + +csnrReasonLens :: Lens' CatSnapshotsRow (Maybe Text) +csnrReasonLens = lens csnrReason (\x y -> x {csnrReason = y}) + +csnrOtherLens :: Lens' CatSnapshotsRow Value +csnrOtherLens = lens csnrOther (\x y -> x {csnrOther = y}) + +instance FromJSON CatSnapshotsRow where + parseJSON = withObject "CatSnapshotsRow" $ \o -> + CatSnapshotsRow + <$> o .:? "id" + <*> o .:? "repository" + <*> o .:? "status" + <*> o .:? "start_epoch" + <*> o .:? "start_time" + <*> o .:? "end_epoch" + <*> o .:? "end_time" + <*> o .:? "duration" + <*> o .:? "indices" + <*> o .:? "successful_shards" + <*> o .:? "failed_shards" + <*> o .:? "total_shards" + <*> o .:? "reason" + <*> pure (Object o) + +-- ========================================================================= +-- @_cat\/nodes@ +-- ========================================================================= +-- +-- The @_cat\/nodes@ endpoint lists the cluster's topology: one row per +-- node with its identity, resource usage, and elected-master flag. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell — including +-- numerics — is rendered as a JSON string when @format=json@ is set, +-- with @"*"@\/@"-"@ used as the cat sentinel for the @master@ column +-- (the elected master emits @"*"@, every other node emits @"-"@). The +-- parsers below tolerate both the string form and a native JSON scalar, +-- matching the defensive parity established by 'CatIndicesRow'. + +-- | A column accepted by the @h@ (header) and @s@ (sort) URI parameters +-- of @_cat\/nodes@. Every documented default column is enumerated; +-- anything else is captured verbatim by 'CatNodesColOther'. The ES +-- @help@ table lists many more columns (e.g. @thread_pool.*@, +-- @indexing.*@, @search.*@, @merges.*@, @get.*@, @discovery.*@) — those +-- are intentionally routed through 'CatNodesColOther' so the column +-- space can grow without churning the sum type. +-- +-- See +data CatNodesColumn + = CatNodesColIp + | CatNodesColPort + | CatNodesColHost + | CatNodesColName + | CatNodesColId + | CatNodesColPid + | CatNodesColMaster + | CatNodesColNodeRole + | CatNodesColHeapPercent + | CatNodesColRamPercent + | CatNodesColCpu + | CatNodesColLoad1m + | CatNodesColLoad5m + | CatNodesColLoad15m + | CatNodesColHeapCurrent + | CatNodesColHeapMax + | CatNodesColRamCurrent + | CatNodesColRamMax + | CatNodesColDiskUsedPercent + | CatNodesColDiskUsed + | CatNodesColDiskAvail + | CatNodesColDiskTotal + | CatNodesColFileDescPercent + | CatNodesColFileDescCurrent + | CatNodesColFileDescMax + | CatNodesColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatNodesColumn'. Used by 'catNodesOptionsParams' +-- (for the @h@ parameter) and by 'catNodesSortSpecText' (for the @s@ +-- parameter). Only the canonical column names are enumerated here; cat +-- also accepts a long list of short aliases (e.g. @n@ for @name@, @r@ +-- for @node.role@, @mp@ for @master@, @h@ for @host@, @p@ for @pid@) +-- which callers can pass verbatim via 'CatNodesColOther'. +catNodesColumnText :: CatNodesColumn -> Text +catNodesColumnText CatNodesColIp = "ip" +catNodesColumnText CatNodesColPort = "port" +catNodesColumnText CatNodesColHost = "host" +catNodesColumnText CatNodesColName = "name" +catNodesColumnText CatNodesColId = "id" +catNodesColumnText CatNodesColPid = "pid" +catNodesColumnText CatNodesColMaster = "master" +catNodesColumnText CatNodesColNodeRole = "node.role" +catNodesColumnText CatNodesColHeapPercent = "heap.percent" +catNodesColumnText CatNodesColRamPercent = "ram.percent" +catNodesColumnText CatNodesColCpu = "cpu" +catNodesColumnText CatNodesColLoad1m = "load_1m" +catNodesColumnText CatNodesColLoad5m = "load_5m" +catNodesColumnText CatNodesColLoad15m = "load_15m" +catNodesColumnText CatNodesColHeapCurrent = "heap.current" +catNodesColumnText CatNodesColHeapMax = "heap.max" +catNodesColumnText CatNodesColRamCurrent = "ram.current" +catNodesColumnText CatNodesColRamMax = "ram.max" +catNodesColumnText CatNodesColDiskUsedPercent = "disk.used_percent" +catNodesColumnText CatNodesColDiskUsed = "disk.used" +catNodesColumnText CatNodesColDiskAvail = "disk.avail" +catNodesColumnText CatNodesColDiskTotal = "disk.total" +catNodesColumnText CatNodesColFileDescPercent = "file_desc.percent" +catNodesColumnText CatNodesColFileDescCurrent = "file_desc.current" +catNodesColumnText CatNodesColFileDescMax = "file_desc.max" +catNodesColumnText (CatNodesColOther t) = t + +-- | A single @\[:\]@ term in the @s@ URI parameter +-- of @_cat\/nodes@. Structurally identical to 'CatSortSpec' but tied to +-- 'CatNodesColumn' so the column spaces can evolve independently. +data CatNodesSortSpec = CatNodesSortSpec + { catNodesSortSpecColumn :: CatNodesColumn, + catNodesSortSpecDirection :: Maybe CatSortDirection + } + deriving stock (Eq, Show) + +-- | Render a 'CatNodesSortSpec' as @\@ or +-- @\:\@. +catNodesSortSpecText :: CatNodesSortSpec -> Text +catNodesSortSpecText (CatNodesSortSpec col mDir) = + case mDir of + Nothing -> catNodesColumnText col + Just dir -> catNodesColumnText col <> ":" <> catSortDirectionText dir + +-- | URI parameters accepted by @GET /_cat\/nodes@. Every parameter +-- documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatNodesOptions' to +-- reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions', the renderer below emits @master_timeout@ for +-- every backend (OS still accepts it as a deprecated alias). A future +-- bead may grow a per-backend override if OS ever drops the alias. +data CatNodesOptions = CatNodesOptions + { -- | Display byte sizes in the requested unit. Affects the rendering + -- of @heap.current@\/@heap.max@\/@ram.current@\/@ram.max@ and the + -- @disk.*@ columns. + cnoBytes :: Maybe CatBytesSize, + -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + cnoColumns :: Maybe (NonEmpty CatNodesColumn), + -- | Return the help table instead of data. Informational only. + cnoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + cnoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + cnoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Comma-separated sort specifiers (the @s@ parameter). + cnoSort :: Maybe (NonEmpty CatNodesSortSpec), + -- | Unit used to render time-valued columns (the @time@ parameter), + -- e.g. @('TimeUnitSeconds', 5)@ renders as @5s@. Affects columns + -- such as @uptime@ that are not typed on 'CatNodesRow' but can be + -- requested via @h=@ and read from 'cnrOther'. + cnoTime :: Maybe (TimeUnits, Word32), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + cnoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatNodesOptions' with every parameter set to 'Nothing'. Combined +-- with @format=json@ always being added by 'catNodesOptionsParams', the +-- resulting request is byte-identical (modulo the cleaner +-- @/_cat\/nodes?format=json@ URL) to a no-parameter call. +defaultCatNodesOptions :: CatNodesOptions +defaultCatNodesOptions = + CatNodesOptions + { cnoBytes = Nothing, + cnoColumns = Nothing, + cnoHelp = Nothing, + cnoLocal = Nothing, + cnoMasterTimeout = Nothing, + cnoSort = Nothing, + cnoTime = Nothing, + cnoVerbose = Nothing + } + +cnoBytesLens :: Lens' CatNodesOptions (Maybe CatBytesSize) +cnoBytesLens = lens cnoBytes (\x y -> x {cnoBytes = y}) + +cnoColumnsLens :: Lens' CatNodesOptions (Maybe (NonEmpty CatNodesColumn)) +cnoColumnsLens = lens cnoColumns (\x y -> x {cnoColumns = y}) + +cnoHelpLens :: Lens' CatNodesOptions (Maybe Bool) +cnoHelpLens = lens cnoHelp (\x y -> x {cnoHelp = y}) + +cnoLocalLens :: Lens' CatNodesOptions (Maybe Bool) +cnoLocalLens = lens cnoLocal (\x y -> x {cnoLocal = y}) + +cnoMasterTimeoutLens :: Lens' CatNodesOptions (Maybe (TimeUnits, Word32)) +cnoMasterTimeoutLens = lens cnoMasterTimeout (\x y -> x {cnoMasterTimeout = y}) + +cnoSortLens :: Lens' CatNodesOptions (Maybe (NonEmpty CatNodesSortSpec)) +cnoSortLens = lens cnoSort (\x y -> x {cnoSort = y}) + +cnoTimeLens :: Lens' CatNodesOptions (Maybe (TimeUnits, Word32)) +cnoTimeLens = lens cnoTime (\x y -> x {cnoTime = y}) + +cnoVerboseLens :: Lens' CatNodesOptions (Maybe Bool) +cnoVerboseLens = lens cnoVerbose (\x y -> x {cnoVerbose = y}) + +-- | Render 'CatNodesOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatNodesOptions' emits only the always-required +-- @format=json@ entry. The order is stable but /unspecified/; callers +-- should treat the result as a set. +catNodesOptionsParams :: CatNodesOptions -> [(Text, Maybe Text)] +catNodesOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("bytes",) . Just . catBytesSizeText <$> cnoBytes opts, + ("h",) . Just . renderColumns <$> cnoColumns opts, + ("help",) . Just . boolQP <$> cnoHelp opts, + ("local",) . Just . boolQP <$> cnoLocal opts, + ("master_timeout",) . Just . renderDuration <$> cnoMasterTimeout opts, + ("s",) . Just . renderSort <$> cnoSort opts, + ("time",) . Just . renderDuration <$> cnoTime opts, + ("v",) . Just . boolQP <$> cnoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catNodesColumnText . toList + renderSort = T.intercalate "," . map catNodesSortSpecText . toList + +-- | Value of the @master@ column of @_cat\/nodes@. The elected master +-- emits @"*"@; every other node emits @"-"@. Distinct from a bare +-- 'Bool' so the wire sentinel is explicit and so future cat-emitted +-- values (e.g. a @"2"@ for a tie-breaking voter-only state) can be +-- added without breaking callers. +data CatNodesMaster + = CatNodesMasterTrue + | CatNodesMasterFalse + deriving stock (Eq, Show) + +-- | Parse the @master@ wire string. @"*"@ is the cat sentinel for the +-- elected master; @"-"@ is the sentinel for every other node. Unknown +-- strings fail the parser, matching the defensive-strict precedent of +-- 'catIndexHealthFromText' (a future server-emitted value should +-- surface as a parse failure rather than a silent drop). +catNodesMasterFromText :: Text -> Maybe CatNodesMaster +catNodesMasterFromText "*" = Just CatNodesMasterTrue +catNodesMasterFromText "-" = Just CatNodesMasterFalse +catNodesMasterFromText _ = Nothing + +-- | Inverse of 'catNodesMasterFromText', useful for golden tests and +-- round-trip assertions. +catNodesMasterToText :: CatNodesMaster -> Text +catNodesMasterToText CatNodesMasterTrue = "*" +catNodesMasterToText CatNodesMasterFalse = "-" + +-- | Structured row of @GET /_cat\/nodes?format=json@. Every default +-- column documented by both ES and OS is typed; anything the server +-- adds in future (or that surfaces under non-default options) is +-- preserved verbatim in 'cnrOther'. +-- +-- All fields except 'cnrName' are 'Maybe' because: +-- +-- * the @h@ URI parameter lets the caller request a strict subset of +-- columns; +-- * some columns are omitted on backends or versions that don't track +-- them (e.g. @load_*m@ is absent on Windows, @id@ only appears when +-- @full_id=true@ is requested, @pid@ is hidden when the node cannot +-- introspect its own process). +data CatNodesRow = CatNodesRow + { -- | @ip@ — the published IP address the node advertises. + cnrIp :: Maybe Text, + -- | @port@ — the bound transport port, parsed via 'parseReadText' + -- (cat emits it as a JSON string). + cnrPort :: Maybe Word32, + -- | @host@ — the published host name. + cnrHost :: Maybe Text, + -- | @name@ — the node name. Always present in both ES and OS + -- default output, so it is the only strict field on the row. + cnrName :: Text, + -- | @id@ — the full node ID. Only populated when @full_id=true@ is + -- requested; absent from the default column set. + cnrId :: Maybe FullNodeId, + -- | @pid@ — the node's operating-system process ID. + cnrPid :: Maybe Word32, + -- | @master@ — the elected-master flag. @"*"@ for the elected + -- master, @"-"@ for every other node; decoded to 'CatNodesMaster'. + -- OpenSearch 2.x+ renamed the column to @cluster_manager@; the + -- parser falls back to @cluster_manager@ when @master@ is absent, + -- so callers see a uniform 'cnrMaster' regardless of backend. + cnrMaster :: Maybe CatNodesMaster, + -- | @node.role@ — the node's compact role string (e.g. @"dimr"@). + -- Kept as 'Text' — with the documented single-character convention — + -- so the role space can evolve without a typed wrapper. + -- Forward-compatible like 'csrPrirep'. + -- + -- Note: OS 2.x+ additionally emits a verbose @node_roles@ plural + -- column (e.g. @"cluster_manager,data,ingest,..."@). It is + -- preserved verbatim in 'cnrOther' and not parsed, because every + -- backend still emits the compact singular form too. If OS ever + -- drops the alias, grow a @parseNodeRoleColumn@ fallback that + -- mirrors 'parseMasterColumn'. + cnrNodeRole :: Maybe Text, + -- | @heap.percent@ — JVM heap used ratio (0-100, integer). + cnrHeapPercent :: Maybe Word32, + -- | @ram.percent@ — total memory used ratio (0-100, integer). + cnrRamPercent :: Maybe Word32, + -- | @cpu@ — recent CPU usage (0-100, integer; absent on some + -- platforms — e.g. Windows). + cnrCpu :: Maybe Word32, + -- | @load_1m@, @load_5m@, @load_15m@ — system load averages. Cat + -- emits them as fractional strings (e.g. @"0.07"@); parsed as + -- 'Double'. Absent on platforms that don't expose load averages. + cnrLoad1m :: Maybe Double, + cnrLoad5m :: Maybe Double, + cnrLoad15m :: Maybe Double, + -- | @heap.current@, @heap.max@ — JVM heap in use / max, parsed via + -- 'parseCatSize'. The unit pairs the @bytes@ URI parameter with the + -- server-chosen humanised suffix; use 'catSizeInBytes' to normalise. + cnrHeapCurrent :: Maybe (Bytes, CatBytesSize), + cnrHeapMax :: Maybe (Bytes, CatBytesSize), + -- | @ram.current@, @ram.max@ — total memory in use / max. + cnrRamCurrent :: Maybe (Bytes, CatBytesSize), + cnrRamMax :: Maybe (Bytes, CatBytesSize), + -- | @disk.used_percent@ — disk usage ratio (0-100, integer). + cnrDiskUsedPercent :: Maybe Word32, + -- | @disk.used@, @disk.avail@, @disk.total@ — disk usage / free / + -- total, parsed via 'parseCatSize'. + cnrDiskUsed :: Maybe (Bytes, CatBytesSize), + cnrDiskAvail :: Maybe (Bytes, CatBytesSize), + cnrDiskTotal :: Maybe (Bytes, CatBytesSize), + -- | @file_desc.percent@, @file_desc.current@, @file_desc.max@ — + -- file descriptor usage ratio / count / limit. + cnrFileDescPercent :: Maybe Word32, + cnrFileDescCurrent :: Maybe Word32, + cnrFileDescMax :: Maybe Word32, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'calrOther' / 'csrOther'. + cnrOther :: Value + } + deriving stock (Eq, Show) + +cnrIpLens :: Lens' CatNodesRow (Maybe Text) +cnrIpLens = lens cnrIp (\x y -> x {cnrIp = y}) + +cnrPortLens :: Lens' CatNodesRow (Maybe Word32) +cnrPortLens = lens cnrPort (\x y -> x {cnrPort = y}) + +cnrHostLens :: Lens' CatNodesRow (Maybe Text) +cnrHostLens = lens cnrHost (\x y -> x {cnrHost = y}) + +cnrNameLens :: Lens' CatNodesRow Text +cnrNameLens = lens cnrName (\x y -> x {cnrName = y}) + +cnrIdLens :: Lens' CatNodesRow (Maybe FullNodeId) +cnrIdLens = lens cnrId (\x y -> x {cnrId = y}) + +cnrPidLens :: Lens' CatNodesRow (Maybe Word32) +cnrPidLens = lens cnrPid (\x y -> x {cnrPid = y}) + +cnrMasterLens :: Lens' CatNodesRow (Maybe CatNodesMaster) +cnrMasterLens = lens cnrMaster (\x y -> x {cnrMaster = y}) + +cnrNodeRoleLens :: Lens' CatNodesRow (Maybe Text) +cnrNodeRoleLens = lens cnrNodeRole (\x y -> x {cnrNodeRole = y}) + +cnrHeapPercentLens :: Lens' CatNodesRow (Maybe Word32) +cnrHeapPercentLens = lens cnrHeapPercent (\x y -> x {cnrHeapPercent = y}) + +cnrRamPercentLens :: Lens' CatNodesRow (Maybe Word32) +cnrRamPercentLens = lens cnrRamPercent (\x y -> x {cnrRamPercent = y}) + +cnrCpuLens :: Lens' CatNodesRow (Maybe Word32) +cnrCpuLens = lens cnrCpu (\x y -> x {cnrCpu = y}) + +cnrLoad1mLens :: Lens' CatNodesRow (Maybe Double) +cnrLoad1mLens = lens cnrLoad1m (\x y -> x {cnrLoad1m = y}) + +cnrLoad5mLens :: Lens' CatNodesRow (Maybe Double) +cnrLoad5mLens = lens cnrLoad5m (\x y -> x {cnrLoad5m = y}) + +cnrLoad15mLens :: Lens' CatNodesRow (Maybe Double) +cnrLoad15mLens = lens cnrLoad15m (\x y -> x {cnrLoad15m = y}) + +cnrHeapCurrentLens :: Lens' CatNodesRow (Maybe (Bytes, CatBytesSize)) +cnrHeapCurrentLens = lens cnrHeapCurrent (\x y -> x {cnrHeapCurrent = y}) + +cnrHeapMaxLens :: Lens' CatNodesRow (Maybe (Bytes, CatBytesSize)) +cnrHeapMaxLens = lens cnrHeapMax (\x y -> x {cnrHeapMax = y}) + +cnrRamCurrentLens :: Lens' CatNodesRow (Maybe (Bytes, CatBytesSize)) +cnrRamCurrentLens = lens cnrRamCurrent (\x y -> x {cnrRamCurrent = y}) + +cnrRamMaxLens :: Lens' CatNodesRow (Maybe (Bytes, CatBytesSize)) +cnrRamMaxLens = lens cnrRamMax (\x y -> x {cnrRamMax = y}) + +cnrDiskUsedPercentLens :: Lens' CatNodesRow (Maybe Word32) +cnrDiskUsedPercentLens = lens cnrDiskUsedPercent (\x y -> x {cnrDiskUsedPercent = y}) + +cnrDiskUsedLens :: Lens' CatNodesRow (Maybe (Bytes, CatBytesSize)) +cnrDiskUsedLens = lens cnrDiskUsed (\x y -> x {cnrDiskUsed = y}) + +cnrDiskAvailLens :: Lens' CatNodesRow (Maybe (Bytes, CatBytesSize)) +cnrDiskAvailLens = lens cnrDiskAvail (\x y -> x {cnrDiskAvail = y}) + +cnrDiskTotalLens :: Lens' CatNodesRow (Maybe (Bytes, CatBytesSize)) +cnrDiskTotalLens = lens cnrDiskTotal (\x y -> x {cnrDiskTotal = y}) + +cnrFileDescPercentLens :: Lens' CatNodesRow (Maybe Word32) +cnrFileDescPercentLens = lens cnrFileDescPercent (\x y -> x {cnrFileDescPercent = y}) + +cnrFileDescCurrentLens :: Lens' CatNodesRow (Maybe Word32) +cnrFileDescCurrentLens = lens cnrFileDescCurrent (\x y -> x {cnrFileDescCurrent = y}) + +cnrFileDescMaxLens :: Lens' CatNodesRow (Maybe Word32) +cnrFileDescMaxLens = lens cnrFileDescMax (\x y -> x {cnrFileDescMax = y}) + +cnrOtherLens :: Lens' CatNodesRow Value +cnrOtherLens = lens cnrOther (\x y -> x {cnrOther = y}) + +instance FromJSON CatNodesRow where + parseJSON = withObject "CatNodesRow" $ \o -> + CatNodesRow + <$> o .:? "ip" + <*> (o .:? "port" >>= traverse parseWord32) + <*> o .:? "host" + <*> o .: "name" + <*> o .:? "id" + <*> (o .:? "pid" >>= traverse parseWord32) + <*> parseMasterColumn o + <*> o .:? "node.role" + <*> (o .:? "heap.percent" >>= traverse parseWord32) + <*> (o .:? "ram.percent" >>= traverse parseWord32) + <*> (o .:? "cpu" >>= traverse parseWord32) + <*> (o .:? "load_1m" >>= traverse parseDouble) + <*> (o .:? "load_5m" >>= traverse parseDouble) + <*> (o .:? "load_15m" >>= traverse parseDouble) + <*> (o .:? "heap.current" >>= traverse parseSize) + <*> (o .:? "heap.max" >>= traverse parseSize) + <*> (o .:? "ram.current" >>= traverse parseSize) + <*> (o .:? "ram.max" >>= traverse parseSize) + <*> (o .:? "disk.used_percent" >>= traverse parseWord32) + <*> (o .:? "disk.used" >>= traverse parseSize) + <*> (o .:? "disk.avail" >>= traverse parseSize) + <*> (o .:? "disk.total" >>= traverse parseSize) + <*> (o .:? "file_desc.percent" >>= traverse parseWord32) + <*> (o .:? "file_desc.current" >>= traverse parseWord32) + <*> (o .:? "file_desc.max" >>= traverse parseWord32) + <*> pure (Object o) + where + parseWord32 = parseAsString "Word32" parseReadText + parseDouble = parseAsString "Double" parseReadText + parseSize = parseAsString "byte-size" parseCatSize + parseMaster = parseAsString "master" go + where + go t = case catNodesMasterFromText t of + Just m -> pure m + Nothing -> fail ("invalid cat master sentinel: " <> T.unpack t) + -- ES emits the elected-master flag as @master@; OpenSearch 2.x+ + -- renamed the column to @cluster_manager@. Try @master@ first + -- (the canonical ES name), then fall back to @cluster_manager@ + -- so callers see a uniform 'cnrMaster' regardless of backend. + parseMasterColumn obj = + obj .:? "master" >>= \mMasterV -> + case mMasterV of + Just v -> Just <$> parseMaster v + Nothing -> obj .:? "cluster_manager" >>= traverse parseMaster + +-- ========================================================================= +-- @_cat\/segments@ +-- ========================================================================= +-- +-- The @_cat\/segments@ endpoint lists the low-level Lucene segments +-- of each shard of each index. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell is rendered as a +-- JSON string when @format=json@ is set, including numerics and +-- booleans. The parsers below tolerate both the string form and a +-- native JSON scalar, matching the defensive parity established by +-- 'CatIndicesRow'. + +-- | A column accepted by the @h@ (header) and @s@ (sort) URI parameters +-- of @_cat\/segments@. Every documented column is enumerated; anything +-- else is captured verbatim by 'CatSegmentsColOther'. +-- +-- See +data CatSegmentsColumn + = CatSegmentsColIndex + | CatSegmentsColShard + | CatSegmentsColPrirep + | CatSegmentsColIp + | CatSegmentsColSegment + | CatSegmentsColId + | CatSegmentsColGeneration + | CatSegmentsColDocsCount + | CatSegmentsColDocsDeleted + | CatSegmentsColSize + | CatSegmentsColSizeMemory + | CatSegmentsColCommitted + | CatSegmentsColSearchable + | CatSegmentsColVersion + | CatSegmentsColCompound + | CatSegmentsColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatSegmentsColumn'. Used by +-- 'catSegmentsOptionsParams' (for the @h@ parameter) and by +-- 'catSegmentsSortSpecText' (for the @s@ parameter). Only the +-- canonical column names are enumerated here; cat also accepts short +-- aliases which callers can pass verbatim via 'CatSegmentsColOther'. +catSegmentsColumnText :: CatSegmentsColumn -> Text +catSegmentsColumnText CatSegmentsColIndex = "index" +catSegmentsColumnText CatSegmentsColShard = "shard" +catSegmentsColumnText CatSegmentsColPrirep = "prirep" +catSegmentsColumnText CatSegmentsColIp = "ip" +catSegmentsColumnText CatSegmentsColSegment = "segment" +catSegmentsColumnText CatSegmentsColId = "id" +catSegmentsColumnText CatSegmentsColGeneration = "generation" +catSegmentsColumnText CatSegmentsColDocsCount = "docs.count" +catSegmentsColumnText CatSegmentsColDocsDeleted = "docs.deleted" +catSegmentsColumnText CatSegmentsColSize = "size" +catSegmentsColumnText CatSegmentsColSizeMemory = "size.memory" +catSegmentsColumnText CatSegmentsColCommitted = "committed" +catSegmentsColumnText CatSegmentsColSearchable = "searchable" +catSegmentsColumnText CatSegmentsColVersion = "version" +catSegmentsColumnText CatSegmentsColCompound = "compound" +catSegmentsColumnText (CatSegmentsColOther t) = t + +-- | A single @\[:\]@ term in the @s@ URI parameter +-- of @_cat\/segments@. Structurally identical to 'CatSortSpec' but +-- tied to 'CatSegmentsColumn' so the column spaces can evolve +-- independently. +data CatSegmentsSortSpec = CatSegmentsSortSpec + { catSegmentsSortSpecColumn :: CatSegmentsColumn, + catSegmentsSortSpecDirection :: Maybe CatSortDirection + } + deriving stock (Eq, Show) + +-- | Render a 'CatSegmentsSortSpec' as @\@ or +-- @\:\@. +catSegmentsSortSpecText :: CatSegmentsSortSpec -> Text +catSegmentsSortSpecText (CatSegmentsSortSpec col mDir) = + case mDir of + Nothing -> catSegmentsColumnText col + Just dir -> catSegmentsColumnText col <> ":" <> catSortDirectionText dir + +-- | URI parameters accepted by @GET /_cat\/segments@. Every +-- parameter documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatSegmentsOptions' +-- to reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions', the renderer below emits @master_timeout@ for +-- every backend (OS still accepts it as a deprecated alias). A future +-- bead may grow a per-backend override if OS ever drops the alias. +data CatSegmentsOptions = CatSegmentsOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + csgoColumns :: Maybe (NonEmpty CatSegmentsColumn), + -- | Byte-size unit used to render size columns (the @bytes@ + -- parameter). + csgoBytes :: Maybe CatBytesSize, + -- | Return the help table instead of data. Informational only. + csgoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + csgoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + csgoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Comma-separated sort specifiers (the @s@ parameter). + csgoSort :: Maybe (NonEmpty CatSegmentsSortSpec), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + csgoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatSegmentsOptions' with every parameter set to 'Nothing'. +defaultCatSegmentsOptions :: CatSegmentsOptions +defaultCatSegmentsOptions = + CatSegmentsOptions + { csgoColumns = Nothing, + csgoBytes = Nothing, + csgoHelp = Nothing, + csgoLocal = Nothing, + csgoMasterTimeout = Nothing, + csgoSort = Nothing, + csgoVerbose = Nothing + } + +csgoColumnsLens :: Lens' CatSegmentsOptions (Maybe (NonEmpty CatSegmentsColumn)) +csgoColumnsLens = lens csgoColumns (\x y -> x {csgoColumns = y}) + +csgoBytesLens :: Lens' CatSegmentsOptions (Maybe CatBytesSize) +csgoBytesLens = lens csgoBytes (\x y -> x {csgoBytes = y}) + +csgoHelpLens :: Lens' CatSegmentsOptions (Maybe Bool) +csgoHelpLens = lens csgoHelp (\x y -> x {csgoHelp = y}) + +csgoLocalLens :: Lens' CatSegmentsOptions (Maybe Bool) +csgoLocalLens = lens csgoLocal (\x y -> x {csgoLocal = y}) + +csgoMasterTimeoutLens :: Lens' CatSegmentsOptions (Maybe (TimeUnits, Word32)) +csgoMasterTimeoutLens = lens csgoMasterTimeout (\x y -> x {csgoMasterTimeout = y}) + +csgoSortLens :: Lens' CatSegmentsOptions (Maybe (NonEmpty CatSegmentsSortSpec)) +csgoSortLens = lens csgoSort (\x y -> x {csgoSort = y}) + +csgoVerboseLens :: Lens' CatSegmentsOptions (Maybe Bool) +csgoVerboseLens = lens csgoVerbose (\x y -> x {csgoVerbose = y}) + +-- | Render 'CatSegmentsOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatSegmentsOptions' emits only the always-required +-- @format=json@ entry. +catSegmentsOptionsParams :: CatSegmentsOptions -> [(Text, Maybe Text)] +catSegmentsOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> csgoColumns opts, + ("bytes",) . Just . catBytesSizeText <$> csgoBytes opts, + ("help",) . Just . boolQP <$> csgoHelp opts, + ("local",) . Just . boolQP <$> csgoLocal opts, + ("master_timeout",) . Just . renderDuration <$> csgoMasterTimeout opts, + ("s",) . Just . renderSort <$> csgoSort opts, + ("v",) . Just . boolQP <$> csgoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catSegmentsColumnText . toList + renderSort = T.intercalate "," . map catSegmentsSortSpecText . toList + +-- | Structured row of @GET /_cat\/segments?format=json@. Every +-- default column documented by ES is typed; anything the server adds in +-- future (or that surfaces under non-default options) is preserved +-- verbatim in 'cserOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns. +data CatSegmentsRow = CatSegmentsRow + { -- | @index@ — the index name. + cserIndex :: Maybe Text, + -- | @shard@ — the shard number. + cserShard :: Maybe Word32, + -- | @prirep@ — @\"p\"@ for primary, @\"r\"@ for replica. + cserPrirep :: Maybe Text, + -- | @ip@ — the IP address of the node hosting the segment. + cserIp :: Maybe Text, + -- | @segment@ — the Lucene segment name. + cserSegment :: Maybe Text, + -- | @id@ — the segment ID (a hex string). + cserId :: Maybe Text, + -- | @generation@ — the generation number of the segment. + cserGeneration :: Maybe Word32, + -- | @docs.count@ — the number of documents in the segment. + cserDocsCount :: Maybe Int64, + -- | @docs.deleted@ — the number of deleted documents. + cserDocsDeleted :: Maybe Int64, + -- | @size@ — the segment size on disk, rendered in the unit + -- specified by the @bytes@ URI parameter (or a server-chosen + -- humanised unit when unset). + cserSize :: Maybe (Bytes, CatBytesSize), + -- | @size.memory@ — the amount of memory used by the segment. + cserSizeMemory :: Maybe (Bytes, CatBytesSize), + -- | @committed@ — whether the segment has been committed to disk. + cserCommitted :: Maybe Bool, + -- | @searchable@ — whether the segment is searchable. + cserSearchable :: Maybe Bool, + -- | @version@ — the Lucene version used to write the segment. + cserVersion :: Maybe Text, + -- | @compound@ — whether the segment uses the compound file format. + cserCompound :: Maybe Bool, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'crrOther'. + cserOther :: Value + } + deriving stock (Eq, Show) + +cserIndexLens :: Lens' CatSegmentsRow (Maybe Text) +cserIndexLens = lens cserIndex (\x y -> x {cserIndex = y}) + +cserShardLens :: Lens' CatSegmentsRow (Maybe Word32) +cserShardLens = lens cserShard (\x y -> x {cserShard = y}) + +cserPrirepLens :: Lens' CatSegmentsRow (Maybe Text) +cserPrirepLens = lens cserPrirep (\x y -> x {cserPrirep = y}) + +cserIpLens :: Lens' CatSegmentsRow (Maybe Text) +cserIpLens = lens cserIp (\x y -> x {cserIp = y}) + +cserSegmentLens :: Lens' CatSegmentsRow (Maybe Text) +cserSegmentLens = lens cserSegment (\x y -> x {cserSegment = y}) + +cserIdLens :: Lens' CatSegmentsRow (Maybe Text) +cserIdLens = lens cserId (\x y -> x {cserId = y}) + +cserGenerationLens :: Lens' CatSegmentsRow (Maybe Word32) +cserGenerationLens = lens cserGeneration (\x y -> x {cserGeneration = y}) + +cserDocsCountLens :: Lens' CatSegmentsRow (Maybe Int64) +cserDocsCountLens = lens cserDocsCount (\x y -> x {cserDocsCount = y}) + +cserDocsDeletedLens :: Lens' CatSegmentsRow (Maybe Int64) +cserDocsDeletedLens = lens cserDocsDeleted (\x y -> x {cserDocsDeleted = y}) + +cserSizeLens :: Lens' CatSegmentsRow (Maybe (Bytes, CatBytesSize)) +cserSizeLens = lens cserSize (\x y -> x {cserSize = y}) + +cserSizeMemoryLens :: Lens' CatSegmentsRow (Maybe (Bytes, CatBytesSize)) +cserSizeMemoryLens = lens cserSizeMemory (\x y -> x {cserSizeMemory = y}) + +cserCommittedLens :: Lens' CatSegmentsRow (Maybe Bool) +cserCommittedLens = lens cserCommitted (\x y -> x {cserCommitted = y}) + +cserSearchableLens :: Lens' CatSegmentsRow (Maybe Bool) +cserSearchableLens = lens cserSearchable (\x y -> x {cserSearchable = y}) + +cserVersionLens :: Lens' CatSegmentsRow (Maybe Text) +cserVersionLens = lens cserVersion (\x y -> x {cserVersion = y}) + +cserCompoundLens :: Lens' CatSegmentsRow (Maybe Bool) +cserCompoundLens = lens cserCompound (\x y -> x {cserCompound = y}) + +cserOtherLens :: Lens' CatSegmentsRow Value +cserOtherLens = lens cserOther (\x y -> x {cserOther = y}) + +instance FromJSON CatSegmentsRow where + parseJSON = withObject "CatSegmentsRow" $ \o -> + CatSegmentsRow + <$> o .:? "index" + <*> (o .:? "shard" >>= traverse parseWord32) + <*> o .:? "prirep" + <*> o .:? "ip" + <*> o .:? "segment" + <*> o .:? "id" + <*> (o .:? "generation" >>= traverse parseWord32) + <*> (o .:? "docs.count" >>= traverse parseInt64) + <*> (o .:? "docs.deleted" >>= traverse parseInt64) + <*> (o .:? "size" >>= traverse parseSize) + <*> (o .:? "size.memory" >>= traverse parseSize) + <*> (o .:? "committed" >>= traverse parseCatBool) + <*> (o .:? "searchable" >>= traverse parseCatBool) + <*> o .:? "version" + <*> (o .:? "compound" >>= traverse parseCatBool) + <*> pure (Object o) + where + parseWord32 = parseAsString "Word32" parseReadText + parseInt64 = parseAsString "Int64" parseReadText + parseSize = parseAsString "segment size" parseCatSize + +-- ========================================================================= +-- @_cat\/recovery@ +-- ========================================================================= +-- +-- The @_cat\/recovery@ endpoint lists shard recovery progress for each +-- shard of each index. See +-- +-- and . +-- +-- The wire shape mirrors @_cat\/indices@: every cell is rendered as a +-- JSON string when @format=json@ is set, including numerics. The +-- parsers below tolerate both the string form and a native JSON scalar. + +-- | A column accepted by the @h@ (header) and @s@ (sort) URI parameters +-- of @_cat\/recovery@. Every documented column is enumerated; anything +-- else is captured verbatim by 'CatRecoveryColOther'. +-- +-- See +data CatRecoveryColumn + = CatRecoveryColIndex + | CatRecoveryColShard + | CatRecoveryColStartTime + | CatRecoveryColStartTimeMillis + | CatRecoveryColStopTime + | CatRecoveryColStopTimeMillis + | CatRecoveryColTime + | CatRecoveryColType + | CatRecoveryColStage + | CatRecoveryColSourceHost + | CatRecoveryColSourceNode + | CatRecoveryColTargetHost + | CatRecoveryColTargetNode + | CatRecoveryColRepository + | CatRecoveryColSnapshot + | CatRecoveryColFiles + | CatRecoveryColFilesRecovered + | CatRecoveryColFilesPercent + | CatRecoveryColFilesTotal + | CatRecoveryColBytes + | CatRecoveryColBytesRecovered + | CatRecoveryColBytesPercent + | CatRecoveryColBytesTotal + | CatRecoveryColTranslogOps + | CatRecoveryColTranslogOpsRecovered + | CatRecoveryColTranslogOpsPercent + | CatRecoveryColOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'CatRecoveryColumn'. Used by +-- 'catRecoveryOptionsParams' (for the @h@ parameter) and by +-- 'catRecoverySortSpecText' (for the @s@ parameter). +catRecoveryColumnText :: CatRecoveryColumn -> Text +catRecoveryColumnText CatRecoveryColIndex = "index" +catRecoveryColumnText CatRecoveryColShard = "shard" +catRecoveryColumnText CatRecoveryColStartTime = "start_time" +catRecoveryColumnText CatRecoveryColStartTimeMillis = "start_time_millis" +catRecoveryColumnText CatRecoveryColStopTime = "stop_time" +catRecoveryColumnText CatRecoveryColStopTimeMillis = "stop_time_millis" +catRecoveryColumnText CatRecoveryColTime = "time" +catRecoveryColumnText CatRecoveryColType = "type" +catRecoveryColumnText CatRecoveryColStage = "stage" +catRecoveryColumnText CatRecoveryColSourceHost = "source_host" +catRecoveryColumnText CatRecoveryColSourceNode = "source_node" +catRecoveryColumnText CatRecoveryColTargetHost = "target_host" +catRecoveryColumnText CatRecoveryColTargetNode = "target_node" +catRecoveryColumnText CatRecoveryColRepository = "repository" +catRecoveryColumnText CatRecoveryColSnapshot = "snapshot" +catRecoveryColumnText CatRecoveryColFiles = "files" +catRecoveryColumnText CatRecoveryColFilesRecovered = "files_recovered" +catRecoveryColumnText CatRecoveryColFilesPercent = "files_percent" +catRecoveryColumnText CatRecoveryColFilesTotal = "files_total" +catRecoveryColumnText CatRecoveryColBytes = "bytes" +catRecoveryColumnText CatRecoveryColBytesRecovered = "bytes_recovered" +catRecoveryColumnText CatRecoveryColBytesPercent = "bytes_percent" +catRecoveryColumnText CatRecoveryColBytesTotal = "bytes_total" +catRecoveryColumnText CatRecoveryColTranslogOps = "translog_ops" +catRecoveryColumnText CatRecoveryColTranslogOpsRecovered = "translog_ops_recovered" +catRecoveryColumnText CatRecoveryColTranslogOpsPercent = "translog_ops_percent" +catRecoveryColumnText (CatRecoveryColOther t) = t + +-- | A single @\[:\]@ term in the @s@ URI parameter +-- of @_cat\/recovery@. Structurally identical to 'CatSortSpec' but +-- tied to 'CatRecoveryColumn' so the column spaces can evolve +-- independently. +data CatRecoverySortSpec = CatRecoverySortSpec + { catRecoverySortSpecColumn :: CatRecoveryColumn, + catRecoverySortSpecDirection :: Maybe CatSortDirection + } + deriving stock (Eq, Show) + +-- | Render a 'CatRecoverySortSpec' as @\@ or +-- @\:\@. +catRecoverySortSpecText :: CatRecoverySortSpec -> Text +catRecoverySortSpecText (CatRecoverySortSpec col mDir) = + case mDir of + Nothing -> catRecoveryColumnText col + Just dir -> catRecoveryColumnText col <> ":" <> catSortDirectionText dir + +-- | URI parameters accepted by @GET /_cat\/recovery@. Every +-- parameter documented by both +-- +-- and +-- +-- is exposed via a 'Maybe' field. Pass 'defaultCatRecoveryOptions' +-- to reproduce the no-parameter behaviour (besides @format=json@). +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'CatIndicesOptions', the renderer below emits @master_timeout@ for +-- every backend (OS still accepts it as a deprecated alias). +data CatRecoveryOptions = CatRecoveryOptions + { -- | Comma-separated list of columns to include in the response + -- (the @h@ parameter). The default column set is decided by the + -- server when this is 'Nothing'. + cryoColumns :: Maybe (NonEmpty CatRecoveryColumn), + -- | Show only active recoveries (the @active_only@ parameter). + cryoActiveOnly :: Maybe Bool, + -- | Byte-size unit used to render size columns (the @bytes@ + -- parameter). + cryoBytes :: Maybe CatBytesSize, + -- | Show detailed view (the @detailed@ parameter). + cryoDetailed :: Maybe Bool, + -- | Return the help table instead of data. Informational only. + cryoHelp :: Maybe Bool, + -- | Fetch cluster state from the connected node rather than the + -- elected master. + cryoLocal :: Maybe Bool, + -- | Master-node timeout. Rendered via 'timeUnitsSuffix' + -- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). + cryoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Comma-separated sort specifiers (the @s@ parameter). + cryoSort :: Maybe (NonEmpty CatRecoverySortSpec), + -- | Emit a header row. Only meaningful for the non-JSON text output + -- (always @false@ for @format=json@), kept here for parity with the + -- documented parameter surface. + cryoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'CatRecoveryOptions' with @bytes@ defaulted to 'CatBytesBytes' and +-- every other parameter set to 'Nothing'. The row parser for +-- 'CatRecoveryRow' types the byte columns as 'Int64' (raw byte +-- counts), so the request /must/ ask the server for raw bytes via +-- @bytes=b@; a humanised unit would surface as a parse failure. If you +-- need a different output unit, set 'cryoBytes' explicitly and be +-- aware that the typed byte columns will then fail to decode (use +-- 'cryrOther' to read the verbatim values in that case). +defaultCatRecoveryOptions :: CatRecoveryOptions +defaultCatRecoveryOptions = + CatRecoveryOptions + { cryoColumns = Nothing, + cryoActiveOnly = Nothing, + cryoBytes = Just CatBytesBytes, + cryoDetailed = Nothing, + cryoHelp = Nothing, + cryoLocal = Nothing, + cryoMasterTimeout = Nothing, + cryoSort = Nothing, + cryoVerbose = Nothing + } + +cryoColumnsLens :: Lens' CatRecoveryOptions (Maybe (NonEmpty CatRecoveryColumn)) +cryoColumnsLens = lens cryoColumns (\x y -> x {cryoColumns = y}) + +cryoActiveOnlyLens :: Lens' CatRecoveryOptions (Maybe Bool) +cryoActiveOnlyLens = lens cryoActiveOnly (\x y -> x {cryoActiveOnly = y}) + +cryoBytesLens :: Lens' CatRecoveryOptions (Maybe CatBytesSize) +cryoBytesLens = lens cryoBytes (\x y -> x {cryoBytes = y}) + +cryoDetailedLens :: Lens' CatRecoveryOptions (Maybe Bool) +cryoDetailedLens = lens cryoDetailed (\x y -> x {cryoDetailed = y}) + +cryoHelpLens :: Lens' CatRecoveryOptions (Maybe Bool) +cryoHelpLens = lens cryoHelp (\x y -> x {cryoHelp = y}) + +cryoLocalLens :: Lens' CatRecoveryOptions (Maybe Bool) +cryoLocalLens = lens cryoLocal (\x y -> x {cryoLocal = y}) + +cryoMasterTimeoutLens :: Lens' CatRecoveryOptions (Maybe (TimeUnits, Word32)) +cryoMasterTimeoutLens = lens cryoMasterTimeout (\x y -> x {cryoMasterTimeout = y}) + +cryoSortLens :: Lens' CatRecoveryOptions (Maybe (NonEmpty CatRecoverySortSpec)) +cryoSortLens = lens cryoSort (\x y -> x {cryoSort = y}) + +cryoVerboseLens :: Lens' CatRecoveryOptions (Maybe Bool) +cryoVerboseLens = lens cryoVerbose (\x y -> x {cryoVerbose = y}) + +-- | Render 'CatRecoveryOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCatRecoveryOptions' emits only the always-required +-- @format=json@ entry. +catRecoveryOptionsParams :: CatRecoveryOptions -> [(Text, Maybe Text)] +catRecoveryOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> cryoColumns opts, + ("active_only",) . Just . boolQP <$> cryoActiveOnly opts, + ("bytes",) . Just . catBytesSizeText <$> cryoBytes opts, + ("detailed",) . Just . boolQP <$> cryoDetailed opts, + ("help",) . Just . boolQP <$> cryoHelp opts, + ("local",) . Just . boolQP <$> cryoLocal opts, + ("master_timeout",) . Just . renderDuration <$> cryoMasterTimeout opts, + ("s",) . Just . renderSort <$> cryoSort opts, + ("v",) . Just . boolQP <$> cryoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catRecoveryColumnText . toList + renderSort = T.intercalate "," . map catRecoverySortSpecText . toList + +-- | Structured row of @GET /_cat\/recovery?format=json@. Every +-- default column documented by ES is typed; anything the server adds in +-- future (or that surfaces under non-default options) is preserved +-- verbatim in 'cryrOther'. +-- +-- All fields are 'Maybe' because the @h@ URI parameter lets the caller +-- request a strict subset of columns. +data CatRecoveryRow = CatRecoveryRow + { -- | @index@ — the index name. + cryrIndex :: Maybe Text, + -- | @shard@ — the shard number. + cryrShard :: Maybe Word32, + -- | @start_time@ — the recovery start time (formatted string). + cryrStartTime :: Maybe Text, + -- | @start_time_millis@ — the start time in epoch milliseconds. + cryrStartTimeMillis :: Maybe Int64, + -- | @stop_time@ — the recovery stop time (formatted string). + cryrStopTime :: Maybe Text, + -- | @stop_time_millis@ — the stop time in epoch milliseconds. + cryrStopTimeMillis :: Maybe Int64, + -- | @time@ — the recovery duration (e.g. @"10s"@). + cryrTime :: Maybe Text, + -- | @type@ — the recovery type (e.g. @"store"@, @"snapshot"@, @"peer"@). + cryrType :: Maybe Text, + -- | @stage@ — the recovery stage (e.g. @"DONE"@, @"INDEX"@). + cryrStage :: Maybe Text, + -- | @source_host@ — the source node host. + cryrSourceHost :: Maybe Text, + -- | @source_node@ — the source node name. + cryrSourceNode :: Maybe Text, + -- | @target_host@ — the target node host. + cryrTargetHost :: Maybe Text, + -- | @target_node@ — the target node name. + cryrTargetNode :: Maybe Text, + -- | @repository@ — the snapshot repository (if applicable). + cryrRepository :: Maybe Text, + -- | @snapshot@ — the snapshot name (if applicable). + cryrSnapshot :: Maybe Text, + -- | @files@ — number of files to recover. + cryrFiles :: Maybe Int64, + -- | @files_recovered@ — files recovered so far. + cryrFilesRecovered :: Maybe Int64, + -- | @files_percent@ — percentage of files recovered (e.g. @"50.0%"@). + cryrFilesPercent :: Maybe Text, + -- | @files_total@ — total files to recover. + cryrFilesTotal :: Maybe Int64, + -- | @bytes@ — bytes to recover. Normalised to a raw byte count: + -- ES 7 emits a bare integer, ES 8/9 emit a humanised size + -- (@\"0b\"@, @\"5.3kb\"@) which is decoded via 'parseCatSize' and + -- 'catSizeInBytes'. + cryrBytes :: Maybe Int64, + -- | @bytes_recovered@ — bytes recovered so far. Normalised to raw + -- bytes (see 'cryrBytes'). + cryrBytesRecovered :: Maybe Int64, + -- | @bytes_percent@ — percentage of bytes recovered. + cryrBytesPercent :: Maybe Text, + -- | @bytes_total@ — total bytes to recover. Normalised to raw + -- bytes (see 'cryrBytes'). + cryrBytesTotal :: Maybe Int64, + -- | @translog_ops@ — translog operations to recover. + cryrTranslogOps :: Maybe Int64, + -- | @translog_ops_recovered@ — translog operations recovered. + cryrTranslogOpsRecovered :: Maybe Int64, + -- | @translog_ops_percent@ — percentage of translog ops recovered. + cryrTranslogOpsPercent :: Maybe Text, + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'cirOther' / 'cserOther'. + cryrOther :: Value + } + deriving stock (Eq, Show) + +cryrIndexLens :: Lens' CatRecoveryRow (Maybe Text) +cryrIndexLens = lens cryrIndex (\x y -> x {cryrIndex = y}) + +cryrShardLens :: Lens' CatRecoveryRow (Maybe Word32) +cryrShardLens = lens cryrShard (\x y -> x {cryrShard = y}) + +cryrStartTimeLens :: Lens' CatRecoveryRow (Maybe Text) +cryrStartTimeLens = lens cryrStartTime (\x y -> x {cryrStartTime = y}) + +cryrStartTimeMillisLens :: Lens' CatRecoveryRow (Maybe Int64) +cryrStartTimeMillisLens = lens cryrStartTimeMillis (\x y -> x {cryrStartTimeMillis = y}) + +cryrStopTimeLens :: Lens' CatRecoveryRow (Maybe Text) +cryrStopTimeLens = lens cryrStopTime (\x y -> x {cryrStopTime = y}) + +cryrStopTimeMillisLens :: Lens' CatRecoveryRow (Maybe Int64) +cryrStopTimeMillisLens = lens cryrStopTimeMillis (\x y -> x {cryrStopTimeMillis = y}) + +cryrTimeLens :: Lens' CatRecoveryRow (Maybe Text) +cryrTimeLens = lens cryrTime (\x y -> x {cryrTime = y}) + +cryrTypeLens :: Lens' CatRecoveryRow (Maybe Text) +cryrTypeLens = lens cryrType (\x y -> x {cryrType = y}) + +cryrStageLens :: Lens' CatRecoveryRow (Maybe Text) +cryrStageLens = lens cryrStage (\x y -> x {cryrStage = y}) + +cryrSourceHostLens :: Lens' CatRecoveryRow (Maybe Text) +cryrSourceHostLens = lens cryrSourceHost (\x y -> x {cryrSourceHost = y}) + +cryrSourceNodeLens :: Lens' CatRecoveryRow (Maybe Text) +cryrSourceNodeLens = lens cryrSourceNode (\x y -> x {cryrSourceNode = y}) + +cryrTargetHostLens :: Lens' CatRecoveryRow (Maybe Text) +cryrTargetHostLens = lens cryrTargetHost (\x y -> x {cryrTargetHost = y}) + +cryrTargetNodeLens :: Lens' CatRecoveryRow (Maybe Text) +cryrTargetNodeLens = lens cryrTargetNode (\x y -> x {cryrTargetNode = y}) + +cryrRepositoryLens :: Lens' CatRecoveryRow (Maybe Text) +cryrRepositoryLens = lens cryrRepository (\x y -> x {cryrRepository = y}) + +cryrSnapshotLens :: Lens' CatRecoveryRow (Maybe Text) +cryrSnapshotLens = lens cryrSnapshot (\x y -> x {cryrSnapshot = y}) + +cryrFilesLens :: Lens' CatRecoveryRow (Maybe Int64) +cryrFilesLens = lens cryrFiles (\x y -> x {cryrFiles = y}) + +cryrFilesRecoveredLens :: Lens' CatRecoveryRow (Maybe Int64) +cryrFilesRecoveredLens = lens cryrFilesRecovered (\x y -> x {cryrFilesRecovered = y}) + +cryrFilesPercentLens :: Lens' CatRecoveryRow (Maybe Text) +cryrFilesPercentLens = lens cryrFilesPercent (\x y -> x {cryrFilesPercent = y}) + +cryrFilesTotalLens :: Lens' CatRecoveryRow (Maybe Int64) +cryrFilesTotalLens = lens cryrFilesTotal (\x y -> x {cryrFilesTotal = y}) + +cryrBytesLens :: Lens' CatRecoveryRow (Maybe Int64) +cryrBytesLens = lens cryrBytes (\x y -> x {cryrBytes = y}) + +cryrBytesRecoveredLens :: Lens' CatRecoveryRow (Maybe Int64) +cryrBytesRecoveredLens = lens cryrBytesRecovered (\x y -> x {cryrBytesRecovered = y}) + +cryrBytesPercentLens :: Lens' CatRecoveryRow (Maybe Text) +cryrBytesPercentLens = lens cryrBytesPercent (\x y -> x {cryrBytesPercent = y}) + +cryrBytesTotalLens :: Lens' CatRecoveryRow (Maybe Int64) +cryrBytesTotalLens = lens cryrBytesTotal (\x y -> x {cryrBytesTotal = y}) + +cryrTranslogOpsLens :: Lens' CatRecoveryRow (Maybe Int64) +cryrTranslogOpsLens = lens cryrTranslogOps (\x y -> x {cryrTranslogOps = y}) + +cryrTranslogOpsRecoveredLens :: Lens' CatRecoveryRow (Maybe Int64) +cryrTranslogOpsRecoveredLens = lens cryrTranslogOpsRecovered (\x y -> x {cryrTranslogOpsRecovered = y}) + +cryrTranslogOpsPercentLens :: Lens' CatRecoveryRow (Maybe Text) +cryrTranslogOpsPercentLens = lens cryrTranslogOpsPercent (\x y -> x {cryrTranslogOpsPercent = y}) + +cryrOtherLens :: Lens' CatRecoveryRow Value +cryrOtherLens = lens cryrOther (\x y -> x {cryrOther = y}) + +instance FromJSON CatRecoveryRow where + parseJSON = withObject "CatRecoveryRow" $ \o -> + CatRecoveryRow + <$> o .:? "index" + <*> (o .:? "shard" >>= traverse parseWord32) + <*> o .:? "start_time" + <*> (o .:? "start_time_millis" >>= traverse parseInt64) + <*> o .:? "stop_time" + <*> (o .:? "stop_time_millis" >>= traverse parseInt64) + <*> o .:? "time" + <*> o .:? "type" + <*> o .:? "stage" + <*> o .:? "source_host" + <*> o .:? "source_node" + <*> o .:? "target_host" + <*> o .:? "target_node" + <*> o .:? "repository" + <*> o .:? "snapshot" + <*> (o .:? "files" >>= traverse parseInt64) + <*> (o .:? "files_recovered" >>= traverse parseInt64) + <*> o .:? "files_percent" + <*> (o .:? "files_total" >>= traverse parseInt64) + <*> (o .:? "bytes" >>= traverse parseByteSize) + <*> (o .:? "bytes_recovered" >>= traverse parseByteSize) + <*> o .:? "bytes_percent" + <*> (o .:? "bytes_total" >>= traverse parseByteSize) + <*> (o .:? "translog_ops" >>= traverse parseInt64) + <*> (o .:? "translog_ops_recovered" >>= traverse parseInt64) + <*> o .:? "translog_ops_percent" + <*> pure (Object o) + where + parseWord32 = parseAsString "Word32" parseReadText + parseInt64 = parseAsString "Int64" parseReadText + -- @bytes@/@bytes_recovered@/@bytes_total@ are byte sizes. ES 7 + -- emits a bare integer (@"0"@), but ES 8/9 default to the + -- humanised form (@"0b"@, @"5.3kb"@). 'parseCatSize' plus + -- 'catSizeInBytes' tolerates both and normalises to a raw byte + -- count, matching the 'Maybe Int64' field type. + parseByteSize = parseAsString "byte-size" $ \t -> do + pair <- parseCatSize t + let Bytes n = catSizeInBytes pair + pure (fromIntegral n) + +-- ========================================================================= +-- @_cat\/component_templates@ +-- ========================================================================= +-- +-- The @_cat\/component_templates@ endpoint lists the component templates +-- known to the cluster. See +-- . +-- +-- Path: @GET /_cat/component_templates[\/{name}]@, where @name@ accepts +-- wildcards. The wire shape mirrors the rest of the cat family: with +-- @format=json@ every cell is a JSON string, and @version@ is emitted +-- either as the literal string @"null"@ or as a native JSON @null@ (both +-- decode to 'Nothing' or @'Just' "null"@ respectively). + +-- | A column accepted by the @h@ (header) URI parameter of +-- @_cat\/component_templates@. Every default column is enumerated; +-- anything else is captured verbatim by 'CatComponentTemplatesColOther'. +data CatComponentTemplatesColumn + = CatComponentTemplatesColName + | CatComponentTemplatesColVersion + | CatComponentTemplatesColAliasCount + | CatComponentTemplatesColMappingCount + | CatComponentTemplatesColSettingsCount + | CatComponentTemplatesColMetadataCount + | CatComponentTemplatesColIncludedIn + | CatComponentTemplatesColOther Text + deriving stock (Eq, Show) + +catComponentTemplatesColumnText :: CatComponentTemplatesColumn -> Text +catComponentTemplatesColumnText CatComponentTemplatesColName = "name" +catComponentTemplatesColumnText CatComponentTemplatesColVersion = "version" +catComponentTemplatesColumnText CatComponentTemplatesColAliasCount = "alias_count" +catComponentTemplatesColumnText CatComponentTemplatesColMappingCount = "mapping_count" +catComponentTemplatesColumnText CatComponentTemplatesColSettingsCount = "settings_count" +catComponentTemplatesColumnText CatComponentTemplatesColMetadataCount = "metadata_count" +catComponentTemplatesColumnText CatComponentTemplatesColIncludedIn = "included_in" +catComponentTemplatesColumnText (CatComponentTemplatesColOther t) = t + +-- | URI parameters accepted by @GET /_cat\/component_templates@. The +-- @s@ (sort) field is a list of raw sort tokens so a caller can request +-- descending order by embedding the suffix (e.g. @"name:desc"@). +data CatComponentTemplatesOptions = CatComponentTemplatesOptions + { cctoColumns :: Maybe (NonEmpty CatComponentTemplatesColumn), + cctoHelp :: Maybe Bool, + cctoSort :: Maybe (NonEmpty Text), + cctoLocal :: Maybe Bool, + cctoMasterTimeout :: Maybe (TimeUnits, Word32), + cctoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultCatComponentTemplatesOptions :: CatComponentTemplatesOptions +defaultCatComponentTemplatesOptions = + CatComponentTemplatesOptions + { cctoColumns = Nothing, + cctoHelp = Nothing, + cctoSort = Nothing, + cctoLocal = Nothing, + cctoMasterTimeout = Nothing, + cctoVerbose = Nothing + } + +cctoColumnsLens :: Lens' CatComponentTemplatesOptions (Maybe (NonEmpty CatComponentTemplatesColumn)) +cctoColumnsLens = lens cctoColumns (\x y -> x {cctoColumns = y}) + +cctoHelpLens :: Lens' CatComponentTemplatesOptions (Maybe Bool) +cctoHelpLens = lens cctoHelp (\x y -> x {cctoHelp = y}) + +cctoSortLens :: Lens' CatComponentTemplatesOptions (Maybe (NonEmpty Text)) +cctoSortLens = lens cctoSort (\x y -> x {cctoSort = y}) + +cctoLocalLens :: Lens' CatComponentTemplatesOptions (Maybe Bool) +cctoLocalLens = lens cctoLocal (\x y -> x {cctoLocal = y}) + +cctoMasterTimeoutLens :: Lens' CatComponentTemplatesOptions (Maybe (TimeUnits, Word32)) +cctoMasterTimeoutLens = lens cctoMasterTimeout (\x y -> x {cctoMasterTimeout = y}) + +cctoVerboseLens :: Lens' CatComponentTemplatesOptions (Maybe Bool) +cctoVerboseLens = lens cctoVerbose (\x y -> x {cctoVerbose = y}) + +catComponentTemplatesOptionsParams :: CatComponentTemplatesOptions -> [(Text, Maybe Text)] +catComponentTemplatesOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> cctoColumns opts, + ("help",) . Just . boolQP <$> cctoHelp opts, + ("s",) . Just . renderSort <$> cctoSort opts, + ("local",) . Just . boolQP <$> cctoLocal opts, + ("master_timeout",) . Just . renderDuration <$> cctoMasterTimeout opts, + ("v",) . Just . boolQP <$> cctoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catComponentTemplatesColumnText . toList + renderSort = T.intercalate "," . toList + +-- | The @version@ column is emitted either as the literal string @"null"@ +-- or as a native JSON @null@; the parser maps the latter to 'Nothing' and +-- keeps the former verbatim. +data CatComponentTemplatesRow = CatComponentTemplatesRow + { cctrName :: Maybe Text, + cctrVersion :: Maybe Text, + cctrAliasCount :: Maybe Int64, + cctrMappingCount :: Maybe Int64, + cctrSettingsCount :: Maybe Int64, + cctrMetadataCount :: Maybe Int64, + cctrIncludedIn :: Maybe Text, + cctrOther :: Value + } + deriving stock (Eq, Show) + +cctrNameLens :: Lens' CatComponentTemplatesRow (Maybe Text) +cctrNameLens = lens cctrName (\x y -> x {cctrName = y}) + +cctrVersionLens :: Lens' CatComponentTemplatesRow (Maybe Text) +cctrVersionLens = lens cctrVersion (\x y -> x {cctrVersion = y}) + +cctrAliasCountLens :: Lens' CatComponentTemplatesRow (Maybe Int64) +cctrAliasCountLens = lens cctrAliasCount (\x y -> x {cctrAliasCount = y}) + +cctrMappingCountLens :: Lens' CatComponentTemplatesRow (Maybe Int64) +cctrMappingCountLens = lens cctrMappingCount (\x y -> x {cctrMappingCount = y}) + +cctrSettingsCountLens :: Lens' CatComponentTemplatesRow (Maybe Int64) +cctrSettingsCountLens = lens cctrSettingsCount (\x y -> x {cctrSettingsCount = y}) + +cctrMetadataCountLens :: Lens' CatComponentTemplatesRow (Maybe Int64) +cctrMetadataCountLens = lens cctrMetadataCount (\x y -> x {cctrMetadataCount = y}) + +cctrIncludedInLens :: Lens' CatComponentTemplatesRow (Maybe Text) +cctrIncludedInLens = lens cctrIncludedIn (\x y -> x {cctrIncludedIn = y}) + +cctrOtherLens :: Lens' CatComponentTemplatesRow Value +cctrOtherLens = lens cctrOther (\x y -> x {cctrOther = y}) + +instance FromJSON CatComponentTemplatesRow where + parseJSON = withObject "CatComponentTemplatesRow" $ \o -> + CatComponentTemplatesRow + <$> o .:? "name" + <*> o .:? "version" + <*> (o .:? "alias_count" >>= traverse parseInt64) + <*> (o .:? "mapping_count" >>= traverse parseInt64) + <*> (o .:? "settings_count" >>= traverse parseInt64) + <*> (o .:? "metadata_count" >>= traverse parseInt64) + <*> o .:? "included_in" + <*> pure (Object o) + where + parseInt64 = parseAsString "Int64" parseReadText + +-- ========================================================================= +-- @_cat\/circuit_breaker@ +-- ========================================================================= +-- +-- The @_cat\/circuit_breaker@ endpoint lists the JVM circuit breakers +-- registered on each node. See +-- . +-- +-- Path: @GET /_cat/circuit_breaker[\/{patterns}]@, where @patterns@ is a +-- comma-separated list of regular expressions filtering the breaker +-- names. The @limit@\/@estimated@ columns are humanised sizes +-- (e.g. @"614.3mb"@); the matching @_bytes@ columns carry the raw byte +-- count as a string-encoded integer (or, defensively, a native number). + +data CatCircuitBreakersColumn + = CatCircuitBreakersColNodeId + | CatCircuitBreakersColNodeName + | CatCircuitBreakersColBreaker + | CatCircuitBreakersColLimit + | CatCircuitBreakersColLimitBytes + | CatCircuitBreakersColEstimated + | CatCircuitBreakersColEstimatedBytes + | CatCircuitBreakersColTripped + | CatCircuitBreakersColOverhead + | CatCircuitBreakersColOther Text + deriving stock (Eq, Show) + +catCircuitBreakersColumnText :: CatCircuitBreakersColumn -> Text +catCircuitBreakersColumnText CatCircuitBreakersColNodeId = "node_id" +catCircuitBreakersColumnText CatCircuitBreakersColNodeName = "node_name" +catCircuitBreakersColumnText CatCircuitBreakersColBreaker = "breaker" +catCircuitBreakersColumnText CatCircuitBreakersColLimit = "limit" +catCircuitBreakersColumnText CatCircuitBreakersColLimitBytes = "limit_bytes" +catCircuitBreakersColumnText CatCircuitBreakersColEstimated = "estimated" +catCircuitBreakersColumnText CatCircuitBreakersColEstimatedBytes = "estimated_bytes" +catCircuitBreakersColumnText CatCircuitBreakersColTripped = "tripped" +catCircuitBreakersColumnText CatCircuitBreakersColOverhead = "overhead" +catCircuitBreakersColumnText (CatCircuitBreakersColOther t) = t + +data CatCircuitBreakersOptions = CatCircuitBreakersOptions + { ccboColumns :: Maybe (NonEmpty CatCircuitBreakersColumn), + ccboHelp :: Maybe Bool, + ccboSort :: Maybe (NonEmpty Text), + ccboLocal :: Maybe Bool, + ccboMasterTimeout :: Maybe (TimeUnits, Word32), + ccboVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultCatCircuitBreakersOptions :: CatCircuitBreakersOptions +defaultCatCircuitBreakersOptions = + CatCircuitBreakersOptions + { ccboColumns = Nothing, + ccboHelp = Nothing, + ccboSort = Nothing, + ccboLocal = Nothing, + ccboMasterTimeout = Nothing, + ccboVerbose = Nothing + } + +ccboColumnsLens :: Lens' CatCircuitBreakersOptions (Maybe (NonEmpty CatCircuitBreakersColumn)) +ccboColumnsLens = lens ccboColumns (\x y -> x {ccboColumns = y}) + +ccboHelpLens :: Lens' CatCircuitBreakersOptions (Maybe Bool) +ccboHelpLens = lens ccboHelp (\x y -> x {ccboHelp = y}) + +ccboSortLens :: Lens' CatCircuitBreakersOptions (Maybe (NonEmpty Text)) +ccboSortLens = lens ccboSort (\x y -> x {ccboSort = y}) + +ccboLocalLens :: Lens' CatCircuitBreakersOptions (Maybe Bool) +ccboLocalLens = lens ccboLocal (\x y -> x {ccboLocal = y}) + +ccboMasterTimeoutLens :: Lens' CatCircuitBreakersOptions (Maybe (TimeUnits, Word32)) +ccboMasterTimeoutLens = lens ccboMasterTimeout (\x y -> x {ccboMasterTimeout = y}) + +ccboVerboseLens :: Lens' CatCircuitBreakersOptions (Maybe Bool) +ccboVerboseLens = lens ccboVerbose (\x y -> x {ccboVerbose = y}) + +catCircuitBreakersOptionsParams :: CatCircuitBreakersOptions -> [(Text, Maybe Text)] +catCircuitBreakersOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("h",) . Just . renderColumns <$> ccboColumns opts, + ("help",) . Just . boolQP <$> ccboHelp opts, + ("s",) . Just . renderSort <$> ccboSort opts, + ("local",) . Just . boolQP <$> ccboLocal opts, + ("master_timeout",) . Just . renderDuration <$> ccboMasterTimeout opts, + ("v",) . Just . boolQP <$> ccboVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderColumns = T.intercalate "," . map catCircuitBreakersColumnText . toList + renderSort = T.intercalate "," . toList + +data CatCircuitBreakersRow = CatCircuitBreakersRow + { ccbrNodeId :: Maybe Text, + ccbrNodeName :: Maybe Text, + ccbrBreaker :: Maybe Text, + ccbrLimit :: Maybe Text, + ccbrLimitBytes :: Maybe Int64, + ccbrEstimated :: Maybe Text, + ccbrEstimatedBytes :: Maybe Int64, + ccbrTripped :: Maybe Int64, + ccbrOverhead :: Maybe Text, + ccbrOther :: Value + } + deriving stock (Eq, Show) + +ccbrNodeIdLens :: Lens' CatCircuitBreakersRow (Maybe Text) +ccbrNodeIdLens = lens ccbrNodeId (\x y -> x {ccbrNodeId = y}) + +ccbrNodeNameLens :: Lens' CatCircuitBreakersRow (Maybe Text) +ccbrNodeNameLens = lens ccbrNodeName (\x y -> x {ccbrNodeName = y}) + +ccbrBreakerLens :: Lens' CatCircuitBreakersRow (Maybe Text) +ccbrBreakerLens = lens ccbrBreaker (\x y -> x {ccbrBreaker = y}) + +ccbrLimitLens :: Lens' CatCircuitBreakersRow (Maybe Text) +ccbrLimitLens = lens ccbrLimit (\x y -> x {ccbrLimit = y}) + +ccbrLimitBytesLens :: Lens' CatCircuitBreakersRow (Maybe Int64) +ccbrLimitBytesLens = lens ccbrLimitBytes (\x y -> x {ccbrLimitBytes = y}) + +ccbrEstimatedLens :: Lens' CatCircuitBreakersRow (Maybe Text) +ccbrEstimatedLens = lens ccbrEstimated (\x y -> x {ccbrEstimated = y}) + +ccbrEstimatedBytesLens :: Lens' CatCircuitBreakersRow (Maybe Int64) +ccbrEstimatedBytesLens = lens ccbrEstimatedBytes (\x y -> x {ccbrEstimatedBytes = y}) + +ccbrTrippedLens :: Lens' CatCircuitBreakersRow (Maybe Int64) +ccbrTrippedLens = lens ccbrTripped (\x y -> x {ccbrTripped = y}) + +ccbrOverheadLens :: Lens' CatCircuitBreakersRow (Maybe Text) +ccbrOverheadLens = lens ccbrOverhead (\x y -> x {ccbrOverhead = y}) + +ccbrOtherLens :: Lens' CatCircuitBreakersRow Value +ccbrOtherLens = lens ccbrOther (\x y -> x {ccbrOther = y}) + +instance FromJSON CatCircuitBreakersRow where + parseJSON = withObject "CatCircuitBreakersRow" $ \o -> + CatCircuitBreakersRow + <$> o .:? "node_id" + <*> o .:? "node_name" + <*> o .:? "breaker" + <*> o .:? "limit" + <*> (o .:? "limit_bytes" >>= traverse parseInt64) + <*> o .:? "estimated" + <*> (o .:? "estimated_bytes" >>= traverse parseInt64) + <*> (o .:? "tripped" >>= traverse parseInt64) + <*> o .:? "overhead" + <*> pure (Object o) + where + parseInt64 = parseAsString "Int64" parseReadText + +-- ========================================================================= +-- @_cat\/ml\/anomaly_detectors@ +-- ========================================================================= +-- +-- The @_cat\/ml\/anomaly_detectors@ endpoint lists the machine-learning +-- anomaly-detection jobs. See +-- . +-- +-- Path: @GET /_cat/ml/anomaly_detectors[\/{job_id}]@. The full column +-- surface is very large (60+ columns); the row below types the +-- commonly-used subset and preserves anything else verbatim in +-- 'cmjrOther'. Use the 'CatMlJobsColOther' escape hatch to request +-- additional columns via the @h@ parameter. + +data CatMlJobsColumn + = CatMlJobsColId + | CatMlJobsColState + | CatMlJobsColAssignmentExplanation + | CatMlJobsColFailureReason + | CatMlJobsColOpenedTime + | CatMlJobsColDataProcessedRecords + | CatMlJobsColDataInputBytes + | CatMlJobsColModelBytes + | CatMlJobsColModelMemoryStatus + | CatMlJobsColModelMemoryLimit + | CatMlJobsColBucketsCount + | CatMlJobsColNodeId + | CatMlJobsColNodeName + | CatMlJobsColNodeEphemeralId + | CatMlJobsColNodeAddress + | CatMlJobsColOther Text + deriving stock (Eq, Show) + +catMlJobsColumnText :: CatMlJobsColumn -> Text +catMlJobsColumnText CatMlJobsColId = "id" +catMlJobsColumnText CatMlJobsColState = "state" +catMlJobsColumnText CatMlJobsColAssignmentExplanation = "assignment_explanation" +catMlJobsColumnText CatMlJobsColFailureReason = "failure_reason" +catMlJobsColumnText CatMlJobsColOpenedTime = "opened_time" +catMlJobsColumnText CatMlJobsColDataProcessedRecords = "data.processed_records" +catMlJobsColumnText CatMlJobsColDataInputBytes = "data.input_bytes" +catMlJobsColumnText CatMlJobsColModelBytes = "model.bytes" +catMlJobsColumnText CatMlJobsColModelMemoryStatus = "model.memory_status" +catMlJobsColumnText CatMlJobsColModelMemoryLimit = "model.memory_limit" +catMlJobsColumnText CatMlJobsColBucketsCount = "buckets.count" +catMlJobsColumnText CatMlJobsColNodeId = "node.id" +catMlJobsColumnText CatMlJobsColNodeName = "node.name" +catMlJobsColumnText CatMlJobsColNodeEphemeralId = "node.ephemeral_id" +catMlJobsColumnText CatMlJobsColNodeAddress = "node.address" +catMlJobsColumnText (CatMlJobsColOther t) = t + +-- | URI parameters accepted by @GET /_cat\/ml\/anomaly_detectors@. The +-- ML cat endpoints do not accept @local@\/@master_timeout@. +data CatMlJobsOptions = CatMlJobsOptions + { cmjoAllowNoMatch :: Maybe Bool, + cmjoColumns :: Maybe (NonEmpty CatMlJobsColumn), + cmjoHelp :: Maybe Bool, + cmjoSort :: Maybe (NonEmpty Text), + cmjoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultCatMlJobsOptions :: CatMlJobsOptions +defaultCatMlJobsOptions = + CatMlJobsOptions + { cmjoAllowNoMatch = Nothing, + cmjoColumns = Nothing, + cmjoHelp = Nothing, + cmjoSort = Nothing, + cmjoVerbose = Nothing + } + +cmjoAllowNoMatchLens :: Lens' CatMlJobsOptions (Maybe Bool) +cmjoAllowNoMatchLens = lens cmjoAllowNoMatch (\x y -> x {cmjoAllowNoMatch = y}) + +cmjoColumnsLens :: Lens' CatMlJobsOptions (Maybe (NonEmpty CatMlJobsColumn)) +cmjoColumnsLens = lens cmjoColumns (\x y -> x {cmjoColumns = y}) + +cmjoHelpLens :: Lens' CatMlJobsOptions (Maybe Bool) +cmjoHelpLens = lens cmjoHelp (\x y -> x {cmjoHelp = y}) + +cmjoSortLens :: Lens' CatMlJobsOptions (Maybe (NonEmpty Text)) +cmjoSortLens = lens cmjoSort (\x y -> x {cmjoSort = y}) + +cmjoVerboseLens :: Lens' CatMlJobsOptions (Maybe Bool) +cmjoVerboseLens = lens cmjoVerbose (\x y -> x {cmjoVerbose = y}) + +catMlJobsOptionsParams :: CatMlJobsOptions -> [(Text, Maybe Text)] +catMlJobsOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("allow_no_match",) . Just . boolQP <$> cmjoAllowNoMatch opts, + ("h",) . Just . renderColumns <$> cmjoColumns opts, + ("help",) . Just . boolQP <$> cmjoHelp opts, + ("s",) . Just . renderSort <$> cmjoSort opts, + ("v",) . Just . boolQP <$> cmjoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderColumns = T.intercalate "," . map catMlJobsColumnText . toList + renderSort = T.intercalate "," . toList + +data CatMlJobsRow = CatMlJobsRow + { cmjrId :: Maybe Text, + cmjrState :: Maybe Text, + cmjrAssignmentExplanation :: Maybe Text, + cmjrFailureReason :: Maybe Text, + cmjrOpenedTime :: Maybe Text, + cmjrDataProcessedRecords :: Maybe Int64, + cmjrDataInputBytes :: Maybe Int64, + cmjrModelBytes :: Maybe Int64, + cmjrModelMemoryStatus :: Maybe Text, + cmjrModelMemoryLimit :: Maybe Text, + cmjrBucketsCount :: Maybe Int64, + cmjrNodeId :: Maybe Text, + cmjrNodeName :: Maybe Text, + cmjrNodeEphemeralId :: Maybe Text, + cmjrNodeAddress :: Maybe Text, + cmjrOther :: Value + } + deriving stock (Eq, Show) + +cmjrIdLens :: Lens' CatMlJobsRow (Maybe Text) +cmjrIdLens = lens cmjrId (\x y -> x {cmjrId = y}) + +cmjrStateLens :: Lens' CatMlJobsRow (Maybe Text) +cmjrStateLens = lens cmjrState (\x y -> x {cmjrState = y}) + +cmjrAssignmentExplanationLens :: Lens' CatMlJobsRow (Maybe Text) +cmjrAssignmentExplanationLens = lens cmjrAssignmentExplanation (\x y -> x {cmjrAssignmentExplanation = y}) + +cmjrFailureReasonLens :: Lens' CatMlJobsRow (Maybe Text) +cmjrFailureReasonLens = lens cmjrFailureReason (\x y -> x {cmjrFailureReason = y}) + +cmjrOpenedTimeLens :: Lens' CatMlJobsRow (Maybe Text) +cmjrOpenedTimeLens = lens cmjrOpenedTime (\x y -> x {cmjrOpenedTime = y}) + +cmjrDataProcessedRecordsLens :: Lens' CatMlJobsRow (Maybe Int64) +cmjrDataProcessedRecordsLens = lens cmjrDataProcessedRecords (\x y -> x {cmjrDataProcessedRecords = y}) + +cmjrDataInputBytesLens :: Lens' CatMlJobsRow (Maybe Int64) +cmjrDataInputBytesLens = lens cmjrDataInputBytes (\x y -> x {cmjrDataInputBytes = y}) + +cmjrModelBytesLens :: Lens' CatMlJobsRow (Maybe Int64) +cmjrModelBytesLens = lens cmjrModelBytes (\x y -> x {cmjrModelBytes = y}) + +cmjrModelMemoryStatusLens :: Lens' CatMlJobsRow (Maybe Text) +cmjrModelMemoryStatusLens = lens cmjrModelMemoryStatus (\x y -> x {cmjrModelMemoryStatus = y}) + +cmjrModelMemoryLimitLens :: Lens' CatMlJobsRow (Maybe Text) +cmjrModelMemoryLimitLens = lens cmjrModelMemoryLimit (\x y -> x {cmjrModelMemoryLimit = y}) + +cmjrBucketsCountLens :: Lens' CatMlJobsRow (Maybe Int64) +cmjrBucketsCountLens = lens cmjrBucketsCount (\x y -> x {cmjrBucketsCount = y}) + +cmjrNodeIdLens :: Lens' CatMlJobsRow (Maybe Text) +cmjrNodeIdLens = lens cmjrNodeId (\x y -> x {cmjrNodeId = y}) + +cmjrNodeNameLens :: Lens' CatMlJobsRow (Maybe Text) +cmjrNodeNameLens = lens cmjrNodeName (\x y -> x {cmjrNodeName = y}) + +cmjrNodeEphemeralIdLens :: Lens' CatMlJobsRow (Maybe Text) +cmjrNodeEphemeralIdLens = lens cmjrNodeEphemeralId (\x y -> x {cmjrNodeEphemeralId = y}) + +cmjrNodeAddressLens :: Lens' CatMlJobsRow (Maybe Text) +cmjrNodeAddressLens = lens cmjrNodeAddress (\x y -> x {cmjrNodeAddress = y}) + +cmjrOtherLens :: Lens' CatMlJobsRow Value +cmjrOtherLens = lens cmjrOther (\x y -> x {cmjrOther = y}) + +instance FromJSON CatMlJobsRow where + parseJSON = withObject "CatMlJobsRow" $ \o -> + CatMlJobsRow + <$> o .:? "id" + <*> o .:? "state" + <*> o .:? "assignment_explanation" + <*> o .:? "failure_reason" + <*> o .:? "opened_time" + <*> (o .:? "data.processed_records" >>= traverse parseInt64) + <*> (o .:? "data.input_bytes" >>= traverse parseInt64) + <*> (o .:? "model.bytes" >>= traverse parseInt64) + <*> o .:? "model.memory_status" + <*> o .:? "model.memory_limit" + <*> (o .:? "buckets.count" >>= traverse parseInt64) + <*> o .:? "node.id" + <*> o .:? "node.name" + <*> o .:? "node.ephemeral_id" + <*> o .:? "node.address" + <*> pure (Object o) + where + parseInt64 = parseAsString "Int64" parseReadText + +-- ========================================================================= +-- @_cat\/ml\/data_frame\/analytics@ +-- ========================================================================= +-- +-- The @_cat\/ml\/data_frame\/analytics@ endpoint lists the machine-learning +-- data frame analytics jobs. See +-- . +-- +-- Path: @GET /_cat/ml/data_frame/analytics[\/{id}]@. Note the slash in +-- @data_frame\/analytics@ — distinct from the bead's shorthand label. + +data CatMlDataFrameAnalyticsColumn + = CatMlDataFrameAnalyticsColId + | CatMlDataFrameAnalyticsColType + | CatMlDataFrameAnalyticsColCreateTime + | CatMlDataFrameAnalyticsColVersion + | CatMlDataFrameAnalyticsColSourceIndex + | CatMlDataFrameAnalyticsColDestIndex + | CatMlDataFrameAnalyticsColDescription + | CatMlDataFrameAnalyticsColModelMemoryLimit + | CatMlDataFrameAnalyticsColState + | CatMlDataFrameAnalyticsColFailureReason + | CatMlDataFrameAnalyticsColProgress + | CatMlDataFrameAnalyticsColAssignmentExplanation + | CatMlDataFrameAnalyticsColNodeId + | CatMlDataFrameAnalyticsColNodeName + | CatMlDataFrameAnalyticsColNodeEphemeralId + | CatMlDataFrameAnalyticsColNodeAddress + | CatMlDataFrameAnalyticsColOther Text + deriving stock (Eq, Show) + +catMlDataFrameAnalyticsColumnText :: CatMlDataFrameAnalyticsColumn -> Text +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColId = "id" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColType = "type" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColCreateTime = "create_time" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColVersion = "version" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColSourceIndex = "source_index" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColDestIndex = "dest_index" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColDescription = "description" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColModelMemoryLimit = "model_memory_limit" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColState = "state" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColFailureReason = "failure_reason" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColProgress = "progress" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColAssignmentExplanation = "assignment_explanation" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColNodeId = "node.id" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColNodeName = "node.name" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColNodeEphemeralId = "node.ephemeral_id" +catMlDataFrameAnalyticsColumnText CatMlDataFrameAnalyticsColNodeAddress = "node.address" +catMlDataFrameAnalyticsColumnText (CatMlDataFrameAnalyticsColOther t) = t + +data CatMlDataFrameAnalyticsOptions = CatMlDataFrameAnalyticsOptions + { cmfaoAllowNoMatch :: Maybe Bool, + cmfaoColumns :: Maybe (NonEmpty CatMlDataFrameAnalyticsColumn), + cmfaoHelp :: Maybe Bool, + cmfaoSort :: Maybe (NonEmpty Text), + cmfaoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultCatMlDataFrameAnalyticsOptions :: CatMlDataFrameAnalyticsOptions +defaultCatMlDataFrameAnalyticsOptions = + CatMlDataFrameAnalyticsOptions + { cmfaoAllowNoMatch = Nothing, + cmfaoColumns = Nothing, + cmfaoHelp = Nothing, + cmfaoSort = Nothing, + cmfaoVerbose = Nothing + } + +cmfaoAllowNoMatchLens :: Lens' CatMlDataFrameAnalyticsOptions (Maybe Bool) +cmfaoAllowNoMatchLens = lens cmfaoAllowNoMatch (\x y -> x {cmfaoAllowNoMatch = y}) + +cmfaoColumnsLens :: Lens' CatMlDataFrameAnalyticsOptions (Maybe (NonEmpty CatMlDataFrameAnalyticsColumn)) +cmfaoColumnsLens = lens cmfaoColumns (\x y -> x {cmfaoColumns = y}) + +cmfaoHelpLens :: Lens' CatMlDataFrameAnalyticsOptions (Maybe Bool) +cmfaoHelpLens = lens cmfaoHelp (\x y -> x {cmfaoHelp = y}) + +cmfaoSortLens :: Lens' CatMlDataFrameAnalyticsOptions (Maybe (NonEmpty Text)) +cmfaoSortLens = lens cmfaoSort (\x y -> x {cmfaoSort = y}) + +cmfaoVerboseLens :: Lens' CatMlDataFrameAnalyticsOptions (Maybe Bool) +cmfaoVerboseLens = lens cmfaoVerbose (\x y -> x {cmfaoVerbose = y}) + +catMlDataFrameAnalyticsOptionsParams :: CatMlDataFrameAnalyticsOptions -> [(Text, Maybe Text)] +catMlDataFrameAnalyticsOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("allow_no_match",) . Just . boolQP <$> cmfaoAllowNoMatch opts, + ("h",) . Just . renderColumns <$> cmfaoColumns opts, + ("help",) . Just . boolQP <$> cmfaoHelp opts, + ("s",) . Just . renderSort <$> cmfaoSort opts, + ("v",) . Just . boolQP <$> cmfaoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderColumns = T.intercalate "," . map catMlDataFrameAnalyticsColumnText . toList + renderSort = T.intercalate "," . toList + +data CatMlDataFrameAnalyticsRow = CatMlDataFrameAnalyticsRow + { cmfaId :: Maybe Text, + cmfaType :: Maybe Text, + cmfaCreateTime :: Maybe Text, + cmfaVersion :: Maybe Text, + cmfaSourceIndex :: Maybe Text, + cmfaDestIndex :: Maybe Text, + cmfaDescription :: Maybe Text, + cmfaModelMemoryLimit :: Maybe Text, + cmfaState :: Maybe Text, + cmfaFailureReason :: Maybe Text, + cmfaProgress :: Maybe Text, + cmfaAssignmentExplanation :: Maybe Text, + cmfaNodeId :: Maybe Text, + cmfaNodeName :: Maybe Text, + cmfaNodeEphemeralId :: Maybe Text, + cmfaNodeAddress :: Maybe Text, + cmfaOther :: Value + } + deriving stock (Eq, Show) + +cmfaIdLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaIdLens = lens cmfaId (\x y -> x {cmfaId = y}) + +cmfaTypeLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaTypeLens = lens cmfaType (\x y -> x {cmfaType = y}) + +cmfaCreateTimeLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaCreateTimeLens = lens cmfaCreateTime (\x y -> x {cmfaCreateTime = y}) + +cmfaVersionLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaVersionLens = lens cmfaVersion (\x y -> x {cmfaVersion = y}) + +cmfaSourceIndexLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaSourceIndexLens = lens cmfaSourceIndex (\x y -> x {cmfaSourceIndex = y}) + +cmfaDestIndexLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaDestIndexLens = lens cmfaDestIndex (\x y -> x {cmfaDestIndex = y}) + +cmfaDescriptionLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaDescriptionLens = lens cmfaDescription (\x y -> x {cmfaDescription = y}) + +cmfaModelMemoryLimitLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaModelMemoryLimitLens = lens cmfaModelMemoryLimit (\x y -> x {cmfaModelMemoryLimit = y}) + +cmfaStateLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaStateLens = lens cmfaState (\x y -> x {cmfaState = y}) + +cmfaFailureReasonLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaFailureReasonLens = lens cmfaFailureReason (\x y -> x {cmfaFailureReason = y}) + +cmfaProgressLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaProgressLens = lens cmfaProgress (\x y -> x {cmfaProgress = y}) + +cmfaAssignmentExplanationLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaAssignmentExplanationLens = lens cmfaAssignmentExplanation (\x y -> x {cmfaAssignmentExplanation = y}) + +cmfaNodeIdLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaNodeIdLens = lens cmfaNodeId (\x y -> x {cmfaNodeId = y}) + +cmfaNodeNameLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaNodeNameLens = lens cmfaNodeName (\x y -> x {cmfaNodeName = y}) + +cmfaNodeEphemeralIdLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaNodeEphemeralIdLens = lens cmfaNodeEphemeralId (\x y -> x {cmfaNodeEphemeralId = y}) + +cmfaNodeAddressLens :: Lens' CatMlDataFrameAnalyticsRow (Maybe Text) +cmfaNodeAddressLens = lens cmfaNodeAddress (\x y -> x {cmfaNodeAddress = y}) + +cmfaOtherLens :: Lens' CatMlDataFrameAnalyticsRow Value +cmfaOtherLens = lens cmfaOther (\x y -> x {cmfaOther = y}) + +instance FromJSON CatMlDataFrameAnalyticsRow where + parseJSON = withObject "CatMlDataFrameAnalyticsRow" $ \o -> + CatMlDataFrameAnalyticsRow + <$> o .:? "id" + <*> o .:? "type" + <*> o .:? "create_time" + <*> o .:? "version" + <*> o .:? "source_index" + <*> o .:? "dest_index" + <*> o .:? "description" + <*> o .:? "model_memory_limit" + <*> o .:? "state" + <*> o .:? "failure_reason" + <*> o .:? "progress" + <*> o .:? "assignment_explanation" + <*> o .:? "node.id" + <*> o .:? "node.name" + <*> o .:? "node.ephemeral_id" + <*> o .:? "node.address" + <*> pure (Object o) + +-- ========================================================================= +-- @_cat\/ml\/datafeeds@ +-- ========================================================================= +-- +-- The @_cat\/ml\/datafeeds@ endpoint lists the machine-learning datafeeds. +-- See +-- . +-- +-- Path: @GET /_cat/ml/datafeeds[\/{datafeed_id}]@. Several columns carry +-- dotted JSON keys (@buckets.count@, @search.count@, @search.time@, +-- @search.bucket_avg@, @search.exp_avg_hour@). + +data CatMlDatafeedsColumn + = CatMlDatafeedsColId + | CatMlDatafeedsColState + | CatMlDatafeedsColAssignmentExplanation + | CatMlDatafeedsColBucketsCount + | CatMlDatafeedsColSearchCount + | CatMlDatafeedsColSearchTime + | CatMlDatafeedsColSearchBucketAvg + | CatMlDatafeedsColSearchExpAvgHour + | CatMlDatafeedsColNodeId + | CatMlDatafeedsColNodeName + | CatMlDatafeedsColNodeEphemeralId + | CatMlDatafeedsColNodeAddress + | CatMlDatafeedsColOther Text + deriving stock (Eq, Show) + +catMlDatafeedsColumnText :: CatMlDatafeedsColumn -> Text +catMlDatafeedsColumnText CatMlDatafeedsColId = "id" +catMlDatafeedsColumnText CatMlDatafeedsColState = "state" +catMlDatafeedsColumnText CatMlDatafeedsColAssignmentExplanation = "assignment_explanation" +catMlDatafeedsColumnText CatMlDatafeedsColBucketsCount = "buckets.count" +catMlDatafeedsColumnText CatMlDatafeedsColSearchCount = "search.count" +catMlDatafeedsColumnText CatMlDatafeedsColSearchTime = "search.time" +catMlDatafeedsColumnText CatMlDatafeedsColSearchBucketAvg = "search.bucket_avg" +catMlDatafeedsColumnText CatMlDatafeedsColSearchExpAvgHour = "search.exp_avg_hour" +catMlDatafeedsColumnText CatMlDatafeedsColNodeId = "node.id" +catMlDatafeedsColumnText CatMlDatafeedsColNodeName = "node.name" +catMlDatafeedsColumnText CatMlDatafeedsColNodeEphemeralId = "node.ephemeral_id" +catMlDatafeedsColumnText CatMlDatafeedsColNodeAddress = "node.address" +catMlDatafeedsColumnText (CatMlDatafeedsColOther t) = t + +data CatMlDatafeedsOptions = CatMlDatafeedsOptions + { cmdfoAllowNoMatch :: Maybe Bool, + cmdfoColumns :: Maybe (NonEmpty CatMlDatafeedsColumn), + cmdfoHelp :: Maybe Bool, + cmdfoSort :: Maybe (NonEmpty Text), + cmdfoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultCatMlDatafeedsOptions :: CatMlDatafeedsOptions +defaultCatMlDatafeedsOptions = + CatMlDatafeedsOptions + { cmdfoAllowNoMatch = Nothing, + cmdfoColumns = Nothing, + cmdfoHelp = Nothing, + cmdfoSort = Nothing, + cmdfoVerbose = Nothing + } + +cmdfoAllowNoMatchLens :: Lens' CatMlDatafeedsOptions (Maybe Bool) +cmdfoAllowNoMatchLens = lens cmdfoAllowNoMatch (\x y -> x {cmdfoAllowNoMatch = y}) + +cmdfoColumnsLens :: Lens' CatMlDatafeedsOptions (Maybe (NonEmpty CatMlDatafeedsColumn)) +cmdfoColumnsLens = lens cmdfoColumns (\x y -> x {cmdfoColumns = y}) + +cmdfoHelpLens :: Lens' CatMlDatafeedsOptions (Maybe Bool) +cmdfoHelpLens = lens cmdfoHelp (\x y -> x {cmdfoHelp = y}) + +cmdfoSortLens :: Lens' CatMlDatafeedsOptions (Maybe (NonEmpty Text)) +cmdfoSortLens = lens cmdfoSort (\x y -> x {cmdfoSort = y}) + +cmdfoVerboseLens :: Lens' CatMlDatafeedsOptions (Maybe Bool) +cmdfoVerboseLens = lens cmdfoVerbose (\x y -> x {cmdfoVerbose = y}) + +catMlDatafeedsOptionsParams :: CatMlDatafeedsOptions -> [(Text, Maybe Text)] +catMlDatafeedsOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("allow_no_match",) . Just . boolQP <$> cmdfoAllowNoMatch opts, + ("h",) . Just . renderColumns <$> cmdfoColumns opts, + ("help",) . Just . boolQP <$> cmdfoHelp opts, + ("s",) . Just . renderSort <$> cmdfoSort opts, + ("v",) . Just . boolQP <$> cmdfoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderColumns = T.intercalate "," . map catMlDatafeedsColumnText . toList + renderSort = T.intercalate "," . toList + +data CatMlDatafeedsRow = CatMlDatafeedsRow + { cmdfId :: Maybe Text, + cmdfState :: Maybe Text, + cmdfAssignmentExplanation :: Maybe Text, + cmdfBucketsCount :: Maybe Int64, + cmdfSearchCount :: Maybe Int64, + cmdfSearchTime :: Maybe Text, + cmdfSearchBucketAvg :: Maybe Text, + cmdfSearchExpAvgHour :: Maybe Text, + cmdfNodeId :: Maybe Text, + cmdfNodeName :: Maybe Text, + cmdfNodeEphemeralId :: Maybe Text, + cmdfNodeAddress :: Maybe Text, + cmdfOther :: Value + } + deriving stock (Eq, Show) + +cmdfIdLens :: Lens' CatMlDatafeedsRow (Maybe Text) +cmdfIdLens = lens cmdfId (\x y -> x {cmdfId = y}) + +cmdfStateLens :: Lens' CatMlDatafeedsRow (Maybe Text) +cmdfStateLens = lens cmdfState (\x y -> x {cmdfState = y}) + +cmdfAssignmentExplanationLens :: Lens' CatMlDatafeedsRow (Maybe Text) +cmdfAssignmentExplanationLens = lens cmdfAssignmentExplanation (\x y -> x {cmdfAssignmentExplanation = y}) + +cmdfBucketsCountLens :: Lens' CatMlDatafeedsRow (Maybe Int64) +cmdfBucketsCountLens = lens cmdfBucketsCount (\x y -> x {cmdfBucketsCount = y}) + +cmdfSearchCountLens :: Lens' CatMlDatafeedsRow (Maybe Int64) +cmdfSearchCountLens = lens cmdfSearchCount (\x y -> x {cmdfSearchCount = y}) + +cmdfSearchTimeLens :: Lens' CatMlDatafeedsRow (Maybe Text) +cmdfSearchTimeLens = lens cmdfSearchTime (\x y -> x {cmdfSearchTime = y}) + +cmdfSearchBucketAvgLens :: Lens' CatMlDatafeedsRow (Maybe Text) +cmdfSearchBucketAvgLens = lens cmdfSearchBucketAvg (\x y -> x {cmdfSearchBucketAvg = y}) + +cmdfSearchExpAvgHourLens :: Lens' CatMlDatafeedsRow (Maybe Text) +cmdfSearchExpAvgHourLens = lens cmdfSearchExpAvgHour (\x y -> x {cmdfSearchExpAvgHour = y}) + +cmdfNodeIdLens :: Lens' CatMlDatafeedsRow (Maybe Text) +cmdfNodeIdLens = lens cmdfNodeId (\x y -> x {cmdfNodeId = y}) + +cmdfNodeNameLens :: Lens' CatMlDatafeedsRow (Maybe Text) +cmdfNodeNameLens = lens cmdfNodeName (\x y -> x {cmdfNodeName = y}) + +cmdfNodeEphemeralIdLens :: Lens' CatMlDatafeedsRow (Maybe Text) +cmdfNodeEphemeralIdLens = lens cmdfNodeEphemeralId (\x y -> x {cmdfNodeEphemeralId = y}) + +cmdfNodeAddressLens :: Lens' CatMlDatafeedsRow (Maybe Text) +cmdfNodeAddressLens = lens cmdfNodeAddress (\x y -> x {cmdfNodeAddress = y}) + +cmdfOtherLens :: Lens' CatMlDatafeedsRow Value +cmdfOtherLens = lens cmdfOther (\x y -> x {cmdfOther = y}) + +instance FromJSON CatMlDatafeedsRow where + parseJSON = withObject "CatMlDatafeedsRow" $ \o -> + CatMlDatafeedsRow + <$> o .:? "id" + <*> o .:? "state" + <*> o .:? "assignment_explanation" + <*> (o .:? "buckets.count" >>= traverse parseInt64) + <*> (o .:? "search.count" >>= traverse parseInt64) + <*> o .:? "search.time" + <*> o .:? "search.bucket_avg" + <*> o .:? "search.exp_avg_hour" + <*> o .:? "node.id" + <*> o .:? "node.name" + <*> o .:? "node.ephemeral_id" + <*> o .:? "node.address" + <*> pure (Object o) + where + parseInt64 = parseAsString "Int64" parseReadText + +-- ========================================================================= +-- @_cat\/ml\/trained_models@ +-- ========================================================================= +-- +-- The @_cat\/ml\/trained_models@ endpoint lists the trained machine-learning +-- models. See +-- . +-- +-- Path: @GET /_cat/ml/trained_models[\/{model_id}]@. Supports pagination +-- via @from@\/@size@. The @heap_size@ column is a humanised size; the +-- @data_frame.id@ column carries the @"__none__"@ sentinel when the model +-- was not produced by a data frame analytics job. + +data CatMlTrainedModelsColumn + = CatMlTrainedModelsColId + | CatMlTrainedModelsColCreatedBy + | CatMlTrainedModelsColHeapSize + | CatMlTrainedModelsColOperations + | CatMlTrainedModelsColLicense + | CatMlTrainedModelsColCreateTime + | CatMlTrainedModelsColVersion + | CatMlTrainedModelsColDescription + | CatMlTrainedModelsColIngestPipelines + | CatMlTrainedModelsColIngestCount + | CatMlTrainedModelsColIngestTime + | CatMlTrainedModelsColIngestCurrent + | CatMlTrainedModelsColIngestFailed + | CatMlTrainedModelsColDataFrameId + | CatMlTrainedModelsColDataFrameCreateTime + | CatMlTrainedModelsColDataFrameSourceIndex + | CatMlTrainedModelsColDataFrameAnalysis + | CatMlTrainedModelsColType + | CatMlTrainedModelsColOther Text + deriving stock (Eq, Show) + +catMlTrainedModelsColumnText :: CatMlTrainedModelsColumn -> Text +catMlTrainedModelsColumnText CatMlTrainedModelsColId = "id" +catMlTrainedModelsColumnText CatMlTrainedModelsColCreatedBy = "created_by" +catMlTrainedModelsColumnText CatMlTrainedModelsColHeapSize = "heap_size" +catMlTrainedModelsColumnText CatMlTrainedModelsColOperations = "operations" +catMlTrainedModelsColumnText CatMlTrainedModelsColLicense = "license" +catMlTrainedModelsColumnText CatMlTrainedModelsColCreateTime = "create_time" +catMlTrainedModelsColumnText CatMlTrainedModelsColVersion = "version" +catMlTrainedModelsColumnText CatMlTrainedModelsColDescription = "description" +catMlTrainedModelsColumnText CatMlTrainedModelsColIngestPipelines = "ingest.pipelines" +catMlTrainedModelsColumnText CatMlTrainedModelsColIngestCount = "ingest.count" +catMlTrainedModelsColumnText CatMlTrainedModelsColIngestTime = "ingest.time" +catMlTrainedModelsColumnText CatMlTrainedModelsColIngestCurrent = "ingest.current" +catMlTrainedModelsColumnText CatMlTrainedModelsColIngestFailed = "ingest.failed" +catMlTrainedModelsColumnText CatMlTrainedModelsColDataFrameId = "data_frame.id" +catMlTrainedModelsColumnText CatMlTrainedModelsColDataFrameCreateTime = "data_frame.create_time" +catMlTrainedModelsColumnText CatMlTrainedModelsColDataFrameSourceIndex = "data_frame.source_index" +catMlTrainedModelsColumnText CatMlTrainedModelsColDataFrameAnalysis = "data_frame.analysis" +catMlTrainedModelsColumnText CatMlTrainedModelsColType = "type" +catMlTrainedModelsColumnText (CatMlTrainedModelsColOther t) = t + +data CatMlTrainedModelsOptions = CatMlTrainedModelsOptions + { cmtoAllowNoMatch :: Maybe Bool, + cmtoFrom :: Maybe Word32, + cmtoSize :: Maybe Word32, + cmtoColumns :: Maybe (NonEmpty CatMlTrainedModelsColumn), + cmtoHelp :: Maybe Bool, + cmtoSort :: Maybe (NonEmpty Text), + cmtoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultCatMlTrainedModelsOptions :: CatMlTrainedModelsOptions +defaultCatMlTrainedModelsOptions = + CatMlTrainedModelsOptions + { cmtoAllowNoMatch = Nothing, + cmtoFrom = Nothing, + cmtoSize = Nothing, + cmtoColumns = Nothing, + cmtoHelp = Nothing, + cmtoSort = Nothing, + cmtoVerbose = Nothing + } + +cmtoAllowNoMatchLens :: Lens' CatMlTrainedModelsOptions (Maybe Bool) +cmtoAllowNoMatchLens = lens cmtoAllowNoMatch (\x y -> x {cmtoAllowNoMatch = y}) + +cmtoFromLens :: Lens' CatMlTrainedModelsOptions (Maybe Word32) +cmtoFromLens = lens cmtoFrom (\x y -> x {cmtoFrom = y}) + +cmtoSizeLens :: Lens' CatMlTrainedModelsOptions (Maybe Word32) +cmtoSizeLens = lens cmtoSize (\x y -> x {cmtoSize = y}) + +cmtoColumnsLens :: Lens' CatMlTrainedModelsOptions (Maybe (NonEmpty CatMlTrainedModelsColumn)) +cmtoColumnsLens = lens cmtoColumns (\x y -> x {cmtoColumns = y}) + +cmtoHelpLens :: Lens' CatMlTrainedModelsOptions (Maybe Bool) +cmtoHelpLens = lens cmtoHelp (\x y -> x {cmtoHelp = y}) + +cmtoSortLens :: Lens' CatMlTrainedModelsOptions (Maybe (NonEmpty Text)) +cmtoSortLens = lens cmtoSort (\x y -> x {cmtoSort = y}) + +cmtoVerboseLens :: Lens' CatMlTrainedModelsOptions (Maybe Bool) +cmtoVerboseLens = lens cmtoVerbose (\x y -> x {cmtoVerbose = y}) + +catMlTrainedModelsOptionsParams :: CatMlTrainedModelsOptions -> [(Text, Maybe Text)] +catMlTrainedModelsOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("allow_no_match",) . Just . boolQP <$> cmtoAllowNoMatch opts, + ("from",) . Just . showText <$> cmtoFrom opts, + ("size",) . Just . showText <$> cmtoSize opts, + ("h",) . Just . renderColumns <$> cmtoColumns opts, + ("help",) . Just . boolQP <$> cmtoHelp opts, + ("s",) . Just . renderSort <$> cmtoSort opts, + ("v",) . Just . boolQP <$> cmtoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderColumns = T.intercalate "," . map catMlTrainedModelsColumnText . toList + renderSort = T.intercalate "," . toList + +data CatMlTrainedModelsRow = CatMlTrainedModelsRow + { ctmrId :: Maybe Text, + ctmrCreatedBy :: Maybe Text, + ctmrHeapSize :: Maybe Text, + ctmrOperations :: Maybe Text, + ctmrLicense :: Maybe Text, + ctmrCreateTime :: Maybe Text, + ctmrVersion :: Maybe Text, + ctmrDescription :: Maybe Text, + ctmrIngestPipelines :: Maybe Text, + ctmrIngestCount :: Maybe Text, + ctmrIngestTime :: Maybe Text, + ctmrIngestCurrent :: Maybe Text, + ctmrIngestFailed :: Maybe Text, + ctmrDataFrameId :: Maybe Text, + ctmrDataFrameCreateTime :: Maybe Text, + ctmrDataFrameSourceIndex :: Maybe Text, + ctmrDataFrameAnalysis :: Maybe Text, + ctmrType :: Maybe Text, + ctmrOther :: Value + } + deriving stock (Eq, Show) + +ctmrIdLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrIdLens = lens ctmrId (\x y -> x {ctmrId = y}) + +ctmrCreatedByLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrCreatedByLens = lens ctmrCreatedBy (\x y -> x {ctmrCreatedBy = y}) + +ctmrHeapSizeLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrHeapSizeLens = lens ctmrHeapSize (\x y -> x {ctmrHeapSize = y}) + +ctmrOperationsLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrOperationsLens = lens ctmrOperations (\x y -> x {ctmrOperations = y}) + +ctmrLicenseLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrLicenseLens = lens ctmrLicense (\x y -> x {ctmrLicense = y}) + +ctmrCreateTimeLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrCreateTimeLens = lens ctmrCreateTime (\x y -> x {ctmrCreateTime = y}) + +ctmrVersionLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrVersionLens = lens ctmrVersion (\x y -> x {ctmrVersion = y}) + +ctmrDescriptionLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrDescriptionLens = lens ctmrDescription (\x y -> x {ctmrDescription = y}) + +ctmrIngestPipelinesLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrIngestPipelinesLens = lens ctmrIngestPipelines (\x y -> x {ctmrIngestPipelines = y}) + +ctmrIngestCountLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrIngestCountLens = lens ctmrIngestCount (\x y -> x {ctmrIngestCount = y}) + +ctmrIngestTimeLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrIngestTimeLens = lens ctmrIngestTime (\x y -> x {ctmrIngestTime = y}) + +ctmrIngestCurrentLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrIngestCurrentLens = lens ctmrIngestCurrent (\x y -> x {ctmrIngestCurrent = y}) + +ctmrIngestFailedLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrIngestFailedLens = lens ctmrIngestFailed (\x y -> x {ctmrIngestFailed = y}) + +ctmrDataFrameIdLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrDataFrameIdLens = lens ctmrDataFrameId (\x y -> x {ctmrDataFrameId = y}) + +ctmrDataFrameCreateTimeLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrDataFrameCreateTimeLens = lens ctmrDataFrameCreateTime (\x y -> x {ctmrDataFrameCreateTime = y}) + +ctmrDataFrameSourceIndexLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrDataFrameSourceIndexLens = lens ctmrDataFrameSourceIndex (\x y -> x {ctmrDataFrameSourceIndex = y}) + +ctmrDataFrameAnalysisLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrDataFrameAnalysisLens = lens ctmrDataFrameAnalysis (\x y -> x {ctmrDataFrameAnalysis = y}) + +ctmrTypeLens :: Lens' CatMlTrainedModelsRow (Maybe Text) +ctmrTypeLens = lens ctmrType (\x y -> x {ctmrType = y}) + +ctmrOtherLens :: Lens' CatMlTrainedModelsRow Value +ctmrOtherLens = lens ctmrOther (\x y -> x {ctmrOther = y}) + +instance FromJSON CatMlTrainedModelsRow where + parseJSON = withObject "CatMlTrainedModelsRow" $ \o -> + CatMlTrainedModelsRow + <$> o .:? "id" + <*> o .:? "created_by" + <*> o .:? "heap_size" + <*> o .:? "operations" + <*> o .:? "license" + <*> o .:? "create_time" + <*> o .:? "version" + <*> o .:? "description" + <*> o .:? "ingest.pipelines" + <*> o .:? "ingest.count" + <*> o .:? "ingest.time" + <*> o .:? "ingest.current" + <*> o .:? "ingest.failed" + <*> o .:? "data_frame.id" + <*> o .:? "data_frame.create_time" + <*> o .:? "data_frame.source_index" + <*> o .:? "data_frame.analysis" + <*> o .:? "type" + <*> pure (Object o) + +-- ========================================================================= +-- @_cat\/transforms@ +-- ========================================================================= +-- +-- The @_cat\/transforms@ endpoint lists the transforms. See +-- . +-- +-- Path: @GET /_cat/transforms[\/{transform_id}]@. Supports pagination +-- via @from@\/@size@. Several columns are emitted as native JSON @null@ +-- when not yet populated (@checkpoint_progress@, @last_search_time@, +-- @changes_last_detection_time@); the parser maps those to 'Nothing'. + +data CatTransformsColumn + = CatTransformsColId + | CatTransformsColState + | CatTransformsColCheckpoint + | CatTransformsColDocumentsProcessed + | CatTransformsColCheckpointProgress + | CatTransformsColLastSearchTime + | CatTransformsColChangesLastDetectionTime + | CatTransformsColCreateTime + | CatTransformsColVersion + | CatTransformsColSourceIndex + | CatTransformsColDestIndex + | CatTransformsColPipeline + | CatTransformsColDescription + | CatTransformsColTransformType + | CatTransformsColFrequency + | CatTransformsColMaxPageSearchSize + | CatTransformsColDocsPerSecond + | CatTransformsColReason + | CatTransformsColSearchTotal + | CatTransformsColSearchFailure + | CatTransformsColSearchTime + | CatTransformsColIndexTotal + | CatTransformsColIndexFailure + | CatTransformsColIndexTime + | CatTransformsColDocumentsIndexed + | CatTransformsColDeleteTime + | CatTransformsColDocumentsDeleted + | CatTransformsColTriggerCount + | CatTransformsColPagesProcessed + | CatTransformsColProcessingTime + | CatTransformsColCheckpointDurationTimeExpAvg + | CatTransformsColIndexedDocumentsExpAvg + | CatTransformsColProcessedDocumentsExpAvg + | CatTransformsColOther Text + deriving stock (Eq, Show) + +catTransformsColumnText :: CatTransformsColumn -> Text +catTransformsColumnText CatTransformsColId = "id" +catTransformsColumnText CatTransformsColState = "state" +catTransformsColumnText CatTransformsColCheckpoint = "checkpoint" +catTransformsColumnText CatTransformsColDocumentsProcessed = "documents_processed" +catTransformsColumnText CatTransformsColCheckpointProgress = "checkpoint_progress" +catTransformsColumnText CatTransformsColLastSearchTime = "last_search_time" +catTransformsColumnText CatTransformsColChangesLastDetectionTime = "changes_last_detection_time" +catTransformsColumnText CatTransformsColCreateTime = "create_time" +catTransformsColumnText CatTransformsColVersion = "version" +catTransformsColumnText CatTransformsColSourceIndex = "source_index" +catTransformsColumnText CatTransformsColDestIndex = "dest_index" +catTransformsColumnText CatTransformsColPipeline = "pipeline" +catTransformsColumnText CatTransformsColDescription = "description" +catTransformsColumnText CatTransformsColTransformType = "transform_type" +catTransformsColumnText CatTransformsColFrequency = "frequency" +catTransformsColumnText CatTransformsColMaxPageSearchSize = "max_page_search_size" +catTransformsColumnText CatTransformsColDocsPerSecond = "docs_per_second" +catTransformsColumnText CatTransformsColReason = "reason" +catTransformsColumnText CatTransformsColSearchTotal = "search_total" +catTransformsColumnText CatTransformsColSearchFailure = "search_failure" +catTransformsColumnText CatTransformsColSearchTime = "search_time" +catTransformsColumnText CatTransformsColIndexTotal = "index_total" +catTransformsColumnText CatTransformsColIndexFailure = "index_failure" +catTransformsColumnText CatTransformsColIndexTime = "index_time" +catTransformsColumnText CatTransformsColDocumentsIndexed = "documents_indexed" +catTransformsColumnText CatTransformsColDeleteTime = "delete_time" +catTransformsColumnText CatTransformsColDocumentsDeleted = "documents_deleted" +catTransformsColumnText CatTransformsColTriggerCount = "trigger_count" +catTransformsColumnText CatTransformsColPagesProcessed = "pages_processed" +catTransformsColumnText CatTransformsColProcessingTime = "processing_time" +catTransformsColumnText CatTransformsColCheckpointDurationTimeExpAvg = "checkpoint_duration_time_exp_avg" +catTransformsColumnText CatTransformsColIndexedDocumentsExpAvg = "indexed_documents_exp_avg" +catTransformsColumnText CatTransformsColProcessedDocumentsExpAvg = "processed_documents_exp_avg" +catTransformsColumnText (CatTransformsColOther t) = t + +data CatTransformsOptions = CatTransformsOptions + { ctxoAllowNoMatch :: Maybe Bool, + ctxoFrom :: Maybe Word32, + ctxoSize :: Maybe Word32, + ctxoColumns :: Maybe (NonEmpty CatTransformsColumn), + ctxoHelp :: Maybe Bool, + ctxoSort :: Maybe (NonEmpty Text), + ctxoVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultCatTransformsOptions :: CatTransformsOptions +defaultCatTransformsOptions = + CatTransformsOptions + { ctxoAllowNoMatch = Nothing, + ctxoFrom = Nothing, + ctxoSize = Nothing, + ctxoColumns = Nothing, + ctxoHelp = Nothing, + ctxoSort = Nothing, + ctxoVerbose = Nothing + } + +ctxoAllowNoMatchLens :: Lens' CatTransformsOptions (Maybe Bool) +ctxoAllowNoMatchLens = lens ctxoAllowNoMatch (\x y -> x {ctxoAllowNoMatch = y}) + +ctxoFromLens :: Lens' CatTransformsOptions (Maybe Word32) +ctxoFromLens = lens ctxoFrom (\x y -> x {ctxoFrom = y}) + +ctxoSizeLens :: Lens' CatTransformsOptions (Maybe Word32) +ctxoSizeLens = lens ctxoSize (\x y -> x {ctxoSize = y}) + +ctxoColumnsLens :: Lens' CatTransformsOptions (Maybe (NonEmpty CatTransformsColumn)) +ctxoColumnsLens = lens ctxoColumns (\x y -> x {ctxoColumns = y}) + +ctxoHelpLens :: Lens' CatTransformsOptions (Maybe Bool) +ctxoHelpLens = lens ctxoHelp (\x y -> x {ctxoHelp = y}) + +ctxoSortLens :: Lens' CatTransformsOptions (Maybe (NonEmpty Text)) +ctxoSortLens = lens ctxoSort (\x y -> x {ctxoSort = y}) + +ctxoVerboseLens :: Lens' CatTransformsOptions (Maybe Bool) +ctxoVerboseLens = lens ctxoVerbose (\x y -> x {ctxoVerbose = y}) + +catTransformsOptionsParams :: CatTransformsOptions -> [(Text, Maybe Text)] +catTransformsOptionsParams opts = + ("format", Just "json") + : catMaybes + [ ("allow_no_match",) . Just . boolQP <$> ctxoAllowNoMatch opts, + ("from",) . Just . showText <$> ctxoFrom opts, + ("size",) . Just . showText <$> ctxoSize opts, + ("h",) . Just . renderColumns <$> ctxoColumns opts, + ("help",) . Just . boolQP <$> ctxoHelp opts, + ("s",) . Just . renderSort <$> ctxoSort opts, + ("v",) . Just . boolQP <$> ctxoVerbose opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderColumns = T.intercalate "," . map catTransformsColumnText . toList + renderSort = T.intercalate "," . toList + +data CatTransformsRow = CatTransformsRow + { ctxrId :: Maybe Text, + ctxrState :: Maybe Text, + ctxrCheckpoint :: Maybe Text, + ctxrDocumentsProcessed :: Maybe Int64, + ctxrCheckpointProgress :: Maybe Text, + ctxrLastSearchTime :: Maybe Text, + ctxrChangesLastDetectionTime :: Maybe Text, + ctxrCreateTime :: Maybe Text, + ctxrVersion :: Maybe Text, + ctxrSourceIndex :: Maybe Text, + ctxrDestIndex :: Maybe Text, + ctxrPipeline :: Maybe Text, + ctxrDescription :: Maybe Text, + ctxrTransformType :: Maybe Text, + ctxrFrequency :: Maybe Text, + ctxrMaxPageSearchSize :: Maybe Text, + ctxrDocsPerSecond :: Maybe Text, + ctxrReason :: Maybe Text, + ctxrSearchTotal :: Maybe Int64, + ctxrSearchFailure :: Maybe Int64, + ctxrSearchTime :: Maybe Text, + ctxrIndexTotal :: Maybe Int64, + ctxrIndexFailure :: Maybe Int64, + ctxrIndexTime :: Maybe Text, + ctxrDocumentsIndexed :: Maybe Int64, + ctxrDeleteTime :: Maybe Text, + ctxrDocumentsDeleted :: Maybe Int64, + ctxrTriggerCount :: Maybe Int64, + ctxrPagesProcessed :: Maybe Int64, + ctxrProcessingTime :: Maybe Text, + ctxrCheckpointDurationTimeExpAvg :: Maybe Text, + ctxrIndexedDocumentsExpAvg :: Maybe Text, + ctxrDocumentsProcessedExpAvg :: Maybe Text, + ctxrOther :: Value + } + deriving stock (Eq, Show) + +ctxrIdLens :: Lens' CatTransformsRow (Maybe Text) +ctxrIdLens = lens ctxrId (\x y -> x {ctxrId = y}) + +ctxrStateLens :: Lens' CatTransformsRow (Maybe Text) +ctxrStateLens = lens ctxrState (\x y -> x {ctxrState = y}) + +ctxrCheckpointLens :: Lens' CatTransformsRow (Maybe Text) +ctxrCheckpointLens = lens ctxrCheckpoint (\x y -> x {ctxrCheckpoint = y}) + +ctxrDocumentsProcessedLens :: Lens' CatTransformsRow (Maybe Int64) +ctxrDocumentsProcessedLens = lens ctxrDocumentsProcessed (\x y -> x {ctxrDocumentsProcessed = y}) + +ctxrCheckpointProgressLens :: Lens' CatTransformsRow (Maybe Text) +ctxrCheckpointProgressLens = lens ctxrCheckpointProgress (\x y -> x {ctxrCheckpointProgress = y}) + +ctxrLastSearchTimeLens :: Lens' CatTransformsRow (Maybe Text) +ctxrLastSearchTimeLens = lens ctxrLastSearchTime (\x y -> x {ctxrLastSearchTime = y}) + +ctxrChangesLastDetectionTimeLens :: Lens' CatTransformsRow (Maybe Text) +ctxrChangesLastDetectionTimeLens = lens ctxrChangesLastDetectionTime (\x y -> x {ctxrChangesLastDetectionTime = y}) + +ctxrCreateTimeLens :: Lens' CatTransformsRow (Maybe Text) +ctxrCreateTimeLens = lens ctxrCreateTime (\x y -> x {ctxrCreateTime = y}) + +ctxrVersionLens :: Lens' CatTransformsRow (Maybe Text) +ctxrVersionLens = lens ctxrVersion (\x y -> x {ctxrVersion = y}) + +ctxrSourceIndexLens :: Lens' CatTransformsRow (Maybe Text) +ctxrSourceIndexLens = lens ctxrSourceIndex (\x y -> x {ctxrSourceIndex = y}) + +ctxrDestIndexLens :: Lens' CatTransformsRow (Maybe Text) +ctxrDestIndexLens = lens ctxrDestIndex (\x y -> x {ctxrDestIndex = y}) + +ctxrPipelineLens :: Lens' CatTransformsRow (Maybe Text) +ctxrPipelineLens = lens ctxrPipeline (\x y -> x {ctxrPipeline = y}) + +ctxrDescriptionLens :: Lens' CatTransformsRow (Maybe Text) +ctxrDescriptionLens = lens ctxrDescription (\x y -> x {ctxrDescription = y}) + +ctxrTransformTypeLens :: Lens' CatTransformsRow (Maybe Text) +ctxrTransformTypeLens = lens ctxrTransformType (\x y -> x {ctxrTransformType = y}) + +ctxrFrequencyLens :: Lens' CatTransformsRow (Maybe Text) +ctxrFrequencyLens = lens ctxrFrequency (\x y -> x {ctxrFrequency = y}) + +ctxrMaxPageSearchSizeLens :: Lens' CatTransformsRow (Maybe Text) +ctxrMaxPageSearchSizeLens = lens ctxrMaxPageSearchSize (\x y -> x {ctxrMaxPageSearchSize = y}) + +ctxrDocsPerSecondLens :: Lens' CatTransformsRow (Maybe Text) +ctxrDocsPerSecondLens = lens ctxrDocsPerSecond (\x y -> x {ctxrDocsPerSecond = y}) + +ctxrReasonLens :: Lens' CatTransformsRow (Maybe Text) +ctxrReasonLens = lens ctxrReason (\x y -> x {ctxrReason = y}) + +ctxrSearchTotalLens :: Lens' CatTransformsRow (Maybe Int64) +ctxrSearchTotalLens = lens ctxrSearchTotal (\x y -> x {ctxrSearchTotal = y}) + +ctxrSearchFailureLens :: Lens' CatTransformsRow (Maybe Int64) +ctxrSearchFailureLens = lens ctxrSearchFailure (\x y -> x {ctxrSearchFailure = y}) + +ctxrSearchTimeLens :: Lens' CatTransformsRow (Maybe Text) +ctxrSearchTimeLens = lens ctxrSearchTime (\x y -> x {ctxrSearchTime = y}) + +ctxrIndexTotalLens :: Lens' CatTransformsRow (Maybe Int64) +ctxrIndexTotalLens = lens ctxrIndexTotal (\x y -> x {ctxrIndexTotal = y}) + +ctxrIndexFailureLens :: Lens' CatTransformsRow (Maybe Int64) +ctxrIndexFailureLens = lens ctxrIndexFailure (\x y -> x {ctxrIndexFailure = y}) + +ctxrIndexTimeLens :: Lens' CatTransformsRow (Maybe Text) +ctxrIndexTimeLens = lens ctxrIndexTime (\x y -> x {ctxrIndexTime = y}) + +ctxrDocumentsIndexedLens :: Lens' CatTransformsRow (Maybe Int64) +ctxrDocumentsIndexedLens = lens ctxrDocumentsIndexed (\x y -> x {ctxrDocumentsIndexed = y}) + +ctxrDeleteTimeLens :: Lens' CatTransformsRow (Maybe Text) +ctxrDeleteTimeLens = lens ctxrDeleteTime (\x y -> x {ctxrDeleteTime = y}) + +ctxrDocumentsDeletedLens :: Lens' CatTransformsRow (Maybe Int64) +ctxrDocumentsDeletedLens = lens ctxrDocumentsDeleted (\x y -> x {ctxrDocumentsDeleted = y}) + +ctxrTriggerCountLens :: Lens' CatTransformsRow (Maybe Int64) +ctxrTriggerCountLens = lens ctxrTriggerCount (\x y -> x {ctxrTriggerCount = y}) + +ctxrPagesProcessedLens :: Lens' CatTransformsRow (Maybe Int64) +ctxrPagesProcessedLens = lens ctxrPagesProcessed (\x y -> x {ctxrPagesProcessed = y}) + +ctxrProcessingTimeLens :: Lens' CatTransformsRow (Maybe Text) +ctxrProcessingTimeLens = lens ctxrProcessingTime (\x y -> x {ctxrProcessingTime = y}) + +ctxrCheckpointDurationTimeExpAvgLens :: Lens' CatTransformsRow (Maybe Text) +ctxrCheckpointDurationTimeExpAvgLens = lens ctxrCheckpointDurationTimeExpAvg (\x y -> x {ctxrCheckpointDurationTimeExpAvg = y}) + +ctxrIndexedDocumentsExpAvgLens :: Lens' CatTransformsRow (Maybe Text) +ctxrIndexedDocumentsExpAvgLens = lens ctxrIndexedDocumentsExpAvg (\x y -> x {ctxrIndexedDocumentsExpAvg = y}) + +ctxrDocumentsProcessedExpAvgLens :: Lens' CatTransformsRow (Maybe Text) +ctxrDocumentsProcessedExpAvgLens = lens ctxrDocumentsProcessedExpAvg (\x y -> x {ctxrDocumentsProcessedExpAvg = y}) + +ctxrOtherLens :: Lens' CatTransformsRow Value +ctxrOtherLens = lens ctxrOther (\x y -> x {ctxrOther = y}) + +instance FromJSON CatTransformsRow where + parseJSON = withObject "CatTransformsRow" $ \o -> + CatTransformsRow + <$> o .:? "id" + <*> o .:? "state" + <*> o .:? "checkpoint" + <*> (o .:? "documents_processed" >>= traverse parseInt64) + <*> o .:? "checkpoint_progress" + <*> o .:? "last_search_time" + <*> o .:? "changes_last_detection_time" + <*> o .:? "create_time" + <*> o .:? "version" + <*> o .:? "source_index" + <*> o .:? "dest_index" + <*> o .:? "pipeline" + <*> o .:? "description" + <*> o .:? "transform_type" + <*> o .:? "frequency" + <*> o .:? "max_page_search_size" + <*> o .:? "docs_per_second" + <*> o .:? "reason" + <*> (o .:? "search_total" >>= traverse parseInt64) + <*> (o .:? "search_failure" >>= traverse parseInt64) + <*> o .:? "search_time" + <*> (o .:? "index_total" >>= traverse parseInt64) + <*> (o .:? "index_failure" >>= traverse parseInt64) + <*> o .:? "index_time" + <*> (o .:? "documents_indexed" >>= traverse parseInt64) + <*> o .:? "delete_time" + <*> (o .:? "documents_deleted" >>= traverse parseInt64) + <*> (o .:? "trigger_count" >>= traverse parseInt64) + <*> (o .:? "pages_processed" >>= traverse parseInt64) + <*> o .:? "processing_time" + <*> o .:? "checkpoint_duration_time_exp_avg" + <*> o .:? "indexed_documents_exp_avg" + <*> o .:? "processed_documents_exp_avg" + <*> pure (Object o) + where + parseInt64 = parseAsString "Int64" parseReadText diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Cluster.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Cluster.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Cluster.hs @@ -0,0 +1,970 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.Common.Types.Cluster + ( -- * Cluster Health + ClusterHealth (..), + ClusterHealthStatus (..), + + -- * Cluster Health request options + ClusterHealthLevel (..), + ClusterHealthOptions (..), + defaultClusterHealthOptions, + renderClusterHealthLevel, + + -- * Cluster allocation explain + AllocationExplainRequest (..), + defaultAllocationExplainRequest, + mkAllocationExplainRequest, + AllocationExplanation (..), + + -- ** Typed views onto the @Value@ blobs + + -- + -- $typedViews + AllocationCurrentNode (..), + AllocationUnassignedInfo (..), + AllocationDecision (..), + NodeAllocationDecision (..), + aeCurrentNodeTyped, + aeUnassignedInfoTyped, + aeDecisionsTyped, + aeCanRemainOnCurrentNodeTyped, + aeCanRebalanceClusterTyped, + aeCanRebalanceToOtherNodeTyped, + aeRebalanceExplanationTyped, + aeNodeAllocationDecisionsTyped, + + -- * Optics + clusterHealthClusterNameLens, + clusterHealthStatusLens, + clusterHealthTimedOutLens, + clusterHealthNumberOfNodesLens, + clusterHealthNumberOfDataNodesLens, + clusterHealthActivePrimaryShardsLens, + clusterHealthActiveShardsLens, + clusterHealthRelocatingShardsLens, + clusterHealthInitializingShardsLens, + clusterHealthUnassignedShardsLens, + clusterHealthDelayedUnassignedShardsLens, + clusterHealthNumberOfPendingTasksLens, + clusterHealthNumberOfInFlightFetchLens, + clusterHealthTaskMaxWaitingInQueueMillisLens, + clusterHealthTaskMaxWaitingInQueueLens, + clusterHealthActiveShardsPercentAsNumberLens, + clusterHealthUnassignedPrimariesLens, + clusterHealthIndicesLens, + clusterHealthDiscoveredMasterLens, + clusterHealthDiscoveredClusterManagerLens, + clusterHealthDiscoveredNodesLens, + clusterHealthDiscoveredDataNodesLens, + choLevelLens, + choLocalLens, + choMasterTimeoutLens, + choWaitForStatusLens, + choWaitForActiveShardsLens, + choWaitForNodesLens, + choWaitForNoRelocatingShardsLens, + choWaitForNoInitializingShardsLens, + choTimeoutLens, + aerIndexLens, + aerShardLens, + aerPrimaryLens, + aerCurrentNodeLens, + aeIndexLens, + aeShardLens, + aePrimaryLens, + aeCurrentStateLens, + aeCurrentNodeLens, + aeRelocatingNodeLens, + aeShardStateLens, + aeUnassignedInfoLens, + aeAllocateDroningLens, + aeClusterInfoLens, + aeNodesLens, + aeDecisionsLens, + aeOtherLens, + acnIdLens, + acnNameLens, + acnTransportAddressLens, + acnAttributesLens, + acnDecisionLens, + acnOtherLens, + auiReasonLens, + auiAtLens, + auiDetailsLens, + auiLastAllocationStatusLens, + auiOtherLens, + adDeciderLens, + adDecisionLens, + adExplanationLens, + adDetailsLens, + adOtherLens, + nadNodeIdLens, + nadNodeNameLens, + nadTransportAddressLens, + nadRolesLens, + nadNodeAttributesLens, + nadNodeDecisionLens, + nadWeightRankingLens, + nadDecidersLens, + nadOtherLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Indices (ActiveShardCount) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( IndexName, + ShardId (..), + unIndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Units (TimeUnits) + +data ClusterHealthStatus + = ClusterHealthGreen + | ClusterHealthYellow + | ClusterHealthRed + deriving stock (Eq, Show) + +instance FromJSON ClusterHealthStatus where + parseJSON = withText "ClusterHealthStatus" $ \case + "green" -> pure ClusterHealthGreen + "GREEN" -> pure ClusterHealthGreen + "yellow" -> pure ClusterHealthYellow + "YELLOW" -> pure ClusterHealthYellow + "red" -> pure ClusterHealthRed + "RED" -> pure ClusterHealthRed + _ -> fail "Invalid cluster health status" + +instance ToJSON ClusterHealthStatus where + toJSON ClusterHealthGreen = String "green" + toJSON ClusterHealthYellow = String "yellow" + toJSON ClusterHealthRed = String "red" + +data ClusterHealth = ClusterHealth + { clusterHealthClusterName :: Text, + clusterHealthStatus :: ClusterHealthStatus, + clusterHealthTimedOut :: Bool, + clusterHealthNumberOfNodes :: Int, + clusterHealthNumberOfDataNodes :: Int, + clusterHealthActivePrimaryShards :: Int, + clusterHealthActiveShards :: Int, + clusterHealthRelocatingShards :: Int, + clusterHealthInitializingShards :: Int, + clusterHealthUnassignedShards :: Int, + clusterHealthDelayedUnassignedShards :: Int, + clusterHealthNumberOfPendingTasks :: Int, + clusterHealthNumberOfInFlightFetch :: Int, + clusterHealthTaskMaxWaitingInQueueMillis :: Maybe Int, + clusterHealthTaskMaxWaitingInQueue :: Maybe Text, + clusterHealthActiveShardsPercentAsNumber :: Double, + -- | Per-index @unassigned_primaries@ value. The ES docs surface + -- this field only on per-index sub-objects (under + -- 'clusterHealthIndices' when @level=indices@); on the standard + -- top-level response it is absent and this accessor always + -- returns 'Nothing'. It is modelled here for parity with the + -- per-index sub-object so callers can lift the field uniformly + -- when they decode 'clusterHealthIndices' themselves. + clusterHealthUnassignedPrimaries :: Maybe Int, + -- | The @indices@ sub-object returned only when the request + -- specified @level=indices@ or @level=shards@. Preserved verbatim + -- (as an aeson 'Object') so callers needing the per-index or + -- per-shard breakdown can decode it themselves; absent (and + -- 'Nothing') on the default cluster-level response. Typed modelling + -- of the per-index\/per-shard sub-objects is tracked as separate + -- work. + clusterHealthIndices :: Maybe Object, + -- | Conditional fields surfaced by the cluster-health endpoint when + -- the cluster is in the process of electing a new master (the + -- @discovered_*@ family). All 'Nothing' on a healthy, fully-formed + -- cluster; present during master election / cluster formation. + clusterHealthDiscoveredMaster :: Maybe Bool, + clusterHealthDiscoveredClusterManager :: Maybe Bool, + clusterHealthDiscoveredNodes :: Maybe Int, + clusterHealthDiscoveredDataNodes :: Maybe Int + } + deriving stock (Eq, Show) + +clusterHealthClusterNameLens :: Lens' ClusterHealth Text +clusterHealthClusterNameLens = lens clusterHealthClusterName (\x y -> x {clusterHealthClusterName = y}) + +clusterHealthStatusLens :: Lens' ClusterHealth ClusterHealthStatus +clusterHealthStatusLens = lens clusterHealthStatus (\x y -> x {clusterHealthStatus = y}) + +clusterHealthTimedOutLens :: Lens' ClusterHealth Bool +clusterHealthTimedOutLens = lens clusterHealthTimedOut (\x y -> x {clusterHealthTimedOut = y}) + +clusterHealthNumberOfNodesLens :: Lens' ClusterHealth Int +clusterHealthNumberOfNodesLens = lens clusterHealthNumberOfNodes (\x y -> x {clusterHealthNumberOfNodes = y}) + +clusterHealthNumberOfDataNodesLens :: Lens' ClusterHealth Int +clusterHealthNumberOfDataNodesLens = lens clusterHealthNumberOfDataNodes (\x y -> x {clusterHealthNumberOfDataNodes = y}) + +clusterHealthActivePrimaryShardsLens :: Lens' ClusterHealth Int +clusterHealthActivePrimaryShardsLens = lens clusterHealthActivePrimaryShards (\x y -> x {clusterHealthActivePrimaryShards = y}) + +clusterHealthActiveShardsLens :: Lens' ClusterHealth Int +clusterHealthActiveShardsLens = lens clusterHealthActiveShards (\x y -> x {clusterHealthActiveShards = y}) + +clusterHealthRelocatingShardsLens :: Lens' ClusterHealth Int +clusterHealthRelocatingShardsLens = lens clusterHealthRelocatingShards (\x y -> x {clusterHealthRelocatingShards = y}) + +clusterHealthInitializingShardsLens :: Lens' ClusterHealth Int +clusterHealthInitializingShardsLens = lens clusterHealthInitializingShards (\x y -> x {clusterHealthInitializingShards = y}) + +clusterHealthUnassignedShardsLens :: Lens' ClusterHealth Int +clusterHealthUnassignedShardsLens = lens clusterHealthUnassignedShards (\x y -> x {clusterHealthUnassignedShards = y}) + +clusterHealthDelayedUnassignedShardsLens :: Lens' ClusterHealth Int +clusterHealthDelayedUnassignedShardsLens = lens clusterHealthDelayedUnassignedShards (\x y -> x {clusterHealthDelayedUnassignedShards = y}) + +clusterHealthNumberOfPendingTasksLens :: Lens' ClusterHealth Int +clusterHealthNumberOfPendingTasksLens = lens clusterHealthNumberOfPendingTasks (\x y -> x {clusterHealthNumberOfPendingTasks = y}) + +clusterHealthNumberOfInFlightFetchLens :: Lens' ClusterHealth Int +clusterHealthNumberOfInFlightFetchLens = lens clusterHealthNumberOfInFlightFetch (\x y -> x {clusterHealthNumberOfInFlightFetch = y}) + +clusterHealthTaskMaxWaitingInQueueMillisLens :: Lens' ClusterHealth (Maybe Int) +clusterHealthTaskMaxWaitingInQueueMillisLens = lens clusterHealthTaskMaxWaitingInQueueMillis (\x y -> x {clusterHealthTaskMaxWaitingInQueueMillis = y}) + +clusterHealthTaskMaxWaitingInQueueLens :: Lens' ClusterHealth (Maybe Text) +clusterHealthTaskMaxWaitingInQueueLens = lens clusterHealthTaskMaxWaitingInQueue (\x y -> x {clusterHealthTaskMaxWaitingInQueue = y}) + +clusterHealthActiveShardsPercentAsNumberLens :: Lens' ClusterHealth Double +clusterHealthActiveShardsPercentAsNumberLens = lens clusterHealthActiveShardsPercentAsNumber (\x y -> x {clusterHealthActiveShardsPercentAsNumber = y}) + +clusterHealthUnassignedPrimariesLens :: Lens' ClusterHealth (Maybe Int) +clusterHealthUnassignedPrimariesLens = lens clusterHealthUnassignedPrimaries (\x y -> x {clusterHealthUnassignedPrimaries = y}) + +clusterHealthIndicesLens :: Lens' ClusterHealth (Maybe Object) +clusterHealthIndicesLens = lens clusterHealthIndices (\x y -> x {clusterHealthIndices = y}) + +clusterHealthDiscoveredMasterLens :: Lens' ClusterHealth (Maybe Bool) +clusterHealthDiscoveredMasterLens = lens clusterHealthDiscoveredMaster (\x y -> x {clusterHealthDiscoveredMaster = y}) + +clusterHealthDiscoveredClusterManagerLens :: Lens' ClusterHealth (Maybe Bool) +clusterHealthDiscoveredClusterManagerLens = lens clusterHealthDiscoveredClusterManager (\x y -> x {clusterHealthDiscoveredClusterManager = y}) + +clusterHealthDiscoveredNodesLens :: Lens' ClusterHealth (Maybe Int) +clusterHealthDiscoveredNodesLens = lens clusterHealthDiscoveredNodes (\x y -> x {clusterHealthDiscoveredNodes = y}) + +clusterHealthDiscoveredDataNodesLens :: Lens' ClusterHealth (Maybe Int) +clusterHealthDiscoveredDataNodesLens = lens clusterHealthDiscoveredDataNodes (\x y -> x {clusterHealthDiscoveredDataNodes = y}) + +instance FromJSON ClusterHealth where + parseJSON = withObject "ClusterHealth" $ \o -> + ClusterHealth + <$> o .: "cluster_name" + <*> o .: "status" + <*> o .: "timed_out" + <*> o .: "number_of_nodes" + <*> o .: "number_of_data_nodes" + <*> o .: "active_primary_shards" + <*> o .: "active_shards" + <*> o .: "relocating_shards" + <*> o .: "initializing_shards" + <*> o .: "unassigned_shards" + <*> o .: "delayed_unassigned_shards" + <*> o .: "number_of_pending_tasks" + <*> o .: "number_of_in_flight_fetch" + <*> o .:? "task_max_waiting_in_queue_millis" + <*> o .:? "task_max_waiting_in_queue" + <*> o .: "active_shards_percent_as_number" + <*> o .:? "unassigned_primaries" + <*> o .:? "indices" + <*> o .:? "discovered_master" + <*> o .:? "discovered_cluster_manager" + <*> o .:? "discovered_nodes" + <*> o .:? "discovered_data_nodes" + +instance ToJSON ClusterHealth where + toJSON ClusterHealth {..} = + object $ + catMaybes + [ Just ("cluster_name" .= clusterHealthClusterName), + Just ("status" .= clusterHealthStatus), + Just ("timed_out" .= clusterHealthTimedOut), + Just ("number_of_nodes" .= clusterHealthNumberOfNodes), + Just ("number_of_data_nodes" .= clusterHealthNumberOfDataNodes), + Just ("active_primary_shards" .= clusterHealthActivePrimaryShards), + Just ("active_shards" .= clusterHealthActiveShards), + Just ("relocating_shards" .= clusterHealthRelocatingShards), + Just ("initializing_shards" .= clusterHealthInitializingShards), + Just ("unassigned_shards" .= clusterHealthUnassignedShards), + Just ("delayed_unassigned_shards" .= clusterHealthDelayedUnassignedShards), + Just ("number_of_pending_tasks" .= clusterHealthNumberOfPendingTasks), + Just ("number_of_in_flight_fetch" .= clusterHealthNumberOfInFlightFetch), + ("task_max_waiting_in_queue_millis" .=) <$> clusterHealthTaskMaxWaitingInQueueMillis, + ("task_max_waiting_in_queue" .=) <$> clusterHealthTaskMaxWaitingInQueue, + Just ("active_shards_percent_as_number" .= clusterHealthActiveShardsPercentAsNumber), + ("unassigned_primaries" .=) <$> clusterHealthUnassignedPrimaries, + ("indices" .=) <$> clusterHealthIndices, + ("discovered_master" .=) <$> clusterHealthDiscoveredMaster, + ("discovered_cluster_manager" .=) <$> clusterHealthDiscoveredClusterManager, + ("discovered_nodes" .=) <$> clusterHealthDiscoveredNodes, + ("discovered_data_nodes" .=) <$> clusterHealthDiscoveredDataNodes + ] + +-- | @level@ URI parameter for the cluster-health endpoint +-- (). +-- Controls how much detail the response carries: the base fields always +-- present ('ClusterHealthLevelCluster'), plus per-index +-- ('ClusterHealthLevelIndices') or per-shard +-- ('ClusterHealthLevelShards') sub-objects. +-- +-- /Note/: when @level@ is @indices@ or @shards@ the response gains extra +-- keys that the 'ClusterHealth' decoder does not currently model. As with +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Indices.CreateIndexOptions', +-- those keys are silently ignored by the existing 'FromJSON' instance; +-- full schema-typed modelling of the indices\/shards breakdown is tracked +-- as separate work. Setting the parameter still has a server-side effect +-- (it changes what the server computes and returns), so callers that +-- only need the top-level summary can safely pass any level. +data ClusterHealthLevel + = ClusterHealthLevelCluster + | ClusterHealthLevelIndices + | ClusterHealthLevelShards + deriving stock (Eq, Show) + +-- | Render a 'ClusterHealthLevel' to its wire string (@cluster@, @indices@, +-- @shards@). +renderClusterHealthLevel :: ClusterHealthLevel -> Text +renderClusterHealthLevel ClusterHealthLevelCluster = "cluster" +renderClusterHealthLevel ClusterHealthLevelIndices = "indices" +renderClusterHealthLevel ClusterHealthLevelShards = "shards" + +-- | The commonly-used URI parameters accepted by the @GET /_cluster/health@ +-- endpoint (with or without an index segment): @level@, @local@, +-- @master_timeout@, @wait_for_status@, @wait_for_active_shards@, +-- @wait_for_nodes@, @wait_for_no_relocating_shards@, +-- @wait_for_no_initializing_shards@ and @timeout@. A few rarely-needed +-- parameters (@awareness_attribute@, @expand_wildcards@, @wait_for_events@) +-- are not modelled; @master_timeout@ is the pre-7.16 name still accepted +-- as a deprecated alias of @cluster_manager_timeout@. Every field is +-- optional so that 'defaultClusterHealthOptions' renders to no parameters +-- at all — byte-for-byte identical to the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.getClusterHealth'. +-- +-- Durations are modelled as a @(unit, magnitude)@ pair, matching the +-- @time-units@ grammar shared with +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Indices.CreateIndexOptions' +-- (e.g. @('TimeUnitSeconds', 30)@ renders as @30s@). @wait_for_active_shards@ +-- reuses 'ActiveShardCount' so @AllActiveShards@ renders as @all@ and +-- @ActiveShards n@ as the bare decimal. @wait_for_nodes@ accepts the ES +-- comparison grammar verbatim (e.g. @"ge(2)"@, @">=2"@, or a bare node +-- count), hence it is typed as a plain 'Text'. +data ClusterHealthOptions = ClusterHealthOptions + { choLevel :: Maybe ClusterHealthLevel, + choLocal :: Maybe Bool, + choMasterTimeout :: Maybe (TimeUnits, Word32), + choWaitForStatus :: Maybe ClusterHealthStatus, + choWaitForActiveShards :: Maybe ActiveShardCount, + choWaitForNodes :: Maybe Text, + choWaitForNoRelocatingShards :: Maybe Bool, + choWaitForNoInitializingShards :: Maybe Bool, + choTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'ClusterHealthOptions' with every parameter set to 'Nothing'. Produces +-- no query string, so @'getClusterHealthWith' 'defaultClusterHealthOptions'@ +-- emits a request identical to 'getClusterHealth'. +defaultClusterHealthOptions :: ClusterHealthOptions +defaultClusterHealthOptions = + ClusterHealthOptions + { choLevel = Nothing, + choLocal = Nothing, + choMasterTimeout = Nothing, + choWaitForStatus = Nothing, + choWaitForActiveShards = Nothing, + choWaitForNodes = Nothing, + choWaitForNoRelocatingShards = Nothing, + choWaitForNoInitializingShards = Nothing, + choTimeout = Nothing + } + +choLevelLens :: Lens' ClusterHealthOptions (Maybe ClusterHealthLevel) +choLevelLens = lens choLevel (\x y -> x {choLevel = y}) + +choLocalLens :: Lens' ClusterHealthOptions (Maybe Bool) +choLocalLens = lens choLocal (\x y -> x {choLocal = y}) + +choMasterTimeoutLens :: Lens' ClusterHealthOptions (Maybe (TimeUnits, Word32)) +choMasterTimeoutLens = lens choMasterTimeout (\x y -> x {choMasterTimeout = y}) + +choWaitForStatusLens :: Lens' ClusterHealthOptions (Maybe ClusterHealthStatus) +choWaitForStatusLens = lens choWaitForStatus (\x y -> x {choWaitForStatus = y}) + +choWaitForActiveShardsLens :: Lens' ClusterHealthOptions (Maybe ActiveShardCount) +choWaitForActiveShardsLens = lens choWaitForActiveShards (\x y -> x {choWaitForActiveShards = y}) + +choWaitForNodesLens :: Lens' ClusterHealthOptions (Maybe Text) +choWaitForNodesLens = lens choWaitForNodes (\x y -> x {choWaitForNodes = y}) + +choWaitForNoRelocatingShardsLens :: Lens' ClusterHealthOptions (Maybe Bool) +choWaitForNoRelocatingShardsLens = lens choWaitForNoRelocatingShards (\x y -> x {choWaitForNoRelocatingShards = y}) + +choWaitForNoInitializingShardsLens :: Lens' ClusterHealthOptions (Maybe Bool) +choWaitForNoInitializingShardsLens = lens choWaitForNoInitializingShards (\x y -> x {choWaitForNoInitializingShards = y}) + +choTimeoutLens :: Lens' ClusterHealthOptions (Maybe (TimeUnits, Word32)) +choTimeoutLens = lens choTimeout (\x y -> x {choTimeout = y}) + +-- -------------------------------------------------------------------------- +-- Cluster allocation explain +-- -------------------------------------------------------------------------- + +-- | Request body for the @/_cluster/allocation/explain@ endpoint. ES +-- requires that if any of 'aerIndex', 'aerShard' or 'aerPrimary' is +-- supplied then all three must be supplied together; see +-- 'mkAllocationExplainRequest' for the canonical constructor. +-- 'aerCurrentNode' may be added to any of these forms to request an +-- explanation for a shard currently on the named node (e.g. during a +-- relocation). +-- +-- +data AllocationExplainRequest = AllocationExplainRequest + { aerIndex :: Maybe IndexName, + aerShard :: Maybe ShardId, + aerPrimary :: Maybe Bool, + aerCurrentNode :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'AllocationExplainRequest' with every field set to 'Nothing'. A body +-- of @{}@ asks the server to explain the first unassigned shard it finds +-- (or return an empty explanation if the cluster is fully allocated). +defaultAllocationExplainRequest :: AllocationExplainRequest +defaultAllocationExplainRequest = + AllocationExplainRequest + { aerIndex = Nothing, + aerShard = Nothing, + aerPrimary = Nothing, + aerCurrentNode = Nothing + } + +-- | Construct an 'AllocationExplainRequest' targeting a specific shard. +-- Per the ES contract the @index@, @shard@ and @primary@ fields must +-- appear together when any of them is present, so this constructor takes +-- all three at once. Pass 'Nothing' for 'aerCurrentNode' afterwards to +-- inspect a non-relocating shard. +mkAllocationExplainRequest :: + IndexName -> + ShardId -> + Bool -> + AllocationExplainRequest +mkAllocationExplainRequest indexName shardId primary = + AllocationExplainRequest + { aerIndex = Just indexName, + aerShard = Just shardId, + aerPrimary = Just primary, + aerCurrentNode = Nothing + } + +instance ToJSON AllocationExplainRequest where + toJSON AllocationExplainRequest {..} = + omitNulls + [ "index" .= (unIndexName <$> aerIndex), + "shard" .= (shardId <$> aerShard), + "primary" .= aerPrimary, + "current_node" .= aerCurrentNode + ] + +aerIndexLens :: Lens' AllocationExplainRequest (Maybe IndexName) +aerIndexLens = lens aerIndex (\x y -> x {aerIndex = y}) + +aerShardLens :: Lens' AllocationExplainRequest (Maybe ShardId) +aerShardLens = lens aerShard (\x y -> x {aerShard = y}) + +aerPrimaryLens :: Lens' AllocationExplainRequest (Maybe Bool) +aerPrimaryLens = lens aerPrimary (\x y -> x {aerPrimary = y}) + +aerCurrentNodeLens :: Lens' AllocationExplainRequest (Maybe Text) +aerCurrentNodeLens = lens aerCurrentNode (\x y -> x {aerCurrentNode = y}) + +-- | Structured subset of the response from +-- @/_cluster/allocation/explain@. The identifying fields +-- ('aeIndex', 'aeShard', 'aePrimary', 'aeCurrentState') are typed; +-- larger nested blobs ('aeCurrentNode', 'aeUnassignedInfo', +-- 'aeClusterInfo', 'aeNodes', 'aeDecisions') are kept as 'Value' for +-- consumption with the aeson 'Data.Aeson.Lens' combinators or direct +-- decoding, since their schema varies across ES\/OS versions and is +-- primarily consumed for diagnostics rather than program logic. +-- +-- Every field except 'aeCurrentState' and 'aeOther' is 'Maybe' because the server +-- omits them when they do not apply (e.g. an explanation for the +-- \"first unassigned shard\" carries no @index@\/@shard@\/@primary@ +-- until one is selected, and @current_node@ is absent for unassigned +-- shards). 'aeOther' captures the verbatim response object with every +-- key the typed fields above do not model (modern ES diagnostics such +-- as @can_remain_on_current_node@, @can_rebalance_cluster@, +-- @can_rebalance_to_other_node@, @rebalance_explanation@ and +-- @node_allocation_decisions@), so the payload round-trips through +-- 'ToJSON'\/'FromJSON' without loss; the 'aeXxxTyped' helpers below +-- lift the most useful of those keys into typed views. +-- +-- +data AllocationExplanation = AllocationExplanation + { aeIndex :: Maybe IndexName, + aeShard :: Maybe ShardId, + aePrimary :: Maybe Bool, + aeCurrentState :: Text, + aeCurrentNode :: Maybe Value, + aeRelocatingNode :: Maybe Value, + aeShardState :: Maybe Text, + aeUnassignedInfo :: Maybe Value, + aeAllocateDroning :: Maybe Bool, + aeClusterInfo :: Maybe Value, + aeNodes :: Maybe Value, + aeDecisions :: Maybe Value, + aeOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON AllocationExplanation where + parseJSON = withObject "AllocationExplanation" $ \o -> + AllocationExplanation + <$> o .:? "index" + <*> o .:? "shard" + <*> o .:? "primary" + <*> o .: "current_state" + <*> o .:? "current_node" + <*> o .:? "relocating_node" + <*> o .:? "shard_state" + <*> o .:? "unassigned_info" + <*> o .:? "allocate_droning" + <*> o .:? "cluster_info" + <*> o .:? "nodes" + <*> o .:? "decisions" + <*> pure (Object o) + +aeIndexLens :: Lens' AllocationExplanation (Maybe IndexName) +aeIndexLens = lens aeIndex (\x y -> x {aeIndex = y}) + +aeShardLens :: Lens' AllocationExplanation (Maybe ShardId) +aeShardLens = lens aeShard (\x y -> x {aeShard = y}) + +aePrimaryLens :: Lens' AllocationExplanation (Maybe Bool) +aePrimaryLens = lens aePrimary (\x y -> x {aePrimary = y}) + +aeCurrentStateLens :: Lens' AllocationExplanation Text +aeCurrentStateLens = lens aeCurrentState (\x y -> x {aeCurrentState = y}) + +aeCurrentNodeLens :: Lens' AllocationExplanation (Maybe Value) +aeCurrentNodeLens = lens aeCurrentNode (\x y -> x {aeCurrentNode = y}) + +aeRelocatingNodeLens :: Lens' AllocationExplanation (Maybe Value) +aeRelocatingNodeLens = lens aeRelocatingNode (\x y -> x {aeRelocatingNode = y}) + +aeShardStateLens :: Lens' AllocationExplanation (Maybe Text) +aeShardStateLens = lens aeShardState (\x y -> x {aeShardState = y}) + +aeUnassignedInfoLens :: Lens' AllocationExplanation (Maybe Value) +aeUnassignedInfoLens = lens aeUnassignedInfo (\x y -> x {aeUnassignedInfo = y}) + +aeAllocateDroningLens :: Lens' AllocationExplanation (Maybe Bool) +aeAllocateDroningLens = lens aeAllocateDroning (\x y -> x {aeAllocateDroning = y}) + +aeClusterInfoLens :: Lens' AllocationExplanation (Maybe Value) +aeClusterInfoLens = lens aeClusterInfo (\x y -> x {aeClusterInfo = y}) + +aeNodesLens :: Lens' AllocationExplanation (Maybe Value) +aeNodesLens = lens aeNodes (\x y -> x {aeNodes = y}) + +aeDecisionsLens :: Lens' AllocationExplanation (Maybe Value) +aeDecisionsLens = lens aeDecisions (\x y -> x {aeDecisions = y}) + +aeOtherLens :: Lens' AllocationExplanation Value +aeOtherLens = lens aeOther (\x y -> x {aeOther = y}) + +instance ToJSON AllocationExplanation where + toJSON ex = + case aeOther ex of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "index" .= (unIndexName <$> aeIndex ex), + "shard" .= (shardId <$> aeShard ex), + "primary" .= aePrimary ex, + "current_state" .= aeCurrentState ex, + "current_node" .= aeCurrentNode ex, + "relocating_node" .= aeRelocatingNode ex, + "shard_state" .= aeShardState ex, + "unassigned_info" .= aeUnassignedInfo ex, + "allocate_droning" .= aeAllocateDroning ex, + "cluster_info" .= aeClusterInfo ex, + "nodes" .= aeNodes ex, + "decisions" .= aeDecisions ex + ] + +-- -------------------------------------------------------------------------- +-- Typed views onto the @Value@ blobs +-- -------------------------------------------------------------------------- +-- + +-- $typedViews +-- +-- The maintainer's 'AllocationExplanation' deliberately keeps the +-- nested @current_node@, @unassigned_info@ and @decisions@ sub-objects +-- as 'Value' blobs because their schema varies across ES\/OS versions +-- and is primarily consumed for diagnostics. The records below give +-- callers an /opt-in/ path to typed access: each comes with a +-- 'FromJSON' instance (and a 'ToJSON' round-trip), and the +-- @aeXxxTyped@ helpers lift the corresponding 'Value' field into the +-- typed shape via aeson. Callers who need a key the typed record does +-- not expose can still drop down to the raw 'Value' and decode with +-- aeson directly. + +-- | Typed view of the @current_node@ sub-object carried by +-- 'aeCurrentNode'. The node identifier has been emitted under both +-- @id@ (modern ES\/OS) and @node_id@ (older ES, and the per-node +-- decision entries), and the display name similarly appears as @name@ +-- or @node_name@. The parser tries the primary key first then falls +-- back to the legacy key via the throwing 'Data.Aeson..:' accessor +-- wrapped in 'Just' (a naive @.?: \<|\> .:?@ would be dead code because +-- @.?:@ always succeeds with 'Nothing'). +data AllocationCurrentNode = AllocationCurrentNode + { acnId :: Maybe Text, + acnName :: Maybe Text, + acnTransportAddress :: Maybe Text, + acnAttributes :: Maybe Value, + acnDecision :: Maybe Text, + acnOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON AllocationCurrentNode where + parseJSON = withObject "AllocationCurrentNode" $ \o -> + AllocationCurrentNode + <$> resolveKey o "id" "node_id" + <*> resolveKey o "name" "node_name" + <*> o .:? "transport_address" + <*> o .:? "attributes" + <*> o .:? "node_decision" + <*> pure (Object o) + where + resolveKey o primary fallback = + (Just <$> o .: primary) <|> (Just <$> o .: fallback) <|> pure Nothing + +instance ToJSON AllocationCurrentNode where + toJSON cn = + case acnOther cn of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= acnId cn, + "name" .= acnName cn, + "transport_address" .= acnTransportAddress cn, + "attributes" .= acnAttributes cn, + "node_decision" .= acnDecision cn + ] + +acnIdLens :: Lens' AllocationCurrentNode (Maybe Text) +acnIdLens = lens acnId (\x y -> x {acnId = y}) + +acnNameLens :: Lens' AllocationCurrentNode (Maybe Text) +acnNameLens = lens acnName (\x y -> x {acnName = y}) + +acnTransportAddressLens :: Lens' AllocationCurrentNode (Maybe Text) +acnTransportAddressLens = lens acnTransportAddress (\x y -> x {acnTransportAddress = y}) + +acnAttributesLens :: Lens' AllocationCurrentNode (Maybe Value) +acnAttributesLens = lens acnAttributes (\x y -> x {acnAttributes = y}) + +acnDecisionLens :: Lens' AllocationCurrentNode (Maybe Text) +acnDecisionLens = lens acnDecision (\x y -> x {acnDecision = y}) + +acnOtherLens :: Lens' AllocationCurrentNode Value +acnOtherLens = lens acnOther (\x y -> x {acnOther = y}) + +-- | Typed view of the @unassigned_info@ sub-object carried by +-- 'aeUnassignedInfo'. Present when @current_state@ is @UNASSIGNED@; +-- carries the reason the shard became unassigned, the @at@ timestamp, +-- optional human-readable @details@, and the +-- @last_allocation_status@ the allocator last computed. Forward-compat +-- keys survive in 'auiOther'. +data AllocationUnassignedInfo = AllocationUnassignedInfo + { auiReason :: Maybe Text, + auiAt :: Maybe Text, + auiDetails :: Maybe Text, + auiLastAllocationStatus :: Maybe Text, + auiOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON AllocationUnassignedInfo where + parseJSON = withObject "AllocationUnassignedInfo" $ \o -> + AllocationUnassignedInfo + <$> o .:? "reason" + <*> o .:? "at" + <*> o .:? "details" + <*> o .:? "last_allocation_status" + <*> pure (Object o) + +instance ToJSON AllocationUnassignedInfo where + toJSON ui = + case auiOther ui of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "reason" .= auiReason ui, + "at" .= auiAt ui, + "details" .= auiDetails ui, + "last_allocation_status" .= auiLastAllocationStatus ui + ] + +auiReasonLens :: Lens' AllocationUnassignedInfo (Maybe Text) +auiReasonLens = lens auiReason (\x y -> x {auiReason = y}) + +auiAtLens :: Lens' AllocationUnassignedInfo (Maybe Text) +auiAtLens = lens auiAt (\x y -> x {auiAt = y}) + +auiDetailsLens :: Lens' AllocationUnassignedInfo (Maybe Text) +auiDetailsLens = lens auiDetails (\x y -> x {auiDetails = y}) + +auiLastAllocationStatusLens :: Lens' AllocationUnassignedInfo (Maybe Text) +auiLastAllocationStatusLens = lens auiLastAllocationStatus (\x y -> x {auiLastAllocationStatus = y}) + +auiOtherLens :: Lens' AllocationUnassignedInfo Value +auiOtherLens = lens auiOther (\x y -> x {auiOther = y}) + +-- | Typed view of a single entry of the @decisions@ array carried by +-- 'aeDecisions'. Each entry carries the @decider@ name (e.g. @filter@, +-- @same_shard@, @awareness@), its @decision@ (@YES@\/@NO@\/@THROTTLE@), +-- a human-readable @explanation@, and an optional decider-specific +-- @details@ sub-object. Forward-compat keys survive in 'adOther'. +-- +-- This shape matches the entries of both the legacy top-level +-- @decisions@ array and the modern nested +-- @node_allocation_decisions[].deciders@ list, so callers can decode +-- either with 'Data.Aeson.fromJSON' against this type. +data AllocationDecision = AllocationDecision + { adDecider :: Maybe Text, + adDecision :: Maybe Text, + adExplanation :: Maybe Text, + adDetails :: Maybe Value, + adOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON AllocationDecision where + parseJSON = withObject "AllocationDecision" $ \o -> + AllocationDecision + <$> o .:? "decider" + <*> o .:? "decision" + <*> o .:? "explanation" + <*> o .:? "details" + <*> pure (Object o) + +instance ToJSON AllocationDecision where + toJSON d = + case adOther d of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "decider" .= adDecider d, + "decision" .= adDecision d, + "explanation" .= adExplanation d, + "details" .= adDetails d + ] + +adDeciderLens :: Lens' AllocationDecision (Maybe Text) +adDeciderLens = lens adDecider (\x y -> x {adDecider = y}) + +adDecisionLens :: Lens' AllocationDecision (Maybe Text) +adDecisionLens = lens adDecision (\x y -> x {adDecision = y}) + +adExplanationLens :: Lens' AllocationDecision (Maybe Text) +adExplanationLens = lens adExplanation (\x y -> x {adExplanation = y}) + +adDetailsLens :: Lens' AllocationDecision (Maybe Value) +adDetailsLens = lens adDetails (\x y -> x {adDetails = y}) + +adOtherLens :: Lens' AllocationDecision Value +adOtherLens = lens adOther (\x y -> x {adOther = y}) + +-- | Decode the 'aeCurrentNode' blob into a typed 'AllocationCurrentNode'. +-- Returns 'Nothing' when the field is absent (e.g. for an unassigned +-- shard) or when the underlying 'Value' is not a JSON object. +aeCurrentNodeTyped :: AllocationExplanation -> Maybe AllocationCurrentNode +aeCurrentNodeTyped ex = aeCurrentNode ex >>= parseMaybe parseJSON + +-- | Decode the 'aeUnassignedInfo' blob into a typed +-- 'AllocationUnassignedInfo'. Returns 'Nothing' when the field is +-- absent (e.g. for an assigned shard) or when the underlying 'Value' +-- is not a JSON object. +aeUnassignedInfoTyped :: AllocationExplanation -> Maybe AllocationUnassignedInfo +aeUnassignedInfoTyped ex = aeUnassignedInfo ex >>= parseMaybe parseJSON + +-- | Decode the 'aeDecisions' blob into a typed list of +-- 'AllocationDecision'. Returns 'Nothing' when the field is absent or +-- when the underlying 'Value' is not a JSON array of objects. +aeDecisionsTyped :: AllocationExplanation -> Maybe [AllocationDecision] +aeDecisionsTyped ex = aeDecisions ex >>= parseMaybe parseJSON + +-- -------------------------------------------------------------------------- +-- Modern ES allocation diagnostics (can_* / node_allocation_decisions) +-- -------------------------------------------------------------------------- +-- +-- ES 7.x+ emits a richer top-level diagnostic set alongside the legacy +-- @decisions@ array: scalar @can_remain_on_current_node@, +-- @can_rebalance_cluster@, @can_rebalance_to_other_node@ and +-- @rebalance_explanation@ fields, plus a @node_allocation_decisions@ +-- array whose entries each carry per-node diagnostics (node identity, +-- @node_decision@, @weight_ranking@) and a nested @deciders@ list. The +-- @deciders@ entries share their shape with the legacy top-level +-- @decisions@ entries, so they reuse 'AllocationDecision'. +-- +-- The keys survive verbatim in 'aeOther'; the helpers below lift the +-- most useful ones into typed values via aeson. + +-- | Typed view of a single entry of the @node_allocation_decisions@ +-- array emitted by modern ES. For entries in this array the node +-- identifier appears under @node_id@ (modern ES\/OS) with @id@ as a +-- fallback for older ES shapes, and the display name appears under +-- @node_name@ with @name@ as a fallback. (This is the reverse +-- orientation from 'AllocationCurrentNode', whose @current_node@ +-- sub-object prefers @id@\/@name@ — both orientations are intentional +-- and match what real ES responses emit for their respective +-- sub-objects.) The parser tries the primary key first then falls +-- back via the throwing '.:' accessor wrapped in 'Just' (a naive +-- @.?: \<|\> .:?@ would be dead code because @.?:@ always succeeds +-- with 'Nothing'). Forward-compat keys survive in 'nadOther'. +data NodeAllocationDecision = NodeAllocationDecision + { nadNodeId :: Maybe Text, + nadNodeName :: Maybe Text, + nadTransportAddress :: Maybe Text, + nadRoles :: Maybe Value, + nadNodeAttributes :: Maybe Value, + nadNodeDecision :: Maybe Text, + nadWeightRanking :: Maybe Int, + nadDeciders :: Maybe [AllocationDecision], + nadOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON NodeAllocationDecision where + parseJSON = withObject "NodeAllocationDecision" $ \o -> + NodeAllocationDecision + <$> resolveKey o "node_id" "id" + <*> resolveKey o "node_name" "name" + <*> o .:? "transport_address" + <*> o .:? "roles" + <*> o .:? "node_attributes" + <*> o .:? "node_decision" + <*> o .:? "weight_ranking" + <*> o .:? "deciders" + <*> pure (Object o) + where + resolveKey o primary fallback = + (Just <$> o .: primary) <|> (Just <$> o .: fallback) <|> pure Nothing + +instance ToJSON NodeAllocationDecision where + toJSON d = + case nadOther d of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "node_id" .= nadNodeId d, + "node_name" .= nadNodeName d, + "transport_address" .= nadTransportAddress d, + "roles" .= nadRoles d, + "node_attributes" .= nadNodeAttributes d, + "node_decision" .= nadNodeDecision d, + "weight_ranking" .= nadWeightRanking d, + "deciders" .= nadDeciders d + ] + +nadNodeIdLens :: Lens' NodeAllocationDecision (Maybe Text) +nadNodeIdLens = lens nadNodeId (\x y -> x {nadNodeId = y}) + +nadNodeNameLens :: Lens' NodeAllocationDecision (Maybe Text) +nadNodeNameLens = lens nadNodeName (\x y -> x {nadNodeName = y}) + +nadTransportAddressLens :: Lens' NodeAllocationDecision (Maybe Text) +nadTransportAddressLens = lens nadTransportAddress (\x y -> x {nadTransportAddress = y}) + +nadRolesLens :: Lens' NodeAllocationDecision (Maybe Value) +nadRolesLens = lens nadRoles (\x y -> x {nadRoles = y}) + +nadNodeAttributesLens :: Lens' NodeAllocationDecision (Maybe Value) +nadNodeAttributesLens = lens nadNodeAttributes (\x y -> x {nadNodeAttributes = y}) + +nadNodeDecisionLens :: Lens' NodeAllocationDecision (Maybe Text) +nadNodeDecisionLens = lens nadNodeDecision (\x y -> x {nadNodeDecision = y}) + +nadWeightRankingLens :: Lens' NodeAllocationDecision (Maybe Int) +nadWeightRankingLens = lens nadWeightRanking (\x y -> x {nadWeightRanking = y}) + +nadDecidersLens :: Lens' NodeAllocationDecision (Maybe [AllocationDecision]) +nadDecidersLens = lens nadDeciders (\x y -> x {nadDeciders = y}) + +nadOtherLens :: Lens' NodeAllocationDecision Value +nadOtherLens = lens nadOther (\x y -> x {nadOther = y}) + +-- | Extract the @can_remain_on_current_node@ scalar from the +-- 'aeOther' blob. Returns 'Nothing' when the key is absent or the +-- 'aeOther' blob is not a JSON object. +aeCanRemainOnCurrentNodeTyped :: AllocationExplanation -> Maybe Text +aeCanRemainOnCurrentNodeTyped ex = aeKey ex "can_remain_on_current_node" + +-- | Extract the @can_rebalance_cluster@ scalar from the 'aeOther' blob. +-- Returns 'Nothing' when the key is absent or the 'aeOther' blob is not +-- a JSON object. +aeCanRebalanceClusterTyped :: AllocationExplanation -> Maybe Text +aeCanRebalanceClusterTyped ex = aeKey ex "can_rebalance_cluster" + +-- | Extract the @can_rebalance_to_other_node@ scalar from the 'aeOther' +-- blob. Returns 'Nothing' when the key is absent or the 'aeOther' blob +-- is not a JSON object. +aeCanRebalanceToOtherNodeTyped :: AllocationExplanation -> Maybe Text +aeCanRebalanceToOtherNodeTyped ex = aeKey ex "can_rebalance_to_other_node" + +-- | Extract the @rebalance_explanation@ scalar from the 'aeOther' blob. +-- Returns 'Nothing' when the key is absent or the 'aeOther' blob is not +-- a JSON object. +aeRebalanceExplanationTyped :: AllocationExplanation -> Maybe Text +aeRebalanceExplanationTyped ex = aeKey ex "rebalance_explanation" + +-- | Decode the @node_allocation_decisions@ array from the 'aeOther' blob +-- into a typed list of 'NodeAllocationDecision'. Returns 'Nothing' when +-- the key is absent or the underlying 'Value' is not a JSON array of +-- objects. +aeNodeAllocationDecisionsTyped :: AllocationExplanation -> Maybe [NodeAllocationDecision] +aeNodeAllocationDecisionsTyped ex = aeKey ex "node_allocation_decisions" >>= parseMaybe parseJSON + +-- | Project a single key from the 'aeOther' blob as a decoded value. +-- Returns 'Nothing' when 'aeOther' is not a JSON object or the key is +-- missing. Used by the @aeCanRemainOnCurrentNodeTyped@, +-- @aeCanRebalanceClusterTyped@, @aeCanRebalanceToOtherNodeTyped@, +-- @aeRebalanceExplanationTyped@ and @aeNodeAllocationDecisionsTyped@ +-- helpers above. +aeKey :: (FromJSON a) => AllocationExplanation -> Key -> Maybe a +aeKey ex key = + case aeOther ex of + Object o -> KM.lookup key o >>= parseMaybe parseJSON + _ -> Nothing + +-- | Merge typed @(key, value)@ pairs into a 'KM.KeyMap', dropping +-- @Null@ values (matching 'omitNulls' semantics). Typed pairs whose +-- value is non-@Null@ take precedence over stale duplicates in the +-- @*Other@ blob so round-trips overwrite the verbatim entries with the +-- typed projections; @Null@ typed values defer to the blob so that +-- round-trips preserve keys the typed record omits. Mirrors the helper +-- in +-- "Database.Bloodhound.Internal.Versions.Common.Types.PendingTask". +mergeIgnoringNulls :: [(Key, Value)] -> KM.KeyMap Value -> KM.KeyMap Value +mergeIgnoringNulls kvs o = KM.union (KM.fromList (filter notNull kvs)) o + where + notNull (_, Null) = False + notNull _ = True diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/ClusterSettings.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/ClusterSettings.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/ClusterSettings.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.Common.Types.ClusterSettings + ( -- * Cluster settings response + ClusterSettings (..), + + -- * Cluster settings GET options + ClusterSettingsOptions (..), + defaultClusterSettingsOptions, + clusterSettingsOptionsParams, + + -- * Cluster settings update body + ClusterSettingsUpdate (..), + defaultClusterSettingsUpdate, + + -- * Cluster settings update options + ClusterSettingsUpdateOptions (..), + defaultClusterSettingsUpdateOptions, + clusterSettingsUpdateOptionsParams, + + -- * Optics + clusterSettingsPersistentLens, + clusterSettingsTransientLens, + clusterSettingsDefaultsLens, + csoFlatSettingsLens, + csoMasterTimeoutLens, + csoIncludeDefaultsLens, + clusterSettingsUpdatePersistentLens, + clusterSettingsUpdateTransientLens, + csuoFlatSettingsLens, + csuoMasterTimeoutLens, + ) +where + +import Data.Aeson +import Data.HashMap.Strict (HashMap) +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Units (TimeUnits, timeUnitsSuffix) + +-- | Response body for @GET /_cluster/settings@. Carries the cluster-wide +-- settings split between the two writeable layers — @persistent@ (stored +-- in the cluster state, survives full restarts) and @transient@ (also +-- stored in the cluster state but cleared on a full restart) — and, when +-- the request was issued with @include_defaults=true@, a third @defaults@ +-- layer containing the built-in values. +-- +-- Each layer is exposed as an opaque 'HashMap' of JSON 'Value's. With +-- @flat_settings=false@ (the default) the keys form a nested object tree +-- (e.g. @cluster.routing.allocation.disk.watermark.low@ is a deeply +-- nested object); with @flat_settings=true@ the same data is returned as +-- a flat map of dotted keys to scalar values. Both shapes decode into +-- the same 'HashMap' representation — callers that want typed access to +-- individual settings should reach for the @UpdatableIndexSetting@ type +-- (for writes) or decode the relevant sub-object themselves. +-- +-- () +data ClusterSettings = ClusterSettings + { clusterSettingsPersistent :: HashMap Text Value, + clusterSettingsTransient :: HashMap Text Value, + clusterSettingsDefaults :: Maybe (HashMap Text Value) + } + deriving stock (Eq, Show) + +clusterSettingsPersistentLens :: Lens' ClusterSettings (HashMap Text Value) +clusterSettingsPersistentLens = lens clusterSettingsPersistent (\x y -> x {clusterSettingsPersistent = y}) + +clusterSettingsTransientLens :: Lens' ClusterSettings (HashMap Text Value) +clusterSettingsTransientLens = lens clusterSettingsTransient (\x y -> x {clusterSettingsTransient = y}) + +clusterSettingsDefaultsLens :: Lens' ClusterSettings (Maybe (HashMap Text Value)) +clusterSettingsDefaultsLens = lens clusterSettingsDefaults (\x y -> x {clusterSettingsDefaults = y}) + +instance FromJSON ClusterSettings where + parseJSON = withObject "ClusterSettings" $ \o -> + ClusterSettings + <$> o .:? "persistent" .!= mempty + <*> o .:? "transient" .!= mempty + <*> o .:? "defaults" + +instance ToJSON ClusterSettings where + toJSON ClusterSettings {..} = + object $ + [ "persistent" .= clusterSettingsPersistent, + "transient" .= clusterSettingsTransient + ] + ++ [ "defaults" .= defaults + | Just defaults <- [clusterSettingsDefaults] + ] + +-- | The URI parameters accepted by @GET /_cluster/settings@ that are +-- modelled here: @flat_settings@ (render the settings as a flat @a.b.c@ +-- map instead of a nested object tree), @master_timeout@ (the pre-7.16 +-- alias of @cluster_manager_timeout@, still accepted by every supported +-- backend) and @include_defaults@ (also return the built-in default +-- values in a separate @defaults@ layer). A couple of rarely-needed +-- parameters (@timeout@, @include_type_name@ on ES ≤ 7.x) are not +-- modelled. Every field is optional so +-- 'defaultClusterSettingsOptions' renders to no parameters at all — +-- byte-for-byte identical to a parameterless call. +data ClusterSettingsOptions = ClusterSettingsOptions + { csoFlatSettings :: Maybe Bool, + csoMasterTimeout :: Maybe (TimeUnits, Word32), + csoIncludeDefaults :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'ClusterSettingsOptions' with every parameter set to 'Nothing'. +-- Produces no query string, so @'getClusterSettingsWith' +-- 'defaultClusterSettingsOptions'@ emits a request identical to +-- 'getClusterSettings'. +defaultClusterSettingsOptions :: ClusterSettingsOptions +defaultClusterSettingsOptions = + ClusterSettingsOptions + { csoFlatSettings = Nothing, + csoMasterTimeout = Nothing, + csoIncludeDefaults = Nothing + } + +csoFlatSettingsLens :: Lens' ClusterSettingsOptions (Maybe Bool) +csoFlatSettingsLens = lens csoFlatSettings (\x y -> x {csoFlatSettings = y}) + +csoMasterTimeoutLens :: Lens' ClusterSettingsOptions (Maybe (TimeUnits, Word32)) +csoMasterTimeoutLens = lens csoMasterTimeout (\x y -> x {csoMasterTimeout = y}) + +csoIncludeDefaultsLens :: Lens' ClusterSettingsOptions (Maybe Bool) +csoIncludeDefaultsLens = lens csoIncludeDefaults (\x y -> x {csoIncludeDefaults = y}) + +-- | Render 'ClusterSettingsOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultClusterSettingsOptions' produces an empty list (and therefore +-- no query string). +clusterSettingsOptionsParams :: ClusterSettingsOptions -> [(Text, Maybe Text)] +clusterSettingsOptionsParams opts = + catMaybes + [ ("flat_settings",) . Just . renderBool <$> csoFlatSettings opts, + ("master_timeout",) . Just . renderDuration <$> csoMasterTimeout opts, + ("include_defaults",) . Just . renderBool <$> csoIncludeDefaults opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +-- | Request body for @PUT /_cluster/settings@. Mirrors the writeable +-- layers of 'ClusterSettings' — @persistent@ (stored in the cluster +-- state, survives full restarts) and @transient@ (cleared on a full +-- restart) — but drops the read-only @defaults@ layer. Each layer is an +-- opaque 'HashMap' of JSON 'Value's; assign 'Null' to a key to clear it. +-- +-- Both fields are 'Maybe' so a caller can express \"leave this layer +-- untouched\": 'Nothing' omits the key from the body entirely, while +-- 'Just' a (possibly empty) map emits it. 'defaultClusterSettingsUpdate' +-- therefore renders to the empty object @{}@, which Elasticsearch +-- accepts as a no-op. +-- +-- /Note:/ there is intentionally no 'FromJSON' instance — the +-- @GET /_cluster/settings@ response should be decoded into +-- 'ClusterSettings', which models the additional @defaults@ layer. +-- +-- () +data ClusterSettingsUpdate = ClusterSettingsUpdate + { clusterSettingsUpdatePersistent :: Maybe (HashMap Text Value), + clusterSettingsUpdateTransient :: Maybe (HashMap Text Value) + } + deriving stock (Eq, Show) + +-- | 'ClusterSettingsUpdate' with both layers set to 'Nothing'. Renders +-- to the empty object @{}@, leaving every cluster setting untouched. +defaultClusterSettingsUpdate :: ClusterSettingsUpdate +defaultClusterSettingsUpdate = + ClusterSettingsUpdate + { clusterSettingsUpdatePersistent = Nothing, + clusterSettingsUpdateTransient = Nothing + } + +clusterSettingsUpdatePersistentLens :: Lens' ClusterSettingsUpdate (Maybe (HashMap Text Value)) +clusterSettingsUpdatePersistentLens = + lens clusterSettingsUpdatePersistent (\x y -> x {clusterSettingsUpdatePersistent = y}) + +clusterSettingsUpdateTransientLens :: Lens' ClusterSettingsUpdate (Maybe (HashMap Text Value)) +clusterSettingsUpdateTransientLens = + lens clusterSettingsUpdateTransient (\x y -> x {clusterSettingsUpdateTransient = y}) + +instance ToJSON ClusterSettingsUpdate where + toJSON ClusterSettingsUpdate {..} = + object $ + catMaybes + [ ("persistent" .=) <$> clusterSettingsUpdatePersistent, + ("transient" .=) <$> clusterSettingsUpdateTransient + ] + +-- | The URI parameters accepted by @PUT /_cluster/settings@ that are +-- modelled here: @flat_settings@ (store the update as a flat @a.b.c@ +-- map rather than a nested object tree) and @master_timeout@ (the +-- pre-7.16 alias of @cluster_manager_timeout@, still accepted by every +-- supported backend). The @GET@-only @include_defaults@ parameter does +-- not apply on writes and is therefore absent. Every field is optional +-- so 'defaultClusterSettingsUpdateOptions' renders to no parameters at +-- all — byte-for-byte identical to a parameterless call. +data ClusterSettingsUpdateOptions = ClusterSettingsUpdateOptions + { csuoFlatSettings :: Maybe Bool, + csuoMasterTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'ClusterSettingsUpdateOptions' with every parameter set to +-- 'Nothing'. Produces no query string, so @'updateClusterSettingsWith' +-- 'defaultClusterSettingsUpdateOptions'@ emits a request identical to +-- 'updateClusterSettings'. +defaultClusterSettingsUpdateOptions :: ClusterSettingsUpdateOptions +defaultClusterSettingsUpdateOptions = + ClusterSettingsUpdateOptions + { csuoFlatSettings = Nothing, + csuoMasterTimeout = Nothing + } + +csuoFlatSettingsLens :: Lens' ClusterSettingsUpdateOptions (Maybe Bool) +csuoFlatSettingsLens = lens csuoFlatSettings (\x y -> x {csuoFlatSettings = y}) + +csuoMasterTimeoutLens :: Lens' ClusterSettingsUpdateOptions (Maybe (TimeUnits, Word32)) +csuoMasterTimeoutLens = lens csuoMasterTimeout (\x y -> x {csuoMasterTimeout = y}) + +-- | Render 'ClusterSettingsUpdateOptions' as a list of @(key, value)@ +-- pairs suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultClusterSettingsUpdateOptions' produces an empty list (and +-- therefore no query string). +clusterSettingsUpdateOptionsParams :: ClusterSettingsUpdateOptions -> [(Text, Maybe Text)] +clusterSettingsUpdateOptionsParams opts = + catMaybes + [ ("flat_settings",) . Just . renderBool <$> csuoFlatSettings opts, + ("master_timeout",) . Just . renderDuration <$> csuoMasterTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/ClusterState.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/ClusterState.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/ClusterState.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.Common.Types.ClusterState + ( ClusterState (..), + ClusterStateNode (..), + ClusterStateMetadata (..), + ClusterStateRoutingTable (..), + + -- * @GET /_cluster/state@ options + ClusterStateMetric (..), + renderClusterStateMetric, + ClusterStateOptions (..), + defaultClusterStateOptions, + clusterStateOptionsParams, + clusterStateOptionsPathSegments, + + -- * Optics + clusterStateClusterNameLens, + clusterStateClusterUuidLens, + clusterStateVersionLens, + clusterStateStateUuidLens, + clusterStateMasterNodeLens, + clusterStateNodesLens, + clusterStateMetadataLens, + clusterStateRoutingTableLens, + cstoMetricsLens, + cstoIndicesLens, + cstoLocalLens, + cstoMasterTimeoutLens, + cstoWaitForMetadataVersionLens, + cstoFilterPathLens, + ) +where + +import Data.Aeson +import Data.HashMap.Strict (HashMap) +import Data.Text qualified as T +import Data.Word (Word32, Word64) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( IndexName, + unIndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Units + ( TimeUnits, + timeUnitsSuffix, + ) + +newtype ClusterStateRoutingTable = ClusterStateRoutingTable + { clusterStateRoutingTableIndices :: HashMap Text Value + } + deriving stock (Eq, Show) + +instance FromJSON ClusterStateRoutingTable where + parseJSON = withObject "ClusterStateRoutingTable" $ \o -> + ClusterStateRoutingTable <$> o .:? "indices" .!= mempty + +instance ToJSON ClusterStateRoutingTable where + toJSON (ClusterStateRoutingTable indices) = object ["indices" .= indices] + +newtype ClusterStateMetadata = ClusterStateMetadata + { clusterStateMetadataIndices :: HashMap Text Value + } + deriving stock (Eq, Show) + +instance FromJSON ClusterStateMetadata where + parseJSON = withObject "ClusterStateMetadata" $ \o -> + ClusterStateMetadata <$> o .:? "indices" .!= mempty + +instance ToJSON ClusterStateMetadata where + toJSON (ClusterStateMetadata indices) = object ["indices" .= indices] + +data ClusterStateNode = ClusterStateNode + { clusterStateNodeName :: Text, + clusterStateNodeEphemeralId :: Text, + clusterStateNodeTransportAddress :: Text, + clusterStateNodeAttributes :: HashMap Text Value + } + deriving stock (Eq, Show) + +instance FromJSON ClusterStateNode where + parseJSON = withObject "ClusterStateNode" $ \o -> + ClusterStateNode + <$> o .: "name" + <*> o .: "ephemeral_id" + <*> o .: "transport_address" + <*> o .:? "attributes" .!= mempty + +instance ToJSON ClusterStateNode where + toJSON ClusterStateNode {..} = + object + [ "name" .= clusterStateNodeName, + "ephemeral_id" .= clusterStateNodeEphemeralId, + "transport_address" .= clusterStateNodeTransportAddress, + "attributes" .= clusterStateNodeAttributes + ] + +data ClusterState = ClusterState + { clusterStateClusterName :: Text, + clusterStateClusterUuid :: Text, + clusterStateVersion :: Int, + clusterStateStateUuid :: Text, + clusterStateMasterNode :: Maybe Text, + clusterStateNodes :: HashMap Text ClusterStateNode, + clusterStateMetadata :: Maybe ClusterStateMetadata, + clusterStateRoutingTable :: Maybe ClusterStateRoutingTable + } + deriving stock (Eq, Show) + +clusterStateClusterNameLens :: Lens' ClusterState Text +clusterStateClusterNameLens = lens clusterStateClusterName (\x y -> x {clusterStateClusterName = y}) + +clusterStateClusterUuidLens :: Lens' ClusterState Text +clusterStateClusterUuidLens = lens clusterStateClusterUuid (\x y -> x {clusterStateClusterUuid = y}) + +clusterStateVersionLens :: Lens' ClusterState Int +clusterStateVersionLens = lens clusterStateVersion (\x y -> x {clusterStateVersion = y}) + +clusterStateStateUuidLens :: Lens' ClusterState Text +clusterStateStateUuidLens = lens clusterStateStateUuid (\x y -> x {clusterStateStateUuid = y}) + +clusterStateMasterNodeLens :: Lens' ClusterState (Maybe Text) +clusterStateMasterNodeLens = lens clusterStateMasterNode (\x y -> x {clusterStateMasterNode = y}) + +clusterStateNodesLens :: Lens' ClusterState (HashMap Text ClusterStateNode) +clusterStateNodesLens = lens clusterStateNodes (\x y -> x {clusterStateNodes = y}) + +clusterStateMetadataLens :: Lens' ClusterState (Maybe ClusterStateMetadata) +clusterStateMetadataLens = lens clusterStateMetadata (\x y -> x {clusterStateMetadata = y}) + +clusterStateRoutingTableLens :: Lens' ClusterState (Maybe ClusterStateRoutingTable) +clusterStateRoutingTableLens = lens clusterStateRoutingTable (\x y -> x {clusterStateRoutingTable = y}) + +instance FromJSON ClusterState where + parseJSON = withObject "ClusterState" $ \o -> + ClusterState + <$> o .: "cluster_name" + <*> o .: "cluster_uuid" + <*> o .: "version" + <*> o .: "state_uuid" + <*> o .:? "master_node" + <*> o .:? "nodes" .!= mempty + <*> o .:? "metadata" + <*> o .:? "routing_table" + +instance ToJSON ClusterState where + toJSON ClusterState {..} = + object $ + [ "cluster_name" .= clusterStateClusterName, + "cluster_uuid" .= clusterStateClusterUuid, + "version" .= clusterStateVersion, + "state_uuid" .= clusterStateStateUuid, + "nodes" .= clusterStateNodes + ] + ++ ["master_node" .= clusterStateMasterNode | Just _ <- [clusterStateMasterNode]] + ++ ["metadata" .= clusterStateMetadata | Just _ <- [clusterStateMetadata]] + ++ ["routing_table" .= clusterStateRoutingTable | Just _ <- [clusterStateRoutingTable]] + +-- | Metric filter segment for @GET /_cluster/state\/{metric}@. Each +-- constructor renders to the wire name ES\/OS expect between the +-- @state@ and @index@ path segments. The full set documented at +-- +-- is modelled except for the catch-all @_all@, which is what +-- 'ClusterStateOptions' emits by omission (when 'cstoMetrics' is +-- 'Nothing'). The enum is closed — no @OtherClusterStateMetric Text@ +-- constructor — so 'Enum' and 'Bounded' are sound derivations. The +-- library never enumerates the full set at runtime; the test suite +-- uses @[minBound .. maxBound]@ to verify the wire-name mapping is +-- total and injective. +data ClusterStateMetric + = ClusterStateMetricBlocks + | ClusterStateMetricCustomMetadata + | ClusterStateMetricMasterNode + | ClusterStateMetricMetadata + | ClusterStateMetricNodes + | ClusterStateMetricRoutingNodes + | ClusterStateMetricRoutingTable + | ClusterStateMetricSettings + | ClusterStateMetricVersion + deriving stock (Eq, Show, Enum, Bounded) + +-- | Render a single 'ClusterStateMetric' as its wire name. Stable +-- across every supported backend (ES 7\/8\/9, OS 1\/2\/3). +renderClusterStateMetric :: ClusterStateMetric -> Text +renderClusterStateMetric m = case m of + ClusterStateMetricBlocks -> "blocks" + ClusterStateMetricCustomMetadata -> "custom_metadata" + ClusterStateMetricMasterNode -> "master_node" + ClusterStateMetricMetadata -> "metadata" + ClusterStateMetricNodes -> "nodes" + ClusterStateMetricRoutingNodes -> "routing_nodes" + ClusterStateMetricRoutingTable -> "routing_table" + ClusterStateMetricSettings -> "settings" + ClusterStateMetricVersion -> "version" + +-- | The URI shape of @GET /_cluster/state@: a 'Nothing' field is +-- omitted (the server then applies its default — @\"_all\"@ on both +-- metric and index filters). Every field is optional so +-- 'defaultClusterStateOptions' produces a parameterless request +-- byte-for-byte identical to the legacy 'getClusterState'. +-- +-- /Path components./ The ES API takes the metric and index filters as +-- additional path segments (@GET /_cluster/state/{metric}/{index}@) +-- rather than query parameters. They are therefore rendered into the +-- endpoint path by 'clusterStateOptionsPathSegments'; only the +-- remaining parameters stay on the query string via +-- 'clusterStateOptionsParams'. +-- +-- /Index filter./ Comma-separated when multiple are given, mirroring +-- the metric filter. The server accepts index expressions (wildcards, +-- @-@ exclusions); they are passed through verbatim via 'IndexName'. +data ClusterStateOptions = ClusterStateOptions + { -- | @GET /_cluster/state/{metric}@ — limit which top-level sections + -- come back. 'Nothing' renders as the server default (@_all@). + cstoMetrics :: Maybe (NonEmpty ClusterStateMetric), + -- | @GET /_cluster/state/{metric}/{index}@ — only meaningful when + -- 'cstoMetrics' includes 'ClusterStateMetricMetadata' or + -- 'ClusterStateMetricRoutingTable' (otherwise the server ignores + -- it). 'Nothing' renders as @_all@. + cstoIndices :: Maybe (NonEmpty IndexName), + -- | @local=true@ — return the local node's view of the cluster + -- state instead of the master's. Cheaper, eventually consistent. + cstoLocal :: Maybe Bool, + -- | @master_timeout@ — time to wait for the master. The pre-7.16 + -- alias of @cluster_manager_timeout@, still accepted by every + -- supported backend. + cstoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | @wait_for_metadata_version@ — block until the cluster's + -- metadata version reaches at least this value (ES 7.9+). + cstoWaitForMetadataVersion :: Maybe Word64, + -- | @filter_path@ — comma-separated list of dotted filters that + -- restrict which fields come back in the response. Comma-joined + -- when multiple are given. /Note:/ individual filters must not + -- themselves contain commas — no escaping is performed. + cstoFilterPath :: Maybe (NonEmpty Text) + } + deriving stock (Eq, Show) + +-- | 'ClusterStateOptions' with every parameter set to 'Nothing'. +-- Produces no path segments beyond @/_cluster/state@ and no query +-- string, so @'getClusterStateWith' 'defaultClusterStateOptions'@ +-- emits a request identical to 'getClusterState'. +defaultClusterStateOptions :: ClusterStateOptions +defaultClusterStateOptions = + ClusterStateOptions + { cstoMetrics = Nothing, + cstoIndices = Nothing, + cstoLocal = Nothing, + cstoMasterTimeout = Nothing, + cstoWaitForMetadataVersion = Nothing, + cstoFilterPath = Nothing + } + +cstoMetricsLens :: Lens' ClusterStateOptions (Maybe (NonEmpty ClusterStateMetric)) +cstoMetricsLens = lens cstoMetrics (\x y -> x {cstoMetrics = y}) + +cstoIndicesLens :: Lens' ClusterStateOptions (Maybe (NonEmpty IndexName)) +cstoIndicesLens = lens cstoIndices (\x y -> x {cstoIndices = y}) + +cstoLocalLens :: Lens' ClusterStateOptions (Maybe Bool) +cstoLocalLens = lens cstoLocal (\x y -> x {cstoLocal = y}) + +cstoMasterTimeoutLens :: Lens' ClusterStateOptions (Maybe (TimeUnits, Word32)) +cstoMasterTimeoutLens = lens cstoMasterTimeout (\x y -> x {cstoMasterTimeout = y}) + +cstoWaitForMetadataVersionLens :: Lens' ClusterStateOptions (Maybe Word64) +cstoWaitForMetadataVersionLens = + lens cstoWaitForMetadataVersion (\x y -> x {cstoWaitForMetadataVersion = y}) + +cstoFilterPathLens :: Lens' ClusterStateOptions (Maybe (NonEmpty Text)) +cstoFilterPathLens = lens cstoFilterPath (\x y -> x {cstoFilterPath = y}) + +-- | Render the path-segment portion of 'ClusterStateOptions' — i.e. +-- the @{metric}@ and @{index}@ filters of +-- @GET /_cluster/state/{metric}/{index}@. Returns the empty list when +-- neither filter is set, so the caller can prepend @["_cluster", "state"]@ +-- and concatenate without further branching. Multiple metrics or +-- indices are comma-joined per the ES API contract. +-- +-- /Note:/ the @index@ segment is only meaningful when @metric@ is +-- present (the server routes @GET /_cluster/state//foo@ to a 400). +-- The renderer therefore emits the index segment only when the metric +-- segment is also present; if a caller sets 'cstoIndices' without +-- 'cstoMetrics' the index filter is silently dropped. The drop is +-- total (no exception) because it is behaviourally inert: with no +-- metric segment the server applies its @_all@ default, which +-- already spans every index, so the dropped filter could not have +-- narrowed the response anyway. +clusterStateOptionsPathSegments :: ClusterStateOptions -> [Text] +clusterStateOptionsPathSegments opts = + catMaybes + [ metricSeg, + indexSeg + ] + where + metricSeg = + csv renderClusterStateMetric <$> cstoMetrics opts + indexSeg + | Just _ <- cstoMetrics opts = csv unIndexName <$> cstoIndices opts + | otherwise = Nothing + csv render = T.intercalate "," . map render . toList + +-- | Render the query-string portion of 'ClusterStateOptions' — +-- everything that is /not/ a path segment — as a list of +-- @(key, value)@ pairs suitable for 'withQueries'. 'Nothing' fields +-- are omitted, so 'defaultClusterStateOptions' produces the empty +-- list (and therefore no query string). +clusterStateOptionsParams :: ClusterStateOptions -> [(Text, Maybe Text)] +clusterStateOptionsParams opts = + catMaybes + [ ("local",) . Just . renderBool <$> cstoLocal opts, + ("master_timeout",) . Just . renderDuration <$> cstoMasterTimeout opts, + ("wait_for_metadata_version",) . Just . showText <$> cstoWaitForMetadataVersion opts, + ("filter_path",) . Just . T.intercalate "," . toList <$> cstoFilterPath opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/ClusterStats.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/ClusterStats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/ClusterStats.hs @@ -0,0 +1,583 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.Common.Types.ClusterStats + ( -- * Cluster stats response + ClusterStats (..), + ClusterStatsNodeSummary (..), + + -- * Indices breakdown + ClusterStatsIndices (..), + ClusterStatsShards (..), + ClusterStatsDocs (..), + ClusterStatsStore (..), + ClusterStatsIndexVersion (..), + + -- * Nodes breakdown + ClusterStatsNodes (..), + ClusterStatsNodeCount (..), + + -- * Optics + clusterStatsTimestampLens, + clusterStatsClusterNameLens, + clusterStatsClusterUuidLens, + clusterStatsStatusLens, + clusterStatsNodesSummaryLens, + clusterStatsIndicesLens, + clusterStatsNodesLens, + clusterStatsNodeSummaryTotalLens, + clusterStatsNodeSummarySuccessfulLens, + clusterStatsNodeSummaryFailedLens, + clusterStatsIndicesCountLens, + clusterStatsIndicesShardsLens, + clusterStatsIndicesDocsLens, + clusterStatsIndicesStoreLens, + clusterStatsIndicesVersionsLens, + clusterStatsIndicesOtherLens, + clusterStatsIndexVersionVersionLens, + clusterStatsIndexVersionIndexCountLens, + clusterStatsIndexVersionPrimaryShardCountLens, + clusterStatsIndexVersionTotalPrimaryBytesLens, + clusterStatsIndexVersionOtherLens, + clusterStatsShardsTotalLens, + clusterStatsShardsPrimariesLens, + clusterStatsShardsReplicationLens, + clusterStatsShardsOtherLens, + clusterStatsDocsCountLens, + clusterStatsDocsDeletedLens, + clusterStatsStoreSizeInBytesLens, + clusterStatsStoreOtherLens, + clusterStatsNodesCountLens, + clusterStatsNodesVersionsLens, + clusterStatsNodesOtherLens, + clusterStatsNodeCountTotalLens, + clusterStatsNodeCountByRoleLens, + ) +where + +import Data.Aeson +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.Word (Word64) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Cluster (ClusterHealthStatus) + +-- | Top-level envelope of the @GET /_cluster/stats@ response +-- (). +-- +-- The endpoint returns a large payload describing the cluster as a whole: +-- indices counts/shards/docs/store/versions/segments/mappings/... and +-- per-node aggregates (count by role, JVM, FS, OS, plugins, ingest, ...). +-- Only the universally useful top-level fields, the @indices.count@, +-- @indices.shards@, @indices.docs@, @indices.store@ and @indices.versions@ +-- blocks, and the @nodes.count@ and @nodes.versions@ blocks are typed on +-- this first cut; everything else is preserved verbatim in +-- 'clusterStatsIndicesOther' and 'clusterStatsNodesOther' so callers can +-- navigate any not-yet-typed section with aeson while later beads promote +-- individual sections to typed records. This mirrors the strategy used by +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Indices.IndexStats'. +data ClusterStats = ClusterStats + { clusterStatsTimestamp :: Word64, + clusterStatsClusterName :: Text, + clusterStatsClusterUuid :: Text, + clusterStatsStatus :: ClusterHealthStatus, + clusterStatsNodesSummary :: ClusterStatsNodeSummary, + clusterStatsIndices :: ClusterStatsIndices, + clusterStatsNodes :: ClusterStatsNodes + } + deriving stock (Eq, Show) + +-- | The @_nodes@ sub-object carried by every cluster-level ES response: +-- the total / successful / failed node counts that the server touched +-- while building the reply. +data ClusterStatsNodeSummary = ClusterStatsNodeSummary + { clusterStatsNodeSummaryTotal :: Int, + clusterStatsNodeSummarySuccessful :: Int, + clusterStatsNodeSummaryFailed :: Int + } + deriving stock (Eq, Show) + +-- | The @indices@ sub-object of 'ClusterStats'. Models @count@, the +-- universally-useful @shards@ summary (@total@, @primaries@, +-- @replication@), the @docs@ and @store@ blocks (same shape as +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Indices.IndexStatDocs' +-- and the @size_in_bytes@ projection of +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Indices.IndexStatStore') +-- and the @versions@ array; everything else (segments, mappings, +-- fielddata, query_cache, completion, analysis, stack_versions, ...) is +-- preserved verbatim in 'clusterStatsIndicesOther'. +data ClusterStatsIndices = ClusterStatsIndices + { clusterStatsIndicesCount :: Int, + clusterStatsIndicesShards :: ClusterStatsShards, + clusterStatsIndicesDocs :: Maybe ClusterStatsDocs, + clusterStatsIndicesStore :: Maybe ClusterStatsStore, + clusterStatsIndicesVersions :: [ClusterStatsIndexVersion], + clusterStatsIndicesOther :: Value + } + deriving stock (Eq, Show) + +-- | Summary shard counts for the cluster. The server reports @total@, +-- @primaries@ and a @replication@ ratio; additional sub-objects (@index@, +-- @primaries@' neighbours) are preserved verbatim in +-- 'clusterStatsShardsOther'. +data ClusterStatsShards = ClusterStatsShards + { clusterStatsShardsTotal :: Int, + clusterStatsShardsPrimaries :: Int, + clusterStatsShardsReplication :: Maybe Double, + clusterStatsShardsOther :: Value + } + deriving stock (Eq, Show) + +-- | @docs@ block: live document count and deleted document count for the +-- whole cluster. +data ClusterStatsDocs = ClusterStatsDocs + { clusterStatsDocsCount :: Word64, + clusterStatsDocsDeleted :: Word64 + } + deriving stock (Eq, Show) + +-- | @store@ block: physical store size in bytes plus the additional +-- total/free/reserved counters reported on modern ES versions. The +-- typed 'clusterStatsStoreSizeInBytes' field is authoritative; the full +-- original object is preserved in 'clusterStatsStoreOther' so callers +-- can read @total_data_set_size_in_bytes@, @reserved_in_bytes@, etc. +-- without waiting for a typed model. +data ClusterStatsStore = ClusterStatsStore + { clusterStatsStoreSizeInBytes :: Word64, + clusterStatsStoreOther :: Value + } + deriving stock (Eq, Show) + +-- | A single entry of the @indices.versions@ array. ES 7.x and earlier +-- emit a bare string (@\"7.17.25\"@); modern ES (and the +-- @indices.stack_versions@ sibling) emit an object carrying the version +-- plus per-version rollups (@index_count@, @primary_shard_count@, +-- @total_primary_bytes@). Both shapes decode to this type — when the +-- server emits a bare string only 'clusterStatsIndexVersionVersion' is +-- populated and the other fields stay 'Nothing'. +data ClusterStatsIndexVersion = ClusterStatsIndexVersion + { clusterStatsIndexVersionVersion :: Text, + clusterStatsIndexVersionIndexCount :: Maybe Int, + clusterStatsIndexVersionPrimaryShardCount :: Maybe Int, + clusterStatsIndexVersionTotalPrimaryBytes :: Maybe Word64, + clusterStatsIndexVersionOther :: Value + } + deriving stock (Eq, Show) + +-- | The @nodes@ sub-object of 'ClusterStats'. Models the per-role +-- @count@ breakdown and the @versions@ array; everything else (@os@, +-- @process@, @jvm@, @fs@, @plugins@, @network_types@, @discovery_types@, +-- @packaging_types@, @ingest@, @indexing_pressure@, ...) is preserved +-- verbatim in 'clusterStatsNodesOther'. +data ClusterStatsNodes = ClusterStatsNodes + { clusterStatsNodesCount :: ClusterStatsNodeCount, + clusterStatsNodesVersions :: [Text], + clusterStatsNodesOther :: Value + } + deriving stock (Eq, Show) + +-- | Per-role node count breakdown. 'clusterStatsNodeCountTotal' is the +-- authoritative total; the role-keyed counts (decoded in document order +-- into a list of @(role, count)@ pairs) cover the standard ES roles +-- (@data@, @data_hot@, @data_warm@, @data_cold@, @data_frozen@, +-- @data_content@, @master@, @ingest@, @coordinating_only@, @ml@, +-- @remote_cluster_client@, @transform@, @voting_only@, @index@, ...). +-- Unknown roles are preserved so the cluster_stats response stays +-- forward-compatible with new ES roles without a library release. +data ClusterStatsNodeCount = ClusterStatsNodeCount + { clusterStatsNodeCountTotal :: Int, + clusterStatsNodeCountByRole :: [(Text, Int)] + } + deriving stock (Eq, Show) + +clusterStatsTimestampLens :: Lens' ClusterStats Word64 +clusterStatsTimestampLens = lens clusterStatsTimestamp (\x y -> x {clusterStatsTimestamp = y}) + +clusterStatsClusterNameLens :: Lens' ClusterStats Text +clusterStatsClusterNameLens = lens clusterStatsClusterName (\x y -> x {clusterStatsClusterName = y}) + +clusterStatsClusterUuidLens :: Lens' ClusterStats Text +clusterStatsClusterUuidLens = lens clusterStatsClusterUuid (\x y -> x {clusterStatsClusterUuid = y}) + +clusterStatsStatusLens :: Lens' ClusterStats ClusterHealthStatus +clusterStatsStatusLens = lens clusterStatsStatus (\x y -> x {clusterStatsStatus = y}) + +clusterStatsNodesSummaryLens :: Lens' ClusterStats ClusterStatsNodeSummary +clusterStatsNodesSummaryLens = lens clusterStatsNodesSummary (\x y -> x {clusterStatsNodesSummary = y}) + +clusterStatsIndicesLens :: Lens' ClusterStats ClusterStatsIndices +clusterStatsIndicesLens = lens clusterStatsIndices (\x y -> x {clusterStatsIndices = y}) + +clusterStatsNodesLens :: Lens' ClusterStats ClusterStatsNodes +clusterStatsNodesLens = lens clusterStatsNodes (\x y -> x {clusterStatsNodes = y}) + +clusterStatsNodeSummaryTotalLens :: Lens' ClusterStatsNodeSummary Int +clusterStatsNodeSummaryTotalLens = + lens clusterStatsNodeSummaryTotal (\x y -> x {clusterStatsNodeSummaryTotal = y}) + +clusterStatsNodeSummarySuccessfulLens :: Lens' ClusterStatsNodeSummary Int +clusterStatsNodeSummarySuccessfulLens = + lens clusterStatsNodeSummarySuccessful (\x y -> x {clusterStatsNodeSummarySuccessful = y}) + +clusterStatsNodeSummaryFailedLens :: Lens' ClusterStatsNodeSummary Int +clusterStatsNodeSummaryFailedLens = + lens clusterStatsNodeSummaryFailed (\x y -> x {clusterStatsNodeSummaryFailed = y}) + +clusterStatsIndicesCountLens :: Lens' ClusterStatsIndices Int +clusterStatsIndicesCountLens = lens clusterStatsIndicesCount (\x y -> x {clusterStatsIndicesCount = y}) + +clusterStatsIndicesShardsLens :: Lens' ClusterStatsIndices ClusterStatsShards +clusterStatsIndicesShardsLens = lens clusterStatsIndicesShards (\x y -> x {clusterStatsIndicesShards = y}) + +clusterStatsIndicesDocsLens :: Lens' ClusterStatsIndices (Maybe ClusterStatsDocs) +clusterStatsIndicesDocsLens = lens clusterStatsIndicesDocs (\x y -> x {clusterStatsIndicesDocs = y}) + +clusterStatsIndicesStoreLens :: Lens' ClusterStatsIndices (Maybe ClusterStatsStore) +clusterStatsIndicesStoreLens = lens clusterStatsIndicesStore (\x y -> x {clusterStatsIndicesStore = y}) + +clusterStatsIndicesVersionsLens :: Lens' ClusterStatsIndices [ClusterStatsIndexVersion] +clusterStatsIndicesVersionsLens = + lens clusterStatsIndicesVersions (\x y -> x {clusterStatsIndicesVersions = y}) + +clusterStatsIndicesOtherLens :: Lens' ClusterStatsIndices Value +clusterStatsIndicesOtherLens = lens clusterStatsIndicesOther (\x y -> x {clusterStatsIndicesOther = y}) + +clusterStatsIndexVersionVersionLens :: Lens' ClusterStatsIndexVersion Text +clusterStatsIndexVersionVersionLens = + lens clusterStatsIndexVersionVersion (\x y -> x {clusterStatsIndexVersionVersion = y}) + +clusterStatsIndexVersionIndexCountLens :: Lens' ClusterStatsIndexVersion (Maybe Int) +clusterStatsIndexVersionIndexCountLens = + lens clusterStatsIndexVersionIndexCount (\x y -> x {clusterStatsIndexVersionIndexCount = y}) + +clusterStatsIndexVersionPrimaryShardCountLens :: Lens' ClusterStatsIndexVersion (Maybe Int) +clusterStatsIndexVersionPrimaryShardCountLens = + lens clusterStatsIndexVersionPrimaryShardCount (\x y -> x {clusterStatsIndexVersionPrimaryShardCount = y}) + +clusterStatsIndexVersionTotalPrimaryBytesLens :: Lens' ClusterStatsIndexVersion (Maybe Word64) +clusterStatsIndexVersionTotalPrimaryBytesLens = + lens clusterStatsIndexVersionTotalPrimaryBytes (\x y -> x {clusterStatsIndexVersionTotalPrimaryBytes = y}) + +clusterStatsIndexVersionOtherLens :: Lens' ClusterStatsIndexVersion Value +clusterStatsIndexVersionOtherLens = + lens clusterStatsIndexVersionOther (\x y -> x {clusterStatsIndexVersionOther = y}) + +clusterStatsShardsTotalLens :: Lens' ClusterStatsShards Int +clusterStatsShardsTotalLens = lens clusterStatsShardsTotal (\x y -> x {clusterStatsShardsTotal = y}) + +clusterStatsShardsPrimariesLens :: Lens' ClusterStatsShards Int +clusterStatsShardsPrimariesLens = + lens clusterStatsShardsPrimaries (\x y -> x {clusterStatsShardsPrimaries = y}) + +clusterStatsShardsReplicationLens :: Lens' ClusterStatsShards (Maybe Double) +clusterStatsShardsReplicationLens = + lens clusterStatsShardsReplication (\x y -> x {clusterStatsShardsReplication = y}) + +clusterStatsShardsOtherLens :: Lens' ClusterStatsShards Value +clusterStatsShardsOtherLens = lens clusterStatsShardsOther (\x y -> x {clusterStatsShardsOther = y}) + +clusterStatsDocsCountLens :: Lens' ClusterStatsDocs Word64 +clusterStatsDocsCountLens = lens clusterStatsDocsCount (\x y -> x {clusterStatsDocsCount = y}) + +clusterStatsDocsDeletedLens :: Lens' ClusterStatsDocs Word64 +clusterStatsDocsDeletedLens = lens clusterStatsDocsDeleted (\x y -> x {clusterStatsDocsDeleted = y}) + +clusterStatsStoreSizeInBytesLens :: Lens' ClusterStatsStore Word64 +clusterStatsStoreSizeInBytesLens = + lens clusterStatsStoreSizeInBytes (\x y -> x {clusterStatsStoreSizeInBytes = y}) + +clusterStatsStoreOtherLens :: Lens' ClusterStatsStore Value +clusterStatsStoreOtherLens = lens clusterStatsStoreOther (\x y -> x {clusterStatsStoreOther = y}) + +clusterStatsNodesCountLens :: Lens' ClusterStatsNodes ClusterStatsNodeCount +clusterStatsNodesCountLens = lens clusterStatsNodesCount (\x y -> x {clusterStatsNodesCount = y}) + +clusterStatsNodesVersionsLens :: Lens' ClusterStatsNodes [Text] +clusterStatsNodesVersionsLens = + lens clusterStatsNodesVersions (\x y -> x {clusterStatsNodesVersions = y}) + +clusterStatsNodesOtherLens :: Lens' ClusterStatsNodes Value +clusterStatsNodesOtherLens = lens clusterStatsNodesOther (\x y -> x {clusterStatsNodesOther = y}) + +clusterStatsNodeCountTotalLens :: Lens' ClusterStatsNodeCount Int +clusterStatsNodeCountTotalLens = + lens clusterStatsNodeCountTotal (\x y -> x {clusterStatsNodeCountTotal = y}) + +clusterStatsNodeCountByRoleLens :: Lens' ClusterStatsNodeCount [(Text, Int)] +clusterStatsNodeCountByRoleLens = + lens clusterStatsNodeCountByRole (\x y -> x {clusterStatsNodeCountByRole = y}) + +instance FromJSON ClusterStats where + parseJSON = withObject "ClusterStats" $ \o -> + ClusterStats + <$> o .:? "timestamp" .!= 0 + <*> o .: "cluster_name" + <*> o .: "cluster_uuid" + <*> o .: "status" + <*> o .:? "_nodes" .!= defaultNodeSummary + <*> o .:? "indices" .!= defaultIndices + <*> o .:? "nodes" .!= defaultNodes + +instance ToJSON ClusterStats where + toJSON ClusterStats {..} = + object + [ "timestamp" .= clusterStatsTimestamp, + "cluster_name" .= clusterStatsClusterName, + "cluster_uuid" .= clusterStatsClusterUuid, + "status" .= clusterStatsStatus, + "_nodes" .= clusterStatsNodesSummary, + "indices" .= clusterStatsIndices, + "nodes" .= clusterStatsNodes + ] + +instance FromJSON ClusterStatsNodeSummary where + parseJSON = withObject "ClusterStatsNodeSummary" $ \o -> + ClusterStatsNodeSummary + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON ClusterStatsNodeSummary where + toJSON ClusterStatsNodeSummary {..} = + object + [ "total" .= clusterStatsNodeSummaryTotal, + "successful" .= clusterStatsNodeSummarySuccessful, + "failed" .= clusterStatsNodeSummaryFailed + ] + +instance FromJSON ClusterStatsIndices where + parseJSON = withObject "ClusterStatsIndices" $ \o -> + ClusterStatsIndices + <$> o .:? "count" .!= 0 + <*> parseShardsOrDefault (o .:? "shards") + <*> o .:? "docs" + <*> o .:? "store" + <*> o .:? "versions" .!= [] + <*> pure (Object o) + +instance ToJSON ClusterStatsIndices where + toJSON ci = + case clusterStatsIndicesOther ci of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "count" .= clusterStatsIndicesCount ci, + "shards" .= clusterStatsIndicesShards ci, + "docs" .= clusterStatsIndicesDocs ci, + "store" .= clusterStatsIndicesStore ci, + "versions" .= clusterStatsIndicesVersions ci + ] + +instance FromJSON ClusterStatsShards where + parseJSON = withObject "ClusterStatsShards" $ \o -> + ClusterStatsShards + <$> o .:? "total" .!= 0 + <*> o .:? "primaries" .!= 0 + <*> o .:? "replication" + <*> pure (Object o) + +instance ToJSON ClusterStatsShards where + toJSON sh = + case clusterStatsShardsOther sh of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "total" .= clusterStatsShardsTotal sh, + "primaries" .= clusterStatsShardsPrimaries sh, + "replication" .= clusterStatsShardsReplication sh + ] + +instance FromJSON ClusterStatsDocs where + parseJSON = withObject "ClusterStatsDocs" $ \o -> + ClusterStatsDocs + <$> o .:? "count" .!= 0 + <*> o .:? "deleted" .!= 0 + +instance ToJSON ClusterStatsDocs where + toJSON ClusterStatsDocs {..} = + object + [ "count" .= clusterStatsDocsCount, + "deleted" .= clusterStatsDocsDeleted + ] + +-- | Parse the @store@ block: capture @size_in_bytes@ as the typed +-- projection while preserving the original object (including +-- @total_data_set_size_in_bytes@, @reserved_in_bytes@, ...) in +-- 'clusterStatsStoreOther' for forward compatibility. +instance FromJSON ClusterStatsStore where + parseJSON = withObject "ClusterStatsStore" $ \o -> do + size <- o .:? "size_in_bytes" .!= 0 + pure $ ClusterStatsStore size (Object o) + +instance ToJSON ClusterStatsStore where + toJSON store = + case clusterStatsStoreOther store of + Object o -> + Object (mergeIgnoringNulls [k .= v] o) + _ -> object [k .= v] + where + k = "size_in_bytes" + v = clusterStatsStoreSizeInBytes store + +-- | Decode a single @indices.versions@ entry. Accepts both the legacy +-- bare-string form (@\"7.17.25\"@) and the modern object form +-- (@{version, index_count, primary_shard_count, total_primary_bytes}@). +-- The full original value is preserved in 'clusterStatsIndexVersionOther' +-- for forward compatibility with extra keys ES may add later. +instance FromJSON ClusterStatsIndexVersion where + parseJSON (String t) = + pure $ + ClusterStatsIndexVersion + { clusterStatsIndexVersionVersion = t, + clusterStatsIndexVersionIndexCount = Nothing, + clusterStatsIndexVersionPrimaryShardCount = Nothing, + clusterStatsIndexVersionTotalPrimaryBytes = Nothing, + clusterStatsIndexVersionOther = String t + } + parseJSON v@(Object o) = + ClusterStatsIndexVersion + <$> o .: "version" + <*> o .:? "index_count" + <*> o .:? "primary_shard_count" + <*> o .:? "total_primary_bytes" + <*> pure v + parseJSON v = fail ("ClusterStatsIndexVersion: expected String or Object, got " <> show v) + +instance ToJSON ClusterStatsIndexVersion where + toJSON v = + case clusterStatsIndexVersionOther v of + Object o -> + Object (mergeIgnoringNulls [k .= val] o) + _ -> toJSON val + where + k = "version" + val = clusterStatsIndexVersionVersion v + +instance FromJSON ClusterStatsNodes where + parseJSON = withObject "ClusterStatsNodes" $ \o -> + ClusterStatsNodes + <$> parseNodeCountOrDefault (o .:? "count") + <*> o .:? "versions" .!= [] + <*> pure (Object o) + +instance ToJSON ClusterStatsNodes where + toJSON ns = + case clusterStatsNodesOther ns of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "count" .= clusterStatsNodesCount ns, + "versions" .= clusterStatsNodesVersions ns + ] + +-- | Parse the @nodes.count@ sub-object. @total@ is always present; every +-- other key (whatever the server reports — @data@, @master@, @ingest@, +-- @ml@, future ES roles, ...) is captured into a list of @(role, count)@ +-- pairs in document order so unknown roles survive a round trip. +instance FromJSON ClusterStatsNodeCount where + parseJSON = withObject "ClusterStatsNodeCount" $ \o -> do + total <- o .:? "total" .!= 0 + let byRole = + [ (K.toText k, n) + | (k, v) <- KM.toList o, + k /= "total", + Just n <- [toInt v] + ] + pure $ ClusterStatsNodeCount total byRole + where + toInt (Number s) = Just (round s) + toInt _ = Nothing + +instance ToJSON ClusterStatsNodeCount where + toJSON count = + Object $ + KM.insert "total" (toJSON (clusterStatsNodeCountTotal count)) $ + kmFromRoleCounts (clusterStatsNodeCountByRole count) + +-- ------------------------------------------------------------------ -- +-- Internal helpers -- +-- ------------------------------------------------------------------ -- + +-- | Decode an optional @indices.shards@ block, falling back to a zeroed +-- 'ClusterStatsShards' when the server omits the key (closed indices or +-- degraded cluster state). Mirrors the @parseOrDefault@ helper used by +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Indices.IndexStatMetrics'. +parseShardsOrDefault :: Parser (Maybe Value) -> Parser ClusterStatsShards +parseShardsOrDefault p = do + mv <- p + case mv of + Just v@(Object _) -> parseJSON v + _ -> pure defaultShards + +-- | Decode an optional @nodes.count@ block, falling back to a zeroed +-- 'ClusterStatsNodeCount' when the server omits the key. +parseNodeCountOrDefault :: Parser (Maybe Value) -> Parser ClusterStatsNodeCount +parseNodeCountOrDefault p = do + mv <- p + case mv of + Just v@(Object _) -> parseJSON v + _ -> pure defaultNodeCount + +-- | Build the role-keyed 'KM.KeyMap' for 'ToJSON ClusterStatsNodeCount'. +-- Keys are inserted in document order so round-tripping preserves the +-- server's original ordering. +kmFromRoleCounts :: [(Text, Int)] -> KM.KeyMap Value +kmFromRoleCounts = KM.fromList . fmap (\(role, n) -> (K.fromText role, toJSON n)) + +-- | Merge a list of @(key, value)@ pairs into a 'KM.KeyMap', dropping +-- any pair whose value is 'Null' (matching 'omitNulls' semantics). The +-- typed pairs take precedence over any stale duplicates already present +-- in the @Other@ blob captured at decode time, ensuring that round +-- trips overwrite the verbatim entries with the typed projections +-- rather than the other way around. +mergeIgnoringNulls :: [(Key, Value)] -> KM.KeyMap Value -> KM.KeyMap Value +mergeIgnoringNulls kvs o = KM.union (KM.fromList (filter notNull kvs)) o + where + notNull (_, Null) = False + notNull _ = True + +defaultNodeSummary :: ClusterStatsNodeSummary +defaultNodeSummary = + ClusterStatsNodeSummary + { clusterStatsNodeSummaryTotal = 0, + clusterStatsNodeSummarySuccessful = 0, + clusterStatsNodeSummaryFailed = 0 + } + +defaultShards :: ClusterStatsShards +defaultShards = + ClusterStatsShards + { clusterStatsShardsTotal = 0, + clusterStatsShardsPrimaries = 0, + clusterStatsShardsReplication = Nothing, + clusterStatsShardsOther = emptyObject + } + +defaultNodeCount :: ClusterStatsNodeCount +defaultNodeCount = + ClusterStatsNodeCount + { clusterStatsNodeCountTotal = 0, + clusterStatsNodeCountByRole = [] + } + +defaultIndices :: ClusterStatsIndices +defaultIndices = + ClusterStatsIndices + { clusterStatsIndicesCount = 0, + clusterStatsIndicesShards = defaultShards, + clusterStatsIndicesDocs = Nothing, + clusterStatsIndicesStore = Nothing, + clusterStatsIndicesVersions = [], + clusterStatsIndicesOther = emptyObject + } + +defaultNodes :: ClusterStatsNodes +defaultNodes = + ClusterStatsNodes + { clusterStatsNodesCount = defaultNodeCount, + clusterStatsNodesVersions = [], + clusterStatsNodesOther = emptyObject + } diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Count.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Count.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Count.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Count.hs @@ -1,20 +1,43 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module Database.Bloodhound.Internal.Versions.Common.Types.Count ( CountQuery (..), CountResponse (..), CountShards (..), + -- * URI parameters + CountOptions (..), + defaultCountOptions, + countOptionsParams, + -- * Optics countResponseCountLens, countResponseShardsLens, countShardsTotalLens, countShardsSuccessfulLens, + countShardsSkippedLens, countShardsFailedLens, + coAllowNoIndicesLens, + coExpandWildcardsLens, + coIgnoreUnavailableLens, + coMinScoreLens, + coPreferenceLens, + coRoutingLens, ) where import Data.Aeson +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports (showText) +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) import Database.Bloodhound.Internal.Versions.Common.Types.Query import Numeric.Natural import Optics.Lens @@ -48,9 +71,18 @@ countResponseShardsLens :: Lens' CountResponse CountShards countResponseShardsLens = lens crShards (\x y -> x {crShards = y}) +-- | Shard-level summary returned in the @_shards@ object of a +-- 'CountResponse'. Mirrors the 'ShardResult' shape used by search and +-- snapshot endpoints (total\/successful\/skipped\/failed), so that +-- callers can rely on the same field set across endpoints. The +-- @skipped@ field was historically omitted by the count endpoint but +-- is documented for @POST \/{index}\/_count@ on ES 7.x+ and +-- OpenSearch; it is parsed leniently (defaulting to @0@ when absent) +-- so older servers that omit it still decode cleanly. data CountShards = CountShards { csTotal :: Int, csSuccessful :: Int, + csSkipped :: Int, csFailed :: Int } deriving stock (Eq, Show) @@ -61,17 +93,130 @@ \o -> CountShards <$> o - .: "total" + .:? "total" + .!= 0 <*> o - .: "successful" + .:? "successful" + .!= 0 <*> o - .: "failed" + .:? "skipped" + .!= 0 + <*> o + .:? "failed" + .!= 0 +instance ToJSON CountShards where + toJSON CountShards {..} = + object + [ "total" .= csTotal, + "successful" .= csSuccessful, + "skipped" .= csSkipped, + "failed" .= csFailed + ] + countShardsTotalLens :: Lens' CountShards Int countShardsTotalLens = lens csTotal (\x y -> x {csTotal = y}) countShardsSuccessfulLens :: Lens' CountShards Int countShardsSuccessfulLens = lens csSuccessful (\x y -> x {csSuccessful = y}) +countShardsSkippedLens :: Lens' CountShards Int +countShardsSkippedLens = lens csSkipped (\x y -> x {csSkipped = y}) + countShardsFailedLens :: Lens' CountShards Int countShardsFailedLens = lens csFailed (\x y -> x {csFailed = y}) + +-- | URI parameters accepted by @//_count@ and @/_count@. Each +-- field maps 1:1 to a query-string parameter of the count endpoint (see +-- +-- and ). +-- Field shapes mirror 'Database.Bloodhound.Internal.Versions.Common.Types.Search.SearchOptions' +-- where the parameter exists on both endpoints, so callers can reuse +-- the same values across count and search. +-- +-- The deprecated \/ URI-only query parameters (@q@, @df@, @lenient@, +-- @analyzer@, @analyze_wildcard@, @default_operator@, @ignore_throttled@) +-- are not modelled here: the count body carries the structured 'Query' +-- via 'CountQuery', which subsumes them. @terminate_after@ is also +-- omitted: it is documented as a URI parameter on legacy ES versions +-- but is not part of the modern count API surface; track it as a +-- follow-up if a need arises. +data CountOptions = CountOptions + { -- | Whether to short-circuit the request if a concrete (non-wildcard) + -- index / alias is missing. Defaults to @false@ server-side. + coAllowNoIndices :: Maybe Bool, + -- | Which wildcard patterns to expand. The server accepts a + -- comma-separated list; we model it as a 'NonEmpty' to encode "at + -- least one", reusing the 'ExpandWildcards' sum type shared with + -- the search endpoint. + coExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + -- | Skip missing / closed indices silently instead of failing. + coIgnoreUnavailable :: Maybe Bool, + -- | Minimum @_score@ a document must have to be counted. Forwarded + -- as the @min_score@ query-string parameter; the server types it as + -- a @number@, so we use 'Double' to admit fractional scores. + coMinScore :: Maybe Double, + -- | Shard routing hint, e.g. @_local@ or @_only_local@. Also accepts + -- an arbitrary string for custom allocation, mirroring + -- 'Database.Bloodhound.Internal.Versions.Common.Types.Search.soPreference'. + coPreference :: Maybe Text, + -- | Custom routing value(s). For multi-route queries pass a + -- comma-separated string, e.g. @"route1,route2"@, mirroring + -- 'Database.Bloodhound.Internal.Versions.Common.Types.Search.soRouting'. + coRouting :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'CountOptions' with every parameter set to 'Nothing'. Produces no +-- query string, so a call made with this value is byte-identical to a +-- parameterless call (and to the legacy 'countByIndex' wire shape). +defaultCountOptions :: CountOptions +defaultCountOptions = + CountOptions + { coAllowNoIndices = Nothing, + coExpandWildcards = Nothing, + coIgnoreUnavailable = Nothing, + coMinScore = Nothing, + coPreference = Nothing, + coRouting = Nothing + } + +coAllowNoIndicesLens :: Lens' CountOptions (Maybe Bool) +coAllowNoIndicesLens = lens coAllowNoIndices (\x y -> x {coAllowNoIndices = y}) + +coExpandWildcardsLens :: Lens' CountOptions (Maybe (NonEmpty ExpandWildcards)) +coExpandWildcardsLens = lens coExpandWildcards (\x y -> x {coExpandWildcards = y}) + +coIgnoreUnavailableLens :: Lens' CountOptions (Maybe Bool) +coIgnoreUnavailableLens = lens coIgnoreUnavailable (\x y -> x {coIgnoreUnavailable = y}) + +coMinScoreLens :: Lens' CountOptions (Maybe Double) +coMinScoreLens = lens coMinScore (\x y -> x {coMinScore = y}) + +coPreferenceLens :: Lens' CountOptions (Maybe Text) +coPreferenceLens = lens coPreference (\x y -> x {coPreference = y}) + +coRoutingLens :: Lens' CountOptions (Maybe Text) +coRoutingLens = lens coRouting (\x y -> x {coRouting = y}) + +-- | Render 'CountOptions' as a list of @(key, value)@ pairs suitable for +-- 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultCountOptions' produces an empty list. The order of the +-- returned list is stable but /unspecified/ — callers (including +-- tests) should treat it as a set and not pattern-match on the head. +-- The underlying 'withQueries' is order-insensitive. +countOptionsParams :: CountOptions -> [(Text, Maybe Text)] +countOptionsParams opts = + catMaybes + [ boolParam "allow_no_indices" <$> coAllowNoIndices opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> coExpandWildcards opts, + boolParam "ignore_unavailable" <$> coIgnoreUnavailable opts, + ("min_score",) . Just . showText <$> coMinScore opts, + ("preference",) . Just <$> coPreference opts, + ("routing",) . Just <$> coRouting opts + ] + where + boolParam k b = (k, Just (boolQP b)) + boolQP True = "true" + boolQP False = "false" + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Dangling.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Dangling.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Dangling.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Dangling +-- Copyright : (C) 2014, 2018 Chris Allen +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Chris Allen +-- Stability : provisional +-- Portability : GHC +-- +-- Types for the /dangling indices/ endpoints +-- (@GET /_dangling@, @POST /_dangling/{uuid}@, +-- @DELETE /_dangling/{uuid}@), available since Elasticsearch 7.16. +-- OpenSearch implements the same endpoints (added in OpenSearch 1.0). +-- +-- +-- +module Database.Bloodhound.Internal.Versions.Common.Types.Dangling + ( -- * Core types + DanglingIndexUuid (..), + unDanglingIndexUuid, + DanglingIndex (..), + danglingIndexUuidLens, + danglingIndexIndexNameLens, + danglingIndexNodeIdsLens, + danglingIndexCreationDateMillisLens, + DanglingIndicesResponse (..), + danglingIndicesResponseListLens, + + -- * Import options (POST /_dangling/{uuid}) + ImportDanglingIndexOptions (..), + defaultImportDanglingIndexOptions, + importDanglingIndexOptionsParams, + idioAcceptDataLossLens, + idioMasterTimeoutLens, + idioTimeoutLens, + + -- * Delete options (DELETE /_dangling/{uuid}) + DeleteDanglingIndexOptions (..), + defaultDeleteDanglingIndexOptions, + deleteDanglingIndexOptionsParams, + ddioMasterTimeoutLens, + ddioTimeoutLens, + ) +where + +import Data.Aeson +import Data.Text (Text) +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports + ( Lens', + catMaybes, + lens, + showText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Units + ( TimeUnits, + timeUnitsSuffix, + ) + +-- | The UUID used by Elasticsearch to identify a dangling index in the +-- @/_dangling/{uuid}@ path. This is the @index_uuid@ reported by +-- @GET /_dangling@ (a 22-character base64-encoded UUID, e.g. +-- @wWy3QpguT5S-u2f0x2GXoQ@). +newtype DanglingIndexUuid = DanglingIndexUuid Text + deriving stock (Eq, Ord, Show) + +-- | /Deliberately/ no 'FromJSON' or 'ToJSON' instance: the dangling +-- endpoints never put the UUID in a JSON body, only in the URL path. +-- A bare accessor avoids an 'IsString' implicit coercion in client +-- code (which would defeat the newtype) while keeping the path-render +-- trivially obvious in the request builders. +unDanglingIndexUuid :: DanglingIndexUuid -> Text +unDanglingIndexUuid (DanglingIndexUuid x) = x + +-- | One entry in the @GET /_dangling@ response. The +-- @creation_date_millis@ field is the epoch-millisecond timestamp at +-- which the index was created; it is required by the spec, so we parse +-- it strictly as an 'Int'. +-- +-- The @node_ids@ field is the list of node IDs holding the dangling +-- index's data; it is required and emitted as an array by the server. +-- +-- The @index_name@ is surfaced as plain 'Text' rather than +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Newtypes.IndexName': +-- a dangling index originated on another cluster and its name may not +-- satisfy this library's index-name validator. Callers that want to +-- re-import it under a sanitized name can do so themselves. +data DanglingIndex = DanglingIndex + { danglingIndexUuid :: DanglingIndexUuid, + danglingIndexIndexName :: Text, + danglingIndexNodeIds :: [Text], + danglingIndexCreationDateMillis :: Int + } + deriving stock (Eq, Show) + +instance FromJSON DanglingIndex where + parseJSON = + withObject "DanglingIndex" $ \o -> + DanglingIndex + <$> (DanglingIndexUuid <$> o .: "index_uuid") + <*> o .: "index_name" + <*> o .: "node_ids" + <*> o .: "creation_date_millis" + +danglingIndexUuidLens :: Lens' DanglingIndex DanglingIndexUuid +danglingIndexUuidLens = + lens danglingIndexUuid (\x y -> x {danglingIndexUuid = y}) + +danglingIndexIndexNameLens :: Lens' DanglingIndex Text +danglingIndexIndexNameLens = + lens danglingIndexIndexName (\x y -> x {danglingIndexIndexName = y}) + +danglingIndexNodeIdsLens :: Lens' DanglingIndex [Text] +danglingIndexNodeIdsLens = + lens danglingIndexNodeIds (\x y -> x {danglingIndexNodeIds = y}) + +danglingIndexCreationDateMillisLens :: Lens' DanglingIndex Int +danglingIndexCreationDateMillisLens = + lens danglingIndexCreationDateMillis (\x y -> x {danglingIndexCreationDateMillis = y}) + +-- | Envelope returned by @GET /_dangling@: +-- @{"dangling_indices": [ ... ]}@. An empty list is the common case +-- on a healthy cluster. +newtype DanglingIndicesResponse = DanglingIndicesResponse + { danglingIndicesResponseList :: [DanglingIndex] + } + deriving stock (Eq, Show) + +instance FromJSON DanglingIndicesResponse where + parseJSON = + withObject "DanglingIndicesResponse" $ \o -> + DanglingIndicesResponse <$> (o .:? "dangling_indices" .!= []) + +danglingIndicesResponseListLens :: Lens' DanglingIndicesResponse [DanglingIndex] +danglingIndicesResponseListLens = + lens danglingIndicesResponseList (\x y -> x {danglingIndicesResponseList = y}) + +-- | URI parameters accepted by @POST /_dangling/{uuid}@. +-- +-- @accept_data_loss@ is /required/ by the server — the request fails +-- 400 without it. The default 'defaultImportDanglingIndexOptions' +-- sets it to 'True' (the only meaningful value), but the field is +-- exposed in case a future caller wants to inspect or override it +-- (e.g. to render an \"I have not consented\" request shape for +-- audit logging). +-- +-- @master_timeout@ and @timeout@ follow the project-wide +-- @(unit, magnitude)@ convention rendered via 'timeUnitsSuffix' +-- (e.g. @('TimeUnitSeconds', 30)@ -> @30s@). 'Nothing' omits the +-- parameter. +data ImportDanglingIndexOptions = ImportDanglingIndexOptions + { idioAcceptDataLoss :: Bool, + idioMasterTimeout :: Maybe (TimeUnits, Word32), + idioTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'True' for @accept_data_loss@ (the server-required value), no +-- @master_timeout@, no @timeout@. +defaultImportDanglingIndexOptions :: ImportDanglingIndexOptions +defaultImportDanglingIndexOptions = + ImportDanglingIndexOptions + { idioAcceptDataLoss = True, + idioMasterTimeout = Nothing, + idioTimeout = Nothing + } + +idioAcceptDataLossLens :: Lens' ImportDanglingIndexOptions Bool +idioAcceptDataLossLens = + lens idioAcceptDataLoss (\x y -> x {idioAcceptDataLoss = y}) + +idioMasterTimeoutLens :: Lens' ImportDanglingIndexOptions (Maybe (TimeUnits, Word32)) +idioMasterTimeoutLens = + lens idioMasterTimeout (\x y -> x {idioMasterTimeout = y}) + +idioTimeoutLens :: Lens' ImportDanglingIndexOptions (Maybe (TimeUnits, Word32)) +idioTimeoutLens = + lens idioTimeout (\x y -> x {idioTimeout = y}) + +-- | Render 'ImportDanglingIndexOptions' as URI parameters. 'Nothing' +-- fields are omitted, so 'defaultImportDanglingIndexOptions' emits +-- exactly one parameter: @accept_data_loss=true@. The order is +-- stable but unspecified — callers should treat it as a set. +importDanglingIndexOptionsParams :: ImportDanglingIndexOptions -> [(Text, Maybe Text)] +importDanglingIndexOptionsParams opts = + catMaybes + [ Just ("accept_data_loss", Just (boolQP (idioAcceptDataLoss opts))), + ("master_timeout",) . Just . renderDuration <$> idioMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> idioTimeout opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +-- | URI parameters accepted by @DELETE /_dangling/{uuid}@. Same +-- shape as 'ImportDanglingIndexOptions' minus the @accept_data_loss@ +-- flag (delete does not require it). +data DeleteDanglingIndexOptions = DeleteDanglingIndexOptions + { ddioMasterTimeout :: Maybe (TimeUnits, Word32), + ddioTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | No parameters. 'defaultDeleteDanglingIndexOptions' emits no +-- query string at all. +defaultDeleteDanglingIndexOptions :: DeleteDanglingIndexOptions +defaultDeleteDanglingIndexOptions = + DeleteDanglingIndexOptions + { ddioMasterTimeout = Nothing, + ddioTimeout = Nothing + } + +ddioMasterTimeoutLens :: Lens' DeleteDanglingIndexOptions (Maybe (TimeUnits, Word32)) +ddioMasterTimeoutLens = + lens ddioMasterTimeout (\x y -> x {ddioMasterTimeout = y}) + +ddioTimeoutLens :: Lens' DeleteDanglingIndexOptions (Maybe (TimeUnits, Word32)) +ddioTimeoutLens = + lens ddioTimeout (\x y -> x {ddioTimeout = y}) + +-- | Render 'DeleteDanglingIndexOptions' as URI parameters. 'Nothing' +-- fields are omitted, so 'defaultDeleteDanglingIndexOptions' produces +-- an empty list. The order is stable but unspecified. +deleteDanglingIndexOptionsParams :: DeleteDanglingIndexOptions -> [(Text, Maybe Text)] +deleteDanglingIndexOptionsParams opts = + catMaybes + [ ("master_timeout",) . Just . renderDuration <$> ddioMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> ddioTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/DiskUsage.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/DiskUsage.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/DiskUsage.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.DiskUsage +-- License : BSD-style (see the file LICENSE) +-- +-- Types for the @POST \/{target}/_disk_usage@ endpoint, shared by +-- Elasticsearch (7.x\/8.x\/9.x). This is an ES feature (core since +-- 7.15, technical preview); OpenSearch does not implement it, so calls +-- against an OpenSearch cluster will fail at runtime — the types are +-- still hosted under @Common@ to match the project's SLM\/Validate +-- precedent. See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.DiskUsage + ( -- * Response types + DiskUsageResponse (..), + DiskUsageIndex (..), + DiskUsageFieldBreakdown (..), + DiskUsageInvertedIndex (..), + + -- * URI parameters + DiskUsageOptions (..), + defaultDiskUsageOptions, + diskUsageOptionsParams, + + -- * Optics + durShardsLens, + durIndicesLens, + duiStoreSizeLens, + duiStoreSizeInBytesLens, + duiAllFieldsLens, + duiFieldsLens, + dufbTotalLens, + dufbTotalInBytesLens, + dufbInvertedIndexLens, + dufbStoredFieldsLens, + dufbStoredFieldsInBytesLens, + dufbDocValuesLens, + dufbDocValuesInBytesLens, + dufbPointsLens, + dufbPointsInBytesLens, + dufbNormsLens, + dufbNormsInBytesLens, + dufbTermVectorsLens, + dufbTermVectorsInBytesLens, + duiiTotalLens, + duiiTotalInBytesLens, + duoRunExpensiveTasksLens, + duoFlushLens, + duoAllowNoIndicesLens, + duoExpandWildcardsLens, + duoIgnoreUnavailableLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens) +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes + ( ShardResult, + ) + +-- | Top-level response of @POST \/{target}/_disk_usage@. The response +-- is an object with a @_shards@ summary plus one top-level key per +-- concrete index that was analysed; because index names are not +-- statically known, the per-index payload is collected into a 'KeyMap'. +data DiskUsageResponse = DiskUsageResponse + { -- | Shard-level execution summary (the canonical @_shards@ envelope). + durShards :: ShardResult, + -- | One entry per analysed index, keyed by index name. Built by + -- collecting every top-level key other than @_shards@; a literal + -- index named @_shards@ would therefore be silently dropped, but + -- ES forbids such names so this is impossible in practice. + durIndices :: KeyMap DiskUsageIndex + } + deriving stock (Eq, Show) + +instance FromJSON DiskUsageResponse where + parseJSON = withObject "DiskUsageResponse" $ \o -> do + shards <- o .: "_shards" + -- Everything except @_shards@ is the per-index payload. + indices <- traverse parseJSON (KM.delete "_shards" o) + pure $ DiskUsageResponse shards indices + +instance ToJSON DiskUsageResponse where + toJSON DiskUsageResponse {..} = + Object $ KM.insert "_shards" (toJSON durShards) (toJSON <$> durIndices) + +-- | The per-index payload: human-readable and byte-precise store sizes, +-- an @all_fields@ aggregate breakdown, and a @fields@ map of per-field +-- breakdowns. +data DiskUsageIndex = DiskUsageIndex + { -- | @store_size@ — human-readable store size of the analysed shards. + duiStoreSize :: Maybe Text, + -- | @store_size_in_bytes@ — byte-precise store size. + duiStoreSizeInBytes :: Maybe Int, + -- | @all_fields@ — aggregate breakdown across every field. + duiAllFields :: Maybe DiskUsageFieldBreakdown, + -- | @fields@ — per-field breakdowns, keyed by field name (which may + -- include a multi-field suffix such as @message.keyword@). + duiFields :: Maybe (KeyMap DiskUsageFieldBreakdown) + } + deriving stock (Eq, Show) + +instance FromJSON DiskUsageIndex where + parseJSON = withObject "DiskUsageIndex" $ \o -> + DiskUsageIndex + <$> o .:? "store_size" + <*> o .:? "store_size_in_bytes" + <*> o .:? "all_fields" + <*> o .:? "fields" + +instance ToJSON DiskUsageIndex where + toJSON DiskUsageIndex {..} = + object $ + catMaybes + [ ("store_size" .=) <$> duiStoreSize, + ("store_size_in_bytes" .=) <$> duiStoreSizeInBytes, + ("all_fields" .=) <$> duiAllFields, + ("fields" .=) <$> duiFields + ] + +-- | Breakdown of the disk usage of a single field (or the +-- @all_fields@ aggregate). Each structural component (@stored_fields@, +-- @doc_values@, @points@, @norms@, @term_vectors@) is reported as a +-- human-readable size plus a byte count; @inverted_index@ additionally +-- nests its own @{total, total_in_bytes}@ object. All fields are +-- 'Maybe' because the server omits a component when the field does not +-- use that structure (e.g. @doc_values@ is absent for @keyword@ +-- fields). +data DiskUsageFieldBreakdown = DiskUsageFieldBreakdown + { dufbTotal :: Maybe Text, + dufbTotalInBytes :: Maybe Int, + dufbInvertedIndex :: Maybe DiskUsageInvertedIndex, + dufbStoredFields :: Maybe Text, + dufbStoredFieldsInBytes :: Maybe Int, + dufbDocValues :: Maybe Text, + dufbDocValuesInBytes :: Maybe Int, + dufbPoints :: Maybe Text, + dufbPointsInBytes :: Maybe Int, + dufbNorms :: Maybe Text, + dufbNormsInBytes :: Maybe Int, + dufbTermVectors :: Maybe Text, + dufbTermVectorsInBytes :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON DiskUsageFieldBreakdown where + parseJSON = withObject "DiskUsageFieldBreakdown" $ \o -> + DiskUsageFieldBreakdown + <$> o .:? "total" + <*> o .:? "total_in_bytes" + <*> o .:? "inverted_index" + <*> o .:? "stored_fields" + <*> o .:? "stored_fields_in_bytes" + <*> o .:? "doc_values" + <*> o .:? "doc_values_in_bytes" + <*> o .:? "points" + <*> o .:? "points_in_bytes" + <*> o .:? "norms" + <*> o .:? "norms_in_bytes" + <*> o .:? "term_vectors" + <*> o .:? "term_vectors_in_bytes" + +instance ToJSON DiskUsageFieldBreakdown where + toJSON DiskUsageFieldBreakdown {..} = + object $ + catMaybes + [ ("total" .=) <$> dufbTotal, + ("total_in_bytes" .=) <$> dufbTotalInBytes, + ("inverted_index" .=) <$> dufbInvertedIndex, + ("stored_fields" .=) <$> dufbStoredFields, + ("stored_fields_in_bytes" .=) <$> dufbStoredFieldsInBytes, + ("doc_values" .=) <$> dufbDocValues, + ("doc_values_in_bytes" .=) <$> dufbDocValuesInBytes, + ("points" .=) <$> dufbPoints, + ("points_in_bytes" .=) <$> dufbPointsInBytes, + ("norms" .=) <$> dufbNorms, + ("norms_in_bytes" .=) <$> dufbNormsInBytes, + ("term_vectors" .=) <$> dufbTermVectors, + ("term_vectors_in_bytes" .=) <$> dufbTermVectorsInBytes + ] + +-- | The nested @inverted_index@ object inside a +-- 'DiskUsageFieldBreakdown': its own human-readable and byte-precise +-- totals. +data DiskUsageInvertedIndex = DiskUsageInvertedIndex + { duiiTotal :: Maybe Text, + duiiTotalInBytes :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON DiskUsageInvertedIndex where + parseJSON = withObject "DiskUsageInvertedIndex" $ \o -> + DiskUsageInvertedIndex + <$> o .:? "total" + <*> o .:? "total_in_bytes" + +instance ToJSON DiskUsageInvertedIndex where + toJSON DiskUsageInvertedIndex {..} = + object $ + catMaybes + [ ("total" .=) <$> duiiTotal, + ("total_in_bytes" .=) <$> duiiTotalInBytes + ] + +-- Lenses for DiskUsageResponse + +durShardsLens :: Lens' DiskUsageResponse ShardResult +durShardsLens = lens durShards (\x y -> x {durShards = y}) + +durIndicesLens :: Lens' DiskUsageResponse (KeyMap DiskUsageIndex) +durIndicesLens = lens durIndices (\x y -> x {durIndices = y}) + +-- Lenses for DiskUsageIndex + +duiStoreSizeLens :: Lens' DiskUsageIndex (Maybe Text) +duiStoreSizeLens = lens duiStoreSize (\x y -> x {duiStoreSize = y}) + +duiStoreSizeInBytesLens :: Lens' DiskUsageIndex (Maybe Int) +duiStoreSizeInBytesLens = + lens duiStoreSizeInBytes (\x y -> x {duiStoreSizeInBytes = y}) + +duiAllFieldsLens :: Lens' DiskUsageIndex (Maybe DiskUsageFieldBreakdown) +duiAllFieldsLens = lens duiAllFields (\x y -> x {duiAllFields = y}) + +duiFieldsLens :: + Lens' DiskUsageIndex (Maybe (KeyMap DiskUsageFieldBreakdown)) +duiFieldsLens = lens duiFields (\x y -> x {duiFields = y}) + +-- Lenses for DiskUsageFieldBreakdown + +dufbTotalLens :: Lens' DiskUsageFieldBreakdown (Maybe Text) +dufbTotalLens = lens dufbTotal (\x y -> x {dufbTotal = y}) + +dufbTotalInBytesLens :: Lens' DiskUsageFieldBreakdown (Maybe Int) +dufbTotalInBytesLens = lens dufbTotalInBytes (\x y -> x {dufbTotalInBytes = y}) + +dufbInvertedIndexLens :: + Lens' DiskUsageFieldBreakdown (Maybe DiskUsageInvertedIndex) +dufbInvertedIndexLens = + lens dufbInvertedIndex (\x y -> x {dufbInvertedIndex = y}) + +dufbStoredFieldsLens :: Lens' DiskUsageFieldBreakdown (Maybe Text) +dufbStoredFieldsLens = lens dufbStoredFields (\x y -> x {dufbStoredFields = y}) + +dufbStoredFieldsInBytesLens :: Lens' DiskUsageFieldBreakdown (Maybe Int) +dufbStoredFieldsInBytesLens = + lens dufbStoredFieldsInBytes (\x y -> x {dufbStoredFieldsInBytes = y}) + +dufbDocValuesLens :: Lens' DiskUsageFieldBreakdown (Maybe Text) +dufbDocValuesLens = lens dufbDocValues (\x y -> x {dufbDocValues = y}) + +dufbDocValuesInBytesLens :: Lens' DiskUsageFieldBreakdown (Maybe Int) +dufbDocValuesInBytesLens = + lens dufbDocValuesInBytes (\x y -> x {dufbDocValuesInBytes = y}) + +dufbPointsLens :: Lens' DiskUsageFieldBreakdown (Maybe Text) +dufbPointsLens = lens dufbPoints (\x y -> x {dufbPoints = y}) + +dufbPointsInBytesLens :: Lens' DiskUsageFieldBreakdown (Maybe Int) +dufbPointsInBytesLens = + lens dufbPointsInBytes (\x y -> x {dufbPointsInBytes = y}) + +dufbNormsLens :: Lens' DiskUsageFieldBreakdown (Maybe Text) +dufbNormsLens = lens dufbNorms (\x y -> x {dufbNorms = y}) + +dufbNormsInBytesLens :: Lens' DiskUsageFieldBreakdown (Maybe Int) +dufbNormsInBytesLens = lens dufbNormsInBytes (\x y -> x {dufbNormsInBytes = y}) + +dufbTermVectorsLens :: Lens' DiskUsageFieldBreakdown (Maybe Text) +dufbTermVectorsLens = lens dufbTermVectors (\x y -> x {dufbTermVectors = y}) + +dufbTermVectorsInBytesLens :: Lens' DiskUsageFieldBreakdown (Maybe Int) +dufbTermVectorsInBytesLens = + lens dufbTermVectorsInBytes (\x y -> x {dufbTermVectorsInBytes = y}) + +-- Lenses for DiskUsageInvertedIndex + +duiiTotalLens :: Lens' DiskUsageInvertedIndex (Maybe Text) +duiiTotalLens = lens duiiTotal (\x y -> x {duiiTotal = y}) + +duiiTotalInBytesLens :: Lens' DiskUsageInvertedIndex (Maybe Int) +duiiTotalInBytesLens = lens duiiTotalInBytes (\x y -> x {duiiTotalInBytes = y}) + +-- | URI parameters accepted by @POST \/{target}/_disk_usage@. See +-- . +-- +-- Note that @run_expensive_tasks@ is /required/ by the API (the call is +-- rejected without @run_expensive_tasks=true@); it is therefore a plain +-- 'Bool' rather than 'Maybe', and 'defaultDiskUsageOptions' sets it to +-- @True@ so that the parameterless 'diskUsage' works out of the box. +-- +-- Although the ES 7.17 docs list @wait_for_active_shards@ for this +-- endpoint, ES 7.17.25 actually rejects it with @400 contains +-- unrecognized parameter: [wait_for_active_shards]@, so it is /not/ +-- modelled here. The remaining parameters — @flush@, +-- @ignore_unavailable@, @allow_no_indices@ and @expand_wildcards@ — +-- were live-verified accepted against ES 7.17.25. +data DiskUsageOptions = DiskUsageOptions + { -- | @run_expensive_tasks@ (required) — must be @True@ for the API + -- to perform the analysis. Defaults to @True@ in + -- 'defaultDiskUsageOptions'. + duoRunExpensiveTasks :: Bool, + -- | @flush@ — perform a flush before analysis. Defaults to @True@ + -- on the server when omitted. + duoFlush :: Maybe Bool, + -- | @ignore_unavailable@ — error on missing\/closed indices. + duoIgnoreUnavailable :: Maybe Bool, + -- | @allow_no_indices@ — short-circuit if no concrete index matches. + duoAllowNoIndices :: Maybe Bool, + -- | @expand_wildcards@ — wildcard-pattern expansion policy. + duoExpandWildcards :: Maybe (NonEmpty ExpandWildcards) + } + deriving stock (Eq, Show) + +-- | 'DiskUsageOptions' with @run_expensive_tasks@ set to @True@ and +-- every other parameter @Nothing@. Unlike most @default*Options@ in +-- this module, this /does/ emit a query string +-- (@?run_expensive_tasks=true@) because the parameter is required by +-- the API. +defaultDiskUsageOptions :: DiskUsageOptions +defaultDiskUsageOptions = + DiskUsageOptions + { duoRunExpensiveTasks = True, + duoFlush = Nothing, + duoIgnoreUnavailable = Nothing, + duoAllowNoIndices = Nothing, + duoExpandWildcards = Nothing + } + +-- | Render a 'DiskUsageOptions' record as a @(key, value)@ list +-- suitable for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. +-- 'Nothing' fields are omitted, but @run_expensive_tasks@ is always +-- rendered (it is required). +diskUsageOptionsParams :: DiskUsageOptions -> [(Text, Maybe Text)] +diskUsageOptionsParams DiskUsageOptions {..} = + ("run_expensive_tasks", Just (boolText duoRunExpensiveTasks)) + : catMaybes + [ ("flush",) . Just . boolText <$> duoFlush, + ("ignore_unavailable",) . Just . boolText <$> duoIgnoreUnavailable, + ("allow_no_indices",) . Just . boolText <$> duoAllowNoIndices, + ("expand_wildcards",) . Just . renderExpandWildcards <$> duoExpandWildcards + ] + where + boolText True = "true" + boolText False = "false" + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + +-- Lenses for DiskUsageOptions + +duoRunExpensiveTasksLens :: Lens' DiskUsageOptions Bool +duoRunExpensiveTasksLens = + lens duoRunExpensiveTasks (\x y -> x {duoRunExpensiveTasks = y}) + +duoFlushLens :: Lens' DiskUsageOptions (Maybe Bool) +duoFlushLens = lens duoFlush (\x y -> x {duoFlush = y}) + +duoIgnoreUnavailableLens :: Lens' DiskUsageOptions (Maybe Bool) +duoIgnoreUnavailableLens = + lens duoIgnoreUnavailable (\x y -> x {duoIgnoreUnavailable = y}) + +duoAllowNoIndicesLens :: Lens' DiskUsageOptions (Maybe Bool) +duoAllowNoIndicesLens = + lens duoAllowNoIndices (\x y -> x {duoAllowNoIndices = y}) + +duoExpandWildcardsLens :: + Lens' DiskUsageOptions (Maybe (NonEmpty ExpandWildcards)) +duoExpandWildcardsLens = + lens duoExpandWildcards (\x y -> x {duoExpandWildcards = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Document.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Document.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Document.hs @@ -0,0 +1,875 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | URI-level option records and the request-body type for the +-- document-oriented endpoints that previously only supported a single +-- hard-coded wire shape: +-- +-- * 'GetDocumentOptions' — the @GET \/{index}\/_doc\/{id}@ (and mget) +-- URI parameters (@_source@, @_source_includes@\/@_source_excludes@, +-- @stored_fields@, @preference@, @realtime@, @refresh@, @routing@, +-- @version@, @version_type@). +-- * 'GetDocumentSourceOptions' — the @GET \/{index}\/_doc\/{id}\/_source@ +-- URI parameters (a subset of 'GetDocumentOptions' that drops +-- @stored_fields@ and the @_source@ toggle). +-- * 'DeleteDocumentOptions' — the @DELETE \/{index}\/_doc\/{id}@ +-- URI parameters (@wait_for_active_shards@, @refresh@, @routing@, +-- @timeout@, @version@, @version_type@, @if_seq_no@, +-- @if_primary_term@). +-- * 'DocumentExistsOptions' — the @HEAD \/{index}\/_doc\/{id}@ +-- existence-check URI parameters (@stored_fields@, @preference@, +-- @realtime@, @refresh@, @routing@, @version@, @version_type@). +-- * 'DocumentSourceExistsOptions' — the +-- @HEAD \/{index}\/_doc\/{id}\/_source@ existence-check URI +-- parameters (a subset of 'DocumentExistsOptions' that drops +-- @stored_fields@). +-- * 'ByQueryOptions' — the shared URI parameters of +-- @POST \/{index}\/_update_by_query@ and +-- @POST \/{index}\/_delete_by_query@ (@conflicts@, +-- @wait_for_completion@, @slices@, @max_docs@, @routing@, +-- @scroll_size@, @refresh@, @timeout@, @scroll@, @request_cache@, +-- @pipeline@). +-- * 'UpdateBody' — the @POST \/{index}\/_update\/{id}@ request body, +-- which is a discriminated union: a partial-document update +-- (@{\"doc\": …}@) or a script-driven update +-- (@{\"script\": …, \"upsert\": …, \"scripted_upsert\": …}@). +-- +-- All six options records follow the same convention established by +-- "Database.Bloodhound.Internal.Versions.Common.Types.Bulk" and +-- "Database.Bloodhound.Internal.Versions.Common.Types.Search": every +-- field is 'Maybe', the @default…@ value leaves every field @Nothing@ +-- so that the legacy parameterless entry points remain byte-for-byte +-- identical on the wire, and the @…OptionsParams@ renderers drop +-- @Nothing@ fields via 'Data.Maybe.catMaybes'. +module Database.Bloodhound.Internal.Versions.Common.Types.Document + ( -- * GetDocument options + GetDocumentOptions (..), + defaultGetDocumentOptions, + getDocumentOptionsParams, + + -- * GetDocumentSource options + GetDocumentSourceOptions (..), + defaultGetDocumentSourceOptions, + getDocumentSourceOptionsParams, + + -- * DeleteDocument options + DeleteDocumentOptions (..), + defaultDeleteDocumentOptions, + deleteDocumentOptionsParams, + + -- * DocumentExists options + DocumentExistsOptions (..), + defaultDocumentExistsOptions, + documentExistsOptionsParams, + + -- * DocumentSourceExists options + DocumentSourceExistsOptions (..), + defaultDocumentSourceExistsOptions, + documentSourceExistsParams, + + -- * ByQuery options + ByQueryOptions (..), + ConflictsPolicy (..), + Slices (..), + defaultByQueryOptions, + byQueryOptionsParams, + renderConflictsPolicy, + renderSlices, + + -- * UpdateBody + UpdateBody (..), + mkUpdateDoc, + mkUpdateScript, + + -- * Optics + gdoSourceLens, + gdoSourceIncludesLens, + gdoSourceExcludesLens, + gdoStoredFieldsLens, + gdoPreferenceLens, + gdoRealtimeLens, + gdoRefreshLens, + gdoRoutingLens, + gdoVersionLens, + gdoVersionTypeLens, + gdsoSourceIncludesLens, + gdsoSourceExcludesLens, + gdsoPreferenceLens, + gdsoRealtimeLens, + gdsoRefreshLens, + gdsoRoutingLens, + gdsoVersionLens, + gdsoVersionTypeLens, + ddoWaitForActiveShardsLens, + ddoRefreshLens, + ddoRoutingLens, + ddoTimeoutLens, + ddoVersionLens, + ddoVersionTypeLens, + ddoIfSeqNoLens, + ddoIfPrimaryTermLens, + deoStoredFieldsLens, + deoPreferenceLens, + deoRealtimeLens, + deoRefreshLens, + deoRoutingLens, + deoVersionLens, + deoVersionTypeLens, + dseoPreferenceLens, + dseoRealtimeLens, + dseoRefreshLens, + dseoRoutingLens, + dseoVersionLens, + dseoVersionTypeLens, + bqoConflictsLens, + bqoWaitForCompletionLens, + bqoRefreshLens, + bqoTimeoutLens, + bqoScrollLens, + bqoScrollSizeLens, + bqoSlicesLens, + bqoRoutingLens, + bqoMaxDocsLens, + bqoRequestCacheLens, + bqoPipelineLens, + ) +where + +import Data.Aeson (ToJSON (..), Value, (.=)) +import Data.Word (Word64) +import Database.Bloodhound.Internal.Utils.Imports + ( Lens', + Text, + catMaybes, + lens, + omitNulls, + showText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Indices + ( ActiveShardCount, + renderActiveShardCount, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Refresh + ( RefreshPolicy, + renderRefreshPolicy, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Script + ( Script, + scriptInnerValue, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.VersionType + ( VersionType, + renderVersionType, + ) +import Numeric.Natural (Natural) + +-- | URI parameters of the @GET \/{index}\/_doc\/{id}@ endpoint and its +-- multi-get siblings. See +-- +-- and +-- . +data GetDocumentOptions = GetDocumentOptions + { -- | @_source@ — when @Just False@ the source is omitted from the + -- response entirely. @Just True@ emits @_source=true@ explicitly + -- (the server treats it the same as @Nothing@, which omits the + -- parameter and relies on the default of returning the source). + gdoSource :: Maybe Bool, + -- | @_source_includes@ — comma-separated field globs to include. + gdoSourceIncludes :: Maybe Text, + -- | @_source_excludes@ — comma-separated field globs to exclude. + gdoSourceExcludes :: Maybe Text, + -- | @stored_fields@ — comma-separated list of stored fields to + -- return. Note this is the deprecated 7.x field-selection mechanism; + -- new code should prefer the @fields@ body field of @\_search@. It is + -- still honoured by the GET API. + gdoStoredFields :: Maybe Text, + -- | @preference@ — shard/route preference, e.g. @"_local"@. + gdoPreference :: Maybe Text, + -- | @realtime@ — when @Just False@, fetch the document from the + -- index rather than the translog (realtime). Defaults to @true@. + gdoRealtime :: Maybe Bool, + -- | @refresh@ — when @Just True@, refresh the relevant shard before + -- fetching so the GET sees the effect of the most recent indexed + -- document. + gdoRefresh :: Maybe Bool, + -- | @routing@ — target shard routing value. Must match the value + -- used at index time for routed documents. + gdoRouting :: Maybe Text, + -- | @version@ — return the document only if its current version + -- matches. Typically combined with 'gdoVersionType' = external. + gdoVersion :: Maybe Word64, + -- | @version_type@ — how to interpret 'gdoVersion'. See the + -- 'VersionType' renderer for the accepted values. + gdoVersionType :: Maybe VersionType + } + deriving stock (Eq, Show) + +-- | 'GetDocumentOptions' with every field @Nothing@. Emits an empty +-- query string, preserving the wire behaviour of the legacy +-- parameterless 'Database.Bloodhound.Common.Requests.getDocument'. +defaultGetDocumentOptions :: GetDocumentOptions +defaultGetDocumentOptions = + GetDocumentOptions + { gdoSource = Nothing, + gdoSourceIncludes = Nothing, + gdoSourceExcludes = Nothing, + gdoStoredFields = Nothing, + gdoPreference = Nothing, + gdoRealtime = Nothing, + gdoRefresh = Nothing, + gdoRouting = Nothing, + gdoVersion = Nothing, + gdoVersionType = Nothing + } + +-- | Render a 'GetDocumentOptions' record as a @key=value@ list for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. @Nothing@ +-- fields are omitted; the order of the list is stable but unspecified. +getDocumentOptionsParams :: GetDocumentOptions -> [(Text, Maybe Text)] +getDocumentOptionsParams GetDocumentOptions {..} = + catMaybes + [ ("_source",) . Just . boolText <$> gdoSource, + ("_source_includes",) . Just <$> gdoSourceIncludes, + ("_source_excludes",) . Just <$> gdoSourceExcludes, + ("stored_fields",) . Just <$> gdoStoredFields, + ("preference",) . Just <$> gdoPreference, + ("realtime",) . Just . boolText <$> gdoRealtime, + ("refresh",) . Just . boolText <$> gdoRefresh, + ("routing",) . Just <$> gdoRouting, + ("version",) . Just . showText <$> gdoVersion, + ("version_type",) . Just . renderVersionType <$> gdoVersionType + ] + +-- | URI parameters of the +-- @GET \/{index}\/_doc\/{id}\/_source@ endpoint. This is a subset of +-- 'GetDocumentOptions': the @_source=true@\/@_source=false@ toggle is +-- meaningless for a source-only endpoint (the whole response is the +-- @_source@ object), and @stored_fields@ is not honoured by the +-- source API (it belongs to the full GET envelope). See +-- . +data GetDocumentSourceOptions = GetDocumentSourceOptions + { -- | @_source_includes@ — comma-separated field globs to include. + gdsoSourceIncludes :: Maybe Text, + -- | @_source_excludes@ — comma-separated field globs to exclude. + gdsoSourceExcludes :: Maybe Text, + -- | @preference@ — shard/route preference, e.g. @"_local"@. + gdsoPreference :: Maybe Text, + -- | @realtime@ — when @Just False@, fetch the document from the + -- index rather than the translog (realtime). Defaults to @true@. + gdsoRealtime :: Maybe Bool, + -- | @refresh@ — when @Just True@, refresh the relevant shard + -- before fetching so the source GET sees the effect of the most + -- recent indexed document. + gdsoRefresh :: Maybe Bool, + -- | @routing@ — target shard routing value. Must match the value + -- used at index time for routed documents. + gdsoRouting :: Maybe Text, + -- | @version@ — return the document only if its current version + -- matches. Typically combined with 'gdsoVersionType' = external. + gdsoVersion :: Maybe Word64, + -- | @version_type@ — how to interpret 'gdsoVersion'. See the + -- 'VersionType' renderer for the accepted values. + gdsoVersionType :: Maybe VersionType + } + deriving stock (Eq, Show) + +-- | 'GetDocumentSourceOptions' with every field @Nothing@. Emits an +-- empty query string, preserving the wire behaviour of the +-- parameterless +-- 'Database.Bloodhound.Common.Requests.getDocumentSource'. +defaultGetDocumentSourceOptions :: GetDocumentSourceOptions +defaultGetDocumentSourceOptions = + GetDocumentSourceOptions + { gdsoSourceIncludes = Nothing, + gdsoSourceExcludes = Nothing, + gdsoPreference = Nothing, + gdsoRealtime = Nothing, + gdsoRefresh = Nothing, + gdsoRouting = Nothing, + gdsoVersion = Nothing, + gdsoVersionType = Nothing + } + +-- | Render a 'GetDocumentSourceOptions' record as a @key=value@ list +-- for 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. +-- @Nothing@ fields are omitted; the order of the list is stable but +-- unspecified. +getDocumentSourceOptionsParams :: GetDocumentSourceOptions -> [(Text, Maybe Text)] +getDocumentSourceOptionsParams GetDocumentSourceOptions {..} = + catMaybes + [ ("_source_includes",) . Just <$> gdsoSourceIncludes, + ("_source_excludes",) . Just <$> gdsoSourceExcludes, + ("preference",) . Just <$> gdsoPreference, + ("realtime",) . Just . boolText <$> gdsoRealtime, + ("refresh",) . Just . boolText <$> gdsoRefresh, + ("routing",) . Just <$> gdsoRouting, + ("version",) . Just . showText <$> gdsoVersion, + ("version_type",) . Just . renderVersionType <$> gdsoVersionType + ] + +-- | URI parameters of the @DELETE \/{index}\/_doc\/{id}@ endpoint. See +-- . +-- +-- This is a hybrid of 'GetDocumentOptions' (for the read-side +-- @version@\/@version_type@\/@routing@ parameters, which use the +-- simple 'Word64' + 'VersionType' form rather than the write-side +-- 'VersionControl' ADT — delete has no \"force\" or \"external_gte\" +-- semantics) and 'IndexDocumentSettings' (for the write-side +-- @refresh@, @wait_for_active_shards@, @if_seq_no@\/@if_primary_term@ +-- parameters, which share their types with the Index API). +-- +-- @timeout@ has no dedicated newtype in this library yet and is +-- passed through as 'Text' (e.g. @"5s"@), matching +-- 'ByQueryOptions'\'s 'bqoTimeout'. +data DeleteDocumentOptions = DeleteDocumentOptions + { -- | @wait_for_active_shards@ — number of active shard copies + -- required before the delete returns. Uses the shared + -- 'ActiveShardCount' type so @"all"@ and numeric counts are both + -- representable. Same semantics as + -- 'IndexDocumentSettings'\'s 'idsWaitForActiveShards'. + ddoWaitForActiveShards :: Maybe ActiveShardCount, + -- | @refresh@ — controls shard refresh behaviour after the delete. + -- Uses 'RefreshPolicy' (=@false@/=@true@/=@wait_for@) like + -- 'IndexDocumentSettings'\'s 'idsRefresh', not the bare 'Bool' + -- used by 'GetDocumentOptions' (which is pre-GET, not post-write). + ddoRefresh :: Maybe RefreshPolicy, + -- | @routing@ — target shard routing value. Must match the value + -- used at index time for routed documents. + ddoRouting :: Maybe Text, + -- | @timeout@ — per-request wall-clock timeout, e.g. @"5s"@. + ddoTimeout :: Maybe Text, + -- | @version@ — perform the delete only if the document's current + -- version matches. Typically combined with + -- 'ddoVersionType' = external. + ddoVersion :: Maybe Word64, + -- | @version_type@ — how to interpret 'ddoVersion'. See the + -- 'VersionType' renderer for the accepted values. + ddoVersionType :: Maybe VersionType, + -- | @if_seq_no@ — perform the delete only if the document's + -- current sequence number matches. Should be set together with + -- 'ddoIfPrimaryTerm' for optimistic concurrency control. If only + -- one of the two is set, the partial pair is sent verbatim and + -- Elasticsearch responds with HTTP 400 — by design, so caller + -- mistakes are not silently swallowed (same behaviour as + -- 'IndexDocumentSettings'\'s 'idsIfSeqNo'). + ddoIfSeqNo :: Maybe Word64, + -- | @if_primary_term@ — companion to 'ddoIfSeqNo'. See its + -- documentation for the half-set behaviour. + ddoIfPrimaryTerm :: Maybe Word64 + } + deriving stock (Eq, Show) + +-- | 'DeleteDocumentOptions' with every field @Nothing@. Emits an +-- empty query string, preserving the wire behaviour of the legacy +-- parameterless +-- 'Database.Bloodhound.Common.Requests.deleteDocument'. +defaultDeleteDocumentOptions :: DeleteDocumentOptions +defaultDeleteDocumentOptions = + DeleteDocumentOptions + { ddoWaitForActiveShards = Nothing, + ddoRefresh = Nothing, + ddoRouting = Nothing, + ddoTimeout = Nothing, + ddoVersion = Nothing, + ddoVersionType = Nothing, + ddoIfSeqNo = Nothing, + ddoIfPrimaryTerm = Nothing + } + +-- | Render a 'DeleteDocumentOptions' record as a @key=value@ list for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. +-- @Nothing@ fields are omitted; the order of the list is stable but +-- unspecified. The @if_seq_no@\/@if_primary_term@ pair is emitted +-- independently — only the fields that are set appear in the query +-- string (so a half-set pair is passed through to Elasticsearch's +-- HTTP 400 rather than being silently dropped). +deleteDocumentOptionsParams :: DeleteDocumentOptions -> [(Text, Maybe Text)] +deleteDocumentOptionsParams DeleteDocumentOptions {..} = + catMaybes + [ ("wait_for_active_shards",) . Just . renderActiveShardCount <$> ddoWaitForActiveShards, + ("refresh",) . Just . renderRefreshPolicy <$> ddoRefresh, + ("routing",) . Just <$> ddoRouting, + ("timeout",) . Just <$> ddoTimeout, + ("version",) . Just . showText <$> ddoVersion, + ("version_type",) . Just . renderVersionType <$> ddoVersionType, + ("if_seq_no",) . Just . showText <$> ddoIfSeqNo, + ("if_primary_term",) . Just . showText <$> ddoIfPrimaryTerm + ] + +-- | URI parameters of the @HEAD \/{index}\/_doc\/{id}@ existence +-- check. See +-- . +-- +-- This is the HEAD counterpart of 'GetDocumentOptions' restricted to +-- the parameters that influence shard selection / freshness / OCC on +-- a request that carries no body: the @_source@\/@_source_includes@\/ +-- @_source_excludes@ toggles are meaningless (a HEAD returns no body), +-- but @stored_fields@ is still a documented parameter and is kept +-- here for API-surface completeness. @refresh@ uses the read-side +-- 'Bool' form (pre-check, like 'GetDocumentOptions'\'s 'gdoRefresh') +-- rather than the write-side 'RefreshPolicy'. +data DocumentExistsOptions = DocumentExistsOptions + { -- | @stored_fields@ — documented for the HEAD API though it has + -- no body to populate; kept for completeness. Comma-separated list + -- of stored fields. + deoStoredFields :: Maybe Text, + -- | @preference@ — shard/route preference, e.g. @"_local"@. + deoPreference :: Maybe Text, + -- | @realtime@ — when @Just False@, perform the existence check + -- against the index rather than the translog (realtime). Defaults + -- to @true@. + deoRealtime :: Maybe Bool, + -- | @refresh@ — when @Just True@, refresh the relevant shard + -- before the check so the HEAD sees the effect of the most recent + -- indexed document. + deoRefresh :: Maybe Bool, + -- | @routing@ — target shard routing value. Must match the value + -- used at index time for routed documents. + deoRouting :: Maybe Text, + -- | @version@ — report existence only if the document's current + -- version matches. Typically combined with + -- 'deoVersionType' = external. + deoVersion :: Maybe Word64, + -- | @version_type@ — how to interpret 'deoVersion'. See the + -- 'VersionType' renderer for the accepted values. + deoVersionType :: Maybe VersionType + } + deriving stock (Eq, Show) + +-- | 'DocumentExistsOptions' with every field @Nothing@. Emits an +-- empty query string, preserving the wire behaviour of the legacy +-- parameterless +-- 'Database.Bloodhound.Common.Requests.documentExists'. +defaultDocumentExistsOptions :: DocumentExistsOptions +defaultDocumentExistsOptions = + DocumentExistsOptions + { deoStoredFields = Nothing, + deoPreference = Nothing, + deoRealtime = Nothing, + deoRefresh = Nothing, + deoRouting = Nothing, + deoVersion = Nothing, + deoVersionType = Nothing + } + +-- | Render a 'DocumentExistsOptions' record as a @key=value@ list for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. +-- @Nothing@ fields are omitted; the order of the list is stable but +-- unspecified. +documentExistsOptionsParams :: DocumentExistsOptions -> [(Text, Maybe Text)] +documentExistsOptionsParams DocumentExistsOptions {..} = + catMaybes + [ ("stored_fields",) . Just <$> deoStoredFields, + ("preference",) . Just <$> deoPreference, + ("realtime",) . Just . boolText <$> deoRealtime, + ("refresh",) . Just . boolText <$> deoRefresh, + ("routing",) . Just <$> deoRouting, + ("version",) . Just . showText <$> deoVersion, + ("version_type",) . Just . renderVersionType <$> deoVersionType + ] + +-- | URI parameters of the @HEAD \/{index}\/_doc\/{id}\/_source@ +-- existence check. See +-- . +-- +-- This is the HEAD counterpart of 'GetDocumentSourceOptions': a +-- strict subset of 'DocumentExistsOptions' that drops @stored_fields@ +-- (the source API does not honour it). The @_source@ toggle is +-- meaningless for a source-only endpoint and is also absent. +data DocumentSourceExistsOptions = DocumentSourceExistsOptions + { -- | @preference@ — shard/route preference, e.g. @"_local"@. + dseoPreference :: Maybe Text, + -- | @realtime@ — when @Just False@, perform the existence check + -- against the index rather than the translog (realtime). Defaults + -- to @true@. + dseoRealtime :: Maybe Bool, + -- | @refresh@ — when @Just True@, refresh the relevant shard + -- before the check so the HEAD sees the effect of the most recent + -- indexed document. + dseoRefresh :: Maybe Bool, + -- | @routing@ — target shard routing value. Must match the value + -- used at index time for routed documents. + dseoRouting :: Maybe Text, + -- | @version@ — report existence only if the document's current + -- version matches. Typically combined with + -- 'dseoVersionType' = external. + dseoVersion :: Maybe Word64, + -- | @version_type@ — how to interpret 'dseoVersion'. See the + -- 'VersionType' renderer for the accepted values. + dseoVersionType :: Maybe VersionType + } + deriving stock (Eq, Show) + +-- | 'DocumentSourceExistsOptions' with every field @Nothing@. Emits +-- an empty query string, preserving the wire behaviour of the legacy +-- parameterless +-- 'Database.Bloodhound.Common.Requests.documentSourceExists'. +defaultDocumentSourceExistsOptions :: DocumentSourceExistsOptions +defaultDocumentSourceExistsOptions = + DocumentSourceExistsOptions + { dseoPreference = Nothing, + dseoRealtime = Nothing, + dseoRefresh = Nothing, + dseoRouting = Nothing, + dseoVersion = Nothing, + dseoVersionType = Nothing + } + +-- | Render a 'DocumentSourceExistsOptions' record as a @key=value@ +-- list for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. +-- @Nothing@ fields are omitted; the order of the list is stable but +-- unspecified. +documentSourceExistsParams :: DocumentSourceExistsOptions -> [(Text, Maybe Text)] +documentSourceExistsParams DocumentSourceExistsOptions {..} = + catMaybes + [ ("preference",) . Just <$> dseoPreference, + ("realtime",) . Just . boolText <$> dseoRealtime, + ("refresh",) . Just . boolText <$> dseoRefresh, + ("routing",) . Just <$> dseoRouting, + ("version",) . Just . showText <$> dseoVersion, + ("version_type",) . Just . renderVersionType <$> dseoVersionType + ] + +-- | How the @update_by_query@ \/ @delete_by_query@ @conflicts@ URI +-- parameter should behave when a version conflict occurs. See +-- . +data ConflictsPolicy + = -- | @conflicts=proceed@ — continue processing the remaining + -- documents when a version conflict is encountered. + ConflictsProceed + | -- | @conflicts=abort@ — abort the request on the first conflict. + -- This is the server-side default. + ConflictsAbort + deriving stock (Eq, Show) + +renderConflictsPolicy :: ConflictsPolicy -> Text +renderConflictsPolicy = \case + ConflictsProceed -> "proceed" + ConflictsAbort -> "abort" + +-- | The @slices@ parameter — the number of sub-tasks to parallelise the +-- by-query work across. See +-- . +data Slices + = -- | @slices=auto@ — let the server pick (typically one per shard). + -- Recommended in the docs. + SlicesAuto + | -- | @slices=@ — explicit slice count. + SlicesCount Natural + deriving stock (Eq, Show) + +renderSlices :: Slices -> Text +renderSlices = \case + SlicesAuto -> "auto" + SlicesCount n -> showText n + +-- | Shared URI parameters of @POST \/{index}\/_update_by_query@ and +-- @POST \/{index}\/_delete_by_query@. The two endpoints accept the same +-- parameter set (see the ES docs); a single record therefore covers +-- both. The body is not affected — only the URI. +data ByQueryOptions = ByQueryOptions + { -- | @conflicts@ — what to do on version conflict. + bqoConflicts :: Maybe ConflictsPolicy, + -- | @wait_for_completion@ — when @Just False@ the request returns + -- immediately with a task id and runs asynchronously. Defaults to + -- @true@. + bqoWaitForCompletion :: Maybe Bool, + -- | @refresh@ — refresh all shards involved in the by-query after + -- it completes. + bqoRefresh :: Maybe RefreshPolicy, + -- | @timeout@ — per-request wall-clock timeout, e.g. @"5s"@. + bqoTimeout :: Maybe Text, + -- | @scroll@ — how long to keep the search context alive when + -- paging through the by-query, e.g. @"1m"@. + bqoScroll :: Maybe Text, + -- | @scroll_size@ — batch size for the internal scroll. + bqoScrollSize :: Maybe Natural, + -- | @slices@ — parallelism. + bqoSlices :: Maybe Slices, + -- | @routing@ — restrict the by-query to a shard-routing value. + bqoRouting :: Maybe Text, + -- | @max_docs@ — cap on the number of documents processed. + bqoMaxDocs :: Maybe Natural, + -- | @request_cache@ — override the index's @request_cache@ setting + -- for this by-query. + bqoRequestCache :: Maybe Bool, + -- | @pipeline@ — ingest pipeline to apply to each updated document + -- (update_by_query only; delete_by_query silently ignores it). + bqoPipeline :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'ByQueryOptions' with every field @Nothing@. Emits an empty query +-- string, preserving the wire behaviour of the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.updateByQuery' and +-- 'deleteByQuery'. +defaultByQueryOptions :: ByQueryOptions +defaultByQueryOptions = + ByQueryOptions + { bqoConflicts = Nothing, + bqoWaitForCompletion = Nothing, + bqoRefresh = Nothing, + bqoTimeout = Nothing, + bqoScroll = Nothing, + bqoScrollSize = Nothing, + bqoSlices = Nothing, + bqoRouting = Nothing, + bqoMaxDocs = Nothing, + bqoRequestCache = Nothing, + bqoPipeline = Nothing + } + +-- | Render a 'ByQueryOptions' record as a @key=value@ list for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. @Nothing@ +-- fields are omitted. +byQueryOptionsParams :: ByQueryOptions -> [(Text, Maybe Text)] +byQueryOptionsParams ByQueryOptions {..} = + catMaybes + [ ("conflicts",) . Just . renderConflictsPolicy <$> bqoConflicts, + ("wait_for_completion",) . Just . boolText <$> bqoWaitForCompletion, + ("refresh",) . Just . renderRefreshPolicy <$> bqoRefresh, + ("timeout",) . Just <$> bqoTimeout, + ("scroll",) . Just <$> bqoScroll, + ("scroll_size",) . Just . showText <$> bqoScrollSize, + ("slices",) . Just . renderSlices <$> bqoSlices, + ("routing",) . Just <$> bqoRouting, + ("max_docs",) . Just . showText <$> bqoMaxDocs, + ("request_cache",) . Just . boolText <$> bqoRequestCache, + ("pipeline",) . Just <$> bqoPipeline + ] + +-- | Body of @POST \/{index}\/_update\/{id}@. The Elasticsearch Update +-- API takes either a partial document (the @doc@ form) or a script +-- (the @script@ form); the two cannot be mixed in the same request. +-- See +-- . +-- +-- The legacy 'Database.Bloodhound.Common.Requests.updateDocument' +-- function constructs the 'UpdateDoc' form from its @patch@ argument; +-- use 'Database.Bloodhound.Common.Requests.updateDocumentWith' (added +-- alongside this type) to send the 'UpdateScript' form. +data UpdateBody + = -- | Partial-document update: sends @{"doc": }@, plus + -- @{"doc_as_upsert": true}@ when 'ubDocAsUpsert' is set so the + -- document is created if it does not yet exist. + UpdateDoc + { ubDoc :: Value, + ubDocAsUpsert :: Maybe Bool + } + | -- | Script-driven update: sends + -- @{"script": , "upsert": ?, "scripted_upsert": ?}@. + -- 'ubUpsert' is the document inserted if the referenced document + -- does not exist; 'ubScriptedUpsert' = @Just True@ flips that to + -- \"always run the script for the upsert too\". The script value + -- is rendered via 'scriptInnerValue' (no @\"script\"@ wrapper) + -- because it is already placed under the top-level @\"script\"@ key. + UpdateScript + { ubScript :: Script, + ubUpsert :: Maybe Value, + ubScriptedUpsert :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | Smart constructor for the @{"doc": …}@ body with no upsert behaviour. +mkUpdateDoc :: Value -> UpdateBody +mkUpdateDoc doc = UpdateDoc {ubDoc = doc, ubDocAsUpsert = Nothing} + +-- | Smart constructor for a script-only update (no upsert document, +-- no scripted_upsert). +mkUpdateScript :: Script -> UpdateBody +mkUpdateScript script = + UpdateScript + { ubScript = script, + ubUpsert = Nothing, + ubScriptedUpsert = Nothing + } + +-- Note: per-constructor field lenses are deliberately omitted. 'UpdateBody' +-- is a discriminated union, so a total 'Lens'' over e.g. 'ubDoc' would +-- either lie (returning a bogus value on 'UpdateScript') or silently +-- drop the script branch on update. Use the constructors / smart +-- constructors ('mkUpdateDoc', 'mkUpdateScript') to build values, and +-- pattern-match to inspect them. + +instance ToJSON UpdateBody where + toJSON (UpdateDoc doc mAsUpsert) = + omitNulls + [ "doc" .= doc, + "doc_as_upsert" .= mAsUpsert + ] + toJSON (UpdateScript script mUpsert mScriptedUpsert) = + omitNulls + [ "script" .= scriptInnerValue script, + "upsert" .= mUpsert, + "scripted_upsert" .= mScriptedUpsert + ] + +-- Lenses for GetDocumentOptions + +gdoSourceLens :: Lens' GetDocumentOptions (Maybe Bool) +gdoSourceLens = lens gdoSource (\x y -> x {gdoSource = y}) + +gdoSourceIncludesLens :: Lens' GetDocumentOptions (Maybe Text) +gdoSourceIncludesLens = lens gdoSourceIncludes (\x y -> x {gdoSourceIncludes = y}) + +gdoSourceExcludesLens :: Lens' GetDocumentOptions (Maybe Text) +gdoSourceExcludesLens = lens gdoSourceExcludes (\x y -> x {gdoSourceExcludes = y}) + +gdoStoredFieldsLens :: Lens' GetDocumentOptions (Maybe Text) +gdoStoredFieldsLens = lens gdoStoredFields (\x y -> x {gdoStoredFields = y}) + +gdoPreferenceLens :: Lens' GetDocumentOptions (Maybe Text) +gdoPreferenceLens = lens gdoPreference (\x y -> x {gdoPreference = y}) + +gdoRealtimeLens :: Lens' GetDocumentOptions (Maybe Bool) +gdoRealtimeLens = lens gdoRealtime (\x y -> x {gdoRealtime = y}) + +gdoRefreshLens :: Lens' GetDocumentOptions (Maybe Bool) +gdoRefreshLens = lens gdoRefresh (\x y -> x {gdoRefresh = y}) + +gdoRoutingLens :: Lens' GetDocumentOptions (Maybe Text) +gdoRoutingLens = lens gdoRouting (\x y -> x {gdoRouting = y}) + +gdoVersionLens :: Lens' GetDocumentOptions (Maybe Word64) +gdoVersionLens = lens gdoVersion (\x y -> x {gdoVersion = y}) + +gdoVersionTypeLens :: Lens' GetDocumentOptions (Maybe VersionType) +gdoVersionTypeLens = lens gdoVersionType (\x y -> x {gdoVersionType = y}) + +-- Lenses for GetDocumentSourceOptions + +gdsoSourceIncludesLens :: Lens' GetDocumentSourceOptions (Maybe Text) +gdsoSourceIncludesLens = lens gdsoSourceIncludes (\x y -> x {gdsoSourceIncludes = y}) + +gdsoSourceExcludesLens :: Lens' GetDocumentSourceOptions (Maybe Text) +gdsoSourceExcludesLens = lens gdsoSourceExcludes (\x y -> x {gdsoSourceExcludes = y}) + +gdsoPreferenceLens :: Lens' GetDocumentSourceOptions (Maybe Text) +gdsoPreferenceLens = lens gdsoPreference (\x y -> x {gdsoPreference = y}) + +gdsoRealtimeLens :: Lens' GetDocumentSourceOptions (Maybe Bool) +gdsoRealtimeLens = lens gdsoRealtime (\x y -> x {gdsoRealtime = y}) + +gdsoRefreshLens :: Lens' GetDocumentSourceOptions (Maybe Bool) +gdsoRefreshLens = lens gdsoRefresh (\x y -> x {gdsoRefresh = y}) + +gdsoRoutingLens :: Lens' GetDocumentSourceOptions (Maybe Text) +gdsoRoutingLens = lens gdsoRouting (\x y -> x {gdsoRouting = y}) + +gdsoVersionLens :: Lens' GetDocumentSourceOptions (Maybe Word64) +gdsoVersionLens = lens gdsoVersion (\x y -> x {gdsoVersion = y}) + +gdsoVersionTypeLens :: Lens' GetDocumentSourceOptions (Maybe VersionType) +gdsoVersionTypeLens = lens gdsoVersionType (\x y -> x {gdsoVersionType = y}) + +-- Lenses for DeleteDocumentOptions + +ddoWaitForActiveShardsLens :: Lens' DeleteDocumentOptions (Maybe ActiveShardCount) +ddoWaitForActiveShardsLens = + lens ddoWaitForActiveShards (\x y -> x {ddoWaitForActiveShards = y}) + +ddoRefreshLens :: Lens' DeleteDocumentOptions (Maybe RefreshPolicy) +ddoRefreshLens = lens ddoRefresh (\x y -> x {ddoRefresh = y}) + +ddoRoutingLens :: Lens' DeleteDocumentOptions (Maybe Text) +ddoRoutingLens = lens ddoRouting (\x y -> x {ddoRouting = y}) + +ddoTimeoutLens :: Lens' DeleteDocumentOptions (Maybe Text) +ddoTimeoutLens = lens ddoTimeout (\x y -> x {ddoTimeout = y}) + +ddoVersionLens :: Lens' DeleteDocumentOptions (Maybe Word64) +ddoVersionLens = lens ddoVersion (\x y -> x {ddoVersion = y}) + +ddoVersionTypeLens :: Lens' DeleteDocumentOptions (Maybe VersionType) +ddoVersionTypeLens = lens ddoVersionType (\x y -> x {ddoVersionType = y}) + +ddoIfSeqNoLens :: Lens' DeleteDocumentOptions (Maybe Word64) +ddoIfSeqNoLens = lens ddoIfSeqNo (\x y -> x {ddoIfSeqNo = y}) + +ddoIfPrimaryTermLens :: Lens' DeleteDocumentOptions (Maybe Word64) +ddoIfPrimaryTermLens = lens ddoIfPrimaryTerm (\x y -> x {ddoIfPrimaryTerm = y}) + +-- Lenses for DocumentExistsOptions + +deoStoredFieldsLens :: Lens' DocumentExistsOptions (Maybe Text) +deoStoredFieldsLens = lens deoStoredFields (\x y -> x {deoStoredFields = y}) + +deoPreferenceLens :: Lens' DocumentExistsOptions (Maybe Text) +deoPreferenceLens = lens deoPreference (\x y -> x {deoPreference = y}) + +deoRealtimeLens :: Lens' DocumentExistsOptions (Maybe Bool) +deoRealtimeLens = lens deoRealtime (\x y -> x {deoRealtime = y}) + +deoRefreshLens :: Lens' DocumentExistsOptions (Maybe Bool) +deoRefreshLens = lens deoRefresh (\x y -> x {deoRefresh = y}) + +deoRoutingLens :: Lens' DocumentExistsOptions (Maybe Text) +deoRoutingLens = lens deoRouting (\x y -> x {deoRouting = y}) + +deoVersionLens :: Lens' DocumentExistsOptions (Maybe Word64) +deoVersionLens = lens deoVersion (\x y -> x {deoVersion = y}) + +deoVersionTypeLens :: Lens' DocumentExistsOptions (Maybe VersionType) +deoVersionTypeLens = lens deoVersionType (\x y -> x {deoVersionType = y}) + +-- Lenses for DocumentSourceExistsOptions + +dseoPreferenceLens :: Lens' DocumentSourceExistsOptions (Maybe Text) +dseoPreferenceLens = lens dseoPreference (\x y -> x {dseoPreference = y}) + +dseoRealtimeLens :: Lens' DocumentSourceExistsOptions (Maybe Bool) +dseoRealtimeLens = lens dseoRealtime (\x y -> x {dseoRealtime = y}) + +dseoRefreshLens :: Lens' DocumentSourceExistsOptions (Maybe Bool) +dseoRefreshLens = lens dseoRefresh (\x y -> x {dseoRefresh = y}) + +dseoRoutingLens :: Lens' DocumentSourceExistsOptions (Maybe Text) +dseoRoutingLens = lens dseoRouting (\x y -> x {dseoRouting = y}) + +dseoVersionLens :: Lens' DocumentSourceExistsOptions (Maybe Word64) +dseoVersionLens = lens dseoVersion (\x y -> x {dseoVersion = y}) + +dseoVersionTypeLens :: Lens' DocumentSourceExistsOptions (Maybe VersionType) +dseoVersionTypeLens = lens dseoVersionType (\x y -> x {dseoVersionType = y}) + +-- Lenses for ByQueryOptions + +bqoConflictsLens :: Lens' ByQueryOptions (Maybe ConflictsPolicy) +bqoConflictsLens = lens bqoConflicts (\x y -> x {bqoConflicts = y}) + +bqoWaitForCompletionLens :: Lens' ByQueryOptions (Maybe Bool) +bqoWaitForCompletionLens = lens bqoWaitForCompletion (\x y -> x {bqoWaitForCompletion = y}) + +bqoRefreshLens :: Lens' ByQueryOptions (Maybe RefreshPolicy) +bqoRefreshLens = lens bqoRefresh (\x y -> x {bqoRefresh = y}) + +bqoTimeoutLens :: Lens' ByQueryOptions (Maybe Text) +bqoTimeoutLens = lens bqoTimeout (\x y -> x {bqoTimeout = y}) + +bqoScrollLens :: Lens' ByQueryOptions (Maybe Text) +bqoScrollLens = lens bqoScroll (\x y -> x {bqoScroll = y}) + +bqoScrollSizeLens :: Lens' ByQueryOptions (Maybe Natural) +bqoScrollSizeLens = lens bqoScrollSize (\x y -> x {bqoScrollSize = y}) + +bqoSlicesLens :: Lens' ByQueryOptions (Maybe Slices) +bqoSlicesLens = lens bqoSlices (\x y -> x {bqoSlices = y}) + +bqoRoutingLens :: Lens' ByQueryOptions (Maybe Text) +bqoRoutingLens = lens bqoRouting (\x y -> x {bqoRouting = y}) + +bqoMaxDocsLens :: Lens' ByQueryOptions (Maybe Natural) +bqoMaxDocsLens = lens bqoMaxDocs (\x y -> x {bqoMaxDocs = y}) + +bqoRequestCacheLens :: Lens' ByQueryOptions (Maybe Bool) +bqoRequestCacheLens = lens bqoRequestCache (\x y -> x {bqoRequestCache = y}) + +bqoPipelineLens :: Lens' ByQueryOptions (Maybe Text) +bqoPipelineLens = lens bqoPipeline (\x y -> x {bqoPipeline = y}) + +boolText :: Bool -> Text +boolText True = "true" +boolText False = "false" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Enrich.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Enrich.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Enrich.hs @@ -0,0 +1,571 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Enrich +-- Description : Types for the Elasticsearch Enrich policy API +-- +-- Defines the request and response shapes for the ES X-Pack Enrich policy +-- endpoints (under @\/_enrich\/policy*@). An enrich policy attaches a +-- follower lookup index built from a source index, letting documents +-- indexed into other indices be decorated with fields resolved by +-- matching a key (@match@, @geo_match@, @range@). +-- +-- * @PUT /_enrich/policy/{policy_id}@ — create or update ('EnrichPolicy'). +-- * @DELETE /_enrich/policy/{policy_id}@ — returns 'Acknowledged'. +-- * @GET /_enrich/policy[/{policy_id}]@ — 'EnrichPoliciesResponse'. +-- * @POST /_enrich/policy/{policy_id}/_execute@ — returns 'Acknowledged' +-- (with 'EnrichExecuteOptions' for @wait_for_completion@). +-- * @GET /_enrich/_execute_stats@ — 'EnrichExecuteStatsResponse'. +-- * @GET /_enrich/policy/{policy_id}/_execute_stats@ — same response +-- shape, filtered to one policy. +-- +-- Enrich ships in Elasticsearch 7.5 and later and lives in the free +-- (basic) X-Pack tier; ES7\/ES8\/ES9 share the same wire surface, which +-- is why these types live in the Common layer alongside SLM\/ILM. +-- OpenSearch does not implement the enrich API, so calls against an +-- OpenSearch cluster will fail at runtime — the types are still hosted +-- under @Common@ to match the project's SLM\/DiskUsage precedent. +-- +-- The policy body uses a @sum-type-as-object-key@ encoding: the policy +-- type name (@match@, @geo_match@, @range@) is the JSON object key and +-- the 'EnrichPolicyConfig' is its value. 'EnrichPolicyConfig' models the +-- stable enrich-specific fields (@indices@, @match_field@, +-- @enrich_fields@, optional @query@) and carries an @epcExtras@ +-- 'KeyMap' catch-all so unknown sibling fields survive a round-trip +-- (the same strategy used by +-- "Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlAnomalyJobs"). +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Enrich + ( -- * Identity + EnrichPolicyId (..), + + -- * Policy type tag + EnrichPolicyType (..), + enrichPolicyTypeText, + + -- * Policy config (inner object) + EnrichPolicyConfig (..), + defaultEnrichPolicyConfig, + enrichPolicyConfigIndicesLens, + enrichPolicyConfigMatchFieldLens, + enrichPolicyConfigEnrichFieldsLens, + enrichPolicyConfigQueryLens, + enrichPolicyConfigExtrasLens, + + -- * Policy (PUT body / GET @config@) + EnrichPolicy (..), + enrichPolicyTypeTagLens, + enrichPolicyConfigLens, + + -- * GET response + EnrichPolicyInfo (..), + enrichPolicyInfoNameLens, + enrichPolicyInfoPolicyLens, + EnrichPoliciesResponse (..), + enrichPoliciesResponseListLens, + + -- * Execute stats + EnrichPolicyPhase (..), + enrichPolicyPhaseText, + EnrichExecuteStatsEntry (..), + enrichExecuteStatsEntryPolicyLens, + enrichExecuteStatsEntryLastExecutionTimeLens, + enrichExecuteStatsEntryRunningPolicyIndexSearchLens, + enrichExecuteStatsEntryPhaseLens, + enrichExecuteStatsEntryExtrasLens, + EnrichExecuteStatsResponse (..), + enrichExecuteStatsResponseExecutorPoolLens, + enrichExecuteStatsResponseStatsLens, + + -- * Execute options + EnrichExecuteOptions (..), + defaultEnrichExecuteOptions, + enrichExecuteOptionsParams, + enrichExecuteOptionsWaitForCompletionLens, + ) +where + +import Data.Aeson +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) +import Data.Text (Text) +import Data.Vector qualified as V +import Database.Bloodhound.Internal.Utils.Imports (Lens', Parser, lens, omitNulls) +import Database.Bloodhound.Internal.Versions.Common.Types.Indices + ( IndexPattern (..), + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( FieldName (..), + ) + +-- | Identifies an enrich policy in the @\/_enrich\/policy\/{policy_id}@ +-- URL path. Wraps 'Text' so it round-trips through JSON as a bare string +-- but is distinct at the Haskell type level from SLM\/ILM policy ids. +newtype EnrichPolicyId = EnrichPolicyId {unEnrichPolicyId :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +-- | The enrich policy type — the JSON object key that tags the policy +-- config in both the PUT body and the GET @config@ value. Documented +-- values: @match@, @geo_match@, @range@; the custom branch absorbs +-- anything newer (ES has historically added policy types under the same +-- envelope, e.g. future @mismatch@-style processors). +data EnrichPolicyType + = EnrichPolicyTypeMatch + | EnrichPolicyTypeGeoMatch + | EnrichPolicyTypeRange + | EnrichPolicyTypeCustom Text + deriving stock (Eq, Show) + +-- | The wire spelling of each 'EnrichPolicyType' — used both as the +-- object key on encode and to recognise the key on decode. +enrichPolicyTypeText :: EnrichPolicyType -> Text +enrichPolicyTypeText = \case + EnrichPolicyTypeMatch -> "match" + EnrichPolicyTypeGeoMatch -> "geo_match" + EnrichPolicyTypeRange -> "range" + EnrichPolicyTypeCustom t -> t + +-- | The policy type tag serialises as a bare string (the same token used +-- as the object key by 'EnrichPolicy'). This instance lets the tag be +-- carried as a JSON value too; the policy body encoder still emits it as +-- the object key via 'enrichPolicyTypeText'. +instance ToJSON EnrichPolicyType where + toJSON = toJSON . enrichPolicyTypeText + +instance FromJSON EnrichPolicyType where + parseJSON = withText "EnrichPolicyType" $ \t -> pure $ + case t of + "match" -> EnrichPolicyTypeMatch + "geo_match" -> EnrichPolicyTypeGeoMatch + "range" -> EnrichPolicyTypeRange + other -> EnrichPolicyTypeCustom other + +-- | A single enrich policy config — the /inner/ object that is the value +-- of the type-tag key (@match@ \/ @geo_match@ \/ @range@) in the PUT +-- body and in the GET @config@ value. The stable enrich-specific fields +-- are typed; any unknown sibling fields are preserved in 'epcExtras' so +-- the structure round-trips through @encode . decode@ even when ES adds +-- new optional fields. +data EnrichPolicyConfig = EnrichPolicyConfig + { -- | @indices@ — one or more source indices (or wildcard patterns + -- such as @logs-*@). Accepted on decode either as a JSON array of + -- strings or as a single bare string; always emitted as an array on + -- encode. + epcIndices :: NonEmpty IndexPattern, + -- | @match_field@ — the field used as the lookup key in the source + -- index. + epcMatchField :: FieldName, + -- | @enrich_fields@ — the fields copied from the source index into + -- the follower enrich index. Accepted on decode either as an array + -- or a single bare string; always emitted as an array on encode. + epcEnrichFields :: NonEmpty FieldName, + -- | @query@ — optional filter restricting which source documents are + -- eligible. Carried as an opaque 'Value' because it is a standard + -- ES query DSL body (callers build it with the typed 'Query' and + -- 'toJSON' it in). This mirrors the SLM\/MlAnomalyJob precedent for + -- non-category-specific nested bodies. + epcQuery :: Maybe Value, + -- | Catch-all for every other sibling field ES adds in future + -- (@description@, @remote_indices@, ...) so decode is + -- forward-compatible and @encode . decode@ round-trips. + epcExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | A minimal config: one 'IndexPattern' and one 'FieldName' for both +-- @match_field@ and @enrich_fields@, no @query@, no extras. Intended as +-- a starting point callers then overwrite with the record lenses. +defaultEnrichPolicyConfig :: + IndexPattern -> + FieldName -> + NonEmpty FieldName -> + EnrichPolicyConfig +defaultEnrichPolicyConfig indices matchField enrichFields = + EnrichPolicyConfig + { epcIndices = indices :| [], + epcMatchField = matchField, + epcEnrichFields = enrichFields, + epcQuery = Nothing, + epcExtras = KM.empty + } + +-- Known keys inside the config object — used to split the decoded +-- 'Object' into the typed fields and the @epcExtras@ catch-all. +configKnownKeys :: [Key] +configKnownKeys = ["indices", "match_field", "enrich_fields", "query"] + +instance FromJSON EnrichPolicyConfig where + parseJSON = withObject "EnrichPolicyConfig" $ \o -> do + indices <- parseIndices =<< o .:? "indices" + matchField <- o .: "match_field" + enrichFields <- parseFieldList "enrich_fields" =<< o .: "enrich_fields" + query <- o .:? "query" + let extras = KM.fromList . filter ((`notElem` configKnownKeys) . fst) $ KM.toList o + pure EnrichPolicyConfig {epcIndices = indices, epcMatchField = matchField, epcEnrichFields = enrichFields, epcQuery = query, epcExtras = extras} + where + -- ES accepts @indices@ as either a JSON array or a single string. + -- A single string is normalised to a one-element 'NonEmpty' list. + parseIndices :: Maybe Value -> Parser (NonEmpty IndexPattern) + parseIndices (Just (Array xs)) + | V.null xs = fail "enrich policy 'indices' array must be non-empty" + | otherwise = toNonEmptyM (V.toList xs) + parseIndices (Just v@(String _)) = (:| []) <$> parseJSON v + parseIndices Nothing = fail "enrich policy is missing required 'indices'" + parseIndices _ = fail "enrich policy 'indices' must be a string or array of strings" + + -- Generic non-empty list-of-strings parser used for both + -- @enrich_fields@ (typed) and would-be-typed siblings. Accepts a + -- single bare string as a one-element list. + parseFieldList :: (FromJSON a) => String -> Value -> Parser (NonEmpty a) + parseFieldList label (Array xs) + | V.null xs = fail ("enrich policy '" <> label <> "' array must be non-empty") + | otherwise = toNonEmptyM (V.toList xs) + parseFieldList _ v@(String _) = (:| []) <$> parseJSON v + parseFieldList label _ = fail ("enrich policy '" <> label <> "' must be a string or array of strings") + + -- Parse every element of a list, failing the whole parse if any + -- element is malformed; the empty case was already excluded by the + -- callers above, so 'NonEmpty' construction is total here. + toNonEmptyM :: (FromJSON a) => [Value] -> Parser (NonEmpty a) + toNonEmptyM [] = fail "enrich policy field: unexpected empty array" + toNonEmptyM (h : rest) = (:|) <$> parseJSON h <*> traverse parseJSON rest + +instance ToJSON EnrichPolicyConfig where + toJSON EnrichPolicyConfig {..} = + -- 'object' (not 'omitNulls') so the @epcExtras@ catch-all survives a + -- round-trip even when it carries a @null@ or empty-array value — the + -- documented forward-compat guarantee. The known fields are pre-filtered + -- by 'catMaybes' (stripping 'Nothing's), so they never contribute a + -- 'Null' here, and the extras have already had the known keys stripped + -- on decode. + object $ + catMaybes + [ Just ("indices" .= NE.toList epcIndices), + Just ("match_field" .= epcMatchField), + Just ("enrich_fields" .= NE.toList epcEnrichFields), + ("query" .=) <$> epcQuery + ] + -- Merge the extras catch-all last so caller-supplied keys are + -- preserved verbatim; the four known keys above are deliberately + -- not present in @epcExtras@ (the decoder strips them out). + <> [toPair kv | kv <- KM.toList epcExtras] + where + toPair (k, v) = k .= v + +-- | The PUT request body for @PUT /_enrich/policy/{policy_id}@ and the +-- @config@ value in the GET response. The policy type name is the JSON +-- object key and the 'EnrichPolicyConfig' is the (sole) value. There is +-- exactly one key on the wire. +data EnrichPolicy = EnrichPolicy + { epTypeTag :: EnrichPolicyType, + epConfig :: EnrichPolicyConfig + } + deriving stock (Eq, Show) + +instance ToJSON EnrichPolicy where + toJSON EnrichPolicy {..} = + Object $ + KM.singleton + (fromText (enrichPolicyTypeText epTypeTag)) + (toJSON epConfig) + +instance FromJSON EnrichPolicy where + parseJSON = withObject "EnrichPolicy" parse + where + parse o = + case KM.toList o of + [(k, v)] -> do + cfg <- parseJSON v + pure + EnrichPolicy + { epTypeTag = parseTypeKey (toText k), + epConfig = cfg + } + [] -> fail "enrich policy body must have exactly one type key, got an empty object" + _ -> fail ("enrich policy body must have exactly one type key, got " <> show (length (KM.toList o)) <> " keys") + + parseTypeKey :: Text -> EnrichPolicyType + parseTypeKey "match" = EnrichPolicyTypeMatch + parseTypeKey "geo_match" = EnrichPolicyTypeGeoMatch + parseTypeKey "range" = EnrichPolicyTypeRange + parseTypeKey other = EnrichPolicyTypeCustom other + +-- | A single policy entry as returned by @GET /_enrich/policy[/{id}]@. +-- The @config@ sub-object is the full 'EnrichPolicy' body (type tag + +-- config) and @name@ is the policy id. +data EnrichPolicyInfo = EnrichPolicyInfo + { epiName :: EnrichPolicyId, + epiPolicy :: EnrichPolicy + } + deriving stock (Eq, Show) + +instance FromJSON EnrichPolicyInfo where + parseJSON = withObject "EnrichPolicyInfo" $ \o -> do + name <- o .: "name" + policy <- o .: "config" + pure EnrichPolicyInfo {epiName = name, epiPolicy = policy} + +instance ToJSON EnrichPolicyInfo where + toJSON EnrichPolicyInfo {..} = + object + [ "name" .= epiName, + "config" .= epiPolicy + ] + +-- | Response body of @GET /_enrich/policy[/{id}]@: a @policies@ array of +-- 'EnrichPolicyInfo' entries. +newtype EnrichPoliciesResponse = EnrichPoliciesResponse + { unEnrichPoliciesResponse :: [EnrichPolicyInfo] + } + deriving stock (Eq, Show) + +instance FromJSON EnrichPoliciesResponse where + parseJSON = withObject "EnrichPoliciesResponse" $ \o -> + EnrichPoliciesResponse <$> o .: "policies" + +instance ToJSON EnrichPoliciesResponse where + toJSON (EnrichPoliciesResponse ps) = + object ["policies" .= ps] + +-- | The @phase@ of an enrich policy execution as returned by +-- @GET /_enrich/.../_execute_stats@. Documented values: @ENDED@, +-- @RUNNING@; the custom branch absorbs anything newer. +data EnrichPolicyPhase + = EnrichPolicyPhaseEnded + | EnrichPolicyPhaseRunning + | EnrichPolicyPhaseCustom Text + deriving stock (Eq, Show) + +enrichPolicyPhaseText :: EnrichPolicyPhase -> Text +enrichPolicyPhaseText = \case + EnrichPolicyPhaseEnded -> "ENDED" + EnrichPolicyPhaseRunning -> "RUNNING" + EnrichPolicyPhaseCustom t -> t + +instance ToJSON EnrichPolicyPhase where + toJSON = toJSON . enrichPolicyPhaseText + +instance FromJSON EnrichPolicyPhase where + parseJSON = withText "EnrichPolicyPhase" $ \t -> pure $ + case t of + "ENDED" -> EnrichPolicyPhaseEnded + "RUNNING" -> EnrichPolicyPhaseRunning + other -> EnrichPolicyPhaseCustom other + +-- | One entry of the @execute_stats@ array. @last_execution_time@ is +-- carried as a raw 'Value' because ES 7.x emits it as epoch-millis +-- while 8.x\/9.x emit an ISO-8601 string — the 'Maybe' 'Value' on +-- 'eseeLastExecutionTime' tolerates both shapes +-- without forcing a lossy conversion. Unknown sibling fields are +-- preserved in 'eseeExtras'. +data EnrichExecuteStatsEntry = EnrichExecuteStatsEntry + { eseePolicy :: EnrichPolicyId, + -- | Epoch milliseconds (ES 7.x) or ISO-8601 string (ES 8.x\/9.x). + -- Carried as a raw 'Value' to tolerate both shapes; absent before + -- the first execution. + eseeLastExecutionTime :: Maybe Value, + eseeRunningPolicyIndexSearch :: Maybe Bool, + eseePhase :: Maybe EnrichPolicyPhase, + eseeExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +executeStatsEntryKnownKeys :: [Key] +executeStatsEntryKnownKeys = + ["policy", "last_execution_time", "running_policy_index_search", "phase"] + +instance FromJSON EnrichExecuteStatsEntry where + parseJSON = withObject "EnrichExecuteStatsEntry" $ \o -> do + policy <- o .: "policy" + lastExecutionTime <- o .:? "last_execution_time" + running <- o .:? "running_policy_index_search" + phase <- o .:? "phase" + let extras = + KM.fromList $ + filter ((`notElem` executeStatsEntryKnownKeys) . fst) $ + KM.toList o + pure + EnrichExecuteStatsEntry + { eseePolicy = policy, + eseeLastExecutionTime = lastExecutionTime, + eseeRunningPolicyIndexSearch = running, + eseePhase = phase, + eseeExtras = extras + } + +instance ToJSON EnrichExecuteStatsEntry where + toJSON EnrichExecuteStatsEntry {..} = + -- 'object' (not 'omitNulls') so the @eseeExtras@ catch-all survives a + -- round-trip even when it carries a @null@ or empty-array value. The + -- known fields are pre-filtered by 'catMaybes' (stripping 'Nothing's). + object $ + catMaybes + [ Just ("policy" .= eseePolicy), + ("last_execution_time" .=) <$> eseeLastExecutionTime, + ("running_policy_index_search" .=) <$> eseeRunningPolicyIndexSearch, + ("phase" .=) <$> eseePhase + ] + <> [toPair kv | kv <- KM.toList eseeExtras] + where + toPair (k, v) = k .= v + +-- | Response body of @GET /_enrich/_execute_stats@ (and the per-policy +-- @GET /_enrich/policy/{id}/_execute_stats@ variant): the +-- @executor_pool@ name plus the @execute_stats@ array. +data EnrichExecuteStatsResponse = EnrichExecuteStatsResponse + { eesrExecutorPool :: Maybe Text, + eesrStats :: [EnrichExecuteStatsEntry] + } + deriving stock (Eq, Show) + +instance FromJSON EnrichExecuteStatsResponse where + parseJSON = withObject "EnrichExecuteStatsResponse" $ \o -> do + executorPool <- o .:? "executor_pool" + stats <- fromMaybe [] <$> (o .:? "execute_stats") + pure + EnrichExecuteStatsResponse + { eesrExecutorPool = executorPool, + eesrStats = stats + } + +instance ToJSON EnrichExecuteStatsResponse where + toJSON EnrichExecuteStatsResponse {..} = + omitNulls $ + catMaybes + [ ("executor_pool" .=) <$> eesrExecutorPool, + Just ("execute_stats" .= eesrStats) + ] + +-- | URI parameters accepted by @POST /_enrich/policy/{policy_id}/_execute@. +-- Only @wait_for_completion@ is documented for the execute endpoint; it +-- defaults to @true@ on the server, which makes the call synchronous and +-- returns 'Acknowledged'. When set to @false@ ES returns a task handle +-- instead — callers that need that shape should decode the raw body +-- separately. +data EnrichExecuteOptions = EnrichExecuteOptions + { eeoWaitForCompletion :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | An empty options record — encodes to no query string, reproducing +-- the parameterless 'executeEnrichPolicy'. +defaultEnrichExecuteOptions :: EnrichExecuteOptions +defaultEnrichExecuteOptions = + EnrichExecuteOptions + { eeoWaitForCompletion = Nothing + } + +-- | Render an 'EnrichExecuteOptions' as a @(key, value)@ list for +-- 'withQueries'. 'Nothing' fields are omitted. +enrichExecuteOptionsParams :: EnrichExecuteOptions -> [(Text, Maybe Text)] +enrichExecuteOptionsParams EnrichExecuteOptions {..} = + catMaybes + [ ("wait_for_completion",) . Just . boolText <$> eeoWaitForCompletion + ] + where + boolText True = "true" + boolText False = "false" + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +enrichPolicyConfigIndicesLens :: + Lens' EnrichPolicyConfig (NonEmpty IndexPattern) +enrichPolicyConfigIndicesLens = + lens epcIndices (\x y -> x {epcIndices = y}) + +enrichPolicyConfigMatchFieldLens :: + Lens' EnrichPolicyConfig FieldName +enrichPolicyConfigMatchFieldLens = + lens epcMatchField (\x y -> x {epcMatchField = y}) + +enrichPolicyConfigEnrichFieldsLens :: + Lens' EnrichPolicyConfig (NonEmpty FieldName) +enrichPolicyConfigEnrichFieldsLens = + lens epcEnrichFields (\x y -> x {epcEnrichFields = y}) + +enrichPolicyConfigQueryLens :: + Lens' EnrichPolicyConfig (Maybe Value) +enrichPolicyConfigQueryLens = + lens epcQuery (\x y -> x {epcQuery = y}) + +enrichPolicyConfigExtrasLens :: + Lens' EnrichPolicyConfig (KeyMap Value) +enrichPolicyConfigExtrasLens = + lens epcExtras (\x y -> x {epcExtras = y}) + +enrichPolicyTypeTagLens :: Lens' EnrichPolicy EnrichPolicyType +enrichPolicyTypeTagLens = + lens epTypeTag (\x y -> x {epTypeTag = y}) + +enrichPolicyConfigLens :: Lens' EnrichPolicy EnrichPolicyConfig +enrichPolicyConfigLens = + lens epConfig (\x y -> x {epConfig = y}) + +enrichPolicyInfoNameLens :: Lens' EnrichPolicyInfo EnrichPolicyId +enrichPolicyInfoNameLens = + lens epiName (\x y -> x {epiName = y}) + +enrichPolicyInfoPolicyLens :: Lens' EnrichPolicyInfo EnrichPolicy +enrichPolicyInfoPolicyLens = + lens epiPolicy (\x y -> x {epiPolicy = y}) + +enrichPoliciesResponseListLens :: + Lens' EnrichPoliciesResponse [EnrichPolicyInfo] +enrichPoliciesResponseListLens = + lens + unEnrichPoliciesResponse + (\_ y -> EnrichPoliciesResponse y) + +enrichExecuteStatsEntryPolicyLens :: + Lens' EnrichExecuteStatsEntry EnrichPolicyId +enrichExecuteStatsEntryPolicyLens = + lens eseePolicy (\x y -> x {eseePolicy = y}) + +enrichExecuteStatsEntryLastExecutionTimeLens :: + Lens' EnrichExecuteStatsEntry (Maybe Value) +enrichExecuteStatsEntryLastExecutionTimeLens = + lens eseeLastExecutionTime (\x y -> x {eseeLastExecutionTime = y}) + +enrichExecuteStatsEntryRunningPolicyIndexSearchLens :: + Lens' EnrichExecuteStatsEntry (Maybe Bool) +enrichExecuteStatsEntryRunningPolicyIndexSearchLens = + lens + eseeRunningPolicyIndexSearch + (\x y -> x {eseeRunningPolicyIndexSearch = y}) + +enrichExecuteStatsEntryPhaseLens :: + Lens' EnrichExecuteStatsEntry (Maybe EnrichPolicyPhase) +enrichExecuteStatsEntryPhaseLens = + lens eseePhase (\x y -> x {eseePhase = y}) + +enrichExecuteStatsEntryExtrasLens :: + Lens' EnrichExecuteStatsEntry (KeyMap Value) +enrichExecuteStatsEntryExtrasLens = + lens eseeExtras (\x y -> x {eseeExtras = y}) + +enrichExecuteStatsResponseExecutorPoolLens :: + Lens' EnrichExecuteStatsResponse (Maybe Text) +enrichExecuteStatsResponseExecutorPoolLens = + lens eesrExecutorPool (\x y -> x {eesrExecutorPool = y}) + +enrichExecuteStatsResponseStatsLens :: + Lens' EnrichExecuteStatsResponse [EnrichExecuteStatsEntry] +enrichExecuteStatsResponseStatsLens = + lens eesrStats (\x y -> x {eesrStats = y}) + +enrichExecuteOptionsWaitForCompletionLens :: + Lens' EnrichExecuteOptions (Maybe Bool) +enrichExecuteOptionsWaitForCompletionLens = + lens eeoWaitForCompletion (\x y -> x {eeoWaitForCompletion = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/ExpandWildcards.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/ExpandWildcards.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/ExpandWildcards.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards +-- Copyright : (C) 2014, 2018 Chris Allen +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Chris Allen +-- Stability : provisional +-- Portability : GHC +-- +-- The @expand_wildcards@ URI parameter accepted by many index and +-- search endpoints (resolve-index, field-caps, search, etc.). Kept in a +-- dedicated leaf module so that every type module can import it +-- without risking a cycle (in particular +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Indices' needs it +-- for 'ResolveIndexOptions' but cannot import +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Search', which +-- sits above it in the module graph). +module Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards (..), + expandWildcardsText, + ) +where + +import Control.Applicative (empty) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..)) +import Data.Text (Text) +import Prelude hiding (filter, head) + +data ExpandWildcards + = ExpandWildcardsAll + | ExpandWildcardsOpen + | ExpandWildcardsClosed + | -- | @hidden@ — match hidden indices (e.g. @.kibana@). Must be + -- combined with 'ExpandWildcardsOpen' and\/or 'ExpandWildcardsClosed' + -- when sent to the server; on its own the server rejects it. + ExpandWildcardsHidden + | ExpandWildcardsNone + deriving stock (Eq, Show) + +-- | Wire rendering of a single 'ExpandWildcards' value. Both the +-- 'ToJSON' instance and the various URI param renderers go through +-- this function, so there is a single source of truth for the string. +expandWildcardsText :: ExpandWildcards -> Text +expandWildcardsText ExpandWildcardsAll = "all" +expandWildcardsText ExpandWildcardsOpen = "open" +expandWildcardsText ExpandWildcardsClosed = "closed" +expandWildcardsText ExpandWildcardsHidden = "hidden" +expandWildcardsText ExpandWildcardsNone = "none" + +instance ToJSON ExpandWildcards where + toJSON = String . expandWildcardsText + +instance FromJSON ExpandWildcards where + parseJSON (String "all") = pure ExpandWildcardsAll + parseJSON (String "open") = pure ExpandWildcardsOpen + parseJSON (String "closed") = pure ExpandWildcardsClosed + parseJSON (String "hidden") = pure ExpandWildcardsHidden + parseJSON (String "none") = pure ExpandWildcardsNone + parseJSON _ = empty diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Explain.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Explain.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Explain.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Explain +-- Copyright : (C) 2014, 2018 Chris Allen +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Chris Allen +-- Stability : provisional +-- Portability : GHC +-- +-- Types for the @POST \/{index}\/_explain\/{id}@ endpoint, shared +-- verbatim by Elasticsearch (7.x\/8.x\/9.x) and OpenSearch +-- (1.x\/2.x\/3.x). See +-- +-- * +-- * +module Database.Bloodhound.Internal.Versions.Common.Types.Explain + ( -- * Response types + Explanation (..), + ExplainResponse (..), + + -- * Request body + ExplainQuery (..), + + -- * URI parameters + ExplainOptions (..), + defaultExplainOptions, + explainOptionsParams, + + -- * Optics + explanationValueLens, + explanationDescriptionLens, + explanationDetailsLens, + explainResponseIndexLens, + explainResponseIdLens, + explainResponseMatchedLens, + explainResponseExplanationLens, + eoRoutingLens, + eoPreferenceLens, + eoStoredFieldsLens, + eoSourceLens, + eoSourceIncludesLens, + eoSourceExcludesLens, + eoLenientLens, + eoDefaultOperatorLens, + eoDfLens, + eoAnalyzerLens, + eoAnalyzeWildcardLens, + ) +where + +import Data.Aeson +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( DocId (..), + IndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Query + ( Query, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Query.Commons + ( BooleanOperator (And, Or), + ) + +-- | Recursive score explanation returned by the @_explain@ endpoint. +-- Each node carries the @value@ this sub-clause contributed to the +-- overall score, a human-readable @description@ of how that value was +-- computed, and a (possibly empty) list of child 'Explanation's that +-- were combined to produce it. Leaves carry an empty +-- 'explanationDetails' list. +-- +-- The shape is identical between Elasticsearch and OpenSearch and has +-- been stable since the earliest releases that ship the @_explain@ +-- endpoint, so it lives in the Common layer and is re-exported by +-- every backend. +data Explanation = Explanation + { -- | The numeric score contribution. The ES\/OS docs type this as + -- a @number@; we model it as 'Double' to admit fractional scores. + -- A value of @0.0@ does /not/ by itself mean "no match": check + -- 'explainResponseMatched' for that. + explanationValue :: Double, + -- | Human-readable description of the scoring formula at this + -- node. The exact text is server-defined and may change between + -- versions; callers should treat it as diagnostic prose and not + -- parse it programmatically. + explanationDescription :: Text, + -- | Child explanations combined by the parent. Empty for leaves. + -- The combinator (sum, product, max, ...) is implicit and is + -- described in 'explanationDescription'. + explanationDetails :: [Explanation] + } + deriving stock (Eq, Show) + +instance FromJSON Explanation where + parseJSON = withObject "Explanation" $ \o -> + Explanation + <$> o + .: "value" + <*> o + .: "description" + <*> o + .:? "details" + .!= [] + +instance ToJSON Explanation where + toJSON Explanation {..} = + object + [ "value" .= explanationValue, + "description" .= explanationDescription, + "details" .= explanationDetails + ] + +-- | Top-level wrapper of the @_explain@ response. The @matched@ flag +-- tells the caller whether the document matched the query at all: +-- when it did not, the server omits the @explanation@ field entirely +-- (hence 'explainResponseExplanation' is a 'Maybe'); when it did, +-- the server returns a recursive 'Explanation' describing how the +-- score was computed. Always inspect 'explainResponseMatched' +-- before reading 'explainResponseExplanation'. +data ExplainResponse = ExplainResponse + { explainResponseIndex :: IndexName, + explainResponseId :: DocId, + explainResponseMatched :: Bool, + -- | 'Nothing' when 'explainResponseMatched' is @False@ (the + -- server omits the field entirely) or when the server sends + -- @\"explanation\": null@. @Just@ an 'Explanation' on a + -- matched document. + explainResponseExplanation :: Maybe Explanation + } + deriving stock (Eq, Show) + +instance FromJSON ExplainResponse where + parseJSON = withObject "ExplainResponse" $ \o -> + ExplainResponse + <$> o + .: "_index" + <*> o + .: "_id" + <*> o + .: "matched" + <*> o + .:? "explanation" + +-- Lenses for Explanation + +explanationValueLens :: Lens' Explanation Double +explanationValueLens = lens explanationValue (\x y -> x {explanationValue = y}) + +explanationDescriptionLens :: Lens' Explanation Text +explanationDescriptionLens = + lens explanationDescription (\x y -> x {explanationDescription = y}) + +explanationDetailsLens :: Lens' Explanation [Explanation] +explanationDetailsLens = lens explanationDetails (\x y -> x {explanationDetails = y}) + +-- Lenses for ExplainResponse + +explainResponseIndexLens :: Lens' ExplainResponse IndexName +explainResponseIndexLens = + lens explainResponseIndex (\x y -> x {explainResponseIndex = y}) + +explainResponseIdLens :: Lens' ExplainResponse DocId +explainResponseIdLens = + lens explainResponseId (\x y -> x {explainResponseId = y}) + +explainResponseMatchedLens :: Lens' ExplainResponse Bool +explainResponseMatchedLens = + lens explainResponseMatched (\x y -> x {explainResponseMatched = y}) + +explainResponseExplanationLens :: Lens' ExplainResponse (Maybe Explanation) +explainResponseExplanationLens = + lens explainResponseExplanation (\x y -> x {explainResponseExplanation = y}) + +-- | Request body of the @_explain@ endpoint: a 'Query' wrapped as +-- @{"query": ...}@. The server rejects the larger 'Search' body shape +-- (it does not accept @from@, @size@, @track_scores@, etc.), so the +-- request builder takes a 'Query' directly and wraps it in this +-- newtype. Mirrors +-- "Database.Bloodhound.Internal.Versions.Common.Types.Count".CountQuery. +newtype ExplainQuery = ExplainQuery {explainQuery :: Query} + deriving stock (Eq, Show) + +instance ToJSON ExplainQuery where + toJSON (ExplainQuery q) = object ["query" .= q] + +-- | URI parameters of the @POST \/{index}\/_explain\/{id}@ endpoint. See +-- +-- and +-- . +-- +-- Every field is 'Maybe'; 'defaultExplainOptions' leaves them all +-- @Nothing@, which emits no query string and is therefore byte-for-byte +-- equivalent to the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.explainDocument'. +-- +-- Important: 'explainDocumentWith' always sends the 'Query' as a JSON +-- body (@{"query": ...}@). The five query-parsing parameters below are +-- only honoured by the server when @_explain@ is driven by a URI-mode +-- @q=...@ query string, /which this client does not currently emit/ — +-- they are therefore inert on the wire today and are modelled here +-- prospectively (so a future URI-search variant can expose them without +-- a schema change). Setting them has no effect until such a variant +-- exists: +-- +-- * 'eoDefaultOperator', 'eoAnalyzer', 'eoDf', 'eoAnalyzeWildcard', +-- 'eoLenient' +-- +-- The source-selection and routing parameters apply regardless of how +-- the query is supplied: +-- +-- * 'eoStoredFields', 'eoSource', 'eoSourceIncludes', 'eoSourceExcludes', +-- 'eoRouting', 'eoPreference' +data ExplainOptions = ExplainOptions + { -- | @routing@ — target shard routing value. Must match the value + -- used at index time for custom-routed documents. + eoRouting :: Maybe Text, + -- | @preference@ — shard\/route preference, e.g. @"_local"@. + eoPreference :: Maybe Text, + -- | @stored_fields@ — comma-separated list of stored fields to + -- return. + eoStoredFields :: Maybe Text, + -- | @_source@ — when @Just False@ the @_source@ is omitted from the + -- response entirely. @Just True@ emits @_source=true@ explicitly. + eoSource :: Maybe Bool, + -- | @_source_includes@ — comma-separated field globs to include. + eoSourceIncludes :: Maybe Text, + -- | @_source_excludes@ — comma-separated field globs to exclude. + eoSourceExcludes :: Maybe Text, + -- | @lenient@ — when @Just True@, format-based failures (e.g. + -- providing text on a numeric field) are ignored. + eoLenient :: Maybe Bool, + -- | @default_operator@ — default operator for query-string parsing + -- (@AND@\/@OR@). ES accepts @and@\/@AND@\/@or@\/@OR@ on the wire; + -- we emit the canonical uppercase form documented in the prose, + -- even though 'BooleanOperator'\'s JSON encoding is lowercase (the + -- body form); see 'explainOptionsParams'. + eoDefaultOperator :: Maybe BooleanOperator, + -- | @df@ — default field for query-string terms with no explicit + -- field prefix. + eoDf :: Maybe Text, + -- | @analyzer@ — name of the analyzer to use for the query string. + eoAnalyzer :: Maybe Text, + -- | @analyze_wildcard@ — when @Just True@, wildcard terms are + -- analyzed. + eoAnalyzeWildcard :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'ExplainOptions' with every field @Nothing@. Emits an empty query +-- string, preserving the wire behaviour of the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.explainDocument'. +defaultExplainOptions :: ExplainOptions +defaultExplainOptions = + ExplainOptions + { eoRouting = Nothing, + eoPreference = Nothing, + eoStoredFields = Nothing, + eoSource = Nothing, + eoSourceIncludes = Nothing, + eoSourceExcludes = Nothing, + eoLenient = Nothing, + eoDefaultOperator = Nothing, + eoDf = Nothing, + eoAnalyzer = Nothing, + eoAnalyzeWildcard = Nothing + } + +-- | Render an 'ExplainOptions' record as a @(key, value)@ list suitable +-- for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. 'Nothing' +-- fields are omitted, so 'defaultExplainOptions' produces an empty list +-- (and therefore no query string). The order of the list is stable but +-- /unspecified/ — callers and tests should treat it as a set. +explainOptionsParams :: ExplainOptions -> [(Text, Maybe Text)] +explainOptionsParams ExplainOptions {..} = + catMaybes + [ ("routing",) . Just <$> eoRouting, + ("preference",) . Just <$> eoPreference, + ("stored_fields",) . Just <$> eoStoredFields, + ("_source",) . Just . boolText <$> eoSource, + ("_source_includes",) . Just <$> eoSourceIncludes, + ("_source_excludes",) . Just <$> eoSourceExcludes, + ("lenient",) . Just . boolText <$> eoLenient, + ("default_operator",) . Just . renderDefaultOperator <$> eoDefaultOperator, + ("df",) . Just <$> eoDf, + ("analyzer",) . Just <$> eoAnalyzer, + ("analyze_wildcard",) . Just . boolText <$> eoAnalyzeWildcard + ] + where + boolText True = "true" + boolText False = "false" + -- The ES @_explain@ URI parameter accepts @AND@\/@and@\/@OR@\/@or@ + -- (all four forms); we emit the canonical uppercase form used in + -- the ES docs prose, whereas 'BooleanOperator'\'s 'ToJSON' renders + -- lowercase @and@\/@or@ (the JSON body form). Render uppercase here + -- to match the documented canonical query-string contract. + renderDefaultOperator And = "AND" + renderDefaultOperator Or = "OR" + +-- Lenses for ExplainOptions + +eoRoutingLens :: Lens' ExplainOptions (Maybe Text) +eoRoutingLens = lens eoRouting (\x y -> x {eoRouting = y}) + +eoPreferenceLens :: Lens' ExplainOptions (Maybe Text) +eoPreferenceLens = lens eoPreference (\x y -> x {eoPreference = y}) + +eoStoredFieldsLens :: Lens' ExplainOptions (Maybe Text) +eoStoredFieldsLens = lens eoStoredFields (\x y -> x {eoStoredFields = y}) + +eoSourceLens :: Lens' ExplainOptions (Maybe Bool) +eoSourceLens = lens eoSource (\x y -> x {eoSource = y}) + +eoSourceIncludesLens :: Lens' ExplainOptions (Maybe Text) +eoSourceIncludesLens = lens eoSourceIncludes (\x y -> x {eoSourceIncludes = y}) + +eoSourceExcludesLens :: Lens' ExplainOptions (Maybe Text) +eoSourceExcludesLens = lens eoSourceExcludes (\x y -> x {eoSourceExcludes = y}) + +eoLenientLens :: Lens' ExplainOptions (Maybe Bool) +eoLenientLens = lens eoLenient (\x y -> x {eoLenient = y}) + +eoDefaultOperatorLens :: Lens' ExplainOptions (Maybe BooleanOperator) +eoDefaultOperatorLens = lens eoDefaultOperator (\x y -> x {eoDefaultOperator = y}) + +eoDfLens :: Lens' ExplainOptions (Maybe Text) +eoDfLens = lens eoDf (\x y -> x {eoDf = y}) + +eoAnalyzerLens :: Lens' ExplainOptions (Maybe Text) +eoAnalyzerLens = lens eoAnalyzer (\x y -> x {eoAnalyzer = y}) + +eoAnalyzeWildcardLens :: Lens' ExplainOptions (Maybe Bool) +eoAnalyzeWildcardLens = lens eoAnalyzeWildcard (\x y -> x {eoAnalyzeWildcard = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/FieldCaps.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/FieldCaps.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/FieldCaps.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.FieldCaps +-- +-- Request and response types for the @POST /_field_caps@ and +-- @POST \/{index}\/_field_caps@ endpoints, which return the +-- capabilities of fields across one or more indices (whether they are +-- searchable, aggregatable, their type, and the indices in which they +-- are defined). +-- +-- The request references field names as glob-style patterns (e.g. +-- @\"user\"@, @\"@timestamp@\" or @\"geo*\"@) and optionally carries an +-- @index_filter@ query (only indices matching the query are considered) +-- and / or @runtime_mappings@ (definitions of runtime fields to take +-- into account when computing capabilities). +-- +-- See +-- +-- and +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.FieldCaps + ( -- * Request body + FieldPattern (..), + FieldCapsRequest (..), + defaultFieldCapsRequest, + + -- * URI parameters + FieldCapsOptions (..), + defaultFieldCapsOptions, + fieldCapsOptionsParams, + + -- * Response + FieldCapsResponse (..), + FieldCapability (..), + + -- * Optics + fieldCapsRequestIndexFilterLens, + fieldCapsRequestRuntimeMappingsLens, + fcoFieldsLens, + fcoAllowNoIndicesLens, + fcoExpandWildcardsLens, + fcoIgnoreUnavailableLens, + fcoIncludeUnmappedLens, + fieldCapsResponseIndicesLens, + fieldCapsResponseFieldsLens, + fieldCapabilityTypeLens, + fieldCapabilitySearchableLens, + fieldCapabilityAggregatableLens, + fieldCapabilityIndicesLens, + fieldCapabilityNonSearchableIndicesLens, + fieldCapabilityNonAggregatableIndicesLens, + fieldCapabilityMetadataFieldLens, + fieldCapabilityMetaLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap (KeyMap) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( IndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Query (Query) +import Database.Bloodhound.Internal.Versions.Common.Types.Search + ( ExpandWildcards, + expandWildcardsText, + ) +import Optics.Lens + +-- | A field-name pattern passed to the @fields@ parameter of +-- 'FieldCapsRequest'. Plain names (@user@), dotted paths +-- (@@timestamp@) and glob patterns (@geo*@) are all valid; the +-- server interprets the wildcards. We wrap 'Text' in a newtype to +-- distinguish patterns from exact 'Database.Bloodhound.Internal.Versions.Common.Types.Newtypes.FieldName's. +newtype FieldPattern = FieldPattern {unFieldPattern :: Text} + deriving stock (Eq, Show, Ord) + deriving newtype (ToJSON, FromJSON) + +-- | Body of @POST /_field_caps@. Carries only the @index_filter@ query +-- and the @runtime_mappings@ object; the @fields@ array is sent as a +-- URI query parameter (see 'FieldCapsOptions') for cross-version +-- compatibility — Elasticsearch ≤ 7.x does not accept @fields@ in the +-- body (it was added in 8.5). An empty 'FieldCapsRequest' is +-- equivalent to sending @{}@. +data FieldCapsRequest = FieldCapsRequest + { fieldCapsRequestIndexFilter :: Maybe Query, + fieldCapsRequestRuntimeMappings :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +instance ToJSON FieldCapsRequest where + toJSON req = + object $ + catMaybes + [ ("index_filter" .=) <$> fieldCapsRequestIndexFilter req, + ("runtime_mappings" .=) <$> fieldCapsRequestRuntimeMappings req + ] + +fieldCapsRequestIndexFilterLens :: Lens' FieldCapsRequest (Maybe Query) +fieldCapsRequestIndexFilterLens = lens fieldCapsRequestIndexFilter (\x y -> x {fieldCapsRequestIndexFilter = y}) + +fieldCapsRequestRuntimeMappingsLens :: Lens' FieldCapsRequest (Maybe (KeyMap Value)) +fieldCapsRequestRuntimeMappingsLens = lens fieldCapsRequestRuntimeMappings (\x y -> x {fieldCapsRequestRuntimeMappings = y}) + +-- | 'FieldCapsRequest' with every body field set to 'Nothing'. Produces +-- an empty JSON object (@{}@) — equivalent to a bodyless request. +defaultFieldCapsRequest :: FieldCapsRequest +defaultFieldCapsRequest = + FieldCapsRequest + { fieldCapsRequestIndexFilter = Nothing, + fieldCapsRequestRuntimeMappings = Nothing + } + +-- | URI parameters accepted by @/_field_caps@: @fields@ (the +-- glob-style field patterns to inspect, comma-joined when more than +-- one), @allow_no_indices@, @expand_wildcards@ (reuses the +-- 'ExpandWildcards' sum type from "Database.Bloodhound.Internal.Versions.Common.Types.Search"), +-- @ignore_unavailable@ and @include_unmapped@. The deprecated 7.x-only +-- @filters@ parameter and the ES-only @types@ (8.2+) / +-- @include_empty_fields@ (8.13+) parameters are not modelled yet. +-- +-- Note that @fields@ is a URI parameter rather than a body field: +-- Elasticsearch ≤ 7.x only accepts @fields@ in the query string. +data FieldCapsOptions = FieldCapsOptions + { fcoFields :: Maybe [FieldPattern], + fcoAllowNoIndices :: Maybe Bool, + fcoExpandWildcards :: Maybe [ExpandWildcards], + fcoIgnoreUnavailable :: Maybe Bool, + fcoIncludeUnmapped :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'FieldCapsOptions' with every parameter set to 'Nothing'. Produces +-- no query string, so a call made with this value is byte-identical to +-- a parameterless call. +defaultFieldCapsOptions :: FieldCapsOptions +defaultFieldCapsOptions = + FieldCapsOptions + { fcoFields = Nothing, + fcoAllowNoIndices = Nothing, + fcoExpandWildcards = Nothing, + fcoIgnoreUnavailable = Nothing, + fcoIncludeUnmapped = Nothing + } + +fcoFieldsLens :: Lens' FieldCapsOptions (Maybe [FieldPattern]) +fcoFieldsLens = lens fcoFields (\x y -> x {fcoFields = y}) + +fcoAllowNoIndicesLens :: Lens' FieldCapsOptions (Maybe Bool) +fcoAllowNoIndicesLens = lens fcoAllowNoIndices (\x y -> x {fcoAllowNoIndices = y}) + +fcoExpandWildcardsLens :: Lens' FieldCapsOptions (Maybe [ExpandWildcards]) +fcoExpandWildcardsLens = lens fcoExpandWildcards (\x y -> x {fcoExpandWildcards = y}) + +fcoIgnoreUnavailableLens :: Lens' FieldCapsOptions (Maybe Bool) +fcoIgnoreUnavailableLens = lens fcoIgnoreUnavailable (\x y -> x {fcoIgnoreUnavailable = y}) + +fcoIncludeUnmappedLens :: Lens' FieldCapsOptions (Maybe Bool) +fcoIncludeUnmappedLens = lens fcoIncludeUnmapped (\x y -> x {fcoIncludeUnmapped = y}) + +-- | Render 'FieldCapsOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultFieldCapsOptions' produces an empty list. +fieldCapsOptionsParams :: FieldCapsOptions -> [(Text, Maybe Text)] +fieldCapsOptionsParams opts = + catMaybes + [ ("fields",) . Just . renderFields <$> fcoFields opts, + ("allow_no_indices",) . Just . boolText <$> fcoAllowNoIndices opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> fcoExpandWildcards opts, + ("ignore_unavailable",) . Just . boolText <$> fcoIgnoreUnavailable opts, + ("include_unmapped",) . Just . boolText <$> fcoIncludeUnmapped opts + ] + where + boolText True = "true" + boolText False = "false" + renderFields = T.intercalate "," . map unFieldPattern + renderExpandWildcards = T.intercalate "," . map expandWildcardsText + +-- | Top-level response body for @/_field_caps@. The @indices@ field is +-- @null@ when every selected index agrees on the type family for every +-- returned field; otherwise it lists the indices that contributed to +-- the response. The @fields@ object is keyed first by field name, then +-- by Elasticsearch type name (a field may appear under several types +-- when it has different mappings across indices). +data FieldCapsResponse = FieldCapsResponse + { fieldCapsResponseIndices :: Maybe [IndexName], + fieldCapsResponseFields :: KeyMap (KeyMap FieldCapability) + } + deriving stock (Eq, Show) + +instance FromJSON FieldCapsResponse where + parseJSON = withObject "FieldCapsResponse" $ \o -> + FieldCapsResponse + <$> o .:? "indices" + <*> o .: "fields" + +fieldCapsResponseIndicesLens :: Lens' FieldCapsResponse (Maybe [IndexName]) +fieldCapsResponseIndicesLens = lens fieldCapsResponseIndices (\x y -> x {fieldCapsResponseIndices = y}) + +fieldCapsResponseFieldsLens :: Lens' FieldCapsResponse (KeyMap (KeyMap FieldCapability)) +fieldCapsResponseFieldsLens = lens fieldCapsResponseFields (\x y -> x {fieldCapsResponseFields = y}) + +-- | Capability of a single (field, type) pair. The @type@, +-- @searchable@ and @aggregatable@ fields are always present; the rest +-- are absent when the field has uniform capability across the +-- contributing indices. +data FieldCapability = FieldCapability + { fieldCapabilityType :: Text, + fieldCapabilitySearchable :: Bool, + fieldCapabilityAggregatable :: Bool, + fieldCapabilityIndices :: Maybe [IndexName], + fieldCapabilityNonSearchableIndices :: Maybe [IndexName], + fieldCapabilityNonAggregatableIndices :: Maybe [IndexName], + fieldCapabilityMetadataField :: Maybe Bool, + fieldCapabilityMeta :: Maybe (KeyMap [Value]) + } + deriving stock (Eq, Show) + +instance FromJSON FieldCapability where + parseJSON = withObject "FieldCapability" $ \o -> + FieldCapability + <$> o + .: "type" + <*> o + .: "searchable" + <*> o + .: "aggregatable" + <*> o + .:? "indices" + <*> o + .:? "non_searchable_indices" + <*> o + .:? "non_aggregatable_indices" + <*> o + .:? "metadata_field" + <*> o + .:? "meta" + +fieldCapabilityTypeLens :: Lens' FieldCapability Text +fieldCapabilityTypeLens = lens fieldCapabilityType (\x y -> x {fieldCapabilityType = y}) + +fieldCapabilitySearchableLens :: Lens' FieldCapability Bool +fieldCapabilitySearchableLens = lens fieldCapabilitySearchable (\x y -> x {fieldCapabilitySearchable = y}) + +fieldCapabilityAggregatableLens :: Lens' FieldCapability Bool +fieldCapabilityAggregatableLens = lens fieldCapabilityAggregatable (\x y -> x {fieldCapabilityAggregatable = y}) + +fieldCapabilityIndicesLens :: Lens' FieldCapability (Maybe [IndexName]) +fieldCapabilityIndicesLens = lens fieldCapabilityIndices (\x y -> x {fieldCapabilityIndices = y}) + +fieldCapabilityNonSearchableIndicesLens :: Lens' FieldCapability (Maybe [IndexName]) +fieldCapabilityNonSearchableIndicesLens = lens fieldCapabilityNonSearchableIndices (\x y -> x {fieldCapabilityNonSearchableIndices = y}) + +fieldCapabilityNonAggregatableIndicesLens :: Lens' FieldCapability (Maybe [IndexName]) +fieldCapabilityNonAggregatableIndicesLens = lens fieldCapabilityNonAggregatableIndices (\x y -> x {fieldCapabilityNonAggregatableIndices = y}) + +fieldCapabilityMetadataFieldLens :: Lens' FieldCapability (Maybe Bool) +fieldCapabilityMetadataFieldLens = lens fieldCapabilityMetadataField (\x y -> x {fieldCapabilityMetadataField = y}) + +fieldCapabilityMetaLens :: Lens' FieldCapability (Maybe (KeyMap [Value])) +fieldCapabilityMetaLens = lens fieldCapabilityMeta (\x y -> x {fieldCapabilityMeta = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/FieldUsageStats.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/FieldUsageStats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/FieldUsageStats.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.FieldUsageStats +-- License : BSD-style (see the file LICENSE) +-- +-- Types for the @GET \/{index}/_field_usage_stats@ endpoint. This is an +-- ES feature (technical preview); OpenSearch does not implement it, so +-- calls against an OpenSearch cluster will fail at runtime — the types +-- are still hosted under @Common@ to match the project's SLM\/Validate +-- precedent. See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.FieldUsageStats + ( -- * Response types + FieldUsageStatsResponse (..), + FieldUsageStatsIndex (..), + FieldUsageShard (..), + FieldUsageRouting (..), + FieldUsageStats (..), + FieldUsageBreakdown (..), + FieldUsageInvertedIndex (..), + + -- * URI parameters + FieldUsageStatsOptions (..), + defaultFieldUsageStatsOptions, + fieldUsageStatsOptionsParams, + + -- * Optics + fusrShardsLens, + fusrIndicesLens, + fusiShardsLens, + fusTrackingIdLens, + fusTrackingStartedAtMillisLens, + fusRoutingLens, + fusStatsLens, + furStateLens, + furPrimaryLens, + furNodeLens, + furRelocatingNodeLens, + fustatAllFieldsLens, + fustatFieldsLens, + fubAnyLens, + fubInvertedIndexLens, + fubStoredFieldsLens, + fubDocValuesLens, + fubPointsLens, + fubNormsLens, + fubTermVectorsLens, + fuiiTermsLens, + fuiiPostingsLens, + fuiiProximityLens, + fuiiPositionsLens, + fuiiTermFrequenciesLens, + fuiiOffsetsLens, + fuiiPayloadsLens, + fusoIgnoreUnavailableLens, + fusoAllowNoIndicesLens, + fusoExpandWildcardsLens, + fusoFieldsLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens) +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes + ( ShardResult, + ) + +-- | Top-level response of @GET \/{index}/_field_usage_stats@. As with +-- the disk-usage response, the payload is an object with a @_shards@ +-- summary plus one top-level key per index, collected into a 'KeyMap'. +data FieldUsageStatsResponse = FieldUsageStatsResponse + { fusrShards :: ShardResult, + -- | One entry per index, keyed by index name. Built by collecting + -- every top-level key other than @_shards@; a literal index named + -- @_shards@ would therefore be silently dropped, but ES forbids + -- such names so this is impossible in practice. + fusrIndices :: KeyMap FieldUsageStatsIndex + } + deriving stock (Eq, Show) + +instance FromJSON FieldUsageStatsResponse where + parseJSON = withObject "FieldUsageStatsResponse" $ \o -> do + shards <- o .: "_shards" + indices <- traverse parseJSON (KM.delete "_shards" o) + pure $ FieldUsageStatsResponse shards indices + +instance ToJSON FieldUsageStatsResponse where + toJSON FieldUsageStatsResponse {..} = + Object $ KM.insert "_shards" (toJSON fusrShards) (toJSON <$> fusrIndices) + +-- | Per-index payload: a @shards@ array of 'FieldUsageShard'. +newtype FieldUsageStatsIndex = FieldUsageStatsIndex + { fusiShards :: [FieldUsageShard] + } + deriving stock (Eq, Show) + +instance FromJSON FieldUsageStatsIndex where + parseJSON = withObject "FieldUsageStatsIndex" $ \o -> + FieldUsageStatsIndex + <$> o + .:? "shards" + .!= [] + +instance ToJSON FieldUsageStatsIndex where + toJSON (FieldUsageStatsIndex shards) = + object ["shards" .= shards] + +-- | One shard entry within the @shards@ array. Carries the tracking +-- id, the tracking start time, the shard routing, and the aggregate +-- field-usage @stats@. +data FieldUsageShard = FieldUsageShard + { fusTrackingId :: Maybe Text, + fusTrackingStartedAtMillis :: Maybe Int, + fusRouting :: Maybe FieldUsageRouting, + fusStats :: Maybe FieldUsageStats + } + deriving stock (Eq, Show) + +instance FromJSON FieldUsageShard where + parseJSON = withObject "FieldUsageShard" $ \o -> + FieldUsageShard + <$> o .:? "tracking_id" + <*> o .:? "tracking_started_at_millis" + <*> o .:? "routing" + <*> o .:? "stats" + +instance ToJSON FieldUsageShard where + toJSON FieldUsageShard {..} = + object $ + catMaybes + [ ("tracking_id" .=) <$> fusTrackingId, + ("tracking_started_at_millis" .=) <$> fusTrackingStartedAtMillis, + ("routing" .=) <$> fusRouting, + ("stats" .=) <$> fusStats + ] + +-- | The @routing@ object: shard placement metadata. +data FieldUsageRouting = FieldUsageRouting + { furState :: Maybe Text, + furPrimary :: Maybe Bool, + furNode :: Maybe Text, + furRelocatingNode :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON FieldUsageRouting where + parseJSON = withObject "FieldUsageRouting" $ \o -> + FieldUsageRouting + <$> o .:? "state" + <*> o .:? "primary" + <*> o .:? "node" + <*> o .:? "relocating_node" + +instance ToJSON FieldUsageRouting where + toJSON FieldUsageRouting {..} = + object $ + catMaybes + [ ("state" .=) <$> furState, + ("primary" .=) <$> furPrimary, + ("node" .=) <$> furNode, + ("relocating_node" .=) <$> furRelocatingNode + ] + +-- | The @stats@ object: an @all_fields@ aggregate breakdown plus a +-- per-field map. +data FieldUsageStats = FieldUsageStats + { fustatAllFields :: Maybe FieldUsageBreakdown, + fustatFields :: Maybe (KeyMap FieldUsageBreakdown) + } + deriving stock (Eq, Show) + +instance FromJSON FieldUsageStats where + parseJSON = withObject "FieldUsageStats" $ \o -> + FieldUsageStats + <$> o .:? "all_fields" + <*> o .:? "fields" + +instance ToJSON FieldUsageStats where + toJSON FieldUsageStats {..} = + object $ + catMaybes + [ ("all_fields" .=) <$> fustatAllFields, + ("fields" .=) <$> fustatFields + ] + +-- | Per-field (or @all_fields@) usage breakdown. @any@ counts any kind +-- of use; the remaining fields count use of a specific structure. +data FieldUsageBreakdown = FieldUsageBreakdown + { fubAny :: Maybe Int, + fubInvertedIndex :: Maybe FieldUsageInvertedIndex, + fubStoredFields :: Maybe Int, + fubDocValues :: Maybe Int, + fubPoints :: Maybe Int, + fubNorms :: Maybe Int, + fubTermVectors :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON FieldUsageBreakdown where + parseJSON = withObject "FieldUsageBreakdown" $ \o -> + FieldUsageBreakdown + <$> o .:? "any" + <*> o .:? "inverted_index" + <*> o .:? "stored_fields" + <*> o .:? "doc_values" + <*> o .:? "points" + <*> o .:? "norms" + <*> o .:? "term_vectors" + +instance ToJSON FieldUsageBreakdown where + toJSON FieldUsageBreakdown {..} = + object $ + catMaybes + [ ("any" .=) <$> fubAny, + ("inverted_index" .=) <$> fubInvertedIndex, + ("stored_fields" .=) <$> fubStoredFields, + ("doc_values" .=) <$> fubDocValues, + ("points" .=) <$> fubPoints, + ("norms" .=) <$> fubNorms, + ("term_vectors" .=) <$> fubTermVectors + ] + +-- | The nested @inverted_index@ object inside a 'FieldUsageBreakdown'. +data FieldUsageInvertedIndex = FieldUsageInvertedIndex + { fuiiTerms :: Maybe Int, + fuiiPostings :: Maybe Int, + fuiiProximity :: Maybe Int, + fuiiPositions :: Maybe Int, + fuiiTermFrequencies :: Maybe Int, + fuiiOffsets :: Maybe Int, + fuiiPayloads :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON FieldUsageInvertedIndex where + parseJSON = withObject "FieldUsageInvertedIndex" $ \o -> + FieldUsageInvertedIndex + <$> o .:? "terms" + <*> o .:? "postings" + <*> o .:? "proximity" + <*> o .:? "positions" + <*> o .:? "term_frequencies" + <*> o .:? "offsets" + <*> o .:? "payloads" + +instance ToJSON FieldUsageInvertedIndex where + toJSON FieldUsageInvertedIndex {..} = + object $ + catMaybes + [ ("terms" .=) <$> fuiiTerms, + ("postings" .=) <$> fuiiPostings, + ("proximity" .=) <$> fuiiProximity, + ("positions" .=) <$> fuiiPositions, + ("term_frequencies" .=) <$> fuiiTermFrequencies, + ("offsets" .=) <$> fuiiOffsets, + ("payloads" .=) <$> fuiiPayloads + ] + +-- Lenses + +fusrShardsLens :: Lens' FieldUsageStatsResponse ShardResult +fusrShardsLens = lens fusrShards (\x y -> x {fusrShards = y}) + +fusrIndicesLens :: Lens' FieldUsageStatsResponse (KeyMap FieldUsageStatsIndex) +fusrIndicesLens = lens fusrIndices (\x y -> x {fusrIndices = y}) + +fusiShardsLens :: Lens' FieldUsageStatsIndex [FieldUsageShard] +fusiShardsLens = lens fusiShards (\x y -> x {fusiShards = y}) + +fusTrackingIdLens :: Lens' FieldUsageShard (Maybe Text) +fusTrackingIdLens = lens fusTrackingId (\x y -> x {fusTrackingId = y}) + +fusTrackingStartedAtMillisLens :: Lens' FieldUsageShard (Maybe Int) +fusTrackingStartedAtMillisLens = + lens fusTrackingStartedAtMillis (\x y -> x {fusTrackingStartedAtMillis = y}) + +fusRoutingLens :: Lens' FieldUsageShard (Maybe FieldUsageRouting) +fusRoutingLens = lens fusRouting (\x y -> x {fusRouting = y}) + +fusStatsLens :: Lens' FieldUsageShard (Maybe FieldUsageStats) +fusStatsLens = lens fusStats (\x y -> x {fusStats = y}) + +furStateLens :: Lens' FieldUsageRouting (Maybe Text) +furStateLens = lens furState (\x y -> x {furState = y}) + +furPrimaryLens :: Lens' FieldUsageRouting (Maybe Bool) +furPrimaryLens = lens furPrimary (\x y -> x {furPrimary = y}) + +furNodeLens :: Lens' FieldUsageRouting (Maybe Text) +furNodeLens = lens furNode (\x y -> x {furNode = y}) + +furRelocatingNodeLens :: Lens' FieldUsageRouting (Maybe Text) +furRelocatingNodeLens = lens furRelocatingNode (\x y -> x {furRelocatingNode = y}) + +fustatAllFieldsLens :: Lens' FieldUsageStats (Maybe FieldUsageBreakdown) +fustatAllFieldsLens = lens fustatAllFields (\x y -> x {fustatAllFields = y}) + +fustatFieldsLens :: + Lens' FieldUsageStats (Maybe (KeyMap FieldUsageBreakdown)) +fustatFieldsLens = lens fustatFields (\x y -> x {fustatFields = y}) + +fubAnyLens :: Lens' FieldUsageBreakdown (Maybe Int) +fubAnyLens = lens fubAny (\x y -> x {fubAny = y}) + +fubInvertedIndexLens :: Lens' FieldUsageBreakdown (Maybe FieldUsageInvertedIndex) +fubInvertedIndexLens = lens fubInvertedIndex (\x y -> x {fubInvertedIndex = y}) + +fubStoredFieldsLens :: Lens' FieldUsageBreakdown (Maybe Int) +fubStoredFieldsLens = lens fubStoredFields (\x y -> x {fubStoredFields = y}) + +fubDocValuesLens :: Lens' FieldUsageBreakdown (Maybe Int) +fubDocValuesLens = lens fubDocValues (\x y -> x {fubDocValues = y}) + +fubPointsLens :: Lens' FieldUsageBreakdown (Maybe Int) +fubPointsLens = lens fubPoints (\x y -> x {fubPoints = y}) + +fubNormsLens :: Lens' FieldUsageBreakdown (Maybe Int) +fubNormsLens = lens fubNorms (\x y -> x {fubNorms = y}) + +fubTermVectorsLens :: Lens' FieldUsageBreakdown (Maybe Int) +fubTermVectorsLens = lens fubTermVectors (\x y -> x {fubTermVectors = y}) + +fuiiTermsLens :: Lens' FieldUsageInvertedIndex (Maybe Int) +fuiiTermsLens = lens fuiiTerms (\x y -> x {fuiiTerms = y}) + +fuiiPostingsLens :: Lens' FieldUsageInvertedIndex (Maybe Int) +fuiiPostingsLens = lens fuiiPostings (\x y -> x {fuiiPostings = y}) + +fuiiProximityLens :: Lens' FieldUsageInvertedIndex (Maybe Int) +fuiiProximityLens = lens fuiiProximity (\x y -> x {fuiiProximity = y}) + +fuiiPositionsLens :: Lens' FieldUsageInvertedIndex (Maybe Int) +fuiiPositionsLens = lens fuiiPositions (\x y -> x {fuiiPositions = y}) + +fuiiTermFrequenciesLens :: Lens' FieldUsageInvertedIndex (Maybe Int) +fuiiTermFrequenciesLens = + lens fuiiTermFrequencies (\x y -> x {fuiiTermFrequencies = y}) + +fuiiOffsetsLens :: Lens' FieldUsageInvertedIndex (Maybe Int) +fuiiOffsetsLens = lens fuiiOffsets (\x y -> x {fuiiOffsets = y}) + +fuiiPayloadsLens :: Lens' FieldUsageInvertedIndex (Maybe Int) +fuiiPayloadsLens = lens fuiiPayloads (\x y -> x {fuiiPayloads = y}) + +-- | URI parameters accepted by @GET \/{index}/_field_usage_stats@. See +-- . +-- Every field is 'Maybe'; 'defaultFieldUsageStatsOptions' leaves them +-- all @Nothing@, which emits no query string. +-- +-- Although the ES 7.17 docs list @wait_for_active_shards@, +-- @master_timeout@ and @timeout@ for this endpoint, ES 7.17.25 actually +-- rejects all three with @400 contains unrecognized parameters: +-- [master_timeout], [timeout], [wait_for_active_shards]@, so they are +-- /not/ modelled here. The remaining parameters — @fields@, +-- @expand_wildcards@, @ignore_unavailable@ and @allow_no_indices@ — +-- were live-verified accepted against ES 7.17.25. +data FieldUsageStatsOptions = FieldUsageStatsOptions + { fusoIgnoreUnavailable :: Maybe Bool, + fusoAllowNoIndices :: Maybe Bool, + fusoExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + fusoFields :: Maybe (NonEmpty Text) + } + deriving stock (Eq, Show) + +-- | 'FieldUsageStatsOptions' with every field @Nothing@. Emits an empty +-- query string, preserving the wire behaviour of the parameterless +-- @GET \/{index}/_field_usage_stats@. +defaultFieldUsageStatsOptions :: FieldUsageStatsOptions +defaultFieldUsageStatsOptions = + FieldUsageStatsOptions + { fusoIgnoreUnavailable = Nothing, + fusoAllowNoIndices = Nothing, + fusoExpandWildcards = Nothing, + fusoFields = Nothing + } + +-- | Render a 'FieldUsageStatsOptions' record as a @(key, value)@ list +-- suitable for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. +-- 'Nothing' fields are omitted, so 'defaultFieldUsageStatsOptions' +-- produces an empty list (and therefore no query string). +fieldUsageStatsOptionsParams :: + FieldUsageStatsOptions -> + [(Text, Maybe Text)] +fieldUsageStatsOptionsParams FieldUsageStatsOptions {..} = + catMaybes + [ ("ignore_unavailable",) . Just . boolText <$> fusoIgnoreUnavailable, + ("allow_no_indices",) . Just . boolText <$> fusoAllowNoIndices, + ("expand_wildcards",) . Just . renderExpandWildcards <$> fusoExpandWildcards, + ("fields",) . Just . renderFields <$> fusoFields + ] + where + boolText True = "true" + boolText False = "false" + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + renderFields = T.intercalate "," . toList + +-- Options lenses + +fusoIgnoreUnavailableLens :: Lens' FieldUsageStatsOptions (Maybe Bool) +fusoIgnoreUnavailableLens = + lens fusoIgnoreUnavailable (\x y -> x {fusoIgnoreUnavailable = y}) + +fusoAllowNoIndicesLens :: Lens' FieldUsageStatsOptions (Maybe Bool) +fusoAllowNoIndicesLens = + lens fusoAllowNoIndices (\x y -> x {fusoAllowNoIndices = y}) + +fusoExpandWildcardsLens :: + Lens' FieldUsageStatsOptions (Maybe (NonEmpty ExpandWildcards)) +fusoExpandWildcardsLens = + lens fusoExpandWildcards (\x y -> x {fusoExpandWildcards = y}) + +fusoFieldsLens :: Lens' FieldUsageStatsOptions (Maybe (NonEmpty Text)) +fusoFieldsLens = lens fusoFields (\x y -> x {fusoFields = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Fleet.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Fleet.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Fleet.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Fleet +-- Description : Types for the Elasticsearch Fleet API +-- +-- Defines the request and response shapes for the ES X-Pack Fleet +-- endpoints (under @/{index}/_fleet/*@). These endpoints exist so the +-- Fleet Server can use Elasticsearch as a data store for internal agent +-- and action data. They are explicitly /experimental/ and /for internal +-- use by Fleet only/ — Elastic reserves the right to change or remove +-- them. Bloodhound exposes them because they are ordinary ES REST +-- endpoints; calling them directly is not supported by Elastic. +-- +-- * @GET /{index}/_fleet/global_checkpoints@ — 'FleetGlobalCheckpointsResponse'. +-- * @POST /{index}/_fleet/_fleet_search@ — a standard 'SearchResult' +-- (the request body is a regular 'Search', scoped to a single index). +-- * @POST /{index}/_fleet/_fleet_msearch@ — a standard +-- 'MultiSearchResponse' (same NDJSON body shape as @_msearch@). +-- +-- OpenSearch does not implement the Fleet API, so calls against an +-- OpenSearch cluster will fail at runtime — the types are hosted under +-- @Common@ to match the project's SLM\/Enrich precedent for shared +-- ES7\/ES8\/ES9 wire surfaces. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Fleet + ( -- * Checkpoints + GlobalCheckpoint (..), + + -- * Get global checkpoints + FleetGlobalCheckpointsResponse (..), + fleetGlobalCheckpointsResponseCheckpointsLens, + fleetGlobalCheckpointsResponseTimedOutLens, + fleetGlobalCheckpointsResponseExtrasLens, + + -- ** Options + FleetGlobalCheckpointsOptions (..), + defaultFleetGlobalCheckpointsOptions, + fleetGlobalCheckpointsOptionsParams, + fleetGlobalCheckpointsOptionsWaitForAdvanceLens, + fleetGlobalCheckpointsOptionsWaitForIndexLens, + fleetGlobalCheckpointsOptionsCheckpointsLens, + fleetGlobalCheckpointsOptionsTimeoutLens, + + -- * Fleet search options + FleetSearchOptions (..), + defaultFleetSearchOptions, + fleetSearchOptionsParams, + fleetSearchOptionsWaitForCheckpointsLens, + fleetSearchOptionsAllowPartialSearchResultsLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Int (Int64) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens, showText) +import Database.Bloodhound.Internal.Versions.Common.Types.Units + ( TimeUnits, + timeUnitsSuffix, + ) + +-- | A sequence-number checkpoint used by the Fleet API. ES carries these +-- as a JSON number (a signed 64-bit @long@); we model them as an 'Int64' +-- newtype so they are distinct at the type level from ordinary counts. +-- The 'Num'\/'Integral' derivations let callers write literal checkpoints +-- directly (@42 :: GlobalCheckpoint@) and feed them to 'fromIntegral'. +newtype GlobalCheckpoint = GlobalCheckpoint {unGlobalCheckpoint :: Int64} + deriving newtype + ( Eq, + Ord, + Show, + Num, + Enum, + Real, + Integral, + ToJSON, + FromJSON + ) + +-- | Response body of @GET /{index}/_fleet/global_checkpoints@. The +-- @global_checkpoints@ array holds the current per-shard global +-- checkpoints for the index and @timed_out@ reports whether a polling +-- request (@wait_for_advance=true@) exhausted its @timeout@ before the +-- checkpoints advanced past the supplied @checkpoints@. Unknown sibling +-- fields are preserved in 'fgcrExtras' so the structure round-trips even +-- as ES adds fields to this experimental endpoint. +data FleetGlobalCheckpointsResponse = FleetGlobalCheckpointsResponse + { fgcrCheckpoints :: [GlobalCheckpoint], + fgcrTimedOut :: Bool, + fgcrExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +globalCheckpointsResponseKnownKeys :: [Key] +globalCheckpointsResponseKnownKeys = ["global_checkpoints", "timed_out"] + +instance FromJSON FleetGlobalCheckpointsResponse where + parseJSON = withObject "FleetGlobalCheckpointsResponse" $ \o -> do + checkpoints <- o .: "global_checkpoints" + timedOut <- o .: "timed_out" + let extras = + KM.fromList $ + filter ((`notElem` globalCheckpointsResponseKnownKeys) . fst) $ + KM.toList o + pure + FleetGlobalCheckpointsResponse + { fgcrCheckpoints = checkpoints, + fgcrTimedOut = timedOut, + fgcrExtras = extras + } + +instance ToJSON FleetGlobalCheckpointsResponse where + toJSON FleetGlobalCheckpointsResponse {..} = + -- 'object' (not 'omitNulls') so the @fgcrExtras@ catch-all survives a + -- round-trip even when it carries a @null@ or empty-array value. The + -- known fields are emitted unconditionally. + object $ + [ "global_checkpoints" .= fgcrCheckpoints, + "timed_out" .= fgcrTimedOut + ] + <> [toPair kv | kv <- KM.toList fgcrExtras] + where + toPair (k, v) = k .= v + +-- | URI parameters accepted by @GET /{index}/_fleet/global_checkpoints@. +-- In polling mode (@'fgcoWaitForAdvance' = 'Just' 'True'@) the call +-- blocks until the global checkpoints advance past 'fgcoCheckpoints' or +-- 'fgcoTimeout' elapses; @'fgcoWaitForIndex' = 'Just' 'True'@ additionally +-- waits for the index to exist with all primary shards active. The server +-- defaults are @wait_for_advance=false@, @checkpoints=[]@, @timeout=30s@. +data FleetGlobalCheckpointsOptions = FleetGlobalCheckpointsOptions + { fgcoWaitForAdvance :: Maybe Bool, + fgcoWaitForIndex :: Maybe Bool, + fgcoCheckpoints :: [GlobalCheckpoint], + fgcoTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | An empty options record — encodes to no query string, reproducing the +-- parameterless immediate-return call. +defaultFleetGlobalCheckpointsOptions :: FleetGlobalCheckpointsOptions +defaultFleetGlobalCheckpointsOptions = + FleetGlobalCheckpointsOptions + { fgcoWaitForAdvance = Nothing, + fgcoWaitForIndex = Nothing, + fgcoCheckpoints = [], + fgcoTimeout = Nothing + } + +-- | Render a 'FleetGlobalCheckpointsOptions' as a @(key, value)@ list for +-- 'withQueries'. 'Nothing' fields and an empty @checkpoints@ list are +-- omitted (an empty @checkpoints@ is the server default). +fleetGlobalCheckpointsOptionsParams :: + FleetGlobalCheckpointsOptions -> + [(Text, Maybe Text)] +fleetGlobalCheckpointsOptionsParams FleetGlobalCheckpointsOptions {..} = + catMaybes + [ boolParam "wait_for_advance" <$> fgcoWaitForAdvance, + boolParam "wait_for_index" <$> fgcoWaitForIndex, + ("checkpoints",) . Just . renderCheckpoints <$> nonEmptyCheckpoints, + ("timeout",) . Just . renderDuration <$> fgcoTimeout + ] + where + renderCheckpoints = T.intercalate "," . map (showText . unGlobalCheckpoint) + renderDuration (u, n) = showText n <> timeUnitsSuffix u + nonEmptyCheckpoints = + if null fgcoCheckpoints then Nothing else Just fgcoCheckpoints + +-- | URI parameters accepted by the Fleet search and Fleet multi-search +-- endpoints. @wait_for_checkpoints@ gates the search until the supplied +-- sequence-number checkpoints are visible for search (indexed by shard); +-- @allow_partial_search_results@ mirrors the regular search parameter. +-- Both default to the server defaults (empty list and the cluster +-- setting @search.default_allow_partial_results@ respectively) when +-- omitted, which 'defaultFleetSearchOptions' reproduces. +data FleetSearchOptions = FleetSearchOptions + { fsoWaitForCheckpoints :: [GlobalCheckpoint], + fsoAllowPartialSearchResults :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | An empty options record — encodes to no query string, reproducing the +-- parameterless fleet search. +defaultFleetSearchOptions :: FleetSearchOptions +defaultFleetSearchOptions = + FleetSearchOptions + { fsoWaitForCheckpoints = [], + fsoAllowPartialSearchResults = Nothing + } + +-- | Render a 'FleetSearchOptions' as a @(key, value)@ list for +-- 'withQueries'. 'Nothing' fields and an empty @wait_for_checkpoints@ +-- list are omitted. +fleetSearchOptionsParams :: FleetSearchOptions -> [(Text, Maybe Text)] +fleetSearchOptionsParams FleetSearchOptions {..} = + catMaybes + [ ("wait_for_checkpoints",) . Just . renderCheckpoints <$> nonEmptyCheckpoints, + boolParam "allow_partial_search_results" <$> fsoAllowPartialSearchResults + ] + where + renderCheckpoints = T.intercalate "," . map (showText . unGlobalCheckpoint) + nonEmptyCheckpoints = + if null fsoWaitForCheckpoints then Nothing else Just fsoWaitForCheckpoints + +-- | Render a 'Bool' as the wire spelling ES expects for boolean query +-- parameters (@\"true\"@ \/ @\"false\"@), paired with its key. +boolParam :: Text -> Bool -> (Text, Maybe Text) +boolParam key b = (key, Just (boolText b)) + +-- | Render a 'Bool' as the wire spelling ES expects for boolean query +-- parameters (@\"true\"@ \/ @\"false\"@). +boolText :: Bool -> Text +boolText True = "true" +boolText False = "false" + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +fleetGlobalCheckpointsResponseCheckpointsLens :: + Lens' FleetGlobalCheckpointsResponse [GlobalCheckpoint] +fleetGlobalCheckpointsResponseCheckpointsLens = + lens fgcrCheckpoints (\x y -> x {fgcrCheckpoints = y}) + +fleetGlobalCheckpointsResponseTimedOutLens :: + Lens' FleetGlobalCheckpointsResponse Bool +fleetGlobalCheckpointsResponseTimedOutLens = + lens fgcrTimedOut (\x y -> x {fgcrTimedOut = y}) + +fleetGlobalCheckpointsResponseExtrasLens :: + Lens' FleetGlobalCheckpointsResponse (KeyMap Value) +fleetGlobalCheckpointsResponseExtrasLens = + lens fgcrExtras (\x y -> x {fgcrExtras = y}) + +fleetGlobalCheckpointsOptionsWaitForAdvanceLens :: + Lens' FleetGlobalCheckpointsOptions (Maybe Bool) +fleetGlobalCheckpointsOptionsWaitForAdvanceLens = + lens fgcoWaitForAdvance (\x y -> x {fgcoWaitForAdvance = y}) + +fleetGlobalCheckpointsOptionsWaitForIndexLens :: + Lens' FleetGlobalCheckpointsOptions (Maybe Bool) +fleetGlobalCheckpointsOptionsWaitForIndexLens = + lens fgcoWaitForIndex (\x y -> x {fgcoWaitForIndex = y}) + +fleetGlobalCheckpointsOptionsCheckpointsLens :: + Lens' FleetGlobalCheckpointsOptions [GlobalCheckpoint] +fleetGlobalCheckpointsOptionsCheckpointsLens = + lens fgcoCheckpoints (\x y -> x {fgcoCheckpoints = y}) + +fleetGlobalCheckpointsOptionsTimeoutLens :: + Lens' FleetGlobalCheckpointsOptions (Maybe (TimeUnits, Word32)) +fleetGlobalCheckpointsOptionsTimeoutLens = + lens fgcoTimeout (\x y -> x {fgcoTimeout = y}) + +fleetSearchOptionsWaitForCheckpointsLens :: + Lens' FleetSearchOptions [GlobalCheckpoint] +fleetSearchOptionsWaitForCheckpointsLens = + lens fsoWaitForCheckpoints (\x y -> x {fsoWaitForCheckpoints = y}) + +fleetSearchOptionsAllowPartialSearchResultsLens :: + Lens' FleetSearchOptions (Maybe Bool) +fleetSearchOptionsAllowPartialSearchResultsLens = + lens + fsoAllowPartialSearchResults + (\x y -> x {fsoAllowPartialSearchResults = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Highlight.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Highlight.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Highlight.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Highlight.hs @@ -2,7 +2,7 @@ module Database.Bloodhound.Internal.Versions.Common.Types.Highlight where -import qualified Data.Map.Strict as M +import Data.Map.Strict qualified as M import Database.Bloodhound.Internal.Utils.Imports import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes import Database.Bloodhound.Internal.Versions.Common.Types.Query @@ -48,7 +48,7 @@ data HighlightSettings = Plain PlainHighlight - | Postings PostingsHighlight + | Unified UnifiedHighlight | FastVector FastVectorHighlight deriving stock (Eq, Show) @@ -60,12 +60,12 @@ Plain x -> Right x _ -> Left hs -highlightSettingsPostingsPrism :: Prism' HighlightSettings PostingsHighlight -highlightSettingsPostingsPrism = prism Postings extract +highlightSettingsUnifiedPrism :: Prism' HighlightSettings UnifiedHighlight +highlightSettingsUnifiedPrism = prism Unified extract where extract hs = case hs of - Postings x -> Right x + Unified x -> Right x _ -> Left hs highlightSettingsFastVectorPrism :: Prism' HighlightSettings FastVectorHighlight @@ -91,12 +91,13 @@ plainHighlightNonPostLens :: Lens' PlainHighlight (Maybe NonPostings) plainHighlightNonPostLens = lens plainNonPost (\x y -> x {plainNonPost = y}) --- This requires that index_options are set to 'offset' in the mapping. -newtype PostingsHighlight = PostingsHighlight {getPostingsHighlight :: Maybe CommonHighlight} +-- The 'unified' highlighter is the modern default; it picks its term-vector +-- source automatically from the mapping, falling back to re-analyzing _source. +newtype UnifiedHighlight = UnifiedHighlight {getUnifiedHighlight :: Maybe CommonHighlight} deriving stock (Eq, Show) -postingsHighlightLens :: Lens' PostingsHighlight (Maybe CommonHighlight) -postingsHighlightLens = lens getPostingsHighlight (\x y -> x {getPostingsHighlight = y}) +unifiedHighlightLens :: Lens' UnifiedHighlight (Maybe CommonHighlight) +unifiedHighlightLens = lens getUnifiedHighlight (\x y -> x {getUnifiedHighlight = y}) -- This requires that term_vector is set to 'with_positions_offsets' in the mapping. data FastVectorHighlight = FastVectorHighlight @@ -142,6 +143,8 @@ } deriving stock (Eq, Show) +{-# DEPRECATED forceSource, commonHighlightForceSourceLens "force_source is marked deprecated:true in the ES/OpenSearch spec; avoid it in new highlight settings." #-} + commonHighlightOrderLens :: Lens' CommonHighlight (Maybe Text) commonHighlightOrderLens = lens order (\x y -> x {order = y}) @@ -187,7 +190,7 @@ -- NOTE: Should the tags use some kind of HTML type, rather than Text? data HighlightTag - = TagSchema Text + = TagSchema | -- Only uses more than the first value in the lists if fvh CustomTags ([Text], [Text]) deriving stock (Eq, Show) @@ -195,7 +198,7 @@ highlightSettingsPairs :: Maybe HighlightSettings -> [Pair] highlightSettingsPairs Nothing = [] highlightSettingsPairs (Just (Plain plh)) = plainHighPairs (Just plh) -highlightSettingsPairs (Just (Postings ph)) = postHighPairs (Just ph) +highlightSettingsPairs (Just (Unified uh)) = unifiedHighPairs (Just uh) highlightSettingsPairs (Just (FastVector fvh)) = fastVectorHighPairs (Just fvh) plainHighPairs :: Maybe PlainHighlight -> [Pair] @@ -205,11 +208,11 @@ ++ commonHighlightPairs plCom ++ nonPostingsToPairs plNonPost -postHighPairs :: Maybe PostingsHighlight -> [Pair] -postHighPairs Nothing = [] -postHighPairs (Just (PostingsHighlight pCom)) = - ("type" .= String "postings") - : commonHighlightPairs pCom +unifiedHighPairs :: Maybe UnifiedHighlight -> [Pair] +unifiedHighPairs Nothing = [] +unifiedHighPairs (Just (UnifiedHighlight uCom)) = + ("type" .= String "unified") + : commonHighlightPairs uCom fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair] fastVectorHighPairs Nothing = [] @@ -230,7 +233,7 @@ "boundary_max_scan" .= fvBoundMaxScan, "fragment_offset" .= fvFragOff, "matched_fields" .= fvMatchedFields, - "phraseLimit" .= fvPhraseLim + "phrase_limit" .= fvPhraseLim ] ++ commonHighlightPairs fvCom ++ nonPostingsToPairs fvNonPostSettings' @@ -254,7 +257,7 @@ "encoder" .= chEncoder, "no_match_size" .= chNoMatchSize, "highlight_query" .= chHighlightQuery, - "require_fieldMatch" .= chRequireFieldMatch + "require_field_match" .= chRequireFieldMatch ] ++ highlightTagToPairs chTag @@ -266,8 +269,8 @@ ] highlightTagToPairs :: Maybe HighlightTag -> [Pair] -highlightTagToPairs (Just (TagSchema _)) = - [ "scheme" .= String "default" +highlightTagToPairs (Just TagSchema) = + [ "tags_schema" .= String "styled" ] highlightTagToPairs (Just (CustomTags (pre, post))) = [ "pre_tags" .= pre, diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/ILM.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/ILM.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/ILM.hs @@ -0,0 +1,818 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.ILM +-- Description : Types for the Elasticsearch Index Lifecycle Management (ILM) API +-- +-- Defines the request and response shapes for the ES ILM +-- @PUT \/_ilm\/policy\/{id}@, @GET /_ilm/policy[\/{id}]@ and +-- @GET /_ilm/explain/{index}@ endpoints. ILM ships in Elasticsearch 7.x +-- and later (ES7\/ES8\/ES9 share the same surface), which is why these +-- types live in the Common layer. +-- +-- The ES ILM @GET \/policy@ response is keyed by policy id: the JSON +-- object's /keys/ are the policy ids and its /values/ are the policy +-- bodies. 'ILMPolicyInfo''s 'FromJSON' therefore fills 'ilmPolicyInfoId' +-- with a placeholder (@""@) that the list-decoding wrapper in +-- "Database.Bloodhound.Common.Requests" overrides with the actual key. As a +-- consequence, a standalone @decode . encode :: ILMPolicyInfo -> +-- Maybe ILMPolicyInfo@ does not preserve the id; round-trip the whole +-- @[ILMPolicyInfo]@ via 'getILMPolicy' instead. +-- +-- The @GET \/explain@ response is shaped similarly but nested one level +-- deeper: @{\"indices\": {\: {...}}}@. Each inner body also +-- carries its own @index@ field, so 'ILMExplanation''s 'FromJSON' reads +-- it directly (no placeholder trick) and 'ILMExplanations's 'FromJSON' +-- just walks the @indices@ object's values. +module Database.Bloodhound.Internal.Versions.Common.Types.ILM + ( ILMPolicyId (..), + ILMPolicy (..), + ILMPolicyInfo (..), + ILMInUseBy (..), + ILMPolicies (..), + ILMExplanation (..), + ILMExplanations (..), + ILMExplainOptions (..), + defaultILMExplainOptions, + + -- * ILM control (start/stop/status/move) + ILMStepKey (..), + MoveStepRequest (..), + ILMOperationMode (..), + ILMStatus (..), + MigrateDataTiersRequest (..), + defaultMigrateDataTiersRequest, + MigrateDataTiersOptions (..), + defaultMigrateDataTiersOptions, + MigrateDataTiersResponse (..), + + -- * Optics + ilmPolicyBodyLens, + ilmPolicyInfoIdLens, + ilmPolicyInfoVersionLens, + ilmPolicyInfoModifiedDateLens, + ilmPolicyInfoModifiedDateStringLens, + ilmPolicyInfoPolicyLens, + ilmPolicyInfoInUseByLens, + ilmInUseByIndicesLens, + ilmInUseByDataStreamsLens, + ilmPoliciesListLens, + ilmExplanationIndexLens, + ilmExplanationManagedLens, + ilmExplanationPolicyLens, + ilmExplanationPhaseLens, + ilmExplanationPhaseTimeLens, + ilmExplanationPhaseTimeMillisLens, + ilmExplanationActionLens, + ilmExplanationActionTimeLens, + ilmExplanationActionTimeMillisLens, + ilmExplanationStepLens, + ilmExplanationStepTimeLens, + ilmExplanationStepTimeMillisLens, + ilmExplanationStepInfoLens, + ilmExplanationAgeLens, + ilmExplanationLifecycleDateLens, + ilmExplanationLifecycleDateMillisLens, + ilmExplanationIndexCreationDateLens, + ilmExplanationIndexCreationDateMillisLens, + ilmExplanationTimeSinceIndexCreationLens, + ilmExplanationsListLens, + ilmeoOnlyErrorsLens, + ilmeoOnlyManagedLens, + ilmeoMasterTimeoutLens, + ilmStepKeyPhaseLens, + ilmStepKeyActionLens, + ilmStepKeyNameLens, + moveStepRequestCurrentStepLens, + moveStepRequestNextStepLens, + ilmStatusOperationModeLens, + migrateDataTiersRequestLegacyTemplateToDeleteLens, + migrateDataTiersRequestNodeAttributeLens, + migrateDataTiersOptionsDryRunLens, + migrateDataTiersResponseDryRunLens, + migrateDataTiersResponseRemovedLegacyTemplateLens, + migrateDataTiersResponseMigratedIlmPoliciesLens, + migrateDataTiersResponseMigratedIndicesLens, + migrateDataTiersResponseMigratedLegacyTemplatesLens, + migrateDataTiersResponseMigratedComposableTemplatesLens, + migrateDataTiersResponseMigratedComponentTemplatesLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes (IndexName, unIndexName) +import Database.Bloodhound.Internal.Versions.Common.Types.Units (TimeUnits) + +-- | Identifies an ILM policy in the @\/_ilm\/policy\/{id}@ URL path. Wraps +-- 'Text' so it round-trips through JSON as a bare string but is distinct at +-- the Haskell type level from OpenSearch's 'PolicyId' (which is plugin-local). +newtype ILMPolicyId = ILMPolicyId {unILMPolicyId :: Text} + deriving newtype (Eq, Show, ToJSON, FromJSON) + +-- | Request body of @PUT /_ilm/policy\/{id}@. ES wraps the actual policy +-- (phases, actions, ...) under a @policy@ field, so that is exactly what the +-- 'ToJSON' instance produces and what 'FromJSON' expects. The policy proper +-- is carried as an opaque 'Value' until a typed ILM policy schema lands +-- (tracked separately) — the same treatment already used for +-- 'ilmPolicyInfoPolicy'. +newtype ILMPolicy = ILMPolicy {unILMPolicy :: Value} + deriving stock (Eq, Show) + +instance ToJSON ILMPolicy where + toJSON (ILMPolicy body) = object ["policy" .= body] + +instance FromJSON ILMPolicy where + parseJSON = withObject "ILMPolicy" $ \o -> ILMPolicy <$> o .: "policy" + +-- | A single policy entry as returned by @GET /_ilm/policy[\/{id}]@. The +-- @policy@ sub-object is the full ILM policy body (phases, actions, ...) and +-- is carried as an opaque 'Value' until a typed ILM policy schema lands +-- (tracked separately). +data ILMPolicyInfo = ILMPolicyInfo + { ilmPolicyInfoId :: ILMPolicyId, + -- | @version@ is server-managed and may be @-1@ / absent for policies + -- that have never been saved. + ilmPolicyInfoVersion :: Maybe Int, + -- | Epoch milliseconds. Negative or absent on unmodified policies. + ilmPolicyInfoModifiedDate :: Maybe Int, + ilmPolicyInfoModifiedDateString :: Maybe Text, + ilmPolicyInfoPolicy :: Value, + ilmPolicyInfoInUseBy :: Maybe ILMInUseBy + } + deriving stock (Eq, Show) + +-- | The id is the JSON object key in the outer response, not a field inside +-- the value; 'ilmPolicyInfoId' is therefore filled with @""@ here and the +-- list-decoding wrapper in "Database.Bloodhound.Common.Requests" overwrites +-- it with the real key. +-- +-- The @modified_date@ field is tolerant of both wire shapes seen across +-- supported ES versions: early 7.x emits it as an epoch-millis 'Number' +-- alongside a @modified_date_string@ sibling, while ES 7.17+ (and 8.x\/9.x) +-- emit it as an ISO-8601 'String' and drop the @*_string@ sibling. A +-- 'Number' populates 'ilmPolicyInfoModifiedDate'; a 'String' falls through +-- to 'ilmPolicyInfoModifiedDateString' (an explicit @modified_date_string@ +-- sibling, when present, takes precedence on either path). +instance FromJSON ILMPolicyInfo where + parseJSON = withObject "ILMPolicyInfo" $ \o -> do + ilmPolicyInfoVersion <- o .:? "version" + rawModifiedDate <- (o .:? "modified_date") :: Parser (Maybe Value) + explicitDateString <- o .:? "modified_date_string" + let (ilmPolicyInfoModifiedDate, inheritedDateString) = + case rawModifiedDate of + Just (Number n) -> (Just (round n), Nothing) + Just (String s) -> (Nothing, Just s) + _ -> (Nothing, Nothing) + ilmPolicyInfoModifiedDateString = explicitDateString <|> inheritedDateString + ilmPolicyInfoPolicy <- o .: "policy" + ilmPolicyInfoInUseBy <- o .:? "in_use_by" + return ILMPolicyInfo {ilmPolicyInfoId = ILMPolicyId "", ..} + +instance ToJSON ILMPolicyInfo where + toJSON ILMPolicyInfo {..} = + omitNulls $ + catMaybes + [ fmap ("version" .=) ilmPolicyInfoVersion, + fmap ("modified_date" .=) ilmPolicyInfoModifiedDate, + fmap ("modified_date_string" .=) ilmPolicyInfoModifiedDateString, + Just ("policy" .= ilmPolicyInfoPolicy), + fmap ("in_use_by" .=) ilmPolicyInfoInUseBy + ] + +-- | The @in_use_by@ field of an ILM policy response: which concrete indices +-- and data streams are currently managed by the policy. Both lists default +-- to @[]@ when the server omits them. +data ILMInUseBy = ILMInUseBy + { ilmInUseByIndices :: [IndexName], + ilmInUseByDataStreams :: [Text] + } + deriving stock (Eq, Show) + +instance FromJSON ILMInUseBy where + parseJSON = withObject "ILMInUseBy" $ \o -> do + ilmInUseByIndices <- o .:? "indices" .!= [] + ilmInUseByDataStreams <- o .:? "data_streams" .!= [] + return ILMInUseBy {..} + +instance ToJSON ILMInUseBy where + toJSON ILMInUseBy {..} = + object + [ "indices" .= ilmInUseByIndices, + "data_streams" .= ilmInUseByDataStreams + ] + +-- | The response body of @GET /_ilm/policy[\/{id}]@. ES keys the response by +-- policy id, so the JSON is an object whose keys are ids and whose values are +-- the policy bodies. The 'FromJSON' walks the keys and folds each one into +-- the corresponding 'ILMPolicyInfo' (overriding the placeholder id set by +-- 'ILMPolicyInfo's own decoder). Round-trip the whole 'ILMPolicies' through +-- @encode . decode@ to preserve ids. +newtype ILMPolicies = ILMPolicies {unILMPolicies :: [ILMPolicyInfo]} + deriving stock (Eq, Show) + +instance FromJSON ILMPolicies where + parseJSON = withObject "Collection of ILMPolicyInfo" parse + where + parse = fmap ILMPolicies . mapM stamp . KM.toList + stamp (rawId, v) = do + p <- parseJSON v + return p {ilmPolicyInfoId = ILMPolicyId (toText rawId)} + +instance ToJSON ILMPolicies where + toJSON (ILMPolicies ps) = + Object . KM.fromList $ + [ (fromText (unILMPolicyId (ilmPolicyInfoId p)), toJSON p) + | p <- ps + ] + +-- Lenses + +ilmPolicyBodyLens :: Lens' ILMPolicy Value +ilmPolicyBodyLens = lens unILMPolicy (\x y -> x {unILMPolicy = y}) + +ilmPolicyInfoIdLens :: Lens' ILMPolicyInfo ILMPolicyId +ilmPolicyInfoIdLens = lens ilmPolicyInfoId (\x y -> x {ilmPolicyInfoId = y}) + +ilmPolicyInfoVersionLens :: Lens' ILMPolicyInfo (Maybe Int) +ilmPolicyInfoVersionLens = lens ilmPolicyInfoVersion (\x y -> x {ilmPolicyInfoVersion = y}) + +ilmPolicyInfoModifiedDateLens :: Lens' ILMPolicyInfo (Maybe Int) +ilmPolicyInfoModifiedDateLens = lens ilmPolicyInfoModifiedDate (\x y -> x {ilmPolicyInfoModifiedDate = y}) + +ilmPolicyInfoModifiedDateStringLens :: Lens' ILMPolicyInfo (Maybe Text) +ilmPolicyInfoModifiedDateStringLens = lens ilmPolicyInfoModifiedDateString (\x y -> x {ilmPolicyInfoModifiedDateString = y}) + +ilmPolicyInfoPolicyLens :: Lens' ILMPolicyInfo Value +ilmPolicyInfoPolicyLens = lens ilmPolicyInfoPolicy (\x y -> x {ilmPolicyInfoPolicy = y}) + +ilmPolicyInfoInUseByLens :: Lens' ILMPolicyInfo (Maybe ILMInUseBy) +ilmPolicyInfoInUseByLens = lens ilmPolicyInfoInUseBy (\x y -> x {ilmPolicyInfoInUseBy = y}) + +ilmInUseByIndicesLens :: Lens' ILMInUseBy [IndexName] +ilmInUseByIndicesLens = lens ilmInUseByIndices (\x y -> x {ilmInUseByIndices = y}) + +ilmInUseByDataStreamsLens :: Lens' ILMInUseBy [Text] +ilmInUseByDataStreamsLens = lens ilmInUseByDataStreams (\x y -> x {ilmInUseByDataStreams = y}) + +ilmPoliciesListLens :: Lens' ILMPolicies [ILMPolicyInfo] +ilmPoliciesListLens = lens unILMPolicies (\(ILMPolicies _) y -> ILMPolicies y) + +-- $ilm-explain +-- +-- /Explain lifecycle state/ retrieves the per-index ILM status (managed +-- flag, current phase\/action\/step, age, error details, ...). One request +-- can cover many indices because the @index@ path segment accepts +-- wildcards and comma-lists; the response is therefore keyed by the +-- concrete matched index names. + +-- | A single per-index entry in the @GET /_ilm/explain/{index}@ response. +-- Only 'ilmExplanationManaged' is reliably present; every other field is +-- 'Maybe' because Elasticsearch omits @phase@, @action@, @step@, ... on +-- indices that ILM is not currently driving. Time fields come in pairs: +-- an ISO-8601 @*_time@ \/ @*_date@ string alongside the matching +-- @*_millis@ epoch-milliseconds 'Int' — both are kept since callers +-- sometimes want one and sometimes the other. +-- +-- The @step_info@ payload is a free-form object that ES only populates +-- when the current step is in an error state. It is carried as an opaque +-- 'Value' (matching 'ilmPolicyInfoPolicy') pending a typed schema. +data ILMExplanation = ILMExplanation + { ilmExplanationIndex :: IndexName, + ilmExplanationManaged :: Bool, + ilmExplanationPolicy :: Maybe Text, + -- | Current lifecycle phase: @new@, @hot@, @warm@, @cold@, + -- @frozen@, @delete@, @complete@. Open-ended on the wire — parsed as + -- 'Text' rather than an enum so future phases don't break decode. + ilmExplanationPhase :: Maybe Text, + ilmExplanationPhaseTime :: Maybe Text, + ilmExplanationPhaseTimeMillis :: Maybe Int, + ilmExplanationAction :: Maybe Text, + ilmExplanationActionTime :: Maybe Text, + ilmExplanationActionTimeMillis :: Maybe Int, + ilmExplanationStep :: Maybe Text, + ilmExplanationStepTime :: Maybe Text, + ilmExplanationStepTimeMillis :: Maybe Int, + ilmExplanationStepInfo :: Maybe Value, + ilmExplanationAge :: Maybe Text, + ilmExplanationLifecycleDate :: Maybe Text, + ilmExplanationLifecycleDateMillis :: Maybe Int, + ilmExplanationIndexCreationDate :: Maybe Text, + ilmExplanationIndexCreationDateMillis :: Maybe Int, + ilmExplanationTimeSinceIndexCreation :: Maybe Text + } + deriving stock (Eq, Show) + +-- The ES per-index body always includes an @index@ field whose value +-- matches the outer @indices@ object key, so 'FromJSON' reads it +-- directly via 'IndexName's own validated parser. No placeholder trick +-- is needed (contrast with 'ILMPolicyInfo', whose id is only present as +-- the JSON object key and not inside the value). +instance FromJSON ILMExplanation where + parseJSON = withObject "ILMExplanation" $ \o -> do + ilmExplanationIndex <- o .: "index" + ilmExplanationManaged <- o .: "managed" + ilmExplanationPolicy <- o .:? "policy" + ilmExplanationPhase <- o .:? "phase" + ilmExplanationPhaseTime <- o .:? "phase_time" + ilmExplanationPhaseTimeMillis <- o .:? "phase_time_millis" + ilmExplanationAction <- o .:? "action" + ilmExplanationActionTime <- o .:? "action_time" + ilmExplanationActionTimeMillis <- o .:? "action_time_millis" + ilmExplanationStep <- o .:? "step" + ilmExplanationStepTime <- o .:? "step_time" + ilmExplanationStepTimeMillis <- o .:? "step_time_millis" + ilmExplanationStepInfo <- o .:? "step_info" + ilmExplanationAge <- o .:? "age" + ilmExplanationLifecycleDate <- o .:? "lifecycle_date" + ilmExplanationLifecycleDateMillis <- o .:? "lifecycle_date_millis" + ilmExplanationIndexCreationDate <- o .:? "index_creation_date" + ilmExplanationIndexCreationDateMillis <- o .:? "index_creation_date_millis" + ilmExplanationTimeSinceIndexCreation <- o .:? "time_since_index_creation" + return ILMExplanation {..} + +instance ToJSON ILMExplanation where + toJSON ILMExplanation {..} = + omitNulls $ + catMaybes + [ Just ("index" .= ilmExplanationIndex), + Just ("managed" .= ilmExplanationManaged), + ("policy" .=) <$> ilmExplanationPolicy, + ("phase" .=) <$> ilmExplanationPhase, + ("phase_time" .=) <$> ilmExplanationPhaseTime, + ("phase_time_millis" .=) <$> ilmExplanationPhaseTimeMillis, + ("action" .=) <$> ilmExplanationAction, + ("action_time" .=) <$> ilmExplanationActionTime, + ("action_time_millis" .=) <$> ilmExplanationActionTimeMillis, + ("step" .=) <$> ilmExplanationStep, + ("step_time" .=) <$> ilmExplanationStepTime, + ("step_time_millis" .=) <$> ilmExplanationStepTimeMillis, + ("step_info" .=) <$> ilmExplanationStepInfo, + ("age" .=) <$> ilmExplanationAge, + ("lifecycle_date" .=) <$> ilmExplanationLifecycleDate, + ("lifecycle_date_millis" .=) <$> ilmExplanationLifecycleDateMillis, + ("index_creation_date" .=) <$> ilmExplanationIndexCreationDate, + ("index_creation_date_millis" .=) <$> ilmExplanationIndexCreationDateMillis, + ("time_since_index_creation" .=) <$> ilmExplanationTimeSinceIndexCreation + ] + +-- | Response body of @GET /_ilm/explain/{index}@. ES nests the per-index +-- entries under an @indices@ object whose keys are index names and whose +-- values are 'ILMExplanation' bodies. The 'FromJSON' simply decodes the +-- @indices@ object as a list of 'ILMExplanation' values, since each +-- inner body already carries its own @index@ field. +newtype ILMExplanations = ILMExplanations {unILMExplanations :: [ILMExplanation]} + deriving stock (Eq, Show) + +instance FromJSON ILMExplanations where + parseJSON = withObject "ILMExplanations" $ \o -> do + raw <- o .: "indices" + ILMExplanations <$> withObject "Collection of ILMExplanation" parseValues raw + where + parseValues obj = mapM (parseJSON . snd) (KM.toList obj) + +instance ToJSON ILMExplanations where + toJSON (ILMExplanations es) = + object + [ "indices" + .= Object + ( KM.fromList + [ (fromText (unIndexName (ilmExplanationIndex e)), toJSON e) + | e <- es + ] + ) + ] + +-- | URI parameters accepted by @GET /_ilm/explain/{index}@: +-- +-- * @only_errors@ — restrict the response to indices in an ILM error +-- state (policy missing or a step failing). +-- * @only_managed@ — restrict the response to indices ILM currently +-- manages. +-- * @master_timeout@ — time to wait for the master node, rendered via +-- 'timeUnitsSuffix' (e.g. @('TimeUnitSeconds', 30)@ -> @30s@). +-- +-- See +-- . +data ILMExplainOptions = ILMExplainOptions + { ilmeoOnlyErrors :: Maybe Bool, + ilmeoOnlyManaged :: Maybe Bool, + ilmeoMasterTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | The empty options record: no URI parameters are emitted, making +-- @'explainILMWith' 'defaultILMExplainOptions'@ byte-for-byte identical +-- to 'explainILM'. +defaultILMExplainOptions :: ILMExplainOptions +defaultILMExplainOptions = + ILMExplainOptions + { ilmeoOnlyErrors = Nothing, + ilmeoOnlyManaged = Nothing, + ilmeoMasterTimeout = Nothing + } + +-- ILMExplanation lenses + +ilmExplanationIndexLens :: Lens' ILMExplanation IndexName +ilmExplanationIndexLens = lens ilmExplanationIndex (\x y -> x {ilmExplanationIndex = y}) + +ilmExplanationManagedLens :: Lens' ILMExplanation Bool +ilmExplanationManagedLens = lens ilmExplanationManaged (\x y -> x {ilmExplanationManaged = y}) + +ilmExplanationPolicyLens :: Lens' ILMExplanation (Maybe Text) +ilmExplanationPolicyLens = lens ilmExplanationPolicy (\x y -> x {ilmExplanationPolicy = y}) + +ilmExplanationPhaseLens :: Lens' ILMExplanation (Maybe Text) +ilmExplanationPhaseLens = lens ilmExplanationPhase (\x y -> x {ilmExplanationPhase = y}) + +ilmExplanationPhaseTimeLens :: Lens' ILMExplanation (Maybe Text) +ilmExplanationPhaseTimeLens = lens ilmExplanationPhaseTime (\x y -> x {ilmExplanationPhaseTime = y}) + +ilmExplanationPhaseTimeMillisLens :: Lens' ILMExplanation (Maybe Int) +ilmExplanationPhaseTimeMillisLens = lens ilmExplanationPhaseTimeMillis (\x y -> x {ilmExplanationPhaseTimeMillis = y}) + +ilmExplanationActionLens :: Lens' ILMExplanation (Maybe Text) +ilmExplanationActionLens = lens ilmExplanationAction (\x y -> x {ilmExplanationAction = y}) + +ilmExplanationActionTimeLens :: Lens' ILMExplanation (Maybe Text) +ilmExplanationActionTimeLens = lens ilmExplanationActionTime (\x y -> x {ilmExplanationActionTime = y}) + +ilmExplanationActionTimeMillisLens :: Lens' ILMExplanation (Maybe Int) +ilmExplanationActionTimeMillisLens = lens ilmExplanationActionTimeMillis (\x y -> x {ilmExplanationActionTimeMillis = y}) + +ilmExplanationStepLens :: Lens' ILMExplanation (Maybe Text) +ilmExplanationStepLens = lens ilmExplanationStep (\x y -> x {ilmExplanationStep = y}) + +ilmExplanationStepTimeLens :: Lens' ILMExplanation (Maybe Text) +ilmExplanationStepTimeLens = lens ilmExplanationStepTime (\x y -> x {ilmExplanationStepTime = y}) + +ilmExplanationStepTimeMillisLens :: Lens' ILMExplanation (Maybe Int) +ilmExplanationStepTimeMillisLens = lens ilmExplanationStepTimeMillis (\x y -> x {ilmExplanationStepTimeMillis = y}) + +ilmExplanationStepInfoLens :: Lens' ILMExplanation (Maybe Value) +ilmExplanationStepInfoLens = lens ilmExplanationStepInfo (\x y -> x {ilmExplanationStepInfo = y}) + +ilmExplanationAgeLens :: Lens' ILMExplanation (Maybe Text) +ilmExplanationAgeLens = lens ilmExplanationAge (\x y -> x {ilmExplanationAge = y}) + +ilmExplanationLifecycleDateLens :: Lens' ILMExplanation (Maybe Text) +ilmExplanationLifecycleDateLens = lens ilmExplanationLifecycleDate (\x y -> x {ilmExplanationLifecycleDate = y}) + +ilmExplanationLifecycleDateMillisLens :: Lens' ILMExplanation (Maybe Int) +ilmExplanationLifecycleDateMillisLens = lens ilmExplanationLifecycleDateMillis (\x y -> x {ilmExplanationLifecycleDateMillis = y}) + +ilmExplanationIndexCreationDateLens :: Lens' ILMExplanation (Maybe Text) +ilmExplanationIndexCreationDateLens = lens ilmExplanationIndexCreationDate (\x y -> x {ilmExplanationIndexCreationDate = y}) + +ilmExplanationIndexCreationDateMillisLens :: Lens' ILMExplanation (Maybe Int) +ilmExplanationIndexCreationDateMillisLens = lens ilmExplanationIndexCreationDateMillis (\x y -> x {ilmExplanationIndexCreationDateMillis = y}) + +ilmExplanationTimeSinceIndexCreationLens :: Lens' ILMExplanation (Maybe Text) +ilmExplanationTimeSinceIndexCreationLens = lens ilmExplanationTimeSinceIndexCreation (\x y -> x {ilmExplanationTimeSinceIndexCreation = y}) + +ilmExplanationsListLens :: Lens' ILMExplanations [ILMExplanation] +ilmExplanationsListLens = lens unILMExplanations (\(ILMExplanations _) y -> ILMExplanations y) + +-- ILMExplainOptions lenses + +ilmeoOnlyErrorsLens :: Lens' ILMExplainOptions (Maybe Bool) +ilmeoOnlyErrorsLens = lens ilmeoOnlyErrors (\x y -> x {ilmeoOnlyErrors = y}) + +ilmeoOnlyManagedLens :: Lens' ILMExplainOptions (Maybe Bool) +ilmeoOnlyManagedLens = lens ilmeoOnlyManaged (\x y -> x {ilmeoOnlyManaged = y}) + +ilmeoMasterTimeoutLens :: Lens' ILMExplainOptions (Maybe (TimeUnits, Word32)) +ilmeoMasterTimeoutLens = lens ilmeoMasterTimeout (\x y -> x {ilmeoMasterTimeout = y}) + +-- $ilm-control +-- +-- /ILM control/ endpoints drive the plugin's overall operation mode and +-- force individual indices between lifecycle steps. They are: +-- +-- * @POST /_ilm/start@, @POST /_ilm/stop@ — start/stop the plugin +-- ('startILM', 'stopILM'). +-- * @GET /_ilm/status@ — read the operation mode ('getILMStatus', +-- 'ILMStatus' \/ 'ILMOperationMode'). +-- * @POST /_ilm/move/{index}@ — force an index into a specific step +-- ('moveILMStep', 'MoveStepRequest' \/ 'ILMStepKey'). +-- * @POST /_ilm/retry/{index}@ — retry an errored step ('retryILMStep'). +-- * @POST /_ilm/remove/{index}@ — detach an index from ILM ('removeILM'). +-- * @POST /_ilm/migrate_to_data_tiers@ — migrate node-attribute allocation +-- to data-tier routing ('migrateDataTiers', 'MigrateDataTiersRequest', +-- 'MigrateDataTiersResponse'). +-- +-- See +-- , +-- , +-- , +-- , +-- , +-- . + +-- | A single step identifier inside a 'MoveStepRequest' body. Each of the +-- @current_step@ and @next_step@ objects in the @POST /_ilm/move/{index}@ +-- request is one of these. +-- +-- Note the wire-shape gotcha: the step identifier is carried under the +-- @name@ key (NOT @step@, unlike the 'ilmExplanationStep' field of the +-- /explain/ response — the two endpoints genuinely disagree). The +-- 'ToJSON'\/'FromJSON' instances below honour that. +-- +-- Only the @phase@ is required; @action@ and @name@ are optional, and +-- ES will resolve a partial @next_step@ (phase-only, or phase+action) to +-- the first matching step in the policy. +data ILMStepKey = ILMStepKey + { ilmStepKeyPhase :: Text, + ilmStepKeyAction :: Maybe Text, + -- | Step identifier. Rendered as the @name@ JSON key (see the note + -- above). + ilmStepKeyName :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON ILMStepKey where + toJSON ILMStepKey {..} = + omitNulls $ + catMaybes + [ Just ("phase" .= ilmStepKeyPhase), + ("action" .=) <$> ilmStepKeyAction, + ("name" .=) <$> ilmStepKeyName + ] + +instance FromJSON ILMStepKey where + parseJSON = withObject "ILMStepKey" $ \o -> do + ilmStepKeyPhase <- o .: "phase" + ilmStepKeyAction <- o .:? "action" + ilmStepKeyName <- o .:? "name" + return ILMStepKey {..} + +-- | Request body of @POST /_ilm/move/{index}@. Forces the index from +-- 'moveStepRequestCurrentStep' into 'moveStepRequestNextStep'. Both +-- steps must be present in the request body (ES rejects a partial body), +-- though each individual 'ILMStepKey' may leave @action@\/@name@ absent. +data MoveStepRequest = MoveStepRequest + { moveStepRequestCurrentStep :: ILMStepKey, + moveStepRequestNextStep :: ILMStepKey + } + deriving stock (Eq, Show) + +instance ToJSON MoveStepRequest where + toJSON MoveStepRequest {..} = + object + [ "current_step" .= moveStepRequestCurrentStep, + "next_step" .= moveStepRequestNextStep + ] + +instance FromJSON MoveStepRequest where + parseJSON = withObject "MoveStepRequest" $ \o -> do + moveStepRequestCurrentStep <- o .: "current_step" + moveStepRequestNextStep <- o .: "next_step" + return MoveStepRequest {..} + +-- | The cluster-wide ILM operation mode returned by @GET /_ilm/status@. +-- ES exposes exactly three values, all in upper case; the +-- 'ToJSON'\/'FromJSON' instances honour that spelling. An unknown value +-- fails to decode (the enum has been stable since ILM shipped, so a new +-- mode would warrant a deliberate constructor addition here). +data ILMOperationMode + = ILMOperationModeRunning + | ILMOperationModeStopping + | ILMOperationModeStopped + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON ILMOperationMode where + toJSON ILMOperationModeRunning = String "RUNNING" + toJSON ILMOperationModeStopping = String "STOPPING" + toJSON ILMOperationModeStopped = String "STOPPED" + +instance FromJSON ILMOperationMode where + parseJSON = withText "ILMOperationMode" parseOperationMode + where + parseOperationMode "RUNNING" = pure ILMOperationModeRunning + parseOperationMode "STOPPING" = pure ILMOperationModeStopping + parseOperationMode "STOPPED" = pure ILMOperationModeStopped + parseOperationMode other = + fail ("unknown ILM operation_mode: " <> show other) + +-- | Response body of @GET /_ilm/status@. Wraps the single +-- 'ilmStatusOperationMode' field. +newtype ILMStatus = ILMStatus {ilmStatusOperationMode :: ILMOperationMode} + deriving stock (Eq, Show) + +instance ToJSON ILMStatus where + toJSON (ILMStatus mode) = + object ["operation_mode" .= mode] + +instance FromJSON ILMStatus where + parseJSON = withObject "ILMStatus" $ \o -> + ILMStatus <$> o .: "operation_mode" + +-- | Optional body of @POST /_ilm/migrate_to_data_tiers@. Both fields are +-- optional: when omitted, Elasticsearch auto-detects the node attribute +-- from the cluster's existing index routing allocations and only deletes +-- a legacy template if it is unambiguously tied to the detected +-- attribute. Pass them explicitly to disambiguate multi-attribute +-- clusters or to name a specific legacy template to remove. +-- +-- See +-- . +data MigrateDataTiersRequest = MigrateDataTiersRequest + { migrateDataTiersRequestLegacyTemplateToDelete :: Maybe Text, + migrateDataTiersRequestNodeAttribute :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'migrateDataTiers' sends an empty body, letting ES auto-detect both +-- fields. Use the 'migrateDataTiersWith' builder to override them. +defaultMigrateDataTiersRequest :: MigrateDataTiersRequest +defaultMigrateDataTiersRequest = + MigrateDataTiersRequest + { migrateDataTiersRequestLegacyTemplateToDelete = Nothing, + migrateDataTiersRequestNodeAttribute = Nothing + } + +instance ToJSON MigrateDataTiersRequest where + toJSON MigrateDataTiersRequest {..} = + omitNulls $ + catMaybes + [ ("legacy_template_to_delete" .=) + <$> migrateDataTiersRequestLegacyTemplateToDelete, + ("node_attribute" .=) <$> migrateDataTiersRequestNodeAttribute + ] + +instance FromJSON MigrateDataTiersRequest where + parseJSON = withObject "MigrateDataTiersRequest" $ \o -> do + migrateDataTiersRequestLegacyTemplateToDelete <- o .:? "legacy_template_to_delete" + migrateDataTiersRequestNodeAttribute <- o .:? "node_attribute" + return MigrateDataTiersRequest {..} + +-- | Optional URI parameters of @POST /_ilm/migrate_to_data_tiers@. +-- Currently only @dry_run@ is exposed; @master_timeout@ is tracked as a +-- follow-up (the same param is already modelled on 'ILMExplainOptions'). +data MigrateDataTiersOptions = MigrateDataTiersOptions + { migrateDataTiersOptionsDryRun :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | No options: ES performs the migration for real. Set +-- 'migrateDataTiersOptionsDryRun' = 'Just' 'True' to preview the +-- affected indices and templates without applying any change. +defaultMigrateDataTiersOptions :: MigrateDataTiersOptions +defaultMigrateDataTiersOptions = MigrateDataTiersOptions {migrateDataTiersOptionsDryRun = Nothing} + +-- | Response body of @POST /_ilm/migrate_to_data_tiers@. ES returns a +-- flat object describing what was (or, with @dry_run=true@, what /would/ +-- be) migrated. The @removed_legacy_template@ field is documented as +-- required but is absent when no legacy template was removed, so it is +-- decoded as 'Maybe' 'Text'. The @migrated_indices@ field has an unusual +-- union wire shape (@string | array[string]@): a single migrated index +-- comes back as a bare string rather than a one-element array. The +-- 'FromJSON' instance normalises both forms into a single +-- @['Text']@ list so callers never see the asymmetry; 'ToJSON' always +-- emits the array form. +-- +-- See +-- . +data MigrateDataTiersResponse = MigrateDataTiersResponse + { migrateDataTiersResponseDryRun :: Bool, + migrateDataTiersResponseRemovedLegacyTemplate :: Maybe Text, + migrateDataTiersResponseMigratedIlmPolicies :: [Text], + migrateDataTiersResponseMigratedIndices :: [Text], + migrateDataTiersResponseMigratedLegacyTemplates :: [Text], + migrateDataTiersResponseMigratedComposableTemplates :: [Text], + migrateDataTiersResponseMigratedComponentTemplates :: [Text] + } + deriving stock (Eq, Show) + +instance ToJSON MigrateDataTiersResponse where + toJSON MigrateDataTiersResponse {..} = + omitNulls $ + catMaybes + [ Just ("dry_run" .= migrateDataTiersResponseDryRun), + ("removed_legacy_template" .=) + <$> migrateDataTiersResponseRemovedLegacyTemplate, + Just ("migrated_ilm_policies" .= migrateDataTiersResponseMigratedIlmPolicies), + Just ("migrated_indices" .= migrateDataTiersResponseMigratedIndices), + Just ("migrated_legacy_templates" .= migrateDataTiersResponseMigratedLegacyTemplates), + Just ("migrated_composable_templates" .= migrateDataTiersResponseMigratedComposableTemplates), + Just ("migrated_component_templates" .= migrateDataTiersResponseMigratedComponentTemplates) + ] + +instance FromJSON MigrateDataTiersResponse where + parseJSON = withObject "MigrateDataTiersResponse" $ \o -> do + migrateDataTiersResponseDryRun <- o .: "dry_run" + migrateDataTiersResponseRemovedLegacyTemplate <- o .:? "removed_legacy_template" + migrateDataTiersResponseMigratedIlmPolicies <- o .:? "migrated_ilm_policies" .!= [] + migrateDataTiersResponseMigratedIndices <- parseIndicesField =<< o .:? "migrated_indices" + migrateDataTiersResponseMigratedLegacyTemplates <- o .:? "migrated_legacy_templates" .!= [] + migrateDataTiersResponseMigratedComposableTemplates <- o .:? "migrated_composable_templates" .!= [] + migrateDataTiersResponseMigratedComponentTemplates <- o .:? "migrated_component_templates" .!= [] + return MigrateDataTiersResponse {..} + where + -- @migrated_indices@ has a union wire shape: @string | array[string]@. + -- Normalise both forms (and an absent field) to @['Text']@. + parseIndicesField Nothing = pure [] + parseIndicesField (Just (String s)) = pure [s] + parseIndicesField (Just xs) = parseJSON xs + +-- ILMStepKey lenses + +ilmStepKeyPhaseLens :: Lens' ILMStepKey Text +ilmStepKeyPhaseLens = lens ilmStepKeyPhase (\x y -> x {ilmStepKeyPhase = y}) + +ilmStepKeyActionLens :: Lens' ILMStepKey (Maybe Text) +ilmStepKeyActionLens = lens ilmStepKeyAction (\x y -> x {ilmStepKeyAction = y}) + +ilmStepKeyNameLens :: Lens' ILMStepKey (Maybe Text) +ilmStepKeyNameLens = lens ilmStepKeyName (\x y -> x {ilmStepKeyName = y}) + +-- MoveStepRequest lenses + +moveStepRequestCurrentStepLens :: Lens' MoveStepRequest ILMStepKey +moveStepRequestCurrentStepLens = + lens moveStepRequestCurrentStep (\x y -> x {moveStepRequestCurrentStep = y}) + +moveStepRequestNextStepLens :: Lens' MoveStepRequest ILMStepKey +moveStepRequestNextStepLens = + lens moveStepRequestNextStep (\x y -> x {moveStepRequestNextStep = y}) + +-- ILMStatus lens + +ilmStatusOperationModeLens :: Lens' ILMStatus ILMOperationMode +ilmStatusOperationModeLens = + lens ilmStatusOperationMode (\x y -> x {ilmStatusOperationMode = y}) + +-- MigrateDataTiers lenses + +migrateDataTiersRequestLegacyTemplateToDeleteLens :: + Lens' MigrateDataTiersRequest (Maybe Text) +migrateDataTiersRequestLegacyTemplateToDeleteLens = + lens + migrateDataTiersRequestLegacyTemplateToDelete + (\x y -> x {migrateDataTiersRequestLegacyTemplateToDelete = y}) + +migrateDataTiersRequestNodeAttributeLens :: + Lens' MigrateDataTiersRequest (Maybe Text) +migrateDataTiersRequestNodeAttributeLens = + lens + migrateDataTiersRequestNodeAttribute + (\x y -> x {migrateDataTiersRequestNodeAttribute = y}) + +migrateDataTiersOptionsDryRunLens :: Lens' MigrateDataTiersOptions (Maybe Bool) +migrateDataTiersOptionsDryRunLens = + lens + migrateDataTiersOptionsDryRun + (\x y -> x {migrateDataTiersOptionsDryRun = y}) + +migrateDataTiersResponseDryRunLens :: Lens' MigrateDataTiersResponse Bool +migrateDataTiersResponseDryRunLens = + lens + migrateDataTiersResponseDryRun + (\x y -> x {migrateDataTiersResponseDryRun = y}) + +migrateDataTiersResponseRemovedLegacyTemplateLens :: + Lens' MigrateDataTiersResponse (Maybe Text) +migrateDataTiersResponseRemovedLegacyTemplateLens = + lens + migrateDataTiersResponseRemovedLegacyTemplate + (\x y -> x {migrateDataTiersResponseRemovedLegacyTemplate = y}) + +migrateDataTiersResponseMigratedIlmPoliciesLens :: + Lens' MigrateDataTiersResponse [Text] +migrateDataTiersResponseMigratedIlmPoliciesLens = + lens + migrateDataTiersResponseMigratedIlmPolicies + (\x y -> x {migrateDataTiersResponseMigratedIlmPolicies = y}) + +migrateDataTiersResponseMigratedIndicesLens :: + Lens' MigrateDataTiersResponse [Text] +migrateDataTiersResponseMigratedIndicesLens = + lens + migrateDataTiersResponseMigratedIndices + (\x y -> x {migrateDataTiersResponseMigratedIndices = y}) + +migrateDataTiersResponseMigratedLegacyTemplatesLens :: + Lens' MigrateDataTiersResponse [Text] +migrateDataTiersResponseMigratedLegacyTemplatesLens = + lens + migrateDataTiersResponseMigratedLegacyTemplates + (\x y -> x {migrateDataTiersResponseMigratedLegacyTemplates = y}) + +migrateDataTiersResponseMigratedComposableTemplatesLens :: + Lens' MigrateDataTiersResponse [Text] +migrateDataTiersResponseMigratedComposableTemplatesLens = + lens + migrateDataTiersResponseMigratedComposableTemplates + (\x y -> x {migrateDataTiersResponseMigratedComposableTemplates = y}) + +migrateDataTiersResponseMigratedComponentTemplatesLens :: + Lens' MigrateDataTiersResponse [Text] +migrateDataTiersResponseMigratedComponentTemplatesLens = + lens + migrateDataTiersResponseMigratedComponentTemplates + (\x y -> x {migrateDataTiersResponseMigratedComponentTemplates = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Indices.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Indices.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Indices.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Indices.hs @@ -1,914 +1,4851 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} - -module Database.Bloodhound.Internal.Versions.Common.Types.Indices - ( AliasRouting (..), - AllocationPolicy (..), - CompoundFormat (..), - Compression (..), - FSType (..), - FieldDefinition (..), - FieldType (..), - ForceMergeIndexSettings (..), - IndexAlias (..), - IndexAliasAction (..), - IndexAliasCreate (..), - IndexAliasRouting (..), - IndexAliasSummary (..), - IndexAliasesSummary (..), - IndexDocumentSettings (..), - IndexMappingsLimits (..), - IndexPattern (..), - IndexSelection (..), - IndexSettings (..), - IndexSettingsSummary (..), - IndexTemplate (..), - JoinRelation (..), - Mapping (..), - MappingField (..), - NominalDiffTimeJSON (..), - OpenCloseIndex (..), - ReplicaBounds (..), - RoutingValue (..), - SearchAliasRouting (..), - Status (..), - TemplateName (..), - UpdatableIndexSetting (..), - defaultForceMergeIndexSettings, - defaultIndexDocumentSettings, - defaultIndexMappingsLimits, - defaultIndexSettings, - - -- * Optics - statusNameLens, - statusClusterNameLens, - statusClusterUuidLens, - statusVersionLens, - statusTaglineLens, - indexSettingsShardsLens, - indexSettingsReplicasLens, - indexSettingsMappingsLimitsLens, - indexMappingsLimitsDepthLens, - indexMappingsLimitsNestedFieldsLens, - indexMappingsLimitsNestedObjectsLens, - indexMappingsLimitsFieldNameLengthLens, - forceMergeIndexSettingsMaxNumSegmentsLens, - forceMergeIndexSettingsOnlyExpungeDeletesLens, - forceMergeIndexSettingsFlushAfterOptimizeLens, - indexSettingsSummarySummaryIndexNameLens, - indexSettingsSummarySummaryFixedSettingsLens, - indexSettingsSummarySummaryUpdateableLens, - fieldDefinitionTypeLens, - indexTemplatePatternsLens, - indexTemplateSettingsLens, - indexTemplateMappingsLens, - mappingFieldNameLens, - mappingFieldDefinitionLens, - mappingFieldsLens, - indexAliasSrcIndexLens, - indexAliasLens, - indexAliasCreateRoutingLens, - indexAliasCreateFilterLens, - routingValueLens, - indexAliasesSummaryLens, - indexAliasSummaryAliasLens, - indexAliasSummaryCreateLens, - indexDocumentSettingsVersionControlLens, - indexDocumentSettingsJoinRelationLens, - ) -where - -import qualified Data.Aeson.KeyMap as X -import qualified Data.HashMap.Strict as HM -import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import qualified Data.Traversable as DT -import Database.Bloodhound.Internal.Client.Doc -import Database.Bloodhound.Internal.Utils.Imports -import Database.Bloodhound.Internal.Utils.StringlyTyped -import Database.Bloodhound.Internal.Versions.Common.Types.Analysis -import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes -import Database.Bloodhound.Internal.Versions.Common.Types.Nodes -import Database.Bloodhound.Internal.Versions.Common.Types.Query -import Database.Bloodhound.Internal.Versions.Common.Types.Units -import GHC.Generics - --- | 'Status' is a data type for describing the JSON body returned by --- Elasticsearch when you query its status. This was deprecated in 1.2.0. --- --- -data Status = Status - { name :: Text, - cluster_name :: Text, - cluster_uuid :: Text, - version :: Version, - tagline :: Text - } - deriving stock (Eq, Show) - -instance FromJSON Status where - parseJSON (Object v) = - Status - <$> v - .: "name" - <*> v - .: "cluster_name" - <*> v - .: "cluster_uuid" - <*> v - .: "version" - <*> v - .: "tagline" - parseJSON _ = empty - -statusNameLens :: Lens' Status Text -statusNameLens = lens name (\x y -> x {name = y}) - -statusClusterNameLens :: Lens' Status Text -statusClusterNameLens = lens cluster_name (\x y -> x {cluster_name = y}) - -statusClusterUuidLens :: Lens' Status Text -statusClusterUuidLens = lens cluster_uuid (\x y -> x {cluster_uuid = y}) - -statusVersionLens :: Lens' Status Version -statusVersionLens = lens version (\x y -> x {version = y}) - -statusTaglineLens :: Lens' Status Text -statusTaglineLens = lens tagline (\x y -> x {tagline = y}) - --- | 'IndexSettings' is used to configure the shards and replicas when --- you create an Elasticsearch Index. --- --- -data IndexSettings = IndexSettings - { indexShards :: ShardCount, - indexReplicas :: ReplicaCount, - indexMappingsLimits :: IndexMappingsLimits - } - deriving stock (Eq, Show, Generic) - -instance ToJSON IndexSettings where - toJSON (IndexSettings s r l) = - object - [ "settings" - .= object - [ "index" - .= object ["number_of_shards" .= s, "number_of_replicas" .= r, "mapping" .= l] - ] - ] - -instance FromJSON IndexSettings where - parseJSON = withObject "IndexSettings" parse - where - parse o = do - s <- o .: "settings" - i <- s .: "index" - IndexSettings - <$> i - .: "number_of_shards" - <*> i - .: "number_of_replicas" - <*> i - .:? "mapping" - .!= defaultIndexMappingsLimits - -indexSettingsShardsLens :: Lens' IndexSettings ShardCount -indexSettingsShardsLens = lens indexShards (\x y -> x {indexShards = y}) - -indexSettingsReplicasLens :: Lens' IndexSettings ReplicaCount -indexSettingsReplicasLens = lens indexReplicas (\x y -> x {indexReplicas = y}) - -indexSettingsMappingsLimitsLens :: Lens' IndexSettings IndexMappingsLimits -indexSettingsMappingsLimitsLens = lens indexMappingsLimits (\x y -> x {indexMappingsLimits = y}) - --- | 'defaultIndexSettings' is an 'IndexSettings' with 3 shards and --- 2 replicas. -defaultIndexSettings :: IndexSettings -defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2) defaultIndexMappingsLimits - --- defaultIndexSettings is exported by Database.Bloodhound as well --- no trailing slashes in servers, library handles building the path. - --- | 'IndexMappingsLimits is used to configure index's limits. --- -data IndexMappingsLimits = IndexMappingsLimits - { indexMappingsLimitDepth :: Maybe Int, - indexMappingsLimitNestedFields :: Maybe Int, - indexMappingsLimitNestedObjects :: Maybe Int, - indexMappingsLimitFieldNameLength :: Maybe Int - } - deriving stock (Eq, Show, Generic) - -instance ToJSON IndexMappingsLimits where - toJSON (IndexMappingsLimits d f o n) = - object $ - mapMaybe - go - [ ("depth.limit", d), - ("nested_fields.limit", f), - ("nested_objects.limit", o), - ("field_name_length.limit", n) - ] - where - go (name, value) = (name .=) <$> value - -instance FromJSON IndexMappingsLimits where - parseJSON = withObject "IndexMappingsLimits" $ \o -> - IndexMappingsLimits - <$> o .:?? "depth" - <*> o .:?? "nested_fields" - <*> o .:?? "nested_objects" - <*> o .:?? "field_name_length" - where - o .:?? name = optional $ do - f <- o .: name - f .: "limit" - -indexMappingsLimitsDepthLens :: Lens' IndexMappingsLimits (Maybe Int) -indexMappingsLimitsDepthLens = lens indexMappingsLimitDepth (\x y -> x {indexMappingsLimitDepth = y}) - -indexMappingsLimitsNestedFieldsLens :: Lens' IndexMappingsLimits (Maybe Int) -indexMappingsLimitsNestedFieldsLens = lens indexMappingsLimitNestedFields (\x y -> x {indexMappingsLimitNestedFields = y}) - -indexMappingsLimitsNestedObjectsLens :: Lens' IndexMappingsLimits (Maybe Int) -indexMappingsLimitsNestedObjectsLens = lens indexMappingsLimitNestedObjects (\x y -> x {indexMappingsLimitNestedObjects = y}) - -indexMappingsLimitsFieldNameLengthLens :: Lens' IndexMappingsLimits (Maybe Int) -indexMappingsLimitsFieldNameLengthLens = lens indexMappingsLimitFieldNameLength (\x y -> x {indexMappingsLimitFieldNameLength = y}) - -defaultIndexMappingsLimits :: IndexMappingsLimits -defaultIndexMappingsLimits = IndexMappingsLimits Nothing Nothing Nothing Nothing - --- | 'ForceMergeIndexSettings' is used to configure index optimization. See --- --- for more info. -data ForceMergeIndexSettings = ForceMergeIndexSettings - { -- | Number of segments to optimize to. 1 will fully optimize the index. If omitted, the default behavior is to only optimize if the server deems it necessary. - maxNumSegments :: Maybe Int, - -- | Should the optimize process only expunge segments with deletes in them? If the purpose of the optimization is to free disk space, this should be set to True. - onlyExpungeDeletes :: Bool, - -- | Should a flush be performed after the optimize. - flushAfterOptimize :: Bool - } - deriving stock (Eq, Show) - -forceMergeIndexSettingsMaxNumSegmentsLens :: Lens' ForceMergeIndexSettings (Maybe Int) -forceMergeIndexSettingsMaxNumSegmentsLens = lens maxNumSegments (\x y -> x {maxNumSegments = y}) - -forceMergeIndexSettingsOnlyExpungeDeletesLens :: Lens' ForceMergeIndexSettings Bool -forceMergeIndexSettingsOnlyExpungeDeletesLens = lens onlyExpungeDeletes (\x y -> x {onlyExpungeDeletes = y}) - -forceMergeIndexSettingsFlushAfterOptimizeLens :: Lens' ForceMergeIndexSettings Bool -forceMergeIndexSettingsFlushAfterOptimizeLens = lens flushAfterOptimize (\x y -> x {flushAfterOptimize = y}) - --- | 'defaultForceMergeIndexSettings' implements the default settings that --- Elasticsearch uses for index optimization. 'maxNumSegments' is Nothing, --- 'onlyExpungeDeletes' is False, and flushAfterOptimize is True. -defaultForceMergeIndexSettings :: ForceMergeIndexSettings -defaultForceMergeIndexSettings = ForceMergeIndexSettings Nothing False True - --- | 'UpdatableIndexSetting' are settings which may be updated after an index is created. --- --- -data UpdatableIndexSetting - = -- | The number of replicas each shard has. - NumberOfReplicas ReplicaCount - | AutoExpandReplicas ReplicaBounds - | -- | Set to True to have the index read only. False to allow writes and metadata changes. - BlocksReadOnly Bool - | -- | Set to True to disable read operations against the index. - BlocksRead Bool - | -- | Set to True to disable write operations against the index. - BlocksWrite Bool - | -- | Set to True to disable metadata operations against the index. - BlocksMetaData Bool - | -- | The async refresh interval of a shard - RefreshInterval NominalDiffTime - | IndexConcurrency Int - | FailOnMergeFailure Bool - | -- | When to flush on operations. - TranslogFlushThresholdOps Int - | -- | When to flush based on translog (bytes) size. - TranslogFlushThresholdSize Bytes - | -- | When to flush based on a period of not flushing. - TranslogFlushThresholdPeriod NominalDiffTime - | -- | Disables flushing. Note, should be set for a short interval and then enabled. - TranslogDisableFlush Bool - | -- | The maximum size of filter cache (per segment in shard). - CacheFilterMaxSize (Maybe Bytes) - | -- | The expire after access time for filter cache. - CacheFilterExpire (Maybe NominalDiffTime) - | -- | The gateway snapshot interval (only applies to shared gateways). - GatewaySnapshotInterval NominalDiffTime - | -- | A node matching any rule will be allowed to host shards from the index. - RoutingAllocationInclude (NonEmpty NodeAttrFilter) - | -- | A node matching any rule will NOT be allowed to host shards from the index. - RoutingAllocationExclude (NonEmpty NodeAttrFilter) - | -- | Only nodes matching all rules will be allowed to host shards from the index. - RoutingAllocationRequire (NonEmpty NodeAttrFilter) - | -- | Enables shard allocation for a specific index. - RoutingAllocationEnable AllocationPolicy - | -- | Controls the total number of shards (replicas and primaries) allowed to be allocated on a single node. - RoutingAllocationShardsPerNode ShardCount - | -- | When using local gateway a particular shard is recovered only if there can be allocated quorum shards in the cluster. - RecoveryInitialShards InitialShardCount - | GCDeletes NominalDiffTime - | -- | Disables temporarily the purge of expired docs. - TTLDisablePurge Bool - | TranslogFSType FSType - | CompressionSetting Compression - | IndexCompoundFormat CompoundFormat - | IndexCompoundOnFlush Bool - | WarmerEnabled Bool - | MappingTotalFieldsLimit Int - | -- | Analysis is not a dynamic setting and can only be performed on a closed index. - AnalysisSetting Analysis - | -- | Sets a delay to the allocation of replica shards which become unassigned because a node has left, giving them chance to return. See - UnassignedNodeLeftDelayedTimeout NominalDiffTime - deriving stock (Eq, Show, Generic) - -attrFilterJSON :: NonEmpty NodeAttrFilter -> Value -attrFilterJSON fs = - object - [ fromText n .= T.intercalate "," (toList vs) - | NodeAttrFilter (NodeAttrName n) vs <- toList fs - ] - -parseAttrFilter :: Value -> Parser (NonEmpty NodeAttrFilter) -parseAttrFilter = withObject "NonEmpty NodeAttrFilter" parse - where - parse o = case X.toList o of - [] -> fail "Expected non-empty list of NodeAttrFilters" - x : xs -> DT.mapM (uncurry parse') (x :| xs) - parse' n = withText "Text" $ \t -> - case T.splitOn "," t of - fv : fvs -> return (NodeAttrFilter (NodeAttrName $ toText n) (fv :| fvs)) - [] -> fail "Expected non-empty list of filter values" - -instance ToJSON UpdatableIndexSetting where - toJSON (NumberOfReplicas x) = oPath ("index" :| ["number_of_replicas"]) x - toJSON (AutoExpandReplicas x) = oPath ("index" :| ["auto_expand_replicas"]) x - toJSON (RefreshInterval x) = oPath ("index" :| ["refresh_interval"]) (NominalDiffTimeJSON x) - toJSON (IndexConcurrency x) = oPath ("index" :| ["concurrency"]) x - toJSON (FailOnMergeFailure x) = oPath ("index" :| ["fail_on_merge_failure"]) x - toJSON (TranslogFlushThresholdOps x) = oPath ("index" :| ["translog", "flush_threshold_ops"]) x - toJSON (TranslogFlushThresholdSize x) = oPath ("index" :| ["translog", "flush_threshold_size"]) x - toJSON (TranslogFlushThresholdPeriod x) = oPath ("index" :| ["translog", "flush_threshold_period"]) (NominalDiffTimeJSON x) - toJSON (TranslogDisableFlush x) = oPath ("index" :| ["translog", "disable_flush"]) x - toJSON (CacheFilterMaxSize x) = oPath ("index" :| ["cache", "filter", "max_size"]) x - toJSON (CacheFilterExpire x) = oPath ("index" :| ["cache", "filter", "expire"]) (NominalDiffTimeJSON <$> x) - toJSON (GatewaySnapshotInterval x) = oPath ("index" :| ["gateway", "snapshot_interval"]) (NominalDiffTimeJSON x) - toJSON (RoutingAllocationInclude fs) = oPath ("index" :| ["routing", "allocation", "include"]) (attrFilterJSON fs) - toJSON (RoutingAllocationExclude fs) = oPath ("index" :| ["routing", "allocation", "exclude"]) (attrFilterJSON fs) - toJSON (RoutingAllocationRequire fs) = oPath ("index" :| ["routing", "allocation", "require"]) (attrFilterJSON fs) - toJSON (RoutingAllocationEnable x) = oPath ("index" :| ["routing", "allocation", "enable"]) x - toJSON (RoutingAllocationShardsPerNode x) = oPath ("index" :| ["routing", "allocation", "total_shards_per_node"]) x - toJSON (RecoveryInitialShards x) = oPath ("index" :| ["recovery", "initial_shards"]) x - toJSON (GCDeletes x) = oPath ("index" :| ["gc_deletes"]) (NominalDiffTimeJSON x) - toJSON (TTLDisablePurge x) = oPath ("index" :| ["ttl", "disable_purge"]) x - toJSON (TranslogFSType x) = oPath ("index" :| ["translog", "fs", "type"]) x - toJSON (CompressionSetting x) = oPath ("index" :| ["codec"]) x - toJSON (IndexCompoundFormat x) = oPath ("index" :| ["compound_format"]) x - toJSON (IndexCompoundOnFlush x) = oPath ("index" :| ["compound_on_flush"]) x - toJSON (WarmerEnabled x) = oPath ("index" :| ["warmer", "enabled"]) x - toJSON (BlocksReadOnly x) = oPath ("blocks" :| ["read_only"]) x - toJSON (BlocksRead x) = oPath ("blocks" :| ["read"]) x - toJSON (BlocksWrite x) = oPath ("blocks" :| ["write"]) x - toJSON (BlocksMetaData x) = oPath ("blocks" :| ["metadata"]) x - toJSON (MappingTotalFieldsLimit x) = oPath ("index" :| ["mapping", "total_fields", "limit"]) x - toJSON (AnalysisSetting x) = oPath ("index" :| ["analysis"]) x - toJSON (UnassignedNodeLeftDelayedTimeout x) = oPath ("index" :| ["unassigned", "node_left", "delayed_timeout"]) (NominalDiffTimeJSON x) - -instance FromJSON UpdatableIndexSetting where - parseJSON = withObject "UpdatableIndexSetting" parse - where - parse o = - numberOfReplicas - `taggedAt` ["index", "number_of_replicas"] - <|> autoExpandReplicas - `taggedAt` ["index", "auto_expand_replicas"] - <|> refreshInterval - `taggedAt` ["index", "refresh_interval"] - <|> indexConcurrency - `taggedAt` ["index", "concurrency"] - <|> failOnMergeFailure - `taggedAt` ["index", "fail_on_merge_failure"] - <|> translogFlushThresholdOps - `taggedAt` ["index", "translog", "flush_threshold_ops"] - <|> translogFlushThresholdSize - `taggedAt` ["index", "translog", "flush_threshold_size"] - <|> translogFlushThresholdPeriod - `taggedAt` ["index", "translog", "flush_threshold_period"] - <|> translogDisableFlush - `taggedAt` ["index", "translog", "disable_flush"] - <|> cacheFilterMaxSize - `taggedAt` ["index", "cache", "filter", "max_size"] - <|> cacheFilterExpire - `taggedAt` ["index", "cache", "filter", "expire"] - <|> gatewaySnapshotInterval - `taggedAt` ["index", "gateway", "snapshot_interval"] - <|> routingAllocationInclude - `taggedAt` ["index", "routing", "allocation", "include"] - <|> routingAllocationExclude - `taggedAt` ["index", "routing", "allocation", "exclude"] - <|> routingAllocationRequire - `taggedAt` ["index", "routing", "allocation", "require"] - <|> routingAllocationEnable - `taggedAt` ["index", "routing", "allocation", "enable"] - <|> routingAllocationShardsPerNode - `taggedAt` ["index", "routing", "allocation", "total_shards_per_node"] - <|> recoveryInitialShards - `taggedAt` ["index", "recovery", "initial_shards"] - <|> gcDeletes - `taggedAt` ["index", "gc_deletes"] - <|> ttlDisablePurge - `taggedAt` ["index", "ttl", "disable_purge"] - <|> translogFSType - `taggedAt` ["index", "translog", "fs", "type"] - <|> compressionSetting - `taggedAt` ["index", "codec"] - <|> compoundFormat - `taggedAt` ["index", "compound_format"] - <|> compoundOnFlush - `taggedAt` ["index", "compound_on_flush"] - <|> warmerEnabled - `taggedAt` ["index", "warmer", "enabled"] - <|> blocksReadOnly - `taggedAt` ["blocks", "read_only"] - <|> blocksRead - `taggedAt` ["blocks", "read"] - <|> blocksWrite - `taggedAt` ["blocks", "write"] - <|> blocksMetaData - `taggedAt` ["blocks", "metadata"] - <|> mappingTotalFieldsLimit - `taggedAt` ["index", "mapping", "total_fields", "limit"] - <|> analysisSetting - `taggedAt` ["index", "analysis"] - <|> unassignedNodeLeftDelayedTimeout - `taggedAt` ["index", "unassigned", "node_left", "delayed_timeout"] - where - taggedAt :: (FromJSON a) => (a -> Parser b) -> [Key] -> Parser b - taggedAt f ks = taggedAt' f (Object o) ks - taggedAt' f v [] = - f =<< (parseJSON v <|> parseJSON (unStringlyTypeJSON v)) - taggedAt' f v (k : ks) = - withObject - "Object" - ( \o -> do - v' <- o .: k - taggedAt' f v' ks - ) - v - numberOfReplicas = pure . NumberOfReplicas - autoExpandReplicas = pure . AutoExpandReplicas - refreshInterval = pure . RefreshInterval . ndtJSON - indexConcurrency = pure . IndexConcurrency - failOnMergeFailure = pure . FailOnMergeFailure - translogFlushThresholdOps = pure . TranslogFlushThresholdOps - translogFlushThresholdSize = pure . TranslogFlushThresholdSize - translogFlushThresholdPeriod = pure . TranslogFlushThresholdPeriod . ndtJSON - translogDisableFlush = pure . TranslogDisableFlush - cacheFilterMaxSize = pure . CacheFilterMaxSize - cacheFilterExpire = pure . CacheFilterExpire . fmap ndtJSON - gatewaySnapshotInterval = pure . GatewaySnapshotInterval . ndtJSON - routingAllocationInclude = fmap RoutingAllocationInclude . parseAttrFilter - routingAllocationExclude = fmap RoutingAllocationExclude . parseAttrFilter - routingAllocationRequire = fmap RoutingAllocationRequire . parseAttrFilter - routingAllocationEnable = pure . RoutingAllocationEnable - routingAllocationShardsPerNode = pure . RoutingAllocationShardsPerNode - recoveryInitialShards = pure . RecoveryInitialShards - gcDeletes = pure . GCDeletes . ndtJSON - ttlDisablePurge = pure . TTLDisablePurge - translogFSType = pure . TranslogFSType - compressionSetting = pure . CompressionSetting - compoundFormat = pure . IndexCompoundFormat - compoundOnFlush = pure . IndexCompoundOnFlush - warmerEnabled = pure . WarmerEnabled - blocksReadOnly = pure . BlocksReadOnly - blocksRead = pure . BlocksRead - blocksWrite = pure . BlocksWrite - blocksMetaData = pure . BlocksMetaData - mappingTotalFieldsLimit = pure . MappingTotalFieldsLimit - analysisSetting = pure . AnalysisSetting - unassignedNodeLeftDelayedTimeout = pure . UnassignedNodeLeftDelayedTimeout . ndtJSON - -data ReplicaBounds - = ReplicasBounded Int Int - | ReplicasLowerBounded Int - | ReplicasUnbounded - deriving stock (Eq, Show) - -instance ToJSON ReplicaBounds where - toJSON (ReplicasBounded a b) = String (showText a <> "-" <> showText b) - toJSON (ReplicasLowerBounded a) = String (showText a <> "-all") - toJSON ReplicasUnbounded = Bool False - -instance FromJSON ReplicaBounds where - parseJSON v = - withText "ReplicaBounds" parseText v - <|> withBool "ReplicaBounds" parseBool v - where - parseText t = case T.splitOn "-" t of - [a, "all"] -> ReplicasLowerBounded <$> parseReadText a - [a, b] -> - ReplicasBounded - <$> parseReadText a - <*> parseReadText b - _ -> fail ("Could not parse ReplicaBounds: " <> show t) - parseBool False = pure ReplicasUnbounded - parseBool _ = fail "ReplicasUnbounded cannot be represented with True" - -data Compression - = -- | Compress with LZ4 - CompressionDefault - | -- | Compress with DEFLATE. Elastic - -- - -- that this can reduce disk use by 15%-25%. - CompressionBest - deriving stock (Eq, Show, Generic) - -instance ToJSON Compression where - toJSON x = case x of - CompressionDefault -> toJSON ("default" :: Text) - CompressionBest -> toJSON ("best_compression" :: Text) - -instance FromJSON Compression where - parseJSON = withText "Compression" $ \t -> case t of - "default" -> return CompressionDefault - "best_compression" -> return CompressionBest - _ -> fail "invalid compression codec" - -data FSType - = FSSimple - | FSBuffered - deriving stock (Eq, Show, Generic) - -instance ToJSON FSType where - toJSON FSSimple = "simple" - toJSON FSBuffered = "buffered" - -instance FromJSON FSType where - parseJSON = withText "FSType" parse - where - parse "simple" = pure FSSimple - parse "buffered" = pure FSBuffered - parse t = fail ("Invalid FSType: " <> show t) - -data CompoundFormat - = CompoundFileFormat Bool - | -- | percentage between 0 and 1 where 0 is false, 1 is true - MergeSegmentVsTotalIndex Double - deriving stock (Eq, Show, Generic) - -instance ToJSON CompoundFormat where - toJSON (CompoundFileFormat x) = Bool x - toJSON (MergeSegmentVsTotalIndex x) = toJSON x - -instance FromJSON CompoundFormat where - parseJSON v = - CompoundFileFormat - <$> parseJSON v - <|> MergeSegmentVsTotalIndex - <$> parseJSON v - -newtype NominalDiffTimeJSON = NominalDiffTimeJSON {ndtJSON :: NominalDiffTime} - -instance ToJSON NominalDiffTimeJSON where - toJSON (NominalDiffTimeJSON t) = String (showText (round t :: Integer) <> "s") - -instance FromJSON NominalDiffTimeJSON where - parseJSON = withText "NominalDiffTime" parse - where - parse t = case T.takeEnd 1 t of - "s" -> NominalDiffTimeJSON . fromInteger <$> parseReadText (T.dropEnd 1 t) - _ -> fail "Invalid or missing NominalDiffTime unit (expected s)" - -data IndexSettingsSummary = IndexSettingsSummary - { sSummaryIndexName :: IndexName, - sSummaryFixedSettings :: IndexSettings, - sSummaryUpdateable :: [UpdatableIndexSetting] - } - deriving stock (Eq, Show) - -indexSettingsSummarySummaryIndexNameLens :: Lens' IndexSettingsSummary IndexName -indexSettingsSummarySummaryIndexNameLens = lens sSummaryIndexName (\x y -> x {sSummaryIndexName = y}) - -indexSettingsSummarySummaryFixedSettingsLens :: Lens' IndexSettingsSummary IndexSettings -indexSettingsSummarySummaryFixedSettingsLens = lens sSummaryFixedSettings (\x y -> x {sSummaryFixedSettings = y}) - -indexSettingsSummarySummaryUpdateableLens :: Lens' IndexSettingsSummary [UpdatableIndexSetting] -indexSettingsSummarySummaryUpdateableLens = lens sSummaryUpdateable (\x y -> x {sSummaryUpdateable = y}) - -parseSettings :: Object -> Parser [UpdatableIndexSetting] -parseSettings o = do - o' <- o .: "index" - -- slice the index object into singleton hashmaps and try to parse each - parses <- forM (HM.toList o') $ \(k, v) -> do - -- blocks are now nested into the "index" key, which is not how they're serialized - let atRoot = Object (X.singleton k v) - let atIndex = Object (X.singleton "index" atRoot) - optional (parseJSON atRoot <|> parseJSON atIndex) - return (catMaybes parses) - -instance FromJSON IndexSettingsSummary where - parseJSON = withObject "IndexSettingsSummary" parse - where - parse o = case X.toList o of - [(ixn, v@(Object o'))] -> - IndexSettingsSummary - <$> parseJSON (toJSON ixn) - <*> parseJSON v - <*> (fmap (filter (not . redundant)) . parseSettings =<< o' .: "settings") - _ -> fail "Expected single-key object with index name" - redundant (NumberOfReplicas _) = True - redundant _ = False - --- | 'OpenCloseIndex' is a sum type for opening and closing indices. --- --- -data OpenCloseIndex = OpenIndex | CloseIndex deriving stock (Eq, Show) - -data FieldType - = GeoPointType - | GeoShapeType - | FloatType - | IntegerType - | LongType - | ShortType - | ByteType - deriving stock (Eq, Show) - -newtype FieldDefinition = FieldDefinition - { fieldType :: FieldType - } - deriving stock (Eq, Show) - -fieldDefinitionTypeLens :: Lens' FieldDefinition FieldType -fieldDefinitionTypeLens = lens fieldType (\x y -> x {fieldType = y}) - --- | An 'IndexTemplate' defines a template that will automatically be --- applied to new indices created. The templates include both --- 'IndexSettings' and mappings, and a simple 'IndexPattern' that --- controls if the template will be applied to the index created. --- Specify mappings as follows: @[toJSON TweetMapping, ...]@ --- --- https://www.elastic.co/guide/en/elasticsearch/reference/1.7/indices-templates.html -data IndexTemplate = IndexTemplate - { templatePatterns :: [IndexPattern], - templateSettings :: Maybe IndexSettings, - templateMappings :: Value - } - -instance ToJSON IndexTemplate where - toJSON (IndexTemplate p s m) = - merge - ( object - [ "index_patterns" .= p, - "mappings" .= m - ] - ) - (toJSON s) - where - merge (Object o1) (Object o2) = toJSON $ X.union o1 o2 - merge o Null = o - merge _ _ = undefined - -indexTemplatePatternsLens :: Lens' IndexTemplate [IndexPattern] -indexTemplatePatternsLens = lens templatePatterns (\x y -> x {templatePatterns = y}) - -indexTemplateSettingsLens :: Lens' IndexTemplate (Maybe IndexSettings) -indexTemplateSettingsLens = lens templateSettings (\x y -> x {templateSettings = y}) - -indexTemplateMappingsLens :: Lens' IndexTemplate Value -indexTemplateMappingsLens = lens templateMappings (\x y -> x {templateMappings = y}) - -data MappingField = MappingField - { mappingFieldName :: FieldName, - fieldDefinition :: FieldDefinition - } - deriving stock (Eq, Show) - -mappingFieldNameLens :: Lens' MappingField FieldName -mappingFieldNameLens = lens mappingFieldName (\x y -> x {mappingFieldName = y}) - -mappingFieldDefinitionLens :: Lens' MappingField FieldDefinition -mappingFieldDefinitionLens = lens fieldDefinition (\x y -> x {fieldDefinition = y}) - --- | Support for type reification of 'Mapping's is currently incomplete, for --- now the mapping API verbiage expects a 'ToJSON'able blob. --- --- Indexes have mappings, mappings are schemas for the documents contained --- in the index. I'd recommend having only one mapping per index, always --- having a mapping, and keeping different kinds of documents separated --- if possible. -newtype Mapping = Mapping {mappingFields :: [MappingField]} - deriving stock (Eq, Show) - -mappingFieldsLens :: Lens' Mapping [MappingField] -mappingFieldsLens = lens mappingFields (\x y -> x {mappingFields = y}) - -data AllocationPolicy - = -- | Allows shard allocation for all shards. - AllocAll - | -- | Allows shard allocation only for primary shards. - AllocPrimaries - | -- | Allows shard allocation only for primary shards for new indices. - AllocNewPrimaries - | -- | No shard allocation is allowed - AllocNone - deriving stock (Eq, Show, Generic) - -instance ToJSON AllocationPolicy where - toJSON AllocAll = String "all" - toJSON AllocPrimaries = String "primaries" - toJSON AllocNewPrimaries = String "new_primaries" - toJSON AllocNone = String "none" - -instance FromJSON AllocationPolicy where - parseJSON = withText "AllocationPolicy" parse - where - parse "all" = pure AllocAll - parse "primaries" = pure AllocPrimaries - parse "new_primaries" = pure AllocNewPrimaries - parse "none" = pure AllocNone - parse t = fail ("Invlaid AllocationPolicy: " <> show t) - -data IndexAlias = IndexAlias - { srcIndex :: IndexName, - indexAlias :: IndexAliasName - } - deriving stock (Eq, Show) - -indexAliasSrcIndexLens :: Lens' IndexAlias IndexName -indexAliasSrcIndexLens = lens srcIndex (\x y -> x {srcIndex = y}) - -indexAliasLens :: Lens' IndexAlias IndexAliasName -indexAliasLens = lens indexAlias (\x y -> x {indexAlias = y}) - -data IndexAliasAction - = AddAlias IndexAlias IndexAliasCreate - | RemoveAlias IndexAlias - deriving stock (Eq, Show) - -data IndexAliasCreate = IndexAliasCreate - { aliasCreateRouting :: Maybe AliasRouting, - aliasCreateFilter :: Maybe Filter - } - deriving stock (Eq, Show) - -indexAliasCreateRoutingLens :: Lens' IndexAliasCreate (Maybe AliasRouting) -indexAliasCreateRoutingLens = lens aliasCreateRouting (\x y -> x {aliasCreateRouting = y}) - -indexAliasCreateFilterLens :: Lens' IndexAliasCreate (Maybe Filter) -indexAliasCreateFilterLens = lens aliasCreateFilter (\x y -> x {aliasCreateFilter = y}) - -data AliasRouting - = AllAliasRouting RoutingValue - | GranularAliasRouting (Maybe SearchAliasRouting) (Maybe IndexAliasRouting) - deriving stock (Eq, Show) - -newtype SearchAliasRouting - = SearchAliasRouting (NonEmpty RoutingValue) - deriving stock (Eq, Show, Generic) - -instance ToJSON SearchAliasRouting where - toJSON (SearchAliasRouting rvs) = toJSON (T.intercalate "," (routingValue <$> toList rvs)) - -instance FromJSON SearchAliasRouting where - parseJSON = withText "SearchAliasRouting" parse - where - parse t = SearchAliasRouting <$> parseNEJSON (String <$> T.splitOn "," t) - -newtype IndexAliasRouting - = IndexAliasRouting RoutingValue - deriving newtype (Eq, Show, ToJSON, FromJSON) - -newtype RoutingValue = RoutingValue {routingValue :: Text} - deriving newtype (Eq, Show, ToJSON, FromJSON) - -routingValueLens :: Lens' RoutingValue Text -routingValueLens = lens routingValue (\x y -> x {routingValue = y}) - -newtype IndexAliasesSummary = IndexAliasesSummary {indexAliasesSummary :: [IndexAliasSummary]} - deriving stock (Eq, Show) - -instance FromJSON IndexAliasesSummary where - parseJSON = withObject "IndexAliasesSummary" parse - where - parse o = IndexAliasesSummary . mconcat <$> mapM (uncurry go) (X.toList o) - go ixn = withObject "index aliases" $ \ia -> do - indexName <- parseJSON $ toJSON ixn - aliases <- ia .:? "aliases" .!= mempty - forM (HM.toList aliases) $ \(aName, v) -> do - let indexAlias = IndexAlias indexName (IndexAliasName aName) - IndexAliasSummary indexAlias <$> parseJSON v - -indexAliasesSummaryLens :: Lens' IndexAliasesSummary [IndexAliasSummary] -indexAliasesSummaryLens = lens indexAliasesSummary (\x y -> x {indexAliasesSummary = y}) - -instance ToJSON IndexAliasAction where - toJSON (AddAlias ia opts) = object ["add" .= (jsonObject ia <> jsonObject opts)] - toJSON (RemoveAlias ia) = object ["remove" .= jsonObject ia] - -instance ToJSON IndexAlias where - toJSON IndexAlias {..} = - object - [ "index" .= srcIndex, - "alias" .= indexAlias - ] - -instance ToJSON IndexAliasCreate where - toJSON IndexAliasCreate {..} = Object (filterObj <> routingObj) - where - filterObj = maybe mempty (X.singleton "filter" . toJSON) aliasCreateFilter - routingObj = jsonObject $ maybe (Object mempty) toJSON aliasCreateRouting - -instance ToJSON AliasRouting where - toJSON (AllAliasRouting v) = object ["routing" .= v] - toJSON (GranularAliasRouting srch idx) = object (catMaybes prs) - where - prs = - [ ("search_routing" .=) <$> srch, - ("index_routing" .=) <$> idx - ] - -instance FromJSON AliasRouting where - parseJSON = withObject "AliasRouting" parse - where - parse o = parseAll o <|> parseGranular o - parseAll o = AllAliasRouting <$> o .: "routing" - parseGranular o = do - sr <- o .:? "search_routing" - ir <- o .:? "index_routing" - if isNothing sr && isNothing ir - then fail "Both search_routing and index_routing can't be blank" - else return (GranularAliasRouting sr ir) - -instance FromJSON IndexAliasCreate where - parseJSON v = withObject "IndexAliasCreate" parse v - where - parse o = - IndexAliasCreate - <$> optional (parseJSON v) - <*> o .:? "filter" - --- | 'IndexAliasSummary' is a summary of an index alias configured for a server. -data IndexAliasSummary = IndexAliasSummary - { indexAliasSummaryAlias :: IndexAlias, - indexAliasSummaryCreate :: IndexAliasCreate - } - deriving stock (Eq, Show) - -indexAliasSummaryAliasLens :: Lens' IndexAliasSummary IndexAlias -indexAliasSummaryAliasLens = lens indexAliasSummaryAlias (\x y -> x {indexAliasSummaryAlias = y}) - -indexAliasSummaryCreateLens :: Lens' IndexAliasSummary IndexAliasCreate -indexAliasSummaryCreateLens = lens indexAliasSummaryCreate (\x y -> x {indexAliasSummaryCreate = y}) - -data JoinRelation - = ParentDocument FieldName RelationName - | ChildDocument FieldName RelationName DocId - deriving stock (Eq, Show) - --- | 'IndexDocumentSettings' are special settings supplied when indexing --- a document. For the best backwards compatiblity when new fields are --- added, you should probably prefer to start with 'defaultIndexDocumentSettings' -data IndexDocumentSettings = IndexDocumentSettings - { idsVersionControl :: VersionControl, - idsJoinRelation :: Maybe JoinRelation - } - deriving stock (Eq, Show) - -indexDocumentSettingsVersionControlLens :: Lens' IndexDocumentSettings VersionControl -indexDocumentSettingsVersionControlLens = lens idsVersionControl (\x y -> x {idsVersionControl = y}) - -indexDocumentSettingsJoinRelationLens :: Lens' IndexDocumentSettings (Maybe JoinRelation) -indexDocumentSettingsJoinRelationLens = lens idsJoinRelation (\x y -> x {idsJoinRelation = y}) - --- | Reasonable default settings. Chooses no version control and no parent. -defaultIndexDocumentSettings :: IndexDocumentSettings -defaultIndexDocumentSettings = IndexDocumentSettings NoVersionControl Nothing - --- | 'IndexSelection' is used for APIs which take a single index, a list of --- indexes, or the special @_all@ index. - --- TODO: this does not fully support . It wouldn't be too hard to implement but you'd have to add the optional parameters (ignore_unavailable, allow_no_indices, expand_wildcards) to any APIs using it. Also would be a breaking API. -data IndexSelection - = IndexList (NonEmpty IndexName) - | AllIndexes - deriving stock (Eq, Show) - --- | 'TemplateName' is used to describe which template to query/create/delete -newtype TemplateName = TemplateName Text deriving newtype (Eq, Show, ToJSON, FromJSON) - --- | 'IndexPattern' represents a pattern which is matched against index names -newtype IndexPattern = IndexPattern Text deriving newtype (Eq, Show, ToJSON, FromJSON) - --- * Utils - -jsonObject :: (ToJSON a) => a -> Object -jsonObject x = - case toJSON x of - Object o -> o - e -> error $ "Expected Object, but got " <> show e +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.Common.Types.Indices + ( ActiveShardCount (..), + SamplingMethod (..), + AliasRouting (..), + AllocationPolicy (..), + CompoundFormat (..), + ComponentTemplate (..), + ComposableTemplate (..), + ComposableTemplateContent (..), + ComposableTemplateOptions (..), + Compression (..), + CreateIndexOptions (..), + DiskWatermark (..), + EsDuration (..), + FSType (..), + FieldDefinition (..), + FieldType (..), + FieldMappingResponse (..), + FieldMappingIndexEntry (..), + FieldMappingDetail (..), + ForceMergeIndexSettings (..), + GetIndexTemplatesResponse (..), + GetTemplatesResponse (..), + ComponentTemplateInfo (..), + GetComponentTemplatesResponse (..), + IndexAlias (..), + IndexAliasAction (..), + IndexAliasCreate (..), + IndexAliasRouting (..), + IndexAliasSummary (..), + IndexAliasesSummary (..), + IndexAliasesInfo (..), + IndexBlock (..), + IndexDocumentSettings (..), + IndexMappingsLimits (..), + IndexPattern (..), + mkIndexPattern, + IndexSelection (..), + IndexInfo (..), + IndexSettings (..), + IndexSettingsSummary (..), + IndexTemplate (..), + IndexTemplateInfo (..), + TemplateInfo (..), + JoinRelation (..), + Mapping (..), + MappingField (..), + NominalDiffTimeJSON (..), + OpenCloseIndex (..), + ReplicaBounds (..), + RoutingValue (..), + RolloverConditions (..), + RolloverResponse (..), + ShrinkSettings (..), + SplitSettings (..), + CloneSettings (..), + SearchAliasRouting (..), + Status (..), + TemplateName (..), + TemplateNamePattern (..), + SimulatedTemplate (..), + SimulatedTemplateOverlap (..), + UpdatableIndexSetting (..), + UpdateAliasesOptions (..), + defaultCreateIndexOptions, + defaultComposableTemplateOptions, + defaultForceMergeIndexSettings, + defaultIndexAliasCreate, + defaultIndexDocumentSettings, + defaultIndexMappingsLimits, + defaultIndexSettings, + defaultRolloverConditions, + defaultShrinkSettings, + defaultSplitSettings, + defaultCloneSettings, + defaultUpdateAliasesOptions, + indexBlockText, + indexBlockToSetting, + indexBlockToUpdatable, + renderActiveShardCount, + renderEsDuration, + updateAliasesOptionsParams, + + -- * Optics + statusNameLens, + statusClusterNameLens, + statusClusterUuidLens, + statusVersionLens, + statusTaglineLens, + indexSettingsShardsLens, + indexSettingsReplicasLens, + indexSettingsMappingsLimitsLens, + indexMappingsLimitsDepthLens, + indexMappingsLimitsNestedFieldsLens, + indexMappingsLimitsNestedObjectsLens, + indexMappingsLimitsFieldNameLengthLens, + forceMergeIndexSettingsMaxNumSegmentsLens, + forceMergeIndexSettingsOnlyExpungeDeletesLens, + forceMergeIndexSettingsFlushAfterOptimizeLens, + indexSettingsSummarySummaryIndexNameLens, + indexSettingsSummarySummaryFixedSettingsLens, + indexSettingsSummarySummaryUpdateableLens, + iiIndexNameLens, + iiAliasesLens, + iiMappingsLens, + iiFixedSettingsLens, + iiUpdateableSettingsLens, + fieldDefinitionTypeLens, + indexTemplatePatternsLens, + indexTemplateSettingsLens, + indexTemplateMappingsLens, + ctIndexPatternsLens, + ctTemplateLens, + ctPriorityLens, + ctVersionLens, + ctComposedOfLens, + ctAllowAutoCreateLens, + cpTemplateLens, + cpVersionLens, + cpMetaLens, + cpDeprecatedLens, + ctcSettingsLens, + ctcMappingsLens, + ctcAliasesLens, + ctoCreateLens, + ctoMasterTimeoutLens, + ctoCauseLens, + composableTemplateOptionsParams, + itiNameLens, + itiIndexTemplateLens, + getIndexTemplatesResponseTemplatesLens, + stTemplateLens, + stOverlappingLens, + stOtherLens, + stoNameLens, + stoIndexPatternsLens, + stoOtherLens, + tiNameLens, + tiOrderLens, + tiIndexPatternsLens, + tiSettingsLens, + tiMappingsLens, + tiAliasesLens, + tiVersionLens, + getTemplatesResponseTemplatesLens, + ctiNameLens, + ctiComponentTemplateLens, + getComponentTemplatesResponseTemplatesLens, + mappingFieldNameLens, + mappingFieldDefinitionLens, + mappingFieldsLens, + fieldMappingResponseIndicesLens, + fieldMappingIndexEntryFieldsLens, + fieldMappingDetailFullNameLens, + fieldMappingDetailMappingLens, + indexAliasSrcIndexLens, + indexAliasLens, + indexAliasCreateRoutingLens, + indexAliasCreateFilterLens, + indexAliasCreateIsWriteIndexLens, + indexAliasCreateIsHiddenLens, + indexAliasCreateMustExistLens, + routingValueLens, + indexAliasesSummaryLens, + indexAliasesInfoLens, + indexAliasSummaryAliasLens, + indexAliasSummaryCreateLens, + uaoMasterTimeoutLens, + uaoTimeoutLens, + indexDocumentSettingsVersionControlLens, + indexDocumentSettingsJoinRelationLens, + indexDocumentSettingsOpTypeLens, + indexDocumentSettingsPipelineLens, + indexDocumentSettingsRefreshLens, + indexDocumentSettingsWaitForActiveShardsLens, + indexDocumentSettingsIfSeqNoLens, + indexDocumentSettingsIfPrimaryTermLens, + indexDocumentSettingsRequireAliasLens, + indexDocumentSettingsTimeoutLens, + + -- * CreateIndexOptions optics + cioSettingsLens, + cioMappingsLens, + cioAliasesLens, + cioWaitForActiveShardsLens, + cioMasterTimeoutLens, + cioTimeoutLens, + + -- * Rollover optics + rolloverConditionsMaxAgeLens, + rolloverConditionsMaxDocsLens, + rolloverConditionsMaxSizeLens, + rolloverConditionsMaxPrimaryShardSizeLens, + rolloverResponseAcknowledgedLens, + rolloverResponseShardsAcknowledgedLens, + rolloverResponseOldIndexLens, + rolloverResponseNewIndexLens, + rolloverResponseRolledOverLens, + rolloverResponseDryRunLens, + rolloverResponseConditionsLens, + + -- * Resize optics + shrinkSettingsOptionsLens, + splitSettingsOptionsLens, + cloneSettingsOptionsLens, + + -- * Index Stats + IndexStats (..), + IndexStatAggregate (..), + IndexStatEntry (..), + IndexStatMetrics (..), + IndexStatDocs (..), + IndexStatStore (..), + + -- * Index Stats Optics + indexStatsShardsLens, + indexStatsAllLens, + indexStatsIndicesLens, + indexStatAggregatePrimariesLens, + indexStatAggregateTotalLens, + indexStatEntryUuidLens, + indexStatEntryHealthLens, + indexStatEntryStatusLens, + indexStatEntryPrimariesLens, + indexStatEntryTotalLens, + indexStatMetricsDocsLens, + indexStatMetricsStoreLens, + indexStatMetricsOtherLens, + indexStatDocsCountLens, + indexStatDocsDeletedLens, + indexStatStoreSizeInBytesLens, + + -- * Index Recovery + IndexRecovery (..), + ShardRecovery (..), + ShardRecoveryIndex (..), + ShardRecoveryFiles (..), + + -- * Index Recovery Optics + indexRecoveryIndicesLens, + shardRecoveryIdLens, + shardRecoveryTypeLens, + shardRecoveryStageLens, + shardRecoveryPrimaryLens, + shardRecoveryStartTimeMillisLens, + shardRecoveryStopTimeMillisLens, + shardRecoveryTotalTimeMillisLens, + shardRecoverySourceLens, + shardRecoveryTargetLens, + shardRecoveryIndexLens, + shardRecoveryOtherLens, + shardRecoveryIndexFilesLens, + shardRecoveryIndexOtherLens, + shardRecoveryFilesTotalLens, + shardRecoveryFilesReusedLens, + shardRecoveryFilesRecoveredLens, + shardRecoveryFilesPercentLens, + + -- * Index Segments + IndexSegments (..), + IndexSegmentsShard (..), + SegmentRouting (..), + SegmentInfo (..), + + -- * Index Segments Optics + indexSegmentsShardsLens, + indexSegmentsIndicesLens, + indexSegmentsShardRoutingLens, + indexSegmentsShardNumCommittedLens, + indexSegmentsShardNumSearchLens, + indexSegmentsShardSegmentsLens, + segmentRoutingStateLens, + segmentRoutingPrimaryLens, + segmentRoutingNodeLens, + segmentRoutingRelocatingNodeLens, + segmentGenerationLens, + segmentNumDocsLens, + segmentDeletedDocsLens, + segmentSizeInBytesLens, + segmentMemoryInBytesLens, + segmentCommittedLens, + segmentSearchLens, + segmentVersionLens, + segmentCompoundLens, + segmentAttributesLens, + segmentOtherLens, + + -- * Shard Stores + ShardStores (..), + ShardStoresShard (..), + ShardStore (..), + ShardStoreNode (..), + ShardStoreAllocation (..), + ShardStoreException (..), + + -- * Shard Stores Optics + shardStoresShardsLens, + shardStoresIndicesLens, + shardStoresShardStoresLens, + shardStoreAllocationIdLens, + shardStoreAllocationLens, + shardStoreNodeLens, + shardStoreStoreExceptionLens, + shardStoreOtherLens, + shardStoreNodeNameLens, + shardStoreNodeEphemeralIdLens, + shardStoreNodeTransportAddressLens, + shardStoreNodeExternalIdLens, + shardStoreNodeAttributesLens, + shardStoreNodeRolesLens, + shardStoreNodeVersionLens, + shardStoreNodeMinIndexVersionLens, + shardStoreNodeMaxIndexVersionLens, + shardStoreNodeOtherLens, + shardStoreExceptionTypeLens, + shardStoreExceptionReasonLens, + shardStoreExceptionOtherLens, + + -- * Resolve Index + ResolveIndexOptions (..), + defaultResolveIndexOptions, + resolveIndexOptionsParams, + ResolvedIndices (..), + ResolvedIndex (..), + ResolvedAlias (..), + ResolvedDataStream (..), + + -- * Index ops options (open/close/flush/refresh) + OpenCloseIndexOptions (..), + defaultOpenCloseIndexOptions, + openCloseIndexOptionsParams, + FlushIndexOptions (..), + defaultFlushIndexOptions, + flushIndexOptionsParams, + RefreshIndexOptions (..), + defaultRefreshIndexOptions, + refreshIndexOptionsParams, + + -- * Put mapping options + PutMappingOptions (..), + defaultPutMappingOptions, + putMappingOptionsParams, + + -- * Index settings options (update/get) + UpdateIndexSettingsOptions (..), + defaultUpdateIndexSettingsOptions, + updateIndexSettingsOptionsParams, + GetIndexSettingsOptions (..), + defaultGetIndexSettingsOptions, + getIndexSettingsOptionsParams, + + -- * Shard Stores options + ShardStoresStatus (..), + shardStoresStatusText, + ShardStoresOptions (..), + defaultShardStoresOptions, + shardStoresOptionsParams, + + -- * Resolve Index Optics + rioExpandWildcardsLens, + rioIgnoreUnavailableLens, + rioAllowNoIndicesLens, + resolvedIndicesIndicesLens, + resolvedIndicesAliasesLens, + resolvedIndicesDataStreamsLens, + resolvedIndexNameLens, + resolvedIndexAttributesLens, + resolvedIndexAliasesLens, + resolvedIndexDataStreamLens, + resolvedIndexModeLens, + resolvedIndexOtherLens, + resolvedAliasNameLens, + resolvedAliasIndicesLens, + resolvedAliasOtherLens, + resolvedDataStreamNameLens, + resolvedDataStreamBackingIndicesLens, + resolvedDataStreamTimestampFieldLens, + resolvedDataStreamOtherLens, + + -- * Index ops options optics (open/close/flush/refresh) + ocioWaitForActiveShardsLens, + ocioIgnoreUnavailableLens, + ocioAllowNoIndicesLens, + ocioExpandWildcardsLens, + ocioMasterTimeoutLens, + ocioTimeoutLens, + fioWaitIfOngoingLens, + fioForceLens, + fioIgnoreUnavailableLens, + fioAllowNoIndicesLens, + fioExpandWildcardsLens, + rfioIgnoreUnavailableLens, + rfioAllowNoIndicesLens, + rfioExpandWildcardsLens, + rfioForceLens, + + -- * Put mapping options optics + pmoAllowNoIndicesLens, + pmoExpandWildcardsLens, + pmoIgnoreUnavailableLens, + pmoMasterTimeoutLens, + pmoTimeoutLens, + pmoWriteIndexOnlyLens, + + -- * Index settings options optics (update/get) + uisoMasterTimeoutLens, + uisoTimeoutLens, + uisoPreserveExistingLens, + uisoFlatSettingsLens, + gisoMasterTimeoutLens, + gisoFlatSettingsLens, + gisoIncludeDefaultsLens, + gisoLocalLens, + + -- * Shard Stores options optics + ssoStatusLens, + ssoIgnoreUnavailableLens, + ssoAllowNoIndicesLens, + ssoExpandWildcardsLens, + + -- * Utils + jsonObject, + ) +where + +import Data.Aeson.Key qualified as AK +import Data.Aeson.KeyMap qualified as X +import Data.HashMap.Strict qualified as HM +import Data.Map.Strict qualified as M +import Data.Maybe (mapMaybe) +import Data.Text qualified as T +import Data.Traversable qualified as DT +import Data.Word (Word32, Word64) +import Database.Bloodhound.Internal.Client.Doc +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Utils.StringlyTyped +import Database.Bloodhound.Internal.Versions.Common.Types.Analysis +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes +import Database.Bloodhound.Internal.Versions.Common.Types.OpType (OpType) +import Database.Bloodhound.Internal.Versions.Common.Types.Query +import Database.Bloodhound.Internal.Versions.Common.Types.Refresh (RefreshPolicy) +import Database.Bloodhound.Internal.Versions.Common.Types.Units +import GHC.Generics + +-- | 'Status' is a data type for describing the JSON body returned by +-- Elasticsearch when you query its status. This was deprecated in 1.2.0. +-- +-- +data Status = Status + { name :: Text, + cluster_name :: Text, + cluster_uuid :: Text, + version :: Version, + tagline :: Text + } + deriving stock (Eq, Show) + +instance FromJSON Status where + parseJSON (Object v) = + Status + <$> v + .: "name" + <*> v + .: "cluster_name" + <*> v + .: "cluster_uuid" + <*> v + .: "version" + <*> v + .: "tagline" + parseJSON _ = empty + +statusNameLens :: Lens' Status Text +statusNameLens = lens name (\x y -> x {name = y}) + +statusClusterNameLens :: Lens' Status Text +statusClusterNameLens = lens cluster_name (\x y -> x {cluster_name = y}) + +statusClusterUuidLens :: Lens' Status Text +statusClusterUuidLens = lens cluster_uuid (\x y -> x {cluster_uuid = y}) + +statusVersionLens :: Lens' Status Version +statusVersionLens = lens version (\x y -> x {version = y}) + +statusTaglineLens :: Lens' Status Text +statusTaglineLens = lens tagline (\x y -> x {tagline = y}) + +-- | 'IndexSettings' is used to configure the shards and replicas when +-- you create an Elasticsearch Index. +-- +-- +data IndexSettings = IndexSettings + { indexShards :: ShardCount, + indexReplicas :: ReplicaCount, + indexMappingsLimits :: IndexMappingsLimits + } + deriving stock (Eq, Show, Generic) + +instance ToJSON IndexSettings where + toJSON (IndexSettings s r l) = + object + [ "settings" + .= object + [ "index" + .= object ["number_of_shards" .= s, "number_of_replicas" .= r, "mapping" .= l] + ] + ] + +instance FromJSON IndexSettings where + parseJSON = withObject "IndexSettings" parse + where + parse o = do + s <- o .: "settings" + i <- s .: "index" + IndexSettings + <$> i + .: "number_of_shards" + <*> i + .: "number_of_replicas" + <*> i + .:? "mapping" + .!= defaultIndexMappingsLimits + +indexSettingsShardsLens :: Lens' IndexSettings ShardCount +indexSettingsShardsLens = lens indexShards (\x y -> x {indexShards = y}) + +indexSettingsReplicasLens :: Lens' IndexSettings ReplicaCount +indexSettingsReplicasLens = lens indexReplicas (\x y -> x {indexReplicas = y}) + +indexSettingsMappingsLimitsLens :: Lens' IndexSettings IndexMappingsLimits +indexSettingsMappingsLimitsLens = lens indexMappingsLimits (\x y -> x {indexMappingsLimits = y}) + +-- | 'defaultIndexSettings' is an 'IndexSettings' with 3 shards and +-- 2 replicas. +defaultIndexSettings :: IndexSettings +defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2) defaultIndexMappingsLimits + +-- defaultIndexSettings is exported by Database.Bloodhound as well +-- no trailing slashes in servers, library handles building the path. + +-- | 'IndexMappingsLimits is used to configure index's limits. +-- +data IndexMappingsLimits = IndexMappingsLimits + { indexMappingsLimitDepth :: Maybe Int, + indexMappingsLimitNestedFields :: Maybe Int, + indexMappingsLimitNestedObjects :: Maybe Int, + indexMappingsLimitFieldNameLength :: Maybe Int + } + deriving stock (Eq, Show, Generic) + +instance ToJSON IndexMappingsLimits where + toJSON (IndexMappingsLimits d f o n) = + object $ + mapMaybe + go + [ ("depth.limit", d), + ("nested_fields.limit", f), + ("nested_objects.limit", o), + ("field_name_length.limit", n) + ] + where + go (name, value) = (name .=) <$> value + +instance FromJSON IndexMappingsLimits where + parseJSON = withObject "IndexMappingsLimits" $ \o -> + IndexMappingsLimits + <$> o .:?? "depth" + <*> o .:?? "nested_fields" + <*> o .:?? "nested_objects" + <*> o .:?? "field_name_length" + where + o .:?? name = optional $ do + f <- o .: name + f .: "limit" + +indexMappingsLimitsDepthLens :: Lens' IndexMappingsLimits (Maybe Int) +indexMappingsLimitsDepthLens = lens indexMappingsLimitDepth (\x y -> x {indexMappingsLimitDepth = y}) + +indexMappingsLimitsNestedFieldsLens :: Lens' IndexMappingsLimits (Maybe Int) +indexMappingsLimitsNestedFieldsLens = lens indexMappingsLimitNestedFields (\x y -> x {indexMappingsLimitNestedFields = y}) + +indexMappingsLimitsNestedObjectsLens :: Lens' IndexMappingsLimits (Maybe Int) +indexMappingsLimitsNestedObjectsLens = lens indexMappingsLimitNestedObjects (\x y -> x {indexMappingsLimitNestedObjects = y}) + +indexMappingsLimitsFieldNameLengthLens :: Lens' IndexMappingsLimits (Maybe Int) +indexMappingsLimitsFieldNameLengthLens = lens indexMappingsLimitFieldNameLength (\x y -> x {indexMappingsLimitFieldNameLength = y}) + +defaultIndexMappingsLimits :: IndexMappingsLimits +defaultIndexMappingsLimits = IndexMappingsLimits Nothing Nothing Nothing Nothing + +-- | 'ForceMergeIndexSettings' is used to configure index optimization. See +-- +-- for more info. +-- +-- /NOTE/ (added @bloodhound-04f.7.17@, 2026-06-20): this record +-- intentionally does /not/ model @master_timeout@ or @timeout@, even +-- though those parameters are listed on some endpoint-summary pages. +-- Verified empirically: every supported backend (ES 7.17, 8.17, 9.3; +-- OpenSearch 1.3, 2.19, 3.0) returns HTTP 400 +-- @contains unrecognized parameters: [master_timeout], [timeout]@ when +-- they are sent on @POST //_forcemerge@. Do not re-add them +-- without re-checking the upstream contract. +data ForceMergeIndexSettings = ForceMergeIndexSettings + { -- | Number of segments to optimize to. 1 will fully optimize the index. If omitted, the default behavior is to only optimize if the server deems it necessary. + maxNumSegments :: Maybe Int, + -- | Should the optimize process only expunge segments with deletes in them? If the purpose of the optimization is to free disk space, this should be set to True. + onlyExpungeDeletes :: Bool, + -- | Should a flush be performed after the optimize. + flushAfterOptimize :: Bool + } + deriving stock (Eq, Show) + +forceMergeIndexSettingsMaxNumSegmentsLens :: Lens' ForceMergeIndexSettings (Maybe Int) +forceMergeIndexSettingsMaxNumSegmentsLens = lens maxNumSegments (\x y -> x {maxNumSegments = y}) + +forceMergeIndexSettingsOnlyExpungeDeletesLens :: Lens' ForceMergeIndexSettings Bool +forceMergeIndexSettingsOnlyExpungeDeletesLens = lens onlyExpungeDeletes (\x y -> x {onlyExpungeDeletes = y}) + +forceMergeIndexSettingsFlushAfterOptimizeLens :: Lens' ForceMergeIndexSettings Bool +forceMergeIndexSettingsFlushAfterOptimizeLens = lens flushAfterOptimize (\x y -> x {flushAfterOptimize = y}) + +-- | 'defaultForceMergeIndexSettings' implements the default settings that +-- Elasticsearch uses for index optimization. 'maxNumSegments' is Nothing, +-- 'onlyExpungeDeletes' is False, and flushAfterOptimize is True. +defaultForceMergeIndexSettings :: ForceMergeIndexSettings +defaultForceMergeIndexSettings = ForceMergeIndexSettings Nothing False True + +-- | An Elasticsearch time-duration value rendered as @@ +-- (e.g. @200ms@, @5s@, @1m@). Unlike 'NominalDiffTimeJSON' — which is +-- seconds-only and silently rounds sub-second values — 'EsDuration' +-- preserves the full set of time units accepted by Elasticsearch +-- (matching 'timeUnitsSuffix'). Used by settings such as slowlog +-- thresholds and @index.search.idle.after@. +-- +-- +data EsDuration = EsDuration + { edMagnitude :: Word, + edUnit :: TimeUnits + } + deriving stock (Eq, Ord, Show, Generic) + +-- | Render an 'EsDuration' as the bare ES wire string +-- (@@), e.g. @EsDuration 200 TimeUnitMilliseconds@ +-- → @"200ms"@. Used both by the 'ToJSON' instance and by URI renderers. +renderEsDuration :: EsDuration -> Text +renderEsDuration (EsDuration n u) = showText n <> timeUnitsSuffix u + +instance ToJSON EsDuration where + toJSON = String . renderEsDuration + +instance FromJSON EsDuration where + parseJSON = withText "EsDuration" $ \t -> + case parseEsDuration t of + Just d -> pure d + Nothing -> fail ("Invalid EsDuration (expected ): " <> show t) + +-- | Parse the @@ wire form. Multi-char suffixes (@ms@, +-- @micros@, @nanos@) are tried before their single-char tails as a +-- defensive measure — @stripSuffix@ + the all-digit check on the +-- remainder already disambiguates in practice, but trying the longest +-- suffix first keeps the match unambiguous if the digit check ever +-- loosens. +parseEsDuration :: Text -> Maybe EsDuration +parseEsDuration t = go unitsBySuffixLength + where + go [] = Nothing + go (u : us) = + case T.stripSuffix (timeUnitsSuffix u) t of + Just digits + | not (T.null digits), + Just n <- readMay (T.unpack digits) -> + Just (EsDuration n u) + _ -> go us + -- Longest suffix first so "ms"/"micros"/"nanos" win over "m"/"s". + unitsBySuffixLength = + [ TimeUnitMicroseconds, + TimeUnitNanoseconds, + TimeUnitMilliseconds, + TimeUnitDays, + TimeUnitHours, + TimeUnitMinutes, + TimeUnitSeconds + ] + +-- | A disk-allocation watermark value as accepted by the +-- @index.routing.allocation.disk.watermark.{low,high,flood_stage}@ +-- settings. Elasticsearch accepts either a percentage string +-- (e.g. @"85%"@) or a fixed byte size (e.g. @"500gb"@). +-- +-- +data DiskWatermark + = -- | Render as @"%"@ (e.g. @DiskWatermarkPercent 85@ → @"85%"@). + DiskWatermarkPercent Double + | -- | Render as @"b"@ using the raw byte count carried by 'Bytes' + -- (e.g. @DiskWatermarkBytes (gigabytes 500)@ → @"500000000000b"@). + DiskWatermarkBytes Bytes + deriving stock (Eq, Ord, Show, Generic) + +instance ToJSON DiskWatermark where + toJSON (DiskWatermarkPercent p) = String (showText p <> "%") + toJSON (DiskWatermarkBytes (Bytes n)) = String (showText n <> "b") + +instance FromJSON DiskWatermark where + parseJSON = withText "DiskWatermark" $ \t -> + case parseDiskWatermark t of + Just w -> pure w + Nothing -> fail ("Invalid DiskWatermark: " <> show t) + +-- | Parse a 'DiskWatermark' from its ES wire form: @"%"@ for a +-- percentage, otherwise an ES byte-size string (@500gb@, @1024b@, bare +-- @1024@ treated as bytes). +parseDiskWatermark :: Text -> Maybe DiskWatermark +parseDiskWatermark t + | Just rest <- T.stripSuffix "%" t = DiskWatermarkPercent <$> readMay (T.unpack rest) + | otherwise = DiskWatermarkBytes <$> parseByteSize t + +-- | Parse an ES byte-size string (@500gb@, @1024b@, bare @1024@) into +-- raw 'Bytes'. Returns 'Nothing' for an unparseable magnitude, an +-- unknown suffix, or a value that would overflow 'Bytes'\'s 'Int' +-- (e.g. an absurd @9999pb@). The multiplier is applied in 'Integer' +-- and bounds-checked before being narrowed back to 'Int'. +parseByteSize :: Text -> Maybe Bytes +parseByteSize t = + if T.null numStr + then Nothing + else do + n <- readMay (T.unpack numStr) :: Maybe Integer + mult <- lookupMultiplier suffixStr :: Maybe Integer + let prod = n * toInteger mult + if prod > toInteger (maxBound :: Int) + then Nothing + else Just (Bytes (fromInteger prod)) + where + isAsciiDigit c = c >= '0' && c <= '9' + (numStr, suffixStr) = T.span isAsciiDigit t + lookupMultiplier s = case T.unpack s of + "" -> Just 1 + "b" -> Just 1 + "kb" -> Just 1000 + "mb" -> Just (1000 * 1000) + "gb" -> Just (1000 * 1000 * 1000) + "tb" -> Just (1000 * 1000 * 1000 * 1000) + "pb" -> Just (1000 * 1000 * 1000 * 1000 * 1000) + _ -> Nothing + +-- | 'UpdatableIndexSetting' are settings which may be updated after an index is created. +-- +-- +data UpdatableIndexSetting + = -- | The number of replicas each shard has. + NumberOfReplicas ReplicaCount + | AutoExpandReplicas ReplicaBounds + | -- | Set to True to have the index read only. False to allow writes and metadata changes. + BlocksReadOnly Bool + | -- | Set to True to disable read operations against the index. + BlocksRead Bool + | -- | Set to True to disable write operations against the index. + BlocksWrite Bool + | -- | Set to True to disable metadata operations against the index. + BlocksMetaData Bool + | -- | The async refresh interval of a shard + RefreshInterval NominalDiffTime + | IndexConcurrency Int + | FailOnMergeFailure Bool + | -- | When to flush on operations. + TranslogFlushThresholdOps Int + | -- | When to flush based on translog (bytes) size. + TranslogFlushThresholdSize Bytes + | -- | When to flush based on a period of not flushing. + TranslogFlushThresholdPeriod NominalDiffTime + | -- | Disables flushing. Note, should be set for a short interval and then enabled. + TranslogDisableFlush Bool + | -- | The maximum size of filter cache (per segment in shard). + CacheFilterMaxSize (Maybe Bytes) + | -- | The expire after access time for filter cache. + CacheFilterExpire (Maybe NominalDiffTime) + | -- | The gateway snapshot interval (only applies to shared gateways). + GatewaySnapshotInterval NominalDiffTime + | -- | A node matching any rule will be allowed to host shards from the index. + RoutingAllocationInclude (NonEmpty NodeAttrFilter) + | -- | A node matching any rule will NOT be allowed to host shards from the index. + RoutingAllocationExclude (NonEmpty NodeAttrFilter) + | -- | Only nodes matching all rules will be allowed to host shards from the index. + RoutingAllocationRequire (NonEmpty NodeAttrFilter) + | -- | Enables shard allocation for a specific index. + RoutingAllocationEnable AllocationPolicy + | -- | Controls the total number of shards (replicas and primaries) allowed to be allocated on a single node. + RoutingAllocationShardsPerNode ShardCount + | -- | When using local gateway a particular shard is recovered only if there can be allocated quorum shards in the cluster. + RecoveryInitialShards InitialShardCount + | GCDeletes NominalDiffTime + | -- | Disables temporarily the purge of expired docs. + TTLDisablePurge Bool + | TranslogFSType FSType + | CompressionSetting Compression + | IndexCompoundFormat CompoundFormat + | IndexCompoundOnFlush Bool + | WarmerEnabled Bool + | MappingTotalFieldsLimit Int + | -- | Analysis is not a dynamic setting and can only be performed on a closed index. + AnalysisSetting Analysis + | -- | Sets a delay to the allocation of replica shards which become unassigned because a node has left, giving them chance to return. See + UnassignedNodeLeftDelayedTimeout NominalDiffTime + | -- | How long a shard can go without a search/get before being + -- marked search-idle. @index.search.idle.after@ (default @30s@). + IndexSearchIdleAfter EsDuration + | -- | Enables or disables the request cache for the index. + -- @index.requests.cache.enable@. + RequestsCacheEnable Bool + | -- | Hides the index from wildcard lookups unless explicitly requested. + -- @index.hidden@. + IndexHidden Bool + | -- | Sets @index.blocks.read_only_allow_delete@ — the index can be + -- read and documents deleted, but no writes, mapping changes, or + -- setting changes are allowed. ES sets this automatically when a + -- disk hits the flood-stage watermark; it can also be set manually. + -- Distinct from 'BlocksReadOnly' (which does not allow deletes). + BlocksReadOnlyAllowDelete Bool + | -- | Index recovery priority (lower numbers are recovered first). + -- @index.priority@. + IndexPriority Int + | -- | Disk watermark for shard allocation — low water mark. + -- @index.routing.allocation.disk.watermark.low@. + RoutingAllocationDiskWatermarkLow DiskWatermark + | -- | Disk watermark for shard allocation — high water mark. + -- @index.routing.allocation.disk.watermark.high@. + RoutingAllocationDiskWatermarkHigh DiskWatermark + | -- | Disk watermark for shard allocation — flood-stage water mark. + -- @index.routing.allocation.disk.watermark.flood_stage@. + RoutingAllocationDiskWatermarkFloodStage DiskWatermark + | -- | Search slowlog threshold for the query phase at @warn@ level. + -- @index.search.slowlog.threshold.query.warn@. + SearchSlowlogThresholdQueryWarn EsDuration + | -- | @index.search.slowlog.threshold.query.info@. + SearchSlowlogThresholdQueryInfo EsDuration + | -- | @index.search.slowlog.threshold.query.debug@. + SearchSlowlogThresholdQueryDebug EsDuration + | -- | @index.search.slowlog.threshold.query.trace@. + SearchSlowlogThresholdQueryTrace EsDuration + | -- | Search slowlog threshold for the fetch phase at @warn@ level. + -- @index.search.slowlog.threshold.fetch.warn@. + SearchSlowlogThresholdFetchWarn EsDuration + | -- | @index.search.slowlog.threshold.fetch.info@. + SearchSlowlogThresholdFetchInfo EsDuration + | -- | @index.search.slowlog.threshold.fetch.debug@. + SearchSlowlogThresholdFetchDebug EsDuration + | -- | @index.search.slowlog.threshold.fetch.trace@. + SearchSlowlogThresholdFetchTrace EsDuration + | -- | Indexing slowlog threshold at @warn@ level. + -- @index.indexing.slowlog.threshold.index.warn@. + IndexingSlowlogThresholdIndexWarn EsDuration + | -- | @index.indexing.slowlog.threshold.index.info@. + IndexingSlowlogThresholdIndexInfo EsDuration + | -- | @index.indexing.slowlog.threshold.index.debug@. + IndexingSlowlogThresholdIndexDebug EsDuration + | -- | @index.indexing.slowlog.threshold.index.trace@. + IndexingSlowlogThresholdIndexTrace EsDuration + deriving stock (Eq, Show, Generic) + +attrFilterJSON :: NonEmpty NodeAttrFilter -> Value +attrFilterJSON fs = + object + [ fromText n .= T.intercalate "," (toList vs) + | NodeAttrFilter (NodeAttrName n) vs <- toList fs + ] + +parseAttrFilter :: Value -> Parser (NonEmpty NodeAttrFilter) +parseAttrFilter = withObject "NonEmpty NodeAttrFilter" parse + where + parse o = case X.toList o of + [] -> fail "Expected non-empty list of NodeAttrFilters" + x : xs -> DT.mapM (uncurry parse') (x :| xs) + parse' n = withText "Text" $ \t -> + case T.splitOn "," t of + fv : fvs -> return (NodeAttrFilter (NodeAttrName $ toText n) (fv :| fvs)) + [] -> fail "Expected non-empty list of filter values" + +instance ToJSON UpdatableIndexSetting where + toJSON (NumberOfReplicas x) = oPath ("index" :| ["number_of_replicas"]) x + toJSON (AutoExpandReplicas x) = oPath ("index" :| ["auto_expand_replicas"]) x + toJSON (RefreshInterval x) = oPath ("index" :| ["refresh_interval"]) (NominalDiffTimeJSON x) + toJSON (IndexConcurrency x) = oPath ("index" :| ["concurrency"]) x + toJSON (FailOnMergeFailure x) = oPath ("index" :| ["fail_on_merge_failure"]) x + toJSON (TranslogFlushThresholdOps x) = oPath ("index" :| ["translog", "flush_threshold_ops"]) x + toJSON (TranslogFlushThresholdSize x) = oPath ("index" :| ["translog", "flush_threshold_size"]) x + toJSON (TranslogFlushThresholdPeriod x) = oPath ("index" :| ["translog", "flush_threshold_period"]) (NominalDiffTimeJSON x) + toJSON (TranslogDisableFlush x) = oPath ("index" :| ["translog", "disable_flush"]) x + toJSON (CacheFilterMaxSize x) = oPath ("index" :| ["cache", "filter", "max_size"]) x + toJSON (CacheFilterExpire x) = oPath ("index" :| ["cache", "filter", "expire"]) (NominalDiffTimeJSON <$> x) + toJSON (GatewaySnapshotInterval x) = oPath ("index" :| ["gateway", "snapshot_interval"]) (NominalDiffTimeJSON x) + toJSON (RoutingAllocationInclude fs) = oPath ("index" :| ["routing", "allocation", "include"]) (attrFilterJSON fs) + toJSON (RoutingAllocationExclude fs) = oPath ("index" :| ["routing", "allocation", "exclude"]) (attrFilterJSON fs) + toJSON (RoutingAllocationRequire fs) = oPath ("index" :| ["routing", "allocation", "require"]) (attrFilterJSON fs) + toJSON (RoutingAllocationEnable x) = oPath ("index" :| ["routing", "allocation", "enable"]) x + toJSON (RoutingAllocationShardsPerNode x) = oPath ("index" :| ["routing", "allocation", "total_shards_per_node"]) x + toJSON (RecoveryInitialShards x) = oPath ("index" :| ["recovery", "initial_shards"]) x + toJSON (GCDeletes x) = oPath ("index" :| ["gc_deletes"]) (NominalDiffTimeJSON x) + toJSON (TTLDisablePurge x) = oPath ("index" :| ["ttl", "disable_purge"]) x + toJSON (TranslogFSType x) = oPath ("index" :| ["translog", "fs", "type"]) x + toJSON (CompressionSetting x) = oPath ("index" :| ["codec"]) x + toJSON (IndexCompoundFormat x) = oPath ("index" :| ["compound_format"]) x + toJSON (IndexCompoundOnFlush x) = oPath ("index" :| ["compound_on_flush"]) x + toJSON (WarmerEnabled x) = oPath ("index" :| ["warmer", "enabled"]) x + toJSON (BlocksReadOnly x) = oPath ("index" :| ["blocks", "read_only"]) x + toJSON (BlocksRead x) = oPath ("index" :| ["blocks", "read"]) x + toJSON (BlocksWrite x) = oPath ("index" :| ["blocks", "write"]) x + toJSON (BlocksMetaData x) = oPath ("index" :| ["blocks", "metadata"]) x + toJSON (MappingTotalFieldsLimit x) = oPath ("index" :| ["mapping", "total_fields", "limit"]) x + toJSON (AnalysisSetting x) = oPath ("index" :| ["analysis"]) x + toJSON (UnassignedNodeLeftDelayedTimeout x) = oPath ("index" :| ["unassigned", "node_left", "delayed_timeout"]) (NominalDiffTimeJSON x) + toJSON (IndexSearchIdleAfter x) = oPath ("index" :| ["search", "idle", "after"]) x + toJSON (RequestsCacheEnable x) = oPath ("index" :| ["requests", "cache", "enable"]) x + toJSON (IndexHidden x) = oPath ("index" :| ["hidden"]) x + toJSON (BlocksReadOnlyAllowDelete x) = oPath ("index" :| ["blocks", "read_only_allow_delete"]) x + toJSON (IndexPriority x) = oPath ("index" :| ["priority"]) x + toJSON (RoutingAllocationDiskWatermarkLow x) = oPath ("index" :| ["routing", "allocation", "disk", "watermark", "low"]) x + toJSON (RoutingAllocationDiskWatermarkHigh x) = oPath ("index" :| ["routing", "allocation", "disk", "watermark", "high"]) x + toJSON (RoutingAllocationDiskWatermarkFloodStage x) = oPath ("index" :| ["routing", "allocation", "disk", "watermark", "flood_stage"]) x + toJSON (SearchSlowlogThresholdQueryWarn x) = oPath ("index" :| ["search", "slowlog", "threshold", "query", "warn"]) x + toJSON (SearchSlowlogThresholdQueryInfo x) = oPath ("index" :| ["search", "slowlog", "threshold", "query", "info"]) x + toJSON (SearchSlowlogThresholdQueryDebug x) = oPath ("index" :| ["search", "slowlog", "threshold", "query", "debug"]) x + toJSON (SearchSlowlogThresholdQueryTrace x) = oPath ("index" :| ["search", "slowlog", "threshold", "query", "trace"]) x + toJSON (SearchSlowlogThresholdFetchWarn x) = oPath ("index" :| ["search", "slowlog", "threshold", "fetch", "warn"]) x + toJSON (SearchSlowlogThresholdFetchInfo x) = oPath ("index" :| ["search", "slowlog", "threshold", "fetch", "info"]) x + toJSON (SearchSlowlogThresholdFetchDebug x) = oPath ("index" :| ["search", "slowlog", "threshold", "fetch", "debug"]) x + toJSON (SearchSlowlogThresholdFetchTrace x) = oPath ("index" :| ["search", "slowlog", "threshold", "fetch", "trace"]) x + toJSON (IndexingSlowlogThresholdIndexWarn x) = oPath ("index" :| ["indexing", "slowlog", "threshold", "index", "warn"]) x + toJSON (IndexingSlowlogThresholdIndexInfo x) = oPath ("index" :| ["indexing", "slowlog", "threshold", "index", "info"]) x + toJSON (IndexingSlowlogThresholdIndexDebug x) = oPath ("index" :| ["indexing", "slowlog", "threshold", "index", "debug"]) x + toJSON (IndexingSlowlogThresholdIndexTrace x) = oPath ("index" :| ["indexing", "slowlog", "threshold", "index", "trace"]) x + +instance FromJSON UpdatableIndexSetting where + parseJSON = withObject "UpdatableIndexSetting" parse + where + parse o = + numberOfReplicas + `taggedAt` ["index", "number_of_replicas"] + <|> autoExpandReplicas + `taggedAt` ["index", "auto_expand_replicas"] + <|> refreshInterval + `taggedAt` ["index", "refresh_interval"] + <|> indexConcurrency + `taggedAt` ["index", "concurrency"] + <|> failOnMergeFailure + `taggedAt` ["index", "fail_on_merge_failure"] + <|> translogFlushThresholdOps + `taggedAt` ["index", "translog", "flush_threshold_ops"] + <|> translogFlushThresholdSize + `taggedAt` ["index", "translog", "flush_threshold_size"] + <|> translogFlushThresholdPeriod + `taggedAt` ["index", "translog", "flush_threshold_period"] + <|> translogDisableFlush + `taggedAt` ["index", "translog", "disable_flush"] + <|> cacheFilterMaxSize + `taggedAt` ["index", "cache", "filter", "max_size"] + <|> cacheFilterExpire + `taggedAt` ["index", "cache", "filter", "expire"] + <|> gatewaySnapshotInterval + `taggedAt` ["index", "gateway", "snapshot_interval"] + <|> routingAllocationInclude + `taggedAt` ["index", "routing", "allocation", "include"] + <|> routingAllocationExclude + `taggedAt` ["index", "routing", "allocation", "exclude"] + <|> routingAllocationRequire + `taggedAt` ["index", "routing", "allocation", "require"] + <|> routingAllocationEnable + `taggedAt` ["index", "routing", "allocation", "enable"] + <|> routingAllocationShardsPerNode + `taggedAt` ["index", "routing", "allocation", "total_shards_per_node"] + <|> recoveryInitialShards + `taggedAt` ["index", "recovery", "initial_shards"] + <|> gcDeletes + `taggedAt` ["index", "gc_deletes"] + <|> ttlDisablePurge + `taggedAt` ["index", "ttl", "disable_purge"] + <|> translogFSType + `taggedAt` ["index", "translog", "fs", "type"] + <|> compressionSetting + `taggedAt` ["index", "codec"] + <|> compoundFormat + `taggedAt` ["index", "compound_format"] + <|> compoundOnFlush + `taggedAt` ["index", "compound_on_flush"] + <|> warmerEnabled + `taggedAt` ["index", "warmer", "enabled"] + <|> blocksReadOnly + `taggedAt` ["index", "blocks", "read_only"] + <|> blocksRead + `taggedAt` ["index", "blocks", "read"] + <|> blocksWrite + `taggedAt` ["index", "blocks", "write"] + <|> blocksMetaData + `taggedAt` ["index", "blocks", "metadata"] + <|> mappingTotalFieldsLimit + `taggedAt` ["index", "mapping", "total_fields", "limit"] + <|> analysisSetting + `taggedAt` ["index", "analysis"] + <|> unassignedNodeLeftDelayedTimeout + `taggedAt` ["index", "unassigned", "node_left", "delayed_timeout"] + <|> indexSearchIdleAfter + `taggedAt` ["index", "search", "idle", "after"] + <|> requestsCacheEnable + `taggedAt` ["index", "requests", "cache", "enable"] + <|> indexHidden + `taggedAt` ["index", "hidden"] + <|> blocksReadOnlyAllowDelete + `taggedAt` ["index", "blocks", "read_only_allow_delete"] + <|> indexPriority + `taggedAt` ["index", "priority"] + <|> routingAllocationDiskWatermarkLow + `taggedAt` ["index", "routing", "allocation", "disk", "watermark", "low"] + <|> routingAllocationDiskWatermarkHigh + `taggedAt` ["index", "routing", "allocation", "disk", "watermark", "high"] + <|> routingAllocationDiskWatermarkFloodStage + `taggedAt` ["index", "routing", "allocation", "disk", "watermark", "flood_stage"] + <|> searchSlowlogThresholdQueryWarn + `taggedAt` ["index", "search", "slowlog", "threshold", "query", "warn"] + <|> searchSlowlogThresholdQueryInfo + `taggedAt` ["index", "search", "slowlog", "threshold", "query", "info"] + <|> searchSlowlogThresholdQueryDebug + `taggedAt` ["index", "search", "slowlog", "threshold", "query", "debug"] + <|> searchSlowlogThresholdQueryTrace + `taggedAt` ["index", "search", "slowlog", "threshold", "query", "trace"] + <|> searchSlowlogThresholdFetchWarn + `taggedAt` ["index", "search", "slowlog", "threshold", "fetch", "warn"] + <|> searchSlowlogThresholdFetchInfo + `taggedAt` ["index", "search", "slowlog", "threshold", "fetch", "info"] + <|> searchSlowlogThresholdFetchDebug + `taggedAt` ["index", "search", "slowlog", "threshold", "fetch", "debug"] + <|> searchSlowlogThresholdFetchTrace + `taggedAt` ["index", "search", "slowlog", "threshold", "fetch", "trace"] + <|> indexingSlowlogThresholdIndexWarn + `taggedAt` ["index", "indexing", "slowlog", "threshold", "index", "warn"] + <|> indexingSlowlogThresholdIndexInfo + `taggedAt` ["index", "indexing", "slowlog", "threshold", "index", "info"] + <|> indexingSlowlogThresholdIndexDebug + `taggedAt` ["index", "indexing", "slowlog", "threshold", "index", "debug"] + <|> indexingSlowlogThresholdIndexTrace + `taggedAt` ["index", "indexing", "slowlog", "threshold", "index", "trace"] + where + taggedAt :: (FromJSON a) => (a -> Parser b) -> [Key] -> Parser b + taggedAt f ks = taggedAt' f (Object o) ks + taggedAt' f v [] = + f =<< (parseJSON v <|> parseJSON (unStringlyTypeJSON v)) + taggedAt' f v (k : ks) = + withObject + "Object" + ( \o -> do + v' <- o .: k + taggedAt' f v' ks + ) + v + numberOfReplicas = pure . NumberOfReplicas + autoExpandReplicas = pure . AutoExpandReplicas + refreshInterval = pure . RefreshInterval . ndtJSON + indexConcurrency = pure . IndexConcurrency + failOnMergeFailure = pure . FailOnMergeFailure + translogFlushThresholdOps = pure . TranslogFlushThresholdOps + translogFlushThresholdSize = pure . TranslogFlushThresholdSize + translogFlushThresholdPeriod = pure . TranslogFlushThresholdPeriod . ndtJSON + translogDisableFlush = pure . TranslogDisableFlush + cacheFilterMaxSize = pure . CacheFilterMaxSize + cacheFilterExpire = pure . CacheFilterExpire . fmap ndtJSON + gatewaySnapshotInterval = pure . GatewaySnapshotInterval . ndtJSON + routingAllocationInclude = fmap RoutingAllocationInclude . parseAttrFilter + routingAllocationExclude = fmap RoutingAllocationExclude . parseAttrFilter + routingAllocationRequire = fmap RoutingAllocationRequire . parseAttrFilter + routingAllocationEnable = pure . RoutingAllocationEnable + routingAllocationShardsPerNode = pure . RoutingAllocationShardsPerNode + recoveryInitialShards = pure . RecoveryInitialShards + gcDeletes = pure . GCDeletes . ndtJSON + ttlDisablePurge = pure . TTLDisablePurge + translogFSType = pure . TranslogFSType + compressionSetting = pure . CompressionSetting + compoundFormat = pure . IndexCompoundFormat + compoundOnFlush = pure . IndexCompoundOnFlush + warmerEnabled = pure . WarmerEnabled + blocksReadOnly = pure . BlocksReadOnly + blocksRead = pure . BlocksRead + blocksWrite = pure . BlocksWrite + blocksMetaData = pure . BlocksMetaData + mappingTotalFieldsLimit = pure . MappingTotalFieldsLimit + analysisSetting = pure . AnalysisSetting + unassignedNodeLeftDelayedTimeout = pure . UnassignedNodeLeftDelayedTimeout . ndtJSON + indexSearchIdleAfter = pure . IndexSearchIdleAfter + requestsCacheEnable = pure . RequestsCacheEnable + indexHidden = pure . IndexHidden + blocksReadOnlyAllowDelete = pure . BlocksReadOnlyAllowDelete + indexPriority = pure . IndexPriority + routingAllocationDiskWatermarkLow = pure . RoutingAllocationDiskWatermarkLow + routingAllocationDiskWatermarkHigh = pure . RoutingAllocationDiskWatermarkHigh + routingAllocationDiskWatermarkFloodStage = pure . RoutingAllocationDiskWatermarkFloodStage + searchSlowlogThresholdQueryWarn = pure . SearchSlowlogThresholdQueryWarn + searchSlowlogThresholdQueryInfo = pure . SearchSlowlogThresholdQueryInfo + searchSlowlogThresholdQueryDebug = pure . SearchSlowlogThresholdQueryDebug + searchSlowlogThresholdQueryTrace = pure . SearchSlowlogThresholdQueryTrace + searchSlowlogThresholdFetchWarn = pure . SearchSlowlogThresholdFetchWarn + searchSlowlogThresholdFetchInfo = pure . SearchSlowlogThresholdFetchInfo + searchSlowlogThresholdFetchDebug = pure . SearchSlowlogThresholdFetchDebug + searchSlowlogThresholdFetchTrace = pure . SearchSlowlogThresholdFetchTrace + indexingSlowlogThresholdIndexWarn = pure . IndexingSlowlogThresholdIndexWarn + indexingSlowlogThresholdIndexInfo = pure . IndexingSlowlogThresholdIndexInfo + indexingSlowlogThresholdIndexDebug = pure . IndexingSlowlogThresholdIndexDebug + indexingSlowlogThresholdIndexTrace = pure . IndexingSlowlogThresholdIndexTrace + +data ReplicaBounds + = ReplicasBounded Int Int + | ReplicasLowerBounded Int + | ReplicasUnbounded + deriving stock (Eq, Show) + +instance ToJSON ReplicaBounds where + toJSON (ReplicasBounded a b) = String (showText a <> "-" <> showText b) + toJSON (ReplicasLowerBounded a) = String (showText a <> "-all") + toJSON ReplicasUnbounded = Bool False + +instance FromJSON ReplicaBounds where + parseJSON v = + withText "ReplicaBounds" parseText v + <|> withBool "ReplicaBounds" parseBool v + where + parseText t = case T.splitOn "-" t of + [a, "all"] -> ReplicasLowerBounded <$> parseReadText a + [a, b] -> + ReplicasBounded + <$> parseReadText a + <*> parseReadText b + _ -> fail ("Could not parse ReplicaBounds: " <> show t) + parseBool False = pure ReplicasUnbounded + parseBool _ = fail "ReplicasUnbounded cannot be represented with True" + +data Compression + = -- | Compress with LZ4 + CompressionDefault + | -- | Compress with DEFLATE. Elastic + -- + -- that this can reduce disk use by 15%-25%. + CompressionBest + | -- | ZSTD compression. Native on OpenSearch (accepted as the + -- @index.codec@ value @"zstd"@ from OpenSearch 2.4); on Elasticsearch + -- the @best_compression@ codec already uses ZSTD internally, so this + -- constructor is primarily of interest for OpenSearch backends. + CompressionZstd + deriving stock (Eq, Show, Generic) + +instance ToJSON Compression where + toJSON x = case x of + CompressionDefault -> toJSON ("default" :: Text) + CompressionBest -> toJSON ("best_compression" :: Text) + CompressionZstd -> toJSON ("zstd" :: Text) + +instance FromJSON Compression where + parseJSON = withText "Compression" $ \t -> case t of + "default" -> return CompressionDefault + "best_compression" -> return CompressionBest + "zstd" -> return CompressionZstd + _ -> fail ("invalid compression codec: " <> show t) + +data FSType + = FSSimple + | FSBuffered + deriving stock (Eq, Show, Generic) + +instance ToJSON FSType where + toJSON FSSimple = "simple" + toJSON FSBuffered = "buffered" + +instance FromJSON FSType where + parseJSON = withText "FSType" parse + where + parse "simple" = pure FSSimple + parse "buffered" = pure FSBuffered + parse t = fail ("Invalid FSType: " <> show t) + +data CompoundFormat + = CompoundFileFormat Bool + | -- | percentage between 0 and 1 where 0 is false, 1 is true + MergeSegmentVsTotalIndex Double + deriving stock (Eq, Show, Generic) + +instance ToJSON CompoundFormat where + toJSON (CompoundFileFormat x) = Bool x + toJSON (MergeSegmentVsTotalIndex x) = toJSON x + +instance FromJSON CompoundFormat where + parseJSON v = + CompoundFileFormat + <$> parseJSON v + <|> MergeSegmentVsTotalIndex + <$> parseJSON v + +newtype NominalDiffTimeJSON = NominalDiffTimeJSON {ndtJSON :: NominalDiffTime} + +instance ToJSON NominalDiffTimeJSON where + toJSON (NominalDiffTimeJSON t) = String (showText (round t :: Integer) <> "s") + +instance FromJSON NominalDiffTimeJSON where + parseJSON = withText "NominalDiffTime" parse + where + parse t = case T.takeEnd 1 t of + "s" -> NominalDiffTimeJSON . fromInteger <$> parseReadText (T.dropEnd 1 t) + _ -> fail "Invalid or missing NominalDiffTime unit (expected s)" + +data IndexSettingsSummary = IndexSettingsSummary + { sSummaryIndexName :: IndexName, + sSummaryFixedSettings :: IndexSettings, + sSummaryUpdateable :: [UpdatableIndexSetting] + } + deriving stock (Eq, Show) + +indexSettingsSummarySummaryIndexNameLens :: Lens' IndexSettingsSummary IndexName +indexSettingsSummarySummaryIndexNameLens = lens sSummaryIndexName (\x y -> x {sSummaryIndexName = y}) + +indexSettingsSummarySummaryFixedSettingsLens :: Lens' IndexSettingsSummary IndexSettings +indexSettingsSummarySummaryFixedSettingsLens = lens sSummaryFixedSettings (\x y -> x {sSummaryFixedSettings = y}) + +indexSettingsSummarySummaryUpdateableLens :: Lens' IndexSettingsSummary [UpdatableIndexSetting] +indexSettingsSummarySummaryUpdateableLens = lens sSummaryUpdateable (\x y -> x {sSummaryUpdateable = y}) + +parseSettings :: Object -> Parser [UpdatableIndexSetting] +parseSettings o = do + o' <- o .: "index" + -- slice the index object into singleton hashmaps and try to parse each + parses <- forM (HM.toList o') $ \(k, v) -> do + -- Each (k,v) is presented to the parser in two shapes: the + -- singleton at the root ({k:v}) and the singleton nested under + -- "index" ({"index":{k:v}}). The latter is the form our ToJSON + -- produces and ES round-trips; the former is retained for + -- backward compatibility with older callers that may have + -- built settings JSON by hand without the index wrapper. + let atRoot = Object (X.singleton k v) + let atIndex = Object (X.singleton "index" atRoot) + optional (parseJSON atRoot <|> parseJSON atIndex) + return (catMaybes parses) + +-- | Classifies 'UpdatableIndexSetting' constructors that should be +-- dropped from a parsed settings list because they are redundant with +-- the fixed 'IndexSettings' fields. Currently filters +-- 'NumberOfReplicas', which is already carried by 'indexReplicas'. +redundant :: UpdatableIndexSetting -> Bool +redundant (NumberOfReplicas _) = True +redundant _ = False + +instance FromJSON IndexSettingsSummary where + parseJSON = withObject "IndexSettingsSummary" parse + where + parse o = case X.toList o of + [(ixn, v@(Object o'))] -> + IndexSettingsSummary + <$> parseJSON (toJSON ixn) + <*> parseJSON v + <*> (fmap (filter (not . redundant)) . parseSettings =<< o' .: "settings") + _ -> fail "Expected single-key object with index name" + +-- | Response of the @GET /{index}@ (get-index) endpoint, which returns +-- the @aliases@, @mappings@ and @settings@ of one index in a single +-- envelope. The server wraps the payload in a single-key object keyed +-- by the index name — the same shape as 'IndexSettingsSummary' — but +-- additionally surfaces aliases and mappings alongside the settings. +-- +-- +data IndexInfo = IndexInfo + { iiIndexName :: IndexName, + iiAliases :: [IndexAliasSummary], + -- | The @mappings@ block is kept as an opaque 'Value' for now, + -- matching the existing 'IndexTemplate' pattern; a typed Mapping + -- model is tracked as a separate epic. + iiMappings :: Value, + iiFixedSettings :: IndexSettings, + iiUpdateableSettings :: [UpdatableIndexSetting] + } + deriving stock (Eq, Show) + +instance FromJSON IndexInfo where + parseJSON = withObject "IndexInfo" parse + where + parse o = case X.toList o of + [(ixn, Object o')] -> do + indexName <- parseJSON (toJSON ixn) + aliases <- parseIndexAliases indexName o' + mappings <- o' .:? "mappings" .!= Null + fixed <- parseJSON (Object o') + upd <- fmap (filter (not . redundant)) . parseSettings =<< o' .: "settings" + pure $ IndexInfo indexName aliases mappings fixed upd + _ -> fail "Expected single-key object with index name" + +-- | Parse the @aliases@ sub-object of a get-index response into a list +-- of 'IndexAliasSummary'. Mirrors the alias-extraction logic of +-- 'IndexAliasesSummary''s 'FromJSON' instance, but operates on the +-- already-unwrapped inner object. +parseIndexAliases :: IndexName -> Object -> Parser [IndexAliasSummary] +parseIndexAliases indexName o = do + mAliases <- o .:? "aliases" + case mAliases of + Nothing -> pure [] + Just aliases -> + forM (HM.toList aliases) $ \(aName, v) -> + IndexAliasSummary (IndexAlias indexName (IndexAliasName aName)) <$> parseJSON v + +iiIndexNameLens :: Lens' IndexInfo IndexName +iiIndexNameLens = lens iiIndexName (\x y -> x {iiIndexName = y}) + +iiAliasesLens :: Lens' IndexInfo [IndexAliasSummary] +iiAliasesLens = lens iiAliases (\x y -> x {iiAliases = y}) + +iiMappingsLens :: Lens' IndexInfo Value +iiMappingsLens = lens iiMappings (\x y -> x {iiMappings = y}) + +iiFixedSettingsLens :: Lens' IndexInfo IndexSettings +iiFixedSettingsLens = lens iiFixedSettings (\x y -> x {iiFixedSettings = y}) + +iiUpdateableSettingsLens :: Lens' IndexInfo [UpdatableIndexSetting] +iiUpdateableSettingsLens = lens iiUpdateableSettings (\x y -> x {iiUpdateableSettings = y}) + +-- | 'OpenCloseIndex' is a sum type for opening and closing indices. +-- +-- +data OpenCloseIndex = OpenIndex | CloseIndex deriving stock (Eq, Show) + +-- | The block kind passed as the last path segment of +-- @PUT /\/_block/\@ +-- (, +-- ). +-- +-- Each constructor maps to a documented wire string rendered by +-- 'indexBlockText'. This is the canonical way to apply an index block. +-- The dedicated @_block@ endpoint is add-only on every supported +-- backend (ES7+\/OS1+), so removal routes through +-- @PUT /\/_settings@ with the matching 'UpdatableIndexSetting' +-- via 'indexBlockToSetting' — see +-- 'Database.Bloodhound.Common.Requests.removeIndexBlock'. The +-- 'BlocksWrite', 'BlocksRead', 'BlocksReadOnly', 'BlocksMetaData', +-- 'BlocksReadOnlyAllowDelete' 'ToJSON' renderers emit the +-- @index.blocks.X@ form ES requires (fixed in bloodhound-442). +data IndexBlock + = -- | @write@ — disable data write operations (matches 'BlocksWrite'). + IndexBlockWrite + | -- | @read@ — disable data read operations (matches 'BlocksRead'). + IndexBlockRead + | -- | @read_only@ — disable both data read and write operations + -- (matches 'BlocksReadOnly'). + IndexBlockReadOnly + | -- | @metadata@ — disable metadata operations (matches 'BlocksMetaData'). + IndexBlockMetadata + deriving stock (Eq, Show) + +-- | Wire string for an 'IndexBlock'. Single source of truth used by +-- 'Database.Bloodhound.Common.Requests.addIndexBlock' to render the +-- trailing path segment of @PUT /\/_block/\@. +indexBlockText :: IndexBlock -> Text +indexBlockText IndexBlockWrite = "write" +indexBlockText IndexBlockRead = "read" +indexBlockText IndexBlockReadOnly = "read_only" +indexBlockText IndexBlockMetadata = "metadata" + +-- | Maps an 'IndexBlock' to the matching 'UpdatableIndexSetting' with +-- the supplied 'Bool' flag. Used by +-- 'Database.Bloodhound.Common.Requests.removeIndexBlock' to clear a +-- block via @PUT /\/_settings@: the dedicated +-- @PUT /\/_block/\@ endpoint is add-only on every +-- supported backend (ES7+\/OS1+), so removal routes through +-- @_settings@ with the corresponding @BlocksX False@. +indexBlockToSetting :: Bool -> IndexBlock -> UpdatableIndexSetting +indexBlockToSetting b IndexBlockWrite = BlocksWrite b +indexBlockToSetting b IndexBlockRead = BlocksRead b +indexBlockToSetting b IndexBlockReadOnly = BlocksReadOnly b +indexBlockToSetting b IndexBlockMetadata = BlocksMetaData b + +-- | Maps an 'IndexBlock' to its matching 'UpdatableIndexSetting' with +-- the block disabled, suitable for 'updateIndexSettings' to clear a +-- block applied by 'Database.Bloodhound.Common.Requests.addIndexBlock' +-- or any other source. The dedicated @DELETE /\/_block/\@ +-- endpoint ('indices.remove_block', ES 9.1+) is the natural counterpart +-- to 'Database.Bloodhound.Common.Requests.addIndexBlock' but does not +-- exist on ES 7\/8 or OpenSearch, so the portable teardown path is +-- 'updateIndexSettings' with this mapping. The 'ToJSON' renderers for +-- the 'BlocksX' constructors emit the @index.blocks.X@ shape ES +-- requires (fixed in bloodhound-442). +indexBlockToUpdatable :: IndexBlock -> UpdatableIndexSetting +indexBlockToUpdatable IndexBlockWrite = BlocksWrite False +indexBlockToUpdatable IndexBlockRead = BlocksRead False +indexBlockToUpdatable IndexBlockReadOnly = BlocksReadOnly False +indexBlockToUpdatable IndexBlockMetadata = BlocksMetaData False + +data FieldType + = GeoPointType + | GeoShapeType + | FloatType + | IntegerType + | LongType + | ShortType + | ByteType + deriving stock (Eq, Show) + +newtype FieldDefinition = FieldDefinition + { fieldType :: FieldType + } + deriving stock (Eq, Show) + +fieldDefinitionTypeLens :: Lens' FieldDefinition FieldType +fieldDefinitionTypeLens = lens fieldType (\x y -> x {fieldType = y}) + +-- | An 'IndexTemplate' defines a template that will automatically be +-- applied to new indices created. The templates include both +-- 'IndexSettings' and mappings, and a simple 'IndexPattern' that +-- controls if the template will be applied to the index created. +-- Specify mappings as follows: @[toJSON TweetMapping, ...]@ +-- +-- https://www.elastic.co/guide/en/elasticsearch/reference/7.17/indices-templates.html +data IndexTemplate = IndexTemplate + { templatePatterns :: [IndexPattern], + templateSettings :: Maybe IndexSettings, + templateMappings :: Value + } + +instance ToJSON IndexTemplate where + toJSON (IndexTemplate p s m) = + merge + ( object + [ "index_patterns" .= p, + "mappings" .= m + ] + ) + (toJSON s) + where + merge (Object o1) (Object o2) = toJSON $ X.union o1 o2 + merge o Null = o + merge _ _ = undefined + +indexTemplatePatternsLens :: Lens' IndexTemplate [IndexPattern] +indexTemplatePatternsLens = lens templatePatterns (\x y -> x {templatePatterns = y}) + +indexTemplateSettingsLens :: Lens' IndexTemplate (Maybe IndexSettings) +indexTemplateSettingsLens = lens templateSettings (\x y -> x {templateSettings = y}) + +indexTemplateMappingsLens :: Lens' IndexTemplate Value +indexTemplateMappingsLens = lens templateMappings (\x y -> x {templateMappings = y}) + +-- $composableTemplates +-- +-- /Composable index templates/ (introduced in Elasticsearch 7.8 and +-- available in OpenSearch 2.x) are the recommended replacement for the +-- legacy 'IndexTemplate' \/ @PUT /_template@ API. They are composed of +-- an optional 'ComposableTemplateContent' (settings, mappings and +-- aliases that get applied to matching indices) plus optional metadata +-- (@priority@, @version@, @composed_of@, @allow_auto_create@). +-- +-- See +-- +-- and +-- . + +-- | Inner @template@ object of a 'ComposableTemplate'. Carries the +-- @settings@, @mappings@ and @aliases@ that Elasticsearch applies to +-- every new index matching the surrounding 'ComposableTemplate'\'s +-- @index_patterns@. Every field is optional — omitting one leaves the +-- server free to derive it from a component template or its defaults — +-- and each is encoded as a raw JSON 'Value' so callers can express +-- arbitrary settings (not just the typed subset modelled by +-- 'IndexSettings'), exactly like 'CreateIndexOptions' does for +-- @PUT /{index}@. +data ComposableTemplateContent = ComposableTemplateContent + { -- | @settings@ body field. Note that the composable template's + -- @settings@ object is /flat/ — e.g. + -- @{"number_of_shards": 1, "index.refresh_interval": "1s"}@ — so + -- passing 'toJSON' 'defaultIndexSettings' is /wrong/ (it produces + -- the wrapped @{"settings":{"index":{...}}}@ shape used by + -- @PUT /{index}@). Hand-roll an 'Object' with the flat keys + -- instead, exactly as for 'CreateIndexOptions.cioSettings' on + -- OpenSearch clusters. + ctcSettings :: Maybe Value, + -- | @mappings@ body field. Pass any 'ToJSON'able mapping blob, e.g. + -- @'toJSON' TweetMapping@. + ctcMappings :: Maybe Value, + -- | @aliases@ body field. Each key is an alias name; each value is + -- an (optionally empty) alias body. + ctcAliases :: Maybe Object + } + deriving stock (Eq, Show) + +instance ToJSON ComposableTemplateContent where + toJSON ComposableTemplateContent {..} = + omitNulls + [ "settings" .= ctcSettings, + "mappings" .= ctcMappings, + "aliases" .= ctcAliases + ] + +instance FromJSON ComposableTemplateContent where + parseJSON = withObject "ComposableTemplateContent" $ \o -> + ComposableTemplateContent + <$> o .:? "settings" + <*> o .:? "mappings" + <*> o .:? "aliases" + +ctcSettingsLens :: Lens' ComposableTemplateContent (Maybe Value) +ctcSettingsLens = lens ctcSettings (\x y -> x {ctcSettings = y}) + +ctcMappingsLens :: Lens' ComposableTemplateContent (Maybe Value) +ctcMappingsLens = lens ctcMappings (\x y -> x {ctcMappings = y}) + +ctcAliasesLens :: Lens' ComposableTemplateContent (Maybe Object) +ctcAliasesLens = lens ctcAliases (\x y -> x {ctcAliases = y}) + +-- | Request body for @PUT /_index_template/{name}@. The @index_patterns@ +-- field is required by the server; the 'ctTemplate' content and every +-- metadata field is optional and emitted only when present and +-- non-empty (via 'omitNulls', so 'Nothing' /and/ @'Just' []@ both render +-- to no field), so a minimal 'ComposableTemplate' with just +-- @'ctIndexPatterns' = [...]@ produces @{\"index_patterns\": [...]}@ on +-- the wire. +data ComposableTemplate = ComposableTemplate + { -- | @index_patterns@. One or more glob patterns matched against new + -- index names. Reuses the 'IndexPattern' newtype from the legacy + -- 'IndexTemplate' API. + ctIndexPatterns :: [IndexPattern], + -- | @template@. The settings \/ mappings \/ aliases applied to + -- matching indices. 'Nothing' is unusual but valid (a template that + -- only contributes @composed_of@). + ctTemplate :: Maybe ComposableTemplateContent, + -- | @priority@. When several templates match an index, the highest + -- priority wins and its @template@ (merged with lower-priority + -- templates that also matched) is applied. + ctPriority :: Maybe Int, + -- | @version@. Opaque version number for external tracking. + ctVersion :: Maybe Int, + -- | @composed_of@. Names of component templates (created via + -- @PUT /_component_template/{name}@) whose content is merged into + -- this template, in the given order. + ctComposedOf :: Maybe [TemplateName], + -- | @allow_auto_create@. Overrides the cluster-wide + -- @action.auto_create_index@ setting for indices matched by this + -- template. + ctAllowAutoCreate :: Maybe Bool + } + deriving stock (Eq, Show) + +instance ToJSON ComposableTemplate where + toJSON ComposableTemplate {..} = + omitNulls $ + [ "index_patterns" .= ctIndexPatterns, + "template" .= ctTemplate, + "priority" .= ctPriority, + "version" .= ctVersion, + "composed_of" .= ctComposedOf, + "allow_auto_create" .= ctAllowAutoCreate + ] + +instance FromJSON ComposableTemplate where + parseJSON = withObject "ComposableTemplate" $ \o -> + ComposableTemplate + <$> o .:? "index_patterns" .!= [] + <*> o .:? "template" + <*> o .:? "priority" + <*> o .:? "version" + <*> o .:? "composed_of" + <*> o .:? "allow_auto_create" + +ctIndexPatternsLens :: Lens' ComposableTemplate [IndexPattern] +ctIndexPatternsLens = lens ctIndexPatterns (\x y -> x {ctIndexPatterns = y}) + +ctTemplateLens :: Lens' ComposableTemplate (Maybe ComposableTemplateContent) +ctTemplateLens = lens ctTemplate (\x y -> x {ctTemplate = y}) + +ctPriorityLens :: Lens' ComposableTemplate (Maybe Int) +ctPriorityLens = lens ctPriority (\x y -> x {ctPriority = y}) + +ctVersionLens :: Lens' ComposableTemplate (Maybe Int) +ctVersionLens = lens ctVersion (\x y -> x {ctVersion = y}) + +ctComposedOfLens :: Lens' ComposableTemplate (Maybe [TemplateName]) +ctComposedOfLens = lens ctComposedOf (\x y -> x {ctComposedOf = y}) + +ctAllowAutoCreateLens :: Lens' ComposableTemplate (Maybe Bool) +ctAllowAutoCreateLens = lens ctAllowAutoCreate (\x y -> x {ctAllowAutoCreate = y}) + +-- $componentTemplates +-- +-- /Component templates/ (introduced in Elasticsearch 7.8 and available in +-- OpenSearch 2.x) are reusable building blocks that can be composed into +-- composable index templates (see 'ComposableTemplate'\'s @composed_of@ +-- field). A component template carries the same +-- 'ComposableTemplateContent' shape (settings, mappings, aliases) as a +-- composable template, plus optional metadata (@version@, @_meta@, +-- @deprecated@). It has no @index_patterns@ of its own — it is only +-- applied when referenced by a composable template. +-- +-- See +-- +-- and +-- . + +-- | Request body for @PUT /_component_template/{name}@. The +-- 'cpTemplate' content is the same 'ComposableTemplateContent' shape +-- used by 'ComposableTemplate' (settings \/ mappings \/ aliases), reused +-- here verbatim — the inner @template@ object is byte-identical between +-- the two endpoints. Every field is optional and emitted only when +-- present (via 'omitNulls'), so a minimal 'ComponentTemplate' with +-- 'Nothing' everywhere produces @{}@ on the wire, which the server +-- accepts as an empty component template. +data ComponentTemplate = ComponentTemplate + { -- | @template@. The settings \/ mappings \/ aliases contributed by + -- this component template. 'Nothing' is unusual but valid (a + -- component template that only carries metadata). + cpTemplate :: Maybe ComposableTemplateContent, + -- | @version@. Opaque version number for external tracking. Used by + -- built-in templates (e.g. @logs-settings@) for upgrade ordering. + cpVersion :: Maybe Int, + -- | @_meta@. Optional user metadata, stored in the cluster state. + -- May have any contents; keeping it short is preferable. + cpMeta :: Maybe Object, + -- | @deprecated@. Marks this component template as deprecated. + -- Creating or updating a non-deprecated template that composes a + -- deprecated component emits a deprecation warning. + cpDeprecated :: Maybe Bool + } + deriving stock (Eq, Show) + +instance ToJSON ComponentTemplate where + toJSON ComponentTemplate {..} = + omitNulls + [ "template" .= cpTemplate, + "version" .= cpVersion, + "_meta" .= cpMeta, + "deprecated" .= cpDeprecated + ] + +instance FromJSON ComponentTemplate where + parseJSON = withObject "ComponentTemplate" $ \o -> + ComponentTemplate + <$> o .:? "template" + <*> o .:? "version" + <*> o .:? "_meta" + <*> o .:? "deprecated" + +cpTemplateLens :: Lens' ComponentTemplate (Maybe ComposableTemplateContent) +cpTemplateLens = lens cpTemplate (\x y -> x {cpTemplate = y}) + +cpVersionLens :: Lens' ComponentTemplate (Maybe Int) +cpVersionLens = lens cpVersion (\x y -> x {cpVersion = y}) + +cpMetaLens :: Lens' ComponentTemplate (Maybe Object) +cpMetaLens = lens cpMeta (\x y -> x {cpMeta = y}) + +cpDeprecatedLens :: Lens' ComponentTemplate (Maybe Bool) +cpDeprecatedLens = lens cpDeprecated (\x y -> x {cpDeprecated = y}) + +-- $indexTemplateInfo +-- +-- The @GET /_index_template@ endpoint +-- () +-- returns a @{"index_templates": [...]}@ envelope in which each entry +-- pairs a template name with its decoded 'ComposableTemplate' body. The +-- same envelope is returned whether the request names a single template, +-- a wildcard pattern, or asks for every template on the cluster — the +-- server expands the path argument to the matching set and always +-- returns a list. 'IndexTemplateInfo' is the per-entry record; +-- 'GetIndexTemplatesResponse' is the envelope. + +-- | One entry in a @GET /_index_template@ response: the template's +-- @name@ paired with its @index_template@ body (decoded into a +-- 'ComposableTemplate'). The wire shape is +-- @{\"name\": ..., \"index_template\": {...}}@. +data IndexTemplateInfo = IndexTemplateInfo + { itiName :: TemplateName, + itiIndexTemplate :: ComposableTemplate + } + deriving stock (Eq, Show) + +instance ToJSON IndexTemplateInfo where + toJSON IndexTemplateInfo {..} = + object + [ "name" .= itiName, + "index_template" .= itiIndexTemplate + ] + +instance FromJSON IndexTemplateInfo where + parseJSON = withObject "IndexTemplateInfo" $ \o -> + IndexTemplateInfo + <$> o .: "name" + <*> o .: "index_template" + +itiNameLens :: Lens' IndexTemplateInfo TemplateName +itiNameLens = lens itiName (\x y -> x {itiName = y}) + +itiIndexTemplateLens :: Lens' IndexTemplateInfo ComposableTemplate +itiIndexTemplateLens = lens itiIndexTemplate (\x y -> x {itiIndexTemplate = y}) + +-- | Envelope returned by @GET /_index_template@. The server wraps the +-- matching templates in a single @index_templates@ array (see +-- 'IndexTemplateInfo'); this newtype peels off that outer key. +newtype GetIndexTemplatesResponse = GetIndexTemplatesResponse + { getIndexTemplatesResponseTemplates :: [IndexTemplateInfo] + } + deriving stock (Eq, Show) + +instance FromJSON GetIndexTemplatesResponse where + parseJSON = withObject "GetIndexTemplatesResponse" $ \o -> + GetIndexTemplatesResponse <$> o .: "index_templates" + +instance ToJSON GetIndexTemplatesResponse where + toJSON (GetIndexTemplatesResponse xs) = + object ["index_templates" .= xs] + +getIndexTemplatesResponseTemplatesLens :: Lens' GetIndexTemplatesResponse [IndexTemplateInfo] +getIndexTemplatesResponseTemplatesLens = + lens + getIndexTemplatesResponseTemplates + (\x y -> x {getIndexTemplatesResponseTemplates = y}) + +-- $simulatedTemplate +-- +-- The @POST /_index_template/_simulate@ endpoint +-- () +-- resolves a hypothetical 'ComposableTemplate' against the templates +-- already registered on the cluster and returns the merged +-- @settings@\/@mappings@\/@aliases@ that would be applied to a new +-- matching index, plus the list of /existing/ composable templates +-- whose @index_patterns@ overlap the simulated template's patterns +-- (and would therefore also match). The endpoint is available since +-- Elasticsearch 7.8 and in OpenSearch 2.x. +-- +-- The request body is the bare 'ComposableTemplate' (the same shape +-- used by 'putIndexTemplate' for @PUT /_index_template/{name}@); no +-- @index_template@ wrapper is required. The response's @template@ +-- object has the same @settings@\/@mappings@\/@aliases@ shape as +-- 'ComposableTemplateContent', so the typed view reuses that type +-- verbatim — no separate "resolved template" record is needed. +-- +-- Note that the response's @settings@ blob is /server-normalised/: +-- flat keys supplied on the request (e.g. @number_of_shards@) come +-- back wrapped under @index@ with numeric values stringified (e.g. +-- @{"index":{"number_of_shards":"1"}}@). It is therefore not +-- directly reusable as a request body for 'putIndexTemplate' — the +-- same surprise as the @GET /_index_template@ response (see +-- 'IndexTemplateInfo'). Callers that need to re-PUT the resolved +-- body must re-flatten the settings themselves. + +-- | Merge typed @(key, value)@ pairs into an 'X.KeyMap', dropping +-- @Null@ values (matching 'omitNulls' semantics). Typed pairs take +-- precedence over stale duplicates in the @*Other@ blob so round-trips +-- overwrite the verbatim entries with the typed projections. Mirrors +-- the helper in +-- "Database.Bloodhound.Internal.Versions.Common.Types.PendingTask". +mergeIgnoringNulls :: [(Key, Value)] -> X.KeyMap Value -> X.KeyMap Value +mergeIgnoringNulls kvs o = X.union (X.fromList (filter notNull kvs)) o + where + notNull (_, Null) = False + notNull _ = True + +-- | One entry in the @overlapping@ array of a 'SimulatedTemplate' +-- response: the @name@ of an existing composable template whose +-- @index_patterns@ overlap the simulated template's patterns. Forward- +-- compat keys survive in 'stoOther'. +data SimulatedTemplateOverlap = SimulatedTemplateOverlap + { -- | @name@ of the overlapping composable template. + stoName :: Maybe TemplateName, + -- | @index_patterns@ of the overlapping template. Decoded leniently + -- (defaults to @[]@ when the server omits the key). + stoIndexPatterns :: [IndexPattern], + -- | Unmodified source object, so callers can inspect any + -- server-added field without losing it on round-trip. + stoOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SimulatedTemplateOverlap where + parseJSON = withObject "SimulatedTemplateOverlap" $ \o -> + SimulatedTemplateOverlap + <$> o .:? "name" + <*> (o .:? "index_patterns" .!= []) + <*> pure (Object o) + +instance ToJSON SimulatedTemplateOverlap where + toJSON ov = + case stoOther ov of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= stoName ov, + "index_patterns" .= stoIndexPatterns ov + ] + +stoNameLens :: Lens' SimulatedTemplateOverlap (Maybe TemplateName) +stoNameLens = lens stoName (\x y -> x {stoName = y}) + +stoIndexPatternsLens :: Lens' SimulatedTemplateOverlap [IndexPattern] +stoIndexPatternsLens = lens stoIndexPatterns (\x y -> x {stoIndexPatterns = y}) + +stoOtherLens :: Lens' SimulatedTemplateOverlap Value +stoOtherLens = lens stoOther (\x y -> x {stoOther = y}) + +-- | Response body of @POST /_index_template/_simulate@. The @template@ +-- field reuses 'ComposableTemplateContent' because the resolved +-- settings\/mappings\/aliases shape is identical to the per-template +-- content type. Forward-compat keys survive in 'stOther'. +data SimulatedTemplate = SimulatedTemplate + { -- | @template@. The merged @settings@\/@mappings@\/@aliases@ that + -- would be applied to a new index matching the simulated template. + -- Decoded leniently into an empty 'ComposableTemplateContent' when + -- the server omits the key (which is unusual but well-defined). + stTemplate :: ComposableTemplateContent, + -- | @overlapping@. Existing composable templates whose + -- @index_patterns@ overlap the simulated template's patterns. + -- Defaults to @[]@ when the server omits the key (i.e. no overlap). + stOverlapping :: [SimulatedTemplateOverlap], + -- | Unmodified source object, so callers can inspect any + -- server-added field (e.g. future Elasticsearch additions) without + -- losing it on round-trip. + stOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SimulatedTemplate where + parseJSON = withObject "SimulatedTemplate" $ \o -> + SimulatedTemplate + <$> (o .:? "template" .!= emptyContent) + <*> (o .:? "overlapping" .!= []) + <*> pure (Object o) + where + emptyContent = ComposableTemplateContent Nothing Nothing Nothing + +instance ToJSON SimulatedTemplate where + toJSON st = + case stOther st of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "template" .= stTemplate st, + "overlapping" .= stOverlapping st + ] + +stTemplateLens :: Lens' SimulatedTemplate ComposableTemplateContent +stTemplateLens = lens stTemplate (\x y -> x {stTemplate = y}) + +stOverlappingLens :: Lens' SimulatedTemplate [SimulatedTemplateOverlap] +stOverlappingLens = lens stOverlapping (\x y -> x {stOverlapping = y}) + +stOtherLens :: Lens' SimulatedTemplate Value +stOtherLens = lens stOther (\x y -> x {stOther = y}) + +-- $templateInfo +-- +-- The /legacy/ @GET /_template[\/{name}]@ endpoint +-- () +-- is the read-side counterpart of 'putTemplate'. Unlike the composable +-- @GET /_index_template@ shape (which wraps entries in an +-- @index_templates@ array — see 'GetIndexTemplatesResponse'), the legacy +-- endpoint returns an outer object keyed by template name, with each +-- value carrying the legacy-only @order@ and @version@ fields alongside +-- the @index_patterns@ \/ @settings@ \/ @mappings@ \/ @aliases@ body. +-- 'TemplateInfo' is the per-template record; 'GetTemplatesResponse' is +-- the envelope that peels off the outer @{name: body, ...}@ shape and +-- injects the key into each entry as 'tiName'. +-- +-- The server normalises @settings@ (wrapping flat keys under +-- @index@) and rewrites @mappings@ on GET, so neither field round-trips +-- through the typed 'IndexSettings' \/ 'Mapping' losslessly. Both are +-- therefore kept as raw JSON 'Value's, matching the convention used by +-- 'ComposableTemplateContent'\'s @settings@ field. + +-- | One entry in a @GET /_template@ response: the template's name +-- (lifted from the outer JSON key by 'GetTemplatesResponse') paired +-- with its legacy body fields. Every field except 'tiName' and +-- 'tiIndexPatterns' is optional — ES omits absent fields on the wire +-- rather than emitting @null@, and 'Nothing' round-trips back to an +-- absent key via the 'ToJSON' instance. +data TemplateInfo = TemplateInfo + { -- | Template name. Populated from the outer JSON key by + -- 'GetTemplatesResponse'\'s 'FromJSON' decoder; absent on the inner + -- body itself. + tiName :: TemplateName, + -- | @order@. Legacy templates have a numeric order used to resolve + -- conflicts when several templates match a new index. Higher wins. + -- Composable templates replaced this with @priority@. + tiOrder :: Maybe Int, + -- | @index_patterns@. One or more glob patterns matched against new + -- index names. Defaults to @[]@ if the server omits the field. + tiIndexPatterns :: [IndexPattern], + -- | @settings@. Raw JSON 'Value' — the server normalises this on + -- GET (wrapping flat keys under @index@), so the typed + -- 'IndexSettings' does not round-trip losslessly. + tiSettings :: Maybe Value, + -- | @mappings@. Raw JSON 'Value', kept opaque for the same reason + -- as 'tiSettings'. + tiMappings :: Maybe Value, + -- | @aliases@. Per-alias body, keyed by alias name. Optional. + tiAliases :: Maybe Object, + -- | @version@. Opaque version number for external tracking. + tiVersion :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON TemplateInfo where + parseJSON = withObject "TemplateInfo" $ \o -> + -- 'tiName' is filled in by 'GetTemplatesResponse' from the outer + -- JSON key; decoding a standalone body leaves it as the empty + -- 'TemplateName' "". + TemplateInfo (TemplateName "") + <$> o .:? "order" + <*> o .:? "index_patterns" .!= [] + <*> o .:? "settings" + <*> o .:? "mappings" + <*> o .:? "aliases" + <*> o .:? "version" + +instance ToJSON TemplateInfo where + toJSON TemplateInfo {..} = + omitNulls + [ "order" .= tiOrder, + "index_patterns" .= tiIndexPatterns, + "settings" .= tiSettings, + "mappings" .= tiMappings, + "aliases" .= tiAliases, + "version" .= tiVersion + ] + +tiNameLens :: Lens' TemplateInfo TemplateName +tiNameLens = lens tiName (\x y -> x {tiName = y}) + +tiOrderLens :: Lens' TemplateInfo (Maybe Int) +tiOrderLens = lens tiOrder (\x y -> x {tiOrder = y}) + +tiIndexPatternsLens :: Lens' TemplateInfo [IndexPattern] +tiIndexPatternsLens = lens tiIndexPatterns (\x y -> x {tiIndexPatterns = y}) + +tiSettingsLens :: Lens' TemplateInfo (Maybe Value) +tiSettingsLens = lens tiSettings (\x y -> x {tiSettings = y}) + +tiMappingsLens :: Lens' TemplateInfo (Maybe Value) +tiMappingsLens = lens tiMappings (\x y -> x {tiMappings = y}) + +tiAliasesLens :: Lens' TemplateInfo (Maybe Object) +tiAliasesLens = lens tiAliases (\x y -> x {tiAliases = y}) + +tiVersionLens :: Lens' TemplateInfo (Maybe Int) +tiVersionLens = lens tiVersion (\x y -> x {tiVersion = y}) + +-- | Envelope returned by @GET /_template@. The server returns the +-- matching templates as a single object keyed by template name (each +-- value being a 'TemplateInfo' body); this newtype peels off that +-- outer key, lifting each key into the corresponding entry's 'tiName'. +newtype GetTemplatesResponse = GetTemplatesResponse + { getTemplatesResponseTemplates :: [TemplateInfo] + } + deriving stock (Eq, Show) + +instance FromJSON GetTemplatesResponse where + parseJSON = withObject "GetTemplatesResponse" $ \o -> do + let kvPairs = X.toList o + templates <- forM kvPairs $ \(k, v) -> do + info <- parseJSON v :: Parser TemplateInfo + pure info {tiName = TemplateName (AK.toText k)} + pure $ GetTemplatesResponse templates + +instance ToJSON GetTemplatesResponse where + toJSON (GetTemplatesResponse xs) = + object (map (\info -> (AK.fromText (templateNameText (tiName info)), toJSON info)) xs) + where + templateNameText (TemplateName n) = n + +getTemplatesResponseTemplatesLens :: Lens' GetTemplatesResponse [TemplateInfo] +getTemplatesResponseTemplatesLens = + lens + getTemplatesResponseTemplates + (\x y -> x {getTemplatesResponseTemplates = y}) + +-- $componentTemplateInfo +-- +-- The @GET /_component_template@ endpoint +-- () +-- returns a @{"component_templates": [...]}@ envelope in which each +-- entry pairs a template name with its decoded 'ComponentTemplate' body. +-- The same envelope is returned whether the request names a single +-- template, a wildcard pattern, or asks for every component template on +-- the cluster — the server expands the path argument to the matching +-- set and always returns a list. 'ComponentTemplateInfo' is the +-- per-entry record; 'GetComponentTemplatesResponse' is the envelope. + +-- | One entry in a @GET /_component_template@ response: the template's +-- @name@ paired with its @component_template@ body (decoded into a +-- 'ComponentTemplate'). The wire shape is +-- @{\"name\": ..., \"component_template\": {...}}@. +data ComponentTemplateInfo = ComponentTemplateInfo + { ctiName :: TemplateName, + ctiComponentTemplate :: ComponentTemplate + } + deriving stock (Eq, Show) + +instance ToJSON ComponentTemplateInfo where + toJSON ComponentTemplateInfo {..} = + object + [ "name" .= ctiName, + "component_template" .= ctiComponentTemplate + ] + +instance FromJSON ComponentTemplateInfo where + parseJSON = withObject "ComponentTemplateInfo" $ \o -> + ComponentTemplateInfo + <$> o .: "name" + <*> o .: "component_template" + +ctiNameLens :: Lens' ComponentTemplateInfo TemplateName +ctiNameLens = lens ctiName (\x y -> x {ctiName = y}) + +ctiComponentTemplateLens :: Lens' ComponentTemplateInfo ComponentTemplate +ctiComponentTemplateLens = + lens ctiComponentTemplate (\x y -> x {ctiComponentTemplate = y}) + +-- | Envelope returned by @GET /_component_template@. The server wraps +-- the matching templates in a single @component_templates@ array (see +-- 'ComponentTemplateInfo'); this newtype peels off that outer key. +newtype GetComponentTemplatesResponse = GetComponentTemplatesResponse + { getComponentTemplatesResponseTemplates :: [ComponentTemplateInfo] + } + deriving stock (Eq, Show) + +instance FromJSON GetComponentTemplatesResponse where + parseJSON = withObject "GetComponentTemplatesResponse" $ \o -> + GetComponentTemplatesResponse <$> o .: "component_templates" + +instance ToJSON GetComponentTemplatesResponse where + toJSON (GetComponentTemplatesResponse xs) = + object ["component_templates" .= xs] + +getComponentTemplatesResponseTemplatesLens :: Lens' GetComponentTemplatesResponse [ComponentTemplateInfo] +getComponentTemplatesResponseTemplatesLens = + lens + getComponentTemplatesResponseTemplates + (\x y -> x {getComponentTemplatesResponseTemplates = y}) + +-- | URI parameters accepted by @PUT /_index_template/{name}@ that are +-- modelled here: @create@ (fail the request if a template with the +-- given name already exists, instead of upserting), @master_timeout@ +-- (the pre-7.16 alias of @cluster_manager_timeout@, still accepted by +-- every supported backend) and @cause@ (an opaque reason string +-- recorded in the server logs). Every field is optional so +-- 'defaultComposableTemplateOptions' renders to no parameters at all — +-- byte-for-byte identical to a parameterless call via 'putIndexTemplate'. +data ComposableTemplateOptions = ComposableTemplateOptions + { -- | @create@. When @'Just' True@ the server returns a 4xx if a + -- template with the same name already exists. + ctoCreate :: Maybe Bool, + -- | @master_timeout@, encoded as a magnitude paired with a + -- 'TimeUnits' suffix (e.g. @('TimeUnitSeconds', 30)@ renders as + -- @30s@). + ctoMasterTimeout :: Maybe (TimeUnits, Word32), + -- | @cause@. Opaque reason string recorded in the server logs. + -- Rendered verbatim by the (dumbed-down) 'withQueries' renderer, so + -- it must not contain characters that require URL-encoding (spaces, + -- @&@, @=@, ...). + ctoCause :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'ComposableTemplateOptions' with every parameter set to 'Nothing'. +-- Produces no query string, so @'putIndexTemplateWith' name tpl +-- 'defaultComposableTemplateOptions'@ emits a request identical to +-- 'putIndexTemplate'. +defaultComposableTemplateOptions :: ComposableTemplateOptions +defaultComposableTemplateOptions = + ComposableTemplateOptions + { ctoCreate = Nothing, + ctoMasterTimeout = Nothing, + ctoCause = Nothing + } + +ctoCreateLens :: Lens' ComposableTemplateOptions (Maybe Bool) +ctoCreateLens = lens ctoCreate (\x y -> x {ctoCreate = y}) + +ctoMasterTimeoutLens :: Lens' ComposableTemplateOptions (Maybe (TimeUnits, Word32)) +ctoMasterTimeoutLens = lens ctoMasterTimeout (\x y -> x {ctoMasterTimeout = y}) + +ctoCauseLens :: Lens' ComposableTemplateOptions (Maybe Text) +ctoCauseLens = lens ctoCause (\x y -> x {ctoCause = y}) + +-- | Render 'ComposableTemplateOptions' as a list of @(key, value)@ +-- pairs suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultComposableTemplateOptions' produces an empty list (and +-- therefore no query string). +composableTemplateOptionsParams :: ComposableTemplateOptions -> [(Text, Maybe Text)] +composableTemplateOptionsParams opts = + catMaybes + [ ("create",) . Just . renderBool <$> ctoCreate opts, + ("master_timeout",) . Just . renderDuration <$> ctoMasterTimeout opts, + ("cause",) . Just <$> ctoCause opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +data MappingField = MappingField + { mappingFieldName :: FieldName, + fieldDefinition :: FieldDefinition + } + deriving stock (Eq, Show) + +mappingFieldNameLens :: Lens' MappingField FieldName +mappingFieldNameLens = lens mappingFieldName (\x y -> x {mappingFieldName = y}) + +mappingFieldDefinitionLens :: Lens' MappingField FieldDefinition +mappingFieldDefinitionLens = lens fieldDefinition (\x y -> x {fieldDefinition = y}) + +-- | Support for type reification of 'Mapping's is currently incomplete, for +-- now the mapping API verbiage expects a 'ToJSON'able blob. +-- +-- Indexes have mappings, mappings are schemas for the documents contained +-- in the index. I'd recommend having only one mapping per index, always +-- having a mapping, and keeping different kinds of documents separated +-- if possible. +newtype Mapping = Mapping {mappingFields :: [MappingField]} + deriving stock (Eq, Show) + +mappingFieldsLens :: Lens' Mapping [MappingField] +mappingFieldsLens = lens mappingFields (\x y -> x {mappingFields = y}) + +-- | Response shape for @GET \/\\/_mapping\/field\/\@ +-- (). +-- +-- The server returns one entry per requested index. Use this type when you +-- want a structured view of the response; decode into a 'Value' instead if +-- you need the raw JSON. +-- +-- Index names in the response are decoded as 'Map' keys and are therefore +-- not subject to the 'mkIndexNameSystem' validation that 'IndexName'\'s +-- value-level 'FromJSON' performs; the server may legitimately echo back +-- indices whose names the client would refuse to create. +newtype FieldMappingResponse = FieldMappingResponse + { fieldMappingResponseIndices :: M.Map IndexName FieldMappingIndexEntry + } + deriving stock (Eq, Show) + deriving newtype (FromJSON) + +fieldMappingResponseIndicesLens :: Lens' FieldMappingResponse (M.Map IndexName FieldMappingIndexEntry) +fieldMappingResponseIndicesLens = + lens + fieldMappingResponseIndices + (\x y -> x {fieldMappingResponseIndices = y}) + +-- | Per-index portion of a 'FieldMappingResponse', keyed by the requested +-- field name. The server may also return intermediate path components when +-- a sub-field is requested, hence the 'M.Map' rather than a list. +newtype FieldMappingIndexEntry = FieldMappingIndexEntry + { fieldMappingIndexEntryFields :: M.Map T.Text FieldMappingDetail + } + deriving stock (Eq, Show) + +fieldMappingIndexEntryFieldsLens :: Lens' FieldMappingIndexEntry (M.Map T.Text FieldMappingDetail) +fieldMappingIndexEntryFieldsLens = + lens + fieldMappingIndexEntryFields + (\x y -> x {fieldMappingIndexEntryFields = y}) + +-- | Details for a single requested field. +-- +-- The nested @mapping@ object carries the same schema-unstable per-type +-- properties that motivate 'Database.Bloodhound.Common.Client.getMapping' +-- being polymorphic, so it is kept as a 'Value' here. +data FieldMappingDetail = FieldMappingDetail + { fieldMappingDetailFullName :: T.Text, + fieldMappingDetailMapping :: Value + } + deriving stock (Eq, Show) + +fieldMappingDetailFullNameLens :: Lens' FieldMappingDetail T.Text +fieldMappingDetailFullNameLens = + lens + fieldMappingDetailFullName + (\x y -> x {fieldMappingDetailFullName = y}) + +fieldMappingDetailMappingLens :: Lens' FieldMappingDetail Value +fieldMappingDetailMappingLens = + lens + fieldMappingDetailMapping + (\x y -> x {fieldMappingDetailMapping = y}) + +instance FromJSON FieldMappingIndexEntry where + parseJSON = withObject "FieldMappingIndexEntry" $ \o -> do + mappings <- o .: "mappings" + -- The inner @mappings@ object is keyed by the requested field name + -- (or by intermediate path components for nested sub-fields). + fields <- + parseJSON mappings :: Parser (M.Map T.Text FieldMappingDetail) + pure $ FieldMappingIndexEntry fields + +instance FromJSON FieldMappingDetail where + parseJSON = withObject "FieldMappingDetail" $ \o -> + FieldMappingDetail + <$> o .: "full_name" + <*> o .: "mapping" + +data AllocationPolicy + = -- | Allows shard allocation for all shards. + AllocAll + | -- | Allows shard allocation only for primary shards. + AllocPrimaries + | -- | Allows shard allocation only for primary shards for new indices. + AllocNewPrimaries + | -- | No shard allocation is allowed + AllocNone + deriving stock (Eq, Show, Generic) + +instance ToJSON AllocationPolicy where + toJSON AllocAll = String "all" + toJSON AllocPrimaries = String "primaries" + toJSON AllocNewPrimaries = String "new_primaries" + toJSON AllocNone = String "none" + +instance FromJSON AllocationPolicy where + parseJSON = withText "AllocationPolicy" parse + where + parse "all" = pure AllocAll + parse "primaries" = pure AllocPrimaries + parse "new_primaries" = pure AllocNewPrimaries + parse "none" = pure AllocNone + parse t = fail ("Invlaid AllocationPolicy: " <> show t) + +data IndexAlias = IndexAlias + { srcIndex :: IndexName, + indexAlias :: IndexAliasName + } + deriving stock (Eq, Show) + +indexAliasSrcIndexLens :: Lens' IndexAlias IndexName +indexAliasSrcIndexLens = lens srcIndex (\x y -> x {srcIndex = y}) + +indexAliasLens :: Lens' IndexAlias IndexAliasName +indexAliasLens = lens indexAlias (\x y -> x {indexAlias = y}) + +data IndexAliasAction + = AddAlias IndexAlias IndexAliasCreate + | RemoveAlias IndexAlias + deriving stock (Eq, Show) + +-- | 'IndexAliasCreate' carries the per-alias options that may accompany +-- an @add@ action in 'updateIndexAliases'. Every field is optional, so +-- 'defaultIndexAliasCreate' renders to the empty object @{}@, which the +-- server accepts as a no-op alias body. +-- +-- Beyond the legacy 'aliasCreateRouting' and 'aliasCreateFilter' fields, +-- the record also models the body fields documented at +-- : +-- +-- * 'aliasCreateIsWriteIndex' — @is_write_index@ (ES 6.4+). Marks the +-- alias as the write target when several indices share it. Required +-- for rollover to operate on the alias. +-- * 'aliasCreateIsHidden' — @is_hidden@ (ES 7.x+). Hides the alias +-- from wildcard expansions unless explicitly named. +-- * 'aliasCreateMustExist' — @must_exist@ (ES 7.10+). When @Just True@, +-- the action fails if the alias does not already exist; useful for +-- idempotent remove actions. +data IndexAliasCreate = IndexAliasCreate + { aliasCreateRouting :: Maybe AliasRouting, + aliasCreateFilter :: Maybe Filter, + aliasCreateIsWriteIndex :: Maybe Bool, + aliasCreateIsHidden :: Maybe Bool, + aliasCreateMustExist :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'IndexAliasCreate' with every field set to 'Nothing'. Renders to the +-- empty object @{}@. New code is encouraged to start from +-- 'defaultIndexAliasCreate' and override individual fields via the +-- @...Lens@ accessors: +-- +-- @ +-- let body = 'defaultIndexAliasCreate' { 'aliasCreateIsWriteIndex' = 'Just' 'True' } +-- in 'updateIndexAliases' ('AddAlias' alias body :| []) +-- @ +defaultIndexAliasCreate :: IndexAliasCreate +defaultIndexAliasCreate = + IndexAliasCreate + { aliasCreateRouting = Nothing, + aliasCreateFilter = Nothing, + aliasCreateIsWriteIndex = Nothing, + aliasCreateIsHidden = Nothing, + aliasCreateMustExist = Nothing + } + +indexAliasCreateRoutingLens :: Lens' IndexAliasCreate (Maybe AliasRouting) +indexAliasCreateRoutingLens = lens aliasCreateRouting (\x y -> x {aliasCreateRouting = y}) + +indexAliasCreateFilterLens :: Lens' IndexAliasCreate (Maybe Filter) +indexAliasCreateFilterLens = lens aliasCreateFilter (\x y -> x {aliasCreateFilter = y}) + +indexAliasCreateIsWriteIndexLens :: Lens' IndexAliasCreate (Maybe Bool) +indexAliasCreateIsWriteIndexLens = + lens aliasCreateIsWriteIndex (\x y -> x {aliasCreateIsWriteIndex = y}) + +indexAliasCreateIsHiddenLens :: Lens' IndexAliasCreate (Maybe Bool) +indexAliasCreateIsHiddenLens = + lens aliasCreateIsHidden (\x y -> x {aliasCreateIsHidden = y}) + +indexAliasCreateMustExistLens :: Lens' IndexAliasCreate (Maybe Bool) +indexAliasCreateMustExistLens = + lens aliasCreateMustExist (\x y -> x {aliasCreateMustExist = y}) + +data AliasRouting + = AllAliasRouting RoutingValue + | GranularAliasRouting (Maybe SearchAliasRouting) (Maybe IndexAliasRouting) + deriving stock (Eq, Show) + +newtype SearchAliasRouting + = SearchAliasRouting (NonEmpty RoutingValue) + deriving stock (Eq, Show, Generic) + +instance ToJSON SearchAliasRouting where + toJSON (SearchAliasRouting rvs) = toJSON (T.intercalate "," (routingValue <$> toList rvs)) + +instance FromJSON SearchAliasRouting where + parseJSON = withText "SearchAliasRouting" parse + where + parse t = SearchAliasRouting <$> parseNEJSON (String <$> T.splitOn "," t) + +newtype IndexAliasRouting + = IndexAliasRouting RoutingValue + deriving newtype (Eq, Show, ToJSON, FromJSON) + +newtype RoutingValue = RoutingValue {routingValue :: Text} + deriving newtype (Eq, Show, ToJSON, FromJSON) + +routingValueLens :: Lens' RoutingValue Text +routingValueLens = lens routingValue (\x y -> x {routingValue = y}) + +newtype IndexAliasesSummary = IndexAliasesSummary {indexAliasesSummary :: [IndexAliasSummary]} + deriving stock (Eq, Show) + +instance FromJSON IndexAliasesSummary where + parseJSON = withObject "IndexAliasesSummary" parse + where + parse o = IndexAliasesSummary <$> parseIndexAliasSummaries o + +-- | The per-index counterpart of 'IndexAliasesSummary'. Both types +-- parse the same wire shape — the +-- @{"": {"aliases": {"": body}}}@ envelope returned by +-- every alias GET endpoint — but 'IndexAliasesInfo' is the result of a +-- focused 'getIndexAlias' lookup (one index, optionally one alias), +-- whereas 'IndexAliasesSummary' is the result of the unfiltered +-- 'getIndexAliases'. They are kept distinct so callers can tell apart +-- \"I asked for everything\" from \"I asked for one index\/alias\" at +-- the type level, even though the payload shape is identical. +newtype IndexAliasesInfo = IndexAliasesInfo {indexAliasesInfo :: [IndexAliasSummary]} + deriving stock (Eq, Show) + +instance FromJSON IndexAliasesInfo where + parseJSON = withObject "IndexAliasesInfo" parse + where + parse o = IndexAliasesInfo <$> parseIndexAliasSummaries o + +-- | Shared parser for the @{"": {"aliases": {...}}}@ envelope +-- returned by @GET /_aliases@, @GET /_alias@, and +-- @GET /{index}/_alias[\/{name}]@. Used by both 'IndexAliasesSummary' +-- and 'IndexAliasesInfo'. +parseIndexAliasSummaries :: Object -> Parser [IndexAliasSummary] +parseIndexAliasSummaries o = mconcat <$> mapM (uncurry go) (X.toList o) + where + go ixn = withObject "index aliases" $ \ia -> do + indexName <- parseJSON $ toJSON ixn + aliases <- ia .:? "aliases" .!= mempty + forM (HM.toList aliases) $ \(aName, v) -> do + let indexAlias = IndexAlias indexName (IndexAliasName aName) + IndexAliasSummary indexAlias <$> parseJSON v + +indexAliasesSummaryLens :: Lens' IndexAliasesSummary [IndexAliasSummary] +indexAliasesSummaryLens = lens indexAliasesSummary (\x y -> x {indexAliasesSummary = y}) + +indexAliasesInfoLens :: Lens' IndexAliasesInfo [IndexAliasSummary] +indexAliasesInfoLens = lens indexAliasesInfo (\x y -> x {indexAliasesInfo = y}) + +instance ToJSON IndexAliasAction where + toJSON (AddAlias ia opts) = object ["add" .= (jsonObject ia <> jsonObject opts)] + toJSON (RemoveAlias ia) = object ["remove" .= jsonObject ia] + +instance ToJSON IndexAlias where + toJSON IndexAlias {..} = + object + [ "index" .= srcIndex, + "alias" .= indexAlias + ] + +instance ToJSON IndexAliasCreate where + toJSON IndexAliasCreate {..} = + Object $ + filterObj + <> routingObj + <> boolField "is_write_index" aliasCreateIsWriteIndex + <> boolField "is_hidden" aliasCreateIsHidden + <> boolField "must_exist" aliasCreateMustExist + where + filterObj = maybe mempty (X.singleton "filter" . toJSON) aliasCreateFilter + routingObj = jsonObject $ maybe (Object mempty) toJSON aliasCreateRouting + boolField k = maybe mempty (X.singleton k . Bool) + +instance ToJSON AliasRouting where + toJSON (AllAliasRouting v) = object ["routing" .= v] + toJSON (GranularAliasRouting srch idx) = object (catMaybes prs) + where + prs = + [ ("search_routing" .=) <$> srch, + ("index_routing" .=) <$> idx + ] + +instance FromJSON AliasRouting where + parseJSON = withObject "AliasRouting" parse + where + parse o = parseAll o <|> parseGranular o + parseAll o = AllAliasRouting <$> o .: "routing" + parseGranular o = do + sr <- o .:? "search_routing" + ir <- o .:? "index_routing" + if isNothing sr && isNothing ir + then fail "Both search_routing and index_routing can't be blank" + else return (GranularAliasRouting sr ir) + +instance FromJSON IndexAliasCreate where + parseJSON v = withObject "IndexAliasCreate" parse v + where + parse o = + IndexAliasCreate + <$> optional (parseJSON v) + <*> o .:? "filter" + <*> o .:? "is_write_index" + <*> o .:? "is_hidden" + <*> o .:? "must_exist" + +-- | 'IndexAliasSummary' is a summary of an index alias configured for a server. +data IndexAliasSummary = IndexAliasSummary + { indexAliasSummaryAlias :: IndexAlias, + indexAliasSummaryCreate :: IndexAliasCreate + } + deriving stock (Eq, Show) + +indexAliasSummaryAliasLens :: Lens' IndexAliasSummary IndexAlias +indexAliasSummaryAliasLens = lens indexAliasSummaryAlias (\x y -> x {indexAliasSummaryAlias = y}) + +indexAliasSummaryCreateLens :: Lens' IndexAliasSummary IndexAliasCreate +indexAliasSummaryCreateLens = lens indexAliasSummaryCreate (\x y -> x {indexAliasSummaryCreate = y}) + +-- | The URI parameters accepted by @POST /_aliases@ +-- (): +-- @master_timeout@ (the pre-7.16 alias of @cluster_manager_timeout@, +-- still accepted by every supported backend) and @timeout@. Both are +-- modelled as a magnitude paired with a 'TimeUnits' suffix (e.g. +-- @('TimeUnitSeconds', 30)@ renders as @30s@). +-- +-- Every field is optional, so 'defaultUpdateAliasesOptions' produces no +-- query string at all — byte-for-byte identical to a parameterless call +-- to 'updateIndexAliases'. +data UpdateAliasesOptions = UpdateAliasesOptions + { uaoMasterTimeout :: Maybe (TimeUnits, Word32), + uaoTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'UpdateAliasesOptions' with every parameter set to 'Nothing'. +-- Produces no query string, so @'updateIndexAliasesWith' +-- 'defaultUpdateAliasesOptions'@ emits a request identical to +-- 'updateIndexAliases'. +defaultUpdateAliasesOptions :: UpdateAliasesOptions +defaultUpdateAliasesOptions = + UpdateAliasesOptions + { uaoMasterTimeout = Nothing, + uaoTimeout = Nothing + } + +uaoMasterTimeoutLens :: Lens' UpdateAliasesOptions (Maybe (TimeUnits, Word32)) +uaoMasterTimeoutLens = lens uaoMasterTimeout (\x y -> x {uaoMasterTimeout = y}) + +uaoTimeoutLens :: Lens' UpdateAliasesOptions (Maybe (TimeUnits, Word32)) +uaoTimeoutLens = lens uaoTimeout (\x y -> x {uaoTimeout = y}) + +-- | Render 'UpdateAliasesOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultUpdateAliasesOptions' produces an empty list (and therefore +-- no query string). +updateAliasesOptionsParams :: UpdateAliasesOptions -> [(Text, Maybe Text)] +updateAliasesOptionsParams opts = + catMaybes + [ ("master_timeout",) . Just . renderDuration <$> uaoMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> uaoTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +data JoinRelation + = ParentDocument FieldName RelationName + | ChildDocument FieldName RelationName DocId + deriving stock (Eq, Show) + +-- | 'IndexDocumentSettings' are special settings supplied when indexing +-- a document. For the best backwards compatiblity when new fields are +-- added, you should probably prefer to start with 'defaultIndexDocumentSettings' +-- and override individual fields via the @...Lens@ accessors. +-- +-- Beyond the legacy 'idsVersionControl' and 'idsJoinRelation' fields, +-- the record now also carries every documented URI parameter of the +-- Index API (): +-- +-- * 'idsOpType' — @op_type@ (=@index@/=@create@) +-- * 'idsPipeline' — @pipeline@ +-- * 'idsRefresh' — @refresh@ (=@false@/=@true@/=@wait_for@) +-- * 'idsWaitForActiveShards' — @wait_for_active_shards@ +-- * 'idsIfSeqNo' / 'idsIfPrimaryTerm' — @if_seq_no@ / @if_primary_term@ +-- (must be set together for optimistic concurrency) +-- * 'idsRequireAlias' — @require_alias@ +-- * 'idsTimeout' — @timeout@ (also emitted by 'updateDocumentWith', +-- which shares the index-document renderer; the Update API accepts +-- the same parameter) +data IndexDocumentSettings = IndexDocumentSettings + { idsVersionControl :: VersionControl, + idsJoinRelation :: Maybe JoinRelation, + -- | @op_type@ URI parameter. When set to 'Just' 'OpCreate' the + -- server will reject (HTTP 409) an index request that would + -- overwrite an existing document. 'Just' 'OpIndex' is the + -- server default and is equivalent to 'Nothing'. + idsOpType :: Maybe OpType, + -- | @pipeline@ URI parameter — id of an ingest pipeline to apply + -- before indexing. + idsPipeline :: Maybe Text, + -- | @refresh@ URI parameter — controls shard refresh behaviour + -- after the write. + idsRefresh :: Maybe RefreshPolicy, + -- | @wait_for_active_shards@ URI parameter — number of active shard + -- copies required before the operation returns. Uses the shared + -- 'ActiveShardCount' type so @"all"@ and numeric counts are both + -- representable. + idsWaitForActiveShards :: Maybe ActiveShardCount, + -- | @if_seq_no@ — perform the write only if the document's current + -- sequence number matches. Should be set together with + -- 'idsIfPrimaryTerm' for optimistic concurrency control. If only + -- one of the two is set, the partial pair is sent verbatim and + -- Elasticsearch responds with HTTP 400 — by design, so caller + -- mistakes are not silently swallowed. + idsIfSeqNo :: Maybe Word64, + -- | @if_primary_term@ — companion to 'idsIfSeqNo'. See its + -- documentation for the half-set behaviour. + idsIfPrimaryTerm :: Maybe Word64, + -- | @require_alias@ — when set to @Just True@, the destination + -- index name must be an alias (used by data-stream write targets). + -- @Nothing@ and @Just False@ are equivalent on the wire and allow + -- both concrete indexes and aliases. + idsRequireAlias :: Maybe Bool, + -- | @timeout@ URI parameter — upper bound the server should wait + -- for the primary shard and (with @?wait_for_active_shards@) the + -- required active shard copies before failing the write. Encoded + -- as a magnitude paired with a 'TimeUnits' suffix (e.g. + -- @('TimeUnitSeconds', 30)@ renders as @30s@). 'Nothing' falls + -- back to the server default of @1m@. Lets callers bound per-call + -- write latency, which the legacy fields could not express. + idsTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +indexDocumentSettingsVersionControlLens :: Lens' IndexDocumentSettings VersionControl +indexDocumentSettingsVersionControlLens = lens idsVersionControl (\x y -> x {idsVersionControl = y}) + +indexDocumentSettingsJoinRelationLens :: Lens' IndexDocumentSettings (Maybe JoinRelation) +indexDocumentSettingsJoinRelationLens = lens idsJoinRelation (\x y -> x {idsJoinRelation = y}) + +indexDocumentSettingsOpTypeLens :: Lens' IndexDocumentSettings (Maybe OpType) +indexDocumentSettingsOpTypeLens = lens idsOpType (\x y -> x {idsOpType = y}) + +indexDocumentSettingsPipelineLens :: Lens' IndexDocumentSettings (Maybe Text) +indexDocumentSettingsPipelineLens = lens idsPipeline (\x y -> x {idsPipeline = y}) + +indexDocumentSettingsRefreshLens :: Lens' IndexDocumentSettings (Maybe RefreshPolicy) +indexDocumentSettingsRefreshLens = lens idsRefresh (\x y -> x {idsRefresh = y}) + +indexDocumentSettingsWaitForActiveShardsLens :: Lens' IndexDocumentSettings (Maybe ActiveShardCount) +indexDocumentSettingsWaitForActiveShardsLens = + lens idsWaitForActiveShards (\x y -> x {idsWaitForActiveShards = y}) + +indexDocumentSettingsIfSeqNoLens :: Lens' IndexDocumentSettings (Maybe Word64) +indexDocumentSettingsIfSeqNoLens = lens idsIfSeqNo (\x y -> x {idsIfSeqNo = y}) + +indexDocumentSettingsIfPrimaryTermLens :: Lens' IndexDocumentSettings (Maybe Word64) +indexDocumentSettingsIfPrimaryTermLens = lens idsIfPrimaryTerm (\x y -> x {idsIfPrimaryTerm = y}) + +indexDocumentSettingsRequireAliasLens :: Lens' IndexDocumentSettings (Maybe Bool) +indexDocumentSettingsRequireAliasLens = lens idsRequireAlias (\x y -> x {idsRequireAlias = y}) + +indexDocumentSettingsTimeoutLens :: Lens' IndexDocumentSettings (Maybe (TimeUnits, Word32)) +indexDocumentSettingsTimeoutLens = lens idsTimeout (\x y -> x {idsTimeout = y}) + +-- | Reasonable default settings. Chooses no version control, no parent, +-- and omits every newer URI parameter (op_type, pipeline, refresh, +-- wait_for_active_shards, if_seq_no, if_primary_term, require_alias, +-- timeout) so that the resulting request is byte-for-byte identical to the +-- pre-existing @indexDocument@ behaviour. +defaultIndexDocumentSettings :: IndexDocumentSettings +defaultIndexDocumentSettings = + IndexDocumentSettings + { idsVersionControl = NoVersionControl, + idsJoinRelation = Nothing, + idsOpType = Nothing, + idsPipeline = Nothing, + idsRefresh = Nothing, + idsWaitForActiveShards = Nothing, + idsIfSeqNo = Nothing, + idsIfPrimaryTerm = Nothing, + idsRequireAlias = Nothing, + idsTimeout = Nothing + } + +-- | Number of shard copies that must be active before a create-index (or +-- similar) operation returns, sent as the @wait_for_active_shards@ URI +-- parameter. The server accepts the literal string @"all"@ or any positive +-- integer up to @number_of_replicas + 1@. +-- +-- See +data ActiveShardCount + = -- | Render as @"all"@: wait for every shard copy to be active. + AllActiveShards + | -- | Render as the decimal string of the given count. Values larger + -- than @replicas + 1@ are clamped server-side. + ActiveShards Word + deriving stock (Eq, Show) + +-- | URI rendering of 'ActiveShardCount' — @"all"@ for 'AllActiveShards', +-- the bare decimal for 'ActiveShards'. Used by the create-index request +-- builder. +renderActiveShardCount :: ActiveShardCount -> Text +renderActiveShardCount AllActiveShards = "all" +renderActiveShardCount (ActiveShards n) = showText n + +-- | JSON encoding of 'ActiveShardCount': @"all"@ (a JSON string) for +-- 'AllActiveShards', and a bare JSON number for 'ActiveShards'. Used by +-- request bodies that carry @wait_for_active_shards@ (e.g. the ES9 +-- downsample endpoint), where the wire form distinguishes the literal +-- string @"all"@ from an integer shard count. +instance ToJSON ActiveShardCount where + toJSON AllActiveShards = String "all" + toJSON (ActiveShards n) = toJSON n + +-- | Parses the wire form produced by 'ToJSON': @"all"@ (a JSON string) +-- for 'AllActiveShards', or a JSON number for 'ActiveShards'. The +-- complement of 'ToJSON', so 'ActiveShardCount' round-trips through +-- JSON. +instance FromJSON ActiveShardCount where + parseJSON (String "all") = pure AllActiveShards + parseJSON other = ActiveShards <$> (parseJSON other :: Parser Word) + +-- | Downsampling method shared by endpoints that roll up time-series +-- data: @aggregate@ (the documented default) sums aggregated metrics +-- over the interval, while @last_value@ takes the last sample in each +-- bucket. Used by both the ES9 @POST \/\\/_downsample@ body +-- (@sampling_method@) and the ES7 data-stream lifecycle +-- (@downsampling_method@), which share the same wire enum. +data SamplingMethod + = -- | Render as @"aggregate"@. + Aggregate + | -- | Render as @"last_value"@. + LastValue + deriving stock (Eq, Show, Generic) + +-- | Parses the wire form produced by 'ToJSON': @"aggregate"@ or +-- @"last_value"@. Any other value fails, so 'SamplingMethod' does not +-- round-trip through unknown strings. +instance FromJSON SamplingMethod where + parseJSON = withText "SamplingMethod" $ \t -> case t of + "aggregate" -> pure Aggregate + "last_value" -> pure LastValue + _ -> fail "Invalid SamplingMethod (expected 'aggregate' or 'last_value')" + +-- | JSON encoding of 'SamplingMethod': @"aggregate"@ / @"last_value"@. +instance ToJSON SamplingMethod where + toJSON Aggregate = "aggregate" + toJSON LastValue = "last_value" + +-- | 'CreateIndexOptions' is the full set of inputs accepted by the +-- @PUT \/\@ (create-index) endpoint +-- (). +-- It carries both the body (@settings@, @mappings@, @aliases@) and the +-- URI parameters (@wait_for_active_shards@, @master_timeout@, @timeout@). +-- +-- This is a superset of the legacy 'createIndex' \/ 'createIndexWith' +-- functions, which only let callers set @settings@. New code should +-- prefer 'Database.Bloodhound.Common.Client.createIndexOptions' together +-- with 'defaultCreateIndexOptions': +-- +-- @ +-- let opts = 'defaultCreateIndexOptions' +-- { 'cioSettings' = 'Just' 'defaultIndexSettings', +-- 'cioMappings' = 'Just' ('toJSON' myMapping), +-- 'cioWaitForActiveShards' = 'Just' 'AllActiveShards' +-- } +-- in 'Database.Bloodhound.Common.Client.createIndexOptions' opts ('IndexName' "foo") +-- @ +-- +-- For backwards compatibility 'defaultCreateIndexOptions' produces no +-- body and no URI parameters; in particular 'defaultCreateIndexOptions' +-- with @'cioSettings' = 'Just' s@ emits a byte-for-byte identical +-- request to the legacy @'createIndex' s@. +-- +-- /Note/: @mappings@ and @aliases@ are deliberately typed as an opaque +-- 'Value' / 'Object' here. They are user-supplied JSON blobs the same +-- way 'templateMappings' is on 'IndexTemplate' — full schema-typed +-- modelling is tracked as a separate epic. +data CreateIndexOptions = CreateIndexOptions + { -- | Index settings (shards, replicas, mapping limits, ...). When + -- 'Nothing' the @settings@ key is omitted entirely and the server + -- applies its defaults. + cioSettings :: Maybe IndexSettings, + -- | Top-level @mappings@ body field. Pass any 'ToJSON'able mapping + -- blob here, e.g. @'toJSON' ('Mapping' [...])@ or a hand-rolled + -- 'Object'. + cioMappings :: Maybe Value, + -- | Top-level @aliases@ body field. Each key is an alias name; each + -- value is an (optionally empty) alias body. + cioAliases :: Maybe Object, + -- | @wait_for_active_shards@ URI parameter. 'Nothing' uses the + -- server default (which is @1@ for a freshly created index). + cioWaitForActiveShards :: Maybe ActiveShardCount, + -- | @master_timeout@ URI parameter. Modeled as a magnitude paired + -- with a 'TimeUnits' suffix (e.g. @('TimeUnitSeconds', 30)@ renders + -- as @30s@). + cioMasterTimeout :: Maybe (TimeUnits, Word32), + -- | @timeout@ URI parameter. Same encoding as 'cioMasterTimeout'. + cioTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'CreateIndexOptions' with every optional field set to 'Nothing'. +-- Renders to no body and no URI params, so the server uses its built-in +-- defaults for everything. Callers wanting the same behaviour as the +-- legacy @'createIndex' 'defaultIndexSettings'@ should set +-- @'cioSettings' = 'Just' 'defaultIndexSettings'@ explicitly. +defaultCreateIndexOptions :: CreateIndexOptions +defaultCreateIndexOptions = + CreateIndexOptions + { cioSettings = Nothing, + cioMappings = Nothing, + cioAliases = Nothing, + cioWaitForActiveShards = Nothing, + cioMasterTimeout = Nothing, + cioTimeout = Nothing + } + +cioSettingsLens :: Lens' CreateIndexOptions (Maybe IndexSettings) +cioSettingsLens = lens cioSettings (\x y -> x {cioSettings = y}) + +cioMappingsLens :: Lens' CreateIndexOptions (Maybe Value) +cioMappingsLens = lens cioMappings (\x y -> x {cioMappings = y}) + +cioAliasesLens :: Lens' CreateIndexOptions (Maybe Object) +cioAliasesLens = lens cioAliases (\x y -> x {cioAliases = y}) + +cioWaitForActiveShardsLens :: Lens' CreateIndexOptions (Maybe ActiveShardCount) +cioWaitForActiveShardsLens = + lens cioWaitForActiveShards (\x y -> x {cioWaitForActiveShards = y}) + +cioMasterTimeoutLens :: Lens' CreateIndexOptions (Maybe (TimeUnits, Word32)) +cioMasterTimeoutLens = lens cioMasterTimeout (\x y -> x {cioMasterTimeout = y}) + +cioTimeoutLens :: Lens' CreateIndexOptions (Maybe (TimeUnits, Word32)) +cioTimeoutLens = lens cioTimeout (\x y -> x {cioTimeout = y}) + +-- | 'IndexSelection' is used for APIs which take a single index, a list of +-- indexes, or the special @_all@ index. + +-- TODO: this does not fully support . It wouldn't be too hard to implement but you'd have to add the optional parameters (ignore_unavailable, allow_no_indices, expand_wildcards) to any APIs using it. Also would be a breaking API. +data IndexSelection + = IndexList (NonEmpty IndexName) + | AllIndexes + deriving stock (Eq, Show) + +-- | 'TemplateName' is used to describe which template to query/create/delete +newtype TemplateName = TemplateName Text deriving newtype (Eq, Show, ToJSON, FromJSON) + +-- | A glob pattern matched against template names by +-- @GET /_index_template\/{pattern}@ (e.g. @"serv*"@, @"logs-*"@). The +-- server resolves the wildcard; the client forwards the literal text +-- verbatim, exactly as for 'TemplateName'. Introduced to distinguish +-- the path-style \"match many templates\" argument from the +-- \"identify-one-template\" 'TemplateName' used by @PUT@ and @DELETE@. +-- +-- Like every path newtype in this library, the value is interpolated +-- into the URL without percent-encoding, so it must not contain @\/@, +-- @?@ or @#@ — those characters would corrupt the request path or +-- inject spurious query parameters. +newtype TemplateNamePattern = TemplateNamePattern Text deriving newtype (Eq, Show, ToJSON, FromJSON) + +-- | 'IndexPattern' represents a pattern which is matched against index +-- names. Unlike 'Database.Bloodhound.Internal.Versions.Common.Types.Newtypes.IndexName' +-- (whose 'Database.Bloodhound.Internal.Versions.Common.Types.Newtypes.mkIndexName' +-- smart constructor rejects the wildcard characters @*@, @?@, commas, and +-- several others), an 'IndexPattern' is the /escape hatch/ for endpoints +-- whose @{@index@}@ path segment legitimately accepts: +-- +-- * a wildcard pattern such as @\"logs-*\"@ or @\"*_audit\"@, +-- * a comma-separated list such as @\"logs-2024,logs-2025\"@, +-- * a regex (@\/pattern\/@) on backends that support it, +-- * aliases, data-stream names, and @\:\@ remote +-- references. +-- +-- The 'IndexPattern' value is interpolated verbatim into the request URL +-- with no percent-encoding, so it must not contain @\/@, @?@ or @#@ — +-- those characters would corrupt the path or inject spurious query +-- parameters. The smart constructor 'mkIndexPattern' enforces this; +-- callers that bypass it via the raw constructor take on that duty +-- themselves. +-- +-- Endpoints that accept an 'IndexPattern' today include the +-- point-in-time family ('Database.Bloodhound.Common.Requests.openPointInTimeWith', +-- 'Database.Bloodhound.Common.Requests.openPointInTimeWithBody', +-- @pitSearchWith@ on each backend) and the index-resolution family +-- ('Database.Bloodhound.Common.Requests.resolveIndex', +-- 'Database.Bloodhound.Common.Requests.resolveIndexWith'). Other +-- multi-index endpoints such as +-- 'Database.Bloodhound.Common.Requests.searchByIndices' still take a +-- 'NonEmpty' 'IndexName' list because their comma-join rendering is +-- produced by the library itself; widening those is tracked separately. +-- +-- @since 0.26.0.0 +newtype IndexPattern = IndexPattern {unIndexPattern :: Text} deriving newtype (Eq, Show, ToJSON, FromJSON) + +-- | Smart constructor for an 'IndexPattern'. Unlike +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Newtypes.mkIndexName' +-- it permits wildcard (@*@), comma (,@), and the other characters the +-- server treats as pattern syntax, but it rejects the three characters +-- that would corrupt the URL path or inject spurious query parameters: +-- @\/@, @?@ and @#@. It also rejects the empty string. +-- +-- For a fully unvalidated 'IndexPattern' (e.g. to send @\:\@ +-- references that include @\/@ in the cluster-alias portion on some +-- proxies), use the raw 'IndexPattern' constructor directly — the caller +-- then owns URL-safety. +-- +-- prop> mkIndexPattern "logs-*" == Right (IndexPattern "logs-*") +-- prop> mkIndexPattern "a,b" == Right (IndexPattern "a,b") +-- prop> mkIndexPattern "a/b" == Left "..." +-- prop> mkIndexPattern "" == Left "..." +-- +-- @since 0.26.0.0 +mkIndexPattern :: Text -> Either Text IndexPattern +mkIndexPattern name = do + let check explanation p = if p then Right () else Left explanation + check "Is empty" $ not $ T.null name + check + "Includes [/?#]" + (T.all (`notElem` ("/?#" :: String)) name) + return $ IndexPattern name + +-- | Conditions under which 'rolloverIndex' should roll the alias over to a new +-- index. At least one field should be 'Just' when the value is actually sent +-- to the server; the 'Maybe' fields let the caller express any subset. +-- +-- Sizes and ages carry units (e.g. @"7d"@, @"50gb"@) so they are 'Text' +-- rather than numbers, matching the on-the-wire grammar used by both +-- Elasticsearch and OpenSearch. 'rolloverConditionsMaxDocs' is a plain +-- integer. +-- +-- See +-- and . +-- +-- @since 0.26.0.0 +data RolloverConditions = RolloverConditions + { rolloverConditionsMaxAge :: Maybe Text, + rolloverConditionsMaxDocs :: Maybe Int, + rolloverConditionsMaxSize :: Maybe Text, + rolloverConditionsMaxPrimaryShardSize :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance ToJSON RolloverConditions where + toJSON RolloverConditions {..} = + omitNulls + [ "max_age" .= rolloverConditionsMaxAge, + "max_docs" .= rolloverConditionsMaxDocs, + "max_size" .= rolloverConditionsMaxSize, + "max_primary_shard_size" .= rolloverConditionsMaxPrimaryShardSize + ] + +instance FromJSON RolloverConditions where + parseJSON = withObject "RolloverConditions" $ \v -> + RolloverConditions + <$> v + .:? "max_age" + <*> v + .:? "max_docs" + <*> v + .:? "max_size" + <*> v + .:? "max_primary_shard_size" + +-- | 'RolloverConditions' with every threshold set to 'Nothing'. Useful +-- only as a seed for record updates, e.g. +-- +-- @ +-- defaultRolloverConditions { rolloverConditionsMaxDocs = 'Just' 1000 } +-- @ +-- +-- /WARNING/: sending 'defaultRolloverConditions' verbatim to the +-- server produces an empty @conditions@ object, which the rollover +-- endpoint will reject. Always override at least one field with +-- 'Just' before passing it to 'rolloverIndex'. To roll over +-- unconditionally, pass 'Nothing' instead. +defaultRolloverConditions :: RolloverConditions +defaultRolloverConditions = + RolloverConditions + { rolloverConditionsMaxAge = Nothing, + rolloverConditionsMaxDocs = Nothing, + rolloverConditionsMaxSize = Nothing, + rolloverConditionsMaxPrimaryShardSize = Nothing + } + +rolloverConditionsMaxAgeLens :: Lens' RolloverConditions (Maybe Text) +rolloverConditionsMaxAgeLens = lens rolloverConditionsMaxAge (\x y -> x {rolloverConditionsMaxAge = y}) + +rolloverConditionsMaxDocsLens :: Lens' RolloverConditions (Maybe Int) +rolloverConditionsMaxDocsLens = lens rolloverConditionsMaxDocs (\x y -> x {rolloverConditionsMaxDocs = y}) + +rolloverConditionsMaxSizeLens :: Lens' RolloverConditions (Maybe Text) +rolloverConditionsMaxSizeLens = lens rolloverConditionsMaxSize (\x y -> x {rolloverConditionsMaxSize = y}) + +rolloverConditionsMaxPrimaryShardSizeLens :: Lens' RolloverConditions (Maybe Text) +rolloverConditionsMaxPrimaryShardSizeLens = + lens rolloverConditionsMaxPrimaryShardSize (\x y -> x {rolloverConditionsMaxPrimaryShardSize = y}) + +-- | Response body for @POST //_rollover@. +-- +-- All fields are modelled defensively with @.:.?@ to tolerate backends +-- that omit them. The ES OpenAPI spec marks every field as @Required@ +-- in the 200 body, but other backends (OpenSearch) may be looser, and a +-- @dry_run@ response still populates @old_index@\/@new_index@ with the +-- candidate names. +-- +-- @conditions@, when present, is the server's own evaluation of the +-- supplied thresholds: a map from a human-readable condition +-- description (e.g. @"[max_docs: 1]"@) to whether that condition was +-- met (@True@) or not (@False@). The shape is therefore not the same +-- as 'RolloverConditions' — the server re-renders thresholds as +-- display strings rather than echoing the request body. +-- +-- @since 0.26.0.0 +data RolloverResponse = RolloverResponse + { rolloverResponseAcknowledged :: Bool, + rolloverResponseShardsAcknowledged :: Bool, + rolloverResponseOldIndex :: Maybe IndexName, + rolloverResponseNewIndex :: Maybe IndexName, + rolloverResponseRolledOver :: Bool, + rolloverResponseDryRun :: Bool, + rolloverResponseConditions :: Maybe (M.Map Text Bool) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON RolloverResponse where + toJSON RolloverResponse {..} = + omitNulls + [ "acknowledged" .= rolloverResponseAcknowledged, + "shards_acknowledged" .= rolloverResponseShardsAcknowledged, + "old_index" .= rolloverResponseOldIndex, + "new_index" .= rolloverResponseNewIndex, + "rolled_over" .= rolloverResponseRolledOver, + "dry_run" .= rolloverResponseDryRun, + "conditions" .= rolloverResponseConditions + ] + +instance FromJSON RolloverResponse where + parseJSON = withObject "RolloverResponse" $ \v -> do + rolloverResponseAcknowledged <- v .:? "acknowledged" .!= False + rolloverResponseShardsAcknowledged <- v .:? "shards_acknowledged" .!= False + rolloverResponseOldIndex <- v .:? "old_index" + rolloverResponseNewIndex <- v .:? "new_index" + rolloverResponseRolledOver <- v .:? "rolled_over" .!= False + rolloverResponseDryRun <- v .:? "dry_run" .!= False + rolloverResponseConditions <- v .:? "conditions" + return RolloverResponse {..} + +rolloverResponseAcknowledgedLens :: Lens' RolloverResponse Bool +rolloverResponseAcknowledgedLens = + lens rolloverResponseAcknowledged (\x y -> x {rolloverResponseAcknowledged = y}) + +rolloverResponseShardsAcknowledgedLens :: Lens' RolloverResponse Bool +rolloverResponseShardsAcknowledgedLens = + lens rolloverResponseShardsAcknowledged (\x y -> x {rolloverResponseShardsAcknowledged = y}) + +rolloverResponseOldIndexLens :: Lens' RolloverResponse (Maybe IndexName) +rolloverResponseOldIndexLens = + lens rolloverResponseOldIndex (\x y -> x {rolloverResponseOldIndex = y}) + +rolloverResponseNewIndexLens :: Lens' RolloverResponse (Maybe IndexName) +rolloverResponseNewIndexLens = + lens rolloverResponseNewIndex (\x y -> x {rolloverResponseNewIndex = y}) + +rolloverResponseRolledOverLens :: Lens' RolloverResponse Bool +rolloverResponseRolledOverLens = + lens rolloverResponseRolledOver (\x y -> x {rolloverResponseRolledOver = y}) + +rolloverResponseDryRunLens :: Lens' RolloverResponse Bool +rolloverResponseDryRunLens = + lens rolloverResponseDryRun (\x y -> x {rolloverResponseDryRun = y}) + +rolloverResponseConditionsLens :: Lens' RolloverResponse (Maybe (M.Map Text Bool)) +rolloverResponseConditionsLens = + lens rolloverResponseConditions (\x y -> x {rolloverResponseConditions = y}) + +-- $resize +-- +-- /Shrink, split and clone/ all share the same body shape as +-- 'createIndexOptions' (@settings@, @mappings@, @aliases@) and the same +-- URI parameters (@wait_for_active_shards@, @master_timeout@, +-- @timeout@). Each endpoint is therefore modelled as a thin typed +-- newtype around 'CreateIndexOptions': nominal type-safety (a +-- 'CloneSettings' cannot be passed to 'shrinkIndex') while reusing the +-- whole body\/param rendering pipeline. +-- +-- See +-- +-- * +-- * +-- * +-- * +-- * +-- * + +-- | Body and URI parameters for @POST //_shrink/@. The +-- source index must be read-only (@index.blocks.write: true@) and every +-- primary shard of the source must be resident on a single node before +-- the call; the target's @number_of_shards@ must be a divisor of the +-- source's. Wrap 'defaultCreateIndexOptions' (or override +-- 'shrinkSettingsOptions') to populate @settings@ \/ @aliases@ for the +-- new index. +-- +-- @since 0.26.0.0 +newtype ShrinkSettings = ShrinkSettings {shrinkSettingsOptions :: CreateIndexOptions} + deriving stock (Eq, Show) + +-- | 'ShrinkSettings' with every optional field set to 'Nothing': +-- empty body, no URI parameters. The server then copies the source +-- index's settings verbatim and applies its built-in defaults for +-- anything missing. +-- +-- @since 0.26.0.0 +defaultShrinkSettings :: ShrinkSettings +defaultShrinkSettings = ShrinkSettings defaultCreateIndexOptions + +shrinkSettingsOptionsLens :: Lens' ShrinkSettings CreateIndexOptions +shrinkSettingsOptionsLens = + lens shrinkSettingsOptions (\x y -> x {shrinkSettingsOptions = y}) + +-- | Body and URI parameters for @POST //_split/@. The +-- source index must be read-only (@index.blocks.write: true@); the +-- target's @number_of_shards@ must be a multiple of the source's, and +-- the source's @index.number_of_routing_shards@ must be a multiple of +-- the target's. See 'ShrinkSettings' for the field layout — both +-- newtypes wrap 'CreateIndexOptions'. +-- +-- @since 0.26.0.0 +newtype SplitSettings = SplitSettings {splitSettingsOptions :: CreateIndexOptions} + deriving stock (Eq, Show) + +-- | 'SplitSettings' with every optional field set to 'Nothing'. +-- +-- @since 0.26.0.0 +defaultSplitSettings :: SplitSettings +defaultSplitSettings = SplitSettings defaultCreateIndexOptions + +splitSettingsOptionsLens :: Lens' SplitSettings CreateIndexOptions +splitSettingsOptionsLens = + lens splitSettingsOptions (\x y -> x {splitSettingsOptions = y}) + +-- | Body and URI parameters for @POST //_clone/@. The +-- source index must be read-only (@index.blocks.write: true@); the +-- target inherits the source's @number_of_shards@. See +-- 'ShrinkSettings' for the field layout. +-- +-- @since 0.26.0.0 +newtype CloneSettings = CloneSettings {cloneSettingsOptions :: CreateIndexOptions} + deriving stock (Eq, Show) + +-- | 'CloneSettings' with every optional field set to 'Nothing'. +-- +-- @since 0.26.0.0 +defaultCloneSettings :: CloneSettings +defaultCloneSettings = CloneSettings defaultCreateIndexOptions + +cloneSettingsOptionsLens :: Lens' CloneSettings CreateIndexOptions +cloneSettingsOptionsLens = + lens cloneSettingsOptions (\x y -> x {cloneSettingsOptions = y}) + +-- * Utils + +jsonObject :: (ToJSON a) => a -> Object +jsonObject x = + case toJSON x of + Object o -> o + e -> error $ "Expected Object, but got " <> show e + +-- * Index Stats + +-- +-- Response shape for @GET \/\\/_stats@ +-- (). +-- +-- The endpoint returns an enormous payload (indexing, search, get, merge, +-- flush, refresh, query_cache, fielddata, docs, store, translog, segments, +-- completion, ...). On this first cut only the universally useful 'docs' +-- and 'store' sub-objects are typed; everything else is preserved verbatim +-- in 'indexStatMetricsOther' so callers can navigate it with aeson while +-- later beads promote individual sections to typed records. + +-- | Top-level envelope of the @GET \/\\/_stats@ response. Carries +-- the shard result, an optional @_all@ rollup (present when the server +-- aggregates the requested indices) and the per-index entries keyed by +-- index name. +data IndexStats = IndexStats + { indexStatsShards :: ShardResult, + indexStatsAll :: Maybe IndexStatAggregate, + indexStatsIndices :: M.Map IndexName IndexStatEntry + } + deriving stock (Eq, Show) + +indexStatsShardsLens :: Lens' IndexStats ShardResult +indexStatsShardsLens = lens indexStatsShards (\x y -> x {indexStatsShards = y}) + +indexStatsAllLens :: Lens' IndexStats (Maybe IndexStatAggregate) +indexStatsAllLens = lens indexStatsAll (\x y -> x {indexStatsAll = y}) + +indexStatsIndicesLens :: Lens' IndexStats (M.Map IndexName IndexStatEntry) +indexStatsIndicesLens = lens indexStatsIndices (\x y -> x {indexStatsIndices = y}) + +-- | The @_all@ rollup returned when the server aggregates multiple +-- indices (or a single one) into one summary. Lacks the per-index +-- @uuid@, @health@ and @status@ fields. +data IndexStatAggregate = IndexStatAggregate + { indexStatAggregatePrimaries :: IndexStatMetrics, + indexStatAggregateTotal :: IndexStatMetrics + } + deriving stock (Eq, Show) + +indexStatAggregatePrimariesLens :: Lens' IndexStatAggregate IndexStatMetrics +indexStatAggregatePrimariesLens = + lens indexStatAggregatePrimaries (\x y -> x {indexStatAggregatePrimaries = y}) + +indexStatAggregateTotalLens :: Lens' IndexStatAggregate IndexStatMetrics +indexStatAggregateTotalLens = + lens indexStatAggregateTotal (\x y -> x {indexStatAggregateTotal = y}) + +-- | Per-index entry inside 'indexStatsIndices'. Carries the index's +-- metadata (@uuid@, @health@, @status@) alongside the @primaries@ and +-- @total@ metric blocks. +data IndexStatEntry = IndexStatEntry + { indexStatEntryUuid :: Maybe Text, + indexStatEntryHealth :: Maybe Text, + indexStatEntryStatus :: Maybe Text, + indexStatEntryPrimaries :: IndexStatMetrics, + indexStatEntryTotal :: IndexStatMetrics + } + deriving stock (Eq, Show) + +indexStatEntryUuidLens :: Lens' IndexStatEntry (Maybe Text) +indexStatEntryUuidLens = lens indexStatEntryUuid (\x y -> x {indexStatEntryUuid = y}) + +indexStatEntryHealthLens :: Lens' IndexStatEntry (Maybe Text) +indexStatEntryHealthLens = lens indexStatEntryHealth (\x y -> x {indexStatEntryHealth = y}) + +indexStatEntryStatusLens :: Lens' IndexStatEntry (Maybe Text) +indexStatEntryStatusLens = lens indexStatEntryStatus (\x y -> x {indexStatEntryStatus = y}) + +indexStatEntryPrimariesLens :: Lens' IndexStatEntry IndexStatMetrics +indexStatEntryPrimariesLens = + lens indexStatEntryPrimaries (\x y -> x {indexStatEntryPrimaries = y}) + +indexStatEntryTotalLens :: Lens' IndexStatEntry IndexStatMetrics +indexStatEntryTotalLens = + lens indexStatEntryTotal (\x y -> x {indexStatEntryTotal = y}) + +-- | A metric block (either @primaries@ or @total@). The @docs@ and +-- @store@ sub-objects are typed; every other section (indexing, search, +-- merge, flush, refresh, query_cache, fielddata, segments, translog, +-- completion, ...) is preserved verbatim in 'indexStatMetricsOther'. +-- +-- Note: @docs@ and @store@ appear both as typed fields and verbatim +-- inside 'indexStatMetricsOther' (which captures the whole original +-- object). The typed copies are authoritative; the verbatim copy exists +-- so callers can navigate any not-yet-typed section without waiting for +-- a follow-up bead to promote it. +data IndexStatMetrics = IndexStatMetrics + { indexStatMetricsDocs :: Maybe IndexStatDocs, + indexStatMetricsStore :: Maybe IndexStatStore, + indexStatMetricsOther :: Value + } + deriving stock (Eq, Show) + +indexStatMetricsDocsLens :: Lens' IndexStatMetrics (Maybe IndexStatDocs) +indexStatMetricsDocsLens = lens indexStatMetricsDocs (\x y -> x {indexStatMetricsDocs = y}) + +indexStatMetricsStoreLens :: Lens' IndexStatMetrics (Maybe IndexStatStore) +indexStatMetricsStoreLens = lens indexStatMetricsStore (\x y -> x {indexStatMetricsStore = y}) + +indexStatMetricsOtherLens :: Lens' IndexStatMetrics Value +indexStatMetricsOtherLens = lens indexStatMetricsOther (\x y -> x {indexStatMetricsOther = y}) + +-- | @docs@ sub-object: live document count and deleted document count. +data IndexStatDocs = IndexStatDocs + { indexStatDocsCount :: Word64, + indexStatDocsDeleted :: Word64 + } + deriving stock (Eq, Show) + +indexStatDocsCountLens :: Lens' IndexStatDocs Word64 +indexStatDocsCountLens = lens indexStatDocsCount (\x y -> x {indexStatDocsCount = y}) + +indexStatDocsDeletedLens :: Lens' IndexStatDocs Word64 +indexStatDocsDeletedLens = lens indexStatDocsDeleted (\x y -> x {indexStatDocsDeleted = y}) + +-- | @store@ sub-object: physical store size in bytes. +newtype IndexStatStore = IndexStatStore + { indexStatStoreSizeInBytes :: Word64 + } + deriving stock (Eq, Show) + +indexStatStoreSizeInBytesLens :: Lens' IndexStatStore Word64 +indexStatStoreSizeInBytesLens = + lens indexStatStoreSizeInBytes (\x y -> x {indexStatStoreSizeInBytes = y}) + +instance FromJSON IndexStats where + parseJSON = withObject "IndexStats" $ \o -> do + shards <- o .:? "_shards" .!= defaultShardResult + mAll <- o .:? "_all" + mIndices <- o .:? "indices" + indices <- maybe (pure M.empty) parseIndicesMap mIndices + pure $ IndexStats shards mAll indices + +-- | 'ShardResult' with every field zeroed out. Returned when the server +-- omits @_shards@ (e.g. some OpenSearch versions for single-index stats). +defaultShardResult :: ShardResult +defaultShardResult = ShardResult 0 0 0 0 + +instance FromJSON IndexStatAggregate where + parseJSON = withObject "IndexStatAggregate" parse + where + parse o = + IndexStatAggregate + <$> parseOrDefault (o .:? "primaries") + <*> parseOrDefault (o .:? "total") + +instance FromJSON IndexStatEntry where + parseJSON = withObject "IndexStatEntry" parse + where + parse o = + IndexStatEntry + <$> o .:? "uuid" + <*> o .:? "health" + <*> o .:? "status" + <*> parseOrDefault (o .:? "primaries") + <*> parseOrDefault (o .:? "total") + +-- | Parse a metric block. 'indexStatMetricsOther' captures the full +-- original object so callers can navigate any section beyond @docs@ and +-- @store@ without waiting for a typed model. +instance FromJSON IndexStatMetrics where + parseJSON = withObject "IndexStatMetrics" parse + where + parse o = + IndexStatMetrics + <$> o .:? "docs" + <*> o .:? "store" + <*> pure (Object o) + +instance FromJSON IndexStatDocs where + parseJSON = withObject "IndexStatDocs" parse + where + parse o = + IndexStatDocs + <$> o .:? "count" .!= 0 + <*> o .:? "deleted" .!= 0 + +instance FromJSON IndexStatStore where + parseJSON = withObject "IndexStatStore" parse + where + parse o = IndexStatStore <$> o .:? "size_in_bytes" .!= 0 + +-- | Parse the @indices@ map of an 'IndexStats' response. The keys are +-- index names echoed back by the server; they are parsed through +-- 'IndexName'\'s 'FromJSON' instance (i.e. 'mkIndexNameSystem', the +-- lenient validator that accepts hidden indices like @.kibana@), matching +-- the behaviour of 'IndexInfo' and 'FieldMappingResponse'. Truly invalid +-- names still fail the parse, which is the desired behaviour. +parseIndicesMap :: Value -> Parser (M.Map IndexName IndexStatEntry) +parseIndicesMap = withObject "IndexStats.indices" parse + where + parse o = M.fromList <$> traverse parseEntry (X.toList o) + parseEntry (k, v) = do + ixn <- parseJSON (toJSON k) + entry <- parseJSON v + pure (ixn, entry) + +-- | Parse an optional @primaries@\/@total@ metric block. Missing or null +-- yields an empty 'IndexStatMetrics' — the fields are documented but not +-- guaranteed for every index state (e.g. closed indices). +parseOrDefault :: Parser (Maybe Value) -> Parser IndexStatMetrics +parseOrDefault p = do + mv <- p + case mv of + Just v@(Object _) -> parseJSON v + _ -> pure (IndexStatMetrics Nothing Nothing emptyObject) + +-- * Index Recovery + +-- +-- Response shape for @GET \/\\/_recovery@ +-- (). +-- +-- The endpoint reports ongoing and completed shard recoveries (e.g. after +-- snapshot restore, replica allocation, or peer recovery on node restart). +-- The body is keyed by index name; each index carries a @shards@ array with +-- one entry per recovering shard. +-- +-- Following the 'IndexStatMetrics' philosophy, the universally useful +-- fields are typed (@id@, @type@, @stage@, @primary@, the @start@/@stop@/ +-- @total@ timestamps and the @index.files@ progress block) while the +-- @source@, @target@ and the rest of the @index@ sub-object are preserved +-- verbatim so callers can navigate them with aeson while later beads +-- promote individual sections to typed records. + +-- | Top-level envelope of the @GET \/\\/_recovery@ response. The +-- keys are index names echoed back by the server (parsed through +-- 'IndexName'\'s 'FromJSON' instance, the lenient validator that accepts +-- hidden indices like @.kibana@, matching 'IndexStats'). +newtype IndexRecovery = IndexRecovery + { indexRecoveryIndices :: M.Map IndexName [ShardRecovery] + } + deriving stock (Eq, Show) + +indexRecoveryIndicesLens :: Lens' IndexRecovery (M.Map IndexName [ShardRecovery]) +indexRecoveryIndicesLens = + lens indexRecoveryIndices (\x y -> x {indexRecoveryIndices = y}) + +-- | A single shard recovery entry. The @id@ is the shard number; @type@ +-- reports the source of the recovery (@SNAPSHOT@, @REPLICA@, +-- @EXISTING_STORE@, @EMPTY_STORE@ or @PEER_RECOVERY@); @stage@ reports +-- the current phase (@INITIALIZING@, @INDEX@, @FINALIZE@ or @DONE@). +data ShardRecovery = ShardRecovery + { shardRecoveryId :: Int, + shardRecoveryType :: Maybe Text, + shardRecoveryStage :: Maybe Text, + shardRecoveryPrimary :: Bool, + shardRecoveryStartTimeMillis :: Maybe Int, + shardRecoveryStopTimeMillis :: Maybe Int, + shardRecoveryTotalTimeMillis :: Maybe Int, + shardRecoverySource :: Maybe Value, + shardRecoveryTarget :: Maybe Value, + shardRecoveryIndex :: Maybe ShardRecoveryIndex, + shardRecoveryOther :: Value + } + deriving stock (Eq, Show) + +shardRecoveryIdLens :: Lens' ShardRecovery Int +shardRecoveryIdLens = lens shardRecoveryId (\x y -> x {shardRecoveryId = y}) + +shardRecoveryTypeLens :: Lens' ShardRecovery (Maybe Text) +shardRecoveryTypeLens = + lens shardRecoveryType (\x y -> x {shardRecoveryType = y}) + +shardRecoveryStageLens :: Lens' ShardRecovery (Maybe Text) +shardRecoveryStageLens = + lens shardRecoveryStage (\x y -> x {shardRecoveryStage = y}) + +shardRecoveryPrimaryLens :: Lens' ShardRecovery Bool +shardRecoveryPrimaryLens = + lens shardRecoveryPrimary (\x y -> x {shardRecoveryPrimary = y}) + +shardRecoveryStartTimeMillisLens :: Lens' ShardRecovery (Maybe Int) +shardRecoveryStartTimeMillisLens = + lens shardRecoveryStartTimeMillis (\x y -> x {shardRecoveryStartTimeMillis = y}) + +shardRecoveryStopTimeMillisLens :: Lens' ShardRecovery (Maybe Int) +shardRecoveryStopTimeMillisLens = + lens shardRecoveryStopTimeMillis (\x y -> x {shardRecoveryStopTimeMillis = y}) + +shardRecoveryTotalTimeMillisLens :: Lens' ShardRecovery (Maybe Int) +shardRecoveryTotalTimeMillisLens = + lens shardRecoveryTotalTimeMillis (\x y -> x {shardRecoveryTotalTimeMillis = y}) + +shardRecoverySourceLens :: Lens' ShardRecovery (Maybe Value) +shardRecoverySourceLens = + lens shardRecoverySource (\x y -> x {shardRecoverySource = y}) + +shardRecoveryTargetLens :: Lens' ShardRecovery (Maybe Value) +shardRecoveryTargetLens = + lens shardRecoveryTarget (\x y -> x {shardRecoveryTarget = y}) + +shardRecoveryIndexLens :: Lens' ShardRecovery (Maybe ShardRecoveryIndex) +shardRecoveryIndexLens = + lens shardRecoveryIndex (\x y -> x {shardRecoveryIndex = y}) + +shardRecoveryOtherLens :: Lens' ShardRecovery Value +shardRecoveryOtherLens = + lens shardRecoveryOther (\x y -> x {shardRecoveryOther = y}) + +-- | The @index@ sub-block of a shard recovery. The @files@ progress +-- object — the most useful summary of a recovery's progress — is typed; +-- everything else in the @index@ sub-object (size, total_time, +-- source_throttle_time, target_throttle_time, translog, verify_index, +-- ...) is preserved verbatim in 'shardRecoveryIndexOther' so callers can +-- navigate it with aeson while later beads promote individual sections to +-- typed records. +data ShardRecoveryIndex = ShardRecoveryIndex + { shardRecoveryIndexFiles :: Maybe ShardRecoveryFiles, + shardRecoveryIndexOther :: Value + } + deriving stock (Eq, Show) + +shardRecoveryIndexFilesLens :: Lens' ShardRecoveryIndex (Maybe ShardRecoveryFiles) +shardRecoveryIndexFilesLens = + lens shardRecoveryIndexFiles (\x y -> x {shardRecoveryIndexFiles = y}) + +shardRecoveryIndexOtherLens :: Lens' ShardRecoveryIndex Value +shardRecoveryIndexOtherLens = + lens shardRecoveryIndexOther (\x y -> x {shardRecoveryIndexOther = y}) + +-- | The @files@ progress object: counts and a server-rendered percentage +-- string such as @"100.0%"@. +data ShardRecoveryFiles = ShardRecoveryFiles + { shardRecoveryFilesTotal :: Maybe Word64, + shardRecoveryFilesReused :: Maybe Word64, + shardRecoveryFilesRecovered :: Maybe Word64, + shardRecoveryFilesPercent :: Maybe Text + } + deriving stock (Eq, Show) + +shardRecoveryFilesTotalLens :: Lens' ShardRecoveryFiles (Maybe Word64) +shardRecoveryFilesTotalLens = + lens shardRecoveryFilesTotal (\x y -> x {shardRecoveryFilesTotal = y}) + +shardRecoveryFilesReusedLens :: Lens' ShardRecoveryFiles (Maybe Word64) +shardRecoveryFilesReusedLens = + lens shardRecoveryFilesReused (\x y -> x {shardRecoveryFilesReused = y}) + +shardRecoveryFilesRecoveredLens :: Lens' ShardRecoveryFiles (Maybe Word64) +shardRecoveryFilesRecoveredLens = + lens shardRecoveryFilesRecovered (\x y -> x {shardRecoveryFilesRecovered = y}) + +shardRecoveryFilesPercentLens :: Lens' ShardRecoveryFiles (Maybe Text) +shardRecoveryFilesPercentLens = + lens shardRecoveryFilesPercent (\x y -> x {shardRecoveryFilesPercent = y}) + +instance FromJSON IndexRecovery where + parseJSON = withObject "IndexRecovery" $ \o -> + IndexRecovery <$> parseRecoveryIndicesMap (Object o) + +-- | Parse the top-level index-keyed map of a recovery response. The keys +-- are index names echoed back by the server; they are parsed through +-- 'IndexName'\'s 'FromJSON' instance (i.e. 'mkIndexNameSystem', the +-- lenient validator that accepts hidden indices like @.kibana@), matching +-- the behaviour of 'IndexStats' and 'FieldMappingResponse'. Truly invalid +-- names still fail the parse, which is the desired behaviour. +parseRecoveryIndicesMap :: Value -> Parser (M.Map IndexName [ShardRecovery]) +parseRecoveryIndicesMap = withObject "IndexRecovery.indices" parse + where + parse o = M.fromList <$> traverse parseEntry (X.toList o) + parseEntry (k, v) = do + ixn <- parseJSON (toJSON k) + shards <- withObject "IndexRecovery.shards" (.: "shards") v + parseJSON shards >>= \recoveries -> pure (ixn, recoveries) + +instance FromJSON ShardRecovery where + parseJSON = withObject "ShardRecovery" parse + where + parse o = + ShardRecovery + <$> o .:? "id" .!= 0 + <*> o .:? "type" + <*> o .:? "stage" + <*> o .:? "primary" .!= False + <*> o .:? "start_time_in_millis" + <*> o .:? "stop_time_in_millis" + <*> o .:? "total_time_in_millis" + <*> o .:? "source" + <*> o .:? "target" + <*> o .:? "index" + <*> pure (Object o) + +instance FromJSON ShardRecoveryIndex where + parseJSON = withObject "ShardRecoveryIndex" parse + where + parse o = + ShardRecoveryIndex + <$> o .:? "files" + <*> pure (Object o) + +instance FromJSON ShardRecoveryFiles where + parseJSON = withObject "ShardRecoveryFiles" parse + where + parse o = + ShardRecoveryFiles + <$> o .:? "total" + <*> o .:? "reused" + <*> o .:? "recovered" + <*> o .:? "percent" + +-- * Index Segments + +-- +-- Response shape for @GET /{index}/_segments@ +-- ( +-- and +-- ). +-- +-- The endpoint exposes low-level Lucene segment information for every +-- shard copy (primary + replicas) of the requested index. The response +-- is a @indices@ map keyed by index name; each index's @shards@ map is +-- keyed by shard number (a string like @"0"@) whose value is an /array/ +-- of shard entries — ES lists the primary and each replica under the +-- same shard number. +-- +-- The types below cover every field documented on ES 7.17. Fields +-- introduced by later versions (@segment_sort@, @vector_dimension@, +-- @rank_positions@, @lucene_version@, @tier_size_in_bytes@, ...) are +-- preserved verbatim in 'segmentOther' so the parser works on every +-- backend without losing information, mirroring the strategy used by +-- 'IndexStats' and 'ShardRecovery'. + +-- | Top-level envelope of the @GET /{index}/_segments@ response. The +-- outer map is keyed by index name (parsed through 'IndexName'\'s +-- 'FromJSON' instance, the lenient validator that accepts hidden +-- indices like @.kibana@, matching 'IndexStats' and 'IndexRecovery'). +-- The inner map is keyed by shard number as a string. +data IndexSegments = IndexSegments + { indexSegmentsShards :: ShardResult, + indexSegmentsIndices :: M.Map IndexName (M.Map Text [IndexSegmentsShard]) + } + deriving stock (Eq, Show) + +indexSegmentsShardsLens :: Lens' IndexSegments ShardResult +indexSegmentsShardsLens = + lens indexSegmentsShards (\x y -> x {indexSegmentsShards = y}) + +indexSegmentsIndicesLens :: + Lens' IndexSegments (M.Map IndexName (M.Map Text [IndexSegmentsShard])) +indexSegmentsIndicesLens = + lens indexSegmentsIndices (\x y -> x {indexSegmentsIndices = y}) + +-- | A single shard copy's segments report. ES lists the primary and +-- every replica under the same shard number, so each shard number +-- maps to a list of these. +data IndexSegmentsShard = IndexSegmentsShard + { indexSegmentsShardRouting :: SegmentRouting, + indexSegmentsShardNumCommitted :: Int, + indexSegmentsShardNumSearch :: Int, + indexSegmentsShardSegments :: M.Map Text SegmentInfo + } + deriving stock (Eq, Show) + +indexSegmentsShardRoutingLens :: Lens' IndexSegmentsShard SegmentRouting +indexSegmentsShardRoutingLens = + lens indexSegmentsShardRouting (\x y -> x {indexSegmentsShardRouting = y}) + +indexSegmentsShardNumCommittedLens :: Lens' IndexSegmentsShard Int +indexSegmentsShardNumCommittedLens = + lens indexSegmentsShardNumCommitted (\x y -> x {indexSegmentsShardNumCommitted = y}) + +indexSegmentsShardNumSearchLens :: Lens' IndexSegmentsShard Int +indexSegmentsShardNumSearchLens = + lens indexSegmentsShardNumSearch (\x y -> x {indexSegmentsShardNumSearch = y}) + +indexSegmentsShardSegmentsLens :: + Lens' IndexSegmentsShard (M.Map Text SegmentInfo) +indexSegmentsShardSegmentsLens = + lens indexSegmentsShardSegments (\x y -> x {indexSegmentsShardSegments = y}) + +-- | The @routing@ sub-object of a shard entry, describing where the +-- shard copy is currently allocated. +data SegmentRouting = SegmentRouting + { segmentRoutingState :: Maybe Text, + segmentRoutingPrimary :: Bool, + segmentRoutingNode :: Maybe Text, + segmentRoutingRelocatingNode :: Maybe Text + } + deriving stock (Eq, Show) + +segmentRoutingStateLens :: Lens' SegmentRouting (Maybe Text) +segmentRoutingStateLens = + lens segmentRoutingState (\x y -> x {segmentRoutingState = y}) + +segmentRoutingPrimaryLens :: Lens' SegmentRouting Bool +segmentRoutingPrimaryLens = + lens segmentRoutingPrimary (\x y -> x {segmentRoutingPrimary = y}) + +segmentRoutingNodeLens :: Lens' SegmentRouting (Maybe Text) +segmentRoutingNodeLens = + lens segmentRoutingNode (\x y -> x {segmentRoutingNode = y}) + +segmentRoutingRelocatingNodeLens :: Lens' SegmentRouting (Maybe Text) +segmentRoutingRelocatingNodeLens = + lens segmentRoutingRelocatingNode (\x y -> x {segmentRoutingRelocatingNode = y}) + +-- | A single Lucene segment. The segment id (e.g. @"_0"@) is the key +-- in 'indexSegmentsShardSegments', not a field of the segment itself. +-- +-- The typed fields are those documented on ES 7.17; later versions +-- add @segment_sort@, @vector_dimension@, @rank_positions@, +-- @lucene_version@, @tier_size_in_bytes@ and others. Those are +-- preserved verbatim in 'segmentOther' (as the original object minus +-- the promoted keys) so callers can navigate them with aeson while +-- later beads promote individual sections to typed fields. +data SegmentInfo = SegmentInfo + { segmentGeneration :: Int, + segmentNumDocs :: Int, + segmentDeletedDocs :: Int, + segmentSizeInBytes :: Int, + segmentMemoryInBytes :: Maybe Int, + segmentCommitted :: Bool, + segmentSearch :: Bool, + segmentVersion :: Maybe Text, + segmentCompound :: Maybe Bool, + segmentAttributes :: Maybe (M.Map Text Text), + segmentOther :: Maybe Value + } + deriving stock (Eq, Show) + +segmentGenerationLens :: Lens' SegmentInfo Int +segmentGenerationLens = + lens segmentGeneration (\x y -> x {segmentGeneration = y}) + +segmentNumDocsLens :: Lens' SegmentInfo Int +segmentNumDocsLens = + lens segmentNumDocs (\x y -> x {segmentNumDocs = y}) + +segmentDeletedDocsLens :: Lens' SegmentInfo Int +segmentDeletedDocsLens = + lens segmentDeletedDocs (\x y -> x {segmentDeletedDocs = y}) + +segmentSizeInBytesLens :: Lens' SegmentInfo Int +segmentSizeInBytesLens = + lens segmentSizeInBytes (\x y -> x {segmentSizeInBytes = y}) + +segmentMemoryInBytesLens :: Lens' SegmentInfo (Maybe Int) +segmentMemoryInBytesLens = + lens segmentMemoryInBytes (\x y -> x {segmentMemoryInBytes = y}) + +segmentCommittedLens :: Lens' SegmentInfo Bool +segmentCommittedLens = + lens segmentCommitted (\x y -> x {segmentCommitted = y}) + +segmentSearchLens :: Lens' SegmentInfo Bool +segmentSearchLens = + lens segmentSearch (\x y -> x {segmentSearch = y}) + +segmentVersionLens :: Lens' SegmentInfo (Maybe Text) +segmentVersionLens = + lens segmentVersion (\x y -> x {segmentVersion = y}) + +segmentCompoundLens :: Lens' SegmentInfo (Maybe Bool) +segmentCompoundLens = + lens segmentCompound (\x y -> x {segmentCompound = y}) + +segmentAttributesLens :: Lens' SegmentInfo (Maybe (M.Map Text Text)) +segmentAttributesLens = + lens segmentAttributes (\x y -> x {segmentAttributes = y}) + +segmentOtherLens :: Lens' SegmentInfo (Maybe Value) +segmentOtherLens = + lens segmentOther (\x y -> x {segmentOther = y}) + +instance FromJSON IndexSegments where + parseJSON = withObject "IndexSegments" $ \o -> do + -- _shards is documented by every backend but is omitted by some + -- OpenSearch builds on single-index stats; we mirror the defensive + -- parse used by IndexStats rather than fail the whole decode. + shards <- o .:? "_shards" .!= defaultShardResult + indicesVal <- o .:? "indices" .!= Object mempty + indices <- parseSegmentsIndicesMap indicesVal + pure $ IndexSegments shards indices + +-- | Parse the @indices@ sub-object of a segments response. The keys are +-- index names echoed back by the server; they are parsed through +-- 'IndexName'\'s 'FromJSON' instance (the lenient validator that +-- accepts hidden indices like @.kibana@), matching 'IndexStats' and +-- 'IndexRecovery'. +parseSegmentsIndicesMap :: + Value -> + Parser (M.Map IndexName (M.Map Text [IndexSegmentsShard])) +parseSegmentsIndicesMap = withObject "IndexSegments.indices" parse + where + parse o = M.fromList <$> traverse parseEntry (X.toList o) + parseEntry (k, v) = do + ixn <- parseJSON (toJSON k) + shards <- + withObject "IndexSegments.shards" (.: "shards") v + inner <- parseShardsMap shards + pure (ixn, inner) + +-- | Parse the shard-number-keyed map. The shard number is kept as +-- 'Text' because ES documents it as a string and uses non-numeric +-- suffixes for relocating copies in some responses. +parseShardsMap :: + Value -> + Parser (M.Map Text [IndexSegmentsShard]) +parseShardsMap = withObject "IndexSegments.shards map" parse + where + parse o = M.fromList <$> traverse parseEntry (X.toList o) + parseEntry (k, v) = do + entries <- parseJSON v + pure (toText k, entries) + +instance FromJSON IndexSegmentsShard where + parseJSON = withObject "IndexSegmentsShard" parse + where + parse o = + IndexSegmentsShard + <$> o .: "routing" + <*> o .:? "num_committed_segments" .!= 0 + <*> o .:? "num_search_segments" .!= 0 + <*> o .:? "segments" .!= mempty + +instance FromJSON SegmentRouting where + parseJSON = withObject "SegmentRouting" parse + where + parse o = + SegmentRouting + <$> o .:? "state" + <*> o .:? "primary" .!= False + <*> o .:? "node" + <*> o .:? "relocating_node" + +instance FromJSON SegmentInfo where + parseJSON = withObject "SegmentInfo" parse + where + knownKeys = + [ "generation", + "num_docs", + "deleted_docs", + "size_in_bytes", + "memory_in_bytes", + "committed", + "search", + "version", + "compound", + "attributes" + ] + parse o = do + generation <- o .:? "generation" .!= 0 + numDocs <- o .:? "num_docs" .!= 0 + deletedDocs <- o .:? "deleted_docs" .!= 0 + sizeInBytes <- o .:? "size_in_bytes" .!= 0 + memoryInBytes <- o .:? "memory_in_bytes" + committed <- o .:? "committed" .!= False + search <- o .:? "search" .!= False + version <- o .:? "version" + compound <- o .:? "compound" + attributes <- o .:? "attributes" + -- Anything outside the promoted keys is preserved verbatim so + -- ES-8+/9+ fields (segment_sort, vector_dimension, rank_positions, + -- lucene_version, tier_size_in_bytes, ...) survive round-trip. + let other = + case X.filterWithKey (\k _ -> toText k `notElem` knownKeys) o of + km | X.null km -> Nothing + km -> Just (Object km) + pure $ + SegmentInfo + generation + numDocs + deletedDocs + sizeInBytes + memoryInBytes + committed + search + version + compound + attributes + other + +-- * Shard Stores + +-- +-- Response and option shapes for @GET /{index}/_shard_stores@ +-- ( +-- and +-- ). +-- +-- The endpoint returns the store information for every shard copy of +-- the requested index (or every index when no target is supplied), +-- describing where each copy lives (node id + node metadata), its +-- allocation id and its allocation state +-- ('ShardStoreAllocationPrimary' \/ 'ShardStoreAllocationReplica' \/ +-- 'ShardStoreAllocationUnavailable'). The wire shape is identical +-- between ES and OpenSearch; ES additionally emits richer per-node +-- fields (@external_id@, @roles@, @version@, @min_index_version@, +-- @max_index_version@) which are typed here, with anything else +-- preserved verbatim in 'shardStoreNodeOther' (mirroring 'segmentOther'). + +-- | Top-level envelope of the @GET /{index}/_shard_stores@ response. +-- The outer map is keyed by index name (parsed through 'IndexName'\'s +-- 'FromJSON' instance, the lenient validator that accepts hidden +-- indices like @.kibana@, matching 'IndexSegments' and 'IndexRecovery'). +-- The inner map is keyed by shard number as a string (kept as 'Text' +-- because ES documents it as a string and uses non-numeric suffixes +-- for relocating copies in some responses). +data ShardStores = ShardStores + { shardStoresShards :: ShardResult, + shardStoresIndices :: M.Map IndexName (M.Map Text ShardStoresShard) + } + deriving stock (Eq, Show) + +shardStoresShardsLens :: Lens' ShardStores ShardResult +shardStoresShardsLens = + lens shardStoresShards (\x y -> x {shardStoresShards = y}) + +shardStoresIndicesLens :: + Lens' ShardStores (M.Map IndexName (M.Map Text ShardStoresShard)) +shardStoresIndicesLens = + lens shardStoresIndices (\x y -> x {shardStoresIndices = y}) + +-- | Per-shard wrapper inside a 'ShardStores' response. ES reports +-- every copy of a shard (primary and each replica) under the same +-- shard number, collected in 'shardStoresShardStores'. A shard with +-- no assigned copy stores emits an empty list. +data ShardStoresShard = ShardStoresShard + { shardStoresShardStores :: [ShardStore] + } + deriving stock (Eq, Show) + +shardStoresShardStoresLens :: Lens' ShardStoresShard [ShardStore] +shardStoresShardStoresLens = + lens shardStoresShardStores (\x y -> x {shardStoresShardStores = y}) + +-- | A single store copy. The server emits a dynamic per-node key (the +-- node id) alongside the known sibling fields ('shardStoreAllocationId', +-- 'shardStoreAllocation', 'shardStoreStoreException'); the parser peels +-- off the known keys and treats the single remaining 'Object'-valued key +-- as @(node_id, 'ShardStoreNode')@. Any other non-known entry (typically +-- a future scalar sibling field) is preserved verbatim in +-- 'shardStoreOther', mirroring 'segmentOther' and 'shardStoreNodeOther'. +data ShardStore = ShardStore + { shardStoreAllocationId :: Maybe Text, + shardStoreAllocation :: Maybe ShardStoreAllocation, + shardStoreNode :: Maybe (Text, ShardStoreNode), + shardStoreStoreException :: Maybe ShardStoreException, + shardStoreOther :: Maybe Value + } + deriving stock (Eq, Show) + +shardStoreAllocationIdLens :: Lens' ShardStore (Maybe Text) +shardStoreAllocationIdLens = + lens shardStoreAllocationId (\x y -> x {shardStoreAllocationId = y}) + +shardStoreAllocationLens :: Lens' ShardStore (Maybe ShardStoreAllocation) +shardStoreAllocationLens = + lens shardStoreAllocation (\x y -> x {shardStoreAllocation = y}) + +shardStoreNodeLens :: Lens' ShardStore (Maybe (Text, ShardStoreNode)) +shardStoreNodeLens = + lens shardStoreNode (\x y -> x {shardStoreNode = y}) + +shardStoreStoreExceptionLens :: Lens' ShardStore (Maybe ShardStoreException) +shardStoreStoreExceptionLens = + lens shardStoreStoreException (\x y -> x {shardStoreStoreException = y}) + +shardStoreOtherLens :: Lens' ShardStore (Maybe Value) +shardStoreOtherLens = + lens shardStoreOther (\x y -> x {shardStoreOther = y}) + +-- | Per-node metadata attached to each store copy. ES emits a richer +-- set of fields than OpenSearch (which only documents @name@, +-- @ephemeral_id@, @transport_address@ and @attributes@); the typed +-- subset below is the union of both, with anything else preserved +-- verbatim in 'shardStoreNodeOther' (mirroring 'segmentOther'). +data ShardStoreNode = ShardStoreNode + { shardStoreNodeName :: Maybe Text, + shardStoreNodeEphemeralId :: Maybe Text, + shardStoreNodeTransportAddress :: Maybe Text, + shardStoreNodeExternalId :: Maybe Text, + shardStoreNodeAttributes :: Maybe (M.Map Text Text), + shardStoreNodeRoles :: Maybe [Text], + shardStoreNodeVersion :: Maybe Text, + shardStoreNodeMinIndexVersion :: Maybe Int, + shardStoreNodeMaxIndexVersion :: Maybe Int, + shardStoreNodeOther :: Maybe Value + } + deriving stock (Eq, Show) + +shardStoreNodeNameLens :: Lens' ShardStoreNode (Maybe Text) +shardStoreNodeNameLens = + lens shardStoreNodeName (\x y -> x {shardStoreNodeName = y}) + +shardStoreNodeEphemeralIdLens :: Lens' ShardStoreNode (Maybe Text) +shardStoreNodeEphemeralIdLens = + lens shardStoreNodeEphemeralId (\x y -> x {shardStoreNodeEphemeralId = y}) + +shardStoreNodeTransportAddressLens :: Lens' ShardStoreNode (Maybe Text) +shardStoreNodeTransportAddressLens = + lens shardStoreNodeTransportAddress (\x y -> x {shardStoreNodeTransportAddress = y}) + +shardStoreNodeExternalIdLens :: Lens' ShardStoreNode (Maybe Text) +shardStoreNodeExternalIdLens = + lens shardStoreNodeExternalId (\x y -> x {shardStoreNodeExternalId = y}) + +shardStoreNodeAttributesLens :: Lens' ShardStoreNode (Maybe (M.Map Text Text)) +shardStoreNodeAttributesLens = + lens shardStoreNodeAttributes (\x y -> x {shardStoreNodeAttributes = y}) + +shardStoreNodeRolesLens :: Lens' ShardStoreNode (Maybe [Text]) +shardStoreNodeRolesLens = + lens shardStoreNodeRoles (\x y -> x {shardStoreNodeRoles = y}) + +shardStoreNodeVersionLens :: Lens' ShardStoreNode (Maybe Text) +shardStoreNodeVersionLens = + lens shardStoreNodeVersion (\x y -> x {shardStoreNodeVersion = y}) + +shardStoreNodeMinIndexVersionLens :: Lens' ShardStoreNode (Maybe Int) +shardStoreNodeMinIndexVersionLens = + lens shardStoreNodeMinIndexVersion (\x y -> x {shardStoreNodeMinIndexVersion = y}) + +shardStoreNodeMaxIndexVersionLens :: Lens' ShardStoreNode (Maybe Int) +shardStoreNodeMaxIndexVersionLens = + lens shardStoreNodeMaxIndexVersion (\x y -> x {shardStoreNodeMaxIndexVersion = y}) + +shardStoreNodeOtherLens :: Lens' ShardStoreNode (Maybe Value) +shardStoreNodeOtherLens = + lens shardStoreNodeOther (\x y -> x {shardStoreNodeOther = y}) + +-- | The per-copy @allocation@ enum. Wire values are lowercase strings. +-- ES recognises three values; OpenSearch documents only +-- 'ShardStoreAllocationPrimary' and 'ShardStoreAllocationReplica'. The +-- 'ShardStoreAllocationOther' constructor preserves any future / +-- engine-specific value verbatim. +data ShardStoreAllocation + = ShardStoreAllocationPrimary + | ShardStoreAllocationReplica + | ShardStoreAllocationUnavailable + | ShardStoreAllocationOther Text + deriving stock (Eq, Show) + +-- | The optional @store_exception@ sub-object, emitted when a store +-- could not be read. OpenSearch documents @type@ and @reason@; ES +-- emits the same pair (and occasionally additional fields, preserved +-- in 'shardStoreExceptionOther'). +data ShardStoreException = ShardStoreException + { shardStoreExceptionType :: Maybe Text, + shardStoreExceptionReason :: Maybe Text, + shardStoreExceptionOther :: Maybe Value + } + deriving stock (Eq, Show) + +shardStoreExceptionTypeLens :: Lens' ShardStoreException (Maybe Text) +shardStoreExceptionTypeLens = + lens shardStoreExceptionType (\x y -> x {shardStoreExceptionType = y}) + +shardStoreExceptionReasonLens :: Lens' ShardStoreException (Maybe Text) +shardStoreExceptionReasonLens = + lens shardStoreExceptionReason (\x y -> x {shardStoreExceptionReason = y}) + +shardStoreExceptionOtherLens :: Lens' ShardStoreException (Maybe Value) +shardStoreExceptionOtherLens = + lens shardStoreExceptionOther (\x y -> x {shardStoreExceptionOther = y}) + +instance FromJSON ShardStores where + parseJSON = withObject "ShardStores" $ \o -> do + -- _shards is documented by every backend but is omitted by some + -- OpenSearch builds on single-index responses; we mirror the + -- defensive parse used by IndexSegments / IndexStats. + shards <- o .:? "_shards" .!= defaultShardResult + indicesVal <- o .:? "indices" .!= Object mempty + indices <- parseShardStoresIndicesMap indicesVal + pure $ ShardStores shards indices + +-- | Parse the @indices@ sub-object of a shard stores response. The +-- keys are index names echoed back by the server; they are parsed +-- through 'IndexName'\'s 'FromJSON' instance (the lenient validator +-- that accepts hidden indices like @.kibana@), matching 'IndexStats' +-- and 'IndexRecovery'. +parseShardStoresIndicesMap :: + Value -> + Parser (M.Map IndexName (M.Map Text ShardStoresShard)) +parseShardStoresIndicesMap = withObject "ShardStores.indices" parse + where + parse o = M.fromList <$> traverse parseEntry (X.toList o) + parseEntry (k, v) = do + ixn <- parseJSON (toJSON k) + shards <- withObject "ShardStores.shards" (.: "shards") v + inner <- parseShardStoresShardsMap shards + pure (ixn, inner) + +-- | Parse the shard-number-keyed map. The shard number is kept as +-- 'Text' because ES documents it as a string and uses non-numeric +-- suffixes for relocating copies in some responses. +parseShardStoresShardsMap :: + Value -> + Parser (M.Map Text ShardStoresShard) +parseShardStoresShardsMap = withObject "ShardStores.shards map" parse + where + parse o = M.fromList <$> traverse parseEntry (X.toList o) + parseEntry (k, v) = do + entry <- parseJSON v + pure (toText k, entry) + +instance FromJSON ShardStoresShard where + parseJSON = withObject "ShardStoresShard" parse + where + parse o = ShardStoresShard <$> o .:? "stores" .!= [] + +instance FromJSON ShardStore where + parseJSON = withObject "ShardStore" parse + where + knownKeys = ["allocation_id", "allocation", "store_exception"] + parse o = do + allocationId <- o .:? "allocation_id" + allocation <- o .:? "allocation" + storeException <- o .:? "store_exception" + -- The node copy is the single 'Object'-valued dynamic key (its + -- value is always the node metadata object, while + -- @allocation_id@\/@allocation@ are scalars and + -- @store_exception@ is already in @knownKeys@). Any other + -- non-known entry (typically a future scalar sibling field) is + -- preserved verbatim in 'shardStoreOther' so a future ES\/OS + -- addition does not break the parser. + let nonKnown = + X.filterWithKey (\k _ -> toText k `notElem` knownKeys) o + partitionEntry (k, v) = case v of + Object _ -> Left (k, v) + _ -> Right (k, v) + partitioned = foldr step ([], []) (map partitionEntry (X.toList nonKnown)) + step (Left x) (os, ss) = (x : os, ss) + step (Right x) (os, ss) = (os, x : ss) + (objectEntries, scalarEntries) = partitioned + node <- case objectEntries of + [] -> pure Nothing + [(k, v)] -> Just . (toText k,) <$> parseJSON v + _ -> + fail $ + "ShardStore: expected 0 or 1 node entry, got " + <> show (length objectEntries) + let other = + case scalarEntries of + [] -> Nothing + _ -> Just (Object (X.fromList scalarEntries)) + pure $ ShardStore allocationId allocation node storeException other + +instance ToJSON ShardStoreAllocation where + toJSON ShardStoreAllocationPrimary = String "primary" + toJSON ShardStoreAllocationReplica = String "replica" + toJSON ShardStoreAllocationUnavailable = String "unavailable" + toJSON (ShardStoreAllocationOther t) = String t + +instance FromJSON ShardStoreAllocation where + parseJSON (String "primary") = pure ShardStoreAllocationPrimary + parseJSON (String "replica") = pure ShardStoreAllocationReplica + parseJSON (String "unavailable") = pure ShardStoreAllocationUnavailable + parseJSON (String other) = pure $ ShardStoreAllocationOther other + parseJSON other = typeMismatch "ShardStoreAllocation" other + +instance FromJSON ShardStoreNode where + parseJSON = withObject "ShardStoreNode" parse + where + knownKeys = + [ "name", + "ephemeral_id", + "transport_address", + "external_id", + "attributes", + "roles", + "version", + "min_index_version", + "max_index_version" + ] + parse o = do + name <- o .:? "name" + ephemeralId <- o .:? "ephemeral_id" + transportAddress <- o .:? "transport_address" + externalId <- o .:? "external_id" + attributes <- o .:? "attributes" + roles <- o .:? "roles" + version <- o .:? "version" + minIndexVersion <- o .:? "min_index_version" + maxIndexVersion <- o .:? "max_index_version" + let other = + case X.filterWithKey (\k _ -> toText k `notElem` knownKeys) o of + km | X.null km -> Nothing + km -> Just (Object km) + pure $ + ShardStoreNode + name + ephemeralId + transportAddress + externalId + attributes + roles + version + minIndexVersion + maxIndexVersion + other + +instance FromJSON ShardStoreException where + parseJSON = withObject "ShardStoreException" parse + where + knownKeys = ["type", "reason"] + parse o = do + ty <- o .:? "type" + reason <- o .:? "reason" + let other = + case X.filterWithKey (\k _ -> toText k `notElem` knownKeys) o of + km | X.null km -> Nothing + km -> Just (Object km) + pure $ ShardStoreException ty reason other + +-- * Shard Stores options + +-- | The @status@ URI parameter accepted by @GET /{index}/_shard_stores@. +-- Filters the returned shard stores by cluster health of the shard +-- copy. Wire values are lowercase strings. The server-side default is +-- @yellow,red@ (i.e. only shards that are unassigned or have one or +-- more unassigned replica shards) — see +-- . +data ShardStoresStatus + = ShardStoresStatusGreen + | ShardStoresStatusYellow + | ShardStoresStatusRed + | ShardStoresStatusAll + deriving stock (Eq, Show) + +-- | Wire rendering of a single 'ShardStoresStatus' value. Used by both +-- 'ToJSON' and 'shardStoresOptionsParams' so there is a single source +-- of truth for the string. +shardStoresStatusText :: ShardStoresStatus -> Text +shardStoresStatusText ShardStoresStatusGreen = "green" +shardStoresStatusText ShardStoresStatusYellow = "yellow" +shardStoresStatusText ShardStoresStatusRed = "red" +shardStoresStatusText ShardStoresStatusAll = "all" + +instance ToJSON ShardStoresStatus where + toJSON = String . shardStoresStatusText + +instance FromJSON ShardStoresStatus where + parseJSON (String "green") = pure ShardStoresStatusGreen + parseJSON (String "yellow") = pure ShardStoresStatusYellow + parseJSON (String "red") = pure ShardStoresStatusRed + parseJSON (String "all") = pure ShardStoresStatusAll + parseJSON other = typeMismatch "ShardStoresStatus" other + +-- | URI parameters accepted by @GET /{index}/_shard_stores@. The four +-- documented parameters are modelled: @status@ (cluster-health filter, +-- comma-joined on the wire), @ignore_unavailable@, @allow_no_indices@ +-- and @expand_wildcards@ (comma-joined). Every field is optional so +-- 'defaultShardStoresOptions' renders to no query string at all — +-- byte-for-byte identical to a parameterless call. +-- +-- @expand_wildcards@ reuses 'ExpandWildcards' (matching +-- 'ResolveIndexOptions', 'OpenCloseIndexOptions' and friends); @status@ +-- is a list because the server accepts a comma-separated combination +-- (e.g. @[ShardStoresStatusYellow, ShardStoresStatusRed]@, the +-- server-side default). +data ShardStoresOptions = ShardStoresOptions + { ssoStatus :: Maybe (NonEmpty ShardStoresStatus), + ssoIgnoreUnavailable :: Maybe Bool, + ssoAllowNoIndices :: Maybe Bool, + ssoExpandWildcards :: Maybe (NonEmpty ExpandWildcards) + } + deriving stock (Eq, Show) + +-- | 'ShardStoresOptions' with every parameter set to 'Nothing'. Produces +-- no query string, so @'getShardStoresWith' 'defaultShardStoresOptions'@ +-- emits a request byte-for-byte identical to 'getShardStores'. +defaultShardStoresOptions :: ShardStoresOptions +defaultShardStoresOptions = + ShardStoresOptions + { ssoStatus = Nothing, + ssoIgnoreUnavailable = Nothing, + ssoAllowNoIndices = Nothing, + ssoExpandWildcards = Nothing + } + +ssoStatusLens :: Lens' ShardStoresOptions (Maybe (NonEmpty ShardStoresStatus)) +ssoStatusLens = lens ssoStatus (\x y -> x {ssoStatus = y}) + +ssoIgnoreUnavailableLens :: Lens' ShardStoresOptions (Maybe Bool) +ssoIgnoreUnavailableLens = + lens ssoIgnoreUnavailable (\x y -> x {ssoIgnoreUnavailable = y}) + +ssoAllowNoIndicesLens :: Lens' ShardStoresOptions (Maybe Bool) +ssoAllowNoIndicesLens = + lens ssoAllowNoIndices (\x y -> x {ssoAllowNoIndices = y}) + +ssoExpandWildcardsLens :: + Lens' ShardStoresOptions (Maybe (NonEmpty ExpandWildcards)) +ssoExpandWildcardsLens = + lens ssoExpandWildcards (\x y -> x {ssoExpandWildcards = y}) + +-- | Render 'ShardStoresOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultShardStoresOptions' produces an empty list (and therefore no +-- query string). +shardStoresOptionsParams :: ShardStoresOptions -> [(Text, Maybe Text)] +shardStoresOptionsParams opts = + catMaybes + [ ("status",) . Just . renderStatus <$> ssoStatus opts, + ("ignore_unavailable",) . Just . renderBool <$> ssoIgnoreUnavailable opts, + ("allow_no_indices",) . Just . renderBool <$> ssoAllowNoIndices opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> ssoExpandWildcards opts + ] + where + renderStatus = T.intercalate "," . map shardStoresStatusText . toList + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + renderBool True = "true" + renderBool False = "false" + +-- * Resolve Index + +-- +-- Response and option shapes for @GET /_resolve/index\/{name}@ +-- ( +-- and +-- ). +-- +-- The endpoint resolves one or more comma-separated index patterns (or +-- literal names, aliases, or @\:\@ remote-cluster +-- references) into the concrete indices, aliases and data streams they +-- expand to. It is available on every supported backend (ES 7.9+, +-- OpenSearch 1.0+); the wire format modelled here is the lowest common +-- denominator, with the ES-9-only @data_stream@ and @mode@ fields on +-- each index entry kept as 'Maybe' so the same parser works on every +-- version. + +-- | URI parameters accepted by @GET /_resolve/index@. Only +-- @expand_wildcards@ is documented by every backend (ES 7.17, ES 8.x, +-- ES 9.x, OpenSearch); @ignore_unavailable@ and @allow_no_indices@ are +-- documented by ES 8.x\/9.x but accepted (undocumented) by OpenSearch. +-- The deprecated ES-7.x-only @ignore_throttled@ and the ES-9.2-only +-- @mode@ parameters are not modelled here. +-- +-- @expand_wildcards@ is a list because the server accepts a +-- comma-separated combination (e.g. +-- @[ExpandWildcardsOpen, ExpandWildcardsHidden]@). Note that +-- 'ExpandWildcardsHidden' must be combined with 'ExpandWildcardsOpen' +-- and\/or 'ExpandWildcardsClosed' — the server rejects a bare +-- @hidden@. +data ResolveIndexOptions = ResolveIndexOptions + { rioExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + rioIgnoreUnavailable :: Maybe Bool, + rioAllowNoIndices :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'ResolveIndexOptions' with every parameter set to 'Nothing'. Produces +-- no query string, so a call made with this value is byte-identical to a +-- parameterless call. +defaultResolveIndexOptions :: ResolveIndexOptions +defaultResolveIndexOptions = + ResolveIndexOptions + { rioExpandWildcards = Nothing, + rioIgnoreUnavailable = Nothing, + rioAllowNoIndices = Nothing + } + +rioExpandWildcardsLens :: Lens' ResolveIndexOptions (Maybe (NonEmpty ExpandWildcards)) +rioExpandWildcardsLens = lens rioExpandWildcards (\x y -> x {rioExpandWildcards = y}) + +rioIgnoreUnavailableLens :: Lens' ResolveIndexOptions (Maybe Bool) +rioIgnoreUnavailableLens = lens rioIgnoreUnavailable (\x y -> x {rioIgnoreUnavailable = y}) + +rioAllowNoIndicesLens :: Lens' ResolveIndexOptions (Maybe Bool) +rioAllowNoIndicesLens = lens rioAllowNoIndices (\x y -> x {rioAllowNoIndices = y}) + +-- | Render 'ResolveIndexOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultResolveIndexOptions' produces an empty list (and therefore no +-- query string). +resolveIndexOptionsParams :: ResolveIndexOptions -> [(Text, Maybe Text)] +resolveIndexOptionsParams opts = + catMaybes + [ ("expand_wildcards",) . Just . renderExpandWildcards <$> rioExpandWildcards opts, + ("ignore_unavailable",) . Just . renderBool <$> rioIgnoreUnavailable opts, + ("allow_no_indices",) . Just . renderBool <$> rioAllowNoIndices opts + ] + where + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + renderBool True = "true" + renderBool False = "false" + +-- | URI parameters accepted by @POST //_open@ and +-- @POST //_close@ +-- (). +-- All six documented parameters are modelled: @wait_for_active_shards@, +-- @ignore_unavailable@, @allow_no_indices@, @expand_wildcards@, +-- @master_timeout@ (deprecated alias @cluster_manager_timeout@ on ES +-- 7.16+\/OS) and @timeout@. Every field is optional so +-- 'defaultOpenCloseIndexOptions' renders to no query string at all — +-- byte-for-byte identical to the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.openIndex' \/ 'closeIndex'. +-- +-- @wait_for_active_shards@ reuses 'ActiveShardCount' (so 'AllActiveShards' +-- renders as @all@ and @'ActiveShards' n@ as the bare decimal), matching +-- the convention used by +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cluster.ClusterHealthOptions' +-- and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Indices.CreateIndexOptions'. +-- Durations are @(unit, magnitude)@ pairs (e.g. @('TimeUnitSeconds', 30)@ +-- renders as @30s@). +data OpenCloseIndexOptions = OpenCloseIndexOptions + { ocioWaitForActiveShards :: Maybe ActiveShardCount, + ocioIgnoreUnavailable :: Maybe Bool, + ocioAllowNoIndices :: Maybe Bool, + ocioExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + ocioMasterTimeout :: Maybe (TimeUnits, Word32), + ocioTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'OpenCloseIndexOptions' with every parameter set to 'Nothing'. Produces +-- no query string, so @'openIndexWith' 'defaultOpenCloseIndexOptions'@ and +-- @'closeIndexWith' 'defaultOpenCloseIndexOptions'@ emit requests identical +-- to 'openIndex' and 'closeIndex'. +defaultOpenCloseIndexOptions :: OpenCloseIndexOptions +defaultOpenCloseIndexOptions = + OpenCloseIndexOptions + { ocioWaitForActiveShards = Nothing, + ocioIgnoreUnavailable = Nothing, + ocioAllowNoIndices = Nothing, + ocioExpandWildcards = Nothing, + ocioMasterTimeout = Nothing, + ocioTimeout = Nothing + } + +ocioWaitForActiveShardsLens :: Lens' OpenCloseIndexOptions (Maybe ActiveShardCount) +ocioWaitForActiveShardsLens = lens ocioWaitForActiveShards (\x y -> x {ocioWaitForActiveShards = y}) + +ocioIgnoreUnavailableLens :: Lens' OpenCloseIndexOptions (Maybe Bool) +ocioIgnoreUnavailableLens = lens ocioIgnoreUnavailable (\x y -> x {ocioIgnoreUnavailable = y}) + +ocioAllowNoIndicesLens :: Lens' OpenCloseIndexOptions (Maybe Bool) +ocioAllowNoIndicesLens = lens ocioAllowNoIndices (\x y -> x {ocioAllowNoIndices = y}) + +ocioExpandWildcardsLens :: Lens' OpenCloseIndexOptions (Maybe (NonEmpty ExpandWildcards)) +ocioExpandWildcardsLens = lens ocioExpandWildcards (\x y -> x {ocioExpandWildcards = y}) + +ocioMasterTimeoutLens :: Lens' OpenCloseIndexOptions (Maybe (TimeUnits, Word32)) +ocioMasterTimeoutLens = lens ocioMasterTimeout (\x y -> x {ocioMasterTimeout = y}) + +ocioTimeoutLens :: Lens' OpenCloseIndexOptions (Maybe (TimeUnits, Word32)) +ocioTimeoutLens = lens ocioTimeout (\x y -> x {ocioTimeout = y}) + +-- | Render 'OpenCloseIndexOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultOpenCloseIndexOptions' produces an empty list (and therefore no +-- query string). +openCloseIndexOptionsParams :: OpenCloseIndexOptions -> [(Text, Maybe Text)] +openCloseIndexOptionsParams opts = + catMaybes + [ ("wait_for_active_shards",) . Just . renderActiveShardCount <$> ocioWaitForActiveShards opts, + ("ignore_unavailable",) . Just . renderBool <$> ocioIgnoreUnavailable opts, + ("allow_no_indices",) . Just . renderBool <$> ocioAllowNoIndices opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> ocioExpandWildcards opts, + ("master_timeout",) . Just . renderDuration <$> ocioMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> ocioTimeout opts + ] + where + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +-- | URI parameters accepted by @PUT //_mapping@ +-- (). +-- All six documented parameters are modelled: @allow_no_indices@, +-- @expand_wildcards@ (comma-joined on the wire), @ignore_unavailable@, +-- @master_timeout@, @timeout@ and @write_index_only@. Every field is +-- optional so 'defaultPutMappingOptions' renders to no query string at +-- all — byte-for-byte identical to the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.putMapping'. Durations are +-- @(unit, magnitude)@ pairs (e.g. @('TimeUnitSeconds', 30)@ renders as +-- @30s@), matching 'OpenCloseIndexOptions'. +data PutMappingOptions = PutMappingOptions + { pmoAllowNoIndices :: Maybe Bool, + pmoExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + pmoIgnoreUnavailable :: Maybe Bool, + pmoMasterTimeout :: Maybe (TimeUnits, Word32), + pmoTimeout :: Maybe (TimeUnits, Word32), + pmoWriteIndexOnly :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'PutMappingOptions' with every parameter set to 'Nothing'. Produces +-- no query string, so @'putMappingWith' 'defaultPutMappingOptions'@ +-- emits a request identical to 'putMapping'. +defaultPutMappingOptions :: PutMappingOptions +defaultPutMappingOptions = + PutMappingOptions + { pmoAllowNoIndices = Nothing, + pmoExpandWildcards = Nothing, + pmoIgnoreUnavailable = Nothing, + pmoMasterTimeout = Nothing, + pmoTimeout = Nothing, + pmoWriteIndexOnly = Nothing + } + +pmoAllowNoIndicesLens :: Lens' PutMappingOptions (Maybe Bool) +pmoAllowNoIndicesLens = lens pmoAllowNoIndices (\x y -> x {pmoAllowNoIndices = y}) + +pmoExpandWildcardsLens :: Lens' PutMappingOptions (Maybe (NonEmpty ExpandWildcards)) +pmoExpandWildcardsLens = lens pmoExpandWildcards (\x y -> x {pmoExpandWildcards = y}) + +pmoIgnoreUnavailableLens :: Lens' PutMappingOptions (Maybe Bool) +pmoIgnoreUnavailableLens = lens pmoIgnoreUnavailable (\x y -> x {pmoIgnoreUnavailable = y}) + +pmoMasterTimeoutLens :: Lens' PutMappingOptions (Maybe (TimeUnits, Word32)) +pmoMasterTimeoutLens = lens pmoMasterTimeout (\x y -> x {pmoMasterTimeout = y}) + +pmoTimeoutLens :: Lens' PutMappingOptions (Maybe (TimeUnits, Word32)) +pmoTimeoutLens = lens pmoTimeout (\x y -> x {pmoTimeout = y}) + +pmoWriteIndexOnlyLens :: Lens' PutMappingOptions (Maybe Bool) +pmoWriteIndexOnlyLens = lens pmoWriteIndexOnly (\x y -> x {pmoWriteIndexOnly = y}) + +-- | Render 'PutMappingOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultPutMappingOptions' produces an empty list (and therefore no +-- query string). +putMappingOptionsParams :: PutMappingOptions -> [(Text, Maybe Text)] +putMappingOptionsParams opts = + catMaybes + [ ("allow_no_indices",) . Just . renderBool <$> pmoAllowNoIndices opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> pmoExpandWildcards opts, + ("ignore_unavailable",) . Just . renderBool <$> pmoIgnoreUnavailable opts, + ("master_timeout",) . Just . renderDuration <$> pmoMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> pmoTimeout opts, + ("write_index_only",) . Just . renderBool <$> pmoWriteIndexOnly opts + ] + where + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +-- | URI parameters accepted by @POST //_flush@ +-- (). +-- All five documented parameters are modelled: @wait_if_ongoing@, @force@, +-- @ignore_unavailable@, @allow_no_indices@ and @expand_wildcards@. Every +-- field is optional so 'defaultFlushIndexOptions' renders to no query +-- string — byte-for-byte identical to the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.flushIndex'. +data FlushIndexOptions = FlushIndexOptions + { fioWaitIfOngoing :: Maybe Bool, + fioForce :: Maybe Bool, + fioIgnoreUnavailable :: Maybe Bool, + fioAllowNoIndices :: Maybe Bool, + fioExpandWildcards :: Maybe (NonEmpty ExpandWildcards) + } + deriving stock (Eq, Show) + +-- | 'FlushIndexOptions' with every parameter set to 'Nothing'. Produces +-- no query string, so @'flushIndexWith' 'defaultFlushIndexOptions'@ emits a +-- request identical to 'flushIndex'. +defaultFlushIndexOptions :: FlushIndexOptions +defaultFlushIndexOptions = + FlushIndexOptions + { fioWaitIfOngoing = Nothing, + fioForce = Nothing, + fioIgnoreUnavailable = Nothing, + fioAllowNoIndices = Nothing, + fioExpandWildcards = Nothing + } + +fioWaitIfOngoingLens :: Lens' FlushIndexOptions (Maybe Bool) +fioWaitIfOngoingLens = lens fioWaitIfOngoing (\x y -> x {fioWaitIfOngoing = y}) + +fioForceLens :: Lens' FlushIndexOptions (Maybe Bool) +fioForceLens = lens fioForce (\x y -> x {fioForce = y}) + +fioIgnoreUnavailableLens :: Lens' FlushIndexOptions (Maybe Bool) +fioIgnoreUnavailableLens = lens fioIgnoreUnavailable (\x y -> x {fioIgnoreUnavailable = y}) + +fioAllowNoIndicesLens :: Lens' FlushIndexOptions (Maybe Bool) +fioAllowNoIndicesLens = lens fioAllowNoIndices (\x y -> x {fioAllowNoIndices = y}) + +fioExpandWildcardsLens :: Lens' FlushIndexOptions (Maybe (NonEmpty ExpandWildcards)) +fioExpandWildcardsLens = lens fioExpandWildcards (\x y -> x {fioExpandWildcards = y}) + +-- | Render 'FlushIndexOptions' as a list of @(key, value)@ pairs suitable +-- for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultFlushIndexOptions' produces an empty list (and therefore no +-- query string). +flushIndexOptionsParams :: FlushIndexOptions -> [(Text, Maybe Text)] +flushIndexOptionsParams opts = + catMaybes + [ ("wait_if_ongoing",) . Just . renderBool <$> fioWaitIfOngoing opts, + ("force",) . Just . renderBool <$> fioForce opts, + ("ignore_unavailable",) . Just . renderBool <$> fioIgnoreUnavailable opts, + ("allow_no_indices",) . Just . renderBool <$> fioAllowNoIndices opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> fioExpandWildcards opts + ] + where + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + renderBool True = "true" + renderBool False = "false" + +-- | URI parameters accepted by @POST //_refresh@ +-- (). +-- The four documented parameters are modelled: @ignore_unavailable@, +-- @allow_no_indices@, @expand_wildcards@ and @force@. (@force@ has been a +-- no-op since ES 2.1 but is still accepted by every backend, so it is +-- surfaced for completeness.) Every field is optional so +-- 'defaultRefreshIndexOptions' renders to no query string — +-- byte-for-byte identical to the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.refreshIndex'. +data RefreshIndexOptions = RefreshIndexOptions + { rfioIgnoreUnavailable :: Maybe Bool, + rfioAllowNoIndices :: Maybe Bool, + rfioExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + rfioForce :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'RefreshIndexOptions' with every parameter set to 'Nothing'. Produces +-- no query string, so @'refreshIndexWith' 'defaultRefreshIndexOptions'@ +-- emits a request identical to 'refreshIndex'. +defaultRefreshIndexOptions :: RefreshIndexOptions +defaultRefreshIndexOptions = + RefreshIndexOptions + { rfioIgnoreUnavailable = Nothing, + rfioAllowNoIndices = Nothing, + rfioExpandWildcards = Nothing, + rfioForce = Nothing + } + +rfioIgnoreUnavailableLens :: Lens' RefreshIndexOptions (Maybe Bool) +rfioIgnoreUnavailableLens = lens rfioIgnoreUnavailable (\x y -> x {rfioIgnoreUnavailable = y}) + +rfioAllowNoIndicesLens :: Lens' RefreshIndexOptions (Maybe Bool) +rfioAllowNoIndicesLens = lens rfioAllowNoIndices (\x y -> x {rfioAllowNoIndices = y}) + +rfioExpandWildcardsLens :: Lens' RefreshIndexOptions (Maybe (NonEmpty ExpandWildcards)) +rfioExpandWildcardsLens = lens rfioExpandWildcards (\x y -> x {rfioExpandWildcards = y}) + +rfioForceLens :: Lens' RefreshIndexOptions (Maybe Bool) +rfioForceLens = lens rfioForce (\x y -> x {rfioForce = y}) + +-- | Render 'RefreshIndexOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultRefreshIndexOptions' produces an empty list (and therefore no +-- query string). +refreshIndexOptionsParams :: RefreshIndexOptions -> [(Text, Maybe Text)] +refreshIndexOptionsParams opts = + catMaybes + [ ("ignore_unavailable",) . Just . renderBool <$> rfioIgnoreUnavailable opts, + ("allow_no_indices",) . Just . renderBool <$> rfioAllowNoIndices opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> rfioExpandWildcards opts, + ("force",) . Just . renderBool <$> rfioForce opts + ] + where + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + renderBool True = "true" + renderBool False = "false" + +-- | URI parameters accepted by @PUT //_settings@ +-- (). +-- The four documented parameters are modelled: @master_timeout@, +-- @timeout@, @preserve_existing@ and @flat_settings@. Every field is +-- optional so 'defaultUpdateIndexSettingsOptions' renders to no query +-- string — byte-for-byte identical to the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.updateIndexSettings'. Durations +-- are @(unit, magnitude)@ pairs (e.g. @('TimeUnitSeconds', 30)@ renders +-- as @30s@), matching 'OpenCloseIndexOptions'. +data UpdateIndexSettingsOptions = UpdateIndexSettingsOptions + { uisoMasterTimeout :: Maybe (TimeUnits, Word32), + uisoTimeout :: Maybe (TimeUnits, Word32), + uisoPreserveExisting :: Maybe Bool, + uisoFlatSettings :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'UpdateIndexSettingsOptions' with every parameter set to 'Nothing'. +-- Produces no query string, so @'updateIndexSettingsWith' updates name +-- 'defaultUpdateIndexSettingsOptions'@ emits a request identical to +-- 'Database.Bloodhound.Common.Requests.updateIndexSettings'. +defaultUpdateIndexSettingsOptions :: UpdateIndexSettingsOptions +defaultUpdateIndexSettingsOptions = + UpdateIndexSettingsOptions + { uisoMasterTimeout = Nothing, + uisoTimeout = Nothing, + uisoPreserveExisting = Nothing, + uisoFlatSettings = Nothing + } + +uisoMasterTimeoutLens :: Lens' UpdateIndexSettingsOptions (Maybe (TimeUnits, Word32)) +uisoMasterTimeoutLens = lens uisoMasterTimeout (\x y -> x {uisoMasterTimeout = y}) + +uisoTimeoutLens :: Lens' UpdateIndexSettingsOptions (Maybe (TimeUnits, Word32)) +uisoTimeoutLens = lens uisoTimeout (\x y -> x {uisoTimeout = y}) + +uisoPreserveExistingLens :: Lens' UpdateIndexSettingsOptions (Maybe Bool) +uisoPreserveExistingLens = lens uisoPreserveExisting (\x y -> x {uisoPreserveExisting = y}) + +uisoFlatSettingsLens :: Lens' UpdateIndexSettingsOptions (Maybe Bool) +uisoFlatSettingsLens = lens uisoFlatSettings (\x y -> x {uisoFlatSettings = y}) + +-- | Render 'UpdateIndexSettingsOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultUpdateIndexSettingsOptions' produces an empty list (and +-- therefore no query string). +updateIndexSettingsOptionsParams :: UpdateIndexSettingsOptions -> [(Text, Maybe Text)] +updateIndexSettingsOptionsParams opts = + catMaybes + [ ("master_timeout",) . Just . renderDuration <$> uisoMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> uisoTimeout opts, + ("preserve_existing",) . Just . renderBool <$> uisoPreserveExisting opts, + ("flat_settings",) . Just . renderBool <$> uisoFlatSettings opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +-- | URI parameters accepted by @GET //_settings@ +-- (). +-- The four documented parameters are modelled: @master_timeout@, +-- @flat_settings@, @include_defaults@ and @local@. Every field is +-- optional so 'defaultGetIndexSettingsOptions' renders to no query +-- string — byte-for-byte identical to the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.getIndexSettings'. Durations are +-- @(unit, magnitude)@ pairs (e.g. @('TimeUnitSeconds', 30)@ renders as +-- @30s@), matching 'OpenCloseIndexOptions'. +data GetIndexSettingsOptions = GetIndexSettingsOptions + { gisoMasterTimeout :: Maybe (TimeUnits, Word32), + gisoFlatSettings :: Maybe Bool, + gisoIncludeDefaults :: Maybe Bool, + gisoLocal :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'GetIndexSettingsOptions' with every parameter set to 'Nothing'. +-- Produces no query string, so @'getIndexSettingsWith' name +-- 'defaultGetIndexSettingsOptions'@ emits a request identical to +-- 'Database.Bloodhound.Common.Requests.getIndexSettings'. +defaultGetIndexSettingsOptions :: GetIndexSettingsOptions +defaultGetIndexSettingsOptions = + GetIndexSettingsOptions + { gisoMasterTimeout = Nothing, + gisoFlatSettings = Nothing, + gisoIncludeDefaults = Nothing, + gisoLocal = Nothing + } + +gisoMasterTimeoutLens :: Lens' GetIndexSettingsOptions (Maybe (TimeUnits, Word32)) +gisoMasterTimeoutLens = lens gisoMasterTimeout (\x y -> x {gisoMasterTimeout = y}) + +gisoFlatSettingsLens :: Lens' GetIndexSettingsOptions (Maybe Bool) +gisoFlatSettingsLens = lens gisoFlatSettings (\x y -> x {gisoFlatSettings = y}) + +gisoIncludeDefaultsLens :: Lens' GetIndexSettingsOptions (Maybe Bool) +gisoIncludeDefaultsLens = lens gisoIncludeDefaults (\x y -> x {gisoIncludeDefaults = y}) + +gisoLocalLens :: Lens' GetIndexSettingsOptions (Maybe Bool) +gisoLocalLens = lens gisoLocal (\x y -> x {gisoLocal = y}) + +-- | Render 'GetIndexSettingsOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultGetIndexSettingsOptions' produces an empty list (and therefore +-- no query string). +getIndexSettingsOptionsParams :: GetIndexSettingsOptions -> [(Text, Maybe Text)] +getIndexSettingsOptionsParams opts = + catMaybes + [ ("master_timeout",) . Just . renderDuration <$> gisoMasterTimeout opts, + ("flat_settings",) . Just . renderBool <$> gisoFlatSettings opts, + ("include_defaults",) . Just . renderBool <$> gisoIncludeDefaults opts, + ("local",) . Just . renderBool <$> gisoLocal opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +-- | Top-level envelope of the @GET /_resolve/index@ response. Carries +-- the three arrays the server always returns (even when empty): +-- @indices@, @aliases@ and @data_streams@. +data ResolvedIndices = ResolvedIndices + { resolvedIndicesIndices :: [ResolvedIndex], + resolvedIndicesAliases :: [ResolvedAlias], + resolvedIndicesDataStreams :: [ResolvedDataStream] + } + deriving stock (Eq, Show) + +resolvedIndicesIndicesLens :: Lens' ResolvedIndices [ResolvedIndex] +resolvedIndicesIndicesLens = lens resolvedIndicesIndices (\x y -> x {resolvedIndicesIndices = y}) + +resolvedIndicesAliasesLens :: Lens' ResolvedIndices [ResolvedAlias] +resolvedIndicesAliasesLens = lens resolvedIndicesAliases (\x y -> x {resolvedIndicesAliases = y}) + +resolvedIndicesDataStreamsLens :: Lens' ResolvedIndices [ResolvedDataStream] +resolvedIndicesDataStreamsLens = + lens resolvedIndicesDataStreams (\x y -> x {resolvedIndicesDataStreams = y}) + +-- | One entry in the @indices@ array. The universally-present @name@ +-- and @attributes@ fields are typed; @aliases@ (the alias names that +-- point at this index) is optional and defaults to empty when absent; +-- @data_stream@ and @mode@ are ES-9.x-only and kept as 'Maybe'. +-- +-- @attributes@ is intentionally @[Text]@ rather than a sum type: the +-- documented value set differs across versions (ES 8.17 enumerates +-- @open@, @closed@, @hidden@, @system@, @frozen@; @frozen@ is removed +-- in ES 9.x; OpenSearch does not enumerate the values at all), so a +-- permissive list preserves forward compatibility. +-- +-- The remainder of the entry (any not-yet-typed field the server may +-- add) is captured verbatim in 'resolvedIndexOther' so callers can +-- navigate it with aeson. +-- +-- /Strict names/: 'resolvedIndexName' is parsed through +-- 'IndexName'\'s 'FromJSON' instance, which runs 'mkIndexNameSystem'. +-- A name that violates that validator — most realistically a +-- @\:\@ remote-cluster reference (the @:@ is +-- rejected) — fails the /entire/ 'ResolvedIndices' parse, not just +-- this entry. This matches the precedent set by 'FieldMappingResponse' +-- and 'IndexStats'. +data ResolvedIndex = ResolvedIndex + { resolvedIndexName :: IndexName, + resolvedIndexAttributes :: [Text], + resolvedIndexAliases :: [IndexAliasName], + resolvedIndexDataStream :: Maybe Text, + resolvedIndexMode :: Maybe Text, + resolvedIndexOther :: Value + } + deriving stock (Eq, Show) + +resolvedIndexNameLens :: Lens' ResolvedIndex IndexName +resolvedIndexNameLens = lens resolvedIndexName (\x y -> x {resolvedIndexName = y}) + +resolvedIndexAttributesLens :: Lens' ResolvedIndex [Text] +resolvedIndexAttributesLens = lens resolvedIndexAttributes (\x y -> x {resolvedIndexAttributes = y}) + +resolvedIndexAliasesLens :: Lens' ResolvedIndex [IndexAliasName] +resolvedIndexAliasesLens = lens resolvedIndexAliases (\x y -> x {resolvedIndexAliases = y}) + +resolvedIndexDataStreamLens :: Lens' ResolvedIndex (Maybe Text) +resolvedIndexDataStreamLens = lens resolvedIndexDataStream (\x y -> x {resolvedIndexDataStream = y}) + +resolvedIndexModeLens :: Lens' ResolvedIndex (Maybe Text) +resolvedIndexModeLens = lens resolvedIndexMode (\x y -> x {resolvedIndexMode = y}) + +resolvedIndexOtherLens :: Lens' ResolvedIndex Value +resolvedIndexOtherLens = lens resolvedIndexOther (\x y -> x {resolvedIndexOther = y}) + +-- | One entry in the @aliases@ array. @name@ is the alias; +-- @indices@ lists the concrete indices the alias resolves to. The +-- ES-9.x OpenAPI spec types @indices@ as @string | array[string]@, but +-- every documented example renders it as an array; the 'FromJSON' +-- instance below accepts both forms (a bare string is lifted to a +-- singleton list) so the same parser works regardless of backend. +data ResolvedAlias = ResolvedAlias + { resolvedAliasName :: IndexAliasName, + resolvedAliasIndices :: [IndexName], + resolvedAliasOther :: Value + } + deriving stock (Eq, Show) + +resolvedAliasNameLens :: Lens' ResolvedAlias IndexAliasName +resolvedAliasNameLens = lens resolvedAliasName (\x y -> x {resolvedAliasName = y}) + +resolvedAliasIndicesLens :: Lens' ResolvedAlias [IndexName] +resolvedAliasIndicesLens = lens resolvedAliasIndices (\x y -> x {resolvedAliasIndices = y}) + +resolvedAliasOtherLens :: Lens' ResolvedAlias Value +resolvedAliasOtherLens = lens resolvedAliasOther (\x y -> x {resolvedAliasOther = y}) + +-- | One entry in the @data_streams@ array. The ES-9.x OpenAPI spec +-- types @backing_indices@ as @string | array[string]@; as with +-- 'ResolvedAlias', the parser accepts both forms. OpenSearch's example +-- always returns an empty @data_streams@ array, so this type is +-- exercised primarily against Elasticsearch. +data ResolvedDataStream = ResolvedDataStream + { resolvedDataStreamName :: Text, + resolvedDataStreamBackingIndices :: [IndexName], + resolvedDataStreamTimestampField :: Text, + resolvedDataStreamOther :: Value + } + deriving stock (Eq, Show) + +resolvedDataStreamNameLens :: Lens' ResolvedDataStream Text +resolvedDataStreamNameLens = + lens resolvedDataStreamName (\x y -> x {resolvedDataStreamName = y}) + +resolvedDataStreamBackingIndicesLens :: Lens' ResolvedDataStream [IndexName] +resolvedDataStreamBackingIndicesLens = + lens resolvedDataStreamBackingIndices (\x y -> x {resolvedDataStreamBackingIndices = y}) + +resolvedDataStreamTimestampFieldLens :: Lens' ResolvedDataStream Text +resolvedDataStreamTimestampFieldLens = + lens resolvedDataStreamTimestampField (\x y -> x {resolvedDataStreamTimestampField = y}) + +resolvedDataStreamOtherLens :: Lens' ResolvedDataStream Value +resolvedDataStreamOtherLens = + lens resolvedDataStreamOther (\x y -> x {resolvedDataStreamOther = y}) + +instance FromJSON ResolvedIndices where + parseJSON = withObject "ResolvedIndices" parse + where + parse o = + ResolvedIndices + <$> o .:? "indices" .!= [] + <*> o .:? "aliases" .!= [] + <*> o .:? "data_streams" .!= [] + +instance FromJSON ResolvedIndex where + parseJSON = withObject "ResolvedIndex" parse + where + parse o = + ResolvedIndex + <$> o .: "name" + <*> o .:? "attributes" .!= [] + <*> o .:? "aliases" .!= [] + <*> o .:? "data_stream" + <*> o .:? "mode" + <*> pure (Object o) + +instance FromJSON ResolvedAlias where + parseJSON = withObject "ResolvedAlias" parse + where + parse o = do + name <- o .: "name" + indices <- parseStringOrArray =<< o .:? "indices" + pure $ ResolvedAlias name indices (Object o) + +instance FromJSON ResolvedDataStream where + parseJSON = withObject "ResolvedDataStream" parse + where + parse o = do + name <- o .: "name" + backing <- parseStringOrArray =<< o .:? "backing_indices" + ts <- o .: "timestamp_field" + pure $ ResolvedDataStream name backing ts (Object o) + +-- | Accept either a JSON array of strings or a bare JSON string, +-- returning a list of 'IndexName'. The ES-9.x OpenAPI spec types +-- @aliases[].indices@ and @data_streams[].backing_indices@ as +-- @string | array[string]@; every documented example uses the array +-- form, but the parser tolerates the bare-string form for spec +-- compliance. Missing or null yields the empty list. A bare string is +-- parsed through 'IndexName'\'s 'FromJSON' instance so it undergoes +-- the same 'mkIndexNameSystem' validation as the array form. Kept as +-- a @'Maybe' 'Value' -> 'Parser' […]@ (rather than wrapping a +-- 'Parser' action) so it can be unit-tested directly via +-- 'Data.Aeson.Types.parseEither'. +parseStringOrArray :: Maybe Value -> Parser [IndexName] +parseStringOrArray Nothing = pure [] +parseStringOrArray (Just Null) = pure [] +parseStringOrArray (Just s@(String _)) = (: []) <$> parseJSON s +parseStringOrArray (Just v@(Array _)) = parseJSON v +parseStringOrArray (Just other) = typeMismatch "string or array of strings" other diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Ingest.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Ingest.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Ingest.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Ingest +-- Description : Types for the Elasticsearch Ingest Pipeline API +-- +-- Defines the request and response shapes for the ES ingest pipeline +-- @PUT \/_ingest\/pipeline\/{id}@, @GET /_ingest/pipeline[\/{id}]@, +-- @DELETE /_ingest/pipeline/{id}@ and +-- @POST /_ingest/pipeline[\/{id}]\/_simulate@ endpoints. Ingest pipelines +-- ship in Elasticsearch 5.0 and later (ES7\/ES8\/ES9 share the same +-- surface, and OpenSearch 1.x\/2.x\/3.x also support them), which is why +-- these types live in the Common layer alongside the ILM\/SLM types. +-- +-- Like 'Database.Bloodhound.Internal.Versions.Common.Types.SLM.SLMPolicy', +-- an 'IngestPipeline' body is sent at the top level of the request — ES +-- does @not@ wrap the pipeline under a @pipeline@ key in the PUT body +-- (the @pipeline@ key only appears inside the simulate request body, +-- where it represents an inline pipeline definition). The pipeline body +-- is carried as an opaque 'Value' until a typed schema lands (the same +-- treatment already used for 'ILMPolicy'). +-- +-- The ES ingest @GET /_ingest/pipeline[\/{id}]@ response is keyed by +-- pipeline id: the JSON object's /keys/ are the pipeline ids and its +-- /values/ are the pipeline bodies. 'IngestPipelineInfo''s 'FromJSON' +-- therefore fills 'ingestPipelineInfoId' with a placeholder (@""@) that +-- the list-decoding wrapper in +-- "Database.Bloodhound.Common.Requests" overrides with the actual key. +-- This mirrors 'Database.Bloodhound.Internal.Versions.Common.Types.ILM.ILMPolicyInfo'. +module Database.Bloodhound.Internal.Versions.Common.Types.Ingest + ( PipelineId (..), + IngestPipeline (..), + IngestPipelineInfo (..), + IngestPipelines (..), + SimulateIngestPipelineRequest (..), + SimulateResult (..), + GrokPatterns (..), + + -- * Optics + ingestPipelineBodyLens, + ingestPipelineInfoIdLens, + ingestPipelineInfoVersionLens, + ingestPipelineInfoDescriptionLens, + ingestPipelineInfoLastModifiedLens, + ingestPipelineInfoProcessorsLens, + ingestPipelinesListLens, + simulateIngestPipelineRequestPipelineLens, + simulateIngestPipelineRequestDocsLens, + simulateResultBodyLens, + grokPatternsMapLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as M +import Database.Bloodhound.Internal.Utils.Imports + +-- | Identifies an ingest pipeline in the @\/_ingest\/pipeline\/{id}@ URL +-- path. Wraps 'Text' so it round-trips through JSON as a bare string but +-- is distinct at the Haskell type level from +-- 'Database.Bloodhound.Internal.Versions.Common.Types.ILM.ILMPolicyId' +-- (index lifecycle policies) and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.SLM.SLMPolicyId' +-- (snapshot lifecycle policies). +newtype PipelineId = PipelineId {unPipelineId :: Text} + deriving newtype (Eq, Show, ToJSON, FromJSON) + +-- | Request body of @PUT /_ingest/pipeline\/{id}@. ES accepts the pipeline +-- fields (@description@, @processors@, optional @version@, @on_failure@, +-- ...) at the top level of the body — there is @no@ @pipeline@ wrapper +-- like ILM has. The body is therefore carried as an opaque 'Value' that +-- 'ToJSON' emits verbatim; a typed ingest pipeline schema (modeling the +-- ~30 processor types) is tracked as a follow-up. 'FromJSON' rejects +-- non-objects so that @decode "[1,2,3]" :: Maybe IngestPipeline@ yields +-- 'Nothing', protecting callers from trivially malformed input. This +-- follows the 'SLMPolicy' precedent. +newtype IngestPipeline = IngestPipeline {unIngestPipeline :: Value} + deriving stock (Eq, Show) + +instance ToJSON IngestPipeline where + toJSON (IngestPipeline body) = body + +instance FromJSON IngestPipeline where + parseJSON = withObject "IngestPipeline" (pure . IngestPipeline . Object) + +-- | A single pipeline entry as returned by @GET /_ingest/pipeline[\/{id}]@. +-- The @processors@ array is the meat of a pipeline (each processor is one +-- of ~30 types — @set@, @uppercase@, @grok@, @script@, ...). It is +-- carried as an opaque 'Value' pending a typed schema, matching the ILM +-- precedent for policy bodies. +data IngestPipelineInfo = IngestPipelineInfo + { -- | Filled with @""@ by 'FromJSON'; the real id is the JSON object key + -- in the outer response and is stamped in by 'IngestPolicies'' + -- 'FromJSON' wrapper. + ingestPipelineInfoId :: PipelineId, + ingestPipelineInfoVersion :: Maybe Int, + ingestPipelineInfoDescription :: Maybe Text, + -- | ISO-8601 timestamp of the last modifying PUT. ES emits this as a + -- 'String'; absent on never-modified pipelines. + ingestPipelineInfoLastModified :: Maybe Text, + ingestPipelineInfoProcessors :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The id is the JSON object key in the outer response, not a field inside +-- the value; 'ingestPipelineInfoId' is therefore filled with @""@ here and +-- the list-decoding wrapper in "Database.Bloodhound.Common.Requests" +-- overwrites it with the real key — exactly the ILM placeholder trick. +instance FromJSON IngestPipelineInfo where + parseJSON = withObject "IngestPipelineInfo" $ \o -> do + ingestPipelineInfoVersion <- o .:? "version" + ingestPipelineInfoDescription <- o .:? "description" + ingestPipelineInfoLastModified <- o .:? "last_modified" + ingestPipelineInfoProcessors <- o .:? "processors" + return IngestPipelineInfo {ingestPipelineInfoId = PipelineId "", ..} + +instance ToJSON IngestPipelineInfo where + toJSON IngestPipelineInfo {..} = + omitNulls $ + catMaybes + [ fmap ("version" .=) ingestPipelineInfoVersion, + fmap ("description" .=) ingestPipelineInfoDescription, + fmap ("last_modified" .=) ingestPipelineInfoLastModified, + fmap ("processors" .=) ingestPipelineInfoProcessors + ] + +-- | The response body of @GET /_ingest/pipeline[\/{id}]@. ES keys the +-- response by pipeline id, so the JSON is an object whose keys are ids +-- and whose values are the pipeline bodies. The 'FromJSON' walks the +-- keys and folds each one into the corresponding 'IngestPipelineInfo' +-- (overriding the placeholder id set by 'IngestPipelineInfo''s own +-- decoder). Round-trip the whole 'IngestPipelines' through +-- @encode . decode@ to preserve ids. +newtype IngestPipelines = IngestPipelines {unIngestPipelines :: [IngestPipelineInfo]} + deriving stock (Eq, Show) + +instance FromJSON IngestPipelines where + parseJSON = withObject "Collection of IngestPipelineInfo" parse + where + parse = fmap IngestPipelines . mapM stamp . KM.toList + stamp (rawId, v) = do + p <- parseJSON v + return p {ingestPipelineInfoId = PipelineId (toText rawId)} + +instance ToJSON IngestPipelines where + toJSON (IngestPipelines ps) = + Object . KM.fromList $ + [ (fromText (unPipelineId (ingestPipelineInfoId p)), toJSON p) + | p <- ps + ] + +-- | Request body of @POST /_ingest/pipeline[\/{id}]\/_simulate@. The +-- @pipeline@ field carries an inline pipeline definition and is @optional@ +-- when a 'PipelineId' is in the request path (the stored pipeline is used +-- as a default); it is @required@ when the request path omits the id. +-- The 'simulateIngestPipeline' request builder always serializes the +-- carried pipeline (the public API forces an 'IngestPipeline' argument), +-- which is a slight simplification over the real ES API and tracked as a +-- follow-up. The @docs@ array is required; each entry is a free-form +-- object that ES enriches with @_index@\/@_id@\/@_source@ fields. +data SimulateIngestPipelineRequest = SimulateIngestPipelineRequest + { simulateIngestPipelineRequestPipeline :: Maybe IngestPipeline, + simulateIngestPipelineRequestDocs :: [Value] + } + deriving stock (Eq, Show) + +instance ToJSON SimulateIngestPipelineRequest where + toJSON SimulateIngestPipelineRequest {..} = + object $ + catMaybes + [ fmap ("pipeline" .=) simulateIngestPipelineRequestPipeline, + Just ("docs" .= simulateIngestPipelineRequestDocs) + ] + +instance FromJSON SimulateIngestPipelineRequest where + parseJSON = withObject "SimulateIngestPipelineRequest" $ \o -> do + simulateIngestPipelineRequestPipeline <- o .:? "pipeline" + simulateIngestPipelineRequestDocs <- o .:? "docs" .!= [] + return SimulateIngestPipelineRequest {..} + +-- | Response body of @POST /_ingest/pipeline[\/{id}]\/_simulate@. In the +-- default non-verbose shape ES returns a @docs@ array of per-document +-- results, each carrying the transformed @_source@ under a @doc@ key; in +-- the @?verbose=true@ shape each entry nests a @processor_results@ array +-- with one entry per processor. Both shapes (and the per-processor error +-- reporting) are kept as an opaque 'Value' pending a typed schema — the +-- same approach used for 'ILMPolicy'. +newtype SimulateResult = SimulateResult {unSimulateResult :: Value} + deriving stock (Eq, Show) + +instance ToJSON SimulateResult where + toJSON (SimulateResult body) = body + +instance FromJSON SimulateResult where + parseJSON = withObject "SimulateResult" (pure . SimulateResult . Object) + +-- | Response body of @GET /_ingest/processor/grok@. ES wraps the built-in +-- grok patterns under a top-level @patterns@ key; the values are a flat +-- map from pattern name (e.g. @PATH@, @IP@, @BACULA_CAPACITY@) to its +-- grok definition (e.g. @"(?:%{UNIXPATH}|%{WINPATH})"@). The wrapper +-- newtype therefore carries a 'M.Map' keyed by pattern name. +-- +-- The endpoint also accepts the optional @ecs_compatibility@ and @s@ +-- (sort) query parameters that select ECS-compatible patterns and sort +-- the response by key respectively; those are not yet exposed by the +-- 'Database.Bloodhound.Common.Requests.getGrokPatterns' builder and are +-- tracked as a follow-up. +newtype GrokPatterns = GrokPatterns {unGrokPatterns :: M.Map Text Text} + deriving stock (Eq, Show) + +instance FromJSON GrokPatterns where + parseJSON = withObject "GrokPatterns" $ \o -> do + pats <- o .: "patterns" + fmap GrokPatterns . parseJSON $ pats + +instance ToJSON GrokPatterns where + toJSON (GrokPatterns m) = object ["patterns" .= m] + +-- Lenses + +ingestPipelineBodyLens :: Lens' IngestPipeline Value +ingestPipelineBodyLens = lens unIngestPipeline (\x y -> x {unIngestPipeline = y}) + +ingestPipelineInfoIdLens :: Lens' IngestPipelineInfo PipelineId +ingestPipelineInfoIdLens = lens ingestPipelineInfoId (\x y -> x {ingestPipelineInfoId = y}) + +ingestPipelineInfoVersionLens :: Lens' IngestPipelineInfo (Maybe Int) +ingestPipelineInfoVersionLens = + lens ingestPipelineInfoVersion (\x y -> x {ingestPipelineInfoVersion = y}) + +ingestPipelineInfoDescriptionLens :: Lens' IngestPipelineInfo (Maybe Text) +ingestPipelineInfoDescriptionLens = + lens ingestPipelineInfoDescription (\x y -> x {ingestPipelineInfoDescription = y}) + +ingestPipelineInfoLastModifiedLens :: Lens' IngestPipelineInfo (Maybe Text) +ingestPipelineInfoLastModifiedLens = + lens ingestPipelineInfoLastModified (\x y -> x {ingestPipelineInfoLastModified = y}) + +ingestPipelineInfoProcessorsLens :: Lens' IngestPipelineInfo (Maybe Value) +ingestPipelineInfoProcessorsLens = + lens ingestPipelineInfoProcessors (\x y -> x {ingestPipelineInfoProcessors = y}) + +ingestPipelinesListLens :: Lens' IngestPipelines [IngestPipelineInfo] +ingestPipelinesListLens = lens unIngestPipelines (\(IngestPipelines _) y -> IngestPipelines y) + +simulateIngestPipelineRequestPipelineLens :: + Lens' SimulateIngestPipelineRequest (Maybe IngestPipeline) +simulateIngestPipelineRequestPipelineLens = + lens + simulateIngestPipelineRequestPipeline + (\x y -> x {simulateIngestPipelineRequestPipeline = y}) + +simulateIngestPipelineRequestDocsLens :: + Lens' SimulateIngestPipelineRequest [Value] +simulateIngestPipelineRequestDocsLens = + lens + simulateIngestPipelineRequestDocs + (\x y -> x {simulateIngestPipelineRequestDocs = y}) + +simulateResultBodyLens :: Lens' SimulateResult Value +simulateResultBodyLens = lens unSimulateResult (\x y -> x {unSimulateResult = y}) + +grokPatternsMapLens :: Lens' GrokPatterns (M.Map Text Text) +grokPatternsMapLens = + lens unGrokPatterns (\x y -> x {unGrokPatterns = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/KeepAlive.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/KeepAlive.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/KeepAlive.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | A typed representation of the @keep_alive@ duration accepted by the +-- Point-in-Time APIs of Elasticsearch (POST \/{index}\/_pit) and OpenSearch +-- (POST \/{index}\/_search\/point_in_time). Both backends accept the standard +-- ES\/OS time-unit grammar: a positive integer followed by one of the +-- 'TimeUnits' suffixes (e.g. @1m@, @30s@, @500ms@). +module Database.Bloodhound.Internal.Versions.Common.Types.KeepAlive + ( KeepAlive (..), + keepAliveToText, + keepAliveUnitLens, + keepAliveDurationLens, + keepAliveNanoseconds, + keepAliveMicroseconds, + keepAliveMilliseconds, + keepAliveSeconds, + keepAliveMinutes, + keepAliveHours, + keepAliveDays, + ) +where + +import Data.Char (isDigit) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports + ( FromJSON (..), + ToJSON (..), + Value (String), + showText, + typeMismatch, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Units + ( TimeUnits + ( TimeUnitDays, + TimeUnitHours, + TimeUnitMicroseconds, + TimeUnitMilliseconds, + TimeUnitMinutes, + TimeUnitNanoseconds, + TimeUnitSeconds + ), + timeUnitsSuffix, + ) +import Optics.Core (Lens', lens) +import Text.Read (readMaybe) + +-- | A @keep_alive@ duration for a Point-in-Time (PIT) context, modelled as a +-- @(unit, magnitude)@ pair. The 'ToJSON'/'FromJSON' instances and +-- 'keepAliveToText' renderer produce\/consume the wire format (e.g. @1m@, +-- @30s@, @500ms@) that the @keep_alive@ query parameter expects. +-- +-- Smart constructors ('keepAliveSeconds', 'keepAliveMinutes', etc.) are the +-- recommended way to construct values of this type. +-- +-- >>> keepAliveToText (keepAliveMinutes 1) +-- "1m" +-- +-- >>> keepAliveToText (keepAliveMilliseconds 500) +-- "500ms" +newtype KeepAlive = KeepAlive {unKeepAlive :: (TimeUnits, Word32)} + deriving stock (Eq, Ord) + +instance Show KeepAlive where + show = T.unpack . keepAliveToText + +-- | Render a 'KeepAlive' to the wire format @@ expected by +-- the @keep_alive@ parameter (e.g. @5s@, @1m@, @2h@). +keepAliveToText :: KeepAlive -> Text +keepAliveToText (KeepAlive (unit, duration)) = + showText duration <> timeUnitsSuffix unit + +instance ToJSON KeepAlive where + toJSON = toJSON . keepAliveToText + +instance FromJSON KeepAlive where + parseJSON (String t) = + case parseKeepAlive t of + Right ka -> return ka + Left err -> fail err + parseJSON x = typeMismatch "KeepAlive" x + +-- | Parse a 'KeepAlive' from its @@ wire format. +-- Returns an error message on parse failure. The magnitude is parsed as an +-- 'Integer' first so out-of-range values are rejected rather than silently +-- wrapping modulo 2^32. +parseKeepAlive :: Text -> Either String KeepAlive +parseKeepAlive t = + case T.span isDigit t of + ("", _) -> Left $ "Invalid KeepAlive (no magnitude): " <> T.unpack t + (numT, suffixT) -> case readMaybe (T.unpack numT) :: Maybe Integer of + Nothing -> Left $ "Invalid KeepAlive magnitude: " <> T.unpack numT + Just magnitude + | magnitude < fromIntegral (minBound @Word32) + || magnitude > fromIntegral (maxBound @Word32) -> + Left $ "KeepAlive magnitude out of range: " <> show magnitude + | otherwise -> case parseUnit suffixT of + Nothing -> Left $ "Invalid KeepAlive unit: " <> T.unpack suffixT + Just unit -> Right (KeepAlive (unit, fromIntegral magnitude)) + where + parseUnit :: Text -> Maybe TimeUnits + parseUnit "d" = Just TimeUnitDays + parseUnit "h" = Just TimeUnitHours + parseUnit "m" = Just TimeUnitMinutes + parseUnit "s" = Just TimeUnitSeconds + parseUnit "ms" = Just TimeUnitMilliseconds + parseUnit "micros" = Just TimeUnitMicroseconds + parseUnit "nanos" = Just TimeUnitNanoseconds + parseUnit _ = Nothing + +keepAliveUnitLens :: Lens' KeepAlive TimeUnits +keepAliveUnitLens = + lens + (\(KeepAlive (u, _)) -> u) + (\(KeepAlive (_, d)) u -> KeepAlive (u, d)) + +keepAliveDurationLens :: Lens' KeepAlive Word32 +keepAliveDurationLens = + lens + (\(KeepAlive (_, d)) -> d) + (\(KeepAlive (u, _)) d -> KeepAlive (u, d)) + +keepAliveNanoseconds :: Word32 -> KeepAlive +keepAliveNanoseconds d = KeepAlive (TimeUnitNanoseconds, d) + +keepAliveMicroseconds :: Word32 -> KeepAlive +keepAliveMicroseconds d = KeepAlive (TimeUnitMicroseconds, d) + +keepAliveMilliseconds :: Word32 -> KeepAlive +keepAliveMilliseconds d = KeepAlive (TimeUnitMilliseconds, d) + +keepAliveSeconds :: Word32 -> KeepAlive +keepAliveSeconds d = KeepAlive (TimeUnitSeconds, d) + +keepAliveMinutes :: Word32 -> KeepAlive +keepAliveMinutes d = KeepAlive (TimeUnitMinutes, d) + +keepAliveHours :: Word32 -> KeepAlive +keepAliveHours d = KeepAlive (TimeUnitHours, d) + +keepAliveDays :: Word32 -> KeepAlive +keepAliveDays d = KeepAlive (TimeUnitDays, d) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Knn.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Knn.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Knn.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.Common.Types.Knn + ( KnnSearchTarget (..), + KnnQuery (..), + KnnQueryVectorBuilder (..), + KnnInnerHits (..), + mkKnnQuery, + + -- * OpenSearch k-NN + OpenSearchKnnQuery (..), + OpenSearchKnnQueryTermination (..), + OpenSearchKnnMethodParameters (..), + OpenSearchKnnEngine (..), + mkOpenSearchKnnQuery, + mkOpenSearchKnnQueryByMaxDistance, + mkOpenSearchKnnQueryByMinScore, + ) +where + +import Data.Aeson +import Data.Aeson.Key qualified as AK +import Data.Aeson.KeyMap qualified as KM +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes +import Database.Bloodhound.Internal.Versions.Common.Types.Query (Filter) + +-- | Target type for k-NN search. +-- +-- Historically distinguished between searching by index name or by field +-- name. Since ES8+ and OpenSearch both carry the index in the request URL +-- rather than the kNN clause body, this type is retained only for source +-- compatibility; new code should supply the index directly to 'knnSearch'. +data KnnSearchTarget + = KnnByIndex IndexName + | KnnByField FieldName + deriving stock (Eq, Show) + +-- | Builder for computing a query vector from a trained model (ES8+). +-- +-- See . +data KnnQueryVectorBuilder + = KnnQueryVectorBuilderTextEmbedding + { knnTextEmbeddingModelId :: Text, + knnTextEmbeddingModelText :: Text + } + deriving stock (Eq, Show) + +instance ToJSON KnnQueryVectorBuilder where + toJSON (KnnQueryVectorBuilderTextEmbedding modelId modelText) = + object + [ "text_embedding" + .= object + [ "model_id" .= modelId, + "model_text" .= modelText + ] + ] + +instance FromJSON KnnQueryVectorBuilder where + parseJSON = withObject "KnnQueryVectorBuilder" $ \obj -> do + te <- obj .: "text_embedding" + KnnQueryVectorBuilderTextEmbedding + <$> te + .: "model_id" + <*> te + .: "model_text" + +-- | Opaque wrapper for the ES knn @inner_hits@ clause. ES's schema is large +-- and shared with nested queries; this is preserved as a JSON passthrough +-- until a typed model is factored out. +newtype KnnInnerHits = KnnInnerHits {getKnnInnerHits :: Value} + deriving newtype (Eq, Show, ToJSON, FromJSON) + +-- | A single k-NN clause for vector similarity search. +-- +-- Serialized as the __bare clause body__ that lives inside the top-level +-- @\"knn\"@ array of a standard ES8+\/ES9+ @POST \/{index}\/_search@ body: +-- +-- @ +-- { "field": ..., "query_vector": [...], "k": 10, "num_candidates": 100, ... } +-- @ +-- +-- The index is supplied by the surrounding request path, not by the clause +-- itself. See 'knnSearch' in "Database.Bloodhound.ElasticSearch8.Client". +data KnnQuery = KnnQuery + { knnField :: FieldName, + knnQueryVector :: [Double], + -- | Top-k count. Optional per the ES @_types.KnnSearch@ spec (only + -- @field@ is required); 'Nothing' lets the server apply its default. + knnK :: Maybe Int, + knnNumCandidates :: Maybe Int, + knnFilter :: Maybe Filter, + knnSimilarity :: Maybe Double, + knnBoost :: Maybe Double, + knnQueryVectorBuilder :: Maybe KnnQueryVectorBuilder, + knnInnerHits :: Maybe KnnInnerHits + } + deriving stock (Eq, Show) + +-- | Smart constructor for 'KnnQuery' that defaults every optional field to +-- 'Nothing'. Preferred over the positional 'KnnQuery' constructor. +mkKnnQuery :: + FieldName -> + [Double] -> + Maybe Int -> + KnnQuery +mkKnnQuery field queryVector k = + KnnQuery + { knnField = field, + knnQueryVector = queryVector, + knnK = k, + knnNumCandidates = Nothing, + knnFilter = Nothing, + knnSimilarity = Nothing, + knnBoost = Nothing, + knnQueryVectorBuilder = Nothing, + knnInnerHits = Nothing + } + +instance ToJSON KnnQuery where + toJSON KnnQuery {..} = + omitNulls + [ "field" .= knnField, + "query_vector" .= knnQueryVector, + "k" .= knnK, + "num_candidates" .= knnNumCandidates, + "filter" .= knnFilter, + "similarity" .= knnSimilarity, + "boost" .= knnBoost, + "query_vector_builder" .= knnQueryVectorBuilder, + "inner_hits" .= knnInnerHits + ] + +instance FromJSON KnnQuery where + parseJSON = withObject "KnnQuery" $ \obj -> + KnnQuery + <$> obj + .: "field" + <*> obj + .:? "query_vector" + .!= [] + <*> obj + .:? "k" + <*> obj + .:? "num_candidates" + <*> obj + .:? "filter" + <*> obj + .:? "similarity" + <*> obj + .:? "boost" + <*> obj + .:? "query_vector_builder" + <*> obj + .:? "inner_hits" + +-- --------------------------------------------------------------------------- +-- OpenSearch k-NN clause +-- --------------------------------------------------------------------------- + +-- | OpenSearch k-NN engine selection. Set in the index mapping's +-- @method.definition@, not in the search body. Exported here so library users +-- building kNN-enabled index mappings have a typed representation. +-- +-- See . +data OpenSearchKnnEngine + = KnnEngineFaiss + | KnnEngineNmslib + | KnnEngineLucene + deriving stock (Eq, Show) + +instance ToJSON OpenSearchKnnEngine where + toJSON KnnEngineFaiss = String "faiss" + toJSON KnnEngineNmslib = String "nmslib" + toJSON KnnEngineLucene = String "lucene" + +instance FromJSON OpenSearchKnnEngine where + parseJSON (String "faiss") = pure KnnEngineFaiss + parseJSON (String "nmslib") = pure KnnEngineNmslib + parseJSON (String "lucene") = pure KnnEngineLucene + parseJSON v = typeMismatch "OpenSearchKnnEngine (faiss|nmslib|lucene)" v + +-- | OpenSearch kNN @method_parameters@. The two parameters are engine-coupled: +-- @ef_search@ is valid only for faiss\/nmslib HNSW, @nprobes@ only for Lucene +-- IVF. Sending the wrong one for the index's engine fails at query time, so the +-- sum type makes the invalid combination unrepresentable at the Haskell level. +-- +-- Serialized as a single-key object keyed by the active parameter +-- (@{"ef_search": N}@ or @{"nprobes": N}@), matching the OpenSearch wire shape. +-- +-- See . +data OpenSearchKnnMethodParameters + = -- | faiss \/ nmslib HNSW: tuning knob for the size of the dynamic candidate + -- list at search time. + KnnHnswParams {osknnEfSearch :: Int} + | -- | Lucene IVF: number of buckets to probe at search time. + KnnIvfParams {osknnNprobes :: Int} + deriving stock (Eq, Show) + +instance ToJSON OpenSearchKnnMethodParameters where + toJSON (KnnHnswParams efSearch) = object ["ef_search" .= efSearch] + toJSON (KnnIvfParams nprobes) = object ["nprobes" .= nprobes] + +instance FromJSON OpenSearchKnnMethodParameters where + parseJSON = withObject "OpenSearchKnnMethodParameters" $ \obj -> + (KnnHnswParams <$> obj .: "ef_search") + <|> (KnnIvfParams <$> obj .: "nprobes") + <|> fail + "OpenSearchKnnMethodParameters: expected exactly one of ef_search, nprobes" + +-- | A single OpenSearch k-NN clause for vector similarity search. +-- +-- Serialized as the OS-specific query shape: +-- +-- @ +-- { "knn": { "": { "vector": [...], "k": N, "filter": ..., "boost": ..., "method_parameters": ... } } } +-- @ +-- +-- which 'Search' places under the top-level @"query"@ key. Note that — unlike +-- the ES 'KnnQuery' which lives at the top-level @\"knn\"@ array — OpenSearch +-- nests the kNN clause inside @query@ with the field name as the dict key. +-- +-- The termination strategy is encoded by 'osknnTermination': k-based, radial +-- @max_distance@ (L2 \/ cosine space), or radial @min_score@ (inner product +-- space). The three are mutually exclusive by construction on the encode +-- path because OpenSearch rejects requests carrying more than one of them +-- with +-- +-- > "requires exactly one of k, distance or score" +-- +-- See 'mkOpenSearchKnnQuery' for the k-based smart constructor and +-- 'mkOpenSearchKnnQueryByMaxDistance' \/ 'mkOpenSearchKnnQueryByMinScore' +-- for the radial variants. +-- +-- See +-- and . +data OpenSearchKnnQuery = OpenSearchKnnQuery + { osknnField :: FieldName, + osknnVector :: [Double], + osknnTermination :: OpenSearchKnnQueryTermination, + osknnFilter :: Maybe Filter, + osknnBoost :: Maybe Double, + osknnMethodParameters :: Maybe OpenSearchKnnMethodParameters + } + deriving stock (Eq, Show) + +-- | Termination strategy for an 'OpenSearchKnnQuery'. OpenSearch kNN exposes +-- three mutually exclusive shapes: +-- +-- * 'KnnTerminationByK' — top-k nearest neighbours (the classic shape). +-- * 'KnnTerminationByMaxDistance' — radial search in L2 \/ cosine space: +-- return every vector whose distance to the query vector is @<= max_distance@. +-- * 'KnnTerminationByMinScore' — radial search in inner product space: +-- return every vector whose similarity score is @>= min_score@. +-- +-- Sending more than one of these in the same clause fails at query time with +-- @requires exactly one of k, distance or score@; the sum type makes that +-- constraint unrepresentable by construction on the encode path. +-- +-- See . +data OpenSearchKnnQueryTermination + = KnnTerminationByK Int + | KnnTerminationByMaxDistance Double + | KnnTerminationByMinScore Double + deriving stock (Eq, Show) + +instance ToJSON OpenSearchKnnQueryTermination where + toJSON (KnnTerminationByK k) = object ["k" .= k] + toJSON (KnnTerminationByMaxDistance d) = object ["max_distance" .= d] + toJSON (KnnTerminationByMinScore s) = object ["min_score" .= s] + +instance FromJSON OpenSearchKnnQueryTermination where + parseJSON = withObject "OpenSearchKnnQueryTermination" $ \o -> + (KnnTerminationByK <$> o .: "k") + <|> (KnnTerminationByMaxDistance <$> o .: "max_distance") + <|> (KnnTerminationByMinScore <$> o .: "min_score") + <|> fail + "OpenSearchKnnQueryTermination: expected exactly one of k, max_distance, min_score" + +-- | Smart constructor for 'OpenSearchKnnQuery' that defaults every optional +-- field to 'Nothing'. Preferred over the positional constructor. +mkOpenSearchKnnQuery :: + FieldName -> + [Double] -> + Int -> + OpenSearchKnnQuery +mkOpenSearchKnnQuery field vector k = + OpenSearchKnnQuery + { osknnField = field, + osknnVector = vector, + osknnTermination = KnnTerminationByK k, + osknnFilter = Nothing, + osknnBoost = Nothing, + osknnMethodParameters = Nothing + } + +-- | Smart constructor for the radial-search 'OpenSearchKnnQuery' variant +-- (@max_distance@, L2 \/ cosine space). Defaults every optional field to +-- 'Nothing'. Mutually exclusive with k at the OpenSearch query level — +-- enforced here by the 'OpenSearchKnnQueryTermination' sum. +mkOpenSearchKnnQueryByMaxDistance :: + FieldName -> + [Double] -> + Double -> + OpenSearchKnnQuery +mkOpenSearchKnnQueryByMaxDistance field vector maxDistance = + OpenSearchKnnQuery + { osknnField = field, + osknnVector = vector, + osknnTermination = KnnTerminationByMaxDistance maxDistance, + osknnFilter = Nothing, + osknnBoost = Nothing, + osknnMethodParameters = Nothing + } + +-- | Smart constructor for the radial-search 'OpenSearchKnnQuery' variant +-- (@min_score@, inner product space). Defaults every optional field to +-- 'Nothing'. Mutually exclusive with k at the OpenSearch query level — +-- enforced here by the 'OpenSearchKnnQueryTermination' sum. +mkOpenSearchKnnQueryByMinScore :: + FieldName -> + [Double] -> + Double -> + OpenSearchKnnQuery +mkOpenSearchKnnQueryByMinScore field vector minScore = + OpenSearchKnnQuery + { osknnField = field, + osknnVector = vector, + osknnTermination = KnnTerminationByMinScore minScore, + osknnFilter = Nothing, + osknnBoost = Nothing, + osknnMethodParameters = Nothing + } + +-- | Render the field name as an Aeson 'AK.Key' so it can be used as a JSON +-- object key. +fieldNameKey :: FieldName -> AK.Key +fieldNameKey (FieldName t) = AK.fromText t + +-- | Flatten an 'OpenSearchKnnQueryTermination' into the single Aeson pair +-- that lives alongside the other clause-body fields. Used by the +-- 'OpenSearchKnnQuery' ToJSON instance so that @k@ \/ @max_distance@ \/ +-- @min_score@ appear at the same level as @vector@, @filter@, etc. +terminationPair :: OpenSearchKnnQueryTermination -> (AK.Key, Value) +terminationPair (KnnTerminationByK k) = ("k", toJSON k) +terminationPair (KnnTerminationByMaxDistance d) = ("max_distance", toJSON d) +terminationPair (KnnTerminationByMinScore s) = ("min_score", toJSON s) + +instance ToJSON OpenSearchKnnQuery where + toJSON OpenSearchKnnQuery {..} = + object + [ "knn" + .= object + [ fieldNameKey osknnField .= clauseBody + ] + ] + where + clauseBody = + omitNulls + [ "vector" .= osknnVector, + terminationPair osknnTermination, + "filter" .= osknnFilter, + "boost" .= osknnBoost, + "method_parameters" .= osknnMethodParameters + ] + +instance FromJSON OpenSearchKnnQuery where + parseJSON = withObject "OpenSearchKnnQuery" $ \obj -> do + knnObj <- obj .: "knn" + case KM.toList knnObj of + [(fieldKey, clauseVal)] -> withClauseBody fieldKey clauseVal + _ -> fail "OpenSearchKnnQuery: expected a single-field knn object" + where + withClauseBody fieldKey clauseVal = + withObject + "OpenSearchKnnQuery clause body" + ( \clause -> do + fieldVector <- clause .:? "vector" .!= [] + fieldTermination <- parseJSON (Object clause) + fieldFilter <- clause .:? "filter" + fieldBoost <- clause .:? "boost" + fieldMethod <- clause .:? "method_parameters" + return $ + OpenSearchKnnQuery + (FieldName (AK.toText fieldKey)) + fieldVector + fieldTermination + fieldFilter + fieldBoost + fieldMethod + ) + clauseVal diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Logstash.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Logstash.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Logstash.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Logstash +-- Description : Types for the Elasticsearch X-Pack Logstash pipeline API +-- +-- Defines the request and response shapes for the ES X-Pack Logstash +-- centralized pipeline-management endpoints (under @\/_logstash\/pipeline*@). +-- A Logstash pipeline stored centrally in the cluster can be fetched by +-- Logstash nodes via @pipeline.id@ configuration, letting pipeline +-- definitions live with the cluster rather than in per-node config files. +-- +-- * @GET /_logstash/pipeline@ — 'LogstashPipelinesResponse' (all pipelines). +-- * @GET /_logstash/pipeline/{pipeline_id}@ — same response shape, filtered +-- to one entry (ES still returns a map keyed by the id). +-- * @PUT /_logstash/pipeline/{pipeline_id}@ — 'LogstashPipelineConfig' +-- body; returns 'Acknowledged' (handled by the requests layer). +-- * @DELETE /_logstash/pipeline/{pipeline_id}@ — returns 'Acknowledged'. +-- +-- Unlike the Enrich API, the @GET@ response is a /bare JSON object/ keyed by +-- pipeline id (there is no @{\"policies\":[...]}@ envelope), so +-- 'LogstashPipelinesResponse' wraps a 'Map' directly. +-- +-- Logstash centralized management ships in Elasticsearch 7.x and later and +-- requires a platinum or enterprise X-Pack license; ES7\/ES8\/ES9 share the +-- same wire surface, which is why these types live in the Common layer +-- alongside SLM\/ILM\/Enrich. OpenSearch does not implement this API, so +-- calls against an OpenSearch cluster will fail at runtime — the types are +-- still hosted under @Common@ to match the project's SLM\/DiskUsage\/Enrich +-- precedent. +-- +-- The pipeline body carries an @lpcExtras@ 'KeyMap' catch-all so unknown +-- sibling fields survive a round-trip (the same strategy used by +-- "Database.Bloodhound.Internal.Versions.Common.Types.Enrich"). The +-- nested @pipeline_metadata@, @pipeline_settings@ and @last_modified@ +-- bodies are carried as opaque 'Value's: their shapes are non-essential for +-- a @PUT@ and vary across ES7 (epoch-millis for @last_modified@) vs ES8\/9 +-- (ISO-8601), so an opaque value avoids a lossy conversion. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Logstash + ( -- * Identity + LogstashPipelineId (..), + + -- * Pipeline config (PUT body / GET value) + LogstashPipelineConfig (..), + defaultLogstashPipelineConfig, + logstashPipelineConfigDescriptionLens, + logstashPipelineConfigPipelineLens, + logstashPipelineConfigPipelineMetadataLens, + logstashPipelineConfigPipelineSettingsLens, + logstashPipelineConfigUsernameLens, + logstashPipelineConfigLastModifiedLens, + logstashPipelineConfigExtrasLens, + + -- * GET response + LogstashPipelinesResponse (..), + logstashPipelinesResponseMapLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict (Map) +import Data.Maybe (catMaybes) +import Data.String (IsString) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens) + +-- | Identifies a centrally-managed Logstash pipeline in the +-- @\/_logstash\/pipeline\/{pipeline_id}@ URL path. Wraps 'Text' so it +-- round-trips through JSON as a bare string but is distinct at the Haskell +-- type level from other ids. The @Key@ instances let it be used directly as +-- a 'Map' key in 'LogstashPipelinesResponse'. +newtype LogstashPipelineId = LogstashPipelineId {unLogstashPipelineId :: Text} + deriving newtype + (Eq, Show, Ord, IsString, ToJSON, FromJSON, FromJSONKey, ToJSONKey) + +-- | A single Logstash pipeline configuration — the @PUT@ request body and +-- the value associated with each pipeline id in the @GET@ response. The +-- documented fields are typed; any unknown sibling fields are preserved in +-- 'lpcExtras' so the structure round-trips through @encode . decode@ even +-- when ES adds new optional fields. +data LogstashPipelineConfig = LogstashPipelineConfig + { -- | @description@ — human-readable description of the pipeline. + lpcDescription :: Maybe Text, + -- | @pipeline@ — the pipeline configuration as a Logstash DSL string + -- (e.g. @input { stdin { } } output { stdout { } }@). + lpcPipeline :: Maybe Text, + -- | @pipeline_metadata@ — opaque metadata about the pipeline + -- (@{\"type\":\"logstash_pipeline\",\"version\":1}@). Carried as a raw + -- 'Value' because the shape is non-essential for a @PUT@ and may gain + -- fields across ES versions. + lpcPipelineMetadata :: Maybe Value, + -- | @pipeline_settings@ — opaque map of dotted-key pipeline settings + -- (e.g. @pipeline.batch.size@). Carried as a raw 'Value'. + lpcPipelineSettings :: Maybe Value, + -- | @username@ — the user that last modified the pipeline (server-set). + lpcUsername :: Maybe Text, + -- | @last_modified@ — timestamp of the last modification. Carried as a + -- raw 'Value' because ES 7.x emits epoch-millis while 8.x\/9.x emit an + -- ISO-8601 string; absent on a fresh @PUT@ before any @GET@. + lpcLastModified :: Maybe Value, + -- | Catch-all for every other sibling field ES adds in future so decode + -- is forward-compatible and @encode . decode@ round-trips. + lpcExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | An empty config: every documented field is 'Nothing' and there are no +-- extras. Intended as a starting point callers then overwrite with the +-- record lenses (at minimum @lpcPipeline@). +defaultLogstashPipelineConfig :: LogstashPipelineConfig +defaultLogstashPipelineConfig = + LogstashPipelineConfig + { lpcDescription = Nothing, + lpcPipeline = Nothing, + lpcPipelineMetadata = Nothing, + lpcPipelineSettings = Nothing, + lpcUsername = Nothing, + lpcLastModified = Nothing, + lpcExtras = KM.empty + } + +-- Known keys inside the config object — used to split the decoded 'Object' +-- into the typed fields and the @lpcExtras@ catch-all. +configKnownKeys :: [Key] +configKnownKeys = + [ "description", + "pipeline", + "pipeline_metadata", + "pipeline_settings", + "username", + "last_modified" + ] + +instance FromJSON LogstashPipelineConfig where + parseJSON = withObject "LogstashPipelineConfig" $ \o -> do + description <- o .:? "description" + pipeline <- o .:? "pipeline" + pipelineMetadata <- o .:? "pipeline_metadata" + pipelineSettings <- o .:? "pipeline_settings" + username <- o .:? "username" + lastModified <- o .:? "last_modified" + let extras = + KM.fromList $ + filter ((`notElem` configKnownKeys) . fst) $ + KM.toList o + pure + LogstashPipelineConfig + { lpcDescription = description, + lpcPipeline = pipeline, + lpcPipelineMetadata = pipelineMetadata, + lpcPipelineSettings = pipelineSettings, + lpcUsername = username, + lpcLastModified = lastModified, + lpcExtras = extras + } + +instance ToJSON LogstashPipelineConfig where + toJSON LogstashPipelineConfig {..} = + -- 'object' (not 'omitNulls') so the @lpcExtras@ catch-all survives a + -- round-trip even when it carries a @null@ or empty-array value — the + -- documented forward-compat guarantee. The known fields are pre-filtered + -- by 'catMaybes' (stripping 'Nothing's), so they never contribute a + -- 'Null' here, and the extras have already had the known keys stripped + -- on decode. + object $ + catMaybes + [ ("description" .=) <$> lpcDescription, + ("pipeline" .=) <$> lpcPipeline, + ("pipeline_metadata" .=) <$> lpcPipelineMetadata, + ("pipeline_settings" .=) <$> lpcPipelineSettings, + ("username" .=) <$> lpcUsername, + ("last_modified" .=) <$> lpcLastModified + ] + <> [toPair kv | kv <- KM.toList lpcExtras] + where + toPair (k, v) = k .= v + +-- | Response body of @GET /_logstash/pipeline[/{id}]@: a bare JSON object +-- whose keys are pipeline ids and whose values are the corresponding +-- 'LogstashPipelineConfig'. The map is empty when no pipelines are stored; +-- note a @GET /{id}@ for a /missing/ id returns an HTTP 404 rather than an +-- empty object (the decoder still tolerates an empty object defensively). +newtype LogstashPipelinesResponse = LogstashPipelinesResponse + { unLogstashPipelinesResponse :: Map LogstashPipelineId LogstashPipelineConfig + } + deriving stock (Eq, Show) + +instance FromJSON LogstashPipelinesResponse where + parseJSON v = + LogstashPipelinesResponse <$> parseJSON v + +instance ToJSON LogstashPipelinesResponse where + toJSON (LogstashPipelinesResponse m) = toJSON m + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +logstashPipelineConfigDescriptionLens :: + Lens' LogstashPipelineConfig (Maybe Text) +logstashPipelineConfigDescriptionLens = + lens lpcDescription (\x y -> x {lpcDescription = y}) + +logstashPipelineConfigPipelineLens :: + Lens' LogstashPipelineConfig (Maybe Text) +logstashPipelineConfigPipelineLens = + lens lpcPipeline (\x y -> x {lpcPipeline = y}) + +logstashPipelineConfigPipelineMetadataLens :: + Lens' LogstashPipelineConfig (Maybe Value) +logstashPipelineConfigPipelineMetadataLens = + lens lpcPipelineMetadata (\x y -> x {lpcPipelineMetadata = y}) + +logstashPipelineConfigPipelineSettingsLens :: + Lens' LogstashPipelineConfig (Maybe Value) +logstashPipelineConfigPipelineSettingsLens = + lens lpcPipelineSettings (\x y -> x {lpcPipelineSettings = y}) + +logstashPipelineConfigUsernameLens :: + Lens' LogstashPipelineConfig (Maybe Text) +logstashPipelineConfigUsernameLens = + lens lpcUsername (\x y -> x {lpcUsername = y}) + +logstashPipelineConfigLastModifiedLens :: + Lens' LogstashPipelineConfig (Maybe Value) +logstashPipelineConfigLastModifiedLens = + lens lpcLastModified (\x y -> x {lpcLastModified = y}) + +logstashPipelineConfigExtrasLens :: + Lens' LogstashPipelineConfig (KeyMap Value) +logstashPipelineConfigExtrasLens = + lens lpcExtras (\x y -> x {lpcExtras = y}) + +logstashPipelinesResponseMapLens :: + Lens' + LogstashPipelinesResponse + (Map LogstashPipelineId LogstashPipelineConfig) +logstashPipelinesResponseMapLens = + lens + unLogstashPipelinesResponse + (\_ y -> LogstashPipelinesResponse y) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Migration.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Migration.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Migration.hs @@ -0,0 +1,402 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Migration +-- Description : Types for the Elasticsearch Migration Assistance API +-- +-- Defines the request and response shapes for the ES Migration API, used +-- when planning a major-version upgrade: +-- +-- * @GET /_migration/deprecations@ (and @GET /{index}/_migration/deprecations@) +-- — 'MigrationDeprecations' response. +-- * @GET /_migration/system_features@ — 'FeatureUpgradeStatus' response. +-- * @POST /_migration/system_features@ — no body (returns 'Acknowledged'). +-- +-- The deprecations endpoint shipped in Elasticsearch 6.1 and the +-- system_features endpoints in 7.16; both are stable across ES 7.x, 8.x +-- and 9.x, which is why these types live in the Common layer. The wire +-- shape is the same @none\/info\/warning\/critical@ level enum reused at +-- every nesting level (cluster, node, ml, per-index, per-data-stream, +-- per-template and per-ILM-policy). +-- +-- The deprecations response has seven top-level sections: three are flat +-- lists ('migrationDeprecationsClusterSettings', 'migrationDeprecationsNodeSettings', +-- 'migrationDeprecationsMlSettings') and four are JSON objects keyed by +-- the index\/data-stream\/template\/policy name (decoded as a 'Map' to +-- tolerate names — e.g. @logs:apache@ — that 'IndexName' would reject). +-- +-- @POST /_migration/system_features@ returns the bare +-- @{"acknowledged":true}@ body; the existing 'Acknowledged' type from +-- "Database.Bloodhound.Internal.Client.BHRequest" handles it directly, so +-- no request-specific type is defined here. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Migration + ( -- * Deprecations endpoint + DeprecationLevel (..), + Deprecation (..), + MigrationDeprecations (..), + + -- * Feature upgrade endpoint + FeatureMigrationStatus (..), + FeatureUpgradeIndex (..), + FeatureUpgradeInfo (..), + FeatureUpgradeStatus (..), + + -- * Optics + deprecationLevelLens, + deprecationMessageLens, + deprecationUrlLens, + deprecationDetailsLens, + deprecationResolveDuringRollingUpgradeLens, + deprecationMetaLens, + migrationDeprecationsClusterSettingsLens, + migrationDeprecationsNodeSettingsLens, + migrationDeprecationsMlSettingsLens, + migrationDeprecationsIndexSettingsLens, + migrationDeprecationsDataStreamsLens, + migrationDeprecationsTemplatesLens, + migrationDeprecationsILMPoliciesLens, + featureUpgradeIndexIndexLens, + featureUpgradeIndexVersionLens, + featureUpgradeIndexFailureCauseLens, + featureUpgradeInfoFeatureNameLens, + featureUpgradeInfoMinimumIndexVersionLens, + featureUpgradeInfoMigrationStatusLens, + featureUpgradeInfoIndicesLens, + featureUpgradeStatusMigrationStatusLens, + featureUpgradeStatusFeaturesLens, + ) +where + +import Data.Aeson +import Data.Map.Strict (Map) +import Database.Bloodhound.Internal.Utils.Imports + +-- | Severity of a single deprecation warning, returned in the @level@ +-- field of every 'Deprecation'. The enum is stable since the endpoint +-- shipped in ES 6.1; an unknown value fails to decode (a new level would +-- warrant a deliberate constructor addition here). +data DeprecationLevel + = DeprecationLevelNone + | DeprecationLevelInfo + | DeprecationLevelWarning + | DeprecationLevelCritical + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON DeprecationLevel where + toJSON DeprecationLevelNone = String "none" + toJSON DeprecationLevelInfo = String "info" + toJSON DeprecationLevelWarning = String "warning" + toJSON DeprecationLevelCritical = String "critical" + +instance FromJSON DeprecationLevel where + parseJSON = withText "DeprecationLevel" parseLevel + where + parseLevel "none" = pure DeprecationLevelNone + parseLevel "info" = pure DeprecationLevelInfo + parseLevel "warning" = pure DeprecationLevelWarning + parseLevel "critical" = pure DeprecationLevelCritical + parseLevel other = + fail ("unknown deprecation level: " <> show other) + +-- | A single deprecation warning. Reused at every nesting level of +-- 'MigrationDeprecations' (cluster settings, node settings, ML settings, +-- per-index, per-data-stream, per-template and per-ILM-policy). The +-- @url@ field links to the relevant breaking-changes section of the ES +-- documentation; @details@ is a human-readable description of @why@ the +-- warning applies to @this@ cluster. +-- +-- The ES schema marks @resolve_during_rolling_upgrade@ as required, but +-- the official response example omits it; the decoder therefore accepts +-- its absence (defaulting to 'Nothing') so real-world responses parse +-- cleanly. @_meta@ is an opaque free-form object and is likewise +-- optional. +data Deprecation = Deprecation + { deprecationLevel :: DeprecationLevel, + deprecationMessage :: Text, + deprecationUrl :: Text, + deprecationDetails :: Maybe Text, + deprecationResolveDuringRollingUpgrade :: Maybe Bool, + deprecationMeta :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON Deprecation where + parseJSON = withObject "Deprecation" $ \o -> do + deprecationLevel <- o .: "level" + deprecationMessage <- o .: "message" + deprecationUrl <- o .: "url" + deprecationDetails <- o .:? "details" + deprecationResolveDuringRollingUpgrade <- o .:? "resolve_during_rolling_upgrade" + deprecationMeta <- o .:? "_meta" + return Deprecation {..} + +instance ToJSON Deprecation where + toJSON Deprecation {..} = + omitNulls $ + catMaybes + [ Just ("level" .= deprecationLevel), + Just ("message" .= deprecationMessage), + Just ("url" .= deprecationUrl), + fmap ("details" .=) deprecationDetails, + fmap ("resolve_during_rolling_upgrade" .=) deprecationResolveDuringRollingUpgrade, + fmap ("_meta" .=) deprecationMeta + ] + +-- | Response body of @GET /_migration/deprecations@. The seven top-level +-- sections correspond to the categories ES checks when planning an +-- upgrade: +-- +-- * @cluster_settings@, @node_settings@, @ml_settings@ — flat lists of +-- 'Deprecation' (cluster-wide or node-wide warnings). +-- * @index_settings@, @data_streams@, @templates@, @ilm_policies@ — +-- 'Map's keyed by the index\/data-stream\/template\/policy name. The +-- key type is 'Text' (not 'IndexName') because ES emits names verbatim +-- and some real-world names — e.g. @logs:apache@ — would fail +-- 'IndexName's validation. +-- +-- All sections are tolerated as 'Nothing' when absent so the decoder +-- survives older ES versions that emit a subset of the keys. +data MigrationDeprecations = MigrationDeprecations + { migrationDeprecationsClusterSettings :: Maybe [Deprecation], + migrationDeprecationsNodeSettings :: Maybe [Deprecation], + migrationDeprecationsMlSettings :: Maybe [Deprecation], + migrationDeprecationsIndexSettings :: Maybe (Map Text [Deprecation]), + migrationDeprecationsDataStreams :: Maybe (Map Text [Deprecation]), + migrationDeprecationsTemplates :: Maybe (Map Text [Deprecation]), + migrationDeprecationsILMPolicies :: Maybe (Map Text [Deprecation]) + } + deriving stock (Eq, Show) + +instance FromJSON MigrationDeprecations where + parseJSON = withObject "MigrationDeprecations" $ \o -> do + migrationDeprecationsClusterSettings <- o .:? "cluster_settings" + migrationDeprecationsNodeSettings <- o .:? "node_settings" + migrationDeprecationsMlSettings <- o .:? "ml_settings" + migrationDeprecationsIndexSettings <- o .:? "index_settings" + migrationDeprecationsDataStreams <- o .:? "data_streams" + migrationDeprecationsTemplates <- o .:? "templates" + migrationDeprecationsILMPolicies <- o .:? "ilm_policies" + return MigrationDeprecations {..} + +instance ToJSON MigrationDeprecations where + toJSON MigrationDeprecations {..} = + omitNulls $ + catMaybes + [ fmap ("cluster_settings" .=) migrationDeprecationsClusterSettings, + fmap ("node_settings" .=) migrationDeprecationsNodeSettings, + fmap ("ml_settings" .=) migrationDeprecationsMlSettings, + fmap ("index_settings" .=) migrationDeprecationsIndexSettings, + fmap ("data_streams" .=) migrationDeprecationsDataStreams, + fmap ("templates" .=) migrationDeprecationsTemplates, + fmap ("ilm_policies" .=) migrationDeprecationsILMPolicies + ] + +-- | Migration status of a single feature or of the cluster as a whole, +-- returned in the @migration_status@ field of 'FeatureUpgradeStatus' and +-- each 'FeatureUpgradeInfo'. The four values are: no migration needed, +-- migration needed before upgrade, migration in progress, or migration +-- errored. +data FeatureMigrationStatus + = FeatureMigrationStatusNoMigrationNeeded + | FeatureMigrationStatusMigrationNeeded + | FeatureMigrationStatusInProgress + | FeatureMigrationStatusError + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON FeatureMigrationStatus where + toJSON FeatureMigrationStatusNoMigrationNeeded = String "NO_MIGRATION_NEEDED" + toJSON FeatureMigrationStatusMigrationNeeded = String "MIGRATION_NEEDED" + toJSON FeatureMigrationStatusInProgress = String "IN_PROGRESS" + toJSON FeatureMigrationStatusError = String "ERROR" + +instance FromJSON FeatureMigrationStatus where + parseJSON = withText "FeatureMigrationStatus" parseStatus + where + parseStatus "NO_MIGRATION_NEEDED" = pure FeatureMigrationStatusNoMigrationNeeded + parseStatus "MIGRATION_NEEDED" = pure FeatureMigrationStatusMigrationNeeded + parseStatus "IN_PROGRESS" = pure FeatureMigrationStatusInProgress + parseStatus "ERROR" = pure FeatureMigrationStatusError + parseStatus other = + fail ("unknown feature migration status: " <> show other) + +-- | One entry of 'FeatureUpgradeInfo's @indices@ list: an index that +-- still needs its feature version bumped. @failure_cause@ is opaque on +-- the wire (the ES schema does not enumerate its inner fields); it is +-- surfaced as a 'Value' for the caller to inspect. +data FeatureUpgradeIndex = FeatureUpgradeIndex + { featureUpgradeIndexIndex :: Text, + featureUpgradeIndexVersion :: Text, + featureUpgradeIndexFailureCause :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON FeatureUpgradeIndex where + parseJSON = withObject "FeatureUpgradeIndex" $ \o -> do + featureUpgradeIndexIndex <- o .: "index" + featureUpgradeIndexVersion <- o .: "version" + featureUpgradeIndexFailureCause <- o .:? "failure_cause" + return FeatureUpgradeIndex {..} + +instance ToJSON FeatureUpgradeIndex where + toJSON FeatureUpgradeIndex {..} = + omitNulls $ + catMaybes + [ Just ("index" .= featureUpgradeIndexIndex), + Just ("version" .= featureUpgradeIndexVersion), + fmap ("failure_cause" .=) featureUpgradeIndexFailureCause + ] + +-- | A single feature in the @GET /_migration/system_features@ response. +-- @minimum_index_version@ is the lowest feature-revision index version +-- currently stored on the cluster (as a string); the cluster-wide +-- 'FeatureUpgradeStatus' rolls every feature up into a single +-- 'featureUpgradeStatusMigrationStatus'. +data FeatureUpgradeInfo = FeatureUpgradeInfo + { featureUpgradeInfoFeatureName :: Text, + featureUpgradeInfoMinimumIndexVersion :: Text, + featureUpgradeInfoMigrationStatus :: FeatureMigrationStatus, + featureUpgradeInfoIndices :: [FeatureUpgradeIndex] + } + deriving stock (Eq, Show) + +instance FromJSON FeatureUpgradeInfo where + parseJSON = withObject "FeatureUpgradeInfo" $ \o -> do + featureUpgradeInfoFeatureName <- o .: "feature_name" + featureUpgradeInfoMinimumIndexVersion <- o .: "minimum_index_version" + featureUpgradeInfoMigrationStatus <- o .: "migration_status" + featureUpgradeInfoIndices <- o .:? "indices" .!= [] + return FeatureUpgradeInfo {..} + +instance ToJSON FeatureUpgradeInfo where + toJSON FeatureUpgradeInfo {..} = + omitNulls $ + catMaybes + [ Just ("feature_name" .= featureUpgradeInfoFeatureName), + Just ("minimum_index_version" .= featureUpgradeInfoMinimumIndexVersion), + Just ("migration_status" .= featureUpgradeInfoMigrationStatus), + if null featureUpgradeInfoIndices + then Nothing + else Just ("indices" .= featureUpgradeInfoIndices) + ] + +-- | Response body of @GET /_migration/system_features@. The top-level +-- @migration_status@ rolls every feature's individual status into a +-- single cluster-wide verdict: if any feature needs migration the +-- cluster reports 'FeatureMigrationStatusMigrationNeeded' (or +-- 'FeatureMigrationStatusInProgress' / 'FeatureMigrationStatusError' +-- once the matching POST has been kicked off). +data FeatureUpgradeStatus = FeatureUpgradeStatus + { featureUpgradeStatusMigrationStatus :: FeatureMigrationStatus, + featureUpgradeStatusFeatures :: [FeatureUpgradeInfo] + } + deriving stock (Eq, Show) + +instance FromJSON FeatureUpgradeStatus where + parseJSON = withObject "FeatureUpgradeStatus" $ \o -> do + featureUpgradeStatusMigrationStatus <- o .: "migration_status" + featureUpgradeStatusFeatures <- o .:? "features" .!= [] + return FeatureUpgradeStatus {..} + +instance ToJSON FeatureUpgradeStatus where + toJSON FeatureUpgradeStatus {..} = + omitNulls $ + catMaybes + [ Just ("migration_status" .= featureUpgradeStatusMigrationStatus), + if null featureUpgradeStatusFeatures + then Nothing + else Just ("features" .= featureUpgradeStatusFeatures) + ] + +-- Lenses + +deprecationLevelLens :: Lens' Deprecation DeprecationLevel +deprecationLevelLens = + lens deprecationLevel (\x y -> x {deprecationLevel = y}) + +deprecationMessageLens :: Lens' Deprecation Text +deprecationMessageLens = + lens deprecationMessage (\x y -> x {deprecationMessage = y}) + +deprecationUrlLens :: Lens' Deprecation Text +deprecationUrlLens = + lens deprecationUrl (\x y -> x {deprecationUrl = y}) + +deprecationDetailsLens :: Lens' Deprecation (Maybe Text) +deprecationDetailsLens = + lens deprecationDetails (\x y -> x {deprecationDetails = y}) + +deprecationResolveDuringRollingUpgradeLens :: Lens' Deprecation (Maybe Bool) +deprecationResolveDuringRollingUpgradeLens = + lens deprecationResolveDuringRollingUpgrade (\x y -> x {deprecationResolveDuringRollingUpgrade = y}) + +deprecationMetaLens :: Lens' Deprecation (Maybe Value) +deprecationMetaLens = + lens deprecationMeta (\x y -> x {deprecationMeta = y}) + +migrationDeprecationsClusterSettingsLens :: Lens' MigrationDeprecations (Maybe [Deprecation]) +migrationDeprecationsClusterSettingsLens = + lens migrationDeprecationsClusterSettings (\x y -> x {migrationDeprecationsClusterSettings = y}) + +migrationDeprecationsNodeSettingsLens :: Lens' MigrationDeprecations (Maybe [Deprecation]) +migrationDeprecationsNodeSettingsLens = + lens migrationDeprecationsNodeSettings (\x y -> x {migrationDeprecationsNodeSettings = y}) + +migrationDeprecationsMlSettingsLens :: Lens' MigrationDeprecations (Maybe [Deprecation]) +migrationDeprecationsMlSettingsLens = + lens migrationDeprecationsMlSettings (\x y -> x {migrationDeprecationsMlSettings = y}) + +migrationDeprecationsIndexSettingsLens :: Lens' MigrationDeprecations (Maybe (Map Text [Deprecation])) +migrationDeprecationsIndexSettingsLens = + lens migrationDeprecationsIndexSettings (\x y -> x {migrationDeprecationsIndexSettings = y}) + +migrationDeprecationsDataStreamsLens :: Lens' MigrationDeprecations (Maybe (Map Text [Deprecation])) +migrationDeprecationsDataStreamsLens = + lens migrationDeprecationsDataStreams (\x y -> x {migrationDeprecationsDataStreams = y}) + +migrationDeprecationsTemplatesLens :: Lens' MigrationDeprecations (Maybe (Map Text [Deprecation])) +migrationDeprecationsTemplatesLens = + lens migrationDeprecationsTemplates (\x y -> x {migrationDeprecationsTemplates = y}) + +migrationDeprecationsILMPoliciesLens :: Lens' MigrationDeprecations (Maybe (Map Text [Deprecation])) +migrationDeprecationsILMPoliciesLens = + lens migrationDeprecationsILMPolicies (\x y -> x {migrationDeprecationsILMPolicies = y}) + +featureUpgradeIndexIndexLens :: Lens' FeatureUpgradeIndex Text +featureUpgradeIndexIndexLens = + lens featureUpgradeIndexIndex (\x y -> x {featureUpgradeIndexIndex = y}) + +featureUpgradeIndexVersionLens :: Lens' FeatureUpgradeIndex Text +featureUpgradeIndexVersionLens = + lens featureUpgradeIndexVersion (\x y -> x {featureUpgradeIndexVersion = y}) + +featureUpgradeIndexFailureCauseLens :: Lens' FeatureUpgradeIndex (Maybe Value) +featureUpgradeIndexFailureCauseLens = + lens featureUpgradeIndexFailureCause (\x y -> x {featureUpgradeIndexFailureCause = y}) + +featureUpgradeInfoFeatureNameLens :: Lens' FeatureUpgradeInfo Text +featureUpgradeInfoFeatureNameLens = + lens featureUpgradeInfoFeatureName (\x y -> x {featureUpgradeInfoFeatureName = y}) + +featureUpgradeInfoMinimumIndexVersionLens :: Lens' FeatureUpgradeInfo Text +featureUpgradeInfoMinimumIndexVersionLens = + lens featureUpgradeInfoMinimumIndexVersion (\x y -> x {featureUpgradeInfoMinimumIndexVersion = y}) + +featureUpgradeInfoMigrationStatusLens :: Lens' FeatureUpgradeInfo FeatureMigrationStatus +featureUpgradeInfoMigrationStatusLens = + lens featureUpgradeInfoMigrationStatus (\x y -> x {featureUpgradeInfoMigrationStatus = y}) + +featureUpgradeInfoIndicesLens :: Lens' FeatureUpgradeInfo [FeatureUpgradeIndex] +featureUpgradeInfoIndicesLens = + lens featureUpgradeInfoIndices (\x y -> x {featureUpgradeInfoIndices = y}) + +featureUpgradeStatusMigrationStatusLens :: Lens' FeatureUpgradeStatus FeatureMigrationStatus +featureUpgradeStatusMigrationStatusLens = + lens featureUpgradeStatusMigrationStatus (\x y -> x {featureUpgradeStatusMigrationStatus = y}) + +featureUpgradeStatusFeaturesLens :: Lens' FeatureUpgradeStatus [FeatureUpgradeInfo] +featureUpgradeStatusFeaturesLens = + lens featureUpgradeStatusFeatures (\x y -> x {featureUpgradeStatusFeatures = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/MultiGet.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/MultiGet.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/MultiGet.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | Types for the @POST /_mget@ (and @POST /{index}/_mget@) endpoint. +-- +-- * 'MultiGetDoc' \/ 'MultiGet' — the request body. Per-document +-- @_source@\/@stored_fields@ filtering lives on each 'MultiGetDoc' +-- (and overrides the URI-level setting for that one document). +-- * 'MultiGetOptions' — the URI-level parameters documented at +-- : +-- @_source@, @_source_includes@\/@_source_excludes@, +-- @stored_fields@, @preference@, @realtime@, @refresh@, @routing@. +-- These apply uniformly to every document in the 'MultiGet' body. +-- +-- 'MultiGetOptions' deliberately omits @version@ and @version_type@: +-- unlike the single-doc @GET \/{index}\/_doc\/{id}@ API (modelled by +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Document.GetDocumentOptions'), +-- the multi-get endpoint does not accept them as URI parameters. They +-- are only meaningful per-document, and even there the server expects +-- them nested inside each element of the @docs@ array (not on the query +-- string). Surfacing them at the URI level would be a wire-level +-- correctness bug. +module Database.Bloodhound.Internal.Versions.Common.Types.MultiGet + ( -- * Request body + MultiGetDoc (..), + mkMultiGetDoc, + MultiGet (..), + + -- * URI options + MultiGetOptions (..), + defaultMultiGetOptions, + multiGetOptionsParams, + + -- * Response + MultiGetResponse (..), + + -- * Optics + multiGetDocIdLens, + multiGetDocIndexLens, + multiGetDocSourceLens, + multiGetDocStoredFieldsLens, + multiGetDocsLens, + mgoSourceLens, + mgoSourceIncludesLens, + mgoSourceExcludesLens, + mgoStoredFieldsLens, + mgoPreferenceLens, + mgoRealtimeLens, + mgoRefreshLens, + mgoRoutingLens, + multiGetResponseDocsLens, + ) +where + +import Data.Aeson +import Database.Bloodhound.Internal.Client.BHRequest (EsResult) +import Database.Bloodhound.Internal.Utils.Imports + ( Lens', + Text, + catMaybes, + lens, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes +import Database.Bloodhound.Internal.Versions.Common.Types.Search (Source) + +data MultiGetDoc = MultiGetDoc + { multiGetDocIndex :: Maybe IndexName, + multiGetDocId :: DocId, + -- | Per-document @_source@ filtering. When set, overrides the + -- request-level @_source@ URI parameter for this single document + -- only. Accepts the same 'Source' shape as the @\_search@ body + -- field: disable entirely, include\/exclude by pattern, etc. See + -- . + multiGetDocSource :: Maybe Source, + -- | Per-document @stored_fields@ — comma-separated list of stored + -- fields to return for this document. + multiGetDocStoredFields :: Maybe Text + } + deriving stock (Eq, Show) + +-- | Construct a 'MultiGetDoc' from just its id, with no index and no +-- per-document source filtering. The most common case when building a +-- 'MultiGet' body. +mkMultiGetDoc :: DocId -> MultiGetDoc +mkMultiGetDoc docId = + MultiGetDoc + { multiGetDocIndex = Nothing, + multiGetDocId = docId, + multiGetDocSource = Nothing, + multiGetDocStoredFields = Nothing + } + +multiGetDocIndexLens :: Lens' MultiGetDoc (Maybe IndexName) +multiGetDocIndexLens = lens multiGetDocIndex (\x y -> x {multiGetDocIndex = y}) + +multiGetDocIdLens :: Lens' MultiGetDoc DocId +multiGetDocIdLens = lens multiGetDocId (\x y -> x {multiGetDocId = y}) + +multiGetDocSourceLens :: Lens' MultiGetDoc (Maybe Source) +multiGetDocSourceLens = lens multiGetDocSource (\x y -> x {multiGetDocSource = y}) + +multiGetDocStoredFieldsLens :: Lens' MultiGetDoc (Maybe Text) +multiGetDocStoredFieldsLens = lens multiGetDocStoredFields (\x y -> x {multiGetDocStoredFields = y}) + +instance ToJSON MultiGetDoc where + toJSON MultiGetDoc {..} = + object $ case multiGetDocIndex of + Just idx -> basePairs ++ ["_index" .= idx] + Nothing -> basePairs + where + basePairs = + [ "_id" .= multiGetDocId + ] + <> maybe [] (\src -> ["_source" .= src]) multiGetDocSource + <> maybe [] (\sf -> ["stored_fields" .= sf]) multiGetDocStoredFields + +newtype MultiGet = MultiGet + { multiGetDocs :: [MultiGetDoc] + } + deriving stock (Eq, Show) + +multiGetDocsLens :: Lens' MultiGet [MultiGetDoc] +multiGetDocsLens = lens multiGetDocs (\x y -> x {multiGetDocs = y}) + +instance ToJSON MultiGet where + toJSON MultiGet {..} = object ["docs" .= multiGetDocs] + +-- | URI parameters of the @POST /_mget@ and @POST /{index}/_mget@ +-- endpoints. See +-- . +-- +-- Every field is 'Maybe'; 'defaultMultiGetOptions' leaves them all +-- @Nothing@ so the legacy parameterless 'Database.Bloodhound.Common.Requests.getDocuments' +-- \/ 'Database.Bloodhound.Common.Requests.getDocumentsMulti' entry +-- points remain byte-for-byte identical on the wire, and +-- 'multiGetOptionsParams' drops @Nothing@ fields via 'catMaybes'. +-- +-- Per-document @_source@\/@stored_fields@ filtering is /not/ carried +-- here — it lives on each 'MultiGetDoc' in the 'MultiGet' body, and +-- overrides the URI-level setting for that single document. +data MultiGetOptions = MultiGetOptions + { -- | @_source@ — when @Just False@ the source is omitted from every + -- response entirely. @Just True@ emits @_source=true@ explicitly + -- (the server treats it the same as @Nothing@, which omits the + -- parameter and relies on the default of returning the source). + mgoSource :: Maybe Bool, + -- | @_source_includes@ — comma-separated field globs to include. + mgoSourceIncludes :: Maybe Text, + -- | @_source_excludes@ — comma-separated field globs to exclude. + mgoSourceExcludes :: Maybe Text, + -- | @stored_fields@ — comma-separated list of stored fields to + -- return. Note this is the deprecated 7.x field-selection + -- mechanism; new code should prefer the @fields@ body field of + -- @\_search@. It is still honoured by the multi-get API. + mgoStoredFields :: Maybe Text, + -- | @preference@ — shard\/route preference, e.g. @"_local"@. + mgoPreference :: Maybe Text, + -- | @realtime@ — when @Just False@, fetch documents from the index + -- rather than the translog (realtime). Defaults to @true@. + mgoRealtime :: Maybe Bool, + -- | @refresh@ — when @Just True@, refresh the relevant shards + -- before fetching so the multi-get sees the effect of the most + -- recent indexed documents. + mgoRefresh :: Maybe Bool, + -- | @routing@ — target shard routing value. Must match the value + -- used at index time for routed documents; applies to every + -- requested document. Per-document routing is not yet modelled on + -- 'MultiGetDoc' (the per-doc @_index@ IS available via + -- 'multiGetDocIndex'; only @_routing@ is missing). + mgoRouting :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'MultiGetOptions' with every field @Nothing@. Emits an empty query +-- string, preserving the wire behaviour of the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.getDocuments' / +-- 'Database.Bloodhound.Common.Requests.getDocumentsMulti'. +defaultMultiGetOptions :: MultiGetOptions +defaultMultiGetOptions = + MultiGetOptions + { mgoSource = Nothing, + mgoSourceIncludes = Nothing, + mgoSourceExcludes = Nothing, + mgoStoredFields = Nothing, + mgoPreference = Nothing, + mgoRealtime = Nothing, + mgoRefresh = Nothing, + mgoRouting = Nothing + } + +-- | Render a 'MultiGetOptions' record as a @key=value@ list for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. @Nothing@ +-- fields are omitted; the order of the list is stable but unspecified. +multiGetOptionsParams :: MultiGetOptions -> [(Text, Maybe Text)] +multiGetOptionsParams MultiGetOptions {..} = + catMaybes + [ ("_source",) . Just . boolText <$> mgoSource, + ("_source_includes",) . Just <$> mgoSourceIncludes, + ("_source_excludes",) . Just <$> mgoSourceExcludes, + ("stored_fields",) . Just <$> mgoStoredFields, + ("preference",) . Just <$> mgoPreference, + ("realtime",) . Just . boolText <$> mgoRealtime, + ("refresh",) . Just . boolText <$> mgoRefresh, + ("routing",) . Just <$> mgoRouting + ] + +mgoSourceLens :: Lens' MultiGetOptions (Maybe Bool) +mgoSourceLens = lens mgoSource (\x y -> x {mgoSource = y}) + +mgoSourceIncludesLens :: Lens' MultiGetOptions (Maybe Text) +mgoSourceIncludesLens = lens mgoSourceIncludes (\x y -> x {mgoSourceIncludes = y}) + +mgoSourceExcludesLens :: Lens' MultiGetOptions (Maybe Text) +mgoSourceExcludesLens = lens mgoSourceExcludes (\x y -> x {mgoSourceExcludes = y}) + +mgoStoredFieldsLens :: Lens' MultiGetOptions (Maybe Text) +mgoStoredFieldsLens = lens mgoStoredFields (\x y -> x {mgoStoredFields = y}) + +mgoPreferenceLens :: Lens' MultiGetOptions (Maybe Text) +mgoPreferenceLens = lens mgoPreference (\x y -> x {mgoPreference = y}) + +mgoRealtimeLens :: Lens' MultiGetOptions (Maybe Bool) +mgoRealtimeLens = lens mgoRealtime (\x y -> x {mgoRealtime = y}) + +mgoRefreshLens :: Lens' MultiGetOptions (Maybe Bool) +mgoRefreshLens = lens mgoRefresh (\x y -> x {mgoRefresh = y}) + +mgoRoutingLens :: Lens' MultiGetOptions (Maybe Text) +mgoRoutingLens = lens mgoRouting (\x y -> x {mgoRouting = y}) + +boolText :: Bool -> Text +boolText True = "true" +boolText False = "false" + +newtype MultiGetResponse a = MultiGetResponse + { multiGetResponseDocs :: [EsResult a] + } + deriving stock (Eq, Show) + +multiGetResponseDocsLens :: Lens' (MultiGetResponse a) [EsResult a] +multiGetResponseDocsLens = lens multiGetResponseDocs (\x y -> x {multiGetResponseDocs = y}) + +instance (FromJSON a) => FromJSON (MultiGetResponse a) where + parseJSON = withObject "MultiGetResponse" $ \o -> do + docs <- o .: "docs" + MultiGetResponse <$> mapM parseJSON docs diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/MultiSearch.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/MultiSearch.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/MultiSearch.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.Common.Types.MultiSearch + ( -- * Request + MultiSearchItem (..), + MultiSearch (..), + + -- * Response + MultiSearchResponse (..), + + -- * Optics + multiSearchItemIndexLens, + multiSearchItemSearchLens, + multiSearchItemRoutingLens, + multiSearchItemSearchTypeLens, + multiSearchItemPreferenceLens, + multiSearchItemAllowPartialSearchResultsLens, + multiSearchResponsesLens, + encodeMultiSearchItems, + ) +where + +import Data.Aeson +import Data.ByteString.Builder (Builder, byteString, lazyByteString, toLazyByteString) +import Data.ByteString.Lazy qualified as L +import Database.Bloodhound.Internal.Client.BHRequest (EsError) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes +import Database.Bloodhound.Internal.Versions.Common.Types.Search + +-- | One item in an @_msearch@ request body. +-- +-- The header line of each NDJSON pair carries per-search routing hints +-- alongside the @index@ selector. The ES msearch API documents the +-- following per-header fields +-- (): +-- +-- [@index@] target index, optional at the request level +-- [@routing@] custom routing value(s) +-- [@search_type@] @query_then_fetch@ or @dfs_query_then_fetch@ +-- [@preference@] shard preference, e.g. @_local@ +-- [@allow_partial_search_results@] tolerate shard failures for this item +-- +-- All header fields beyond 'multiSearchItemIndex' were added in +-- bloodhound-04f.7.3 and default to 'Nothing' so existing callers keep +-- their byte-for-byte wire shape. +data MultiSearchItem = MultiSearchItem + { -- | Target index for this search; 'Nothing' falls back to the + -- request-level path (e.g. @\/{index}\/_msearch@). + multiSearchItemIndex :: Maybe IndexName, + -- | Per-search routing value, rendered as @routing@ in the header line. + multiSearchItemRouting :: Maybe Text, + -- | Per-search execution mode. Rendered as @search_type@ in the header + -- line; supersedes any URI-level @search_type@ for this item. + multiSearchItemSearchType :: Maybe SearchType, + -- | Per-search shard preference, rendered as @preference@. + multiSearchItemPreference :: Maybe Text, + -- | Per-search tolerance for shard failures, rendered as + -- @allow_partial_search_results@. + multiSearchItemAllowPartialSearchResults :: Maybe Bool, + multiSearchItemSearch :: Search + } + deriving stock (Eq, Show) + +multiSearchItemIndexLens :: Lens' MultiSearchItem (Maybe IndexName) +multiSearchItemIndexLens = lens multiSearchItemIndex (\x y -> x {multiSearchItemIndex = y}) + +multiSearchItemSearchLens :: Lens' MultiSearchItem Search +multiSearchItemSearchLens = lens multiSearchItemSearch (\x y -> x {multiSearchItemSearch = y}) + +multiSearchItemRoutingLens :: Lens' MultiSearchItem (Maybe Text) +multiSearchItemRoutingLens = lens multiSearchItemRouting (\x y -> x {multiSearchItemRouting = y}) + +multiSearchItemSearchTypeLens :: Lens' MultiSearchItem (Maybe SearchType) +multiSearchItemSearchTypeLens = lens multiSearchItemSearchType (\x y -> x {multiSearchItemSearchType = y}) + +multiSearchItemPreferenceLens :: Lens' MultiSearchItem (Maybe Text) +multiSearchItemPreferenceLens = lens multiSearchItemPreference (\x y -> x {multiSearchItemPreference = y}) + +multiSearchItemAllowPartialSearchResultsLens :: Lens' MultiSearchItem (Maybe Bool) +multiSearchItemAllowPartialSearchResultsLens = + lens + multiSearchItemAllowPartialSearchResults + (\x y -> x {multiSearchItemAllowPartialSearchResults = y}) + +newtype MultiSearch = MultiSearch + { multiSearchItems :: NonEmpty MultiSearchItem + } + deriving stock (Eq, Show) + +-- | Each element corresponds to one 'MultiSearchItem' in the request, +-- preserving order. A per-item failure (e.g. the header referenced a +-- missing index, returning @{\"error\": ..., \"status\": 404}@) is +-- decoded as 'Left' 'EsError' rather than failing the whole parse with +-- 'EsProtocolException'. A successful sub-search is 'Right'. +-- +-- See 'bloodhound-0vc' for the rationale and the wire shape. +newtype MultiSearchResponse a = MultiSearchResponse + { multiSearchResponses :: [Either EsError (SearchResult a)] + } + deriving stock (Eq, Show) + +multiSearchResponsesLens :: Lens' (MultiSearchResponse a) [Either EsError (SearchResult a)] +multiSearchResponsesLens = lens multiSearchResponses (\x y -> x {multiSearchResponses = y}) + +instance ToJSON MultiSearchItem where + toJSON MultiSearchItem {..} = + -- The msearch header line uses a flat @index@ string, not the nested + -- "_index" object form; modern Elasticsearch rejects the nested form + -- with index_not_found_exception treating the whole object as the + -- index name. See bloodhound-5vp. Per-header fields (routing, + -- search_type, preference, allow_partial_search_results) ride + -- alongside @index@ in the same object. See bloodhound-04f.7.3. + object $ + catMaybes + [ ("index" .=) <$> multiSearchItemIndex, + ("routing" .=) <$> multiSearchItemRouting, + ("search_type" .=) <$> multiSearchItemSearchType, + ("preference" .=) <$> multiSearchItemPreference, + ("allow_partial_search_results" .=) <$> multiSearchItemAllowPartialSearchResults + ] + +encodeMultiSearchItems :: NonEmpty MultiSearchItem -> L.ByteString +encodeMultiSearchItems items = toLazyByteString result + where + result = mappend encodedItems (byteString "\n") + encodedItems = foldr encodeItem mempty items + encodeItem :: MultiSearchItem -> Builder -> Builder + encodeItem item acc = + acc + <> lazyByteString (encode item) + <> byteString "\n" + <> lazyByteString (encode (multiSearchItemSearch item)) + <> byteString "\n" + +instance (FromJSON a) => FromJSON (MultiSearchResponse a) where + parseJSON = withObject "MultiSearchResponse" $ \o -> do + responses <- o .: "responses" + parsedResponses <- mapM decodeItem responses + return $ MultiSearchResponse parsedResponses + +-- | Each item is either a per-search error (carrying an @error@ key, +-- see 'EsError's 'FromJSON' for the accepted shapes) or a full +-- 'SearchResult'. Discriminating on the @error@ key keeps a single bad +-- sub-search from poisoning the whole response with an +-- 'EsProtocolException' @key "took" not found@. See 'bloodhound-0vc'. +decodeItem :: + (FromJSON a) => + Value -> + Parser (Either EsError (SearchResult a)) +decodeItem = withObject "MultiSearchResponse item" $ \obj -> do + mError <- obj .:? "error" + case (mError :: Maybe Value) of + Just _ -> Left <$> parseJSON (Object obj) + Nothing -> Right <$> parseJSON (Object obj) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/MultiSearchTemplate.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/MultiSearchTemplate.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/MultiSearchTemplate.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.Common.Types.MultiSearchTemplate + ( -- * Request + MultiSearchTemplateItem (..), + + -- * Optics + multiSearchTemplateItemIndexLens, + multiSearchTemplateItemSearchTemplateLens, + multiSearchTemplateItemRoutingLens, + multiSearchTemplateItemSearchTypeLens, + multiSearchTemplateItemPreferenceLens, + multiSearchTemplateItemAllowPartialSearchResultsLens, + + -- * Encoding + encodeMultiSearchTemplateItems, + ) +where + +import Data.Aeson +import Data.ByteString.Builder (Builder, byteString, lazyByteString, toLazyByteString) +import Data.ByteString.Lazy qualified as L +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes +import Database.Bloodhound.Internal.Versions.Common.Types.Search + +-- | One item in an @_msearch/template@ request body. +-- +-- The header line of each NDJSON pair carries the same per-search hints +-- as 'MultiSearchItem' (see +-- ): +-- +-- [@index@] target index, optional at the request level +-- [@routing@] custom routing value(s) +-- [@search_type@] @query_then_fetch@ or @dfs_query_then_fetch@ +-- [@preference@] shard preference, e.g. @_local@ +-- [@allow_partial_search_results@] tolerate shard failures for this item +-- +-- The body line is a 'SearchTemplate' rendered by its existing 'ToJSON' +-- instance (@source@\/@id@, @params@, @explain@, @profile@). +data MultiSearchTemplateItem = MultiSearchTemplateItem + { -- | Target index for this search; 'Nothing' falls back to the + -- request-level path (e.g. @\/{index}\/_msearch\/template@). + multiSearchTemplateItemIndex :: Maybe IndexName, + -- | Per-search routing value, rendered as @routing@ in the header line. + multiSearchTemplateItemRouting :: Maybe Text, + -- | Per-search execution mode. Rendered as @search_type@ in the header + -- line; supersedes any URI-level @search_type@ for this item. + multiSearchTemplateItemSearchType :: Maybe SearchType, + -- | Per-search shard preference, rendered as @preference@. + multiSearchTemplateItemPreference :: Maybe Text, + -- | Per-search tolerance for shard failures, rendered as + -- @allow_partial_search_results@. + multiSearchTemplateItemAllowPartialSearchResults :: Maybe Bool, + multiSearchTemplateItemSearchTemplate :: SearchTemplate + } + deriving stock (Eq, Show) + +multiSearchTemplateItemIndexLens :: Lens' MultiSearchTemplateItem (Maybe IndexName) +multiSearchTemplateItemIndexLens = + lens multiSearchTemplateItemIndex (\x y -> x {multiSearchTemplateItemIndex = y}) + +multiSearchTemplateItemSearchTemplateLens :: Lens' MultiSearchTemplateItem SearchTemplate +multiSearchTemplateItemSearchTemplateLens = + lens + multiSearchTemplateItemSearchTemplate + (\x y -> x {multiSearchTemplateItemSearchTemplate = y}) + +multiSearchTemplateItemRoutingLens :: Lens' MultiSearchTemplateItem (Maybe Text) +multiSearchTemplateItemRoutingLens = + lens multiSearchTemplateItemRouting (\x y -> x {multiSearchTemplateItemRouting = y}) + +multiSearchTemplateItemSearchTypeLens :: Lens' MultiSearchTemplateItem (Maybe SearchType) +multiSearchTemplateItemSearchTypeLens = + lens + multiSearchTemplateItemSearchType + (\x y -> x {multiSearchTemplateItemSearchType = y}) + +multiSearchTemplateItemPreferenceLens :: Lens' MultiSearchTemplateItem (Maybe Text) +multiSearchTemplateItemPreferenceLens = + lens + multiSearchTemplateItemPreference + (\x y -> x {multiSearchTemplateItemPreference = y}) + +multiSearchTemplateItemAllowPartialSearchResultsLens :: + Lens' MultiSearchTemplateItem (Maybe Bool) +multiSearchTemplateItemAllowPartialSearchResultsLens = + lens + multiSearchTemplateItemAllowPartialSearchResults + (\x y -> x {multiSearchTemplateItemAllowPartialSearchResults = y}) + +instance ToJSON MultiSearchTemplateItem where + -- The msearch header line uses a flat @index@ string, not the nested + -- "_index" object form. The header object is shared verbatim with + -- 'MultiSearchItem'; see bloodhound-5vp and bloodhound-04f.7.3 for the + -- rationale. The body line ('SearchTemplate') is encoded separately by + -- 'encodeMultiSearchTemplateItems', so this instance only renders the + -- header. + toJSON MultiSearchTemplateItem {..} = + object $ + catMaybes + [ ("index" .=) <$> multiSearchTemplateItemIndex, + ("routing" .=) <$> multiSearchTemplateItemRouting, + ("search_type" .=) <$> multiSearchTemplateItemSearchType, + ("preference" .=) <$> multiSearchTemplateItemPreference, + ("allow_partial_search_results" .=) + <$> multiSearchTemplateItemAllowPartialSearchResults + ] + +-- | Render a non-empty list of 'MultiSearchTemplateItem's as the NDJSON +-- body of an @_msearch/template@ request: one header line + one body +-- line per item, separated by newlines, with a trailing newline. Matches +-- the wire shape produced by 'encodeMultiSearchItems' for @_msearch@. +encodeMultiSearchTemplateItems :: + NonEmpty MultiSearchTemplateItem -> + L.ByteString +encodeMultiSearchTemplateItems items = toLazyByteString result + where + result = encodedItems <> byteString "\n" + encodedItems = foldr encodeItem mempty items + encodeItem :: MultiSearchTemplateItem -> Builder -> Builder + encodeItem item acc = + acc + <> lazyByteString (encode item) + <> byteString "\n" + <> lazyByteString (encode (multiSearchTemplateItemSearchTemplate item)) + <> byteString "\n" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Newtypes.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Newtypes.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Newtypes.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Newtypes.hs @@ -9,6 +9,7 @@ ShardId (..), DocId (..), FieldName (..), + unFieldName, RelationName (..), QueryString (..), CacheName (..), @@ -30,11 +31,8 @@ StopWord (..), QueryPath (..), AllowLeadingWildcard (..), - LowercaseExpanded (..), EnablePositionIncrements (..), AnalyzeWildcard (..), - GeneratePhraseQueries (..), - Locale (..), MaxWordLength (..), MinWordLength (..), PhraseSlop (..), @@ -52,8 +50,12 @@ IndexName, unIndexName, mkIndexName, + mkIndexNameSystem, qqIndexName, IndexAliasName (..), + AliasName (..), + aliasNameToIndexAliasName, + indexAliasNameToAliasName, MaybeNA (..), SnapshotName (..), MS (..), @@ -64,21 +66,29 @@ PrecisionThreshold (..), OnMissingValue (..), Keyed (..), + Rewrite (..), + QueryName (..), + Format (..), + RangeTimeZone (..), + DateMathString (..), + CaseInsensitive (..), + Transpositions (..), + MaxDeterminizedStates (..), ) where import Control.Exception (throwIO) -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Data.Char (isLetter, isLower) -import qualified Data.Map.Strict as M -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.Map.Strict qualified as M +import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Database.Bloodhound.Internal.Utils.Imports import GHC.Generics import Language.Haskell.TH import Language.Haskell.TH.Quote -newtype From = From Int deriving newtype (Eq, Show, ToJSON) +newtype From = From Int deriving newtype (Eq, Show, ToJSON, FromJSON) newtype Size = Size Int deriving newtype (Eq, Show, ToJSON, FromJSON) @@ -108,10 +118,13 @@ -- a document needs to be specified, usually in 'Query's or 'Filter's. newtype FieldName = FieldName Text - deriving newtype (Eq, Read, Show, ToJSON, FromJSON) + deriving newtype (Eq, Read, Show, ToJSON, FromJSON, ToJSONKey, FromJSONKey, Hashable) +unFieldName :: FieldName -> Text +unFieldName (FieldName x) = x + -- | 'RelationName' describes a relation role between parend and child Documents --- in a Join relarionship: https://www.elastic.co/guide/en/elasticsearch/reference/current/parent-join.html +-- in a Join relarionship: https://www.elastic.co/guide/en/elasticsearch/reference/7.17/parent-join.html newtype RelationName = RelationName Text deriving newtype (Eq, Read, Show, ToJSON, FromJSON) @@ -219,10 +232,6 @@ = AllowLeadingWildcard Bool deriving newtype (Eq, Show, FromJSON, ToJSON) -newtype LowercaseExpanded - = LowercaseExpanded Bool - deriving newtype (Eq, Show, FromJSON, ToJSON) - newtype EnablePositionIncrements = EnablePositionIncrements Bool deriving newtype (Eq, Show, FromJSON, ToJSON) @@ -231,14 +240,6 @@ -- Setting 'AnalyzeWildcard' to true enables best-effort analysis. newtype AnalyzeWildcard = AnalyzeWildcard Bool deriving newtype (Eq, Show, FromJSON, ToJSON) --- | 'GeneratePhraseQueries' defaults to false. -newtype GeneratePhraseQueries - = GeneratePhraseQueries Bool - deriving newtype (Eq, Show, FromJSON, ToJSON) - --- | 'Locale' is used for string conversions - defaults to ROOT. -newtype Locale = Locale Text deriving newtype (Eq, Show, FromJSON, ToJSON) - newtype MaxWordLength = MaxWordLength Int deriving newtype (Eq, Show, FromJSON, ToJSON) newtype MinWordLength = MinWordLength Int deriving newtype (Eq, Show, FromJSON, ToJSON) @@ -267,7 +268,11 @@ -- | Newtype wrapper to parse ES's concerning tendency to in some APIs return a floating point number of milliseconds since epoch ಠ_ಠ newtype POSIXMS = POSIXMS {posixMS :: UTCTime} + deriving stock (Eq, Show) +instance ToJSON POSIXMS where + toJSON (POSIXMS t) = toJSON t + instance FromJSON POSIXMS where parseJSON = withScientific "POSIXMS" (return . parse) where @@ -323,6 +328,22 @@ unIndexName :: IndexName -> Text unIndexName (IndexName x) = x +-- | Build an 'IndexName' from 'Text', enforcing the Elasticsearch +-- naming rules: lowercase, no @\\\/*?\"\<\>| ,#:@, no leading @-+_+.\@, +-- no @.\@ or @..\@, at most 255 UTF-8 bytes. Returns the (human-readable) +-- failing rule as a 'Text' on the left. +-- +-- The smart constructor is deliberately strict: wildcard patterns +-- (@*@, @?@) and comma-separated lists are rejected because they are +-- not valid /index names/ — they are valid /index targets/ for +-- read-side endpoints only. When the caller needs one of those (e.g. +-- @\"logs-*\"@ for a point-in-time or resolve-index call), use an +-- 'Database.Bloodhound.Internal.Versions.Common.Types.IndexPattern' +-- built via +-- 'Database.Bloodhound.Internal.Versions.Common.Types.mkIndexPattern' +-- together with the @...With@ variant that accepts it (such as +-- 'Database.Bloodhound.Common.Requests.openPointInTimeWith' or +-- 'Database.Bloodhound.Common.Requests.resolveIndex'). mkIndexName :: Text -> Either Text IndexName mkIndexName name = do let check explanation p = if p then Right () else Left explanation @@ -334,6 +355,14 @@ check "Starts with [-_+.]" $ maybe False (flip notElem ("-_+." :: String) . fst) $ T.uncons name return $ IndexName name +-- | 'mkIndexNameSystem' is like 'mkIndexName' but permits a leading +-- @.\@ (and the literal names @.\@ and @..\@), for hidden system indices +-- such as @.kibana@. The same wildcard\/comma caveat applies: a system +-- /pattern/ target (e.g. @.logs-*@) must be expressed as an +-- 'Database.Bloodhound.Internal.Versions.Common.Types.IndexPattern' +-- via +-- 'Database.Bloodhound.Internal.Versions.Common.Types.mkIndexPattern', +-- not via this constructor. mkIndexNameSystem :: Text -> Either Text IndexName mkIndexNameSystem name = do let check explanation p = if p then Right () else Left explanation @@ -381,8 +410,31 @@ return a newtype IndexAliasName = IndexAliasName {indexAliasName :: IndexName} - deriving newtype (Eq, Show, ToJSON) + deriving newtype (Eq, Show, ToJSON, FromJSON) +-- | A bare alias name, used as a filter on the read-side alias +-- endpoints (e.g. @GET /{index}/_alias\/{name}@). Unlike +-- 'IndexAliasName' — which is the type carried by every write-side +-- alias operation ('createIndexAlias', 'deleteIndexAlias', +-- 'updateIndexAliases', ...) — 'AliasName' is only ever used to narrow +-- a lookup, never to identify an alias for mutation. The two types are +-- structurally identical (both wrap an 'IndexName') so +-- 'aliasNameToIndexAliasName' is a zero-cost conversion. +newtype AliasName = AliasName {aliasName :: IndexName} + deriving newtype (Eq, Show, ToJSON, FromJSON) + +-- | Convert an 'AliasName' into the equivalent 'IndexAliasName', for +-- callers that read with 'getIndexAlias' and then mutate via the +-- write-side alias API. +aliasNameToIndexAliasName :: AliasName -> IndexAliasName +aliasNameToIndexAliasName (AliasName n) = IndexAliasName n + +-- | The inverse of 'aliasNameToIndexAliasName': convert a write-side +-- 'IndexAliasName' (e.g. returned by 'indexAliasSummaryAlias') into +-- the 'AliasName' filter expected by 'getIndexAlias'. +indexAliasNameToAliasName :: IndexAliasName -> AliasName +indexAliasNameToAliasName (IndexAliasName n) = AliasName n + newtype MaybeNA a = MaybeNA {unMaybeNA :: Maybe a} deriving newtype (Eq, Show, Functor, Applicative, Monad) @@ -427,4 +479,52 @@ newtype Keyed = Keyed Bool + deriving newtype (Eq, Show, FromJSON, ToJSON) + +-- | Multi-term query rewrite strategy for fuzzy/regexp/prefix/wildcard +-- queries (e.g. @constant_score@, @scoring_boolean@, +-- @top_terms_N@, @top_terms_boost_N@, +-- @top_terms_blended_freqs_N@). +newtype Rewrite = Rewrite Text + deriving newtype (Eq, Show, FromJSON, ToJSON) + +-- | Name used to identify a query in the search response (the @_name@ +-- field in the ES query DSL). +newtype QueryName = QueryName Text + deriving newtype (Eq, Show, FromJSON, ToJSON) + +-- | Date format pattern for range queries (e.g. @"yyyy-MM-dd"@). +newtype Format = Format Text + deriving newtype (Eq, Show, FromJSON, ToJSON) + +-- | Time zone (e.g. @"UTC"@ or @"+01:00"@) for date range queries. Named +-- 'RangeTimeZone' to avoid clashing with 'Data.Time.LocalTime.TimeZone'. +newtype RangeTimeZone = RangeTimeZone Text + deriving newtype (Eq, Show, FromJSON, ToJSON) + +-- | An Elasticsearch date-math string used as a range-query bound +-- (e.g. @"now-1d"@, @"now/d"@, @"2020-01-01||+1d"@). Carried opaquely: +-- ES evaluates the expression server-side, so the library does not +-- parse or interpret it. See +-- . +-- +-- Note: do not wrap a plain ISO-8601 timestamp in this newtype — the +-- 'RangeValue' decoder tries 'UTCTime' before date-math, so an ISO value +-- carried here round-trips back as a 'RangeDate*' constructor, not +-- 'RangeDateMath'. Use the typed date constructors for ISO timestamps. +newtype DateMathString = DateMathString Text + deriving newtype (Eq, Show, FromJSON, ToJSON) + +-- | Case-insensitive flag for term-level queries (regexp/wildcard/prefix). +newtype CaseInsensitive = CaseInsensitive Bool + deriving newtype (Eq, Show, FromJSON, ToJSON) + +-- | Whether edit-distance calculations include transpositions for fuzzy +-- queries. +newtype Transpositions = Transpositions Bool + deriving newtype (Eq, Show, FromJSON, ToJSON) + +-- | Maximum number of automaton states that a regexp query is allowed +-- to compile. +newtype MaxDeterminizedStates = MaxDeterminizedStates Int deriving newtype (Eq, Show, FromJSON, ToJSON) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Nodes.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Nodes.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Nodes.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Nodes.hs @@ -13,6 +13,9 @@ EsUsername (..), FullNodeId (..), HealthStatus (..), + HotThreadsDocType (..), + renderHotThreadsDocType, + HotThreadsOptions (..), IndexedDocument (..), InitialShardCount (..), JVMBufferPoolStats (..), @@ -36,6 +39,9 @@ NodeHTTPStats (..), NodeIndicesStats (..), NodeInfo (..), + NodeInfoMetric (..), + renderNodeInfoMetric, + NodeInfoOptions (..), NodeJVMInfo (..), NodeJVMStats (..), NodeName (..), @@ -50,16 +56,31 @@ NodeSelection (..), NodeSelector (..), NodeStats (..), + NodeStatsLevel (..), + renderNodeStatsLevel, + NodeStatsMetric (..), + renderNodeStatsMetric, + NodeStatsOptions (..), NodeThreadPoolInfo (..), NodeThreadPoolStats (..), NodeTransportInfo (..), NodeTransportStats (..), NodesInfo (..), NodesStats (..), + defaultNodeInfoOptions, + defaultNodeStatsOptions, + defaultHotThreadsOptions, + NodesUsage (..), + NodeUsage (..), + NodeUsageMetric (..), + renderNodeUsageMetric, + NodeUsageOptions (..), + defaultNodeUsageOptions, PID (..), PluginName (..), ShardResult (..), ShardsResult (..), + ThreadCount (..), ThreadPool (..), ThreadPoolSize (..), ThreadPoolType (..), @@ -78,6 +99,38 @@ nodesClusterNameLens, nodesStatsListLens, nodesStatsClusterNameLens, + nodesUsageListLens, + nodesUsageClusterNameLens, + nuoMetricsLens, + nuoMasterTimeoutLens, + nuoTimeoutLens, + nodeUsageFullIdLens, + nodeUsageTimestampLens, + nodeUsageSinceLens, + nodeUsageRestActionsLens, + nodeUsageAggregationsLens, + nioMetricsLens, + nioMasterTimeoutLens, + nioFlatSettingsLens, + nioTimeoutLens, + nsoMetricsLens, + nsoMasterTimeoutLens, + nsoCompletionFieldsLens, + nsoFielddataFieldsLens, + nsoFieldsLens, + nsoGroupsLens, + nsoLevelLens, + nsoTypesLens, + nsoTimeoutLens, + nsoIncludeSegmentFileSizesLens, + nsoIncludeUnloadedSegmentsLens, + htoThreadsLens, + htoIntervalLens, + htoSnapshotsLens, + htoDocTypeLens, + htoIgnoreIdleThreadsLens, + htoMasterTimeoutLens, + htoTimeoutLens, nodeStatsNameLens, nodeStatsFullIdLens, nodeStatsBreakersStatsLens, @@ -387,12 +440,13 @@ ) where -import qualified Data.Aeson.KeyMap as X -import qualified Data.HashMap.Strict as HM +import Data.Aeson.KeyMap qualified as X +import Data.HashMap.Strict qualified as HM import Data.Map.Strict (Map) -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Data.Versions as Versions +import Data.Text qualified as T +import Data.Vector qualified as V +import Data.Versions qualified as Versions +import Data.Word (Word32, Word64) import Database.Bloodhound.Internal.Client.BHRequest import Database.Bloodhound.Internal.Utils.Imports import Database.Bloodhound.Internal.Utils.StringlyTyped @@ -414,7 +468,7 @@ newtype NodeAttrName = NodeAttrName Text deriving stock (Eq, Ord, Show) --- | 'NodeSelection' is used for most cluster APIs. See for more details. +-- | 'NodeSelection' is used for most cluster APIs. See for more details. data NodeSelection = -- | Whatever node receives this request LocalNode @@ -442,6 +496,237 @@ NodeByAttribute NodeAttrName Text deriving stock (Eq, Show) +-- | Number of hot threads to identify for the +-- @GET /_nodes/hot_threads@ endpoint. Maps to the @threads@ URI +-- parameter (default 3 server-side). +-- +-- The constructor is intentionally permissive: the server rejects +-- non-positive values with a @400@, so callers wanting compile-time +-- validation should add a smart constructor at the call site. +newtype ThreadCount = ThreadCount {threadCount :: Int} + deriving newtype (Eq, Ord, Show, ToJSON, FromJSON) + +-- | Kind of hot threads to report for the @GET /_nodes/hot_threads@ +-- endpoint. Maps to the @type@ URI parameter, accepted by both ES and +-- OpenSearch (the historical name @doc_type@ is not recognised by the +-- server). Documented values are @cpu@ (default), @wait@ and @block@; +-- anything else is preserved verbatim via 'OtherHotThreadsDocType' +-- (which only flows through 'ToJSON' / 'renderHotThreadsDocType' — +-- 'FromJSON' rejects unknown strings, matching 'NodeInfoMetric'). +-- +-- See +-- +-- and . +data HotThreadsDocType + = HotThreadsDocTypeCPU + | HotThreadsDocTypeWait + | HotThreadsDocTypeBlock + | OtherHotThreadsDocType Text + deriving stock (Eq, Show) + +-- | Wire string for a 'HotThreadsDocType'. @cpu@ / @wait@ / @block@ +-- render to their lowercase names; 'OtherHotThreadsDocType' renders the +-- wrapped 'Text' verbatim. +renderHotThreadsDocType :: HotThreadsDocType -> Text +renderHotThreadsDocType HotThreadsDocTypeCPU = "cpu" +renderHotThreadsDocType HotThreadsDocTypeWait = "wait" +renderHotThreadsDocType HotThreadsDocTypeBlock = "block" +renderHotThreadsDocType (OtherHotThreadsDocType t) = t + +instance ToJSON HotThreadsDocType where + toJSON = String . renderHotThreadsDocType + +instance FromJSON HotThreadsDocType where + parseJSON = withText "HotThreadsDocType" parse + where + parse t = case lookup t renderedPairs of + Just d -> return d + Nothing -> fail ("Unexpected hot threads doc type " <> T.unpack t) + where + renderedPairs = [(renderHotThreadsDocType d, d) | d <- allHotThreadsDocTypes] + +-- | Exhaustive list of the named 'HotThreadsDocType' constructors +-- (excluding 'OtherHotThreadsDocType', which is open-ended). Used by +-- 'FromJSON' to look up known wire strings; unknown strings are rejected +-- (preserving the semantics shared with 'NodeInfoMetric'). +allHotThreadsDocTypes :: [HotThreadsDocType] +allHotThreadsDocTypes = + [ HotThreadsDocTypeCPU, + HotThreadsDocTypeWait, + HotThreadsDocTypeBlock + ] + +-- | Optional URI parameters for the @GET /_nodes/hot_threads@ endpoint, +-- consumed by +-- 'Database.Bloodhound.Common.Requests.getNodesHotThreadsWith'. Every +-- field is optional so that 'defaultHotThreadsOptions' renders to no +-- parameters at all — byte-for-byte identical to the legacy +-- 'Database.Bloodhound.Common.Requests.getNodesHotThreads' called with +-- @Nothing@ thread count. +-- +-- Durations are modelled as a @(unit, magnitude)@ pair, matching the +-- @time-units@ grammar shared with 'NodeInfoOptions' (e.g. +-- @('TimeUnitMilliseconds', 500)@ renders as @500ms@). +-- +-- Fields: +-- +-- * @htoThreads@ -> @threads@ (see 'ThreadCount', default 3 server-side). +-- * @htoInterval@ -> @interval@ (sampling interval, default @500ms@). +-- * @htoSnapshots@ -> @snapshots@ (number of stack trace samples, default 10). +-- * @htoDocType@ -> @type@ (accepted by both ES and OpenSearch; the +-- historical @doc_type@ name is not recognised by the server). +-- * @htoIgnoreIdleThreads@ -> @ignore_idle_threads@ (default @true@). +-- * @htoMasterTimeout@ -> @master_timeout@ (deprecated ES alias of +-- @cluster_manager_timeout@; OS-specific naming is tracked separately +-- under param-completion). +-- * @htoTimeout@ -> @timeout@ (operation timeout). +data HotThreadsOptions = HotThreadsOptions + { htoThreads :: Maybe ThreadCount, + htoInterval :: Maybe (TimeUnits, Word32), + htoSnapshots :: Maybe Word32, + htoDocType :: Maybe HotThreadsDocType, + htoIgnoreIdleThreads :: Maybe Bool, + htoMasterTimeout :: Maybe (TimeUnits, Word32), + htoTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'HotThreadsOptions' with every parameter set to 'Nothing'. Produces +-- no query string, so @'getNodesHotThreadsWith' sel 'defaultHotThreadsOptions'@ +-- emits a request identical to 'getNodesHotThreads' called with +-- @Nothing@ thread count. +defaultHotThreadsOptions :: HotThreadsOptions +defaultHotThreadsOptions = + HotThreadsOptions + { htoThreads = Nothing, + htoInterval = Nothing, + htoSnapshots = Nothing, + htoDocType = Nothing, + htoIgnoreIdleThreads = Nothing, + htoMasterTimeout = Nothing, + htoTimeout = Nothing + } + +htoThreadsLens :: Lens' HotThreadsOptions (Maybe ThreadCount) +htoThreadsLens = lens htoThreads (\x y -> x {htoThreads = y}) + +htoIntervalLens :: Lens' HotThreadsOptions (Maybe (TimeUnits, Word32)) +htoIntervalLens = lens htoInterval (\x y -> x {htoInterval = y}) + +htoSnapshotsLens :: Lens' HotThreadsOptions (Maybe Word32) +htoSnapshotsLens = lens htoSnapshots (\x y -> x {htoSnapshots = y}) + +htoDocTypeLens :: Lens' HotThreadsOptions (Maybe HotThreadsDocType) +htoDocTypeLens = lens htoDocType (\x y -> x {htoDocType = y}) + +htoIgnoreIdleThreadsLens :: Lens' HotThreadsOptions (Maybe Bool) +htoIgnoreIdleThreadsLens = lens htoIgnoreIdleThreads (\x y -> x {htoIgnoreIdleThreads = y}) + +htoMasterTimeoutLens :: Lens' HotThreadsOptions (Maybe (TimeUnits, Word32)) +htoMasterTimeoutLens = lens htoMasterTimeout (\x y -> x {htoMasterTimeout = y}) + +htoTimeoutLens :: Lens' HotThreadsOptions (Maybe (TimeUnits, Word32)) +htoTimeoutLens = lens htoTimeout (\x y -> x {htoTimeout = y}) + +-- | Metric filters accepted by @GET /_nodes\/{nodeIds}\/{metrics}@ — +-- the @/_nodes@ /info/ endpoint, distinct from 'NodeStatsMetric' which +-- covers @/_nodes\/...\/stats@. Each documented top-level metric is +-- enumerated; anything else (e.g. version-specific or plugin-emitted +-- metric names) is preserved verbatim via 'OtherNodeInfoMetric'. +-- +-- See +-- +-- and . +data NodeInfoMetric + = NodeInfoMetricSettings + | NodeInfoMetricOS + | NodeInfoMetricProcess + | NodeInfoMetricJVM + | NodeInfoMetricThreadPool + | NodeInfoMetricTransport + | NodeInfoMetricHTTP + | NodeInfoMetricPlugins + | NodeInfoMetricIngest + | NodeInfoMetricAggregations + | NodeInfoMetricIndices + | NodeInfoMetricDiscovery + | NodeInfoMetricScripting + | NodeInfoMetricAction + | OtherNodeInfoMetric Text + deriving stock (Eq, Show) + +-- | Wire string for a 'NodeInfoMetric'. Used by +-- 'Database.Bloodhound.Common.Requests.getNodesInfoWith' to render the +-- path segment of @GET /_nodes\/{nodeIds}\/{metrics}@. +renderNodeInfoMetric :: NodeInfoMetric -> Text +renderNodeInfoMetric NodeInfoMetricSettings = "settings" +renderNodeInfoMetric NodeInfoMetricOS = "os" +renderNodeInfoMetric NodeInfoMetricProcess = "process" +renderNodeInfoMetric NodeInfoMetricJVM = "jvm" +renderNodeInfoMetric NodeInfoMetricThreadPool = "thread_pool" +renderNodeInfoMetric NodeInfoMetricTransport = "transport" +renderNodeInfoMetric NodeInfoMetricHTTP = "http" +renderNodeInfoMetric NodeInfoMetricPlugins = "plugins" +renderNodeInfoMetric NodeInfoMetricIngest = "ingest" +renderNodeInfoMetric NodeInfoMetricAggregations = "aggregations" +renderNodeInfoMetric NodeInfoMetricIndices = "indices" +renderNodeInfoMetric NodeInfoMetricDiscovery = "discovery" +renderNodeInfoMetric NodeInfoMetricScripting = "scripting" +renderNodeInfoMetric NodeInfoMetricAction = "action" +renderNodeInfoMetric (OtherNodeInfoMetric t) = t + +-- | Metric filters accepted by @GET /_nodes\/{nodeIds}\/stats\/{metrics}@. +-- The stats endpoint shares some metric names with 'NodeInfoMetric' but +-- covers a different (mostly runtime-counter) set; metrics only valid +-- here (e.g. @fs@, @breakers@, @cgroup@) are not in 'NodeInfoMetric'. +-- Anything not enumerated (e.g. version-specific or plugin-emitted +-- metric names) is preserved verbatim via 'OtherNodeStatsMetric'. +-- +-- See +-- +-- and . +data NodeStatsMetric + = NodeStatsMetricIndices + | NodeStatsMetricOS + | NodeStatsMetricProcess + | NodeStatsMetricJVM + | NodeStatsMetricThreadPool + | NodeStatsMetricFS + | NodeStatsMetricTransport + | NodeStatsMetricHTTP + | NodeStatsMetricBreakers + | NodeStatsMetricScript + | NodeStatsMetricDiscovery + | NodeStatsMetricIngest + | NodeStatsMetricAdaptiveSelection + | NodeStatsMetricScriptCache + | NodeStatsMetricIndexingPressure + | NodeStatsMetricCgroup + | OtherNodeStatsMetric Text + deriving stock (Eq, Show) + +-- | Wire string for a 'NodeStatsMetric'. Used by +-- 'Database.Bloodhound.Common.Requests.getNodesStatsWith' to render the +-- path segment of @GET /_nodes\/{nodeIds}\/stats\/{metrics}@. +renderNodeStatsMetric :: NodeStatsMetric -> Text +renderNodeStatsMetric NodeStatsMetricIndices = "indices" +renderNodeStatsMetric NodeStatsMetricOS = "os" +renderNodeStatsMetric NodeStatsMetricProcess = "process" +renderNodeStatsMetric NodeStatsMetricJVM = "jvm" +renderNodeStatsMetric NodeStatsMetricThreadPool = "thread_pool" +renderNodeStatsMetric NodeStatsMetricFS = "fs" +renderNodeStatsMetric NodeStatsMetricTransport = "transport" +renderNodeStatsMetric NodeStatsMetricHTTP = "http" +renderNodeStatsMetric NodeStatsMetricBreakers = "breakers" +renderNodeStatsMetric NodeStatsMetricScript = "script" +renderNodeStatsMetric NodeStatsMetricDiscovery = "discovery" +renderNodeStatsMetric NodeStatsMetricIngest = "ingest" +renderNodeStatsMetric NodeStatsMetricAdaptiveSelection = "adaptive_selection" +renderNodeStatsMetric NodeStatsMetricScriptCache = "script_cache" +renderNodeStatsMetric NodeStatsMetricIndexingPressure = "indexing_pressure" +renderNodeStatsMetric NodeStatsMetricCgroup = "cgroup" +renderNodeStatsMetric (OtherNodeStatsMetric t) = t + nodeSelectorNodeByNamePrism :: Prism' NodeSelector NodeName nodeSelectorNodeByNamePrism = prism NodeByName extract where @@ -517,6 +802,259 @@ nodesStatsClusterNameLens :: Lens' NodesStats ClusterName nodesStatsClusterNameLens = lens nodesStatsClusterName (\x y -> x {nodesStatsClusterName = y}) +-- | Optional parameters for @GET /_nodes/{nodes}/info@. All fields +-- are 'Maybe' so that 'defaultNodeInfoOptions' renders a request +-- byte-for-byte identical to the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.getNodesInfo'. +-- +-- @nioMetrics@ becomes the @/{metrics}@ path segment (comma-joined, +-- e.g. @"jvm,os"@); 'Nothing' or @'Just' []@ omits the segment. +-- +-- The remaining fields are the documented query parameters +-- (): +-- +-- [@nioFlatSettings@] @flat_settings@ — render settings in flat format. +-- [@nioMasterTimeout@] @master_timeout@ — the ES-accepted alias of +-- @cluster_manager_timeout@ (OS-specific naming is tracked separately +-- under param-completion). +-- [@nioTimeout@] @timeout@ — period to wait for a response. +data NodeInfoOptions = NodeInfoOptions + { nioMetrics :: Maybe [NodeInfoMetric], + nioFlatSettings :: Maybe Bool, + nioMasterTimeout :: Maybe (TimeUnits, Word32), + nioTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'NodeInfoOptions' with every field set to 'Nothing'. Renders no +-- path or query additions, so @'getNodesInfoWith' sel 'defaultNodeInfoOptions'@ +-- emits the same URL as 'getNodesInfo'. +defaultNodeInfoOptions :: NodeInfoOptions +defaultNodeInfoOptions = + NodeInfoOptions + { nioMetrics = Nothing, + nioFlatSettings = Nothing, + nioMasterTimeout = Nothing, + nioTimeout = Nothing + } + +nioMetricsLens :: Lens' NodeInfoOptions (Maybe [NodeInfoMetric]) +nioMetricsLens = lens nioMetrics (\x y -> x {nioMetrics = y}) + +nioFlatSettingsLens :: Lens' NodeInfoOptions (Maybe Bool) +nioFlatSettingsLens = lens nioFlatSettings (\x y -> x {nioFlatSettings = y}) + +nioMasterTimeoutLens :: Lens' NodeInfoOptions (Maybe (TimeUnits, Word32)) +nioMasterTimeoutLens = lens nioMasterTimeout (\x y -> x {nioMasterTimeout = y}) + +nioTimeoutLens :: Lens' NodeInfoOptions (Maybe (TimeUnits, Word32)) +nioTimeoutLens = lens nioTimeout (\x y -> x {nioTimeout = y}) + +-- | @level@ URI parameter for the nodes-stats endpoint +-- (). +-- Controls whether statistics are aggregated at the cluster, index, or +-- shard level. Mirrors the cluster-health @level@ enum but kept distinct +-- since the endpoints are different (the wire strings coincide: @cluster@, +-- @indices@, @shards@). +data NodeStatsLevel + = NodeStatsLevelCluster + | NodeStatsLevelIndices + | NodeStatsLevelShards + deriving stock (Eq, Show) + +-- | Render a 'NodeStatsLevel' to its wire string (@cluster@, @indices@, +-- @shards@). +renderNodeStatsLevel :: NodeStatsLevel -> Text +renderNodeStatsLevel NodeStatsLevelCluster = "cluster" +renderNodeStatsLevel NodeStatsLevelIndices = "indices" +renderNodeStatsLevel NodeStatsLevelShards = "shards" + +-- | Optional parameters for @GET /_nodes/{nodes}/stats@. Same +-- conventions as 'NodeInfoOptions'. +-- +-- The query fields are the documented parameters +-- (): +-- +-- [@nsoCompletionFields@] @completion_fields@ — fields to include in @fielddata@ and @suggest@ statistics. +-- [@nsoFielddataFields@] @fielddata_fields@ — fields to include in @fielddata@ statistics. +-- [@nsoFields@] @fields@ — field list for @fielddata@ and @completion@; used as the default unless @completion_fields@\/@fielddata_fields@ are set. +-- [@nsoGroups@] @groups@ — search groups to include in @search@ statistics. +-- [@nsoLevel@] @level@ — aggregation level (see 'NodeStatsLevel'). +-- [@nsoTypes@] @types@ — document types for the @indexing@ index metric. +-- [@nsoMasterTimeout@] @master_timeout@. +-- [@nsoTimeout@] @timeout@. +-- [@nsoIncludeSegmentFileSizes@] @include_segment_file_sizes@. +-- [@nsoIncludeUnloadedSegments@] @include_unloaded_segments@. +data NodeStatsOptions = NodeStatsOptions + { nsoMetrics :: Maybe [NodeStatsMetric], + nsoCompletionFields :: Maybe Text, + nsoFielddataFields :: Maybe Text, + nsoFields :: Maybe Text, + nsoGroups :: Maybe Text, + nsoLevel :: Maybe NodeStatsLevel, + nsoTypes :: Maybe Text, + nsoMasterTimeout :: Maybe (TimeUnits, Word32), + nsoTimeout :: Maybe (TimeUnits, Word32), + nsoIncludeSegmentFileSizes :: Maybe Bool, + nsoIncludeUnloadedSegments :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'NodeStatsOptions' with every field set to 'Nothing'. Renders no +-- path or query additions, so @'getNodesStatsWith' sel 'defaultNodeStatsOptions'@ +-- emits the same URL as 'getNodesStats'. +defaultNodeStatsOptions :: NodeStatsOptions +defaultNodeStatsOptions = + NodeStatsOptions + { nsoMetrics = Nothing, + nsoCompletionFields = Nothing, + nsoFielddataFields = Nothing, + nsoFields = Nothing, + nsoGroups = Nothing, + nsoLevel = Nothing, + nsoTypes = Nothing, + nsoMasterTimeout = Nothing, + nsoTimeout = Nothing, + nsoIncludeSegmentFileSizes = Nothing, + nsoIncludeUnloadedSegments = Nothing + } + +nsoMetricsLens :: Lens' NodeStatsOptions (Maybe [NodeStatsMetric]) +nsoMetricsLens = lens nsoMetrics (\x y -> x {nsoMetrics = y}) + +nsoCompletionFieldsLens :: Lens' NodeStatsOptions (Maybe Text) +nsoCompletionFieldsLens = lens nsoCompletionFields (\x y -> x {nsoCompletionFields = y}) + +nsoFielddataFieldsLens :: Lens' NodeStatsOptions (Maybe Text) +nsoFielddataFieldsLens = lens nsoFielddataFields (\x y -> x {nsoFielddataFields = y}) + +nsoFieldsLens :: Lens' NodeStatsOptions (Maybe Text) +nsoFieldsLens = lens nsoFields (\x y -> x {nsoFields = y}) + +nsoGroupsLens :: Lens' NodeStatsOptions (Maybe Text) +nsoGroupsLens = lens nsoGroups (\x y -> x {nsoGroups = y}) + +nsoLevelLens :: Lens' NodeStatsOptions (Maybe NodeStatsLevel) +nsoLevelLens = lens nsoLevel (\x y -> x {nsoLevel = y}) + +nsoTypesLens :: Lens' NodeStatsOptions (Maybe Text) +nsoTypesLens = lens nsoTypes (\x y -> x {nsoTypes = y}) + +nsoMasterTimeoutLens :: Lens' NodeStatsOptions (Maybe (TimeUnits, Word32)) +nsoMasterTimeoutLens = lens nsoMasterTimeout (\x y -> x {nsoMasterTimeout = y}) + +nsoTimeoutLens :: Lens' NodeStatsOptions (Maybe (TimeUnits, Word32)) +nsoTimeoutLens = lens nsoTimeout (\x y -> x {nsoTimeout = y}) + +nsoIncludeSegmentFileSizesLens :: Lens' NodeStatsOptions (Maybe Bool) +nsoIncludeSegmentFileSizesLens = lens nsoIncludeSegmentFileSizes (\x y -> x {nsoIncludeSegmentFileSizes = y}) + +nsoIncludeUnloadedSegmentsLens :: Lens' NodeStatsOptions (Maybe Bool) +nsoIncludeUnloadedSegmentsLens = lens nsoIncludeUnloadedSegments (\x y -> x {nsoIncludeUnloadedSegments = y}) + +-- | Top-level container returned by @GET /_nodes/usage@. Mirrors the +-- shape of 'NodesInfo' \/ 'NodesStats': a list of per-node records and +-- the cluster name. The @_nodes@ summary sub-object +-- (total\/successful\/failed) is intentionally not modelled, matching +-- 'NodesInfo'. +data NodesUsage = NodesUsage + { nodesUsage :: [NodeUsage], + nodesUsageClusterName :: ClusterName + } + deriving stock (Eq, Show) + +nodesUsageListLens :: Lens' NodesUsage [NodeUsage] +nodesUsageListLens = lens nodesUsage (\x y -> x {nodesUsage = y}) + +nodesUsageClusterNameLens :: Lens' NodesUsage ClusterName +nodesUsageClusterNameLens = lens nodesUsageClusterName (\x y -> x {nodesUsageClusterName = y}) + +-- | Per-node usage record returned under @.nodes@ by +-- @GET /_nodes\/{nodeIds}\/usage@. @timestamp@ and @since@ are both +-- epoch millis; 'Maybe' because the server may omit them. +-- @rest_actions@ maps REST action names to invocation counts. +-- @aggregations@ maps aggregation types to a per-field-type count map. +data NodeUsage = NodeUsage + { nodeUsageFullId :: FullNodeId, + nodeUsageTimestamp :: Maybe Word64, + nodeUsageSince :: Maybe Word64, + nodeUsageRestActions :: Map Text Int, + nodeUsageAggregations :: Map Text (Map Text Int) + } + deriving stock (Eq, Show) + +nodeUsageFullIdLens :: Lens' NodeUsage FullNodeId +nodeUsageFullIdLens = lens nodeUsageFullId (\x y -> x {nodeUsageFullId = y}) + +nodeUsageTimestampLens :: Lens' NodeUsage (Maybe Word64) +nodeUsageTimestampLens = lens nodeUsageTimestamp (\x y -> x {nodeUsageTimestamp = y}) + +nodeUsageSinceLens :: Lens' NodeUsage (Maybe Word64) +nodeUsageSinceLens = lens nodeUsageSince (\x y -> x {nodeUsageSince = y}) + +nodeUsageRestActionsLens :: Lens' NodeUsage (Map Text Int) +nodeUsageRestActionsLens = lens nodeUsageRestActions (\x y -> x {nodeUsageRestActions = y}) + +nodeUsageAggregationsLens :: Lens' NodeUsage (Map Text (Map Text Int)) +nodeUsageAggregationsLens = lens nodeUsageAggregations (\x y -> x {nodeUsageAggregations = y}) + +-- | Metric filters accepted by @GET /_nodes\/{nodeIds}\/usage\/{metrics}@. +-- Documented metrics are @rest_actions@ and @aggregations@; anything +-- else (e.g. version-specific or plugin-emitted metric names) is +-- preserved verbatim via 'OtherNodeUsageMetric'. +-- +-- See +-- +-- and . +data NodeUsageMetric + = NodeUsageMetricRestActions + | NodeUsageMetricAggregations + | OtherNodeUsageMetric Text + deriving stock (Eq, Show) + +-- | Wire string for a 'NodeUsageMetric'. Used by +-- 'Database.Bloodhound.Common.Requests.getNodesUsageWith' to render the +-- path segment of @GET /_nodes\/{nodeIds}\/usage\/{metrics}@. +renderNodeUsageMetric :: NodeUsageMetric -> Text +renderNodeUsageMetric NodeUsageMetricRestActions = "rest_actions" +renderNodeUsageMetric NodeUsageMetricAggregations = "aggregations" +renderNodeUsageMetric (OtherNodeUsageMetric t) = t + +-- | Optional parameters for @GET /_nodes/{nodes}/usage@. Same +-- conventions as 'NodeStatsOptions'. +-- +-- The query fields are the documented parameters +-- (): +-- +-- [@nuoMasterTimeout@] @master_timeout@. +-- [@nuoTimeout@] @timeout@. +data NodeUsageOptions = NodeUsageOptions + { nuoMetrics :: Maybe [NodeUsageMetric], + nuoMasterTimeout :: Maybe (TimeUnits, Word32), + nuoTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'NodeUsageOptions' with every field set to 'Nothing'. Renders no +-- path or query additions, so @'getNodesUsageWith' sel 'defaultNodeUsageOptions'@ +-- emits the same URL as 'getNodesUsage'. +defaultNodeUsageOptions :: NodeUsageOptions +defaultNodeUsageOptions = + NodeUsageOptions + { nuoMetrics = Nothing, + nuoMasterTimeout = Nothing, + nuoTimeout = Nothing + } + +nuoMetricsLens :: Lens' NodeUsageOptions (Maybe [NodeUsageMetric]) +nuoMetricsLens = lens nuoMetrics (\x y -> x {nuoMetrics = y}) + +nuoMasterTimeoutLens :: Lens' NodeUsageOptions (Maybe (TimeUnits, Word32)) +nuoMasterTimeoutLens = lens nuoMasterTimeout (\x y -> x {nuoMasterTimeout = y}) + +nuoTimeoutLens :: Lens' NodeUsageOptions (Maybe (TimeUnits, Word32)) +nuoTimeoutLens = lens nuoTimeout (\x y -> x {nuoTimeout = y}) + data NodeStats = NodeStats { nodeStatsName :: NodeName, nodeStatsFullId :: FullNodeId, @@ -1571,6 +2109,7 @@ | ThreadPoolFixed | ThreadPoolCached | ThreadPoolFixedAutoQueueSize + | ThreadPoolResizable deriving stock (Eq, Show) data NodeJVMInfo = NodeJVMInfo @@ -1721,7 +2260,7 @@ cpuInfoVendorLens = lens cpuVendor (\x y -> x {cpuVendor = y}) data NodeProcessInfo = NodeProcessInfo - { -- | See + { -- | See nodeProcessMLockAll :: Bool, nodeProcessMaxFileDescriptors :: Maybe Int, nodeProcessId :: PID, @@ -1763,6 +2302,34 @@ cn <- o .: "cluster_name" return (NodesStats stats cn) +instance FromJSON NodesUsage where + parseJSON = withObject "NodesUsage" $ \o -> do + nodes <- o .: "nodes" + usages <- + forM (HM.toList nodes) $ + \(fullNID, v) -> + withObject "NodeUsage" (parseNodeUsage (FullNodeId fullNID)) v + cn <- o .: "cluster_name" + return (NodesUsage usages cn) + +-- | Parse a single per-node object from the @.nodes@ map of a +-- @GET /_nodes/usage@ response. @timestamp@ and @since@ are epoch +-- millis, @rest_actions@ is a @Map Text Int@, @aggregations@ is a +-- @Map Text (Map Text Int)@ (aggregation type → field type → count). +parseNodeUsage :: FullNodeId -> Object -> Parser NodeUsage +parseNodeUsage fid o = + NodeUsage fid + <$> o + .:? "timestamp" + <*> o + .:? "since" + <*> o + .:? "rest_actions" + .!= mempty + <*> o + .:? "aggregations" + .!= mempty + instance FromJSON NodeBreakerStats where parseJSON = withObject "NodeBreakerStats" parse where @@ -2440,7 +3007,95 @@ parse "fixed" = return ThreadPoolFixed parse "cached" = return ThreadPoolCached parse "fixed_auto_queue_size" = return ThreadPoolFixedAutoQueueSize + parse "resizable" = return ThreadPoolResizable parse e = fail ("Unexpected thread pool type" <> T.unpack e) + +instance ToJSON NodeInfoMetric where + toJSON = toJSON . renderNodeInfoMetric + +instance FromJSON NodeInfoMetric where + parseJSON = withText "NodeInfoMetric" parse + where + parse t = case lookup t renderedPairs of + Just m -> return m + Nothing -> fail ("Unexpected node info metric " <> T.unpack t) + where + renderedPairs = [(renderNodeInfoMetric m, m) | m <- allNodeInfoMetrics] + +instance ToJSON NodeStatsMetric where + toJSON = toJSON . renderNodeStatsMetric + +instance FromJSON NodeStatsMetric where + parseJSON = withText "NodeStatsMetric" parse + where + parse t = case lookup t renderedPairs of + Just m -> return m + Nothing -> fail ("Unexpected node stats metric " <> T.unpack t) + where + renderedPairs = [(renderNodeStatsMetric m, m) | m <- allNodeStatsMetrics] + +instance ToJSON NodeUsageMetric where + toJSON = toJSON . renderNodeUsageMetric + +instance FromJSON NodeUsageMetric where + parseJSON = withText "NodeUsageMetric" parse + where + parse t = case lookup t renderedPairs of + Just m -> return m + Nothing -> fail ("Unexpected node usage metric " <> T.unpack t) + where + renderedPairs = [(renderNodeUsageMetric m, m) | m <- allNodeUsageMetrics] + +-- | Exhaustive list of the named 'NodeUsageMetric' constructors +-- (excluding 'OtherNodeUsageMetric', which is open-ended). Used by +-- 'FromJSON' to look up known wire strings; unknown strings are rejected +-- (preserving the pre-existing semantics shared with 'NodeInfoMetric'). +allNodeUsageMetrics :: [NodeUsageMetric] +allNodeUsageMetrics = [NodeUsageMetricRestActions, NodeUsageMetricAggregations] + +-- | Exhaustive list of the named 'NodeInfoMetric' constructors (excluding +-- 'OtherNodeInfoMetric', which is open-ended). Used by 'FromJSON' to look +-- up known wire strings; unknown strings decode to 'Nothing' (preserving +-- the pre-existing reject-unknown semantics). +allNodeInfoMetrics :: [NodeInfoMetric] +allNodeInfoMetrics = + [ NodeInfoMetricSettings, + NodeInfoMetricOS, + NodeInfoMetricProcess, + NodeInfoMetricJVM, + NodeInfoMetricThreadPool, + NodeInfoMetricTransport, + NodeInfoMetricHTTP, + NodeInfoMetricPlugins, + NodeInfoMetricIngest, + NodeInfoMetricAggregations, + NodeInfoMetricIndices, + NodeInfoMetricDiscovery, + NodeInfoMetricScripting, + NodeInfoMetricAction + ] + +-- | Exhaustive list of the named 'NodeStatsMetric' constructors (excluding +-- 'OtherNodeStatsMetric'). +allNodeStatsMetrics :: [NodeStatsMetric] +allNodeStatsMetrics = + [ NodeStatsMetricIndices, + NodeStatsMetricOS, + NodeStatsMetricProcess, + NodeStatsMetricJVM, + NodeStatsMetricThreadPool, + NodeStatsMetricFS, + NodeStatsMetricTransport, + NodeStatsMetricHTTP, + NodeStatsMetricBreakers, + NodeStatsMetricScript, + NodeStatsMetricDiscovery, + NodeStatsMetricIngest, + NodeStatsMetricAdaptiveSelection, + NodeStatsMetricScriptCache, + NodeStatsMetricIndexingPressure, + NodeStatsMetricCgroup + ] instance FromJSON NodeTransportInfo where parseJSON = withObject "NodeTransportInfo" parse diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/OpType.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/OpType.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/OpType.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Shared @op_type@ parameter used by the Index, Update, Bulk and Reindex +-- APIs. Elasticsearch accepts only two values: +-- +-- * @index@ — create the document if it does not exist, or replace an +-- existing one (the default behaviour of 'Database.Bloodhound.Common.Requests.indexDocument'). +-- * @create@ — fail with HTTP 409 (@version_conflict_engine_exception@) +-- if a document with the same @_id@ already exists. +-- +-- See +-- (Index API) and +-- (Reindex API). +module Database.Bloodhound.Internal.Versions.Common.Types.OpType + ( OpType (..), + renderOpType, + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withText) +import Data.Text (Text) +import GHC.Generics (Generic) + +data OpType + = -- | Render as @"create"@ — index only if no document with the same + -- @_id@ exists; otherwise the server returns HTTP 409. + OpCreate + | -- | Render as @"index"@ — create or overwrite (default). + OpIndex + deriving stock (Eq, Show, Generic) + +instance FromJSON OpType where + parseJSON = withText "OpType" $ \case + "create" -> pure OpCreate + "index" -> pure OpIndex + s -> fail $ "Expected one of [create, index], found: " <> show s + +instance ToJSON OpType where + toJSON OpCreate = String "create" + toJSON OpIndex = String "index" + +-- | Render as the bare URI parameter value (without quotes), e.g. +-- @\"create\"@. Suitable for use as a @op_type=...@ query-string parameter. +renderOpType :: OpType -> Text +renderOpType OpCreate = "create" +renderOpType OpIndex = "index" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/PendingTask.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/PendingTask.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/PendingTask.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.Common.Types.PendingTask + ( -- * Pending cluster task + PendingTask (..), + PendingTaskPriority (..), + + -- * Optics + pendingTaskInsertOrderLens, + pendingTaskPriorityLens, + pendingTaskSourceLens, + pendingTaskExecutingLens, + pendingTaskTimeInQueueMillisLens, + pendingTaskTimeInQueueLens, + pendingTaskOtherLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- | A single entry of the @tasks@ array returned by +-- @GET /_cluster/pending_tasks@ — the cluster-level changes not yet +-- executed by the master (e.g. index creation, mapping updates, shard +-- starts, reroutes). The typed fields mirror the universally-present +-- keys of the ES response; anything else the server reports is kept +-- verbatim in 'pendingTaskOther' so future ES additions decode cleanly. +-- +-- () +data PendingTask = PendingTask + { pendingTaskInsertOrder :: Int, + pendingTaskPriority :: PendingTaskPriority, + pendingTaskSource :: Text, + pendingTaskExecuting :: Bool, + pendingTaskTimeInQueueMillis :: Int, + pendingTaskTimeInQueue :: Text, + pendingTaskOther :: Value + } + deriving stock (Eq, Show) + +-- | The @priority@ ES assigns to a queued cluster task. These are the +-- fixed values of Elasticsearch's @org.elasticsearch.cluster.Priority@ +-- enum, rendered as upper-case strings on the wire. +data PendingTaskPriority + = PendingTaskImmediate + | PendingTaskUrgent + | PendingTaskHigh + | PendingTaskNormal + | PendingTaskLow + deriving stock (Eq, Show) + +instance FromJSON PendingTaskPriority where + parseJSON = withText "PendingTaskPriority" $ \case + "IMMEDIATE" -> pure PendingTaskImmediate + "URGENT" -> pure PendingTaskUrgent + "HIGH" -> pure PendingTaskHigh + "NORMAL" -> pure PendingTaskNormal + "LOW" -> pure PendingTaskLow + other -> fail ("Invalid pending task priority: " <> T.unpack other) + +instance ToJSON PendingTaskPriority where + toJSON PendingTaskImmediate = String "IMMEDIATE" + toJSON PendingTaskUrgent = String "URGENT" + toJSON PendingTaskHigh = String "HIGH" + toJSON PendingTaskNormal = String "NORMAL" + toJSON PendingTaskLow = String "LOW" + +pendingTaskInsertOrderLens :: Lens' PendingTask Int +pendingTaskInsertOrderLens = lens pendingTaskInsertOrder (\x y -> x {pendingTaskInsertOrder = y}) + +pendingTaskPriorityLens :: Lens' PendingTask PendingTaskPriority +pendingTaskPriorityLens = lens pendingTaskPriority (\x y -> x {pendingTaskPriority = y}) + +pendingTaskSourceLens :: Lens' PendingTask Text +pendingTaskSourceLens = lens pendingTaskSource (\x y -> x {pendingTaskSource = y}) + +pendingTaskExecutingLens :: Lens' PendingTask Bool +pendingTaskExecutingLens = lens pendingTaskExecuting (\x y -> x {pendingTaskExecuting = y}) + +pendingTaskTimeInQueueMillisLens :: Lens' PendingTask Int +pendingTaskTimeInQueueMillisLens = lens pendingTaskTimeInQueueMillis (\x y -> x {pendingTaskTimeInQueueMillis = y}) + +pendingTaskTimeInQueueLens :: Lens' PendingTask Text +pendingTaskTimeInQueueLens = lens pendingTaskTimeInQueue (\x y -> x {pendingTaskTimeInQueue = y}) + +pendingTaskOtherLens :: Lens' PendingTask Value +pendingTaskOtherLens = lens pendingTaskOther (\x y -> x {pendingTaskOther = y}) + +instance FromJSON PendingTask where + parseJSON = withObject "PendingTask" $ \o -> + PendingTask + <$> o .:? "insert_order" .!= 0 + <*> o .:? "priority" .!= PendingTaskNormal + <*> o .:? "source" .!= "" + <*> o .:? "executing" .!= False + <*> o .:? "time_in_queue_millis" .!= 0 + <*> o .:? "time_in_queue" .!= "" + <*> pure (Object o) + +instance ToJSON PendingTask where + toJSON pt = + case pendingTaskOther pt of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "insert_order" .= pendingTaskInsertOrder pt, + "priority" .= pendingTaskPriority pt, + "source" .= pendingTaskSource pt, + "executing" .= pendingTaskExecuting pt, + "time_in_queue_millis" .= pendingTaskTimeInQueueMillis pt, + "time_in_queue" .= pendingTaskTimeInQueue pt + ] + +mergeIgnoringNulls :: [(Key, Value)] -> KM.KeyMap Value -> KM.KeyMap Value +mergeIgnoringNulls kvs o = KM.union (KM.fromList (filter notNull kvs)) o + where + notNull (_, Null) = False + notNull _ = True diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/PointInTime.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/PointInTime.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/PointInTime.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/PointInTime.hs @@ -1,29 +1,312 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} -module Database.Bloodhound.Internal.Versions.Common.Types.PointInTime where +module Database.Bloodhound.Internal.Versions.Common.Types.PointInTime + ( PointInTime (..), + pointInTimeIdLens, + pointInTimeKeepAliveLens, + -- * Summaries + PITSummary (..), + pitSummaryIdLens, + pitSummaryKeepAliveLens, + + -- * URI parameters + PITOptions (..), + defaultPITOptions, + pitOptionsParams, + osPITOptionsParams, + + -- * Request body + OpenPointInTimeBody (..), + defaultOpenPointInTimeBody, + + -- * Optics + pitoRoutingLens, + pitoPreferenceLens, + pitoExpandWildcardsLens, + pitoAllowPartialPITCreationLens, + pitoIgnoreUnavailableLens, + pitoAllowPartialSearchResultsLens, + pitoMaxConcurrentShardRequestsLens, + pitBodyIndexFilterLens, + ) +where + +import Data.Text qualified as T import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.KeepAlive (KeepAlive) +import Database.Bloodhound.Internal.Versions.Common.Types.Query (Query) data PointInTime = PointInTime { pointInTimeId :: Text, - pointInTimeKeepAlive :: Text + pointInTimeKeepAlive :: Maybe KeepAlive } deriving stock (Eq, Show) instance ToJSON PointInTime where toJSON PointInTime {..} = - object - [ "id" .= pointInTimeId, - "keep_alive" .= pointInTimeKeepAlive - ] + object $ + ("id" .= pointInTimeId) + : catMaybes + [ ("keep_alive" .=) <$> pointInTimeKeepAlive + ] instance FromJSON PointInTime where - parseJSON (Object o) = PointInTime <$> o .: "id" <*> o .: "keep_alive" + parseJSON (Object o) = PointInTime <$> o .: "id" <*> o .:? "keep_alive" parseJSON x = typeMismatch "PointInTime" x pointInTimeIdLens :: Lens' PointInTime Text pointInTimeIdLens = lens pointInTimeId (\x y -> x {pointInTimeId = y}) -pointInTimeKeepAliveLens :: Lens' PointInTime Text +pointInTimeKeepAliveLens :: Lens' PointInTime (Maybe KeepAlive) pointInTimeKeepAliveLens = lens pointInTimeKeepAlive (\x y -> x {pointInTimeKeepAlive = y}) + +-- | /Point-in-time summary/ returned by the dynamic 'listAllPITs' +-- dispatcher. Elasticsearch 7\/8 (@GET /_pit@, rendering @keep_alive@ as +-- a @@ string) and OpenSearch 2\/3 +-- (@GET /_search/point_in_time/_all@, reporting @keep_alive@ as a +-- millisecond count) surface the id and, when the server emits it, the +-- remaining @keep_alive@; the latter is parsed into a 'KeepAlive', so +-- the keep-alive field is 'Maybe' (the spec only requires @id@ on a +-- 'PointInTimeReference'; @keep_alive@ is optional and may be absent). +-- +-- Per-backend guarantees: +-- +-- * For the ElasticSearch backends that expose a list operation +-- (7.16+, 8.x) 'pitSummaryKeepAlive' is 'Just' when the server +-- reports the remaining keep-alive and 'Nothing' when it omits the +-- field — callers must defend against 'Nothing'. Elasticsearch 9 +-- removed @GET /_pit@ (the server returns @405@ with +-- @Allow: POST,DELETE@), so the dynamic dispatcher throws for ES9 +-- rather than returning a 'PITSummary'. +-- * For OpenSearch 2 and 3 it is always 'Just' (the list-all-PITs +-- response reports @keep_alive@ as a millisecond count). +data PITSummary = PITSummary + { pitSummaryId :: Text, + pitSummaryKeepAlive :: Maybe KeepAlive + } + deriving stock (Eq, Show) + +pitSummaryIdLens :: Lens' PITSummary Text +pitSummaryIdLens = lens pitSummaryId (\x y -> x {pitSummaryId = y}) + +pitSummaryKeepAliveLens :: Lens' PITSummary (Maybe KeepAlive) +pitSummaryKeepAliveLens = lens pitSummaryKeepAlive (\x y -> x {pitSummaryKeepAlive = y}) + +-- | URI parameters accepted by the open-point-in-time endpoints. +-- +-- Each field maps 1:1 to a query-string parameter of +-- @POST //_pit@ (Elasticsearch 7.10+, see +-- ) +-- and\/or +-- @POST //_search/point_in_time@ (OpenSearch 2+, see +-- ). +-- +-- The fields fall into three tiers, so each backend only emits the +-- parameters it documents (see 'pitOptionsParams' for Elasticsearch +-- and 'osPITOptionsParams' for OpenSearch): +-- +-- * 'pitoRouting', 'pitoPreference', 'pitoExpandWildcards' — accepted +-- by both Elasticsearch and OpenSearch. +-- * 'pitoIgnoreUnavailable', 'pitoAllowPartialSearchResults', +-- 'pitoMaxConcurrentShardRequests' — /Elasticsearch only/. Dropped +-- by the OpenSearch request builders. Note that +-- 'pitoAllowPartialSearchResults' (ES @allow_partial_search_results@) +-- is distinct from the OpenSearch-only +-- 'pitoAllowPartialPITCreation' (@allow_partial_pit_creation@). +-- * 'pitoAllowPartialPITCreation' — /OpenSearch only/. +-- Dropped by the Elasticsearch request builders. +-- +-- Field shapes mirror +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Count.CountOptions' +-- where the parameter exists on both endpoints, so callers can reuse +-- the same values across count and PIT. +data PITOptions = PITOptions + { -- | Custom routing value(s). For multi-route queries pass a + -- comma-separated string, e.g. @"route1,route2"@, mirroring + -- 'Database.Bloodhound.Internal.Versions.Common.Types.Count.coRouting'. + pitoRouting :: Maybe Text, + -- | Shard routing hint, e.g. @_local@ or @_only_local@. Also + -- accepts an arbitrary string for custom allocation, mirroring + -- 'Database.Bloodhound.Internal.Versions.Common.Types.Count.coPreference'. + pitoPreference :: Maybe Text, + -- | Which wildcard patterns to expand. The server accepts a + -- comma-separated list; we model it as a 'NonEmpty' to encode "at + -- least one", reusing the 'ExpandWildcards' sum type shared with + -- the search and count endpoints. + pitoExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + -- | @allow_partial_pit_creation@ — /OpenSearch only/. When set to + -- @'Just' 'True'@, allows the PIT to be created even if some + -- shards are unavailable. Silently dropped by the Elasticsearch + -- request builders. + pitoAllowPartialPITCreation :: Maybe Bool, + -- | @ignore_unavailable@ — /Elasticsearch only/. When set to + -- @'Just' 'True'@, missing or closed indices are ignored instead + -- of failing the request. Silently dropped by the OpenSearch + -- request builders. Mirrors + -- 'Database.Bloodhound.Internal.Versions.Common.Types.Count.coIgnoreUnavailable'. + pitoIgnoreUnavailable :: Maybe Bool, + -- | @allow_partial_search_results@ — /Elasticsearch only/. When + -- set to @'Just' 'False'@, the request fails if partial results + -- are returned (e.g. because a shard is unavailable); the server + -- default is @true@. Silently dropped by the OpenSearch request + -- builders. This is the ES PIT parameter, distinct from the + -- OpenSearch-only 'pitoAllowPartialPITCreation'. + pitoAllowPartialSearchResults :: Maybe Bool, + -- | @max_concurrent_shard_requests@ — /Elasticsearch only/. Bounds + -- the number of concurrent shard requests the search part of the + -- PIT open may trigger. Typed as 'Int' to match + -- 'Database.Bloodhound.Internal.Versions.Common.Types.Search.soMaxConcurrentShardRequests'. + -- Silently dropped by the OpenSearch request builders. + pitoMaxConcurrentShardRequests :: Maybe Int + } + deriving stock (Eq, Show) + +-- | 'PITOptions' with every parameter set to 'Nothing'. Produces no +-- query string, so a call made with this value is byte-identical to a +-- parameterless call (and to the legacy 'openPointInTime' wire shape). +defaultPITOptions :: PITOptions +defaultPITOptions = + PITOptions + { pitoRouting = Nothing, + pitoPreference = Nothing, + pitoExpandWildcards = Nothing, + pitoAllowPartialPITCreation = Nothing, + pitoIgnoreUnavailable = Nothing, + pitoAllowPartialSearchResults = Nothing, + pitoMaxConcurrentShardRequests = Nothing + } + +pitoRoutingLens :: Lens' PITOptions (Maybe Text) +pitoRoutingLens = lens pitoRouting (\x y -> x {pitoRouting = y}) + +pitoPreferenceLens :: Lens' PITOptions (Maybe Text) +pitoPreferenceLens = lens pitoPreference (\x y -> x {pitoPreference = y}) + +pitoExpandWildcardsLens :: Lens' PITOptions (Maybe (NonEmpty ExpandWildcards)) +pitoExpandWildcardsLens = lens pitoExpandWildcards (\x y -> x {pitoExpandWildcards = y}) + +pitoAllowPartialPITCreationLens :: Lens' PITOptions (Maybe Bool) +pitoAllowPartialPITCreationLens = + lens pitoAllowPartialPITCreation (\x y -> x {pitoAllowPartialPITCreation = y}) + +pitoIgnoreUnavailableLens :: Lens' PITOptions (Maybe Bool) +pitoIgnoreUnavailableLens = + lens pitoIgnoreUnavailable (\x y -> x {pitoIgnoreUnavailable = y}) + +pitoAllowPartialSearchResultsLens :: Lens' PITOptions (Maybe Bool) +pitoAllowPartialSearchResultsLens = + lens pitoAllowPartialSearchResults (\x y -> x {pitoAllowPartialSearchResults = y}) + +pitoMaxConcurrentShardRequestsLens :: Lens' PITOptions (Maybe Int) +pitoMaxConcurrentShardRequestsLens = + lens pitoMaxConcurrentShardRequests (\x y -> x {pitoMaxConcurrentShardRequests = y}) + +-- | Parameters accepted by /both/ Elasticsearch and OpenSearch +-- (@routing@, @preference@, @expand_wildcards@). This is the common +-- tier shared by 'pitOptionsParams' and 'osPITOptionsParams'; it is +-- not exported because callers should use the backend-specific +-- renderers. 'Nothing' fields are omitted, so 'defaultPITOptions' +-- produces an empty list here. The order of the returned list is +-- stable but /unspecified/ — callers (including tests) should treat it +-- as a set and not pattern-match on the head. The underlying +-- 'withQueries' is order-insensitive. +pitCommonParams :: PITOptions -> [(Text, Maybe Text)] +pitCommonParams opts = + catMaybes + [ ("routing",) . Just <$> pitoRouting opts, + ("preference",) . Just <$> pitoPreference opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> pitoExpandWildcards opts + ] + where + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + +-- | Render the parameters accepted by the Elasticsearch PIT endpoint: +-- the common tier (@routing@, @preference@, @expand_wildcards@) plus +-- the ES-only @ignore_unavailable@, @allow_partial_search_results@ and +-- @max_concurrent_shard_requests@. The OpenSearch-only +-- 'pitoAllowPartialPITCreation' is /deliberately omitted/ so that +-- the Elasticsearch request builders never emit undocumented +-- parameters. 'Nothing' fields are omitted, so 'defaultPITOptions' +-- produces an empty list. The order of the returned list is stable but +-- /unspecified/ — callers (including tests) should treat it as a set +-- and not pattern-match on the head. The underlying 'withQueries' is +-- order-insensitive. +pitOptionsParams :: PITOptions -> [(Text, Maybe Text)] +pitOptionsParams opts = + pitCommonParams opts + <> catMaybes + [ boolParam "ignore_unavailable" <$> pitoIgnoreUnavailable opts, + boolParam "allow_partial_search_results" <$> pitoAllowPartialSearchResults opts, + intParam "max_concurrent_shard_requests" <$> pitoMaxConcurrentShardRequests opts + ] + where + boolParam k b = (k, Just (boolQP b)) + boolQP True = "true" + boolQP False = "false" + intParam k n = (k, Just (showText n)) + +-- | Render the parameters accepted by the OpenSearch PIT endpoint: the +-- common tier plus the OpenSearch-only +-- @allow_partial_pit_creation@. The Elasticsearch-only fields are +-- /deliberately omitted/ so that the OpenSearch request builders never +-- emit undocumented parameters. 'Nothing' fields are omitted, so +-- 'defaultPITOptions' produces an empty list. The order of the +-- returned list is stable but /unspecified/ — callers (including +-- tests) should treat it as a set and not pattern-match on the head. +-- The underlying 'withQueries' is order-insensitive. +osPITOptionsParams :: PITOptions -> [(Text, Maybe Text)] +osPITOptionsParams opts = + pitCommonParams opts + <> catMaybes + [ ("allow_partial_pit_creation",) . Just . boolQP <$> pitoAllowPartialPITCreation opts + ] + where + boolQP True = "true" + boolQP False = "false" + +-- | Request body of the Elasticsearch @POST //_pit@ endpoint. +-- +-- The body is optional: the only documented body parameter is +-- @index_filter@, a 'Query' used to filter indices out of the PIT when +-- it rewrites to @match_none@ on every shard (see +-- ). +-- 'defaultOpenPointInTimeBody' encodes to the empty object @{}@, which +-- Elasticsearch treats the same as the bodyless 'openPointInTime' call. +-- +-- OpenSearch's PIT-create endpoint does not document @index_filter@, +-- so this type is only consumed by the Elasticsearch request builders +-- (see +-- 'Database.Bloodhound.ElasticSearch7.Requests.openPointInTimeWithBody'). +data OpenPointInTimeBody = OpenPointInTimeBody + { -- | @index_filter@ — a 'Query' that filters which indices the PIT + -- covers. @'Just' q@ is rendered as @{"index_filter":q}@; + -- 'Nothing' is omitted. + pitBodyIndexFilter :: Maybe Query + } + deriving stock (Eq, Show) + +instance ToJSON OpenPointInTimeBody where + toJSON body = + object $ + catMaybes + [ ("index_filter" .=) <$> pitBodyIndexFilter body + ] + +-- | 'OpenPointInTimeBody' with every field set to 'Nothing'. Encodes +-- to the empty object @{}@. +defaultOpenPointInTimeBody :: OpenPointInTimeBody +defaultOpenPointInTimeBody = + OpenPointInTimeBody + { pitBodyIndexFilter = Nothing + } + +pitBodyIndexFilterLens :: Lens' OpenPointInTimeBody (Maybe Query) +pitBodyIndexFilterLens = + lens pitBodyIndexFilter (\x y -> x {pitBodyIndexFilter = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query.hs @@ -21,6 +21,7 @@ GeoPoint (..), HasChildQuery (..), HasParentQuery (..), + HybridQuery (..), IndicesQuery (..), InnerHits (..), LatLon (..), @@ -35,6 +36,7 @@ defaultCache, functionScoreFunctionsPair, mkBoolQuery, + mkHybridQuery, showDistanceUnit, -- * Optics @@ -68,6 +70,8 @@ boostingQueryPositiveQueryLens, boostingQueryNegativeQueryLens, boostingQueryNegativeBoostLens, + hybridQueriesLens, + hybridFilterLens, termFieldLens, termValueLens, boolMatchMustMatchPrism, @@ -102,9 +106,9 @@ ) where -import qualified Data.Aeson.KeyMap as X -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T +import Data.Aeson.KeyMap qualified as X +import Data.HashMap.Strict qualified as HM +import Data.Text qualified as T import Database.Bloodhound.Internal.Utils.Imports import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes import Database.Bloodhound.Internal.Versions.Common.Types.Query.CommonTerms as X @@ -112,7 +116,8 @@ import Database.Bloodhound.Internal.Versions.Common.Types.Query.Fuzzy as X import Database.Bloodhound.Internal.Versions.Common.Types.Query.Match as X import Database.Bloodhound.Internal.Versions.Common.Types.Query.MoreLikeThis as X -import Database.Bloodhound.Internal.Versions.Common.Types.Query.MoreLikeThisField as X +import Database.Bloodhound.Internal.Versions.Common.Types.Query.Neural as X +import Database.Bloodhound.Internal.Versions.Common.Types.Query.NeuralSparse as X import Database.Bloodhound.Internal.Versions.Common.Types.Query.Prefix as X import Database.Bloodhound.Internal.Versions.Common.Types.Query.QueryString as X import Database.Bloodhound.Internal.Versions.Common.Types.Query.Range as X @@ -126,15 +131,18 @@ = TermQuery Term (Maybe Boost) | TermsQuery Key (NonEmpty Text) | QueryMatchQuery MatchQuery + | QueryMatchPhraseQuery MatchPhraseQuery + | QueryMatchPhrasePrefixQuery MatchPhrasePrefixQuery | QueryMultiMatchQuery MultiMatchQuery + | QueryNeuralQuery NeuralQuery + | QueryNeuralSparseQuery NeuralSparseQuery + | QueryHybridQuery HybridQuery | QueryBoolQuery BoolQuery | QueryBoostingQuery BoostingQuery | QueryCommonTermsQuery CommonTermsQuery | ConstantScoreQuery Query Boost | QueryFunctionScoreQuery FunctionScoreQuery | QueryDisMaxQuery DisMaxQuery - | QueryFuzzyLikeThisQuery FuzzyLikeThisQuery - | QueryFuzzyLikeFieldQuery FuzzyLikeFieldQuery | QueryFuzzyQuery FuzzyQuery | QueryHasChildQuery HasChildQuery | QueryHasParentQuery HasParentQuery @@ -142,7 +150,6 @@ | QueryIndicesQuery IndicesQuery | MatchAllQuery (Maybe Boost) | QueryMoreLikeThisQuery MoreLikeThisQuery - | QueryMoreLikeThisFieldQuery MoreLikeThisFieldQuery | QueryNestedQuery NestedQuery | QueryPrefixQuery PrefixQuery | QueryQueryStringQuery QueryStringQuery @@ -176,8 +183,23 @@ object ["query_string" .= qQueryStringQuery] toJSON (QueryMatchQuery matchQuery) = object ["match" .= matchQuery] + toJSON (QueryMatchPhraseQuery matchPhraseQuery) = + object ["match_phrase" .= matchPhraseQuery] + toJSON (QueryMatchPhrasePrefixQuery matchPhrasePrefixQuery) = + object ["match_phrase_prefix" .= matchPhrasePrefixQuery] toJSON (QueryMultiMatchQuery multiMatchQuery) = toJSON multiMatchQuery + -- The neural / neural_sparse leaf types already emit their outer clause + -- key (@neural@ \/ @neural_sparse@) in their own ToJSON; delegating here + -- avoids a double-wrap that would produce wire JSON like + -- @{"neural": {"neural": {...}}}@ which OpenSearch rejects. Same pattern + -- as 'QueryMultiMatchQuery' above. + toJSON (QueryNeuralQuery neuralQuery) = + toJSON neuralQuery + toJSON (QueryNeuralSparseQuery neuralSparseQuery) = + toJSON neuralSparseQuery + toJSON (QueryHybridQuery hybridQuery) = + object ["hybrid" .= hybridQuery] toJSON (QueryBoolQuery boolQuery) = object ["bool" .= boolQuery] toJSON (QueryBoostingQuery boostingQuery) = @@ -196,10 +218,6 @@ object ["function_score" .= functionScoreQuery'] toJSON (QueryDisMaxQuery disMaxQuery) = object ["dis_max" .= disMaxQuery] - toJSON (QueryFuzzyLikeThisQuery fuzzyQuery) = - object ["fuzzy_like_this" .= fuzzyQuery] - toJSON (QueryFuzzyLikeFieldQuery fuzzyFieldQuery) = - object ["fuzzy_like_this_field" .= fuzzyFieldQuery] toJSON (QueryFuzzyQuery fuzzyQuery) = object ["fuzzy" .= fuzzyQuery] toJSON (QueryHasChildQuery childQuery) = @@ -212,8 +230,6 @@ object ["match_all" .= omitNulls ["boost" .= boost]] toJSON (QueryMoreLikeThisQuery query) = object ["more_like_this" .= query] - toJSON (QueryMoreLikeThisFieldQuery query) = - object ["more_like_this_field" .= query] toJSON (QueryNestedQuery query) = object ["nested" .= query] toJSON (QueryPrefixQuery query) = @@ -249,7 +265,15 @@ `taggedWith` "query_string" <|> queryMatchQuery `taggedWith` "match" + <|> queryMatchPhraseQuery + `taggedWith` "match_phrase" + <|> queryMatchPhrasePrefixQuery + `taggedWith` "match_phrase_prefix" <|> queryMultiMatchQuery + <|> queryNeuralQuery + <|> queryNeuralSparseQuery + <|> queryHybridQuery + `taggedWith` "hybrid" <|> queryBoolQuery `taggedWith` "bool" <|> queryBoostingQuery @@ -262,10 +286,6 @@ `taggedWith` "function_score" <|> queryDisMaxQuery `taggedWith` "dis_max" - <|> queryFuzzyLikeThisQuery - `taggedWith` "fuzzy_like_this" - <|> queryFuzzyLikeFieldQuery - `taggedWith` "fuzzy_like_this_field" <|> queryFuzzyQuery `taggedWith` "fuzzy" <|> queryHasChildQuery @@ -278,8 +298,6 @@ `taggedWith` "match_all" <|> queryMoreLikeThisQuery `taggedWith` "more_like_this" - <|> queryMoreLikeThisFieldQuery - `taggedWith` "more_like_this_field" <|> queryNestedQuery `taggedWith` "nested" <|> queryPrefixQuery @@ -306,7 +324,12 @@ idsQuery o = IdsQuery <$> o .: "values" queryQueryStringQuery = pure . QueryQueryStringQuery queryMatchQuery = pure . QueryMatchQuery + queryMatchPhraseQuery = pure . QueryMatchPhraseQuery + queryMatchPhrasePrefixQuery = pure . QueryMatchPhrasePrefixQuery queryMultiMatchQuery = QueryMultiMatchQuery <$> parseJSON v + queryNeuralQuery = QueryNeuralQuery <$> parseJSON v + queryNeuralSparseQuery = QueryNeuralSparseQuery <$> parseJSON v + queryHybridQuery = pure . QueryHybridQuery queryBoolQuery = pure . QueryBoolQuery queryBoostingQuery = pure . QueryBoostingQuery queryCommonTermsQuery = pure . QueryCommonTermsQuery @@ -318,15 +341,12 @@ _ -> fail "Does not appear to be a ConstantScoreQuery" queryFunctionScoreQuery = pure . QueryFunctionScoreQuery queryDisMaxQuery = pure . QueryDisMaxQuery - queryFuzzyLikeThisQuery = pure . QueryFuzzyLikeThisQuery - queryFuzzyLikeFieldQuery = pure . QueryFuzzyLikeFieldQuery queryFuzzyQuery = pure . QueryFuzzyQuery queryHasChildQuery = pure . QueryHasChildQuery queryHasParentQuery = pure . QueryHasParentQuery queryIndicesQuery = pure . QueryIndicesQuery matchAllQuery o = MatchAllQuery <$> o .:? "boost" queryMoreLikeThisQuery = pure . QueryMoreLikeThisQuery - queryMoreLikeThisFieldQuery = pure . QueryMoreLikeThisFieldQuery queryNestedQuery = pure . QueryNestedQuery queryPrefixQuery = pure . QueryPrefixQuery queryRangeQuery = pure . QueryRangeQuery @@ -662,6 +682,84 @@ <$> o .: "positive" <*> o .: "negative" <*> o .: "negative_boost" + +-- | OpenSearch @hybrid@ query clause, used inside the @\"query\"@ body of a +-- @POST \/{index}\/_search@ request as the compound query for hybrid +-- (lexical + neural) search. +-- +-- +-- +-- Serialized as: +-- +-- @ +-- { "hybrid": { "queries": [ \, ... ], "filter": \ } } +-- @ +-- +-- Per the upstream documentation: +-- +-- * @queries@ is required and takes a non-empty array of 1 to 5 sub-query +-- clauses. The 'NonEmpty' list makes the lower bound unrepresentable by +-- construction; the upper bound of 5 is not enforced at the type level +-- and is the caller's responsibility. +-- * @filter@ is optional and is applied to every sub-query. Omitted from +-- the JSON when 'Nothing'. +-- * OpenSearch rejects @hybrid@ at query time when nested inside +-- @function_score@, @constant_score@, @script_score@, or @boosting@. +-- This is not enforced at the type level; see +-- . +-- +-- Score normalization and combination are not configured inline on the +-- @hybrid@ clause; OpenSearch routes them through an external search +-- pipeline attached via the @?search_pipeline=\@ query string. See +-- the normalization-processor reference +-- +-- for @normalization.technique@ (@min_max@, @l2@, @zscore@) and +-- @combination.technique@ (@arithmetic_mean@, @geometric_mean@, +-- @harmonic_mean@). +-- +-- This type is co-located in "Database.Bloodhound.Internal.Versions.Common.Types.Query" +-- rather than split into a @Query.Hybrid@ child module because its +-- @queries@ \/ @filter@ fields reference the enclosing 'Query' sum type, +-- which would create an import cycle. This matches the existing +-- arrangement of 'BoolQuery', 'BoostingQuery', 'NestedQuery', +-- 'HasChildQuery', 'HasParentQuery', 'IndicesQuery', 'DisMaxQuery', and +-- 'FunctionScoreQuery'. +data HybridQuery = HybridQuery + { hybridQueries :: NonEmpty Query, + hybridFilter :: Maybe Query + } + deriving stock (Eq, Show, Generic) + +hybridQueriesLens :: Lens' HybridQuery (NonEmpty Query) +hybridQueriesLens = lens hybridQueries (\x y -> x {hybridQueries = y}) + +hybridFilterLens :: Lens' HybridQuery (Maybe Query) +hybridFilterLens = lens hybridFilter (\x y -> x {hybridFilter = y}) + +instance ToJSON HybridQuery where + toJSON (HybridQuery queries hybridFilt) = + omitNulls + [ "queries" .= toList queries, + "filter" .= hybridFilt + ] + +instance FromJSON HybridQuery where + parseJSON = withObject "HybridQuery" parse + where + parse o = do + queriesList <- o .: "queries" + case queriesList of + [] -> fail "HybridQuery: queries must be a non-empty array" + (q : qs) -> do + hybridFilt <- o .:? "filter" + pure $ HybridQuery (q :| qs) hybridFilt + +-- | Smart constructor for a 'HybridQuery' with no filter. Takes a +-- 'NonEmpty' list of sub-query clauses (the OpenSearch API enforces a +-- maximum of 5 clauses at query time; that bound is the caller's +-- responsibility). +mkHybridQuery :: NonEmpty Query -> HybridQuery +mkHybridQuery queries = HybridQuery queries Nothing data RangeExecution = RangeExecutionIndex diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/CommonTerms.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/CommonTerms.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/CommonTerms.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/CommonTerms.hs @@ -30,9 +30,9 @@ data CommonTermsQuery = CommonTermsQuery { commonField :: FieldName, commonQuery :: QueryString, - commonCutoffFrequency :: CutoffFrequency, - commonLowFreqOperator :: BooleanOperator, - commonHighFreqOperator :: BooleanOperator, + commonCutoffFrequency :: Maybe CutoffFrequency, + commonLowFreqOperator :: Maybe BooleanOperator, + commonHighFreqOperator :: Maybe BooleanOperator, commonMinimumShouldMatch :: Maybe CommonMinimumMatch, commonBoost :: Maybe Boost, commonAnalyzer :: Maybe Analyzer, @@ -46,13 +46,13 @@ commonTermsQueryQueryLens :: Lens' CommonTermsQuery QueryString commonTermsQueryQueryLens = lens commonQuery (\x y -> x {commonQuery = y}) -commonTermsQueryCutoffFrequencyLens :: Lens' CommonTermsQuery CutoffFrequency +commonTermsQueryCutoffFrequencyLens :: Lens' CommonTermsQuery (Maybe CutoffFrequency) commonTermsQueryCutoffFrequencyLens = lens commonCutoffFrequency (\x y -> x {commonCutoffFrequency = y}) -commonTermsQueryLowFreqOperatorLens :: Lens' CommonTermsQuery BooleanOperator +commonTermsQueryLowFreqOperatorLens :: Lens' CommonTermsQuery (Maybe BooleanOperator) commonTermsQueryLowFreqOperatorLens = lens commonLowFreqOperator (\x y -> x {commonLowFreqOperator = y}) -commonTermsQueryHighFreqOperatorLens :: Lens' CommonTermsQuery BooleanOperator +commonTermsQueryHighFreqOperatorLens :: Lens' CommonTermsQuery (Maybe BooleanOperator) commonTermsQueryHighFreqOperatorLens = lens commonHighFreqOperator (\x y -> x {commonHighFreqOperator = y}) commonTermsQueryMinimumShouldMatchLens :: Lens' CommonTermsQuery (Maybe CommonMinimumMatch) @@ -99,9 +99,9 @@ parse = fieldTagged $ \fn o -> CommonTermsQuery fn <$> o .: "query" - <*> o .: "cutoff_frequency" - <*> o .: "low_freq_operator" - <*> o .: "high_freq_operator" + <*> o .:? "cutoff_frequency" + <*> o .:? "low_freq_operator" + <*> o .:? "high_freq_operator" <*> o .:? "minimum_should_match" <*> o .:? "boost" <*> o .:? "analyzer" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Commons.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Commons.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Commons.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Commons.hs @@ -8,7 +8,7 @@ ) where -import qualified Data.Aeson.KeyMap as X +import Data.Aeson.KeyMap qualified as X import Database.Bloodhound.Internal.Utils.Imports import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes import GHC.Generics @@ -41,12 +41,14 @@ parseJSON = withText "BooleanOperator" parse where parse "and" = pure And + parse "AND" = pure And parse "or" = pure Or + parse "OR" = pure Or parse o = fail ("Unexpected BooleanOperator: " <> show o) -- | Fuzziness value as a number or 'AUTO'. -- See: --- https://www.elastic.co/guide/en/elasticsearch/reference/current/common-options.html#fuzziness +-- https://www.elastic.co/guide/en/elasticsearch/reference/7.17/common-options.html#fuzziness data Fuzziness = Fuzziness Double | FuzzinessAuto deriving stock (Eq, Show, Generic) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Fuzzy.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Fuzzy.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Fuzzy.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Fuzzy.hs @@ -2,8 +2,6 @@ module Database.Bloodhound.Internal.Versions.Common.Types.Query.Fuzzy ( FuzzyQuery (..), - FuzzyLikeFieldQuery (..), - FuzzyLikeThisQuery (..), -- * Optics fuzzyQueryFieldLens, @@ -12,22 +10,9 @@ fuzzyQueryMaxExpansionsLens, fuzzyQueryFuzzinessLens, fuzzyQueryBoostLens, - fuzzyLikeFieldQueryFieldLens, - fuzzyLikeFieldQueryTextLens, - fuzzyLikeFieldQueryMaxQueryTermsLens, - fuzzyLikeFieldQueryIgnoreTermFrequencyLens, - fuzzyLikeFieldQueryFuzzinessLens, - fuzzyLikeFieldQueryPrefixLengthLens, - fuzzyLikeFieldQueryBoostLens, - fuzzyLikeFieldQueryAnalyzerLens, - fuzzyLikeThisQueryFieldsLens, - fuzzyLikeThisQueryTextLens, - fuzzyLikeThisQueryMaxQueryTermsLens, - fuzzyLikeThisQueryIgnoreTermFrequencyLens, - fuzzyLikeThisQueryFuzzinessLens, - fuzzyLikeThisQueryPrefixLengthLens, - fuzzyLikeThisQueryBoostLens, - fuzzyLikeThisQueryAnalyzerLens, + fuzzyQueryTranspositionsLens, + fuzzyQueryRewriteLens, + fuzzyQueryNameLens, ) where @@ -39,9 +24,12 @@ data FuzzyQuery = FuzzyQuery { fuzzyQueryField :: FieldName, fuzzyQueryValue :: Text, - fuzzyQueryPrefixLength :: PrefixLength, - fuzzyQueryMaxExpansions :: MaxExpansions, - fuzzyQueryFuzziness :: Fuzziness, + fuzzyQueryFuzziness :: Maybe Fuzziness, + fuzzyQueryPrefixLength :: Maybe PrefixLength, + fuzzyQueryMaxExpansions :: Maybe MaxExpansions, + fuzzyQueryTranspositions :: Maybe Transpositions, + fuzzyQueryRewrite :: Maybe Rewrite, + fuzzyQueryName :: Maybe QueryName, fuzzyQueryBoost :: Maybe Boost } deriving stock (Eq, Show, Generic) @@ -52,26 +40,38 @@ fuzzyQueryValueLens :: Lens' FuzzyQuery Text fuzzyQueryValueLens = lens fuzzyQueryValue (\x y -> x {fuzzyQueryValue = y}) -fuzzyQueryPrefixLengthLens :: Lens' FuzzyQuery PrefixLength +fuzzyQueryPrefixLengthLens :: Lens' FuzzyQuery (Maybe PrefixLength) fuzzyQueryPrefixLengthLens = lens fuzzyQueryPrefixLength (\x y -> x {fuzzyQueryPrefixLength = y}) -fuzzyQueryMaxExpansionsLens :: Lens' FuzzyQuery MaxExpansions +fuzzyQueryMaxExpansionsLens :: Lens' FuzzyQuery (Maybe MaxExpansions) fuzzyQueryMaxExpansionsLens = lens fuzzyQueryMaxExpansions (\x y -> x {fuzzyQueryMaxExpansions = y}) -fuzzyQueryFuzzinessLens :: Lens' FuzzyQuery Fuzziness +fuzzyQueryFuzzinessLens :: Lens' FuzzyQuery (Maybe Fuzziness) fuzzyQueryFuzzinessLens = lens fuzzyQueryFuzziness (\x y -> x {fuzzyQueryFuzziness = y}) fuzzyQueryBoostLens :: Lens' FuzzyQuery (Maybe Boost) fuzzyQueryBoostLens = lens fuzzyQueryBoost (\x y -> x {fuzzyQueryBoost = y}) +fuzzyQueryTranspositionsLens :: Lens' FuzzyQuery (Maybe Transpositions) +fuzzyQueryTranspositionsLens = lens fuzzyQueryTranspositions (\x y -> x {fuzzyQueryTranspositions = y}) + +fuzzyQueryRewriteLens :: Lens' FuzzyQuery (Maybe Rewrite) +fuzzyQueryRewriteLens = lens fuzzyQueryRewrite (\x y -> x {fuzzyQueryRewrite = y}) + +fuzzyQueryNameLens :: Lens' FuzzyQuery (Maybe QueryName) +fuzzyQueryNameLens = lens fuzzyQueryName (\x y -> x {fuzzyQueryName = y}) + instance ToJSON FuzzyQuery where toJSON ( FuzzyQuery (FieldName fieldName) queryText + fuzziness prefixLength maxEx - fuzziness + transpositions + rewrite + name boost ) = object [fromText fieldName .= omitNulls base] @@ -80,8 +80,11 @@ [ "value" .= queryText, "fuzziness" .= fuzziness, "prefix_length" .= prefixLength, - "boost" .= boost, - "max_expansions" .= maxEx + "max_expansions" .= maxEx, + "transpositions" .= transpositions, + "rewrite" .= rewrite, + "_name" .= name, + "boost" .= boost ] instance FromJSON FuzzyQuery where @@ -90,157 +93,10 @@ parse = fieldTagged $ \fn o -> FuzzyQuery fn <$> o .: "value" - <*> o .: "prefix_length" - <*> o .: "max_expansions" - <*> o .: "fuzziness" + <*> o .:? "fuzziness" + <*> o .:? "prefix_length" + <*> o .:? "max_expansions" + <*> o .:? "transpositions" + <*> o .:? "rewrite" + <*> o .:? "_name" <*> o .:? "boost" - -data FuzzyLikeFieldQuery = FuzzyLikeFieldQuery - { fuzzyLikeField :: FieldName, - -- anaphora is good for the soul. - fuzzyLikeFieldText :: Text, - fuzzyLikeFieldMaxQueryTerms :: MaxQueryTerms, - fuzzyLikeFieldIgnoreTermFrequency :: IgnoreTermFrequency, - fuzzyLikeFieldFuzziness :: Fuzziness, - fuzzyLikeFieldPrefixLength :: PrefixLength, - fuzzyLikeFieldBoost :: Boost, - fuzzyLikeFieldAnalyzer :: Maybe Analyzer - } - deriving stock (Eq, Show, Generic) - -fuzzyLikeFieldQueryFieldLens :: Lens' FuzzyLikeFieldQuery FieldName -fuzzyLikeFieldQueryFieldLens = lens fuzzyLikeField (\x y -> x {fuzzyLikeField = y}) - -fuzzyLikeFieldQueryTextLens :: Lens' FuzzyLikeFieldQuery Text -fuzzyLikeFieldQueryTextLens = lens fuzzyLikeFieldText (\x y -> x {fuzzyLikeFieldText = y}) - -fuzzyLikeFieldQueryMaxQueryTermsLens :: Lens' FuzzyLikeFieldQuery MaxQueryTerms -fuzzyLikeFieldQueryMaxQueryTermsLens = lens fuzzyLikeFieldMaxQueryTerms (\x y -> x {fuzzyLikeFieldMaxQueryTerms = y}) - -fuzzyLikeFieldQueryIgnoreTermFrequencyLens :: Lens' FuzzyLikeFieldQuery IgnoreTermFrequency -fuzzyLikeFieldQueryIgnoreTermFrequencyLens = lens fuzzyLikeFieldIgnoreTermFrequency (\x y -> x {fuzzyLikeFieldIgnoreTermFrequency = y}) - -fuzzyLikeFieldQueryFuzzinessLens :: Lens' FuzzyLikeFieldQuery Fuzziness -fuzzyLikeFieldQueryFuzzinessLens = lens fuzzyLikeFieldFuzziness (\x y -> x {fuzzyLikeFieldFuzziness = y}) - -fuzzyLikeFieldQueryPrefixLengthLens :: Lens' FuzzyLikeFieldQuery PrefixLength -fuzzyLikeFieldQueryPrefixLengthLens = lens fuzzyLikeFieldPrefixLength (\x y -> x {fuzzyLikeFieldPrefixLength = y}) - -fuzzyLikeFieldQueryBoostLens :: Lens' FuzzyLikeFieldQuery Boost -fuzzyLikeFieldQueryBoostLens = lens fuzzyLikeFieldBoost (\x y -> x {fuzzyLikeFieldBoost = y}) - -fuzzyLikeFieldQueryAnalyzerLens :: Lens' FuzzyLikeFieldQuery (Maybe Analyzer) -fuzzyLikeFieldQueryAnalyzerLens = lens fuzzyLikeFieldAnalyzer (\x y -> x {fuzzyLikeFieldAnalyzer = y}) - -instance ToJSON FuzzyLikeFieldQuery where - toJSON - ( FuzzyLikeFieldQuery - (FieldName fieldName) - fieldText - maxTerms - ignoreFreq - fuzziness - prefixLength - boost - analyzer - ) = - object - [ fromText fieldName - .= omitNulls - [ "like_text" .= fieldText, - "max_query_terms" .= maxTerms, - "ignore_tf" .= ignoreFreq, - "fuzziness" .= fuzziness, - "prefix_length" .= prefixLength, - "analyzer" .= analyzer, - "boost" .= boost - ] - ] - -instance FromJSON FuzzyLikeFieldQuery where - parseJSON = withObject "FuzzyLikeFieldQuery" parse - where - parse = fieldTagged $ \fn o -> - FuzzyLikeFieldQuery fn - <$> o .: "like_text" - <*> o .: "max_query_terms" - <*> o .: "ignore_tf" - <*> o .: "fuzziness" - <*> o .: "prefix_length" - <*> o .: "boost" - <*> o .:? "analyzer" - -data FuzzyLikeThisQuery = FuzzyLikeThisQuery - { fuzzyLikeFields :: [FieldName], - fuzzyLikeText :: Text, - fuzzyLikeMaxQueryTerms :: MaxQueryTerms, - fuzzyLikeIgnoreTermFrequency :: IgnoreTermFrequency, - fuzzyLikeFuzziness :: Fuzziness, - fuzzyLikePrefixLength :: PrefixLength, - fuzzyLikeBoost :: Boost, - fuzzyLikeAnalyzer :: Maybe Analyzer - } - deriving stock (Eq, Show, Generic) - -fuzzyLikeThisQueryFieldsLens :: Lens' FuzzyLikeThisQuery [FieldName] -fuzzyLikeThisQueryFieldsLens = lens fuzzyLikeFields (\x y -> x {fuzzyLikeFields = y}) - -fuzzyLikeThisQueryTextLens :: Lens' FuzzyLikeThisQuery Text -fuzzyLikeThisQueryTextLens = lens fuzzyLikeText (\x y -> x {fuzzyLikeText = y}) - -fuzzyLikeThisQueryMaxQueryTermsLens :: Lens' FuzzyLikeThisQuery MaxQueryTerms -fuzzyLikeThisQueryMaxQueryTermsLens = lens fuzzyLikeMaxQueryTerms (\x y -> x {fuzzyLikeMaxQueryTerms = y}) - -fuzzyLikeThisQueryIgnoreTermFrequencyLens :: Lens' FuzzyLikeThisQuery IgnoreTermFrequency -fuzzyLikeThisQueryIgnoreTermFrequencyLens = lens fuzzyLikeIgnoreTermFrequency (\x y -> x {fuzzyLikeIgnoreTermFrequency = y}) - -fuzzyLikeThisQueryFuzzinessLens :: Lens' FuzzyLikeThisQuery Fuzziness -fuzzyLikeThisQueryFuzzinessLens = lens fuzzyLikeFuzziness (\x y -> x {fuzzyLikeFuzziness = y}) - -fuzzyLikeThisQueryPrefixLengthLens :: Lens' FuzzyLikeThisQuery PrefixLength -fuzzyLikeThisQueryPrefixLengthLens = lens fuzzyLikePrefixLength (\x y -> x {fuzzyLikePrefixLength = y}) - -fuzzyLikeThisQueryBoostLens :: Lens' FuzzyLikeThisQuery Boost -fuzzyLikeThisQueryBoostLens = lens fuzzyLikeBoost (\x y -> x {fuzzyLikeBoost = y}) - -fuzzyLikeThisQueryAnalyzerLens :: Lens' FuzzyLikeThisQuery (Maybe Analyzer) -fuzzyLikeThisQueryAnalyzerLens = lens fuzzyLikeAnalyzer (\x y -> x {fuzzyLikeAnalyzer = y}) - -instance ToJSON FuzzyLikeThisQuery where - toJSON - ( FuzzyLikeThisQuery - fields - text - maxTerms - ignoreFreq - fuzziness - prefixLength - boost - analyzer - ) = - omitNulls base - where - base = - [ "fields" .= fields, - "like_text" .= text, - "max_query_terms" .= maxTerms, - "ignore_tf" .= ignoreFreq, - "fuzziness" .= fuzziness, - "prefix_length" .= prefixLength, - "analyzer" .= analyzer, - "boost" .= boost - ] - -instance FromJSON FuzzyLikeThisQuery where - parseJSON = withObject "FuzzyLikeThisQuery" parse - where - parse o = - FuzzyLikeThisQuery - <$> o .:? "fields" .!= [] - <*> o .: "like_text" - <*> o .: "max_query_terms" - <*> o .: "ignore_tf" - <*> o .: "fuzziness" - <*> o .: "prefix_length" - <*> o .: "boost" - <*> o .:? "analyzer" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Match.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Match.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Match.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Match.hs @@ -2,7 +2,8 @@ module Database.Bloodhound.Internal.Versions.Common.Types.Query.Match ( MatchQuery (..), - MatchQueryType (..), + MatchPhraseQuery (..), + MatchPhrasePrefixQuery (..), MultiMatchQuery (..), MultiMatchQueryType (..), mkMatchQuery, @@ -14,13 +15,25 @@ matchQueryOperatorLens, matchQueryZeroTermsLens, matchQueryCutoffFrequencyLens, - matchQueryMatchTypeLens, matchQueryAnalyzerLens, matchQueryMaxExpansionsLens, matchQueryLenientLens, matchQueryBoostLens, matchQueryMinimumShouldMatchLens, matchQueryFuzzinessLens, + matchPhraseQueryFieldLens, + matchPhraseQueryQueryStringLens, + matchPhraseQueryBoostLens, + matchPhraseQueryAnalyzerLens, + matchPhraseQuerySlopLens, + matchPhraseQueryZeroTermsLens, + matchPhrasePrefixQueryFieldLens, + matchPhrasePrefixQueryQueryStringLens, + matchPhrasePrefixQueryBoostLens, + matchPhrasePrefixQueryAnalyzerLens, + matchPhrasePrefixQuerySlopLens, + matchPhrasePrefixQueryMaxExpansionsLens, + matchPhrasePrefixQueryZeroTermsLens, multiMatchQueryFieldsLens, multiMatchQueryStringLens, multiMatchQueryOperatorLens, @@ -42,10 +55,9 @@ data MatchQuery = MatchQuery { matchQueryField :: FieldName, matchQueryQueryString :: QueryString, - matchQueryOperator :: BooleanOperator, - matchQueryZeroTerms :: ZeroTermsQuery, + matchQueryOperator :: Maybe BooleanOperator, + matchQueryZeroTerms :: Maybe ZeroTermsQuery, matchQueryCutoffFrequency :: Maybe CutoffFrequency, - matchQueryMatchType :: Maybe MatchQueryType, matchQueryAnalyzer :: Maybe Analyzer, matchQueryMaxExpansions :: Maybe MaxExpansions, matchQueryLenient :: Maybe Lenient, @@ -55,24 +67,23 @@ } deriving stock (Eq, Show, Generic) +{-# DEPRECATED matchQueryCutoffFrequency, matchQueryCutoffFrequencyLens "cutoff_frequency is marked deprecated:true in the ES/OpenSearch spec; avoid it in new queries." #-} + matchQueryFieldLens :: Lens' MatchQuery FieldName matchQueryFieldLens = lens matchQueryField (\x y -> x {matchQueryField = y}) matchQueryQueryStringLens :: Lens' MatchQuery QueryString matchQueryQueryStringLens = lens matchQueryQueryString (\x y -> x {matchQueryQueryString = y}) -matchQueryOperatorLens :: Lens' MatchQuery BooleanOperator +matchQueryOperatorLens :: Lens' MatchQuery (Maybe BooleanOperator) matchQueryOperatorLens = lens matchQueryOperator (\x y -> x {matchQueryOperator = y}) -matchQueryZeroTermsLens :: Lens' MatchQuery ZeroTermsQuery +matchQueryZeroTermsLens :: Lens' MatchQuery (Maybe ZeroTermsQuery) matchQueryZeroTermsLens = lens matchQueryZeroTerms (\x y -> x {matchQueryZeroTerms = y}) matchQueryCutoffFrequencyLens :: Lens' MatchQuery (Maybe CutoffFrequency) matchQueryCutoffFrequencyLens = lens matchQueryCutoffFrequency (\x y -> x {matchQueryCutoffFrequency = y}) -matchQueryMatchTypeLens :: Lens' MatchQuery (Maybe MatchQueryType) -matchQueryMatchTypeLens = lens matchQueryMatchType (\x y -> x {matchQueryMatchType = y}) - matchQueryAnalyzerLens :: Lens' MatchQuery (Maybe Analyzer) matchQueryAnalyzerLens = lens matchQueryAnalyzer (\x y -> x {matchQueryAnalyzer = y}) @@ -99,7 +110,6 @@ booleanOperator zeroTermsQuery cutoffFrequency - matchQueryType analyzer maxExpansions lenient @@ -114,7 +124,6 @@ "operator" .= booleanOperator, "zero_terms_query" .= zeroTermsQuery, "cutoff_frequency" .= cutoffFrequency, - "type" .= matchQueryType, "analyzer" .= analyzer, "max_expansions" .= maxExpansions, "lenient" .= lenient, @@ -129,10 +138,9 @@ parse = fieldTagged $ \fn o -> MatchQuery fn <$> o .: "query" - <*> o .: "operator" - <*> o .: "zero_terms_query" + <*> o .:? "operator" + <*> o .:? "zero_terms_query" <*> o .:? "cutoff_frequency" - <*> o .:? "type" <*> o .:? "analyzer" <*> o .:? "max_expansions" <*> o .:? "lenient" @@ -143,29 +151,142 @@ -- | 'mkMatchQuery' is a convenience function that defaults the less common parameters, -- enabling you to provide only the 'FieldName' and 'QueryString' to make a 'MatchQuery' mkMatchQuery :: FieldName -> QueryString -> MatchQuery -mkMatchQuery field query = MatchQuery field query Or ZeroTermsNone Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing +mkMatchQuery field query = MatchQuery field query Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing -data MatchQueryType - = MatchPhrase - | MatchPhrasePrefix +-- | A @match_phrase@ query. Distinct from 'MatchQuery' (which has no +-- @type@ field): the ES spec models @match_phrase@ as its own +-- container rather than a @match@ clause tagged with a type. +data MatchPhraseQuery = MatchPhraseQuery + { matchPhraseQueryField :: FieldName, + matchPhraseQueryQueryString :: QueryString, + matchPhraseQueryBoost :: Maybe Boost, + matchPhraseQueryAnalyzer :: Maybe Analyzer, + matchPhraseQuerySlop :: Maybe PhraseSlop, + matchPhraseQueryZeroTerms :: Maybe ZeroTermsQuery + } deriving stock (Eq, Show, Generic) -instance ToJSON MatchQueryType where - toJSON MatchPhrase = "phrase" - toJSON MatchPhrasePrefix = "phrase_prefix" +matchPhraseQueryFieldLens :: Lens' MatchPhraseQuery FieldName +matchPhraseQueryFieldLens = lens matchPhraseQueryField (\x y -> x {matchPhraseQueryField = y}) -instance FromJSON MatchQueryType where - parseJSON = withText "MatchQueryType" parse +matchPhraseQueryQueryStringLens :: Lens' MatchPhraseQuery QueryString +matchPhraseQueryQueryStringLens = lens matchPhraseQueryQueryString (\x y -> x {matchPhraseQueryQueryString = y}) + +matchPhraseQueryBoostLens :: Lens' MatchPhraseQuery (Maybe Boost) +matchPhraseQueryBoostLens = lens matchPhraseQueryBoost (\x y -> x {matchPhraseQueryBoost = y}) + +matchPhraseQueryAnalyzerLens :: Lens' MatchPhraseQuery (Maybe Analyzer) +matchPhraseQueryAnalyzerLens = lens matchPhraseQueryAnalyzer (\x y -> x {matchPhraseQueryAnalyzer = y}) + +matchPhraseQuerySlopLens :: Lens' MatchPhraseQuery (Maybe PhraseSlop) +matchPhraseQuerySlopLens = lens matchPhraseQuerySlop (\x y -> x {matchPhraseQuerySlop = y}) + +matchPhraseQueryZeroTermsLens :: Lens' MatchPhraseQuery (Maybe ZeroTermsQuery) +matchPhraseQueryZeroTermsLens = lens matchPhraseQueryZeroTerms (\x y -> x {matchPhraseQueryZeroTerms = y}) + +instance ToJSON MatchPhraseQuery where + toJSON + ( MatchPhraseQuery + (FieldName fieldName) + (QueryString query) + boost + analyzer + slop + zeroTerms + ) = + object [fromText fieldName .= omitNulls base] + where + base = + [ "query" .= query, + "boost" .= boost, + "analyzer" .= analyzer, + "slop" .= slop, + "zero_terms_query" .= zeroTerms + ] + +instance FromJSON MatchPhraseQuery where + parseJSON = withObject "MatchPhraseQuery" parse where - parse "phrase" = pure MatchPhrase - parse "phrase_prefix" = pure MatchPhrasePrefix - parse t = fail ("Unexpected MatchQueryType: " <> show t) + parse = fieldTagged $ \fn o -> + MatchPhraseQuery fn + <$> o .: "query" + <*> o .:? "boost" + <*> o .:? "analyzer" + <*> o .:? "slop" + <*> o .:? "zero_terms_query" +-- | A @match_phrase_prefix@ query. +data MatchPhrasePrefixQuery = MatchPhrasePrefixQuery + { matchPhrasePrefixQueryField :: FieldName, + matchPhrasePrefixQueryQueryString :: QueryString, + matchPhrasePrefixQueryBoost :: Maybe Boost, + matchPhrasePrefixQueryAnalyzer :: Maybe Analyzer, + matchPhrasePrefixQuerySlop :: Maybe PhraseSlop, + matchPhrasePrefixQueryMaxExpansions :: Maybe MaxExpansions, + matchPhrasePrefixQueryZeroTerms :: Maybe ZeroTermsQuery + } + deriving stock (Eq, Show, Generic) + +matchPhrasePrefixQueryFieldLens :: Lens' MatchPhrasePrefixQuery FieldName +matchPhrasePrefixQueryFieldLens = lens matchPhrasePrefixQueryField (\x y -> x {matchPhrasePrefixQueryField = y}) + +matchPhrasePrefixQueryQueryStringLens :: Lens' MatchPhrasePrefixQuery QueryString +matchPhrasePrefixQueryQueryStringLens = lens matchPhrasePrefixQueryQueryString (\x y -> x {matchPhrasePrefixQueryQueryString = y}) + +matchPhrasePrefixQueryBoostLens :: Lens' MatchPhrasePrefixQuery (Maybe Boost) +matchPhrasePrefixQueryBoostLens = lens matchPhrasePrefixQueryBoost (\x y -> x {matchPhrasePrefixQueryBoost = y}) + +matchPhrasePrefixQueryAnalyzerLens :: Lens' MatchPhrasePrefixQuery (Maybe Analyzer) +matchPhrasePrefixQueryAnalyzerLens = lens matchPhrasePrefixQueryAnalyzer (\x y -> x {matchPhrasePrefixQueryAnalyzer = y}) + +matchPhrasePrefixQuerySlopLens :: Lens' MatchPhrasePrefixQuery (Maybe PhraseSlop) +matchPhrasePrefixQuerySlopLens = lens matchPhrasePrefixQuerySlop (\x y -> x {matchPhrasePrefixQuerySlop = y}) + +matchPhrasePrefixQueryMaxExpansionsLens :: Lens' MatchPhrasePrefixQuery (Maybe MaxExpansions) +matchPhrasePrefixQueryMaxExpansionsLens = lens matchPhrasePrefixQueryMaxExpansions (\x y -> x {matchPhrasePrefixQueryMaxExpansions = y}) + +matchPhrasePrefixQueryZeroTermsLens :: Lens' MatchPhrasePrefixQuery (Maybe ZeroTermsQuery) +matchPhrasePrefixQueryZeroTermsLens = lens matchPhrasePrefixQueryZeroTerms (\x y -> x {matchPhrasePrefixQueryZeroTerms = y}) + +instance ToJSON MatchPhrasePrefixQuery where + toJSON + ( MatchPhrasePrefixQuery + (FieldName fieldName) + (QueryString query) + boost + analyzer + slop + maxExpansions + zeroTerms + ) = + object [fromText fieldName .= omitNulls base] + where + base = + [ "query" .= query, + "boost" .= boost, + "analyzer" .= analyzer, + "slop" .= slop, + "max_expansions" .= maxExpansions, + "zero_terms_query" .= zeroTerms + ] + +instance FromJSON MatchPhrasePrefixQuery where + parseJSON = withObject "MatchPhrasePrefixQuery" parse + where + parse = fieldTagged $ \fn o -> + MatchPhrasePrefixQuery fn + <$> o .: "query" + <*> o .:? "boost" + <*> o .:? "analyzer" + <*> o .:? "slop" + <*> o .:? "max_expansions" + <*> o .:? "zero_terms_query" + data MultiMatchQuery = MultiMatchQuery { multiMatchQueryFields :: [FieldName], multiMatchQueryString :: QueryString, - multiMatchQueryOperator :: BooleanOperator, - multiMatchQueryZeroTerms :: ZeroTermsQuery, + multiMatchQueryOperator :: Maybe BooleanOperator, + multiMatchQueryZeroTerms :: Maybe ZeroTermsQuery, multiMatchQueryTiebreaker :: Maybe Tiebreaker, multiMatchQueryType :: Maybe MultiMatchQueryType, multiMatchQueryCutoffFrequency :: Maybe CutoffFrequency, @@ -175,16 +296,18 @@ } deriving stock (Eq, Show, Generic) +{-# DEPRECATED multiMatchQueryCutoffFrequency, multiMatchQueryCutoffFrequencyLens "cutoff_frequency is marked deprecated:true in the ES/OpenSearch spec; avoid it in new queries." #-} + multiMatchQueryFieldsLens :: Lens' MultiMatchQuery [FieldName] multiMatchQueryFieldsLens = lens multiMatchQueryFields (\x y -> x {multiMatchQueryFields = y}) multiMatchQueryStringLens :: Lens' MultiMatchQuery QueryString multiMatchQueryStringLens = lens multiMatchQueryString (\x y -> x {multiMatchQueryString = y}) -multiMatchQueryOperatorLens :: Lens' MultiMatchQuery BooleanOperator +multiMatchQueryOperatorLens :: Lens' MultiMatchQuery (Maybe BooleanOperator) multiMatchQueryOperatorLens = lens multiMatchQueryOperator (\x y -> x {multiMatchQueryOperator = y}) -multiMatchQueryZeroTermsLens :: Lens' MultiMatchQuery ZeroTermsQuery +multiMatchQueryZeroTermsLens :: Lens' MultiMatchQuery (Maybe ZeroTermsQuery) multiMatchQueryZeroTermsLens = lens multiMatchQueryZeroTerms (\x y -> x {multiMatchQueryZeroTerms = y}) multiMatchQueryTiebreakerLens :: Lens' MultiMatchQuery (Maybe Tiebreaker) @@ -242,8 +365,8 @@ MultiMatchQuery <$> o .:? "fields" .!= [] <*> o .: "query" - <*> o .: "operator" - <*> o .: "zero_terms_query" + <*> o .:? "operator" + <*> o .:? "zero_terms_query" <*> o .:? "tie_breaker" <*> o .:? "type" <*> o .:? "cutoff_frequency" @@ -259,8 +382,8 @@ MultiMatchQuery matchFields query - Or - ZeroTermsNone + Nothing + Nothing Nothing Nothing Nothing diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/MoreLikeThis.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/MoreLikeThis.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/MoreLikeThis.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/MoreLikeThis.hs @@ -4,9 +4,9 @@ ( MoreLikeThisQuery (..), -- * Optics - moreLikeThisQueryTextLens, + moreLikeThisQueryLikeLens, moreLikeThisQueryFieldsLens, - moreLikeThisQueryPercentMatchLens, + moreLikeThisQueryMinimumShouldMatchLens, moreLikeThisQueryMinimumTermFreqLens, moreLikeThisQueryMaxQueryTermsLens, moreLikeThisQueryStopWordsLens, @@ -25,10 +25,10 @@ import GHC.Generics data MoreLikeThisQuery = MoreLikeThisQuery - { moreLikeThisText :: Text, + { moreLikeThisLike :: Text, moreLikeThisFields :: Maybe (NonEmpty FieldName), -- default 0.3 (30%) - moreLikeThisPercentMatch :: Maybe PercentMatch, + moreLikeThisMinimumShouldMatch :: Maybe PercentMatch, moreLikeThisMinimumTermFreq :: Maybe MinimumTermFrequency, moreLikeThisMaxQueryTerms :: Maybe MaxQueryTerms, moreLikeThisStopWords :: Maybe (NonEmpty StopWord), @@ -42,14 +42,14 @@ } deriving stock (Eq, Show, Generic) -moreLikeThisQueryTextLens :: Lens' MoreLikeThisQuery (Text) -moreLikeThisQueryTextLens = lens moreLikeThisText (\x y -> x {moreLikeThisText = y}) +moreLikeThisQueryLikeLens :: Lens' MoreLikeThisQuery (Text) +moreLikeThisQueryLikeLens = lens moreLikeThisLike (\x y -> x {moreLikeThisLike = y}) moreLikeThisQueryFieldsLens :: Lens' MoreLikeThisQuery (Maybe (NonEmpty FieldName)) moreLikeThisQueryFieldsLens = lens moreLikeThisFields (\x y -> x {moreLikeThisFields = y}) -moreLikeThisQueryPercentMatchLens :: Lens' MoreLikeThisQuery (Maybe PercentMatch) -moreLikeThisQueryPercentMatchLens = lens moreLikeThisPercentMatch (\x y -> x {moreLikeThisPercentMatch = y}) +moreLikeThisQueryMinimumShouldMatchLens :: Lens' MoreLikeThisQuery (Maybe PercentMatch) +moreLikeThisQueryMinimumShouldMatchLens = lens moreLikeThisMinimumShouldMatch (\x y -> x {moreLikeThisMinimumShouldMatch = y}) moreLikeThisQueryMinimumTermFreqLens :: Lens' MoreLikeThisQuery (Maybe MinimumTermFrequency) moreLikeThisQueryMinimumTermFreqLens = lens moreLikeThisMinimumTermFreq (\x y -> x {moreLikeThisMinimumTermFreq = y}) @@ -84,9 +84,9 @@ instance ToJSON MoreLikeThisQuery where toJSON ( MoreLikeThisQuery - text + like_ fields - percent + msm mtf mqt stopwords @@ -101,9 +101,9 @@ omitNulls base where base = - [ "like_text" .= text, + [ "like" .= like_, "fields" .= fields, - "percent_terms_to_match" .= percent, + "minimum_should_match" .= msm, "min_term_freq" .= mtf, "max_query_terms" .= mqt, "stop_words" .= stopwords, @@ -121,10 +121,10 @@ where parse o = MoreLikeThisQuery - <$> o .: "like_text" + <$> o .: "like" -- <*> (optionalNE =<< o .:? "fields") <*> o .:? "fields" - <*> o .:? "percent_terms_to_match" + <*> o .:? "minimum_should_match" <*> o .:? "min_term_freq" <*> o .:? "max_query_terms" -- <*> (optionalNE =<< o .:? "stop_words") diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/MoreLikeThisField.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/MoreLikeThisField.hs deleted file mode 100644 --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/MoreLikeThisField.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Database.Bloodhound.Internal.Versions.Common.Types.Query.MoreLikeThisField - ( MoreLikeThisFieldQuery (..), - - -- * Optics - moreLikeThisFieldQueryTextLens, - moreLikeThisFieldQueryFieldsLens, - moreLikeThisFieldQueryPercentMatchLens, - moreLikeThisFieldQueryMinimumTermFreqLens, - moreLikeThisFieldQueryMaxQueryTermsLens, - moreLikeThisFieldQueryStopWordsLens, - moreLikeThisFieldQueryMinDocFrequencyLens, - moreLikeThisFieldQueryMaxDocFrequencyLens, - moreLikeThisFieldQueryMinWordLengthLens, - moreLikeThisFieldQueryMaxWordLengthLens, - moreLikeThisFieldQueryBoostTermsLens, - moreLikeThisFieldQueryBoostLens, - moreLikeThisFieldQueryAnalyzerLens, - ) -where - -import Database.Bloodhound.Internal.Utils.Imports -import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes -import Database.Bloodhound.Internal.Versions.Common.Types.Query.Commons -import GHC.Generics - -data MoreLikeThisFieldQuery = MoreLikeThisFieldQuery - { moreLikeThisFieldText :: Text, - moreLikeThisFieldFields :: FieldName, - -- default 0.3 (30%) - moreLikeThisFieldPercentMatch :: Maybe PercentMatch, - moreLikeThisFieldMinimumTermFreq :: Maybe MinimumTermFrequency, - moreLikeThisFieldMaxQueryTerms :: Maybe MaxQueryTerms, - moreLikeThisFieldStopWords :: Maybe (NonEmpty StopWord), - moreLikeThisFieldMinDocFrequency :: Maybe MinDocFrequency, - moreLikeThisFieldMaxDocFrequency :: Maybe MaxDocFrequency, - moreLikeThisFieldMinWordLength :: Maybe MinWordLength, - moreLikeThisFieldMaxWordLength :: Maybe MaxWordLength, - moreLikeThisFieldBoostTerms :: Maybe BoostTerms, - moreLikeThisFieldBoost :: Maybe Boost, - moreLikeThisFieldAnalyzer :: Maybe Analyzer - } - deriving stock (Eq, Show, Generic) - -moreLikeThisFieldQueryTextLens :: Lens' MoreLikeThisFieldQuery Text -moreLikeThisFieldQueryTextLens = lens moreLikeThisFieldText (\x y -> x {moreLikeThisFieldText = y}) - -moreLikeThisFieldQueryFieldsLens :: Lens' MoreLikeThisFieldQuery FieldName -moreLikeThisFieldQueryFieldsLens = lens moreLikeThisFieldFields (\x y -> x {moreLikeThisFieldFields = y}) - -moreLikeThisFieldQueryPercentMatchLens :: Lens' MoreLikeThisFieldQuery (Maybe PercentMatch) -moreLikeThisFieldQueryPercentMatchLens = lens moreLikeThisFieldPercentMatch (\x y -> x {moreLikeThisFieldPercentMatch = y}) - -moreLikeThisFieldQueryMinimumTermFreqLens :: Lens' MoreLikeThisFieldQuery (Maybe MinimumTermFrequency) -moreLikeThisFieldQueryMinimumTermFreqLens = lens moreLikeThisFieldMinimumTermFreq (\x y -> x {moreLikeThisFieldMinimumTermFreq = y}) - -moreLikeThisFieldQueryMaxQueryTermsLens :: Lens' MoreLikeThisFieldQuery (Maybe MaxQueryTerms) -moreLikeThisFieldQueryMaxQueryTermsLens = lens moreLikeThisFieldMaxQueryTerms (\x y -> x {moreLikeThisFieldMaxQueryTerms = y}) - -moreLikeThisFieldQueryStopWordsLens :: Lens' MoreLikeThisFieldQuery (Maybe (NonEmpty StopWord)) -moreLikeThisFieldQueryStopWordsLens = lens moreLikeThisFieldStopWords (\x y -> x {moreLikeThisFieldStopWords = y}) - -moreLikeThisFieldQueryMinDocFrequencyLens :: Lens' MoreLikeThisFieldQuery (Maybe MinDocFrequency) -moreLikeThisFieldQueryMinDocFrequencyLens = lens moreLikeThisFieldMinDocFrequency (\x y -> x {moreLikeThisFieldMinDocFrequency = y}) - -moreLikeThisFieldQueryMaxDocFrequencyLens :: Lens' MoreLikeThisFieldQuery (Maybe MaxDocFrequency) -moreLikeThisFieldQueryMaxDocFrequencyLens = lens moreLikeThisFieldMaxDocFrequency (\x y -> x {moreLikeThisFieldMaxDocFrequency = y}) - -moreLikeThisFieldQueryMinWordLengthLens :: Lens' MoreLikeThisFieldQuery (Maybe MinWordLength) -moreLikeThisFieldQueryMinWordLengthLens = lens moreLikeThisFieldMinWordLength (\x y -> x {moreLikeThisFieldMinWordLength = y}) - -moreLikeThisFieldQueryMaxWordLengthLens :: Lens' MoreLikeThisFieldQuery (Maybe MaxWordLength) -moreLikeThisFieldQueryMaxWordLengthLens = lens moreLikeThisFieldMaxWordLength (\x y -> x {moreLikeThisFieldMaxWordLength = y}) - -moreLikeThisFieldQueryBoostTermsLens :: Lens' MoreLikeThisFieldQuery (Maybe BoostTerms) -moreLikeThisFieldQueryBoostTermsLens = lens moreLikeThisFieldBoostTerms (\x y -> x {moreLikeThisFieldBoostTerms = y}) - -moreLikeThisFieldQueryBoostLens :: Lens' MoreLikeThisFieldQuery (Maybe Boost) -moreLikeThisFieldQueryBoostLens = lens moreLikeThisFieldBoost (\x y -> x {moreLikeThisFieldBoost = y}) - -moreLikeThisFieldQueryAnalyzerLens :: Lens' MoreLikeThisFieldQuery (Maybe Analyzer) -moreLikeThisFieldQueryAnalyzerLens = lens moreLikeThisFieldAnalyzer (\x y -> x {moreLikeThisFieldAnalyzer = y}) - -instance ToJSON MoreLikeThisFieldQuery where - toJSON - ( MoreLikeThisFieldQuery - text - (FieldName fieldName) - percent - mtf - mqt - stopwords - mindf - maxdf - minwl - maxwl - boostTerms - boost - analyzer - ) = - object [fromText fieldName .= omitNulls base] - where - base = - [ "like_text" .= text, - "percent_terms_to_match" .= percent, - "min_term_freq" .= mtf, - "max_query_terms" .= mqt, - "stop_words" .= stopwords, - "min_doc_freq" .= mindf, - "max_doc_freq" .= maxdf, - "min_word_length" .= minwl, - "max_word_length" .= maxwl, - "boost_terms" .= boostTerms, - "boost" .= boost, - "analyzer" .= analyzer - ] - -instance FromJSON MoreLikeThisFieldQuery where - parseJSON = withObject "MoreLikeThisFieldQuery" parse - where - parse = fieldTagged $ \fn o -> - MoreLikeThisFieldQuery - <$> o .: "like_text" - <*> pure fn - <*> o .:? "percent_terms_to_match" - <*> o .:? "min_term_freq" - <*> o .:? "max_query_terms" - -- <*> (optionalNE =<< o .:? "stop_words") - <*> o .:? "stop_words" - <*> o .:? "min_doc_freq" - <*> o .:? "max_doc_freq" - <*> o .:? "min_word_length" - <*> o .:? "max_word_length" - <*> o .:? "boost_terms" - <*> o .:? "boost" - <*> o .:? "analyzer" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Neural.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Neural.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Neural.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | OpenSearch Neural Search query clause. +-- +-- +-- +-- Serialized as the query-clause body: +-- +-- @ +-- { "neural": { "": { "query_text": "...", "model_id": "...", "k": 10 } } } +-- @ +-- +-- Or, for image embeddings: +-- +-- @ +-- { "neural": { "": { "query_image": "base64...", "model_id": "...", "k": 10 } } } +-- @ +-- +-- Or, for radial search (OpenSearch 2.13+), one of @min_score@ \/ @max_distance@ +-- replaces @k@: +-- +-- @ +-- { "neural": { "": { "query_text": "...", "model_id": "...", "min_score": 0.5 } } } +-- @ +module Database.Bloodhound.Internal.Versions.Common.Types.Query.Neural + ( NeuralQuery (..), + NeuralQueryInput (..), + NeuralQueryTermination (..), + mkNeuralQuery, + mkNeuralQueryByMaxDistance, + mkNeuralQueryByMinScore, + + -- * Optics + neuralFieldLens, + neuralInputLens, + neuralModelIdLens, + neuralTerminationLens, + neuralBoostLens, + ) +where + +import Data.Aeson +import Data.Aeson.Key qualified as AK +import Data.Aeson.KeyMap qualified as KM +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes +import GHC.Generics + +-- | The input to a 'NeuralQuery'. OpenSearch accepts exactly one of +-- @query_text@ (text embeddings) or @query_image@ (image embeddings, base64 +-- encoded) per clause; the sum type makes that constraint unrepresentable +-- by construction on the encode path. +data NeuralQueryInput + = NeuralTextInput Text + | NeuralImageInput Text + deriving stock (Eq, Show, Generic) + +instance ToJSON NeuralQueryInput where + toJSON (NeuralTextInput t) = object ["query_text" .= t] + toJSON (NeuralImageInput t) = object ["query_image" .= t] + +instance FromJSON NeuralQueryInput where + parseJSON = withObject "NeuralQueryInput" $ \o -> + (NeuralTextInput <$> o .: "query_text") + <|> (NeuralImageInput <$> o .: "query_image") + <|> fail "NeuralQueryInput: expected exactly one of query_text or query_image" + +-- | Termination strategy for a 'NeuralQuery'. OpenSearch exposes three +-- mutually exclusive shapes: +-- +-- * 'NeuralTerminationByK' — top-k nearest neighbours (the classic shape). +-- * 'NeuralTerminationByMaxDistance' — radial search in L2 \/ cosine space: +-- return every vector whose distance to the query embedding is +-- @<= max_distance@ (OpenSearch 2.13+). +-- * 'NeuralTerminationByMinScore' — radial search in inner product space: +-- return every vector whose similarity score is @>= min_score@ +-- (OpenSearch 2.13+). +-- +-- Sending more than one of these in the same clause fails at query time; +-- the sum type makes that constraint unrepresentable by construction. +data NeuralQueryTermination + = NeuralTerminationByK Int + | NeuralTerminationByMaxDistance Double + | NeuralTerminationByMinScore Double + deriving stock (Eq, Show, Generic) + +instance ToJSON NeuralQueryTermination where + toJSON (NeuralTerminationByK k) = object ["k" .= k] + toJSON (NeuralTerminationByMaxDistance d) = object ["max_distance" .= d] + toJSON (NeuralTerminationByMinScore s) = object ["min_score" .= s] + +instance FromJSON NeuralQueryTermination where + parseJSON = withObject "NeuralQueryTermination" $ \o -> + (NeuralTerminationByK <$> o .: "k") + <|> (NeuralTerminationByMaxDistance <$> o .: "max_distance") + <|> (NeuralTerminationByMinScore <$> o .: "min_score") + <|> fail + "NeuralQueryTermination: expected exactly one of k, max_distance, min_score" + +-- | OpenSearch @neural@ query clause, used inside the @\"query\"@ body of a +-- @POST \/{index}\/_search@ request. This is the recommended way to perform +-- neural search — as a query clause rather than via the +-- @_plugins\/_neural\/search@ endpoint wrapper. +-- +-- The optional @filter@ field of the upstream OpenSearch API is not yet +-- modelled here because it would create a module import cycle with +-- "Database.Bloodhound.Internal.Versions.Common.Types.Query" (the @Filter@ +-- newtype lives there and wraps @Query@). A follow-up bead can introduce +-- @filter@ by either extracting @Filter@ to a shared module or using an +-- @.hs-boot@ source import. +data NeuralQuery = NeuralQuery + { neuralField :: FieldName, + neuralInput :: NeuralQueryInput, + neuralModelId :: Text, + neuralTermination :: NeuralQueryTermination, + neuralBoost :: Maybe Double + } + deriving stock (Eq, Show, Generic) + +neuralFieldLens :: Lens' NeuralQuery FieldName +neuralFieldLens = lens neuralField (\x y -> x {neuralField = y}) + +neuralInputLens :: Lens' NeuralQuery NeuralQueryInput +neuralInputLens = lens neuralInput (\x y -> x {neuralInput = y}) + +neuralModelIdLens :: Lens' NeuralQuery Text +neuralModelIdLens = lens neuralModelId (\x y -> x {neuralModelId = y}) + +neuralTerminationLens :: Lens' NeuralQuery NeuralQueryTermination +neuralTerminationLens = lens neuralTermination (\x y -> x {neuralTermination = y}) + +neuralBoostLens :: Lens' NeuralQuery (Maybe Double) +neuralBoostLens = lens neuralBoost (\x y -> x {neuralBoost = y}) + +-- | Render the field name as an Aeson 'AK.Key' so it can be used as the +-- dict key under @neural@. +fieldNameKey :: FieldName -> AK.Key +fieldNameKey (FieldName t) = AK.fromText t + +-- | Flatten a 'NeuralQueryInput' into the single Aeson pair that lives +-- alongside the other clause-body fields. Used by the 'NeuralQuery' ToJSON +-- instance so that @query_text@ \/ @query_image@ appear at the same level +-- as @model_id@, @k@, etc. +inputPair :: NeuralQueryInput -> (AK.Key, Value) +inputPair (NeuralTextInput t) = ("query_text", toJSON t) +inputPair (NeuralImageInput t) = ("query_image", toJSON t) + +-- | Flatten a 'NeuralQueryTermination' into the single Aeson pair that +-- lives alongside the other clause-body fields. +terminationPair :: NeuralQueryTermination -> (AK.Key, Value) +terminationPair (NeuralTerminationByK k) = ("k", toJSON k) +terminationPair (NeuralTerminationByMaxDistance d) = ("max_distance", toJSON d) +terminationPair (NeuralTerminationByMinScore s) = ("min_score", toJSON s) + +instance ToJSON NeuralQuery where + toJSON (NeuralQuery field input modelId termination boost) = + object + [ "neural" + .= object + [ fieldNameKey field .= clauseBody + ] + ] + where + clauseBody = + omitNulls + [ inputPair input, + "model_id" .= modelId, + terminationPair termination, + "boost" .= boost + ] + +instance FromJSON NeuralQuery where + parseJSON = withObject "NeuralQuery" $ \obj -> do + neuralObj <- obj .: "neural" + case KM.toList neuralObj of + [(fieldKey, clauseVal)] -> withClauseBody fieldKey clauseVal + _ -> fail "NeuralQuery: expected a single-field neural object" + where + withClauseBody fieldKey clauseVal = + withObject + "NeuralQuery clause body" + ( \clause -> do + fieldInput <- parseJSON (Object clause) + fieldModelId <- clause .: "model_id" + fieldTermination <- parseJSON (Object clause) + fieldBoost <- clause .:? "boost" + return $ + NeuralQuery + (FieldName (AK.toText fieldKey)) + fieldInput + fieldModelId + fieldTermination + fieldBoost + ) + clauseVal + +-- | Smart constructor for the k-based 'NeuralQuery' (the classic top-k +-- shape). Defaults every optional field to 'Nothing'. +mkNeuralQuery :: + FieldName -> + NeuralQueryInput -> + Text -> + Int -> + NeuralQuery +mkNeuralQuery field input modelId k = + NeuralQuery + { neuralField = field, + neuralInput = input, + neuralModelId = modelId, + neuralTermination = NeuralTerminationByK k, + neuralBoost = Nothing + } + +-- | Smart constructor for the radial-search 'NeuralQuery' variant +-- (@max_distance@, L2 \/ cosine space). Defaults every optional field to +-- 'Nothing'. Mutually exclusive with k at the OpenSearch query level — +-- enforced here by the 'NeuralQueryTermination' sum. +mkNeuralQueryByMaxDistance :: + FieldName -> + NeuralQueryInput -> + Text -> + Double -> + NeuralQuery +mkNeuralQueryByMaxDistance field input modelId maxDistance = + NeuralQuery + { neuralField = field, + neuralInput = input, + neuralModelId = modelId, + neuralTermination = NeuralTerminationByMaxDistance maxDistance, + neuralBoost = Nothing + } + +-- | Smart constructor for the radial-search 'NeuralQuery' variant +-- (@min_score@, inner product space). Defaults every optional field to +-- 'Nothing'. Mutually exclusive with k at the OpenSearch query level — +-- enforced here by the 'NeuralQueryTermination' sum. +mkNeuralQueryByMinScore :: + FieldName -> + NeuralQueryInput -> + Text -> + Double -> + NeuralQuery +mkNeuralQueryByMinScore field input modelId minScore = + NeuralQuery + { neuralField = field, + neuralInput = input, + neuralModelId = modelId, + neuralTermination = NeuralTerminationByMinScore minScore, + neuralBoost = Nothing + } diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/NeuralSparse.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/NeuralSparse.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/NeuralSparse.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | OpenSearch Neural Sparse Search query clause. +-- +-- +-- +-- Serialized as the query-clause body (text input, default analyzer): +-- +-- @ +-- { "neural_sparse": { "": { "query_text": "..." } } } +-- @ +-- +-- Text input with an explicit sparse-encoding @model_id@: +-- +-- @ +-- { "neural_sparse": { "": { "query_text": "...", "model_id": "..." } } } +-- @ +-- +-- Text input with a built-in analyzer (rank_features fields only): +-- +-- @ +-- { "neural_sparse": { "": { "query_text": "...", "analyzer": "bert-uncased" } } } +-- @ +-- +-- Raw sparse-vector input (pre-encoded token weights): +-- +-- @ +-- { "neural_sparse": { "": { "query_tokens": { "hello": 3.32, "world": 2.61 } } } } +-- @ +-- +-- Approximate nearest-neighbour (ANN) search on @sparse_vector@ fields +-- (OpenSearch 3.3+) adds a nested @method_parameters@ object: +-- +-- @ +-- { "neural_sparse": { "": { "query_text": "...", "model_id": "...", "method_parameters": { "top_n": 10, "heap_factor": 1.0, "k": 10 } } } } +-- @ +module Database.Bloodhound.Internal.Versions.Common.Types.Query.NeuralSparse + ( NeuralSparseQuery (..), + NeuralSparseInput (..), + NeuralSparseModelSource (..), + NeuralSparseMethodParameters (..), + mkNeuralSparseQueryText, + mkNeuralSparseQueryTextAnalyzer, + mkNeuralSparseQueryTokens, + mkNeuralSparseQueryTokensAnalyzer, + + -- * Optics + neuralSparseFieldLens, + neuralSparseInputLens, + neuralSparseModelSourceLens, + neuralSparseMethodParametersLens, + neuralSparseMethodParametersTopNLens, + neuralSparseMethodParametersHeapFactorLens, + neuralSparseMethodParametersKLens, + ) +where + +import Data.Aeson +import Data.Aeson.Key qualified as AK +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as M +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes +import GHC.Generics + +-- | The input to a 'NeuralSparseQuery'. OpenSearch accepts exactly one of +-- @query_text@ (raw text, encoded server-side by the model \/ analyzer) or +-- @query_tokens@ (a pre-encoded sparse vector mapping token strings to +-- weights); the sum type makes that constraint unrepresentable by +-- construction on the encode path. +data NeuralSparseInput + = NeuralSparseTextInput Text + | NeuralSparseTokensInput (M.Map Text Double) + deriving stock (Eq, Show, Generic) + +instance ToJSON NeuralSparseInput where + toJSON (NeuralSparseTextInput t) = object ["query_text" .= t] + toJSON (NeuralSparseTokensInput ts) = object ["query_tokens" .= ts] + +instance FromJSON NeuralSparseInput where + parseJSON = withObject "NeuralSparseInput" $ \o -> + (NeuralSparseTextInput <$> o .: "query_text") + <|> (NeuralSparseTokensInput <$> o .: "query_tokens") + <|> fail + "NeuralSparseInput: expected exactly one of query_text or query_tokens" + +-- | The model source for a 'NeuralSparseQuery' when the input is +-- 'NeuralSparseTextInput'. OpenSearch exposes two mutually exclusive shapes: +-- +-- * 'NeuralSparseByModelId' — references a deployed sparse-encoding model +-- (or tokenizer, for doc-only mode). Valid on both @rank_features@ and +-- @sparse_vector@ fields. +-- * 'NeuralSparseByAnalyzer' — references one of the built-in DL model +-- analyzers (currently @bert-uncased@ or @mbert-uncased@). Valid only on +-- @rank_features@ fields. +-- +-- When neither is supplied, OpenSearch defaults to the @bert-uncased@ +-- analyzer; that default is represented at the type level by passing +-- 'Nothing' in 'neuralSparseModelSource'. +-- +-- Sending both @model_id@ and @analyzer@ fails at query time; the sum type +-- makes that constraint unrepresentable by construction. +data NeuralSparseModelSource + = NeuralSparseByModelId Text + | NeuralSparseByAnalyzer Text + deriving stock (Eq, Show, Generic) + +instance ToJSON NeuralSparseModelSource where + toJSON (NeuralSparseByModelId m) = object ["model_id" .= m] + toJSON (NeuralSparseByAnalyzer a) = object ["analyzer" .= a] + +instance FromJSON NeuralSparseModelSource where + parseJSON = withObject "NeuralSparseModelSource" $ \o -> + (NeuralSparseByModelId <$> o .: "model_id") + <|> (NeuralSparseByAnalyzer <$> o .: "analyzer") + <|> fail + "NeuralSparseModelSource: expected exactly one of model_id or analyzer" + +-- | Approximate-nearest-neighbour tuning parameters for searches on +-- @sparse_vector@ fields (OpenSearch 3.3+). All fields are optional; the +-- record is rendered as the nested @method_parameters@ object inside the +-- clause body. +-- +-- Note: when every field is 'Nothing', the encoder still emits +-- @"method_parameters": {}@ because 'omitNulls' does not elide empty +-- objects. Prefer passing 'Nothing' at the 'NeuralSparseQuery' level +-- (`neuralSparseMethodParameters = Nothing`) in that case. +-- +-- The @filter@ sub-field documented for @method_parameters.filter@ is not +-- modelled here because it would create a module import cycle with +-- "Database.Bloodhound.Internal.Versions.Common.Types.Query" (the @Filter@ +-- newtype lives there and wraps @Query@). A follow-up bead can introduce +-- @filter@ by either extracting @Filter@ to a shared module or using an +-- @.hs-boot@ source import -- the same constraint that keeps the @filter@ +-- field off 'Database.Bloodhound.Internal.Versions.Common.Types.Query.Neural.NeuralQuery'. +data NeuralSparseMethodParameters = NeuralSparseMethodParameters + { neuralSparseMethodParametersTopN :: Maybe Int, + neuralSparseMethodParametersHeapFactor :: Maybe Double, + neuralSparseMethodParametersK :: Maybe Int + } + deriving stock (Eq, Show, Generic) + +instance ToJSON NeuralSparseMethodParameters where + toJSON params = + omitNulls + [ "top_n" .= neuralSparseMethodParametersTopN params, + "heap_factor" .= neuralSparseMethodParametersHeapFactor params, + "k" .= neuralSparseMethodParametersK params + ] + +instance FromJSON NeuralSparseMethodParameters where + parseJSON = withObject "NeuralSparseMethodParameters" $ \o -> + NeuralSparseMethodParameters + <$> o .:? "top_n" + <*> o .:? "heap_factor" + <*> o .:? "k" + +-- | OpenSearch @neural_sparse@ query clause, used inside the @\"query\"@ +-- body of a @POST \/{index}\/_search@ request. Targets either a +-- @rank_features@ field (the classic shape, introduced in OpenSearch 2.11) +-- or a @sparse_vector@ field (approximate nearest-neighbour search, +-- introduced in OpenSearch 3.3). +-- +-- The deprecated @max_token_score@ parameter (a no-op since OpenSearch +-- 2.12) is intentionally not modelled. +data NeuralSparseQuery = NeuralSparseQuery + { neuralSparseField :: FieldName, + neuralSparseInput :: NeuralSparseInput, + neuralSparseModelSource :: Maybe NeuralSparseModelSource, + neuralSparseMethodParameters :: Maybe NeuralSparseMethodParameters + } + deriving stock (Eq, Show, Generic) + +neuralSparseFieldLens :: Lens' NeuralSparseQuery FieldName +neuralSparseFieldLens = lens neuralSparseField (\x y -> x {neuralSparseField = y}) + +neuralSparseInputLens :: Lens' NeuralSparseQuery NeuralSparseInput +neuralSparseInputLens = lens neuralSparseInput (\x y -> x {neuralSparseInput = y}) + +neuralSparseModelSourceLens :: Lens' NeuralSparseQuery (Maybe NeuralSparseModelSource) +neuralSparseModelSourceLens = + lens neuralSparseModelSource (\x y -> x {neuralSparseModelSource = y}) + +neuralSparseMethodParametersLens :: Lens' NeuralSparseQuery (Maybe NeuralSparseMethodParameters) +neuralSparseMethodParametersLens = + lens + neuralSparseMethodParameters + (\x y -> x {neuralSparseMethodParameters = y}) + +neuralSparseMethodParametersTopNLens :: Lens' NeuralSparseMethodParameters (Maybe Int) +neuralSparseMethodParametersTopNLens = + lens + neuralSparseMethodParametersTopN + (\x y -> x {neuralSparseMethodParametersTopN = y}) + +neuralSparseMethodParametersHeapFactorLens :: Lens' NeuralSparseMethodParameters (Maybe Double) +neuralSparseMethodParametersHeapFactorLens = + lens + neuralSparseMethodParametersHeapFactor + (\x y -> x {neuralSparseMethodParametersHeapFactor = y}) + +neuralSparseMethodParametersKLens :: Lens' NeuralSparseMethodParameters (Maybe Int) +neuralSparseMethodParametersKLens = + lens + neuralSparseMethodParametersK + (\x y -> x {neuralSparseMethodParametersK = y}) + +-- | Render the field name as an Aeson 'AK.Key' so it can be used as the +-- dict key under @neural_sparse@. +fieldNameKey :: FieldName -> AK.Key +fieldNameKey (FieldName t) = AK.fromText t + +-- | Flatten a 'NeuralSparseInput' into the single Aeson pair that lives +-- alongside the other clause-body fields. Used by the 'NeuralSparseQuery' +-- ToJSON instance so that @query_text@ \/ @query_tokens@ appear at the same +-- level as @model_id@, @analyzer@, etc. +inputPair :: NeuralSparseInput -> (AK.Key, Value) +inputPair (NeuralSparseTextInput t) = ("query_text", toJSON t) +inputPair (NeuralSparseTokensInput ts) = ("query_tokens", toJSON ts) + +-- | Flatten a 'NeuralSparseModelSource' into the single Aeson pair that +-- lives alongside the other clause-body fields. +modelSourcePair :: NeuralSparseModelSource -> (AK.Key, Value) +modelSourcePair (NeuralSparseByModelId m) = ("model_id", toJSON m) +modelSourcePair (NeuralSparseByAnalyzer a) = ("analyzer", toJSON a) + +instance ToJSON NeuralSparseQuery where + toJSON (NeuralSparseQuery field input modelSource methodParameters) = + object + [ "neural_sparse" + .= object + [ fieldNameKey field .= clauseBody + ] + ] + where + clauseBody = + omitNulls $ + [ inputPair input + ] + ++ maybe [] (pure . modelSourcePair) modelSource + ++ maybe [] (\mp -> ["method_parameters" .= mp]) methodParameters + +instance FromJSON NeuralSparseQuery where + parseJSON = withObject "NeuralSparseQuery" $ \obj -> do + neuralObj <- obj .: "neural_sparse" + case KM.toList neuralObj of + [(fieldKey, clauseVal)] -> withClauseBody fieldKey clauseVal + _ -> fail "NeuralSparseQuery: expected a single-field neural_sparse object" + where + withClauseBody fieldKey clauseVal = + withObject + "NeuralSparseQuery clause body" + ( \clause -> do + -- Input is required: one of query_text or query_tokens must be + -- present, so a hard parse failure is appropriate. + fieldInput <- parseJSON (Object clause) + -- Model source is optional: absence of both model_id and + -- analyzer means "use the default analyzer". + let fieldModelSource = parseMaybe parseJSON (Object clause) + fieldMethodParameters <- clause .:? "method_parameters" + return $ + NeuralSparseQuery + (FieldName (AK.toText fieldKey)) + fieldInput + fieldModelSource + fieldMethodParameters + ) + clauseVal + +-- | Smart constructor for the text-input, @model_id@-based shape. Targets +-- either @rank_features@ or @sparse_vector@ fields. Defaults every +-- optional field to 'Nothing'. +mkNeuralSparseQueryText :: + FieldName -> + Text -> + Text -> + NeuralSparseQuery +mkNeuralSparseQueryText field queryText modelId = + NeuralSparseQuery + { neuralSparseField = field, + neuralSparseInput = NeuralSparseTextInput queryText, + neuralSparseModelSource = Just (NeuralSparseByModelId modelId), + neuralSparseMethodParameters = Nothing + } + +-- | Smart constructor for the text-input, built-in-analyzer shape. Valid +-- only on @rank_features@ fields; OpenSearch accepts @bert-uncased@ and +-- @mbert-uncased@. Defaults every optional field to 'Nothing'. +mkNeuralSparseQueryTextAnalyzer :: + FieldName -> + Text -> + Text -> + NeuralSparseQuery +mkNeuralSparseQueryTextAnalyzer field queryText analyzer = + NeuralSparseQuery + { neuralSparseField = field, + neuralSparseInput = NeuralSparseTextInput queryText, + neuralSparseModelSource = Just (NeuralSparseByAnalyzer analyzer), + neuralSparseMethodParameters = Nothing + } + +-- | Smart constructor for the raw-tokens-input, @model_id@-based shape. +-- The token map is sent verbatim as @query_tokens@. Defaults every +-- optional field to 'Nothing'. +mkNeuralSparseQueryTokens :: + FieldName -> + M.Map Text Double -> + Text -> + NeuralSparseQuery +mkNeuralSparseQueryTokens field tokens modelId = + NeuralSparseQuery + { neuralSparseField = field, + neuralSparseInput = NeuralSparseTokensInput tokens, + neuralSparseModelSource = Just (NeuralSparseByModelId modelId), + neuralSparseMethodParameters = Nothing + } + +-- | Smart constructor for the raw-tokens-input, built-in-analyzer shape. +-- Valid only on @rank_features@ fields. Defaults every optional field to +-- 'Nothing'. +-- +-- Note: per the OpenSearch @neural_sparse@ documentation, @analyzer@ is +-- only meaningful when paired with 'NeuralSparseTextInput' (because raw +-- tokens are already encoded and do not need an analyzer pass). Combining +-- 'NeuralSparseTokensInput' with 'NeuralSparseByAnalyzer' is accepted by +-- this constructor but will be rejected by OpenSearch at query time -- +-- prefer 'mkNeuralSparseQueryTokens' for the tokens-input shape. +mkNeuralSparseQueryTokensAnalyzer :: + FieldName -> + M.Map Text Double -> + Text -> + NeuralSparseQuery +mkNeuralSparseQueryTokensAnalyzer field tokens analyzer = + NeuralSparseQuery + { neuralSparseField = field, + neuralSparseInput = NeuralSparseTokensInput tokens, + neuralSparseModelSource = Just (NeuralSparseByAnalyzer analyzer), + neuralSparseMethodParameters = Nothing + } diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Prefix.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Prefix.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Prefix.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Prefix.hs @@ -7,6 +7,8 @@ prefixQueryFieldLens, prefixQueryPrefixValueLens, prefixQueryBoostLens, + prefixQueryCaseInsensitiveLens, + prefixQueryRewriteLens, ) where @@ -18,6 +20,8 @@ data PrefixQuery = PrefixQuery { prefixQueryField :: FieldName, prefixQueryPrefixValue :: Text, + prefixQueryCaseInsensitive :: Maybe CaseInsensitive, + prefixQueryRewrite :: Maybe Rewrite, prefixQueryBoost :: Maybe Boost } deriving stock (Eq, Show, Generic) @@ -31,12 +35,20 @@ prefixQueryBoostLens :: Lens' PrefixQuery (Maybe Boost) prefixQueryBoostLens = lens prefixQueryBoost (\x y -> x {prefixQueryBoost = y}) +prefixQueryCaseInsensitiveLens :: Lens' PrefixQuery (Maybe CaseInsensitive) +prefixQueryCaseInsensitiveLens = lens prefixQueryCaseInsensitive (\x y -> x {prefixQueryCaseInsensitive = y}) + +prefixQueryRewriteLens :: Lens' PrefixQuery (Maybe Rewrite) +prefixQueryRewriteLens = lens prefixQueryRewrite (\x y -> x {prefixQueryRewrite = y}) + instance ToJSON PrefixQuery where - toJSON (PrefixQuery (FieldName fieldName) queryValue boost) = + toJSON (PrefixQuery (FieldName fieldName) queryValue caseInsensitive rewrite boost) = object [fromText fieldName .= omitNulls base] where base = [ "value" .= queryValue, + "case_insensitive" .= caseInsensitive, + "rewrite" .= rewrite, "boost" .= boost ] @@ -46,4 +58,6 @@ parse = fieldTagged $ \fn o -> PrefixQuery fn <$> o .: "value" + <*> o .:? "case_insensitive" + <*> o .:? "rewrite" <*> o .:? "boost" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/QueryString.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/QueryString.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/QueryString.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/QueryString.hs @@ -10,7 +10,6 @@ queryStringQueryOperatorLens, queryStringQueryAnalyzerLens, queryStringQueryAllowLeadingWildcardLens, - queryStringQueryLowercaseExpandedLens, queryStringQueryEnablePositionIncrementsLens, queryStringQueryFuzzyMaxExpansionsLens, queryStringQueryFuzzinessLens, @@ -18,10 +17,8 @@ queryStringQueryPhraseSlopLens, queryStringQueryBoostLens, queryStringQueryAnalyzeWildcardLens, - queryStringQueryGeneratePhraseQueriesLens, queryStringQueryMinimumShouldMatchLens, queryStringQueryLenientLens, - queryStringQueryLocaleLens, ) where @@ -37,7 +34,6 @@ queryStringOperator :: Maybe BooleanOperator, queryStringAnalyzer :: Maybe Analyzer, queryStringAllowLeadingWildcard :: Maybe AllowLeadingWildcard, - queryStringLowercaseExpanded :: Maybe LowercaseExpanded, queryStringEnablePositionIncrements :: Maybe EnablePositionIncrements, queryStringFuzzyMaxExpansions :: Maybe MaxExpansions, queryStringFuzziness :: Maybe Fuzziness, @@ -45,10 +41,8 @@ queryStringPhraseSlop :: Maybe PhraseSlop, queryStringBoost :: Maybe Boost, queryStringAnalyzeWildcard :: Maybe AnalyzeWildcard, - queryStringGeneratePhraseQueries :: Maybe GeneratePhraseQueries, queryStringMinimumShouldMatch :: Maybe MinimumMatch, - queryStringLenient :: Maybe Lenient, - queryStringLocale :: Maybe Locale + queryStringLenient :: Maybe Lenient } deriving stock (Eq, Show, Generic) @@ -67,9 +61,6 @@ queryStringQueryAllowLeadingWildcardLens :: Lens' QueryStringQuery (Maybe AllowLeadingWildcard) queryStringQueryAllowLeadingWildcardLens = lens queryStringAllowLeadingWildcard (\x y -> x {queryStringAllowLeadingWildcard = y}) -queryStringQueryLowercaseExpandedLens :: Lens' QueryStringQuery (Maybe LowercaseExpanded) -queryStringQueryLowercaseExpandedLens = lens queryStringLowercaseExpanded (\x y -> x {queryStringLowercaseExpanded = y}) - queryStringQueryEnablePositionIncrementsLens :: Lens' QueryStringQuery (Maybe EnablePositionIncrements) queryStringQueryEnablePositionIncrementsLens = lens queryStringEnablePositionIncrements (\x y -> x {queryStringEnablePositionIncrements = y}) @@ -91,18 +82,12 @@ queryStringQueryAnalyzeWildcardLens :: Lens' QueryStringQuery (Maybe AnalyzeWildcard) queryStringQueryAnalyzeWildcardLens = lens queryStringAnalyzeWildcard (\x y -> x {queryStringAnalyzeWildcard = y}) -queryStringQueryGeneratePhraseQueriesLens :: Lens' QueryStringQuery (Maybe GeneratePhraseQueries) -queryStringQueryGeneratePhraseQueriesLens = lens queryStringGeneratePhraseQueries (\x y -> x {queryStringGeneratePhraseQueries = y}) - queryStringQueryMinimumShouldMatchLens :: Lens' QueryStringQuery (Maybe MinimumMatch) queryStringQueryMinimumShouldMatchLens = lens queryStringMinimumShouldMatch (\x y -> x {queryStringMinimumShouldMatch = y}) queryStringQueryLenientLens :: Lens' QueryStringQuery (Maybe Lenient) queryStringQueryLenientLens = lens queryStringLenient (\x y -> x {queryStringLenient = y}) -queryStringQueryLocaleLens :: Lens' QueryStringQuery (Maybe Locale) -queryStringQueryLocaleLens = lens queryStringLocale (\x y -> x {queryStringLocale = y}) - instance ToJSON QueryStringQuery where toJSON ( QueryStringQuery @@ -111,7 +96,6 @@ qsOperator qsAnalyzer qsAllowWildcard - qsLowercaseExpanded qsEnablePositionIncrements qsFuzzyMaxExpansions qsFuzziness @@ -119,10 +103,8 @@ qsPhraseSlop qsBoost qsAnalyzeWildcard - qsGeneratePhraseQueries qsMinimumShouldMatch qsLenient - qsLocale ) = omitNulls base where @@ -132,7 +114,6 @@ "default_operator" .= qsOperator, "analyzer" .= qsAnalyzer, "allow_leading_wildcard" .= qsAllowWildcard, - "lowercase_expanded_terms" .= qsLowercaseExpanded, "enable_position_increments" .= qsEnablePositionIncrements, "fuzzy_max_expansions" .= qsFuzzyMaxExpansions, "fuzziness" .= qsFuzziness, @@ -140,10 +121,8 @@ "phrase_slop" .= qsPhraseSlop, "boost" .= qsBoost, "analyze_wildcard" .= qsAnalyzeWildcard, - "auto_generate_phrase_queries" .= qsGeneratePhraseQueries, "minimum_should_match" .= qsMinimumShouldMatch, - "lenient" .= qsLenient, - "locale" .= qsLocale + "lenient" .= qsLenient ] instance FromJSON QueryStringQuery where @@ -156,7 +135,6 @@ <*> o .:? "default_operator" <*> o .:? "analyzer" <*> o .:? "allow_leading_wildcard" - <*> o .:? "lowercase_expanded_terms" <*> o .:? "enable_position_increments" <*> o .:? "fuzzy_max_expansions" <*> o .:? "fuzziness" @@ -164,18 +142,13 @@ <*> o .:? "phrase_slop" <*> o .:? "boost" <*> o .:? "analyze_wildcard" - <*> o .:? "auto_generate_phrase_queries" <*> o .:? "minimum_should_match" <*> o .:? "lenient" - <*> o .:? "locale" mkQueryStringQuery :: QueryString -> QueryStringQuery mkQueryStringQuery qs = QueryStringQuery qs - Nothing - Nothing - Nothing Nothing Nothing Nothing diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Range.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Range.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Range.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Range.hs @@ -10,13 +10,22 @@ LessThanEq (..), LessThanEqD (..), RangeQuery (..), + RangeRelation (..), RangeValue (..), + RangeDateMathValue (..), mkRangeQuery, -- * Optics rangeQueryFieldLens, rangeQueryRangeLens, rangeQueryBoostLens, + rangeQueryRelationLens, + rangeQueryFormatLens, + rangeQueryTimeZoneLens, + rangeDateMathLtLens, + rangeDateMathLteLens, + rangeDateMathGtLens, + rangeDateMathGteLens, ) where @@ -28,7 +37,10 @@ data RangeQuery = RangeQuery { rangeQueryField :: FieldName, rangeQueryRange :: RangeValue, - rangeQueryBoost :: Boost + rangeQueryBoost :: Maybe Boost, + rangeQueryRelation :: Maybe RangeRelation, + rangeQueryFormat :: Maybe Format, + rangeQueryTimeZone :: Maybe RangeTimeZone } deriving stock (Eq, Show, Generic) @@ -38,14 +50,30 @@ rangeQueryRangeLens :: Lens' RangeQuery RangeValue rangeQueryRangeLens = lens rangeQueryRange (\x y -> x {rangeQueryRange = y}) -rangeQueryBoostLens :: Lens' RangeQuery Boost +rangeQueryBoostLens :: Lens' RangeQuery (Maybe Boost) rangeQueryBoostLens = lens rangeQueryBoost (\x y -> x {rangeQueryBoost = y}) +rangeQueryRelationLens :: Lens' RangeQuery (Maybe RangeRelation) +rangeQueryRelationLens = lens rangeQueryRelation (\x y -> x {rangeQueryRelation = y}) + +rangeQueryFormatLens :: Lens' RangeQuery (Maybe Format) +rangeQueryFormatLens = lens rangeQueryFormat (\x y -> x {rangeQueryFormat = y}) + +rangeQueryTimeZoneLens :: Lens' RangeQuery (Maybe RangeTimeZone) +rangeQueryTimeZoneLens = lens rangeQueryTimeZone (\x y -> x {rangeQueryTimeZone = y}) + instance ToJSON RangeQuery where - toJSON (RangeQuery (FieldName fieldName) range boost) = + toJSON (RangeQuery (FieldName fieldName) range boost relation format timeZone) = object [fromText fieldName .= object conjoined] where - conjoined = ("boost" .= boost) : rangeValueToPair range + conjoined = + rangeValueToPair range + <> catMaybes + [ ("boost" .=) <$> boost, + ("relation" .=) <$> relation, + ("format" .=) <$> format, + ("time_zone" .=) <$> timeZone + ] instance FromJSON RangeQuery where parseJSON = withObject "RangeQuery" parse @@ -53,11 +81,35 @@ parse = fieldTagged $ \fn o -> RangeQuery fn <$> parseJSON (Object o) - <*> o .: "boost" + <*> o .:? "boost" + <*> o .:? "relation" + <*> o .:? "format" + <*> o .:? "time_zone" mkRangeQuery :: FieldName -> RangeValue -> RangeQuery -mkRangeQuery f r = RangeQuery f r (Boost 1.0) +mkRangeQuery f r = RangeQuery f r Nothing Nothing Nothing Nothing +-- | Indicates how a range query matches range terms for search. See the +-- @relation@ field of @range@ queries in the ES query DSL. +data RangeRelation + = RangeRelationContains + | RangeRelationWithin + | RangeRelationIntersects + deriving stock (Eq, Show, Generic) + +instance ToJSON RangeRelation where + toJSON RangeRelationContains = String "CONTAINS" + toJSON RangeRelationWithin = String "WITHIN" + toJSON RangeRelationIntersects = String "INTERSECTS" + +instance FromJSON RangeRelation where + parseJSON = withText "RangeRelation" parse + where + parse "CONTAINS" = pure RangeRelationContains + parse "WITHIN" = pure RangeRelationWithin + parse "INTERSECTS" = pure RangeRelationIntersects + parse t = fail ("Unexpected RangeRelation: " <> show t) + newtype LessThan = LessThan Double deriving stock (Eq, Show, Generic) newtype LessThanEq = LessThanEq Double deriving stock (Eq, Show, Generic) @@ -91,8 +143,37 @@ | RangeDoubleGteLte GreaterThanEq LessThanEq | RangeDoubleGteLt GreaterThanEq LessThan | RangeDoubleGtLte GreaterThan LessThanEq + | RangeDateMath RangeDateMathValue deriving stock (Eq, Show, Generic) +-- | A range over ES date-math string bounds (e.g. @"now-1d"@, @"now/d"@). +-- Each bound is optional, but at least one must be present when encoded; +-- the decoder rejects an all-'Nothing' body (matching the +-- @parseDate@\/@parseDouble@ fallthrough when no bound keys are present). +-- Bounds are 'DateMathString's carried opaquely — ES evaluates the +-- expression server-side. The 'RangeQuery'\'s 'rangeQueryFormat' and +-- 'rangeQueryTimeZone' apply to these bounds just as they do to 'UTCTime' +-- bounds. +data RangeDateMathValue = RangeDateMathValue + { rangeDateMathLt :: Maybe DateMathString, + rangeDateMathLte :: Maybe DateMathString, + rangeDateMathGt :: Maybe DateMathString, + rangeDateMathGte :: Maybe DateMathString + } + deriving stock (Eq, Show, Generic) + +rangeDateMathLtLens :: Lens' RangeDateMathValue (Maybe DateMathString) +rangeDateMathLtLens = lens rangeDateMathLt (\x y -> x {rangeDateMathLt = y}) + +rangeDateMathLteLens :: Lens' RangeDateMathValue (Maybe DateMathString) +rangeDateMathLteLens = lens rangeDateMathLte (\x y -> x {rangeDateMathLte = y}) + +rangeDateMathGtLens :: Lens' RangeDateMathValue (Maybe DateMathString) +rangeDateMathGtLens = lens rangeDateMathGt (\x y -> x {rangeDateMathGt = y}) + +rangeDateMathGteLens :: Lens' RangeDateMathValue (Maybe DateMathString) +rangeDateMathGteLens = lens rangeDateMathGte (\x y -> x {rangeDateMathGte = y}) + parseRangeValue :: ( FromJSON t4, FromJSON t3, @@ -159,6 +240,7 @@ parse o = parseDate o <|> parseDouble o + <|> parseDateMath o parseDate o = parseRangeValue GreaterThanD @@ -191,6 +273,14 @@ RangeDoubleLte mzero o + parseDateMath o = do + lt <- o .:? "lt" + lte <- o .:? "lte" + gt <- o .:? "gt" + gte <- o .:? "gte" + if isNothing lt && isNothing lte && isNothing gt && isNothing gte + then mzero + else pure (RangeDateMath (RangeDateMathValue lt lte gt gte)) rangeValueToPair :: RangeValue -> [Pair] rangeValueToPair rv = case rv of @@ -210,3 +300,10 @@ RangeDoubleGtLte (GreaterThan l) (LessThanEq g) -> ["gt" .= l, "lte" .= g] RangeDoubleGteLt (GreaterThanEq l) (LessThan g) -> ["gte" .= l, "lt" .= g] RangeDoubleGtLt (GreaterThan l) (LessThan g) -> ["gt" .= l, "lt" .= g] + RangeDateMath (RangeDateMathValue lt lte gt gte) -> + catMaybes + [ ("lt" .=) <$> lt, + ("lte" .=) <$> lte, + ("gt" .=) <$> gt, + ("gte" .=) <$> gte + ] diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Regexp.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Regexp.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Regexp.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Regexp.hs @@ -11,10 +11,13 @@ regexpQueryLens, regexpQueryFlagsLens, regexpQueryBoostLens, + regexpQueryCaseInsensitiveLens, + regexpQueryMaxDeterminizedStatesLens, + regexpQueryRewriteLens, ) where -import qualified Data.Text as T +import Data.Text qualified as T import Database.Bloodhound.Internal.Utils.Imports import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes import Database.Bloodhound.Internal.Versions.Common.Types.Query.Commons @@ -23,7 +26,10 @@ data RegexpQuery = RegexpQuery { regexpQueryField :: FieldName, regexpQuery :: Regexp, - regexpQueryFlags :: RegexpFlags, + regexpQueryFlags :: Maybe RegexpFlags, + regexpQueryCaseInsensitive :: Maybe CaseInsensitive, + regexpQueryMaxDeterminizedStates :: Maybe MaxDeterminizedStates, + regexpQueryRewrite :: Maybe Rewrite, regexpQueryBoost :: Maybe Boost } deriving stock (Eq, Show, Generic) @@ -34,18 +40,30 @@ regexpQueryLens :: Lens' RegexpQuery Regexp regexpQueryLens = lens regexpQuery (\x y -> x {regexpQuery = y}) -regexpQueryFlagsLens :: Lens' RegexpQuery RegexpFlags +regexpQueryFlagsLens :: Lens' RegexpQuery (Maybe RegexpFlags) regexpQueryFlagsLens = lens regexpQueryFlags (\x y -> x {regexpQueryFlags = y}) regexpQueryBoostLens :: Lens' RegexpQuery (Maybe Boost) regexpQueryBoostLens = lens regexpQueryBoost (\x y -> x {regexpQueryBoost = y}) +regexpQueryCaseInsensitiveLens :: Lens' RegexpQuery (Maybe CaseInsensitive) +regexpQueryCaseInsensitiveLens = lens regexpQueryCaseInsensitive (\x y -> x {regexpQueryCaseInsensitive = y}) + +regexpQueryMaxDeterminizedStatesLens :: Lens' RegexpQuery (Maybe MaxDeterminizedStates) +regexpQueryMaxDeterminizedStatesLens = lens regexpQueryMaxDeterminizedStates (\x y -> x {regexpQueryMaxDeterminizedStates = y}) + +regexpQueryRewriteLens :: Lens' RegexpQuery (Maybe Rewrite) +regexpQueryRewriteLens = lens regexpQueryRewrite (\x y -> x {regexpQueryRewrite = y}) + instance ToJSON RegexpQuery where toJSON ( RegexpQuery (FieldName rqQueryField) (Regexp regexpQueryQuery) rqQueryFlags + rqQueryCaseInsensitive + rqQueryMaxDeterminizedStates + rqQueryRewrite rqQueryBoost ) = object [fromText rqQueryField .= omitNulls base] @@ -53,6 +71,9 @@ base = [ "value" .= regexpQueryQuery, "flags" .= rqQueryFlags, + "case_insensitive" .= rqQueryCaseInsensitive, + "max_determinized_states" .= rqQueryMaxDeterminizedStates, + "rewrite" .= rqQueryRewrite, "boost" .= rqQueryBoost ] @@ -62,7 +83,10 @@ parse = fieldTagged $ \fn o -> RegexpQuery fn <$> o .: "value" - <*> o .: "flags" + <*> o .:? "flags" + <*> o .:? "case_insensitive" + <*> o .:? "max_determinized_states" + <*> o .:? "rewrite" <*> o .:? "boost" newtype Regexp = Regexp Text deriving newtype (Eq, Show, FromJSON) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/SimpleQueryString.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/SimpleQueryString.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/SimpleQueryString.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/SimpleQueryString.hs @@ -12,8 +12,6 @@ simpleQueryStringQueryOperatorLens, simpleQueryStringQueryAnalyzerLens, simpleQueryStringQueryFlagsLens, - simpleQueryStringQueryLowercaseExpandedLens, - simpleQueryStringQueryLocaleLens, ) where @@ -27,9 +25,7 @@ simpleQueryStringField :: Maybe FieldOrFields, simpleQueryStringOperator :: Maybe BooleanOperator, simpleQueryStringAnalyzer :: Maybe Analyzer, - simpleQueryStringFlags :: Maybe (NonEmpty SimpleQueryFlag), - simpleQueryStringLowercaseExpanded :: Maybe LowercaseExpanded, - simpleQueryStringLocale :: Maybe Locale + simpleQueryStringFlags :: Maybe (NonEmpty SimpleQueryFlag) } deriving stock (Eq, Show, Generic) @@ -48,12 +44,6 @@ simpleQueryStringQueryFlagsLens :: Lens' SimpleQueryStringQuery (Maybe (NonEmpty SimpleQueryFlag)) simpleQueryStringQueryFlagsLens = lens simpleQueryStringFlags (\x y -> x {simpleQueryStringFlags = y}) -simpleQueryStringQueryLowercaseExpandedLens :: Lens' SimpleQueryStringQuery (Maybe LowercaseExpanded) -simpleQueryStringQueryLowercaseExpandedLens = lens simpleQueryStringLowercaseExpanded (\x y -> x {simpleQueryStringLowercaseExpanded = y}) - -simpleQueryStringQueryLocaleLens :: Lens' SimpleQueryStringQuery (Maybe Locale) -simpleQueryStringQueryLocaleLens = lens simpleQueryStringLocale (\x y -> x {simpleQueryStringLocale = y}) - instance ToJSON SimpleQueryStringQuery where toJSON SimpleQueryStringQuery {..} = omitNulls (base ++ maybeAdd) @@ -63,9 +53,7 @@ [ "fields" .= simpleQueryStringField, "default_operator" .= simpleQueryStringOperator, "analyzer" .= simpleQueryStringAnalyzer, - "flags" .= simpleQueryStringFlags, - "lowercase_expanded_terms" .= simpleQueryStringLowercaseExpanded, - "locale" .= simpleQueryStringLocale + "flags" .= simpleQueryStringFlags ] instance FromJSON SimpleQueryStringQuery where @@ -78,8 +66,6 @@ <*> o .:? "default_operator" <*> o .:? "analyzer" <*> (parseFlags <$> o .:? "flags") - <*> o .:? "lowercase_expanded_terms" - <*> o .:? "locale" parseFlags (Just (x : xs)) = Just (x :| xs) parseFlags _ = Nothing diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Wildcard.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Wildcard.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Wildcard.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Query/Wildcard.hs @@ -7,6 +7,9 @@ wildcardQueryFieldLens, wildcardQueryLens, wildcardQueryBoostLens, + wildcardQueryCaseInsensitiveLens, + wildcardQueryRewriteLens, + wildcardQueryNameLens, ) where @@ -17,7 +20,10 @@ data WildcardQuery = WildcardQuery { wildcardQueryField :: FieldName, - wildcardQuery :: Key, + wildcardQuery :: Maybe Key, + wildcardQueryCaseInsensitive :: Maybe CaseInsensitive, + wildcardQueryRewrite :: Maybe Rewrite, + wildcardQueryName :: Maybe QueryName, wildcardQueryBoost :: Maybe Boost } deriving stock (Eq, Show, Generic) @@ -25,23 +31,38 @@ wildcardQueryFieldLens :: Lens' WildcardQuery FieldName wildcardQueryFieldLens = lens wildcardQueryField (\x y -> x {wildcardQueryField = y}) -wildcardQueryLens :: Lens' WildcardQuery Key +wildcardQueryLens :: Lens' WildcardQuery (Maybe Key) wildcardQueryLens = lens wildcardQuery (\x y -> x {wildcardQuery = y}) wildcardQueryBoostLens :: Lens' WildcardQuery (Maybe Boost) wildcardQueryBoostLens = lens wildcardQueryBoost (\x y -> x {wildcardQueryBoost = y}) +wildcardQueryCaseInsensitiveLens :: Lens' WildcardQuery (Maybe CaseInsensitive) +wildcardQueryCaseInsensitiveLens = lens wildcardQueryCaseInsensitive (\x y -> x {wildcardQueryCaseInsensitive = y}) + +wildcardQueryRewriteLens :: Lens' WildcardQuery (Maybe Rewrite) +wildcardQueryRewriteLens = lens wildcardQueryRewrite (\x y -> x {wildcardQueryRewrite = y}) + +wildcardQueryNameLens :: Lens' WildcardQuery (Maybe QueryName) +wildcardQueryNameLens = lens wildcardQueryName (\x y -> x {wildcardQueryName = y}) + instance ToJSON WildcardQuery where toJSON ( WildcardQuery (FieldName wcQueryField) wcQueryQuery + wcQueryCaseInsensitive + wcQueryRewrite + wcQueryName wcQueryBoost ) = object [fromText wcQueryField .= omitNulls base] where base = [ "value" .= wcQueryQuery, + "case_insensitive" .= wcQueryCaseInsensitive, + "rewrite" .= wcQueryRewrite, + "_name" .= wcQueryName, "boost" .= wcQueryBoost ] @@ -50,5 +71,8 @@ where parse = fieldTagged $ \fn o -> WildcardQuery fn - <$> o .: "value" + <$> o .:? "value" + <*> o .:? "case_insensitive" + <*> o .:? "rewrite" + <*> o .:? "_name" <*> o .:? "boost" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/RankEval.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/RankEval.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/RankEval.hs @@ -0,0 +1,769 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.RankEval +-- Copyright : (C) 2014, 2018 Chris Allen +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Chris Allen +-- Stability : provisional +-- Portability : GHC +-- +-- Types for the @POST \/{index}\/_rank_eval@ and @POST /_rank_eval@ +-- endpoints, shared verbatim by Elasticsearch (7.x\/8.x\/9.x) and +-- OpenSearch (1.x\/2.x\/3.x). See +-- +-- * +-- * +module Database.Bloodhound.Internal.Versions.Common.Types.RankEval + ( -- * Request body + RankEvalRequest (..), + RankEvalRequestItem (..), + DocumentRating (..), + UnratedDoc (..), + + -- * Metric specification + RankEvalMetric (..), + MeanReciprocalRankConfig (..), + PrecisionConfig (..), + RecallConfig (..), + ExpectedReciprocalRankConfig (..), + defaultMeanReciprocalRankConfig, + defaultPrecisionConfig, + defaultRecallConfig, + defaultExpectedReciprocalRankConfig, + + -- * Response + RankEvalResponse (..), + RankEvalDetail (..), + RankEvalHit (..), + + -- * URI parameters + RankEvalOptions (..), + defaultRankEvalOptions, + rankEvalOptionsParams, + + -- * Optics + rerRequestsLens, + rerMetricLens, + rerMaxConcurrentSearchesLens, + reiIdLens, + reiRequestLens, + reiRatingsLens, + reiTemplateIdLens, + reiParamsLens, + reiSummaryFieldsLens, + reiIgnoreUnlabeledLens, + drIndexLens, + drIdLens, + drRatingLens, + drPassthroughLens, + rerResponseScoreLens, + rerResponseShardsLens, + rerResponseDetailsLens, + rerResponseFailuresLens, + redMetricScoreLens, + redUnratedDocsLens, + redHitsLens, + redMetricDetailsLens, + rehIndexLens, + rehIdLens, + rehScoreLens, + rehRatingLens, + mrrcKLens, + pcKLens, + pcRelevantRatingThresholdLens, + pcIgnoreUnlabeledLens, + rcKLens, + rcRelevantRatingThresholdLens, + errecKLens, + errecMaximumRelevanceLens, + udIndexLens, + udIdLens, + reoSearchTypeLens, + reoAllowNoIndicesLens, + reoExpandWildcardsLens, + reoIgnoreUnavailableLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap (KeyMap) +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as M +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + ( Lens', + Parser, + lens, + omitNulls, + typeMismatch, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( DocId (..), + FieldName, + IndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes + ( ShardResult (..), + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Search + ( Search, + SearchType (..), + ) + +-- | Top-level request body for @_rank_eval@. Carries the list of +-- 'RankEvalRequestItem's to evaluate, an optional 'RankEvalMetric' +-- (defaults server-side to mean reciprocal rank when 'Nothing'), and +-- an optional @max_concurrent_searches@ cap. +-- +-- /Backend note/: Elasticsearch defaults 'rerMetric' to mean +-- reciprocal rank with @k=20@ when it is 'Nothing'. OpenSearch +-- instead rejects the request with @Required [metric]@ — always set +-- 'rerMetric' explicitly if the request may run against an +-- OpenSearch backend. +data RankEvalRequest = RankEvalRequest + { rerRequests :: [RankEvalRequestItem], + -- | When 'Nothing', the server applies its default + -- (mean_reciprocal_rank with @k=20@). When @'Just' m@, the chosen + -- metric is serialised under its server-recognised key. + rerMetric :: Maybe RankEvalMetric, + -- | Maximum number of concurrent sub-requests the coordinator + -- will fan out. The server default is @1@; raising it trades + -- throughput for resource pressure. Forwarded as + -- @max_concurrent_searches@. + rerMaxConcurrentSearches :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON RankEvalRequest where + toJSON RankEvalRequest {..} = + omitNulls $ + catMaybes + [ Just ("requests" .= rerRequests), + ("metric" .=) <$> rerMetric, + ("max_concurrent_searches" .=) <$> rerMaxConcurrentSearches + ] + +-- Note: no 'FromJSON RankEvalRequest' instance. The server does not +-- echo the request back, and 'Search' has no 'FromJSON' instance +-- anyway. Test the encoding by inspecting 'encode' output directly. + +rerRequestsLens :: Lens' RankEvalRequest [RankEvalRequestItem] +rerRequestsLens = lens rerRequests (\x y -> x {rerRequests = y}) + +rerMetricLens :: Lens' RankEvalRequest (Maybe RankEvalMetric) +rerMetricLens = lens rerMetric (\x y -> x {rerMetric = y}) + +rerMaxConcurrentSearchesLens :: Lens' RankEvalRequest (Maybe Int) +rerMaxConcurrentSearchesLens = lens rerMaxConcurrentSearches (\x y -> x {rerMaxConcurrentSearches = y}) + +-- | A single ranked-search evaluation item. The server runs the +-- 'reiRequest' 'Search' body, compares the top @k@ returned documents +-- against the 'reiRatings' list, and scores the result with the +-- request-level 'RankEvalMetric'. +data RankEvalRequestItem = RankEvalRequestItem + { -- | Caller-chosen identifier; surfaces as a key in + -- 'rerResponseDetails' so each item's score can be correlated + -- back. Must be unique within a single 'RankEvalRequest'. + reiId :: Text, + -- | The search body to evaluate. Treated as a regular + -- @POST \/{index}\/_search@ body, so callers can build it with + -- 'mkSearch' (or any of its helpers) and let the server execute + -- it as-is. The @size@ of the 'Search' controls how many hits + -- are scored against the ratings. + reiRequest :: Search, + -- | Known relevance judgements: documents in the target index + -- with a numerical @rating@ (the higher the more relevant). + -- Metrics interpret the scale differently — see + -- . + reiRatings :: [DocumentRating], + -- | Optional stored search template id. When set, 'reiRequest' + -- is ignored and 'reiParams' is fed to the template instead. + reiTemplateId :: Maybe Text, + -- | Parameters to render the template referenced by + -- 'reiTemplateId'. Ignored unless 'reiTemplateId' is set. + reiParams :: Maybe Object, + -- | Optional list of stored fields to include in each hit so the + -- caller can inspect them in 'redHits'. Renders + -- @summary_fields@. 'Nothing' is omitted entirely (the server + -- default is @[]@). + reiSummaryFields :: Maybe [FieldName], + -- | Drop documents from this item that have no entry in + -- 'reiRatings' before computing the metric. Renders + -- @ignore_unlabeled@. Can also be set on the metric itself (see + -- e.g. 'pcIgnoreUnlabeled'); the item-level value takes + -- precedence when both are set. + reiIgnoreUnlabeled :: Maybe Bool + } + deriving stock (Eq, Show) + +instance ToJSON RankEvalRequestItem where + toJSON RankEvalRequestItem {..} = + omitNulls $ + catMaybes + [ Just ("id" .= reiId), + Just ("request" .= reiRequest), + Just ("ratings" .= reiRatings), + ("template_id" .=) <$> reiTemplateId, + ("params" .=) <$> reiParams, + ("summary_fields" .=) <$> reiSummaryFields, + ("ignore_unlabeled" .=) <$> reiIgnoreUnlabeled + ] + +-- Note: no 'FromJSON RankEvalRequestItem' — see 'RankEvalRequest'. + +reiIdLens :: Lens' RankEvalRequestItem Text +reiIdLens = lens reiId (\x y -> x {reiId = y}) + +reiRequestLens :: Lens' RankEvalRequestItem Search +reiRequestLens = lens reiRequest (\x y -> x {reiRequest = y}) + +reiRatingsLens :: Lens' RankEvalRequestItem [DocumentRating] +reiRatingsLens = lens reiRatings (\x y -> x {reiRatings = y}) + +reiTemplateIdLens :: Lens' RankEvalRequestItem (Maybe Text) +reiTemplateIdLens = lens reiTemplateId (\x y -> x {reiTemplateId = y}) + +reiParamsLens :: Lens' RankEvalRequestItem (Maybe Object) +reiParamsLens = lens reiParams (\x y -> x {reiParams = y}) + +reiSummaryFieldsLens :: Lens' RankEvalRequestItem (Maybe [FieldName]) +reiSummaryFieldsLens = lens reiSummaryFields (\x y -> x {reiSummaryFields = y}) + +reiIgnoreUnlabeledLens :: Lens' RankEvalRequestItem (Maybe Bool) +reiIgnoreUnlabeledLens = lens reiIgnoreUnlabeled (\x y -> x {reiIgnoreUnlabeled = y}) + +-- | A known relevance judgement for a document. Encoded with the +-- @_index@\/@_id@\/@rating@ keys the server expects; an optional +-- @passthrough@ object is forwarded verbatim and surfaces on the +-- matching 'RankEvalHit' so callers can attach domain-specific +-- metadata (category, query intent, ...). +data DocumentRating = DocumentRating + { drIndex :: IndexName, + drId :: DocId, + -- | Numerical relevance rating. Higher = more relevant; the + -- server does not enforce a scale, but most metrics interpret + -- @rating >= 1@ as relevant and @rating = 0@ as irrelevant. + -- Typed as 'Double' to admit fractional ratings (both ES and OS + -- accept any non-negative number); the threshold above which a + -- document counts as "relevant" is governed by the metric (see + -- e.g. 'pcRelevantRatingThreshold'). + drRating :: Double, + drPassthrough :: Maybe Object + } + deriving stock (Eq, Show) + +instance ToJSON DocumentRating where + toJSON DocumentRating {..} = + omitNulls $ + catMaybes + [ Just ("_index" .= drIndex), + Just ("_id" .= drId), + Just ("rating" .= drRating), + ("passthrough" .=) <$> drPassthrough + ] + +instance FromJSON DocumentRating where + parseJSON = withObject "DocumentRating" $ \o -> + DocumentRating + <$> o + .: "_index" + <*> o + .: "_id" + <*> o + .: "rating" + <*> o + .:? "passthrough" + +drIndexLens :: Lens' DocumentRating IndexName +drIndexLens = lens drIndex (\x y -> x {drIndex = y}) + +drIdLens :: Lens' DocumentRating DocId +drIdLens = lens drId (\x y -> x {drId = y}) + +drRatingLens :: Lens' DocumentRating Double +drRatingLens = lens drRating (\x y -> x {drRating = y}) + +drPassthroughLens :: Lens' DocumentRating (Maybe Object) +drPassthroughLens = lens drPassthrough (\x y -> x {drPassthrough = y}) + +-- | A document returned by the search but absent from the ratings +-- list. Surfaces under 'redUnratedDocs' so callers can identify +-- documents they may want to label. +data UnratedDoc = UnratedDoc + { udIndex :: IndexName, + udId :: DocId + } + deriving stock (Eq, Show) + +instance FromJSON UnratedDoc where + parseJSON = withObject "UnratedDoc" $ \o -> + UnratedDoc + <$> o + .: "_index" + <*> o + .: "_id" + +udIndexLens :: Lens' UnratedDoc IndexName +udIndexLens = lens udIndex (\x y -> x {udIndex = y}) + +udIdLens :: Lens' UnratedDoc DocId +udIdLens = lens udId (\x y -> x {udId = y}) + +-- | The relevance metric used to score the evaluation. Each +-- constructor is encoded under its server-recognised key — +-- e.g. 'RankEvalPrecision' becomes +-- @{"precision": { ... }}@. When the field is omitted entirely +-- ('rerMetric' = 'Nothing') the server defaults to mean reciprocal +-- rank with @k=20@. +-- +-- The 'RankEvalDCG' and 'RankEvalNDCG' constructors take no +-- configuration — both metrics are parameterless on the server side. +data RankEvalMetric + = RankEvalMeanReciprocalRank MeanReciprocalRankConfig + | RankEvalPrecision PrecisionConfig + | RankEvalRecall RecallConfig + | RankEvalDCG + | RankEvalNDCG + | RankEvalExpectedReciprocalRank ExpectedReciprocalRankConfig + deriving stock (Eq, Show) + +instance ToJSON RankEvalMetric where + toJSON m = object [pair] + where + pair = case m of + RankEvalMeanReciprocalRank cfg -> "mean_reciprocal_rank" .= cfg + RankEvalPrecision cfg -> "precision" .= cfg + RankEvalRecall cfg -> "recall" .= cfg + RankEvalDCG -> "dcg" .= object [] + RankEvalNDCG -> "ndcg" .= object [] + RankEvalExpectedReciprocalRank cfg -> "expected_reciprocal_rank" .= cfg + +instance FromJSON RankEvalMetric where + parseJSON = withObject "RankEvalMetric" $ \o -> do + -- Exactly one metric key is expected per the ES spec. Pick the + -- first recognised one; unknown keys are ignored so a server-side + -- extension does not cause a hard failure (it falls through to an + -- 'empty' which the caller surfaces as a parse error). + let tryKey :: Key -> Parser (Maybe RankEvalMetric) + tryKey k + | k == "mean_reciprocal_rank" = fmap (fmap RankEvalMeanReciprocalRank) (o .:? k) + | k == "precision" = fmap (fmap RankEvalPrecision) (o .:? k) + | k == "recall" = fmap (fmap RankEvalRecall) (o .:? k) + | k == "dcg" = presentAs RankEvalDCG + | k == "ndcg" = presentAs RankEvalNDCG + | k == "expected_reciprocal_rank" = fmap (fmap RankEvalExpectedReciprocalRank) (o .:? k) + | otherwise = pure Nothing + where + -- @dcg@ and @ndcg@ carry no configuration; only key + -- presence matters. Parse as 'Value' to disambiguate the + -- 'FromJSON a0' constraint. + presentAs metric = do + mv <- (o .:? k) :: Parser (Maybe Value) + pure $ case mv of + Just _ -> Just metric + Nothing -> Nothing + ms <- + traverse + tryKey + [ "mean_reciprocal_rank", + "precision", + "recall", + "dcg", + "ndcg", + "expected_reciprocal_rank" + ] + case catMaybes ms of + (x : _) -> pure x + [] -> fail "RankEvalMetric: no recognised metric key found" + +-- | Configuration for 'RankEvalMeanReciprocalRank'. The server +-- default for a missing 'mrrcK' is @20@. +data MeanReciprocalRankConfig = MeanReciprocalRankConfig + { mrrcK :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON MeanReciprocalRankConfig where + toJSON MeanReciprocalRankConfig {..} = + omitNulls $ catMaybes [("k" .=) <$> mrrcK] + +instance FromJSON MeanReciprocalRankConfig where + parseJSON = withObject "MeanReciprocalRankConfig" $ \o -> + MeanReciprocalRankConfig <$> o .:? "k" + +defaultMeanReciprocalRankConfig :: MeanReciprocalRankConfig +defaultMeanReciprocalRankConfig = MeanReciprocalRankConfig {mrrcK = Nothing} + +mrrcKLens :: Lens' MeanReciprocalRankConfig (Maybe Int) +mrrcKLens = lens mrrcK (\x y -> x {mrrcK = y}) + +-- | Configuration for 'RankEvalPrecision'. +data PrecisionConfig = PrecisionConfig + { -- | Number of top hits to score. Required server-side; we model + -- it as 'Maybe' to allow 'defaultPrecisionConfig' to omit it, + -- but callers should set it before sending. + pcK :: Maybe Int, + -- | Rating threshold above which a document is considered + -- relevant. Defaults to @1@ server-side. + pcRelevantRatingThreshold :: Maybe Int, + -- | When @True@, documents without a rating are treated as + -- irrelevant rather than skipped. Defaults to @false@. + pcIgnoreUnlabeled :: Maybe Bool + } + deriving stock (Eq, Show) + +instance ToJSON PrecisionConfig where + toJSON PrecisionConfig {..} = + omitNulls $ + catMaybes + [ ("k" .=) <$> pcK, + ("relevant_rating_threshold" .=) <$> pcRelevantRatingThreshold, + ("ignore_unlabeled" .=) <$> pcIgnoreUnlabeled + ] + +instance FromJSON PrecisionConfig where + parseJSON = withObject "PrecisionConfig" $ \o -> + PrecisionConfig + <$> o + .:? "k" + <*> o + .:? "relevant_rating_threshold" + <*> o + .:? "ignore_unlabeled" + +defaultPrecisionConfig :: PrecisionConfig +defaultPrecisionConfig = + PrecisionConfig + { pcK = Nothing, + pcRelevantRatingThreshold = Nothing, + pcIgnoreUnlabeled = Nothing + } + +pcKLens :: Lens' PrecisionConfig (Maybe Int) +pcKLens = lens pcK (\x y -> x {pcK = y}) + +pcRelevantRatingThresholdLens :: Lens' PrecisionConfig (Maybe Int) +pcRelevantRatingThresholdLens = + lens pcRelevantRatingThreshold (\x y -> x {pcRelevantRatingThreshold = y}) + +pcIgnoreUnlabeledLens :: Lens' PrecisionConfig (Maybe Bool) +pcIgnoreUnlabeledLens = lens pcIgnoreUnlabeled (\x y -> x {pcIgnoreUnlabeled = y}) + +-- | Configuration for 'RankEvalRecall'. Like 'PrecisionConfig' but +-- without @ignore_unlabeled@. +data RecallConfig = RecallConfig + { rcK :: Maybe Int, + rcRelevantRatingThreshold :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON RecallConfig where + toJSON RecallConfig {..} = + omitNulls $ + catMaybes + [ ("k" .=) <$> rcK, + ("relevant_rating_threshold" .=) <$> rcRelevantRatingThreshold + ] + +instance FromJSON RecallConfig where + parseJSON = withObject "RecallConfig" $ \o -> + RecallConfig + <$> o + .:? "k" + <*> o + .:? "relevant_rating_threshold" + +defaultRecallConfig :: RecallConfig +defaultRecallConfig = + RecallConfig {rcK = Nothing, rcRelevantRatingThreshold = Nothing} + +rcKLens :: Lens' RecallConfig (Maybe Int) +rcKLens = lens rcK (\x y -> x {rcK = y}) + +rcRelevantRatingThresholdLens :: Lens' RecallConfig (Maybe Int) +rcRelevantRatingThresholdLens = + lens rcRelevantRatingThreshold (\x y -> x {rcRelevantRatingThreshold = y}) + +-- | Configuration for 'RankEvalExpectedReciprocalRank'. Both fields +-- are required server-side; modelled as 'Maybe' so the default record +-- can omit them, callers should set them before sending. +data ExpectedReciprocalRankConfig = ExpectedReciprocalRankConfig + { -- | Number of top hits to score. + errecK :: Maybe Int, + -- | Highest possible relevance rating. Used to interpolate + -- gain for ranks beyond the rated set. + errecMaximumRelevance :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON ExpectedReciprocalRankConfig where + toJSON ExpectedReciprocalRankConfig {..} = + omitNulls $ + catMaybes + [ ("k" .=) <$> errecK, + ("maximum_relevance" .=) <$> errecMaximumRelevance + ] + +instance FromJSON ExpectedReciprocalRankConfig where + parseJSON = withObject "ExpectedReciprocalRankConfig" $ \o -> + ExpectedReciprocalRankConfig + <$> o + .:? "k" + <*> o + .:? "maximum_relevance" + +defaultExpectedReciprocalRankConfig :: ExpectedReciprocalRankConfig +defaultExpectedReciprocalRankConfig = + ExpectedReciprocalRankConfig + { errecK = Nothing, + errecMaximumRelevance = Nothing + } + +errecKLens :: Lens' ExpectedReciprocalRankConfig (Maybe Int) +errecKLens = lens errecK (\x y -> x {errecK = y}) + +errecMaximumRelevanceLens :: Lens' ExpectedReciprocalRankConfig (Maybe Int) +errecMaximumRelevanceLens = + lens errecMaximumRelevance (\x y -> x {errecMaximumRelevance = y}) + +-- | Top-level response wrapper. The overall score aggregates the +-- per-request metric scores; 'rerResponseDetails' breaks it down per +-- 'reiId' and 'rerResponseFailures' carries per-item errors. +-- +-- /Backend note/: Elasticsearch and OpenSearch disagree on two +-- fields. ES returns the overall score as @rank_eval_score@ and a +-- @_shards@ block; OpenSearch returns @metric_score@ and no +-- @_shards@. The 'FromJSON' instance tolerates both: it tries the ES +-- key first and falls back to the OS key, and treats a missing +-- @_shards@ as @ShardResult 0 0 0 0@ so callers that don't care +-- about shard counts can ignore the backend difference. Per-item +-- 'RankEvalHit' is similarly tolerant — ES sends @_index\/_id\/_score@ +-- at the top level of each hit, OS nests them under a @hit@ key, and +-- the parser accepts either. +data RankEvalResponse = RankEvalResponse + { rerResponseScore :: Double, + rerResponseShards :: ShardResult, + rerResponseDetails :: Map Text RankEvalDetail, + -- | Per-item errors keyed by 'reiId'. Empty on a fully successful + -- request. Each value is opaque (the server shape is + -- version-specific); decode it downstream if needed. + rerResponseFailures :: Map Text Value + } + deriving stock (Eq, Show) + +instance FromJSON RankEvalResponse where + parseJSON = withObject "RankEvalResponse" $ \o -> do + -- ES calls the top-level score @rank_eval_score@; OpenSearch + -- calls it @metric_score@. Try both before failing. OS may + -- also encode the score as the JSON string @"NaN"@ when the + -- metric cannot be computed (e.g. when the only rated request + -- failed); the @parseScore@ fallback below accepts the literal + -- and surfaces Haskell's @NaN@ so the caller can inspect + -- 'rerResponseFailures' for the cause. (The ES branch + -- type-inferences as @Maybe Double@ from @.:?@, so the + -- @"NaN"@-tolerance only kicks in on the OS fallback — which + -- is the only backend observed to emit it.) + let parseScore v = + case v of + Number n -> pure (realToFrac n) + String "NaN" -> pure (0 / 0) + other -> typeMismatch "score (Number or \"NaN\")" other + score <- + (o .:? "rank_eval_score") + >>= maybe (o .: "metric_score" >>= parseScore) pure + -- ES returns a @_shards@ block; OpenSearch does not. Default to + -- an empty 'ShardResult' when absent so callers that don't need + -- shard counts can ignore the backend difference. + shards <- o .:? "_shards" .!= emptyShardResult + RankEvalResponse score shards + <$> o + .:? "details" + .!= M.empty + <*> o + .:? "failures" + .!= M.empty + where + emptyShardResult = ShardResult 0 0 0 0 + +rerResponseScoreLens :: Lens' RankEvalResponse Double +rerResponseScoreLens = lens rerResponseScore (\x y -> x {rerResponseScore = y}) + +rerResponseShardsLens :: Lens' RankEvalResponse ShardResult +rerResponseShardsLens = + lens rerResponseShards (\x y -> x {rerResponseShards = y}) + +rerResponseDetailsLens :: Lens' RankEvalResponse (Map Text RankEvalDetail) +rerResponseDetailsLens = + lens rerResponseDetails (\x y -> x {rerResponseDetails = y}) + +rerResponseFailuresLens :: Lens' RankEvalResponse (Map Text Value) +rerResponseFailuresLens = + lens rerResponseFailures (\x y -> x {rerResponseFailures = y}) + +-- | Per-item evaluation breakdown, keyed by 'reiId' in +-- 'rerResponseDetails'. +data RankEvalDetail = RankEvalDetail + { redMetricScore :: Double, + -- | Documents the search returned that have no rating. Useful + -- for finding candidates to label. + redUnratedDocs :: [UnratedDoc], + -- | The hits the search returned, each annotated with the + -- rating used for scoring (or 'Nothing' for an unrated doc). + redHits :: [RankEvalHit], + -- | Metric-specific breakdown (e.g. for precision: + -- @relevant_docs_retrieved@ and @docs_retrieved@). Returned + -- verbatim — the shape is metric-dependent. + redMetricDetails :: KeyMap Value + } + deriving stock (Eq, Show) + +instance FromJSON RankEvalDetail where + parseJSON = withObject "RankEvalDetail" $ \o -> + RankEvalDetail + <$> o + .: "metric_score" + <*> o + .:? "unrated_docs" + .!= [] + <*> o + .:? "hits" + .!= [] + <*> o + .:? "metric_details" + .!= mempty + +redMetricScoreLens :: Lens' RankEvalDetail Double +redMetricScoreLens = lens redMetricScore (\x y -> x {redMetricScore = y}) + +redUnratedDocsLens :: Lens' RankEvalDetail [UnratedDoc] +redUnratedDocsLens = lens redUnratedDocs (\x y -> x {redUnratedDocs = y}) + +redHitsLens :: Lens' RankEvalDetail [RankEvalHit] +redHitsLens = lens redHits (\x y -> x {redHits = y}) + +redMetricDetailsLens :: Lens' RankEvalDetail (KeyMap Value) +redMetricDetailsLens = lens redMetricDetails (\x y -> x {redMetricDetails = y}) + +-- | A single hit within a 'RankEvalDetail'. Carries the document +-- coordinates, the score the search assigned it, and the rating +-- applied during evaluation (or 'Nothing' for an unrated doc — +-- matches 'redUnratedDocs'). +data RankEvalHit = RankEvalHit + { rehIndex :: IndexName, + rehId :: DocId, + -- | Search-time score. Mirrors 'SearchResult' scoring semantics + -- — null\/0 does not imply a lack of match. + rehScore :: Maybe Double, + -- | Rating applied during evaluation. 'Nothing' when the hit was + -- not in the 'reiRatings' list (also surfaces in + -- 'redUnratedDocs'). + rehRating :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON RankEvalHit where + parseJSON = withObject "RankEvalHit" $ \o -> do + -- Elasticsearch flattens @_index\/_id\/_score@ to the top level + -- of each hit object. OpenSearch nests them under a @hit@ key. + -- Resolve the inner object once, then read fields off it. + inner <- maybe (pure o) (withObject "RankEvalHit.hit" pure) =<< o .:? "hit" + -- @rating@ always lives at the outer level on both backends. + rating <- o .:? "rating" + RankEvalHit + <$> inner + .: "_index" + <*> inner + .: "_id" + <*> inner + .:? "_score" + <*> pure rating + +rehIndexLens :: Lens' RankEvalHit IndexName +rehIndexLens = lens rehIndex (\x y -> x {rehIndex = y}) + +rehIdLens :: Lens' RankEvalHit DocId +rehIdLens = lens rehId (\x y -> x {rehId = y}) + +rehScoreLens :: Lens' RankEvalHit (Maybe Double) +rehScoreLens = lens rehScore (\x y -> x {rehScore = y}) + +rehRatingLens :: Lens' RankEvalHit (Maybe Int) +rehRatingLens = lens rehRating (\x y -> x {rehRating = y}) + +-- | URI parameters accepted by @_rank_eval@ and @/{index}\/_rank_eval@. +-- Each field maps 1:1 to a query-string parameter of the endpoint +-- (see the +-- +-- and the +-- ). +data RankEvalOptions = RankEvalOptions + { -- | Override the server-default 'SearchType'. The parameter is + -- omitted when set to 'SearchTypeQueryThenFetch' (the server + -- default), mirroring 'searchOptionsParams'. + reoSearchType :: SearchType, + reoAllowNoIndices :: Maybe Bool, + reoExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + reoIgnoreUnavailable :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'RankEvalOptions' with every parameter set to its +-- server-default. Produces no query string, so a call made with this +-- value is byte-identical to a parameterless call. +defaultRankEvalOptions :: RankEvalOptions +defaultRankEvalOptions = + RankEvalOptions + { reoSearchType = SearchTypeQueryThenFetch, + reoAllowNoIndices = Nothing, + reoExpandWildcards = Nothing, + reoIgnoreUnavailable = Nothing + } + +reoSearchTypeLens :: Lens' RankEvalOptions SearchType +reoSearchTypeLens = lens reoSearchType (\x y -> x {reoSearchType = y}) + +reoAllowNoIndicesLens :: Lens' RankEvalOptions (Maybe Bool) +reoAllowNoIndicesLens = lens reoAllowNoIndices (\x y -> x {reoAllowNoIndices = y}) + +reoExpandWildcardsLens :: Lens' RankEvalOptions (Maybe (NonEmpty ExpandWildcards)) +reoExpandWildcardsLens = + lens reoExpandWildcards (\x y -> x {reoExpandWildcards = y}) + +reoIgnoreUnavailableLens :: Lens' RankEvalOptions (Maybe Bool) +reoIgnoreUnavailableLens = + lens reoIgnoreUnavailable (\x y -> x {reoIgnoreUnavailable = y}) + +-- | Render 'RankEvalOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultRankEvalOptions' produces an empty list. The @search_type@ +-- parameter is only emitted when it differs from +-- 'SearchTypeQueryThenFetch' (the server default). Order of the +-- returned list is stable but /unspecified/ — callers should treat +-- it as a set; the underlying 'withQueries' is order-insensitive. +rankEvalOptionsParams :: RankEvalOptions -> [(Text, Maybe Text)] +rankEvalOptionsParams RankEvalOptions {..} = + stParam + <> catMaybes + [ boolParam "allow_no_indices" <$> reoAllowNoIndices, + ("expand_wildcards",) . Just . renderExpandWildcards <$> reoExpandWildcards, + boolParam "ignore_unavailable" <$> reoIgnoreUnavailable + ] + where + stParam + | reoSearchType == SearchTypeDfsQueryThenFetch = + [("search_type", Just "dfs_query_then_fetch")] + | otherwise = [] + boolParam k b = (k, Just (boolQP b)) + boolQP True = "true" + boolQP False = "false" + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Refresh.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Refresh.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Refresh.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | @refresh@ URI parameter shared by several document-mutating APIs +-- (Index, Update, Bulk, By-Query, Reindex, Delete-by-Query). +-- +-- Elasticsearch accepts three values: +-- +-- * @false@ — default; do not refresh the index after the operation. +-- * @true@ — refresh the primary shard (and replicas that can be reached) +-- immediately so the new document is visible to search. Comes with a +-- performance cost. +-- * @wait_for@ — force a refresh only if one is not already in progress, +-- otherwise wait for the next in-flight refresh to complete. Combines +-- low cost with eventually-consistent visibility. +-- +-- See +module Database.Bloodhound.Internal.Versions.Common.Types.Refresh + ( RefreshPolicy (..), + renderRefreshPolicy, + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withText) +import Data.Text (Text) +import GHC.Generics (Generic) + +data RefreshPolicy + = -- | Render as @\"false\"@ — the default. Equivalent to omitting the + -- parameter entirely. + RefreshFalse + | -- | Render as @\"true\"@ — refresh immediately. + RefreshTrue + | -- | Render as @\"wait_for\"@ — wait for the next natural refresh. + RefreshWaitFor + deriving stock (Eq, Show, Generic) + +instance ToJSON RefreshPolicy where + toJSON RefreshFalse = String "false" + toJSON RefreshTrue = String "true" + toJSON RefreshWaitFor = String "wait_for" + +instance FromJSON RefreshPolicy where + parseJSON = withText "RefreshPolicy" $ \case + "false" -> pure RefreshFalse + "true" -> pure RefreshTrue + "wait_for" -> pure RefreshWaitFor + s -> fail $ "Expected one of [false, true, wait_for], found: " <> show s + +-- | Render as the bare URI parameter value, e.g. @\"wait_for\"@. +renderRefreshPolicy :: RefreshPolicy -> Text +renderRefreshPolicy RefreshFalse = "false" +renderRefreshPolicy RefreshTrue = "true" +renderRefreshPolicy RefreshWaitFor = "wait_for" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Reindex.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Reindex.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Reindex.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Reindex.hs @@ -1,24 +1,154 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} -module Database.Bloodhound.Internal.Versions.Common.Types.Reindex where +module Database.Bloodhound.Internal.Versions.Common.Types.Reindex + ( -- * Request body + ReindexRequest (..), + mkReindexRequest, + -- * Request options (URI params) + ReindexOptions (..), + defaultReindexOptions, + reindexOptionsParams, + + -- * Request and response sub-types + ReindexConflicts (..), + ReindexSource (..), + ReindexSlice (..), + ReindexDest (..), + ReindexScript (..), + ReindexResponse (..), + ReindexRetries (..), + ReindexFailure (..), + ReindexFailureCause (..), + ReindexSliceStatus (..), + + -- * Rethrottle + RethrottleRate (..), + renderRethrottleRate, + + -- * Deprecated aliases + ReindexOpType, + + -- * Optics + reindexRequestConflictsLens, + reindexRequestSourceLens, + reindexRequestDestLens, + reindexRequestScriptLens, + reindexRequestMaxDocsLens, + reindexSourceIndexLens, + reindexSourceMaxDocsLens, + reindexSourceQueryLens, + reindexSourceSizeLens, + reindexSourceSliceLens, + reindexSliceIdLens, + reindexSliceMaxLens, + reindexDestIndexLens, + reindexDestVersionTypeLens, + reindexDestOpTypeLens, + reindexScriptLanguageLens, + reindexScriptSourceLens, + reindexResponseTookLens, + reindexResponseUpdatedLens, + reindexResponseCreatedLens, + reindexResponseBatchesLens, + reindexResponseVersionConflictsLens, + reindexResponseThrottledMillisLens, + reindexResponseTotalLens, + reindexResponseDeletedLens, + reindexResponseNoopsLens, + reindexResponseTimedOutLens, + reindexResponseRetriesLens, + reindexResponseThrottledUntilMillisLens, + reindexResponseRequestsPerSecondLens, + reindexResponseFailuresLens, + reindexResponseSlicesLens, + reindexResponseTaskLens, + reindexResponseSliceIdLens, + reindexRetriesBulkLens, + reindexRetriesSearchLens, + reindexFailureIndexLens, + reindexFailureIdLens, + reindexFailureStatusLens, + reindexFailureCauseLens, + reindexFailureCauseTypeLens, + reindexFailureCauseReasonLens, + reindexFailureCauseStackTraceLens, + reindexFailureCauseCausedByLens, + reindexFailureCauseRootCauseLens, + reindexFailureCauseSuppressedLens, + reindexSliceStatusSliceIdLens, + reindexSliceStatusBatchesLens, + reindexSliceStatusCreatedLens, + reindexSliceStatusDeletedLens, + reindexSliceStatusNoopsLens, + reindexSliceStatusRequestsPerSecondLens, + reindexSliceStatusRetriesLens, + reindexSliceStatusThrottledLens, + reindexSliceStatusThrottledMillisLens, + reindexSliceStatusThrottledUntilLens, + reindexSliceStatusThrottledUntilMillisLens, + reindexSliceStatusTotalLens, + reindexSliceStatusUpdatedLens, + reindexSliceStatusVersionConflictsLens, + reindexSliceStatusCancelledLens, + rioConflictsLens, + rioRefreshLens, + rioTimeoutLens, + rioScrollLens, + rioWaitForActiveShardsLens, + rioRequestsPerSecondLens, + rioSlicesLens, + rioPipelineLens, + rioRequireAliasLens, + rioMaxDocsLens, + ) +where + import Data.Aeson import Data.List.NonEmpty +import Data.Maybe (catMaybes) +import Data.Scientific (floatingOrInteger) import Data.Text (Text) -import Database.Bloodhound.Internal.Utils.Imports (omitNulls) +import Database.Bloodhound.Internal.Utils.Imports (Scientific, omitNulls, showText) +import Database.Bloodhound.Internal.Versions.Common.Types.Document + ( ConflictsPolicy (..), + Slices (..), + renderConflictsPolicy, + renderSlices, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Indices + ( ActiveShardCount, + renderActiveShardCount, + ) import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes (IndexName) +import Database.Bloodhound.Internal.Versions.Common.Types.OpType (OpType (..)) import Database.Bloodhound.Internal.Versions.Common.Types.Query (Query) +import Database.Bloodhound.Internal.Versions.Common.Types.Refresh + ( RefreshPolicy, + renderRefreshPolicy, + ) import Database.Bloodhound.Internal.Versions.Common.Types.Script (ScriptLanguage) +import Database.Bloodhound.Internal.Versions.Common.Types.VersionType + ( VersionType (..), + ) import GHC.Generics +import Numeric.Natural (Natural) import Optics.Lens data ReindexRequest = ReindexRequest { reindexConflicts :: Maybe ReindexConflicts, reindexSource :: ReindexSource, reindexDest :: ReindexDest, - reindexScript :: Maybe ReindexScript + reindexScript :: Maybe ReindexScript, + -- | Top-level @max_docs@ cap on the number of documents processed. + -- Available since ES 7.9; the older 'reindexSourceMaxDocs' form is + -- kept for backwards compatibility but new code should prefer this + -- field. See + -- . + reindexMaxDocs :: Maybe Natural } deriving stock (Eq, Show, Generic) @@ -28,7 +158,8 @@ [ "conflicts" .= reindexConflicts, "source" .= reindexSource, "dest" .= reindexDest, - "script" .= reindexScript + "script" .= reindexScript, + "max_docs" .= reindexMaxDocs ] instance FromJSON ReindexRequest where @@ -38,6 +169,7 @@ <*> v .: "source" <*> v .: "dest" <*> v .:? "script" + <*> v .:? "max_docs" reindexRequestConflictsLens :: Lens' ReindexRequest (Maybe ReindexConflicts) reindexRequestConflictsLens = lens reindexConflicts (\x y -> x {reindexConflicts = y}) @@ -51,6 +183,9 @@ reindexRequestScriptLens :: Lens' ReindexRequest (Maybe ReindexScript) reindexRequestScriptLens = lens reindexScript (\x y -> x {reindexScript = y}) +reindexRequestMaxDocsLens :: Lens' ReindexRequest (Maybe Natural) +reindexRequestMaxDocsLens = lens reindexMaxDocs (\x y -> x {reindexMaxDocs = y}) + data ReindexConflicts = ReindexAbortOnConflicts | ReindexProceedOnConflicts @@ -135,7 +270,7 @@ data ReindexDest = ReindexDest { reindexDestIndex :: IndexName, reindexDestVersionType :: Maybe VersionType, - reindexDestOpType :: Maybe ReindexOpType + reindexDestOpType :: Maybe OpType } deriving stock (Eq, Show, Generic) @@ -160,46 +295,16 @@ reindexDestVersionTypeLens :: Lens' ReindexDest (Maybe VersionType) reindexDestVersionTypeLens = lens reindexDestVersionType (\x y -> x {reindexDestVersionType = y}) -reindexDestOpTypeLens :: Lens' ReindexDest (Maybe ReindexOpType) +reindexDestOpTypeLens :: Lens' ReindexDest (Maybe OpType) reindexDestOpTypeLens = lens reindexDestOpType (\x y -> x {reindexDestOpType = y}) -data VersionType - = VersionTypeInternal - | VersionTypeExternal - | VersionTypeExternalGT - | VersionTypeExternalGTE - deriving stock (Eq, Show, Generic) - -instance ToJSON VersionType where - toJSON = - String . \case - VersionTypeInternal -> "internal" - VersionTypeExternal -> "external" - VersionTypeExternalGT -> "external_gt" - VersionTypeExternalGTE -> "external_gte" - -instance FromJSON VersionType where - parseJSON = withText "VersionType" $ \case - "internal" -> pure VersionTypeInternal - "external" -> pure VersionTypeExternal - "external_gt" -> pure VersionTypeExternalGT - "external_gte" -> pure VersionTypeExternalGTE - s -> fail $ "Expected one of [internal, external, external_gt, external_gte], found: " <> show s - -data ReindexOpType - = OpCreate - | OpIndex - deriving stock (Eq, Show, Generic) - -instance FromJSON ReindexOpType where - parseJSON = withText "ReindexOpType" $ \case - "create" -> pure OpCreate - "index" -> pure OpIndex - s -> fail $ "Expected one of [create, index], found: " <> show s +-- | Deprecated backwards-compatibility alias for the now-shared 'OpType'. +-- Kept until the next major version so that existing imports +-- (@Database.Bloodhound.Common.Types.Reindex.ReindexOpType@) keep +-- compiling. New code should use 'OpType' directly. +{-# DEPRECATED ReindexOpType "Use Database.Bloodhound.Common.Types.OpType instead." #-} -instance ToJSON ReindexOpType where - toJSON OpCreate = String "create" - toJSON OpIndex = String "index" +type ReindexOpType = OpType data ReindexScript = ReindexScript { reindexScriptLanguage :: ScriptLanguage, @@ -244,16 +349,48 @@ reindexDestOpType = Nothing }, reindexConflicts = Nothing, - reindexScript = Nothing + reindexScript = Nothing, + reindexMaxDocs = Nothing } data ReindexResponse = ReindexResponse - { reindexResponseTook :: Maybe Int, - reindexResponseUpdated :: Int, - reindexResponseCreated :: Int, - reindexResponseBatches :: Int, - reindexResponseVersionConflicts :: Int, - reindexResponseThrottledMillis :: Int + { -- | Total elapsed milliseconds. The ES docs mark no top-level + -- response field as Required, so every field is decoded with + -- '.:?' and exposed as 'Maybe'; callers that previously read + -- these as 'Int' must now handle 'Maybe Int'. + reindexResponseTook :: Maybe Int, + reindexResponseUpdated :: Maybe Int, + reindexResponseCreated :: Maybe Int, + reindexResponseBatches :: Maybe Int, + reindexResponseVersionConflicts :: Maybe Int, + reindexResponseThrottledMillis :: Maybe Int, + -- | The fields below were silently discarded by the previous + -- decoder. They are documented on the reindex response body + -- (); + -- see + -- for the canonical field list. + reindexResponseTotal :: Maybe Int, + reindexResponseDeleted :: Maybe Int, + reindexResponseNoops :: Maybe Int, + reindexResponseTimedOut :: Maybe Bool, + reindexResponseRetries :: Maybe ReindexRetries, + reindexResponseThrottledUntilMillis :: Maybe Int, + -- | The remaining fields below complete the documented response + -- surface. @requests_per_second@ is 'Scientific' because the docs + -- describe it as a (potentially fractional) number, distinct from + -- the request-side 'rioRequestsPerSecond' which is 'Natural'. + -- @failures@ carries unrecoverable errors collected in the final + -- batch (the reindex halts after the batch in which a failure + -- occurs); @slices@ mirrors the top-level fields per slice when + -- the reindex ran with @slices>1@; @task@ and @slice_id@ are + -- present when this response is itself the body of a task or a + -- slice-status entry. See + -- . + reindexResponseRequestsPerSecond :: Maybe Scientific, + reindexResponseFailures :: Maybe [ReindexFailure], + reindexResponseSlices :: Maybe [ReindexSliceStatus], + reindexResponseTask :: Maybe Text, + reindexResponseSliceId :: Maybe Int } deriving stock (Eq, Show, Generic) @@ -265,33 +402,493 @@ "created" .= reindexResponseCreated, "batches" .= reindexResponseBatches, "version_conflicts" .= reindexResponseVersionConflicts, - "throttled_millis" .= reindexResponseThrottledMillis + "throttled_millis" .= reindexResponseThrottledMillis, + "total" .= reindexResponseTotal, + "deleted" .= reindexResponseDeleted, + "noops" .= reindexResponseNoops, + "timed_out" .= reindexResponseTimedOut, + "retries" .= reindexResponseRetries, + "throttled_until_millis" .= reindexResponseThrottledUntilMillis, + "requests_per_second" .= reindexResponseRequestsPerSecond, + "failures" .= reindexResponseFailures, + "slices" .= reindexResponseSlices, + "task" .= reindexResponseTask, + "slice_id" .= reindexResponseSliceId ] instance FromJSON ReindexResponse where parseJSON = withObject "ReindexResponse" $ \v -> ReindexResponse <$> v .:? "took" - <*> v .: "updated" - <*> v .: "created" - <*> v .: "batches" - <*> v .: "version_conflicts" - <*> v .: "throttled_millis" + <*> v .:? "updated" + <*> v .:? "created" + <*> v .:? "batches" + <*> v .:? "version_conflicts" + <*> v .:? "throttled_millis" + <*> v .:? "total" + <*> v .:? "deleted" + <*> v .:? "noops" + <*> v .:? "timed_out" + <*> v .:? "retries" + <*> v .:? "throttled_until_millis" + <*> v .:? "requests_per_second" + <*> v .:? "failures" + <*> v .:? "slices" + <*> v .:? "task" + <*> v .:? "slice_id" reindexResponseTookLens :: Lens' ReindexResponse (Maybe Int) reindexResponseTookLens = lens reindexResponseTook (\x y -> x {reindexResponseTook = y}) -reindexResponseUpdatedLens :: Lens' ReindexResponse Int +reindexResponseUpdatedLens :: Lens' ReindexResponse (Maybe Int) reindexResponseUpdatedLens = lens reindexResponseUpdated (\x y -> x {reindexResponseUpdated = y}) -reindexResponseCreatedLens :: Lens' ReindexResponse Int +reindexResponseCreatedLens :: Lens' ReindexResponse (Maybe Int) reindexResponseCreatedLens = lens reindexResponseCreated (\x y -> x {reindexResponseCreated = y}) -reindexResponseBatchesLens :: Lens' ReindexResponse Int +reindexResponseBatchesLens :: Lens' ReindexResponse (Maybe Int) reindexResponseBatchesLens = lens reindexResponseBatches (\x y -> x {reindexResponseBatches = y}) -reindexResponseVersionConflictsLens :: Lens' ReindexResponse Int +reindexResponseVersionConflictsLens :: Lens' ReindexResponse (Maybe Int) reindexResponseVersionConflictsLens = lens reindexResponseVersionConflicts (\x y -> x {reindexResponseVersionConflicts = y}) -reindexResponseThrottledMillisLens :: Lens' ReindexResponse Int +reindexResponseThrottledMillisLens :: Lens' ReindexResponse (Maybe Int) reindexResponseThrottledMillisLens = lens reindexResponseThrottledMillis (\x y -> x {reindexResponseThrottledMillis = y}) + +reindexResponseTotalLens :: Lens' ReindexResponse (Maybe Int) +reindexResponseTotalLens = lens reindexResponseTotal (\x y -> x {reindexResponseTotal = y}) + +reindexResponseDeletedLens :: Lens' ReindexResponse (Maybe Int) +reindexResponseDeletedLens = lens reindexResponseDeleted (\x y -> x {reindexResponseDeleted = y}) + +reindexResponseNoopsLens :: Lens' ReindexResponse (Maybe Int) +reindexResponseNoopsLens = lens reindexResponseNoops (\x y -> x {reindexResponseNoops = y}) + +reindexResponseTimedOutLens :: Lens' ReindexResponse (Maybe Bool) +reindexResponseTimedOutLens = lens reindexResponseTimedOut (\x y -> x {reindexResponseTimedOut = y}) + +reindexResponseRetriesLens :: Lens' ReindexResponse (Maybe ReindexRetries) +reindexResponseRetriesLens = lens reindexResponseRetries (\x y -> x {reindexResponseRetries = y}) + +reindexResponseThrottledUntilMillisLens :: Lens' ReindexResponse (Maybe Int) +reindexResponseThrottledUntilMillisLens = lens reindexResponseThrottledUntilMillis (\x y -> x {reindexResponseThrottledUntilMillis = y}) + +reindexResponseRequestsPerSecondLens :: Lens' ReindexResponse (Maybe Scientific) +reindexResponseRequestsPerSecondLens = lens reindexResponseRequestsPerSecond (\x y -> x {reindexResponseRequestsPerSecond = y}) + +reindexResponseFailuresLens :: Lens' ReindexResponse (Maybe [ReindexFailure]) +reindexResponseFailuresLens = lens reindexResponseFailures (\x y -> x {reindexResponseFailures = y}) + +reindexResponseSlicesLens :: Lens' ReindexResponse (Maybe [ReindexSliceStatus]) +reindexResponseSlicesLens = lens reindexResponseSlices (\x y -> x {reindexResponseSlices = y}) + +reindexResponseTaskLens :: Lens' ReindexResponse (Maybe Text) +reindexResponseTaskLens = lens reindexResponseTask (\x y -> x {reindexResponseTask = y}) + +reindexResponseSliceIdLens :: Lens' ReindexResponse (Maybe Int) +reindexResponseSliceIdLens = lens reindexResponseSliceId (\x y -> x {reindexResponseSliceId = y}) + +-- | Nested @retries@ object returned in a 'ReindexResponse' (and per +-- slice in 'ReindexSliceStatus'). Both fields are documented as +-- Required inside the object, but are decoded leniently so partial +-- payloads from any backend still round-trip. See +-- . +data ReindexRetries = ReindexRetries + { reindexRetriesBulk :: Maybe Int, + reindexRetriesSearch :: Maybe Int + } + deriving stock (Eq, Show, Generic) + +instance ToJSON ReindexRetries where + toJSON ReindexRetries {..} = + omitNulls + [ "bulk" .= reindexRetriesBulk, + "search" .= reindexRetriesSearch + ] + +instance FromJSON ReindexRetries where + parseJSON = withObject "ReindexRetries" $ \v -> + ReindexRetries + <$> v .:? "bulk" + <*> v .:? "search" + +reindexRetriesBulkLens :: Lens' ReindexRetries (Maybe Int) +reindexRetriesBulkLens = lens reindexRetriesBulk (\x y -> x {reindexRetriesBulk = y}) + +reindexRetriesSearchLens :: Lens' ReindexRetries (Maybe Int) +reindexRetriesSearchLens = lens reindexRetriesSearch (\x y -> x {reindexRetriesSearch = y}) + +-- | One entry of the @failures@ array on a 'ReindexResponse'. Reindex +-- is batched; any failure ends the run, but all failures observed in +-- the final batch are collected here. The @cause@ sub-object reuses +-- the recursive 'ReindexFailureCause' type. See +-- . +data ReindexFailure = ReindexFailure + { reindexFailureIndex :: Maybe Text, + reindexFailureId :: Maybe Text, + reindexFailureStatus :: Maybe Int, + reindexFailureCause :: Maybe ReindexFailureCause + } + deriving stock (Eq, Show, Generic) + +instance ToJSON ReindexFailure where + toJSON ReindexFailure {..} = + omitNulls + [ "index" .= reindexFailureIndex, + "id" .= reindexFailureId, + "status" .= reindexFailureStatus, + "cause" .= reindexFailureCause + ] + +instance FromJSON ReindexFailure where + parseJSON = withObject "ReindexFailure" $ \v -> + ReindexFailure + <$> v .:? "index" + <*> v .:? "id" + <*> v .:? "status" + <*> v .:? "cause" + +reindexFailureIndexLens :: Lens' ReindexFailure (Maybe Text) +reindexFailureIndexLens = lens reindexFailureIndex (\x y -> x {reindexFailureIndex = y}) + +reindexFailureIdLens :: Lens' ReindexFailure (Maybe Text) +reindexFailureIdLens = lens reindexFailureId (\x y -> x {reindexFailureId = y}) + +reindexFailureStatusLens :: Lens' ReindexFailure (Maybe Int) +reindexFailureStatusLens = lens reindexFailureStatus (\x y -> x {reindexFailureStatus = y}) + +reindexFailureCauseLens :: Lens' ReindexFailure (Maybe ReindexFailureCause) +reindexFailureCauseLens = lens reindexFailureCause (\x y -> x {reindexFailureCause = y}) + +-- | Error-cause object carried by each 'ReindexFailure'. The ES docs +-- document @type@ and @reason@ as the always-present keys and +-- @stack_trace@ / @caused_by@ / @root_cause@ / @suppressed@ as optional. +-- The type is regular-through-'Maybe' recursive: @caused_by@ is a +-- single nested 'ReindexFailureCause', @root_cause@ and @suppressed@ +-- are lists. All fields are 'Maybe' so partial payloads from any +-- backend round-trip. See +-- . +data ReindexFailureCause = ReindexFailureCause + { reindexFailureCauseType :: Maybe Text, + reindexFailureCauseReason :: Maybe Text, + reindexFailureCauseStackTrace :: Maybe Text, + reindexFailureCauseCausedBy :: Maybe ReindexFailureCause, + reindexFailureCauseRootCause :: Maybe [ReindexFailureCause], + reindexFailureCauseSuppressed :: Maybe [ReindexFailureCause] + } + deriving stock (Eq, Show, Generic) + +instance ToJSON ReindexFailureCause where + toJSON ReindexFailureCause {..} = + omitNulls + [ "type" .= reindexFailureCauseType, + "reason" .= reindexFailureCauseReason, + "stack_trace" .= reindexFailureCauseStackTrace, + "caused_by" .= reindexFailureCauseCausedBy, + "root_cause" .= reindexFailureCauseRootCause, + "suppressed" .= reindexFailureCauseSuppressed + ] + +instance FromJSON ReindexFailureCause where + parseJSON = withObject "ReindexFailureCause" $ \v -> + ReindexFailureCause + <$> v .:? "type" + <*> v .:? "reason" + <*> v .:? "stack_trace" + <*> v .:? "caused_by" + <*> v .:? "root_cause" + <*> v .:? "suppressed" + +reindexFailureCauseTypeLens :: Lens' ReindexFailureCause (Maybe Text) +reindexFailureCauseTypeLens = lens reindexFailureCauseType (\x y -> x {reindexFailureCauseType = y}) + +reindexFailureCauseReasonLens :: Lens' ReindexFailureCause (Maybe Text) +reindexFailureCauseReasonLens = lens reindexFailureCauseReason (\x y -> x {reindexFailureCauseReason = y}) + +reindexFailureCauseStackTraceLens :: Lens' ReindexFailureCause (Maybe Text) +reindexFailureCauseStackTraceLens = lens reindexFailureCauseStackTrace (\x y -> x {reindexFailureCauseStackTrace = y}) + +reindexFailureCauseCausedByLens :: Lens' ReindexFailureCause (Maybe ReindexFailureCause) +reindexFailureCauseCausedByLens = lens reindexFailureCauseCausedBy (\x y -> x {reindexFailureCauseCausedBy = y}) + +reindexFailureCauseRootCauseLens :: Lens' ReindexFailureCause (Maybe [ReindexFailureCause]) +reindexFailureCauseRootCauseLens = lens reindexFailureCauseRootCause (\x y -> x {reindexFailureCauseRootCause = y}) + +reindexFailureCauseSuppressedLens :: Lens' ReindexFailureCause (Maybe [ReindexFailureCause]) +reindexFailureCauseSuppressedLens = lens reindexFailureCauseSuppressed (\x y -> x {reindexFailureCauseSuppressed = y}) + +-- | One entry of the @slices@ array on a 'ReindexResponse' (present +-- when the reindex ran with @slices>1@). Named 'ReindexSliceStatus' +-- to avoid clashing with the request-side 'ReindexSlice'. Carries the +-- fifteen documented per-slice fields: the scalar counts plus the +-- bare-string @throttled@ / @throttled_until@ duration variants +-- alongside their @_millis@ counterparts, a nested 'ReindexRetries' +-- object, and a @cancelled@ reason. See +-- . +data ReindexSliceStatus = ReindexSliceStatus + { reindexSliceStatusSliceId :: Maybe Int, + reindexSliceStatusBatches :: Maybe Int, + reindexSliceStatusCreated :: Maybe Int, + reindexSliceStatusDeleted :: Maybe Int, + reindexSliceStatusNoops :: Maybe Int, + reindexSliceStatusRequestsPerSecond :: Maybe Scientific, + reindexSliceStatusRetries :: Maybe ReindexRetries, + reindexSliceStatusThrottled :: Maybe Text, + reindexSliceStatusThrottledMillis :: Maybe Int, + reindexSliceStatusThrottledUntil :: Maybe Text, + reindexSliceStatusThrottledUntilMillis :: Maybe Int, + reindexSliceStatusTotal :: Maybe Int, + reindexSliceStatusUpdated :: Maybe Int, + reindexSliceStatusVersionConflicts :: Maybe Int, + reindexSliceStatusCancelled :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance ToJSON ReindexSliceStatus where + toJSON ReindexSliceStatus {..} = + omitNulls + [ "slice_id" .= reindexSliceStatusSliceId, + "batches" .= reindexSliceStatusBatches, + "created" .= reindexSliceStatusCreated, + "deleted" .= reindexSliceStatusDeleted, + "noops" .= reindexSliceStatusNoops, + "requests_per_second" .= reindexSliceStatusRequestsPerSecond, + "retries" .= reindexSliceStatusRetries, + "throttled" .= reindexSliceStatusThrottled, + "throttled_millis" .= reindexSliceStatusThrottledMillis, + "throttled_until" .= reindexSliceStatusThrottledUntil, + "throttled_until_millis" .= reindexSliceStatusThrottledUntilMillis, + "total" .= reindexSliceStatusTotal, + "updated" .= reindexSliceStatusUpdated, + "version_conflicts" .= reindexSliceStatusVersionConflicts, + "cancelled" .= reindexSliceStatusCancelled + ] + +instance FromJSON ReindexSliceStatus where + parseJSON = withObject "ReindexSliceStatus" $ \v -> + ReindexSliceStatus + <$> v .:? "slice_id" + <*> v .:? "batches" + <*> v .:? "created" + <*> v .:? "deleted" + <*> v .:? "noops" + <*> v .:? "requests_per_second" + <*> v .:? "retries" + <*> v .:? "throttled" + <*> v .:? "throttled_millis" + <*> v .:? "throttled_until" + <*> v .:? "throttled_until_millis" + <*> v .:? "total" + <*> v .:? "updated" + <*> v .:? "version_conflicts" + <*> v .:? "cancelled" + +reindexSliceStatusSliceIdLens :: Lens' ReindexSliceStatus (Maybe Int) +reindexSliceStatusSliceIdLens = lens reindexSliceStatusSliceId (\x y -> x {reindexSliceStatusSliceId = y}) + +reindexSliceStatusBatchesLens :: Lens' ReindexSliceStatus (Maybe Int) +reindexSliceStatusBatchesLens = lens reindexSliceStatusBatches (\x y -> x {reindexSliceStatusBatches = y}) + +reindexSliceStatusCreatedLens :: Lens' ReindexSliceStatus (Maybe Int) +reindexSliceStatusCreatedLens = lens reindexSliceStatusCreated (\x y -> x {reindexSliceStatusCreated = y}) + +reindexSliceStatusDeletedLens :: Lens' ReindexSliceStatus (Maybe Int) +reindexSliceStatusDeletedLens = lens reindexSliceStatusDeleted (\x y -> x {reindexSliceStatusDeleted = y}) + +reindexSliceStatusNoopsLens :: Lens' ReindexSliceStatus (Maybe Int) +reindexSliceStatusNoopsLens = lens reindexSliceStatusNoops (\x y -> x {reindexSliceStatusNoops = y}) + +reindexSliceStatusRequestsPerSecondLens :: Lens' ReindexSliceStatus (Maybe Scientific) +reindexSliceStatusRequestsPerSecondLens = lens reindexSliceStatusRequestsPerSecond (\x y -> x {reindexSliceStatusRequestsPerSecond = y}) + +reindexSliceStatusRetriesLens :: Lens' ReindexSliceStatus (Maybe ReindexRetries) +reindexSliceStatusRetriesLens = lens reindexSliceStatusRetries (\x y -> x {reindexSliceStatusRetries = y}) + +reindexSliceStatusThrottledLens :: Lens' ReindexSliceStatus (Maybe Text) +reindexSliceStatusThrottledLens = lens reindexSliceStatusThrottled (\x y -> x {reindexSliceStatusThrottled = y}) + +reindexSliceStatusThrottledMillisLens :: Lens' ReindexSliceStatus (Maybe Int) +reindexSliceStatusThrottledMillisLens = lens reindexSliceStatusThrottledMillis (\x y -> x {reindexSliceStatusThrottledMillis = y}) + +reindexSliceStatusThrottledUntilLens :: Lens' ReindexSliceStatus (Maybe Text) +reindexSliceStatusThrottledUntilLens = lens reindexSliceStatusThrottledUntil (\x y -> x {reindexSliceStatusThrottledUntil = y}) + +reindexSliceStatusThrottledUntilMillisLens :: Lens' ReindexSliceStatus (Maybe Int) +reindexSliceStatusThrottledUntilMillisLens = lens reindexSliceStatusThrottledUntilMillis (\x y -> x {reindexSliceStatusThrottledUntilMillis = y}) + +reindexSliceStatusTotalLens :: Lens' ReindexSliceStatus (Maybe Int) +reindexSliceStatusTotalLens = lens reindexSliceStatusTotal (\x y -> x {reindexSliceStatusTotal = y}) + +reindexSliceStatusUpdatedLens :: Lens' ReindexSliceStatus (Maybe Int) +reindexSliceStatusUpdatedLens = lens reindexSliceStatusUpdated (\x y -> x {reindexSliceStatusUpdated = y}) + +reindexSliceStatusVersionConflictsLens :: Lens' ReindexSliceStatus (Maybe Int) +reindexSliceStatusVersionConflictsLens = lens reindexSliceStatusVersionConflicts (\x y -> x {reindexSliceStatusVersionConflicts = y}) + +reindexSliceStatusCancelledLens :: Lens' ReindexSliceStatus (Maybe Text) +reindexSliceStatusCancelledLens = lens reindexSliceStatusCancelled (\x y -> x {reindexSliceStatusCancelled = y}) + +-- | URI query parameters accepted by @POST /_reindex@. Mirrors the +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Document.ByQueryOptions' +-- pattern: every field is 'Maybe', the @default…@ value leaves every +-- field @Nothing@ so the legacy parameterless entry points +-- ('Database.Bloodhound.Common.Requests.reindex' and +-- 'Database.Bloodhound.Common.Requests.reindexAsync') remain +-- byte-for-byte identical on the wire, and the renderer drops @Nothing@ +-- fields via 'Data.Maybe.catMaybes'. See +-- . +-- +-- @wait_for_completion@ is deliberately omitted: the synchronous +-- 'Database.Bloodhound.Common.Requests.reindexWith' returns a +-- 'ReindexResponse', while the asynchronous +-- 'Database.Bloodhound.Common.Requests.reindexAsyncWith' forces +-- @wait_for_completion=false@ and returns a 'TaskNodeId' instead. +data ReindexOptions = ReindexOptions + { -- | @conflicts@ — what to do on version conflict. The body-level + -- 'reindexConflicts' sets the same internal flag; ES does not + -- document a precedence when both are sent, so callers should use + -- one or the other. The URI form is the one documented on the + -- reindex API reference page. + rioConflicts :: Maybe ConflictsPolicy, + -- | @refresh@ — refresh all shards involved after the reindex + -- completes. + rioRefresh :: Maybe RefreshPolicy, + -- | @timeout@ — per-request wall-clock timeout, e.g. @"5s"@. + rioTimeout :: Maybe Text, + -- | @scroll@ — how long to keep the search context alive when + -- paging through the reindex, e.g. @"1m"@. + rioScroll :: Maybe Text, + -- | @wait_for_active_shards@ — number of active shard copies required + -- before the reindex starts. + rioWaitForActiveShards :: Maybe ActiveShardCount, + -- | @requests_per_second@ — throttle, in sub-requests per second. + -- @Just 0@ disables throttling. The JSON encoding is intentionally + -- 'ToJSON' so callers can pass any integer (ES accepts floats, but + -- whole numbers cover the common case). + rioRequestsPerSecond :: Maybe Natural, + -- | @slices@ — parallelism. + rioSlices :: Maybe Slices, + -- | @pipeline@ — ingest pipeline to apply to each destination document. + rioPipeline :: Maybe Text, + -- | @require_alias@ — when @Just True@ require the destination to be + -- an alias. + rioRequireAlias :: Maybe Bool, + -- | @max_docs@ URI parameter. Distinct from the body-level + -- 'reindexMaxDocs' / 'reindexSourceMaxDocs'; ES accepts any of the + -- three, but the URI form is the one exposed on the docs page. + rioMaxDocs :: Maybe Natural + } + deriving stock (Eq, Show) + +-- | 'ReindexOptions' with every field @Nothing@. Emits an empty query +-- string, preserving the wire behaviour of the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.reindex' and +-- 'Database.Bloodhound.Common.Requests.reindexAsync'. +-- +-- Note on @wait_for_completion@: unlike +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Document.ByQueryOptions', +-- 'ReindexOptions' deliberately does /not/ expose @wait_for_completion@. +-- The synchronous entry point returns a 'ReindexResponse' while the +-- asynchronous one returns a 'TaskNodeId'; the two response shapes are +-- incompatible, so they get separate entry points +-- ('Database.Bloodhound.Common.Requests.reindexWith' vs +-- 'Database.Bloodhound.Common.Requests.reindexAsyncWith') rather than +-- a single polymorphic function. This is an intentional divergence +-- from the @updateByQuery@ pattern. +defaultReindexOptions :: ReindexOptions +defaultReindexOptions = + ReindexOptions + { rioConflicts = Nothing, + rioRefresh = Nothing, + rioTimeout = Nothing, + rioScroll = Nothing, + rioWaitForActiveShards = Nothing, + rioRequestsPerSecond = Nothing, + rioSlices = Nothing, + rioPipeline = Nothing, + rioRequireAlias = Nothing, + rioMaxDocs = Nothing + } + +-- | Render a 'ReindexOptions' record as a @key=value@ list for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. @Nothing@ +-- fields are omitted. +reindexOptionsParams :: ReindexOptions -> [(Text, Maybe Text)] +reindexOptionsParams ReindexOptions {..} = + catMaybes + [ ("conflicts",) . Just . renderConflictsPolicy <$> rioConflicts, + ("refresh",) . Just . renderRefreshPolicy <$> rioRefresh, + ("timeout",) . Just <$> rioTimeout, + ("scroll",) . Just <$> rioScroll, + ("wait_for_active_shards",) . Just . renderActiveShardCount <$> rioWaitForActiveShards, + ("requests_per_second",) . Just . showText <$> rioRequestsPerSecond, + ("slices",) . Just . renderSlices <$> rioSlices, + ("pipeline",) . Just <$> rioPipeline, + ("require_alias",) . Just . boolText <$> rioRequireAlias, + ("max_docs",) . Just . showText <$> rioMaxDocs + ] + where + boolText :: Bool -> Text + boolText True = "true" + boolText False = "false" + +rioConflictsLens :: Lens' ReindexOptions (Maybe ConflictsPolicy) +rioConflictsLens = lens rioConflicts (\x y -> x {rioConflicts = y}) + +rioRefreshLens :: Lens' ReindexOptions (Maybe RefreshPolicy) +rioRefreshLens = lens rioRefresh (\x y -> x {rioRefresh = y}) + +rioTimeoutLens :: Lens' ReindexOptions (Maybe Text) +rioTimeoutLens = lens rioTimeout (\x y -> x {rioTimeout = y}) + +rioScrollLens :: Lens' ReindexOptions (Maybe Text) +rioScrollLens = lens rioScroll (\x y -> x {rioScroll = y}) + +rioWaitForActiveShardsLens :: Lens' ReindexOptions (Maybe ActiveShardCount) +rioWaitForActiveShardsLens = lens rioWaitForActiveShards (\x y -> x {rioWaitForActiveShards = y}) + +rioRequestsPerSecondLens :: Lens' ReindexOptions (Maybe Natural) +rioRequestsPerSecondLens = lens rioRequestsPerSecond (\x y -> x {rioRequestsPerSecond = y}) + +rioSlicesLens :: Lens' ReindexOptions (Maybe Slices) +rioSlicesLens = lens rioSlices (\x y -> x {rioSlices = y}) + +rioPipelineLens :: Lens' ReindexOptions (Maybe Text) +rioPipelineLens = lens rioPipeline (\x y -> x {rioPipeline = y}) + +rioRequireAliasLens :: Lens' ReindexOptions (Maybe Bool) +rioRequireAliasLens = lens rioRequireAlias (\x y -> x {rioRequireAlias = y}) + +rioMaxDocsLens :: Lens' ReindexOptions (Maybe Natural) +rioMaxDocsLens = lens rioMaxDocs (\x y -> x {rioMaxDocs = y}) + +-- | Throttle rate for @POST /_reindex/{task_id}/_rethrottle@. ES accepts +-- either @-1@ (disable throttling entirely) or any non-negative decimal +-- such as @1.7@ or @12@. 'RethrottleUnlimited' makes the @-1@ case +-- explicit at the type level rather than relying on a sentinel; callers +-- who want a numeric rate should use 'RethrottlePerSecond' with a +-- non-negative 'Scientific'. Passing a negative value to +-- 'RethrottlePerSecond' is not validated — it will render as @-N@ on the +-- wire and ES will treat it as unlimited. +-- +-- See +-- . +data RethrottleRate + = -- | @requests_per_second=-1@ — disable throttling. + RethrottleUnlimited + | -- | @requests_per_second=@ — throttle to @n@ documents per + -- second, where @n@ is any non-negative decimal. + RethrottlePerSecond Scientific + deriving stock (Eq, Show) + +-- | Render a 'RethrottleRate' as the value of the @requests_per_second@ +-- URI parameter. Integer-valued rates are printed without a trailing +-- @.0@ (so @12@ renders as @\"12\"@, not @\"12.0\"@), matching the +-- examples in the ES docs; genuinely fractional rates keep their +-- fractional form. +renderRethrottleRate :: RethrottleRate -> Text +renderRethrottleRate RethrottleUnlimited = "-1" +renderRethrottleRate (RethrottlePerSecond n) = + case floatingOrInteger n :: Either Double Integer of + Right i -> showText i + Left d -> showText d diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/ReloadSearchAnalyzers.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/ReloadSearchAnalyzers.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/ReloadSearchAnalyzers.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.ReloadSearchAnalyzers +-- License : BSD-style (see the file LICENSE) +-- +-- Types for the @POST \/{target}/_reload_search_analyzers@ endpoint, +-- shared verbatim by Elasticsearch (7.x\/8.x\/9.x) and OpenSearch +-- (1.x\/2.x\/3.x). See +-- +-- * +-- * +module Database.Bloodhound.Internal.Versions.Common.Types.ReloadSearchAnalyzers + ( -- * Response types + ReloadSearchAnalyzersResponse (..), + ReloadDetail (..), + + -- * URI parameters + ReloadSearchAnalyzersOptions (..), + defaultReloadSearchAnalyzersOptions, + reloadSearchAnalyzersOptionsParams, + + -- * Optics + rsarShardsLens, + rsarReloadDetailsLens, + rdIndexLens, + rdReloadedAnalyzersLens, + rdReloadedNodeIdsLens, + rsaoAllowNoIndicesLens, + rsaoExpandWildcardsLens, + rsaoIgnoreUnavailableLens, + ) +where + +import Data.Aeson +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens) +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( IndexName, + unIndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes + ( ShardResult, + ) + +-- | Top-level response of @POST \/{target}/_reload_search_analyzers@. +-- The @_shards@ object summarises the per-node reload broadcast (its +-- @total@ may exceed the index shard count, since the reload runs once +-- per node hosting a shard). The @reload_details@ array carries one +-- entry per concrete index whose analyzers were actually reloaded. +data ReloadSearchAnalyzersResponse = ReloadSearchAnalyzersResponse + { -- | Per-node reload broadcast summary. Reuses the canonical + -- 'ShardResult' / @_shards@ envelope type shared with 'flushIndex' + -- and friends. + rsarShards :: ShardResult, + -- | One entry per index whose search analyzers were reloaded. + -- Parsed leniently as the empty list when the server omits the + -- key (e.g. when no analyzer was eligible for reload). + rsarReloadDetails :: [ReloadDetail] + } + deriving stock (Eq, Show) + +instance FromJSON ReloadSearchAnalyzersResponse where + parseJSON = withObject "ReloadSearchAnalyzersResponse" $ \o -> + ReloadSearchAnalyzersResponse + <$> o + .: "_shards" + <*> o + .:? "reload_details" + .!= [] + +instance ToJSON ReloadSearchAnalyzersResponse where + toJSON ReloadSearchAnalyzersResponse {..} = + object + [ "_shards" .= rsarShards, + "reload_details" .= rsarReloadDetails + ] + +-- | One element of the @reload_details@ array. Reports which search +-- analyzers were reloaded for a given index and the node ids on which +-- the reload took effect. +data ReloadDetail = ReloadDetail + { -- | Index whose analyzers were reloaded. + rdIndex :: IndexName, + -- | Names of the search analyzers that picked up new resources + -- (typically updateable @synonym@\/@synonym_graph@ filters). + rdReloadedAnalyzers :: [Text], + -- | Node ids on which the analyzer resources were reloaded. + rdReloadedNodeIds :: [Text] + } + deriving stock (Eq, Show) + +instance FromJSON ReloadDetail where + parseJSON = withObject "ReloadDetail" $ \o -> + ReloadDetail + <$> o + .: "index" + <*> o + .:? "reloaded_analyzers" + .!= [] + <*> o + .:? "reloaded_node_ids" + .!= [] + +instance ToJSON ReloadDetail where + toJSON ReloadDetail {..} = + object + [ "index" .= unIndexName rdIndex, + "reloaded_analyzers" .= rdReloadedAnalyzers, + "reloaded_node_ids" .= rdReloadedNodeIds + ] + +-- Lenses for ReloadSearchAnalyzersResponse + +rsarShardsLens :: Lens' ReloadSearchAnalyzersResponse ShardResult +rsarShardsLens = lens rsarShards (\x y -> x {rsarShards = y}) + +rsarReloadDetailsLens :: Lens' ReloadSearchAnalyzersResponse [ReloadDetail] +rsarReloadDetailsLens = + lens rsarReloadDetails (\x y -> x {rsarReloadDetails = y}) + +-- Lenses for ReloadDetail + +rdIndexLens :: Lens' ReloadDetail IndexName +rdIndexLens = lens rdIndex (\x y -> x {rdIndex = y}) + +rdReloadedAnalyzersLens :: Lens' ReloadDetail [Text] +rdReloadedAnalyzersLens = + lens rdReloadedAnalyzers (\x y -> x {rdReloadedAnalyzers = y}) + +rdReloadedNodeIdsLens :: Lens' ReloadDetail [Text] +rdReloadedNodeIdsLens = + lens rdReloadedNodeIds (\x y -> x {rdReloadedNodeIds = y}) + +-- | URI parameters accepted by @POST \/{target}/_reload_search_analyzers@. +-- See +-- . +-- Every field is 'Maybe'; 'defaultReloadSearchAnalyzersOptions' leaves +-- them all @Nothing@, which emits no query string. +data ReloadSearchAnalyzersOptions = ReloadSearchAnalyzersOptions + { -- | @ignore_unavailable@ — return an error if the request targets a + -- missing or closed index. + rsaoIgnoreUnavailable :: Maybe Bool, + -- | @allow_no_indices@ — short-circuit if no concrete index matches. + rsaoAllowNoIndices :: Maybe Bool, + -- | @expand_wildcards@ — wildcard-pattern expansion policy. Reuses + -- the 'ExpandWildcards' sum type shared across the index APIs. + rsaoExpandWildcards :: Maybe (NonEmpty ExpandWildcards) + } + deriving stock (Eq, Show) + +-- | 'ReloadSearchAnalyzersOptions' with every field @Nothing@. Emits an +-- empty query string, preserving the wire behaviour of the +-- parameterless @POST \/{target}/_reload_search_analyzers@. +defaultReloadSearchAnalyzersOptions :: ReloadSearchAnalyzersOptions +defaultReloadSearchAnalyzersOptions = + ReloadSearchAnalyzersOptions + { rsaoIgnoreUnavailable = Nothing, + rsaoAllowNoIndices = Nothing, + rsaoExpandWildcards = Nothing + } + +-- | Render a 'ReloadSearchAnalyzersOptions' record as a @(key, value)@ +-- list suitable for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. 'Nothing' +-- fields are omitted, so 'defaultReloadSearchAnalyzersOptions' produces +-- an empty list (and therefore no query string). +reloadSearchAnalyzersOptionsParams :: + ReloadSearchAnalyzersOptions -> + [(Text, Maybe Text)] +reloadSearchAnalyzersOptionsParams ReloadSearchAnalyzersOptions {..} = + catMaybes + [ ("ignore_unavailable",) . Just . boolText <$> rsaoIgnoreUnavailable, + ("allow_no_indices",) . Just . boolText <$> rsaoAllowNoIndices, + ("expand_wildcards",) . Just . renderExpandWildcards <$> rsaoExpandWildcards + ] + where + boolText True = "true" + boolText False = "false" + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + +-- Lenses for ReloadSearchAnalyzersOptions + +rsaoIgnoreUnavailableLens :: Lens' ReloadSearchAnalyzersOptions (Maybe Bool) +rsaoIgnoreUnavailableLens = + lens rsaoIgnoreUnavailable (\x y -> x {rsaoIgnoreUnavailable = y}) + +rsaoAllowNoIndicesLens :: Lens' ReloadSearchAnalyzersOptions (Maybe Bool) +rsaoAllowNoIndicesLens = + lens rsaoAllowNoIndices (\x y -> x {rsaoAllowNoIndices = y}) + +rsaoExpandWildcardsLens :: + Lens' ReloadSearchAnalyzersOptions (Maybe (NonEmpty ExpandWildcards)) +rsaoExpandWildcardsLens = + lens rsaoExpandWildcards (\x y -> x {rsaoExpandWildcards = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/RemoteClusterInfo.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/RemoteClusterInfo.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/RemoteClusterInfo.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.Common.Types.RemoteClusterInfo + ( -- * Remote cluster info + RemoteClustersInfo (..), + RemoteClusterInfo (..), + RemoteClusterMode (..), + + -- * Optics + remoteClustersInfoClustersLens, + remoteClusterInfoSeedsLens, + remoteClusterInfoConnectedLens, + remoteClusterInfoNumNodesConnectedLens, + remoteClusterInfoMaxConnectionsPerClusterLens, + remoteClusterInfoModeLens, + remoteClusterInfoSkipUnavailableLens, + remoteClusterInfoOtherLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.HashMap.Strict qualified as HM +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- | The top-level payload of @GET /_remote/info@ — an object +-- keyed by remote-cluster alias, each value describing one configured +-- remote cluster. A cluster with no remotes configured returns an +-- empty object (@{}@); 'remoteClustersInfoClusters' will then be +-- 'HM.empty'. Wrapping the map at the type level means callers cannot +-- accidentally treat the alias-keyed object as a single +-- 'RemoteClusterInfo'. +newtype RemoteClustersInfo = RemoteClustersInfo + { remoteClustersInfoClusters :: HM.HashMap Text RemoteClusterInfo + } + deriving stock (Eq, Show) + +-- | One entry of the @GET /_remote/info@ response — the +-- connection state of a single configured remote cluster. The typed +-- fields mirror the universally-present keys of the ES response; +-- anything else the server reports (e.g. @initial_connect_timeout@, +-- @proxy_address@, @server_name@, @has_proxy@, future additions) is +-- kept verbatim in 'remoteClusterInfoOther' so new ES fields decode +-- cleanly rather than failing the whole parser. +-- +-- () +data RemoteClusterInfo = RemoteClusterInfo + { remoteClusterInfoSeeds :: [Text], + remoteClusterInfoConnected :: Bool, + remoteClusterInfoNumNodesConnected :: Int, + remoteClusterInfoMaxConnectionsPerCluster :: Int, + remoteClusterInfoMode :: Maybe RemoteClusterMode, + remoteClusterInfoSkipUnavailable :: Maybe Bool, + remoteClusterInfoOther :: Value + } + deriving stock (Eq, Show) + +-- | The @mode@ ES reports for a remote cluster — @sniff@ (the +-- default, seeds are probed for the full node list) or @proxy@ +-- (requests are tunnelled through a fixed @proxy_address@, since ES +-- 7.16). Kept as a closed enum because the docs fix the two values; +-- parse-fails on unknowns so a future third mode surfaces loudly +-- rather than being silently dropped. +data RemoteClusterMode + = RemoteClusterModeSniff + | RemoteClusterModeProxy + deriving stock (Eq, Show) + +instance FromJSON RemoteClusterMode where + parseJSON = withText "RemoteClusterMode" $ \case + "sniff" -> pure RemoteClusterModeSniff + "proxy" -> pure RemoteClusterModeProxy + other -> fail ("Invalid remote cluster mode: " <> T.unpack other) + +instance ToJSON RemoteClusterMode where + toJSON RemoteClusterModeSniff = String "sniff" + toJSON RemoteClusterModeProxy = String "proxy" + +remoteClustersInfoClustersLens :: Lens' RemoteClustersInfo (HM.HashMap Text RemoteClusterInfo) +remoteClustersInfoClustersLens = + lens + remoteClustersInfoClusters + (\x y -> x {remoteClustersInfoClusters = y}) + +remoteClusterInfoSeedsLens :: Lens' RemoteClusterInfo [Text] +remoteClusterInfoSeedsLens = lens remoteClusterInfoSeeds (\x y -> x {remoteClusterInfoSeeds = y}) + +remoteClusterInfoConnectedLens :: Lens' RemoteClusterInfo Bool +remoteClusterInfoConnectedLens = + lens remoteClusterInfoConnected (\x y -> x {remoteClusterInfoConnected = y}) + +remoteClusterInfoNumNodesConnectedLens :: Lens' RemoteClusterInfo Int +remoteClusterInfoNumNodesConnectedLens = + lens + remoteClusterInfoNumNodesConnected + (\x y -> x {remoteClusterInfoNumNodesConnected = y}) + +remoteClusterInfoMaxConnectionsPerClusterLens :: Lens' RemoteClusterInfo Int +remoteClusterInfoMaxConnectionsPerClusterLens = + lens + remoteClusterInfoMaxConnectionsPerCluster + (\x y -> x {remoteClusterInfoMaxConnectionsPerCluster = y}) + +remoteClusterInfoModeLens :: Lens' RemoteClusterInfo (Maybe RemoteClusterMode) +remoteClusterInfoModeLens = + lens remoteClusterInfoMode (\x y -> x {remoteClusterInfoMode = y}) + +remoteClusterInfoSkipUnavailableLens :: Lens' RemoteClusterInfo (Maybe Bool) +remoteClusterInfoSkipUnavailableLens = + lens + remoteClusterInfoSkipUnavailable + (\x y -> x {remoteClusterInfoSkipUnavailable = y}) + +remoteClusterInfoOtherLens :: Lens' RemoteClusterInfo Value +remoteClusterInfoOtherLens = + lens remoteClusterInfoOther (\x y -> x {remoteClusterInfoOther = y}) + +instance FromJSON RemoteClusterInfo where + parseJSON = withObject "RemoteClusterInfo" $ \o -> + RemoteClusterInfo + <$> o .:? "seeds" .!= [] + <*> o .:? "connected" .!= False + <*> o .:? "num_nodes_connected" .!= 0 + <*> o .:? "max_connections_per_cluster" .!= 0 + <*> o .:? "mode" + <*> o .:? "skip_unavailable" + <*> pure (Object o) + +instance ToJSON RemoteClusterInfo where + toJSON rci = + case remoteClusterInfoOther rci of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "seeds" .= remoteClusterInfoSeeds rci, + "connected" .= remoteClusterInfoConnected rci, + "num_nodes_connected" .= remoteClusterInfoNumNodesConnected rci, + "max_connections_per_cluster" .= remoteClusterInfoMaxConnectionsPerCluster rci, + "mode" .= remoteClusterInfoMode rci, + "skip_unavailable" .= remoteClusterInfoSkipUnavailable rci + ] + +instance FromJSON RemoteClustersInfo where + parseJSON = withObject "RemoteClustersInfo" $ \o -> + RemoteClustersInfo <$> traverse parseJSON (KM.toHashMapText o) + +instance ToJSON RemoteClustersInfo where + toJSON (RemoteClustersInfo m) = + Object (KM.fromHashMapText (toJSON <$> m)) + +mergeIgnoringNulls :: [(Key, Value)] -> KM.KeyMap Value -> KM.KeyMap Value +mergeIgnoringNulls kvs o = KM.union (KM.fromList (filter notNull kvs)) o + where + notNull (_, Null) = False + notNull _ = True diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/RepositoriesMetering.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/RepositoriesMetering.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/RepositoriesMetering.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.RepositoriesMetering +-- Description : Types for the Elasticsearch X-Pack repositories metering API +-- +-- Defines the response shape for the ES X-Pack repositories metering +-- endpoints (under @\/_nodes\/_repositories_metering@). Repositories +-- metering tracks the throttled throughput of snapshot repository +-- operations (creation and deletion) on each node, surfaced as a +-- per-repository rate-limit report. It is a backing observability hook +-- for searchable snapshots and the snapshot lifecycle's cloud-backed +-- repositories. +-- +-- * @GET /_nodes/_repositories_metering@ — 'RepositoriesMeteringResponse' +-- (cluster-wide); @GET /_nodes\/{selection}\/_repositories_metering@ +-- scopes to a node selection. +-- * @DELETE /_nodes/_repositories_metering@ — 'Acknowledged'; resets the +-- metering counters (same node-scoping variant). +-- +-- Repositories metering ships in Elasticsearch 7.x\/8.x\/9.x and lives +-- behind the (free, basic) X-Pack license; ES7\/ES8\/ES9 share the same +-- wire surface, which is why these types live in the Common layer +-- alongside SLM\/DiskUsage. OpenSearch does not implement this API, so +-- calls against an OpenSearch cluster will fail at runtime — the types +-- are still hosted under @Common@ to match the project's SLM\/DiskUsage +-- precedent. +-- +-- The per-repository payload is modelled with the documented typed +-- fields plus an @rmiExtras@ 'KeyMap' catch-all so unknown sibling +-- fields survive a @encode . decode@ round-trip (the same strategy used +-- by "Database.Bloodhound.Internal.Versions.Common.Types.Enrich" and the +-- SMSnapshotConfig precedent). +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.RepositoriesMetering + ( -- * Response types + RepositoriesMeteringResponse (..), + NodeRepositoriesMetering (..), + RepositoryMeteringInfo (..), + RepositoriesMeteringNodesSummary (..), + + -- * Optics + rmrNodesSummaryLens, + rmrClusterNameLens, + rmrNodesLens, + nrmRepositoriesLens, + rmiCloudProviderLens, + rmiRepoTypeLens, + rmiRepoEndpointLens, + rmiRepoBucketLens, + rmiRepoBasePathLens, + rmiCreationCurrentRateLimitLens, + rmiDeletionCurrentRateLimitLens, + rmiCreationTotalCountLens, + rmiDeletionTotalCountLens, + rmiExtrasLens, + rmnsTotalLens, + rmnsSuccessfulLens, + rmnsFailedLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens, omitNulls) + +-- | Top-level response of @GET /_nodes\/_repositories_metering@. Carries +-- the canonical @_nodes@ summary, the cluster name, and a @nodes@ map +-- keyed by node id whose values are 'NodeRepositoriesMetering'. The +-- shape mirrors the async-search stats envelope (and every other +-- @\/_nodes\/...@ stats endpoint): the per-node entries are nested under +-- a top-level @nodes@ key, distinct from the index-as-top-level-key +-- shape used by @\/{target}/_disk_usage@. +data RepositoriesMeteringResponse = RepositoriesMeteringResponse + { -- | @_nodes@ — the total\/successful\/failed node counts touched + -- while building the reply. Absent in some degenerate responses, so + -- 'Maybe'. + rmrNodesSummary :: Maybe RepositoriesMeteringNodesSummary, + -- | @cluster_name@ — the cluster name. 'Maybe' for forward-compat. + rmrClusterName :: Maybe Text, + -- | @nodes@ — per-node metering, keyed by node id. + rmrNodes :: KeyMap NodeRepositoriesMetering + } + deriving stock (Eq, Show) + +instance FromJSON RepositoriesMeteringResponse where + parseJSON = withObject "RepositoriesMeteringResponse" $ \o -> do + nodesSummary <- o .:? "_nodes" + clusterName <- o .:? "cluster_name" + rawNodes <- o .:? "nodes" .!= mempty + parsedNodes <- traverse parseJSON rawNodes + pure + RepositoriesMeteringResponse + { rmrNodesSummary = nodesSummary, + rmrClusterName = clusterName, + rmrNodes = parsedNodes + } + +instance ToJSON RepositoriesMeteringResponse where + toJSON RepositoriesMeteringResponse {..} = + omitNulls + [ "_nodes" .= rmrNodesSummary, + "cluster_name" .= rmrClusterName, + "nodes" .= toJSON rmrNodes + ] + +-- | The per-node payload: a single @repository_metering@ object whose +-- keys are repository metering keys (a synthesised identifier for the +-- metered repository) and whose values are 'RepositoryMeteringInfo'. +data NodeRepositoriesMetering = NodeRepositoriesMetering + { -- | @repository_metering@ — the per-repository metering map, keyed + -- by the repository metering key. A node with no metered + -- repositories reports an empty object. + nrmRepositories :: KeyMap RepositoryMeteringInfo + } + deriving stock (Eq, Show) + +instance FromJSON NodeRepositoriesMetering where + parseJSON = withObject "NodeRepositoriesMetering" $ \o -> do + repos <- o .:? "repository_metering" .!= mempty + parsed <- traverse parseJSON repos + pure $ NodeRepositoriesMetering parsed + +instance ToJSON NodeRepositoriesMetering where + toJSON NodeRepositoriesMetering {..} = + omitNulls ["repository_metering" .= toJSON nrmRepositories] + +-- | The metering report for a single repository. The stable +-- cloud-repository descriptor fields are typed; the creation\/deletion +-- rate limits are carried as opaque 'Value's because their inner shape +-- (@{type, value}@, e.g. @{"type":"bytes_per_second","value":...}@) is +-- not stable across ES versions, and unknown sibling fields are +-- preserved in 'rmiExtras' so the structure round-trips through +-- @encode . decode@. +data RepositoryMeteringInfo = RepositoryMeteringInfo + { -- | @cloud_provider@ — the cloud provider backing the repository + -- (@aws@, @gcp@, @azure@). + rmiCloudProvider :: Maybe Text, + -- | @repo_type@ — the repository type (@s3@, @gcs@, @azure@). + rmiRepoType :: Maybe Text, + -- | @repo_endpoint@ — the cloud storage endpoint URL. + rmiRepoEndpoint :: Maybe Text, + -- | @repo_bucket@ — the cloud storage bucket (or container). + rmiRepoBucket :: Maybe Text, + -- | @repo_base_path@ — the repository's base path within the bucket. + rmiRepoBasePath :: Maybe Text, + -- | @creation_current_rate_limit@ — the throttled creation + -- throughput as an opaque object (@{type, value}@). + rmiCreationCurrentRateLimit :: Maybe Value, + -- | @deletion_current_rate_limit@ — the throttled deletion + -- throughput as an opaque object (@{type, value}@). + rmiDeletionCurrentRateLimit :: Maybe Value, + -- | @creation_total_count@ — cumulative snapshot-creation requests + -- metered against this repository on this node. + rmiCreationTotalCount :: Maybe Integer, + -- | @deletion_total_count@ — cumulative snapshot-deletion requests + -- metered against this repository on this node. + rmiDeletionTotalCount :: Maybe Integer, + -- | Catch-all for every other sibling field ES adds in future so + -- decode is forward-compatible and @encode . decode@ round-trips. + rmiExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- Known keys inside the per-repository object — used to split the +-- decoded 'Object' into the typed fields and the @rmiExtras@ catch-all. +repoInfoKnownKeys :: [Key] +repoInfoKnownKeys = + [ "cloud_provider", + "repo_type", + "repo_endpoint", + "repo_bucket", + "repo_base_path", + "creation_current_rate_limit", + "deletion_current_rate_limit", + "creation_total_count", + "deletion_total_count" + ] + +instance FromJSON RepositoryMeteringInfo where + parseJSON = withObject "RepositoryMeteringInfo" $ \o -> do + cloudProvider <- o .:? "cloud_provider" + repoType <- o .:? "repo_type" + repoEndpoint <- o .:? "repo_endpoint" + repoBucket <- o .:? "repo_bucket" + repoBasePath <- o .:? "repo_base_path" + creationRateLimit <- o .:? "creation_current_rate_limit" + deletionRateLimit <- o .:? "deletion_current_rate_limit" + creationTotalCount <- o .:? "creation_total_count" + deletionTotalCount <- o .:? "deletion_total_count" + let extras = + KM.fromList $ + filter ((`notElem` repoInfoKnownKeys) . fst) $ + KM.toList o + pure + RepositoryMeteringInfo + { rmiCloudProvider = cloudProvider, + rmiRepoType = repoType, + rmiRepoEndpoint = repoEndpoint, + rmiRepoBucket = repoBucket, + rmiRepoBasePath = repoBasePath, + rmiCreationCurrentRateLimit = creationRateLimit, + rmiDeletionCurrentRateLimit = deletionRateLimit, + rmiCreationTotalCount = creationTotalCount, + rmiDeletionTotalCount = deletionTotalCount, + rmiExtras = extras + } + +instance ToJSON RepositoryMeteringInfo where + toJSON RepositoryMeteringInfo {..} = + -- 'object' (not 'omitNulls') so the @rmiExtras@ catch-all survives a + -- round-trip even when it carries a @null@ or empty-array value — the + -- documented forward-compat guarantee. The known fields are + -- pre-filtered by 'catMaybes' (stripping 'Nothing's), so they never + -- contribute a 'Null' here, and the extras have already had the + -- known keys stripped on decode. + object $ + catMaybes + [ ("cloud_provider" .=) <$> rmiCloudProvider, + ("repo_type" .=) <$> rmiRepoType, + ("repo_endpoint" .=) <$> rmiRepoEndpoint, + ("repo_bucket" .=) <$> rmiRepoBucket, + ("repo_base_path" .=) <$> rmiRepoBasePath, + ("creation_current_rate_limit" .=) <$> rmiCreationCurrentRateLimit, + ("deletion_current_rate_limit" .=) <$> rmiDeletionCurrentRateLimit, + ("creation_total_count" .=) <$> rmiCreationTotalCount, + ("deletion_total_count" .=) <$> rmiDeletionTotalCount + ] + <> [toPair kv | kv <- KM.toList rmiExtras] + where + toPair (k, v) = k .= v + +-- | The @_nodes@ sub-object carried by every cluster-level ES response: +-- the total / successful / failed node counts that the server touched +-- while building the reply. Matches the +-- 'Database.Bloodhound.Internal.Versions.Common.Types.AsyncSearch.AsyncSearchStatsNodes' +-- and +-- 'Database.Bloodhound.Internal.Versions.Common.Types.ClusterStats.ClusterStatsNodeSummary' +-- shapes; a dedicated type is defined here (per the project's per-module +-- precedent) so the module is self-contained. +data RepositoriesMeteringNodesSummary = RepositoriesMeteringNodesSummary + { rmnsTotal :: Int, + rmnsSuccessful :: Int, + rmnsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON RepositoriesMeteringNodesSummary where + parseJSON = withObject "RepositoriesMeteringNodesSummary" $ \o -> + RepositoriesMeteringNodesSummary + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON RepositoriesMeteringNodesSummary where + toJSON RepositoriesMeteringNodesSummary {..} = + object + [ "total" .= rmnsTotal, + "successful" .= rmnsSuccessful, + "failed" .= rmnsFailed + ] + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +rmrNodesSummaryLens :: + Lens' RepositoriesMeteringResponse (Maybe RepositoriesMeteringNodesSummary) +rmrNodesSummaryLens = + lens rmrNodesSummary (\x y -> x {rmrNodesSummary = y}) + +rmrClusterNameLens :: Lens' RepositoriesMeteringResponse (Maybe Text) +rmrClusterNameLens = + lens rmrClusterName (\x y -> x {rmrClusterName = y}) + +rmrNodesLens :: + Lens' RepositoriesMeteringResponse (KeyMap NodeRepositoriesMetering) +rmrNodesLens = + lens rmrNodes (\x y -> x {rmrNodes = y}) + +nrmRepositoriesLens :: + Lens' NodeRepositoriesMetering (KeyMap RepositoryMeteringInfo) +nrmRepositoriesLens = + lens nrmRepositories (\x y -> x {nrmRepositories = y}) + +rmiCloudProviderLens :: Lens' RepositoryMeteringInfo (Maybe Text) +rmiCloudProviderLens = + lens rmiCloudProvider (\x y -> x {rmiCloudProvider = y}) + +rmiRepoTypeLens :: Lens' RepositoryMeteringInfo (Maybe Text) +rmiRepoTypeLens = + lens rmiRepoType (\x y -> x {rmiRepoType = y}) + +rmiRepoEndpointLens :: Lens' RepositoryMeteringInfo (Maybe Text) +rmiRepoEndpointLens = + lens rmiRepoEndpoint (\x y -> x {rmiRepoEndpoint = y}) + +rmiRepoBucketLens :: Lens' RepositoryMeteringInfo (Maybe Text) +rmiRepoBucketLens = + lens rmiRepoBucket (\x y -> x {rmiRepoBucket = y}) + +rmiRepoBasePathLens :: Lens' RepositoryMeteringInfo (Maybe Text) +rmiRepoBasePathLens = + lens rmiRepoBasePath (\x y -> x {rmiRepoBasePath = y}) + +rmiCreationCurrentRateLimitLens :: + Lens' RepositoryMeteringInfo (Maybe Value) +rmiCreationCurrentRateLimitLens = + lens rmiCreationCurrentRateLimit (\x y -> x {rmiCreationCurrentRateLimit = y}) + +rmiDeletionCurrentRateLimitLens :: + Lens' RepositoryMeteringInfo (Maybe Value) +rmiDeletionCurrentRateLimitLens = + lens rmiDeletionCurrentRateLimit (\x y -> x {rmiDeletionCurrentRateLimit = y}) + +rmiCreationTotalCountLens :: Lens' RepositoryMeteringInfo (Maybe Integer) +rmiCreationTotalCountLens = + lens rmiCreationTotalCount (\x y -> x {rmiCreationTotalCount = y}) + +rmiDeletionTotalCountLens :: Lens' RepositoryMeteringInfo (Maybe Integer) +rmiDeletionTotalCountLens = + lens rmiDeletionTotalCount (\x y -> x {rmiDeletionTotalCount = y}) + +rmiExtrasLens :: Lens' RepositoryMeteringInfo (KeyMap Value) +rmiExtrasLens = + lens rmiExtras (\x y -> x {rmiExtras = y}) + +rmnsTotalLens :: Lens' RepositoriesMeteringNodesSummary Int +rmnsTotalLens = + lens rmnsTotal (\x y -> x {rmnsTotal = y}) + +rmnsSuccessfulLens :: Lens' RepositoriesMeteringNodesSummary Int +rmnsSuccessfulLens = + lens rmnsSuccessful (\x y -> x {rmnsSuccessful = y}) + +rmnsFailedLens :: Lens' RepositoriesMeteringNodesSummary Int +rmnsFailedLens = + lens rmnsFailed (\x y -> x {rmnsFailed = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Reroute.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Reroute.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Reroute.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.Common.Types.Reroute + ( -- * Reroute commands + RerouteCommand (..), + + -- * Reroute options + RerouteOptions (..), + defaultRerouteOptions, + rerouteOptionsParams, + + -- * Reroute response + RerouteResponse (..), + + -- * Optics + roDryRunLens, + roExplainLens, + roMetricLens, + roMasterTimeoutLens, + roTimeoutLens, + rrAcknowledgedLens, + rrStateLens, + rrExplanationsLens, + rrOtherLens, + ) +where + +import Data.Aeson +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( IndexName, + ShardId (..), + unIndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes + ( NodeName (..), + nodeName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Units + ( TimeUnits, + timeUnitsSuffix, + ) + +-- | A single command carried in the @commands@ array of a +-- @POST /_cluster/reroute@ request body. Each variant renders on the +-- wire as a single-key object @{ \ : { \ } }@, matching +-- the Elasticsearch\/OpenSearch reroute schema. +-- +-- The five enumerated constructors cover every command ES\/OS +-- document; commands introduced by future versions can be sent verbatim +-- via 'RerouteCmdOther' (which holds the whole single-key object +-- unchanged). +-- +-- () +data RerouteCommand + = -- | @move@ — manually move a started shard between nodes. + RerouteMove + { rmIndex :: IndexName, + rmShard :: ShardId, + rmFromNode :: NodeName, + rmToNode :: NodeName + } + | -- | @cancel@ — cancel an in-progress shard relocation or recovery. + -- 'rcAllowPrimary' maps to @allow_primary@; 'Nothing' omits the key. + RerouteCancel + { rcIndex :: IndexName, + rcShard :: ShardId, + rcNode :: NodeName, + rcAllowPrimary :: Maybe Bool + } + | -- | @allocate_replica@ — allocate an unassigned replica shard to a + -- node. + RerouteAllocateReplica + { rarIndex :: IndexName, + rarShard :: ShardId, + rarNode :: NodeName + } + | -- | @allocate_stale_primary@ — allocate a primary shard using stale + -- data. @accept_data_loss@ is mandatory on the wire. + RerouteAllocateStalePrimary + { raspIndex :: IndexName, + raspShard :: ShardId, + raspNode :: NodeName, + raspAcceptDataLoss :: Bool + } + | -- | @allocate_empty_primary@ — allocate an empty primary shard with + -- no data. @accept_data_loss@ is mandatory on the wire. + RerouteAllocateEmptyPrimary + { raepIndex :: IndexName, + raepShard :: ShardId, + raepNode :: NodeName, + raepAcceptDataLoss :: Bool + } + | -- | An unrecognised command, sent verbatim. The 'Value' should be + -- the whole single-key command object (e.g. + -- @{"allocate\":{...}}@). Kept for forward compatibility with + -- commands the typed constructors above do not model. + RerouteCmdOther Value + deriving stock (Eq, Show) + +instance ToJSON RerouteCommand where + toJSON = \case + RerouteMove {..} -> + wrapped "move" $ + [ "index" .= unIndexName rmIndex, + "shard" .= shardId rmShard, + "from_node" .= nodeName rmFromNode, + "to_node" .= nodeName rmToNode + ] + RerouteCancel {..} -> + wrapped "cancel" $ + [ "index" .= unIndexName rcIndex, + "shard" .= shardId rcShard, + "node" .= nodeName rcNode + ] + ++ maybe [] (pure . ("allow_primary" .=)) rcAllowPrimary + RerouteAllocateReplica {..} -> + wrapped "allocate_replica" $ + [ "index" .= unIndexName rarIndex, + "shard" .= shardId rarShard, + "node" .= nodeName rarNode + ] + RerouteAllocateStalePrimary {..} -> + wrapped "allocate_stale_primary" $ + [ "index" .= unIndexName raspIndex, + "shard" .= shardId raspShard, + "node" .= nodeName raspNode, + "accept_data_loss" .= raspAcceptDataLoss + ] + RerouteAllocateEmptyPrimary {..} -> + wrapped "allocate_empty_primary" $ + [ "index" .= unIndexName raepIndex, + "shard" .= shardId raepShard, + "node" .= nodeName raepNode, + "accept_data_loss" .= raepAcceptDataLoss + ] + RerouteCmdOther v -> v + where + -- Wrap a parameter list as @{ : { } }@. The typed + -- constructors never emit a 'Null' (Maybe fields are appended only + -- when 'Just'), so a plain 'object' suffices. + wrapped :: Key -> [Pair] -> Value + wrapped typeKey params = object [typeKey .= object params] + +-- | URI parameters accepted by @POST /_cluster/reroute@. Every field is +-- optional so 'defaultRerouteOptions' renders to no query string at all +-- — byte-for-byte identical to a parameterless call. +-- +-- Note: OS 2.x+ renamed the @master_timeout@ parameter to +-- @cluster_manager_timeout@. Following the convention established by +-- 'Database.Bloodhound.Internal.Versions.Common.Types.ClusterSettings.ClusterSettingsUpdateOptions' +-- and the cat options, the renderer below emits @master_timeout@ for +-- every backend (OS still accepts it as a deprecated alias). +data RerouteOptions = RerouteOptions + { -- | Simulate the reroute without applying it. When @Just True@ the + -- response carries the resulting cluster state in 'rrState'. + roDryRun :: Maybe Bool, + -- | Return an explanation of the reroute decisions (implies + -- @dry_run@). Populates 'rrExplanations' (and 'rrState'). + roExplain :: Maybe Bool, + -- | Limit the returned cluster @state@ to the given metrics (the + -- @metric@ parameter, e.g. @["blocks"]@). Only meaningful with + -- @dry_run\@/explain@. + roMetric :: Maybe (NonEmpty Text), + -- | Master-node timeout, rendered via 'timeUnitsSuffix'. + roMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Overall operation timeout, rendered via 'timeUnitsSuffix'. + roTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'RerouteOptions' with every parameter set to 'Nothing'. Produces no +-- query string, so @'rerouteClusterWith' 'defaultRerouteOptions'@ emits a +-- request identical (modulo the richer response decoder) to +-- 'rerouteCluster'. +defaultRerouteOptions :: RerouteOptions +defaultRerouteOptions = + RerouteOptions + { roDryRun = Nothing, + roExplain = Nothing, + roMetric = Nothing, + roMasterTimeout = Nothing, + roTimeout = Nothing + } + +roDryRunLens :: Lens' RerouteOptions (Maybe Bool) +roDryRunLens = lens roDryRun (\x y -> x {roDryRun = y}) + +roExplainLens :: Lens' RerouteOptions (Maybe Bool) +roExplainLens = lens roExplain (\x y -> x {roExplain = y}) + +roMetricLens :: Lens' RerouteOptions (Maybe (NonEmpty Text)) +roMetricLens = lens roMetric (\x y -> x {roMetric = y}) + +roMasterTimeoutLens :: Lens' RerouteOptions (Maybe (TimeUnits, Word32)) +roMasterTimeoutLens = lens roMasterTimeout (\x y -> x {roMasterTimeout = y}) + +roTimeoutLens :: Lens' RerouteOptions (Maybe (TimeUnits, Word32)) +roTimeoutLens = lens roTimeout (\x y -> x {roTimeout = y}) + +-- | Render 'RerouteOptions' as a list of @(key, value)@ pairs suitable +-- for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultRerouteOptions' produces an empty list (and therefore no +-- query string). +rerouteOptionsParams :: RerouteOptions -> [(Text, Maybe Text)] +rerouteOptionsParams opts = + catMaybes + [ ("dry_run",) . Just . boolQP <$> roDryRun opts, + ("explain",) . Just . boolQP <$> roExplain opts, + ("metric",) . Just . T.intercalate "," . NE.toList <$> roMetric opts, + ("master_timeout",) . Just . renderDuration <$> roMasterTimeout opts, + ("timeout",) . Just . renderDuration <$> roTimeout opts + ] + where + boolQP True = "true" + boolQP False = "false" + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +-- | Response of @POST /_cluster/reroute@. The 'rrAcknowledged' field is +-- always present. 'rrState' is populated only when the request carried +-- @dry_run\@true@ (or @explain\@true@); 'rrExplanations' is populated +-- only with @explain\@true@. +-- +-- 'rrState' is kept as an opaque 'Value' rather than a typed +-- 'Database.Bloodhound.Internal.Versions.Common.Types.ClusterState.ClusterState': +-- the cluster-state object embedded in a reroute response is /not/ the +-- same shape as @GET /_cluster/state@ (it omits @cluster_name@ and adds +-- @routing_nodes@ \/ @security_tokens@), so the typed view would not +-- round-trip. Callers can navigate the verbatim blob directly or feed +-- the relevant sub-object to a dedicated decoder. This mirrors the +-- shallow-\@Value@ approach used by +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Cluster.AllocationExplanation'. +-- +-- () +data RerouteResponse = RerouteResponse + { rrAcknowledged :: Bool, + rrState :: Maybe Value, + rrExplanations :: Maybe [Value], + -- | The original JSON object, preserved verbatim for forward + -- compatibility. Mirrors 'pendingTaskOther' / 'aeOther'. + rrOther :: Value + } + deriving stock (Eq, Show) + +rrAcknowledgedLens :: Lens' RerouteResponse Bool +rrAcknowledgedLens = lens rrAcknowledged (\x y -> x {rrAcknowledged = y}) + +rrStateLens :: Lens' RerouteResponse (Maybe Value) +rrStateLens = lens rrState (\x y -> x {rrState = y}) + +rrExplanationsLens :: Lens' RerouteResponse (Maybe [Value]) +rrExplanationsLens = lens rrExplanations (\x y -> x {rrExplanations = y}) + +rrOtherLens :: Lens' RerouteResponse Value +rrOtherLens = lens rrOther (\x y -> x {rrOther = y}) + +instance FromJSON RerouteResponse where + parseJSON = withObject "RerouteResponse" $ \o -> + RerouteResponse + <$> o .: "acknowledged" + <*> o .:? "state" + <*> o .:? "explanations" + <*> pure (Object o) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Retriever.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Retriever.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Retriever.hs @@ -0,0 +1,1051 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Elasticsearch Retrievers DSL (ES 8.14+, extended through ES9). +-- +-- A retriever is a top-level search-body clause that produces a ranked list +-- of documents. Unlike @\"query\"@, retrievers are /recursive/: compound +-- retrievers (RRF, linear, rescorer, rule, text_similarity_reranker, +-- diversify, pinned) compose the outputs of other retrievers. When +-- 'Search.retriever' is set, it owns the result ranking; 'Search.queryBody' +-- is still sent (under @\"query\"@) for filtering purposes only — the scores +-- come from the retriever. +-- +-- The wire shape is a single-key object under @\"retriever\"@, e.g.: +-- +-- @ +-- { "retriever": { "rrf": { "retrievers": [ ... ], "rank_window_size": 50 } } } +-- @ +-- +-- See the +-- . +-- The set of modelled kinds mirrors the ES9 @_types.RetrieverContainer@ oneOf: +-- +-- * 'RetrieverStandard' (@standard@) +-- * 'RetrieverKnn' (@knn@) +-- * 'RetrieverRRF' (@rrf@) +-- * 'RetrieverTextSimilarity' (@text_similarity_reranker@) +-- * 'RetrieverRule' (@rule@) +-- * 'RetrieverRescorer' (@rescorer@) +-- * 'RetrieverLinear' (@linear@) +-- * 'RetrieverPinned' (@pinned@) +-- * 'RetrieverDiversify' (@diversify@) +-- +-- /Warning/: Elasticsearch-only. OpenSearch does not recognise the +-- @retriever@ body field and will reject the request if it is set on an +-- OS backend. The field is included in the common record for caller +-- convenience; backend-aware gating is tracked as a follow-up (same +-- situation as 'Search.runtimeMappings'). +module Database.Bloodhound.Internal.Versions.Common.Types.Retriever + ( Retriever (..), + RetrieverBase (..), + StandardRetriever (..), + KnnRetriever (..), + RrfRetriever (..), + RrfRetrieverEntry (..), + TextSimilarityRetriever (..), + RuleRetriever (..), + RetrieverRulesetId (..), + unRetrieverRulesetId, + RescorerRetriever (..), + LinearRetriever (..), + LinearRetrieverEntry (..), + ScoreNormalizer (..), + PinnedRetriever (..), + SpecifiedDocument (..), + DiversifyRetriever (..), + DiversifyType (..), + RescoreVector (..), + RetrieverCollapse (..), + RetrieverRescore (..), + ChunkRescorer (..), + ChunkRescorerChunkingStrategy (..), + ChunkRescorerChunkingSettings (..), + + -- * Smart constructors + mkStandardRetriever, + mkKnnRetriever, + mkRrfRetriever, + mkTextSimilarityRetriever, + mkRuleRetriever, + mkRescorerRetriever, + mkLinearRetriever, + mkPinnedRetriever, + mkDiversifyRetriever, + emptyRetrieverBase, + + -- * Optics + standardRetrieverQueryLens, + rrfRetrieversLens, + rrfRankWindowSizeLens, + rrfRankConstantLens, + textSimilarityRetrieverLens, + textSimilarityFieldLens, + textSimilarityInferenceTextLens, + textSimilarityInferenceIdLens, + textSimilarityRankWindowSizeLens, + retrieverBaseFilterLens, + retrieverBaseMinScoreLens, + retrieverBaseNameLens, + ) +where + +import Data.Aeson +import Data.Aeson.Key qualified as AK +import Data.Aeson.KeyMap qualified as KM +import Data.String (IsString) +import Data.Text qualified as T +import Data.Vector qualified as V +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Aggregation (SearchAfterKey) +import Database.Bloodhound.Internal.Versions.Common.Types.Knn (KnnQueryVectorBuilder) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( DocId (..), + FieldName (..), + IndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Query (Filter, Query) + +-- | Opaque wrapper for the ES @collapse@ clause on a retriever. ES's +-- 'Collapse' schema lives in "Common.Types.Search", which itself imports +-- this module (for the @retriever@ search field); to avoid a module +-- cycle we preserve @collapse@ as a JSON passthrough, mirroring the +-- @KnnInnerHits@ precedent. Tracked as a follow-up if typed access is +-- needed. +newtype RetrieverCollapse = RetrieverCollapse + { getRetrieverCollapse :: Value + } + deriving newtype (Eq, Show, ToJSON, FromJSON) + +-- | Opaque wrapper for a single ES @rescore@ clause inside a +-- 'RescorerRetriever'. Same cycle-avoidance rationale as +-- 'RetrieverCollapse'. Wrap an existing 'Rescore' via 'toJSON'. +newtype RetrieverRescore = RetrieverRescore + { getRetrieverRescore :: Value + } + deriving newtype (Eq, Show, ToJSON, FromJSON) + +-- | A single retriever clause. Exactly one constructor is active per +-- value; the 'ToJSON' instance renders it as the corresponding +-- single-key object (@{"standard": ...}@, @{"knn": ...}@, etc.). +data Retriever + = -- | @standard@ — wraps a textual 'Query' (or match-all when 'Nothing'). + -- The simplest retriever; usually the leaf of a compound tree. + RetrieverStandard StandardRetriever + | -- | @knn@ — vector similarity search. Uses a dedicated 'KnnRetriever' + -- record (not the top-level 'KnnQuery') because the ES retriever + -- field-set diverges: it requires @num_candidates@, rejects @boost@ + -- and @inner_hits@, and adds @visit_percentage@ / @rescore_vector@. + RetrieverKnn KnnRetriever + | -- | @rrf@ — reciprocal rank fusion of two or more sub-retrievers. + RetrieverRRF RrfRetriever + | -- | @text_similarity_reranker@ — reranks an input retriever's output + -- through an inference endpoint (e.g. a cross-encoder model). + -- Renamed from @text_similarity@ in ES 8.14; the older key is + -- deprecated and rejected by this decoder. + RetrieverTextSimilarity TextSimilarityRetriever + | -- | @rule@ — applies stored query rules ('RuleRetriever') to the + -- output of a child retriever. ES 8.16+. + RetrieverRule RuleRetriever + | -- | @rescorer@ — re-scores a child retriever's output with one or + -- more 'Rescore' clauses. ES 8.16+. + RetrieverRescorer RescorerRetriever + | -- | @linear@ — weighted linear combination of several child + -- retrievers (each entry carries its own @weight@ and + -- 'ScoreNormalizer'). ES 9.0+. + RetrieverLinear LinearRetriever + | -- | @pinned@ — promotes fixed documents (by id or by reference) to + -- the top of a child retriever's output. ES 8.16+. + RetrieverPinned PinnedRetriever + | -- | @diversify@ — re-ranks a child retriever's output to increase + -- result diversity (Maximal Marginal Relevance, @mmr@). ES 8.18+. + RetrieverDiversify DiversifyRetriever + deriving stock (Eq, Show) + +-- --------------------------------------------------------------------------- +-- RetrieverBase: the @allOf: RetrieverBase@ fields shared by every retriever +-- kind in the ES9 spec (@filter@, @min_score@, @_name@). Embedded (flattened) +-- into each retriever record via the helpers below so the wire shape stays +-- flat — no nested @base@ object is emitted. +-- --------------------------------------------------------------------------- + +-- | Shared base fields rendered into every retriever object. Matches +-- @_types.RetrieverBase@ in the ES9 spec. +data RetrieverBase = RetrieverBase + { rbFilter :: Maybe Filter, + rbMinScore :: Maybe Double, + rbName :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'RetrieverBase' with every field set to 'Nothing'. Convenient default +-- for the smart constructors. +emptyRetrieverBase :: RetrieverBase +emptyRetrieverBase = RetrieverBase Nothing Nothing Nothing + +-- | Render the base fields as JSON pairs (nulls already included; the +-- surrounding 'omitNulls' call elides them). Used by every retriever +-- 'ToJSON' instance to flatten the base into its own object. +retrieverBasePairs :: RetrieverBase -> [(Key, Value)] +retrieverBasePairs RetrieverBase {..} = + [ "filter" .= rbFilter, + "min_score" .= rbMinScore, + "_name" .= rbName + ] + +-- | Parse the base fields out of a retriever object. Used by every +-- retriever 'FromJSON' instance. +parseRetrieverBase :: Object -> Parser RetrieverBase +parseRetrieverBase o = + RetrieverBase + <$> o .:? "filter" + <*> o .:? "min_score" + <*> o .:? "_name" + +retrieverBaseFilterLens :: Lens' RetrieverBase (Maybe Filter) +retrieverBaseFilterLens = lens rbFilter (\x y -> x {rbFilter = y}) + +retrieverBaseMinScoreLens :: Lens' RetrieverBase (Maybe Double) +retrieverBaseMinScoreLens = lens rbMinScore (\x y -> x {rbMinScore = y}) + +retrieverBaseNameLens :: Lens' RetrieverBase (Maybe Text) +retrieverBaseNameLens = lens rbName (\x y -> x {rbName = y}) + +-- --------------------------------------------------------------------------- +-- standard +-- --------------------------------------------------------------------------- + +-- | @standard@ retriever body. Wraps a textual 'Query'; when 'srQuery' is +-- 'Nothing' the server treats it as @match_all@. +data StandardRetriever = StandardRetriever + { srBase :: RetrieverBase, + srQuery :: Maybe Query, + -- | Pagination cursor (sort values of the last hit of the previous + -- page). Renders as a JSON array; opaque passthrough of the + -- @search_after@ values the server returned. + srSearchAfter :: Maybe SearchAfterKey, + -- | Maximum number of documents to collect per shard. + srTerminateAfter :: Maybe Int, + -- | Collapse the top documents by a specified key. + srCollapse :: Maybe RetrieverCollapse, + -- | Sort specification controlling document ordering. Opaque + -- passthrough because 'SortSpec' is encode-only in this codebase + -- (it has 'ToJSON' but no 'FromJSON'); wrap a 'Sort' via 'toJSON'. + srSort :: Maybe Value + } + deriving stock (Eq, Show) + +-- | Smart constructor for 'StandardRetriever' with the base fields cleared +-- and every optional field set to 'Nothing'. +mkStandardRetriever :: Maybe Query -> StandardRetriever +mkStandardRetriever q = + StandardRetriever + { srBase = emptyRetrieverBase, + srQuery = q, + srSearchAfter = Nothing, + srTerminateAfter = Nothing, + srCollapse = Nothing, + srSort = Nothing + } + +instance ToJSON StandardRetriever where + toJSON StandardRetriever {..} = + omitNulls $ + retrieverBasePairs srBase + <> [ "query" .= srQuery, + "search_after" .= srSearchAfter, + "terminate_after" .= srTerminateAfter, + "collapse" .= srCollapse, + "sort" .= srSort + ] + +instance FromJSON StandardRetriever where + parseJSON = withObject "StandardRetriever" $ \o -> + StandardRetriever + <$> parseRetrieverBase o + <*> o .:? "query" + <*> o .:? "search_after" + <*> o .:? "terminate_after" + <*> o .:? "collapse" + <*> o .:? "sort" + +standardRetrieverQueryLens :: Lens' StandardRetriever (Maybe Query) +standardRetrieverQueryLens = lens srQuery (\x y -> x {srQuery = y}) + +-- --------------------------------------------------------------------------- +-- knn (dedicated retriever record) +-- --------------------------------------------------------------------------- + +-- | @knn@ retriever body. Field-set per the ES9 @_types.KnnRetriever@ spec, +-- which differs from the top-level 'KnnQuery': @num_candidates@ / @field@ / +-- @k@ are required server-side (kept 'Maybe' here to match project +-- convention), @boost@ and @inner_hits@ are NOT accepted, and +-- @visit_percentage@ / @rescore_vector@ are retriever-only. +data KnnRetriever = KnnRetriever + { knnrBase :: RetrieverBase, + knnrField :: FieldName, + -- | Static query vector. One of 'knnrQueryVector' or + -- 'knnrQueryVectorBuilder' must be supplied; both 'Nothing' will be + -- rejected by the server. + knnrQueryVector :: Maybe [Double], + knnrQueryVectorBuilder :: Maybe KnnQueryVectorBuilder, + knnrK :: Maybe Int, + knnrNumCandidates :: Maybe Int, + knnrSimilarity :: Maybe Double, + -- | Percentage of vectors to explore per shard (bbq_disk). ES 9.2+. + knnrVisitPercentage :: Maybe Double, + -- | Oversampling / rescoring for quantized vectors. ES 8.18+. + knnrRescoreVector :: Maybe RescoreVector + } + deriving stock (Eq, Show) + +-- | Smart constructor for 'KnnRetriever'. Only the @field@ is fixed; the +-- caller should set exactly one of 'knnrQueryVector' / +-- 'knnrQueryVectorBuilder' and the required @k@ / @knnrNumCandidates'. +mkKnnRetriever :: FieldName -> KnnRetriever +mkKnnRetriever f = + KnnRetriever + { knnrBase = emptyRetrieverBase, + knnrField = f, + knnrQueryVector = Nothing, + knnrQueryVectorBuilder = Nothing, + knnrK = Nothing, + knnrNumCandidates = Nothing, + knnrSimilarity = Nothing, + knnrVisitPercentage = Nothing, + knnrRescoreVector = Nothing + } + +instance ToJSON KnnRetriever where + toJSON KnnRetriever {..} = + omitNulls $ + retrieverBasePairs knnrBase + <> [ "field" .= knnrField, + "query_vector" .= knnrQueryVector, + "query_vector_builder" .= knnrQueryVectorBuilder, + "k" .= knnrK, + "num_candidates" .= knnrNumCandidates, + "similarity" .= knnrSimilarity, + "visit_percentage" .= knnrVisitPercentage, + "rescore_vector" .= knnrRescoreVector + ] + +instance FromJSON KnnRetriever where + parseJSON = withObject "KnnRetriever" $ \o -> + KnnRetriever + <$> parseRetrieverBase o + <*> o .: "field" + <*> o .:? "query_vector" + <*> o .:? "query_vector_builder" + <*> o .:? "k" + <*> o .:? "num_candidates" + <*> o .:? "similarity" + <*> o .:? "visit_percentage" + <*> o .:? "rescore_vector" + +-- | Oversampling factor applied to @k@ for approximate kNN search over +-- quantized vectors. Matches @_types.RescoreVector@. @oversample@ is +-- required. +newtype RescoreVector = RescoreVector + { rvOversample :: Double + } + deriving stock (Eq, Show) + +instance ToJSON RescoreVector where + toJSON (RescoreVector o) = object ["oversample" .= o] + +instance FromJSON RescoreVector where + parseJSON = withObject "RescoreVector" $ \o -> + RescoreVector <$> o .: "oversample" + +-- --------------------------------------------------------------------------- +-- rrf +-- --------------------------------------------------------------------------- + +-- | @rrf@ retriever body. Combines two or more sub-retrievers using +-- reciprocal rank fusion. The server requires at least two retrievers +-- for fusion to be meaningful; the 'NonEmpty' encodes \"at least one\" +-- but the ES-side invariant is @>= 2@. +data RrfRetriever = RrfRetriever + { rrfBase :: RetrieverBase, + rrfRetrievers :: NonEmpty RrfRetrieverEntry, + -- | Cap on the number of candidates pulled from each input retriever + -- before fusion. Defaults to the search's @size@ server-side. + rrfRankWindowSize :: Maybe Int, + -- | Rank constant for classic RRF (default 60 server-side). + rrfRankConstant :: Maybe Int, + -- | Optional server-side query string used when the RRF inputs need + -- a textual context. ES 8.14+. + rrfQuery :: Maybe Text, + -- | Optional field list for the RRF composition. ES 8.14+. + rrfFields :: Maybe [FieldName] + } + deriving stock (Eq, Show) + +-- | Smart constructor for 'RrfRetriever'. Caller supplies the +-- 'NonEmpty' list of entries; everything else defaults to 'Nothing'. +mkRrfRetriever :: NonEmpty RrfRetrieverEntry -> RrfRetriever +mkRrfRetriever entries = + RrfRetriever + { rrfBase = emptyRetrieverBase, + rrfRetrievers = entries, + rrfRankWindowSize = Nothing, + rrfRankConstant = Nothing, + rrfQuery = Nothing, + rrfFields = Nothing + } + +instance ToJSON RrfRetriever where + toJSON RrfRetriever {..} = + omitNulls $ + retrieverBasePairs rrfBase + <> [ "retrievers" .= toList rrfRetrievers, + "rank_window_size" .= rrfRankWindowSize, + "rank_constant" .= rrfRankConstant, + "query" .= rrfQuery, + "fields" .= rrfFields + ] + +instance FromJSON RrfRetriever where + parseJSON = withObject "RrfRetriever" $ \o -> + RrfRetriever + <$> parseRetrieverBase o + <*> o .: "retrievers" + <*> o .:? "rank_window_size" + <*> o .:? "rank_constant" + <*> o .:? "query" + <*> o .:? "fields" + +-- | A single entry of an 'RrfRetriever.rrfRetrievers' array. ES accepts +-- two shapes: +-- +-- * /Bare/ (backward compatible): the retriever object directly, e.g. +-- @{ "standard": { ... } }@. Encoded as 'RrfRetrieverEntryBare'. +-- +-- * /Weighted/: an explicit @{ "retriever": ..., "weight": N }@ wrapper +-- giving this input a blend weight (default @1.0@). Encoded as +-- 'RrfRetrieverEntryWeighted'. +-- +-- Decoding dispatches on the presence of a @retriever@ key. +data RrfRetrieverEntry + = RrfRetrieverEntryBare Retriever + | RrfRetrieverEntryWeighted Retriever (Maybe Double) + deriving stock (Eq, Show) + +instance ToJSON RrfRetrieverEntry where + toJSON (RrfRetrieverEntryBare r) = toJSON r + toJSON (RrfRetrieverEntryWeighted r w) = + omitNulls ["retriever" .= r, "weight" .= w] + +instance FromJSON RrfRetrieverEntry where + parseJSON v = withObject "RrfRetrieverEntry" dispatch v + where + dispatch o + | KM.member "retriever" o = + RrfRetrieverEntryWeighted + <$> o .: "retriever" + <*> o .:? "weight" + | otherwise = RrfRetrieverEntryBare <$> parseJSON v + +rrfRetrieversLens :: Lens' RrfRetriever (NonEmpty RrfRetrieverEntry) +rrfRetrieversLens = lens rrfRetrievers (\x y -> x {rrfRetrievers = y}) + +rrfRankWindowSizeLens :: Lens' RrfRetriever (Maybe Int) +rrfRankWindowSizeLens = lens rrfRankWindowSize (\x y -> x {rrfRankWindowSize = y}) + +rrfRankConstantLens :: Lens' RrfRetriever (Maybe Int) +rrfRankConstantLens = lens rrfRankConstant (\x y -> x {rrfRankConstant = y}) + +-- --------------------------------------------------------------------------- +-- text_similarity_reranker +-- --------------------------------------------------------------------------- + +-- | @text_similarity_reranker@ retriever body. Reranks the output of an +-- input retriever using a learned model exposed via an inference +-- endpoint. +data TextSimilarityRetriever = TextSimilarityRetriever + { tsBase :: RetrieverBase, + -- | Input retriever whose output is reranked. Required. + tsRetriever :: Retriever, + -- | Semantic-text field whose value is fed to the reranker. Required. + tsField :: FieldName, + -- | Text passed to the reranker as the similarity query. Required. + tsInferenceText :: Text, + -- | Inference endpoint ID (e.g. @.rerank_v1@). Optional since ES + -- 8.14 — when omitted, the field-level @semantic_text@ inference + -- config is used. + tsInferenceId :: Maybe Text, + -- | Cap on the number of candidates pulled from the input retriever + -- before reranking. + tsRankWindowSize :: Maybe Int, + -- | When set, rerank only the best matching chunks of each document. + -- ES 9.2+. + tsChunkRescorer :: Maybe ChunkRescorer + } + deriving stock (Eq, Show) + +-- | Smart constructor for 'TextSimilarityRetriever'. The retriever, field, +-- and inference text are required; the rest default to 'Nothing'. +mkTextSimilarityRetriever :: + Retriever -> + FieldName -> + Text -> + TextSimilarityRetriever +mkTextSimilarityRetriever r f t = + TextSimilarityRetriever + { tsBase = emptyRetrieverBase, + tsRetriever = r, + tsField = f, + tsInferenceText = t, + tsInferenceId = Nothing, + tsRankWindowSize = Nothing, + tsChunkRescorer = Nothing + } + +instance ToJSON TextSimilarityRetriever where + toJSON TextSimilarityRetriever {..} = + omitNulls $ + retrieverBasePairs tsBase + <> [ "retriever" .= tsRetriever, + "field" .= tsField, + "inference_text" .= tsInferenceText, + "inference_id" .= tsInferenceId, + "rank_window_size" .= tsRankWindowSize, + "chunk_rescorer" .= tsChunkRescorer + ] + +instance FromJSON TextSimilarityRetriever where + parseJSON = withObject "TextSimilarityRetriever" $ \o -> + TextSimilarityRetriever + <$> parseRetrieverBase o + <*> o .: "retriever" + <*> o .: "field" + <*> o .: "inference_text" + <*> o .:? "inference_id" + <*> o .:? "rank_window_size" + <*> o .:? "chunk_rescorer" + +textSimilarityRetrieverLens :: Lens' TextSimilarityRetriever Retriever +textSimilarityRetrieverLens = lens tsRetriever (\x y -> x {tsRetriever = y}) + +textSimilarityFieldLens :: Lens' TextSimilarityRetriever FieldName +textSimilarityFieldLens = lens tsField (\x y -> x {tsField = y}) + +textSimilarityInferenceTextLens :: Lens' TextSimilarityRetriever Text +textSimilarityInferenceTextLens = + lens tsInferenceText (\x y -> x {tsInferenceText = y}) + +textSimilarityInferenceIdLens :: Lens' TextSimilarityRetriever (Maybe Text) +textSimilarityInferenceIdLens = + lens tsInferenceId (\x y -> x {tsInferenceId = y}) + +textSimilarityRankWindowSizeLens :: Lens' TextSimilarityRetriever (Maybe Int) +textSimilarityRankWindowSizeLens = + lens tsRankWindowSize (\x y -> x {tsRankWindowSize = y}) + +-- --------------------------------------------------------------------------- +-- rule +-- --------------------------------------------------------------------------- + +-- | Opaque identifier for a stored query ruleset (the +-- @\/_query_rules\/{ruleset_id}@ resource). Local to the retriever module +-- so that 'Common' does not depend on the ES8-specific 'RulesetId'. +newtype RetrieverRulesetId = RetrieverRulesetId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unRetrieverRulesetId :: RetrieverRulesetId -> Text +unRetrieverRulesetId (RetrieverRulesetId x) = x + +-- | @rule@ retriever body. Evaluates the stored rules in one or more +-- rulesets against 'ruleMatchCriteria', and applies the first matching +-- rule's actions to the output of a child retriever. ES 8.16+. +data RuleRetriever = RuleRetriever + { ruleBase :: RetrieverBase, + -- | Ruleset IDs to evaluate. Spec allows either a single id or an + -- array; both are decoded, always encoded as an array. + ruleRulesetIds :: NonEmpty RetrieverRulesetId, + -- | Opaque match-criteria map (@{ "key": "value", ... }@) the rules + -- match against. Required server-side. + ruleMatchCriteria :: Object, + -- | Child retriever whose output rules are applied to. Required. + ruleRetriever :: Retriever, + ruleRankWindowSize :: Maybe Int + } + deriving stock (Eq, Show) + +-- | Smart constructor for 'RuleRetriever'. +mkRuleRetriever :: + NonEmpty RetrieverRulesetId -> + Object -> + Retriever -> + RuleRetriever +mkRuleRetriever ids criteria r = + RuleRetriever + { ruleBase = emptyRetrieverBase, + ruleRulesetIds = ids, + ruleMatchCriteria = criteria, + ruleRetriever = r, + ruleRankWindowSize = Nothing + } + +instance ToJSON RuleRetriever where + toJSON RuleRetriever {..} = + omitNulls $ + retrieverBasePairs ruleBase + <> [ "ruleset_ids" .= toList ruleRulesetIds, + "match_criteria" .= ruleMatchCriteria, + "retriever" .= ruleRetriever, + "rank_window_size" .= ruleRankWindowSize + ] + +instance FromJSON RuleRetriever where + parseJSON = withObject "RuleRetriever" $ \o -> do + base <- parseRetrieverBase o + -- ES encodes ruleset_ids as either a bare id or an array of ids. + ids <- + o .: "ruleset_ids" >>= \case + Array xs + | not (null xs) -> do + parsed <- traverse parseJSON (V.toList xs) :: Parser [RetrieverRulesetId] + case parsed of + (y : ys) -> pure (y :| ys) + [] -> fail "ruleset_ids: empty array" + other -> do + single <- parseJSON other :: Parser RetrieverRulesetId + pure (single :| []) + criteria <- o .: "match_criteria" + r <- o .: "retriever" + window <- o .:? "rank_window_size" + pure $ RuleRetriever base ids criteria r window + +-- --------------------------------------------------------------------------- +-- rescorer +-- --------------------------------------------------------------------------- + +-- | @rescorer@ retriever body. Re-scores the output of a child retriever +-- with one or more 'Rescore' clauses. ES 8.16+. +data RescorerRetriever = RescorerRetriever + { rescorerBase :: RetrieverBase, + -- | Child retriever whose output is rescored. Required. + rescorerRetriever :: Retriever, + -- | One or more rescore clauses. Spec allows a single object or an + -- array; both are decoded, always encoded as an array. + rescorerRescore :: NonEmpty RetrieverRescore + } + deriving stock (Eq, Show) + +-- | Smart constructor for 'RescorerRetriever'. +mkRescorerRetriever :: + Retriever -> + NonEmpty RetrieverRescore -> + RescorerRetriever +mkRescorerRetriever r rescores = + RescorerRetriever + { rescorerBase = emptyRetrieverBase, + rescorerRetriever = r, + rescorerRescore = rescores + } + +instance ToJSON RescorerRetriever where + toJSON RescorerRetriever {..} = + omitNulls $ + retrieverBasePairs rescorerBase + <> [ "retriever" .= rescorerRetriever, + "rescore" .= toList rescorerRescore + ] + +instance FromJSON RescorerRetriever where + parseJSON = withObject "RescorerRetriever" $ \o -> do + base <- parseRetrieverBase o + r <- o .: "retriever" + -- ES encodes rescore as either a single object or an array. + rescore <- + o .: "rescore" >>= \case + Array xs + | not (null xs) -> do + parsed <- traverse parseJSON (V.toList xs) :: Parser [RetrieverRescore] + case parsed of + (y : ys) -> pure (y :| ys) + [] -> fail "rescore: empty array" + other -> do + single <- parseJSON other :: Parser RetrieverRescore + pure (single :| []) + pure $ RescorerRetriever base r rescore + +-- --------------------------------------------------------------------------- +-- linear +-- --------------------------------------------------------------------------- + +-- | Score normalizer applied to a child retriever's scores before linear +-- combination. Matches @_types.ScoreNormalizer@. +data ScoreNormalizer + = NoNormalizer + | MinMaxNormalizer + | L2NormNormalizer + deriving stock (Eq, Show) + +instance ToJSON ScoreNormalizer where + toJSON NoNormalizer = String "none" + toJSON MinMaxNormalizer = String "minmax" + toJSON L2NormNormalizer = String "l2_norm" + +instance FromJSON ScoreNormalizer where + parseJSON = withText "ScoreNormalizer" $ \case + "none" -> pure NoNormalizer + "minmax" -> pure MinMaxNormalizer + "l2_norm" -> pure L2NormNormalizer + other -> fail $ "Unknown score normalizer: " <> T.unpack other + +-- | A single weighted input of a 'LinearRetriever'. All three fields are +-- required server-side per @_types.InnerRetriever@. +data LinearRetrieverEntry = LinearRetrieverEntry + { lreRetriever :: Retriever, + lreWeight :: Double, + lreNormalizer :: ScoreNormalizer + } + deriving stock (Eq, Show) + +instance ToJSON LinearRetrieverEntry where + toJSON LinearRetrieverEntry {..} = + object + [ "retriever" .= lreRetriever, + "weight" .= lreWeight, + "normalizer" .= lreNormalizer + ] + +instance FromJSON LinearRetrieverEntry where + parseJSON = withObject "LinearRetrieverEntry" $ \o -> + LinearRetrieverEntry + <$> o .: "retriever" + <*> o .: "weight" + <*> o .: "normalizer" + +-- | @linear@ retriever body. Combines several child retrievers via a +-- weighted linear combination of (optionally normalized) scores. ES 9.0+. +data LinearRetriever = LinearRetriever + { linearBase :: RetrieverBase, + linearRetrievers :: [LinearRetrieverEntry], + linearRankWindowSize :: Maybe Int, + linearQuery :: Maybe Text, + linearFields :: Maybe [FieldName], + -- | Optional top-level normalizer applied after combination. + linearNormalizer :: Maybe ScoreNormalizer + } + deriving stock (Eq, Show) + +-- | Smart constructor for 'LinearRetriever'. +mkLinearRetriever :: [LinearRetrieverEntry] -> LinearRetriever +mkLinearRetriever entries = + LinearRetriever + { linearBase = emptyRetrieverBase, + linearRetrievers = entries, + linearRankWindowSize = Nothing, + linearQuery = Nothing, + linearFields = Nothing, + linearNormalizer = Nothing + } + +instance ToJSON LinearRetriever where + toJSON LinearRetriever {..} = + omitNulls $ + retrieverBasePairs linearBase + <> [ "retrievers" .= linearRetrievers, + "rank_window_size" .= linearRankWindowSize, + "query" .= linearQuery, + "fields" .= linearFields, + "normalizer" .= linearNormalizer + ] + +instance FromJSON LinearRetriever where + parseJSON = withObject "LinearRetriever" $ \o -> + LinearRetriever + <$> parseRetrieverBase o + <*> o .:? "retrievers" .!= [] + <*> o .:? "rank_window_size" + <*> o .:? "query" + <*> o .:? "fields" + <*> o .:? "normalizer" + +-- --------------------------------------------------------------------------- +-- pinned +-- --------------------------------------------------------------------------- + +-- | A document reference pinned to the top of the results. Matches +-- @_types.SpecifiedDocument@; @index@ is optional, @id@ is required. +-- Named @SpecifiedDocument@ (not @PinnedDocument@) to match the spec and +-- to avoid a record-field clash with the pre-existing 'PinnedDoc' of the +-- Query Rules API. +data SpecifiedDocument = SpecifiedDocument + { sdIndex :: Maybe IndexName, + sdId :: DocId + } + deriving stock (Eq, Show) + +instance ToJSON SpecifiedDocument where + toJSON SpecifiedDocument {..} = + omitNulls ["_index" .= sdIndex, "_id" .= sdId] + +instance FromJSON SpecifiedDocument where + parseJSON = withObject "SpecifiedDocument" $ \o -> + SpecifiedDocument + <$> o .:? "_index" + <*> o .: "_id" + +-- | @pinned@ retriever body. Promotes fixed documents (by id or by +-- reference) to the top of a child retriever's output. ES 8.16+. +data PinnedRetriever = PinnedRetriever + { pinnedBase :: RetrieverBase, + -- | Child retriever whose output is pinned onto. Required. + pinnedRetriever :: Retriever, + -- | Document ids to pin to the top. + pinnedIds :: Maybe [Text], + -- | Document references (index+id) to pin to the top. + pinnedDocs :: Maybe [SpecifiedDocument], + pinnedRankWindowSize :: Maybe Int + } + deriving stock (Eq, Show) + +-- | Smart constructor for 'PinnedRetriever'. +mkPinnedRetriever :: Retriever -> PinnedRetriever +mkPinnedRetriever r = + PinnedRetriever + { pinnedBase = emptyRetrieverBase, + pinnedRetriever = r, + pinnedIds = Nothing, + pinnedDocs = Nothing, + pinnedRankWindowSize = Nothing + } + +instance ToJSON PinnedRetriever where + toJSON PinnedRetriever {..} = + omitNulls $ + retrieverBasePairs pinnedBase + <> [ "retriever" .= pinnedRetriever, + "ids" .= pinnedIds, + "docs" .= pinnedDocs, + "rank_window_size" .= pinnedRankWindowSize + ] + +instance FromJSON PinnedRetriever where + parseJSON = withObject "PinnedRetriever" $ \o -> + PinnedRetriever + <$> parseRetrieverBase o + <*> o .: "retriever" + <*> o .:? "ids" + <*> o .:? "docs" + <*> o .:? "rank_window_size" + +-- --------------------------------------------------------------------------- +-- diversify +-- --------------------------------------------------------------------------- + +-- | Diversification strategy. Only @mmr@ (Maximal Marginal Relevance) is +-- documented in the ES9 spec. +data DiversifyType + = DiversifyMMR + deriving stock (Eq, Show) + +instance ToJSON DiversifyType where + toJSON DiversifyMMR = String "mmr" + +instance FromJSON DiversifyType where + parseJSON = withText "DiversifyType" $ \case + "mmr" -> pure DiversifyMMR + other -> fail $ "Unknown diversify type: " <> T.unpack other + +-- | @diversify@ retriever body. Re-ranks a child retriever's output to +-- increase diversity via MMR. ES 8.18+. +data DiversifyRetriever = DiversifyRetriever + { diversifyBase :: RetrieverBase, + -- | Diversification strategy. Required. + diversifyType :: DiversifyType, + -- | Document field on which to diversify. Required. + diversifyField :: FieldName, + -- | Child retriever whose output is diversified. Required. + diversifyRetriever :: Retriever, + -- | Number of top documents to return after diversification. + diversifySize :: Maybe Int, + diversifyRankWindowSize :: Maybe Int, + -- | Static query vector used for diversity scoring. + diversifyQueryVector :: Maybe [Double], + -- | Model-based query vector builder. + diversifyQueryVectorBuilder :: Maybe KnnQueryVectorBuilder, + -- | Relevance/diversity trade-off for MMR. @0.0@ = pure diversity, + -- @1.0@ = pure relevance. Required for MMR server-side. + diversifyLambda :: Maybe Double + } + deriving stock (Eq, Show) + +-- | Smart constructor for 'DiversifyRetriever' defaulting to the only +-- documented 'DiversifyType' (MMR). +mkDiversifyRetriever :: FieldName -> Retriever -> DiversifyRetriever +mkDiversifyRetriever f r = + DiversifyRetriever + { diversifyBase = emptyRetrieverBase, + diversifyType = DiversifyMMR, + diversifyField = f, + diversifyRetriever = r, + diversifySize = Nothing, + diversifyRankWindowSize = Nothing, + diversifyQueryVector = Nothing, + diversifyQueryVectorBuilder = Nothing, + diversifyLambda = Nothing + } + +instance ToJSON DiversifyRetriever where + toJSON DiversifyRetriever {..} = + omitNulls $ + retrieverBasePairs diversifyBase + <> [ "type" .= diversifyType, + "field" .= diversifyField, + "retriever" .= diversifyRetriever, + "size" .= diversifySize, + "rank_window_size" .= diversifyRankWindowSize, + "query_vector" .= diversifyQueryVector, + "query_vector_builder" .= diversifyQueryVectorBuilder, + "lambda" .= diversifyLambda + ] + +instance FromJSON DiversifyRetriever where + parseJSON = withObject "DiversifyRetriever" $ \o -> + DiversifyRetriever + <$> parseRetrieverBase o + <*> o .: "type" + <*> o .: "field" + <*> o .: "retriever" + <*> o .:? "size" + <*> o .:? "rank_window_size" + <*> o .:? "query_vector" + <*> o .:? "query_vector_builder" + <*> o .:? "lambda" + +-- --------------------------------------------------------------------------- +-- chunk_rescorer (for text_similarity_reranker) +-- --------------------------------------------------------------------------- + +-- | Chunking strategy for a 'ChunkRescorer'. Matches the @strategy@ field +-- of @_types.mapping.ChunkRescorerChunkingSettings@. +data ChunkRescorerChunkingStrategy + = ChunkingStrategySentence + | ChunkingStrategyWord + | ChunkingStrategyNone + | ChunkingStrategyRecursive + deriving stock (Eq, Show) + +instance ToJSON ChunkRescorerChunkingStrategy where + toJSON ChunkingStrategySentence = String "sentence" + toJSON ChunkingStrategyWord = String "word" + toJSON ChunkingStrategyNone = String "none" + toJSON ChunkingStrategyRecursive = String "recursive" + +instance FromJSON ChunkRescorerChunkingStrategy where + parseJSON = withText "ChunkRescorerChunkingStrategy" $ \case + "sentence" -> pure ChunkingStrategySentence + "word" -> pure ChunkingStrategyWord + "none" -> pure ChunkingStrategyNone + "recursive" -> pure ChunkingStrategyRecursive + other -> fail $ "Unknown chunking strategy: " <> T.unpack other + +-- | Chunking settings applied when rescoring only the best matching +-- chunks. @max_chunk_size@ is required server-side. +data ChunkRescorerChunkingSettings = ChunkRescorerChunkingSettings + { crcsMaxChunkSize :: Int, + crcsOverlap :: Maybe Int, + crcsSentenceOverlap :: Maybe Int, + crcsSeparatorGroup :: Maybe Text, + crcsSeparators :: Maybe [Text], + crcsStrategy :: Maybe ChunkRescorerChunkingStrategy + } + deriving stock (Eq, Show) + +instance ToJSON ChunkRescorerChunkingSettings where + toJSON ChunkRescorerChunkingSettings {..} = + omitNulls + [ "max_chunk_size" .= crcsMaxChunkSize, + "overlap" .= crcsOverlap, + "sentence_overlap" .= crcsSentenceOverlap, + "separator_group" .= crcsSeparatorGroup, + "separators" .= crcsSeparators, + "strategy" .= crcsStrategy + ] + +instance FromJSON ChunkRescorerChunkingSettings where + parseJSON = withObject "ChunkRescorerChunkingSettings" $ \o -> + ChunkRescorerChunkingSettings + <$> o .: "max_chunk_size" + <*> o .:? "overlap" + <*> o .:? "sentence_overlap" + <*> o .:? "separator_group" + <*> o .:? "separators" + <*> o .:? "strategy" + +-- | When set on a 'TextSimilarityRetriever', rerank only the best matching +-- chunks of each document. ES 9.2+. +data ChunkRescorer = ChunkRescorer + { crSize :: Maybe Int, + crChunkingSettings :: Maybe ChunkRescorerChunkingSettings + } + deriving stock (Eq, Show) + +instance ToJSON ChunkRescorer where + toJSON ChunkRescorer {..} = + omitNulls + [ "size" .= crSize, + "chunking_settings" .= crChunkingSettings + ] + +instance FromJSON ChunkRescorer where + parseJSON = withObject "ChunkRescorer" $ \o -> + ChunkRescorer + <$> o .:? "size" + <*> o .:? "chunking_settings" + +-- --------------------------------------------------------------------------- +-- Retriever sum-type wire encoding +-- --------------------------------------------------------------------------- + +-- | First-key discriminator for the 'Retriever' sum. Used by both +-- 'ToJSON' (to pick the wrapping key) and 'FromJSON' (to dispatch). +retrieverTag :: Retriever -> (AK.Key, Value) +retrieverTag (RetrieverStandard r) = ("standard", toJSON r) +retrieverTag (RetrieverKnn r) = ("knn", toJSON r) +retrieverTag (RetrieverRRF r) = ("rrf", toJSON r) +retrieverTag (RetrieverTextSimilarity r) = ("text_similarity_reranker", toJSON r) +retrieverTag (RetrieverRule r) = ("rule", toJSON r) +retrieverTag (RetrieverRescorer r) = ("rescorer", toJSON r) +retrieverTag (RetrieverLinear r) = ("linear", toJSON r) +retrieverTag (RetrieverPinned r) = ("pinned", toJSON r) +retrieverTag (RetrieverDiversify r) = ("diversify", toJSON r) + +instance ToJSON Retriever where + toJSON r = object [tag .= body] + where + (tag, body) = retrieverTag r + +instance FromJSON Retriever where + parseJSON v = withObject "Retriever" (dispatch . KM.toList) v + where + dispatch [(tag, body)] = + case AK.toText tag of + "standard" -> RetrieverStandard <$> parseJSON body + "knn" -> RetrieverKnn <$> parseJSON body + "rrf" -> RetrieverRRF <$> parseJSON body + "text_similarity_reranker" -> RetrieverTextSimilarity <$> parseJSON body + "rule" -> RetrieverRule <$> parseJSON body + "rescorer" -> RetrieverRescorer <$> parseJSON body + "linear" -> RetrieverLinear <$> parseJSON body + "pinned" -> RetrieverPinned <$> parseJSON body + "diversify" -> RetrieverDiversify <$> parseJSON body + other -> + fail $ + "Unknown retriever tag: " + <> T.unpack other + <> ". Expected one of: standard, knn, rrf, text_similarity_reranker, rule, rescorer, linear, pinned, diversify." + dispatch other = + fail $ + "Retriever: expected a single-key object, got " + <> show (length other) + <> " keys: " + <> show (map (AK.toText . fst) other) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Rollup.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Rollup.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Rollup.hs @@ -0,0 +1,1474 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Rollup +-- Description : Types for the Elasticsearch X-Pack Rollup API +-- +-- Defines the request and response shapes for the ES X-Pack Rollup +-- endpoints (under @\/_rollup\/*@). A rollup job periodically reduces a +-- high-granularity source index pattern into a coarser @rollup_index@ by +-- aggregating documents along configurable @groups@ (@date_histogram@, +-- @terms@, @histogram@) and computing @metrics@ (@avg@, @sum@, @max@, +-- @min@, @value_count@) per field. +-- +-- * @PUT /_rollup/job/{job_id}@ — create or update ('RollupJobConfig'). +-- * @DELETE /_rollup/job/{job_id}@ — returns 'Acknowledged'. +-- * @GET /_rollup/job[/{job_id}|_all]@ — 'GetRollupJobsResponse'. +-- * @POST /_rollup/job/{job_id}/_start@ — 'RollupJobStarted'. +-- * @POST /_rollup/job/{job_id}/_stop@ — 'RollupJobStopped' +-- (with 'StopRollupJobOptions' for @wait_for_completion@ \/ @timeout@). +-- * @GET /_rollup/job[/{job_id}|_all]/_stats@ — 'GetRollupJobStatsResponse'. +-- * @GET /_rollup/data/{index}@ — 'RollupCapabilitiesResponse' (job caps). +-- * @GET /{target}/_rollup/data@ — 'RollupCapabilitiesResponse' (index caps). +-- * @GET /{index}/_rollup_search@ — standard 'SearchResult' (body-bearing GET). +-- +-- Rollup ships in Elasticsearch 7.x\/8.x\/9.x (it was deprecated in 8.x +-- and is marked technical-preview throughout, but the wire surface is +-- stable across the three), so these types live in the Common layer +-- alongside SLM\/ILM\/Enrich. OpenSearch does not implement the X-Pack +-- rollup API — it has its own Index Rollups plugin covered by the +-- @OpenSearchN.Types.Rollups@ modules — so calls against an OpenSearch +-- cluster will fail at runtime; the types are still hosted under +-- @Common@ to match the project's SLM\/DiskUsage precedent. +-- +-- The @date_histogram@ group is mandatory and accepts exactly one of +-- @calendar_interval@ \/ @fixed_interval@; both are carried as 'Maybe' +-- 'Text' (time-value strings such as @1h@, @60m@, @1d@) so the +-- caller — and the round-trip from a GET response — can carry whichever +-- the server used without forcing a lossy conversion. Unknown sibling +-- fields survive a round-trip via a per-record @extras :: KeyMap Value@ +-- catch-all, the same strategy used by +-- "Database.Bloodhound.Internal.Versions.Common.Types.Enrich". +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Rollup + ( -- * Identity + RollupJobId (..), + + -- * Job config (PUT body / GET @config@) + RollupJobConfig (..), + defaultRollupJobConfig, + rollupJobConfigIdLens, + rollupJobConfigIndexPatternLens, + rollupJobConfigRollupIndexLens, + rollupJobConfigCronLens, + rollupJobConfigPageSizeLens, + rollupJobConfigGroupsLens, + rollupJobConfigMetricsLens, + rollupJobConfigTimeoutLens, + rollupJobConfigHeadersLens, + rollupJobConfigExtrasLens, + + -- * Groups + RollupGroups (..), + defaultRollupGroups, + rollupGroupsDateHistogramLens, + rollupGroupsTermsLens, + rollupGroupsHistogramLens, + rollupGroupsExtrasLens, + RollupDateHistogramGroup (..), + defaultRollupDateHistogramGroup, + rollupDateHistogramGroupFieldLens, + rollupDateHistogramGroupCalendarIntervalLens, + rollupDateHistogramGroupFixedIntervalLens, + rollupDateHistogramGroupDelayLens, + rollupDateHistogramGroupTimeZoneLens, + rollupDateHistogramGroupExtrasLens, + RollupTermsGroup (..), + rollupTermsGroupFieldsLens, + rollupTermsGroupExtrasLens, + RollupHistogramGroup (..), + rollupHistogramGroupFieldsLens, + rollupHistogramGroupIntervalLens, + rollupHistogramGroupExtrasLens, + + -- * Metrics + RollupJobMetric (..), + RollupJobMetricAgg (..), + rollupJobMetricAggText, + rollupJobMetricFieldLens, + rollupJobMetricMetricsLens, + rollupJobMetricExtrasLens, + + -- * GET job response + GetRollupJobsResponse (..), + getRollupJobsResponseListLens, + RollupJob (..), + rollupJobConfigLens, + rollupJobStatusLens, + rollupJobStatsLens, + RollupJobStatus (..), + rollupJobStatusJobStateLens, + rollupJobStatusUpgradedDocIdLens, + rollupJobStatusExtrasLens, + RollupJobState (..), + rollupJobStateText, + RollupJobStats (..), + rollupJobStatsPagesProcessedLens, + rollupJobStatsDocumentsProcessedLens, + rollupJobStatsRollupsIndexedLens, + rollupJobStatsTriggerCountLens, + rollupJobStatsIndexFailuresLens, + rollupJobStatsIndexTimeInMsLens, + rollupJobStatsIndexTotalLens, + rollupJobStatsSearchFailuresLens, + rollupJobStatsSearchTimeInMsLens, + rollupJobStatsSearchTotalLens, + rollupJobStatsProcessingTimeInMsLens, + rollupJobStatsProcessingTotalLens, + rollupJobStatsExtrasLens, + + -- * Stats endpoint response + GetRollupJobStatsResponse (..), + getRollupJobStatsResponseListLens, + RollupJobStatsEntry (..), + rollupJobStatsEntryJobIdLens, + rollupJobStatsEntryStateLens, + rollupJobStatsEntryStatsLens, + rollupJobStatsEntryExtrasLens, + + -- * Capabilities (shared by both caps endpoints) + RollupCapabilitiesResponse (..), + rollupCapabilitiesResponseToList, + lookupRollupCapabilities, + RollupIndexCapabilities (..), + rollupIndexCapabilitiesJobsLens, + RollupJobCapability (..), + rollupJobCapabilityJobIdLens, + rollupJobCapabilityRollupIndexLens, + rollupJobCapabilityIndexPatternLens, + rollupJobCapabilityFieldsLens, + RollupFieldCapability (..), + rollupFieldCapabilityAggLens, + rollupFieldCapabilityTimeZoneLens, + rollupFieldCapabilityCalendarIntervalLens, + rollupFieldCapabilityFixedIntervalLens, + rollupFieldCapabilityDelayLens, + rollupFieldCapabilityExtrasLens, + RollupCapabilityAgg (..), + rollupCapabilityAggText, + + -- * Stop options + StopRollupJobOptions (..), + defaultStopRollupJobOptions, + stopRollupJobOptionsParams, + stopRollupJobOptionsTimeoutLens, + stopRollupJobOptionsWaitForCompletionLens, + + -- * Start / Stop acknowledgements + RollupJobStarted (..), + rollupJobStartedLens, + RollupJobStopped (..), + rollupJobStoppedLens, + ) +where + +import Data.Aeson +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports + ( Lens', + Parser, + lens, + omitNulls, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Indices + ( IndexPattern (..), + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( FieldName (..), + IndexName, + ) + +-- | Identifies a rollup job in the @\/_rollup\/job\/{job_id}@ URL path. +-- Wraps 'Text' so it round-trips through JSON as a bare string but is +-- distinct at the Haskell type level from Enrich\/SLM policy ids. +newtype RollupJobId = RollupJobId {unRollupJobId :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +------------------------------------------------------------------------------ +-- Job config +------------------------------------------------------------------------------ + +-- | The PUT request body for @PUT /_rollup/job/{job_id}@ and the @config@ +-- value returned by @GET /_rollup/job[/{id}]@. The GET response embeds an +-- additional @id@ field inside the config object (server-injected); it is +-- carried here as 'Maybe' 'RollupJobId' and dropped on encode via +-- 'omitNulls', so a PUT body never emits it while a GET response +-- round-trips cleanly. +data RollupJobConfig = RollupJobConfig + { -- | @id@ — only present in the GET @config@ response; 'Nothing' on + -- PUT (omitted from the body by 'omitNulls'). + rjcId :: Maybe RollupJobId, + -- | @index_pattern@ — source index pattern to roll up (e.g. + -- @sensor-*@). Must not match @rjcRollupIndex@. + rjcIndexPattern :: IndexPattern, + -- | @rollup_index@ — destination index storing the rolled-up docs. + rjcRollupIndex :: IndexName, + -- | @cron@ — schedule ( Quartz-style cron string, e.g. + -- @*/30 * * * * ?@). + rjcCron :: Text, + -- | @page_size@ — bucket results processed per indexer iteration. + rjcPageSize :: Int, + -- | @groups@ — the grouping aggregations; @date_histogram@ is + -- mandatory, @terms@ \/ @histogram@ optional. + rjcGroups :: RollupGroups, + -- | @metrics@ — optional per-field metrics; absent means only + -- doc_counts are collected. + rjcMetrics :: Maybe (NonEmpty RollupJobMetric), + -- | @timeout@ — time value (e.g. @20s@). Server defaults to @20s@. + rjcTimeout :: Maybe Text, + -- | @headers@ — optional headers propagated with outgoing requests. + rjcHeaders :: Maybe (KeyMap Value), + -- | Catch-all for every other sibling field ES adds in future so + -- decode is forward-compatible and @encode . decode@ round-trips. + rjcExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +configKnownKeys :: [Key] +configKnownKeys = + [ "id", + "index_pattern", + "rollup_index", + "cron", + "page_size", + "groups", + "metrics", + "timeout", + "headers" + ] + +-- | A minimal config: one @date_histogram@ group, no metrics, no +-- timeout\/headers\/extras. Intended as a starting point callers then +-- overwrite with the record lenses. +defaultRollupJobConfig :: + IndexPattern -> + IndexName -> + Text -> + Int -> + RollupDateHistogramGroup -> + RollupJobConfig +defaultRollupJobConfig indexPattern rollupIndex cron pageSize dateHistogram = + RollupJobConfig + { rjcId = Nothing, + rjcIndexPattern = indexPattern, + rjcRollupIndex = rollupIndex, + rjcCron = cron, + rjcPageSize = pageSize, + rjcGroups = defaultRollupGroups dateHistogram, + rjcMetrics = Nothing, + rjcTimeout = Nothing, + rjcHeaders = Nothing, + rjcExtras = KM.empty + } + +instance FromJSON RollupJobConfig where + parseJSON = withObject "RollupJobConfig" $ \o -> do + jobId <- o .:? "id" + indexPattern <- o .: "index_pattern" + rollupIndex <- o .: "rollup_index" + cron <- o .: "cron" + pageSize <- o .: "page_size" + groups <- o .: "groups" + metrics <- o .:? "metrics" + timeout <- o .:? "timeout" + headers <- o .:? "headers" + let extras = + KM.fromList $ + filter ((`notElem` configKnownKeys) . fst) $ + KM.toList o + pure + RollupJobConfig + { rjcId = jobId, + rjcIndexPattern = indexPattern, + rjcRollupIndex = rollupIndex, + rjcCron = cron, + rjcPageSize = pageSize, + rjcGroups = groups, + rjcMetrics = metrics, + rjcTimeout = timeout, + rjcHeaders = headers, + rjcExtras = extras + } + +instance ToJSON RollupJobConfig where + toJSON RollupJobConfig {..} = + omitNulls $ + catMaybes + [ ("id" .=) <$> rjcId, + Just ("index_pattern" .= rjcIndexPattern), + Just ("rollup_index" .= rjcRollupIndex), + Just ("cron" .= rjcCron), + Just ("page_size" .= rjcPageSize), + Just ("groups" .= rjcGroups), + ("metrics" .=) . NE.toList <$> rjcMetrics, + ("timeout" .=) <$> rjcTimeout, + ("headers" .=) <$> rjcHeaders + ] + <> [toPair kv | kv <- KM.toList rjcExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- Groups +------------------------------------------------------------------------------ + +-- | The @groups@ object. @date_histogram@ is mandatory; @terms@ and +-- @histogram@ are optional and may be combined freely. Unknown sibling +-- fields survive a round-trip via @rgExtras@. +data RollupGroups = RollupGroups + { rgDateHistogram :: RollupDateHistogramGroup, + rgTerms :: Maybe RollupTermsGroup, + rgHistogram :: Maybe RollupHistogramGroup, + rgExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +groupsKnownKeys :: [Key] +groupsKnownKeys = ["date_histogram", "terms", "histogram"] + +defaultRollupGroups :: RollupDateHistogramGroup -> RollupGroups +defaultRollupGroups dateHistogram = + RollupGroups + { rgDateHistogram = dateHistogram, + rgTerms = Nothing, + rgHistogram = Nothing, + rgExtras = KM.empty + } + +instance FromJSON RollupGroups where + parseJSON = withObject "RollupGroups" $ \o -> do + dh <- o .: "date_histogram" + terms <- o .:? "terms" + histogram <- o .:? "histogram" + let extras = + KM.fromList $ + filter ((`notElem` groupsKnownKeys) . fst) $ + KM.toList o + pure + RollupGroups + { rgDateHistogram = dh, + rgTerms = terms, + rgHistogram = histogram, + rgExtras = extras + } + +instance ToJSON RollupGroups where + toJSON RollupGroups {..} = + omitNulls $ + catMaybes + [ Just ("date_histogram" .= rgDateHistogram), + ("terms" .=) <$> rgTerms, + ("histogram" .=) <$> rgHistogram + ] + <> [toPair kv | kv <- KM.toList rgExtras] + where + toPair (k, v) = k .= v + +-- | The mandatory @date_histogram@ group. Exactly one of +-- @calendar_interval@ \/ @fixed_interval@ must be present; both are +-- carried as 'Maybe' 'Text' so the caller picks the spelling the server +-- expects (@1d@-style calendar vs @60m@-style fixed). +data RollupDateHistogramGroup = RollupDateHistogramGroup + { -- | @field@ — the date field to roll up. + rdhgField :: FieldName, + -- | @calendar_interval@ — calendar time unit (@1d@, @1M@, ...). + rdhgCalendarInterval :: Maybe Text, + -- | @fixed_interval@ — fixed time unit (@60m@, @1h@, ...). + rdhgFixedInterval :: Maybe Text, + -- | @delay@ — how long to wait before rolling up new documents. + rdhgDelay :: Maybe Text, + -- | @time_zone@ — timezone the rollup docs are stored as (default + -- @UTC@ on the server). + rdhgTimeZone :: Maybe Text, + rdhgExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +dateHistogramKnownKeys :: [Key] +dateHistogramKnownKeys = + ["field", "calendar_interval", "fixed_interval", "delay", "time_zone", "interval"] + +defaultRollupDateHistogramGroup :: FieldName -> Text -> RollupDateHistogramGroup +defaultRollupDateHistogramGroup field fixedInterval = + RollupDateHistogramGroup + { rdhgField = field, + rdhgCalendarInterval = Nothing, + rdhgFixedInterval = Just fixedInterval, + rdhgDelay = Nothing, + rdhgTimeZone = Nothing, + rdhgExtras = KM.empty + } + +instance FromJSON RollupDateHistogramGroup where + parseJSON = withObject "RollupDateHistogramGroup" $ \o -> do + field' <- o .: "field" + calInterval <- o .:? "calendar_interval" + fixedInterval <- o .:? "fixed_interval" + delay <- o .:? "delay" + timeZone <- o .:? "time_zone" + let extras = + KM.fromList $ + filter ((`notElem` dateHistogramKnownKeys) . fst) $ + KM.toList o + pure + RollupDateHistogramGroup + { rdhgField = field', + rdhgCalendarInterval = calInterval, + rdhgFixedInterval = fixedInterval, + rdhgDelay = delay, + rdhgTimeZone = timeZone, + rdhgExtras = extras + } + +instance ToJSON RollupDateHistogramGroup where + toJSON RollupDateHistogramGroup {..} = + omitNulls $ + catMaybes + [ Just ("field" .= rdhgField), + ("calendar_interval" .=) <$> rdhgCalendarInterval, + ("fixed_interval" .=) <$> rdhgFixedInterval, + ("delay" .=) <$> rdhgDelay, + ("time_zone" .=) <$> rdhgTimeZone + ] + <> [toPair kv | kv <- KM.toList rdhgExtras] + where + toPair (k, v) = k .= v + +-- | The optional @terms@ group: the set of @keyword@ or numeric fields +-- whose values are enumerated and stored per bucket. +data RollupTermsGroup = RollupTermsGroup + { rtgFields :: NonEmpty FieldName, + rtgExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +termsKnownKeys :: [Key] +termsKnownKeys = ["fields"] + +instance FromJSON RollupTermsGroup where + parseJSON = withObject "RollupTermsGroup" $ \o -> do + fields <- parseFieldList =<< o .: "fields" + let extras = + KM.fromList $ + filter ((`notElem` termsKnownKeys) . fst) $ + KM.toList o + pure RollupTermsGroup {rtgFields = fields, rtgExtras = extras} + where + parseFieldList :: Value -> Parser (NonEmpty FieldName) + parseFieldList (Array xs) + | null xs = fail "rollup terms 'fields' array must be non-empty" + | otherwise = toNonEmptyM (toList xs) + parseFieldList v@(String _) = (:| []) <$> parseJSON v + parseFieldList _ = fail "rollup terms 'fields' must be a string or array of strings" + + toNonEmptyM [] = fail "rollup terms 'fields': unexpected empty array" + toNonEmptyM (h : rest) = (:|) <$> parseJSON h <*> traverse parseJSON rest + +instance ToJSON RollupTermsGroup where + toJSON RollupTermsGroup {..} = + object $ + ("fields" .= NE.toList rtgFields) + : [toPair kv | kv <- KM.toList rtgExtras] + where + toPair (k, v) = k .= v + +-- | The optional @histogram@ group: numeric fields bucketed at a fixed +-- numeric @interval@. +data RollupHistogramGroup = RollupHistogramGroup + { rhgFields :: NonEmpty FieldName, + -- | @interval@ — bucket width (integer). + rhgInterval :: Int, + rhgExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +histogramKnownKeys :: [Key] +histogramKnownKeys = ["fields", "interval"] + +instance FromJSON RollupHistogramGroup where + parseJSON = withObject "RollupHistogramGroup" $ \o -> do + fields <- parseFieldList =<< o .: "fields" + interval <- o .: "interval" + let extras = + KM.fromList $ + filter ((`notElem` histogramKnownKeys) . fst) $ + KM.toList o + pure + RollupHistogramGroup + { rhgFields = fields, + rhgInterval = interval, + rhgExtras = extras + } + where + parseFieldList :: Value -> Parser (NonEmpty FieldName) + parseFieldList (Array xs) + | null xs = fail "rollup histogram 'fields' array must be non-empty" + | otherwise = toNonEmptyM (toList xs) + parseFieldList v@(String _) = (:| []) <$> parseJSON v + parseFieldList _ = fail "rollup histogram 'fields' must be a string or array of strings" + + toNonEmptyM [] = fail "rollup histogram 'fields': unexpected empty array" + toNonEmptyM (h : rest) = (:|) <$> parseJSON h <*> traverse parseJSON rest + +instance ToJSON RollupHistogramGroup where + toJSON RollupHistogramGroup {..} = + object $ + [ "fields" .= NE.toList rhgFields, + "interval" .= rhgInterval + ] + <> [toPair kv | kv <- KM.toList rhgExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- Metrics +------------------------------------------------------------------------------ + +-- | One entry of the @metrics@ array: a target field plus the metric +-- aggregations to collect for it. +data RollupJobMetric = RollupJobMetric + { rmField :: FieldName, + rmMetrics :: NonEmpty RollupJobMetricAgg, + rmExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +metricKnownKeys :: [Key] +metricKnownKeys = ["field", "metrics"] + +instance FromJSON RollupJobMetric where + parseJSON = withObject "RollupJobMetric" $ \o -> do + field' <- o .: "field" + metrics <- parseMetricList =<< o .: "metrics" + let extras = + KM.fromList $ + filter ((`notElem` metricKnownKeys) . fst) $ + KM.toList o + pure + RollupJobMetric + { rmField = field', + rmMetrics = metrics, + rmExtras = extras + } + where + parseMetricList :: Value -> Parser (NonEmpty RollupJobMetricAgg) + parseMetricList (Array xs) + | null xs = fail "rollup metric 'metrics' array must be non-empty" + | otherwise = toNonEmptyM (toList xs) + parseMetricList v@(String _) = (:| []) <$> parseJSON v + parseMetricList _ = fail "rollup metric 'metrics' must be a string or array of strings" + + toNonEmptyM [] = fail "rollup metric 'metrics': unexpected empty array" + toNonEmptyM (h : rest) = (:|) <$> parseJSON h <*> traverse parseJSON rest + +instance ToJSON RollupJobMetric where + toJSON RollupJobMetric {..} = + object $ + [ "field" .= rmField, + "metrics" .= NE.toList rmMetrics + ] + <> [toPair kv | kv <- KM.toList rmExtras] + where + toPair (k, v) = k .= v + +-- | The metric aggregations rollup can collect per field. Documented +-- values: @avg@, @max@, @min@, @sum@, @value_count@; the custom branch +-- absorbs anything newer. +data RollupJobMetricAgg + = RollupJobMetricAggAvg + | RollupJobMetricAggMax + | RollupJobMetricAggMin + | RollupJobMetricAggSum + | RollupJobMetricAggValueCount + | RollupJobMetricAggCustom Text + deriving stock (Eq, Show) + +rollupJobMetricAggText :: RollupJobMetricAgg -> Text +rollupJobMetricAggText = \case + RollupJobMetricAggAvg -> "avg" + RollupJobMetricAggMax -> "max" + RollupJobMetricAggMin -> "min" + RollupJobMetricAggSum -> "sum" + RollupJobMetricAggValueCount -> "value_count" + RollupJobMetricAggCustom t -> t + +instance ToJSON RollupJobMetricAgg where + toJSON = toJSON . rollupJobMetricAggText + +instance FromJSON RollupJobMetricAgg where + parseJSON = withText "RollupJobMetricAgg" $ \t -> pure $ + case t of + "avg" -> RollupJobMetricAggAvg + "max" -> RollupJobMetricAggMax + "min" -> RollupJobMetricAggMin + "sum" -> RollupJobMetricAggSum + "value_count" -> RollupJobMetricAggValueCount + other -> RollupJobMetricAggCustom other + +------------------------------------------------------------------------------ +-- GET job response +------------------------------------------------------------------------------ + +-- | Response body of @GET /_rollup/job[/{id}|_all]@: a @jobs@ array of +-- 'RollupJob' entries. +newtype GetRollupJobsResponse = GetRollupJobsResponse + { unGetRollupJobsResponse :: [RollupJob] + } + deriving stock (Eq, Show) + +instance FromJSON GetRollupJobsResponse where + parseJSON = withObject "GetRollupJobsResponse" $ \o -> + GetRollupJobsResponse . fromMaybe [] <$> (o .:? "jobs") + +instance ToJSON GetRollupJobsResponse where + toJSON (GetRollupJobsResponse js) = object ["jobs" .= js] + +-- | A single rollup job as returned by the GET jobs endpoint: the full +-- 'RollupJobConfig' plus transient 'RollupJobStatus' and 'RollupJobStats'. +data RollupJob = RollupJob + { rjConfig :: RollupJobConfig, + rjStatus :: RollupJobStatus, + rjStats :: RollupJobStats + } + deriving stock (Eq, Show) + +instance FromJSON RollupJob where + parseJSON = withObject "RollupJob" $ \o -> do + config <- o .: "config" + status <- o .: "status" + stats <- o .: "stats" + pure RollupJob {rjConfig = config, rjStatus = status, rjStats = stats} + +instance ToJSON RollupJob where + toJSON RollupJob {..} = + object + [ "config" .= rjConfig, + "status" .= rjStatus, + "stats" .= rjStats + ] + +-- | The @status@ object: the indexer's current 'RollupJobState' plus the +-- bookkeeping @upgraded_doc_id@ flag. Unknown sibling fields survive a +-- round-trip via @rjsExtras@. +data RollupJobStatus = RollupJobStatus + { rjsJobState :: RollupJobState, + rjsUpgradedDocId :: Maybe Bool, + rjsExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +statusKnownKeys :: [Key] +statusKnownKeys = ["job_state", "upgraded_doc_id"] + +instance FromJSON RollupJobStatus where + parseJSON = withObject "RollupJobStatus" $ \o -> do + jobState <- o .: "job_state" + upgraded <- o .:? "upgraded_doc_id" + let extras = + KM.fromList $ + filter ((`notElem` statusKnownKeys) . fst) $ + KM.toList o + pure + RollupJobStatus + { rjsJobState = jobState, + rjsUpgradedDocId = upgraded, + rjsExtras = extras + } + +instance ToJSON RollupJobStatus where + toJSON RollupJobStatus {..} = + omitNulls $ + catMaybes + [ Just ("job_state" .= rjsJobState), + ("upgraded_doc_id" .=) <$> rjsUpgradedDocId + ] + <> [toPair kv | kv <- KM.toList rjsExtras] + where + toPair (k, v) = k .= v + +-- | The current state of a rollup job's indexer. Documented values: +-- @stopped@, @started@, @indexing@, @abort@; the custom branch absorbs +-- anything newer. +data RollupJobState + = RollupJobStateStopped + | RollupJobStateStarted + | RollupJobStateIndexing + | RollupJobStateAbort + | RollupJobStateCustom Text + deriving stock (Eq, Show) + +rollupJobStateText :: RollupJobState -> Text +rollupJobStateText = \case + RollupJobStateStopped -> "stopped" + RollupJobStateStarted -> "started" + RollupJobStateIndexing -> "indexing" + RollupJobStateAbort -> "abort" + RollupJobStateCustom t -> t + +instance ToJSON RollupJobState where + toJSON = toJSON . rollupJobStateText + +instance FromJSON RollupJobState where + parseJSON = withText "RollupJobState" $ \t -> pure $ + case t of + "stopped" -> RollupJobStateStopped + "started" -> RollupJobStateStarted + "indexing" -> RollupJobStateIndexing + "abort" -> RollupJobStateAbort + other -> RollupJobStateCustom other + +-- | The transient per-job statistics. The server resets these on node +-- restart; all numeric fields default to @0@ when absent. Unknown sibling +-- fields survive a round-trip via @rstatExtras@. +data RollupJobStats = RollupJobStats + { rstatPagesProcessed :: Integer, + rstatDocumentsProcessed :: Integer, + rstatRollupsIndexed :: Integer, + rstatTriggerCount :: Integer, + rstatIndexFailures :: Integer, + rstatIndexTimeInMs :: Integer, + rstatIndexTotal :: Integer, + rstatSearchFailures :: Integer, + rstatSearchTimeInMs :: Integer, + rstatSearchTotal :: Integer, + rstatProcessingTimeInMs :: Integer, + rstatProcessingTotal :: Integer, + rstatExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +statsKnownKeys :: [Key] +statsKnownKeys = + [ "pages_processed", + "documents_processed", + "rollups_indexed", + "trigger_count", + "index_failures", + "index_time_in_ms", + "index_total", + "search_failures", + "search_time_in_ms", + "search_total", + "processing_time_in_ms", + "processing_total" + ] + +instance FromJSON RollupJobStats where + parseJSON = withObject "RollupJobStats" $ \o -> do + let extras = + KM.fromList $ + filter ((`notElem` statsKnownKeys) . fst) $ + KM.toList o + pagesProcessed <- o .:? "pages_processed" .!= 0 + documentsProcessed <- o .:? "documents_processed" .!= 0 + rollupsIndexed <- o .:? "rollups_indexed" .!= 0 + triggerCount <- o .:? "trigger_count" .!= 0 + indexFailures <- o .:? "index_failures" .!= 0 + indexTimeInMs <- o .:? "index_time_in_ms" .!= 0 + indexTotal <- o .:? "index_total" .!= 0 + searchFailures <- o .:? "search_failures" .!= 0 + searchTimeInMs <- o .:? "search_time_in_ms" .!= 0 + searchTotal <- o .:? "search_total" .!= 0 + processingTimeInMs <- o .:? "processing_time_in_ms" .!= 0 + processingTotal <- o .:? "processing_total" .!= 0 + pure + RollupJobStats + { rstatPagesProcessed = pagesProcessed, + rstatDocumentsProcessed = documentsProcessed, + rstatRollupsIndexed = rollupsIndexed, + rstatTriggerCount = triggerCount, + rstatIndexFailures = indexFailures, + rstatIndexTimeInMs = indexTimeInMs, + rstatIndexTotal = indexTotal, + rstatSearchFailures = searchFailures, + rstatSearchTimeInMs = searchTimeInMs, + rstatSearchTotal = searchTotal, + rstatProcessingTimeInMs = processingTimeInMs, + rstatProcessingTotal = processingTotal, + rstatExtras = extras + } + +instance ToJSON RollupJobStats where + toJSON RollupJobStats {..} = + object $ + [ "pages_processed" .= rstatPagesProcessed, + "documents_processed" .= rstatDocumentsProcessed, + "rollups_indexed" .= rstatRollupsIndexed, + "trigger_count" .= rstatTriggerCount, + "index_failures" .= rstatIndexFailures, + "index_time_in_ms" .= rstatIndexTimeInMs, + "index_total" .= rstatIndexTotal, + "search_failures" .= rstatSearchFailures, + "search_time_in_ms" .= rstatSearchTimeInMs, + "search_total" .= rstatSearchTotal, + "processing_time_in_ms" .= rstatProcessingTimeInMs, + "processing_total" .= rstatProcessingTotal + ] + <> [toPair kv | kv <- KM.toList rstatExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- Stats endpoint response +------------------------------------------------------------------------------ + +-- | Response body of @GET /_rollup/job[/{id}|_all]/_stats@: a @job_stats@ +-- array of 'RollupJobStatsEntry' entries. Each entry carries the job id, +-- its current state, and the transient stats — a flatter shape than the +-- @status@\/@stats@ pair embedded in the GET-jobs response. +newtype GetRollupJobStatsResponse = GetRollupJobStatsResponse + { unGetRollupJobStatsResponse :: [RollupJobStatsEntry] + } + deriving stock (Eq, Show) + +instance FromJSON GetRollupJobStatsResponse where + parseJSON = withObject "GetRollupJobStatsResponse" $ \o -> + GetRollupJobStatsResponse . fromMaybe [] <$> (o .:? "job_stats") + +instance ToJSON GetRollupJobStatsResponse where + toJSON (GetRollupJobStatsResponse es) = object ["job_stats" .= es] + +-- | One entry of the @job_stats@ array. @state@ uses the same shape as +-- the embedded @status@ object from the GET-jobs response, so it reuses +-- 'RollupJobStatus'. +data RollupJobStatsEntry = RollupJobStatsEntry + { rjseJobId :: RollupJobId, + rjseState :: RollupJobStatus, + rjseStats :: RollupJobStats, + rjseExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +statsEntryKnownKeys :: [Key] +statsEntryKnownKeys = ["job_id", "state", "stats"] + +instance FromJSON RollupJobStatsEntry where + parseJSON = withObject "RollupJobStatsEntry" $ \o -> do + jobId <- o .: "job_id" + state <- o .: "state" + stats <- o .: "stats" + let extras = + KM.fromList $ + filter ((`notElem` statsEntryKnownKeys) . fst) $ + KM.toList o + pure + RollupJobStatsEntry + { rjseJobId = jobId, + rjseState = state, + rjseStats = stats, + rjseExtras = extras + } + +instance ToJSON RollupJobStatsEntry where + toJSON RollupJobStatsEntry {..} = + omitNulls $ + catMaybes + [ Just ("job_id" .= rjseJobId), + Just ("state" .= rjseState), + Just ("stats" .= rjseStats) + ] + <> [toPair kv | kv <- KM.toList rjseExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- Capabilities +------------------------------------------------------------------------------ + +-- | Response body of both @GET /_rollup/data/{index}@ and +-- @GET /{target}/_rollup/data@: a 'Map' keyed by the index (pattern) the +-- capabilities pertain to. The two endpoints share the same response +-- shape, differing only in whether the keys are source patterns (job caps) +-- or concrete rollup indices (index caps). +newtype RollupCapabilitiesResponse = RollupCapabilitiesResponse + { unRollupCapabilitiesResponse :: Map Text RollupIndexCapabilities + } + deriving stock (Eq, Show) + +instance FromJSON RollupCapabilitiesResponse where + parseJSON = withObject "RollupCapabilitiesResponse" $ \o -> do + kvPairs <- + traverse + (\(k, v) -> (toText k,) <$> parseJSON v) + (KM.toList o) + pure $ RollupCapabilitiesResponse (Map.fromList kvPairs) + +instance ToJSON RollupCapabilitiesResponse where + toJSON (RollupCapabilitiesResponse m) = + object [fromText k .= v | (k, v) <- Map.toList m] + +-- | The per-index capabilities object: a @rollup_jobs@ array of +-- 'RollupJobCapability'. +newtype RollupIndexCapabilities = RollupIndexCapabilities + { ricJobs :: [RollupJobCapability] + } + deriving stock (Eq, Show) + +instance FromJSON RollupIndexCapabilities where + parseJSON = withObject "RollupIndexCapabilities" $ \o -> do + jobs <- fromMaybe [] <$> (o .:? "rollup_jobs") + pure RollupIndexCapabilities {ricJobs = jobs} + +instance ToJSON RollupIndexCapabilities where + toJSON RollupIndexCapabilities {..} = + object ["rollup_jobs" .= ricJobs] + +-- | Helper: flatten the response into a list of @(index, caps)@ pairs. +rollupCapabilitiesResponseToList :: + RollupCapabilitiesResponse -> [(Text, RollupIndexCapabilities)] +rollupCapabilitiesResponseToList (RollupCapabilitiesResponse m) = + Map.toList m + +-- | Helper: look up the capabilities for a single index (pattern). +lookupRollupCapabilities :: + Text -> RollupCapabilitiesResponse -> Maybe RollupIndexCapabilities +lookupRollupCapabilities k (RollupCapabilitiesResponse m) = + Map.lookup k m + +-- | The capabilities of a single rollup job: its id, target rollup index, +-- source index pattern, and the per-field aggregation capabilities. The +-- @fields@ object is keyed by field name as a bare 'Text' (rather than a +-- typed 'FieldName') because 'FieldName' does not carry an 'Ord' instance +-- and so cannot serve as a 'Map' key without a shared-type change. +data RollupJobCapability = RollupJobCapability + { rjcJobId :: RollupJobId, + rjcRollupIndexCap :: IndexName, + rjcIndexPatternCap :: IndexPattern, + rjcFields :: Map Text [RollupFieldCapability] + } + deriving stock (Eq, Show) + +instance FromJSON RollupJobCapability where + parseJSON = withObject "RollupJobCapability" $ \o -> do + jobId <- o .: "job_id" + rollupIndex <- o .: "rollup_index" + indexPattern <- o .: "index_pattern" + fields <- o .:? "fields" .!= Map.empty + pure + RollupJobCapability + { rjcJobId = jobId, + rjcRollupIndexCap = rollupIndex, + rjcIndexPatternCap = indexPattern, + rjcFields = fields + } + +instance ToJSON RollupJobCapability where + toJSON RollupJobCapability {..} = + omitNulls + [ "job_id" .= rjcJobId, + "rollup_index" .= rjcRollupIndexCap, + "index_pattern" .= rjcIndexPatternCap, + "fields" .= rjcFields + ] + +-- | The capability of a single field under a single job: which aggregation +-- can be performed, plus (for @date_histogram@) the timezone and interval +-- the job was configured with. Unknown sibling fields survive a +-- round-trip via @rfcExtras@. +data RollupFieldCapability = RollupFieldCapability + { rfcAgg :: RollupCapabilityAgg, + rfcTimeZone :: Maybe Text, + rfcCalendarInterval :: Maybe Text, + rfcFixedInterval :: Maybe Text, + rfcDelay :: Maybe Text, + rfcExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +fieldCapabilityKnownKeys :: [Key] +fieldCapabilityKnownKeys = + ["agg", "time_zone", "calendar_interval", "fixed_interval", "delay"] + +instance FromJSON RollupFieldCapability where + parseJSON = withObject "RollupFieldCapability" $ \o -> do + agg <- o .: "agg" + timeZone <- o .:? "time_zone" + calendarInterval <- o .:? "calendar_interval" + fixedInterval <- o .:? "fixed_interval" + delay <- o .:? "delay" + let extras = + KM.fromList $ + filter ((`notElem` fieldCapabilityKnownKeys) . fst) $ + KM.toList o + pure + RollupFieldCapability + { rfcAgg = agg, + rfcTimeZone = timeZone, + rfcCalendarInterval = calendarInterval, + rfcFixedInterval = fixedInterval, + rfcDelay = delay, + rfcExtras = extras + } + +instance ToJSON RollupFieldCapability where + toJSON RollupFieldCapability {..} = + omitNulls $ + catMaybes + [ Just ("agg" .= rfcAgg), + ("time_zone" .=) <$> rfcTimeZone, + ("calendar_interval" .=) <$> rfcCalendarInterval, + ("fixed_interval" .=) <$> rfcFixedInterval, + ("delay" .=) <$> rfcDelay + ] + <> [toPair kv | kv <- KM.toList rfcExtras] + where + toPair (k, v) = k .= v + +-- | The aggregation a rollup job makes available on a field. Documented +-- values: @avg@, @max@, @min@, @sum@, @value_count@, @terms@, +-- @histogram@, @date_histogram@; the custom branch absorbs anything newer. +data RollupCapabilityAgg + = RollupCapabilityAggAvg + | RollupCapabilityAggMax + | RollupCapabilityAggMin + | RollupCapabilityAggSum + | RollupCapabilityAggValueCount + | RollupCapabilityAggTerms + | RollupCapabilityAggHistogram + | RollupCapabilityAggDateHistogram + | RollupCapabilityAggCustom Text + deriving stock (Eq, Show) + +rollupCapabilityAggText :: RollupCapabilityAgg -> Text +rollupCapabilityAggText = \case + RollupCapabilityAggAvg -> "avg" + RollupCapabilityAggMax -> "max" + RollupCapabilityAggMin -> "min" + RollupCapabilityAggSum -> "sum" + RollupCapabilityAggValueCount -> "value_count" + RollupCapabilityAggTerms -> "terms" + RollupCapabilityAggHistogram -> "histogram" + RollupCapabilityAggDateHistogram -> "date_histogram" + RollupCapabilityAggCustom t -> t + +instance ToJSON RollupCapabilityAgg where + toJSON = toJSON . rollupCapabilityAggText + +instance FromJSON RollupCapabilityAgg where + parseJSON = withText "RollupCapabilityAgg" $ \t -> pure $ + case t of + "avg" -> RollupCapabilityAggAvg + "max" -> RollupCapabilityAggMax + "min" -> RollupCapabilityAggMin + "sum" -> RollupCapabilityAggSum + "value_count" -> RollupCapabilityAggValueCount + "terms" -> RollupCapabilityAggTerms + "histogram" -> RollupCapabilityAggHistogram + "date_histogram" -> RollupCapabilityAggDateHistogram + other -> RollupCapabilityAggCustom other + +------------------------------------------------------------------------------ +-- Stop options +------------------------------------------------------------------------------ + +-- | URI parameters accepted by @POST /_rollup/job/{job_id}/_stop@: +-- @wait_for_completion@ (defaults to @false@ on the server) and +-- @timeout@ (a time value, defaults to @30s@). +data StopRollupJobOptions = StopRollupJobOptions + { srjoWaitForCompletion :: Maybe Bool, + srjoTimeout :: Maybe Text + } + deriving stock (Eq, Show) + +-- | An empty options record — encodes to no query string, reproducing the +-- parameterless 'stopRollupJob'. +defaultStopRollupJobOptions :: StopRollupJobOptions +defaultStopRollupJobOptions = + StopRollupJobOptions + { srjoWaitForCompletion = Nothing, + srjoTimeout = Nothing + } + +-- | Render a 'StopRollupJobOptions' as a @(key, value)@ list for +-- 'withQueries'. 'Nothing' fields are omitted. +stopRollupJobOptionsParams :: StopRollupJobOptions -> [(Text, Maybe Text)] +stopRollupJobOptionsParams StopRollupJobOptions {..} = + catMaybes + [ ("wait_for_completion",) . Just . boolText <$> srjoWaitForCompletion, + ("timeout",) . Just <$> srjoTimeout + ] + where + boolText True = "true" + boolText False = "false" + +------------------------------------------------------------------------------ +-- Start / Stop acknowledgements +------------------------------------------------------------------------------ + +-- | Response of @POST /_rollup/job/{job_id}/_start@: @{"started": true}@. +newtype RollupJobStarted = RollupJobStarted + { unRollupJobStarted :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON RollupJobStarted where + parseJSON = withObject "RollupJobStarted" $ \o -> + RollupJobStarted <$> o .:? "started" .!= True + +instance ToJSON RollupJobStarted where + toJSON (RollupJobStarted b) = object ["started" .= b] + +-- | Response of @POST /_rollup/job/{job_id}/_stop@: @{"stopped": true}@. +-- The @stopped@ flag defaults to 'True' on a missing field so an empty +-- body still parses as a successful stop (ES emits the body in practice). +newtype RollupJobStopped = RollupJobStopped + { unRollupJobStopped :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON RollupJobStopped where + parseJSON = withObject "RollupJobStopped" $ \o -> + RollupJobStopped <$> o .:? "stopped" .!= True + +instance ToJSON RollupJobStopped where + toJSON (RollupJobStopped b) = object ["stopped" .= b] + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +rollupJobConfigIdLens :: Lens' RollupJobConfig (Maybe RollupJobId) +rollupJobConfigIdLens = lens rjcId (\x y -> x {rjcId = y}) + +rollupJobConfigIndexPatternLens :: + Lens' RollupJobConfig IndexPattern +rollupJobConfigIndexPatternLens = + lens rjcIndexPattern (\x y -> x {rjcIndexPattern = y}) + +rollupJobConfigRollupIndexLens :: + Lens' RollupJobConfig IndexName +rollupJobConfigRollupIndexLens = + lens rjcRollupIndex (\x y -> x {rjcRollupIndex = y}) + +rollupJobConfigCronLens :: Lens' RollupJobConfig Text +rollupJobConfigCronLens = + lens rjcCron (\x y -> x {rjcCron = y}) + +rollupJobConfigPageSizeLens :: Lens' RollupJobConfig Int +rollupJobConfigPageSizeLens = + lens rjcPageSize (\x y -> x {rjcPageSize = y}) + +rollupJobConfigGroupsLens :: + Lens' RollupJobConfig RollupGroups +rollupJobConfigGroupsLens = + lens rjcGroups (\x y -> x {rjcGroups = y}) + +rollupJobConfigMetricsLens :: + Lens' RollupJobConfig (Maybe (NonEmpty RollupJobMetric)) +rollupJobConfigMetricsLens = + lens rjcMetrics (\x y -> x {rjcMetrics = y}) + +rollupJobConfigTimeoutLens :: + Lens' RollupJobConfig (Maybe Text) +rollupJobConfigTimeoutLens = + lens rjcTimeout (\x y -> x {rjcTimeout = y}) + +rollupJobConfigHeadersLens :: + Lens' RollupJobConfig (Maybe (KeyMap Value)) +rollupJobConfigHeadersLens = + lens rjcHeaders (\x y -> x {rjcHeaders = y}) + +rollupJobConfigExtrasLens :: + Lens' RollupJobConfig (KeyMap Value) +rollupJobConfigExtrasLens = + lens rjcExtras (\x y -> x {rjcExtras = y}) + +rollupGroupsDateHistogramLens :: + Lens' RollupGroups RollupDateHistogramGroup +rollupGroupsDateHistogramLens = + lens rgDateHistogram (\x y -> x {rgDateHistogram = y}) + +rollupGroupsTermsLens :: + Lens' RollupGroups (Maybe RollupTermsGroup) +rollupGroupsTermsLens = + lens rgTerms (\x y -> x {rgTerms = y}) + +rollupGroupsHistogramLens :: + Lens' RollupGroups (Maybe RollupHistogramGroup) +rollupGroupsHistogramLens = + lens rgHistogram (\x y -> x {rgHistogram = y}) + +rollupGroupsExtrasLens :: Lens' RollupGroups (KeyMap Value) +rollupGroupsExtrasLens = + lens rgExtras (\x y -> x {rgExtras = y}) + +rollupDateHistogramGroupFieldLens :: + Lens' RollupDateHistogramGroup FieldName +rollupDateHistogramGroupFieldLens = + lens rdhgField (\x y -> x {rdhgField = y}) + +rollupDateHistogramGroupCalendarIntervalLens :: + Lens' RollupDateHistogramGroup (Maybe Text) +rollupDateHistogramGroupCalendarIntervalLens = + lens rdhgCalendarInterval (\x y -> x {rdhgCalendarInterval = y}) + +rollupDateHistogramGroupFixedIntervalLens :: + Lens' RollupDateHistogramGroup (Maybe Text) +rollupDateHistogramGroupFixedIntervalLens = + lens rdhgFixedInterval (\x y -> x {rdhgFixedInterval = y}) + +rollupDateHistogramGroupDelayLens :: + Lens' RollupDateHistogramGroup (Maybe Text) +rollupDateHistogramGroupDelayLens = + lens rdhgDelay (\x y -> x {rdhgDelay = y}) + +rollupDateHistogramGroupTimeZoneLens :: + Lens' RollupDateHistogramGroup (Maybe Text) +rollupDateHistogramGroupTimeZoneLens = + lens rdhgTimeZone (\x y -> x {rdhgTimeZone = y}) + +rollupDateHistogramGroupExtrasLens :: + Lens' RollupDateHistogramGroup (KeyMap Value) +rollupDateHistogramGroupExtrasLens = + lens rdhgExtras (\x y -> x {rdhgExtras = y}) + +rollupTermsGroupFieldsLens :: + Lens' RollupTermsGroup (NonEmpty FieldName) +rollupTermsGroupFieldsLens = + lens rtgFields (\x y -> x {rtgFields = y}) + +rollupTermsGroupExtrasLens :: + Lens' RollupTermsGroup (KeyMap Value) +rollupTermsGroupExtrasLens = + lens rtgExtras (\x y -> x {rtgExtras = y}) + +rollupHistogramGroupFieldsLens :: + Lens' RollupHistogramGroup (NonEmpty FieldName) +rollupHistogramGroupFieldsLens = + lens rhgFields (\x y -> x {rhgFields = y}) + +rollupHistogramGroupIntervalLens :: + Lens' RollupHistogramGroup Int +rollupHistogramGroupIntervalLens = + lens rhgInterval (\x y -> x {rhgInterval = y}) + +rollupHistogramGroupExtrasLens :: + Lens' RollupHistogramGroup (KeyMap Value) +rollupHistogramGroupExtrasLens = + lens rhgExtras (\x y -> x {rhgExtras = y}) + +rollupJobMetricFieldLens :: Lens' RollupJobMetric FieldName +rollupJobMetricFieldLens = + lens rmField (\x y -> x {rmField = y}) + +rollupJobMetricMetricsLens :: + Lens' RollupJobMetric (NonEmpty RollupJobMetricAgg) +rollupJobMetricMetricsLens = + lens rmMetrics (\x y -> x {rmMetrics = y}) + +rollupJobMetricExtrasLens :: Lens' RollupJobMetric (KeyMap Value) +rollupJobMetricExtrasLens = + lens rmExtras (\x y -> x {rmExtras = y}) + +getRollupJobsResponseListLens :: + Lens' GetRollupJobsResponse [RollupJob] +getRollupJobsResponseListLens = + lens + unGetRollupJobsResponse + (\_ y -> GetRollupJobsResponse y) + +rollupJobConfigLens :: Lens' RollupJob RollupJobConfig +rollupJobConfigLens = + lens rjConfig (\x y -> x {rjConfig = y}) + +rollupJobStatusLens :: Lens' RollupJob RollupJobStatus +rollupJobStatusLens = + lens rjStatus (\x y -> x {rjStatus = y}) + +rollupJobStatsLens :: Lens' RollupJob RollupJobStats +rollupJobStatsLens = + lens rjStats (\x y -> x {rjStats = y}) + +rollupJobStatusJobStateLens :: + Lens' RollupJobStatus RollupJobState +rollupJobStatusJobStateLens = + lens rjsJobState (\x y -> x {rjsJobState = y}) + +rollupJobStatusUpgradedDocIdLens :: + Lens' RollupJobStatus (Maybe Bool) +rollupJobStatusUpgradedDocIdLens = + lens rjsUpgradedDocId (\x y -> x {rjsUpgradedDocId = y}) + +rollupJobStatusExtrasLens :: + Lens' RollupJobStatus (KeyMap Value) +rollupJobStatusExtrasLens = + lens rjsExtras (\x y -> x {rjsExtras = y}) + +rollupJobStatsPagesProcessedLens :: + Lens' RollupJobStats Integer +rollupJobStatsPagesProcessedLens = + lens rstatPagesProcessed (\x y -> x {rstatPagesProcessed = y}) + +rollupJobStatsDocumentsProcessedLens :: + Lens' RollupJobStats Integer +rollupJobStatsDocumentsProcessedLens = + lens rstatDocumentsProcessed (\x y -> x {rstatDocumentsProcessed = y}) + +rollupJobStatsRollupsIndexedLens :: + Lens' RollupJobStats Integer +rollupJobStatsRollupsIndexedLens = + lens rstatRollupsIndexed (\x y -> x {rstatRollupsIndexed = y}) + +rollupJobStatsTriggerCountLens :: + Lens' RollupJobStats Integer +rollupJobStatsTriggerCountLens = + lens rstatTriggerCount (\x y -> x {rstatTriggerCount = y}) + +rollupJobStatsIndexFailuresLens :: + Lens' RollupJobStats Integer +rollupJobStatsIndexFailuresLens = + lens rstatIndexFailures (\x y -> x {rstatIndexFailures = y}) + +rollupJobStatsIndexTimeInMsLens :: + Lens' RollupJobStats Integer +rollupJobStatsIndexTimeInMsLens = + lens rstatIndexTimeInMs (\x y -> x {rstatIndexTimeInMs = y}) + +rollupJobStatsIndexTotalLens :: + Lens' RollupJobStats Integer +rollupJobStatsIndexTotalLens = + lens rstatIndexTotal (\x y -> x {rstatIndexTotal = y}) + +rollupJobStatsSearchFailuresLens :: + Lens' RollupJobStats Integer +rollupJobStatsSearchFailuresLens = + lens rstatSearchFailures (\x y -> x {rstatSearchFailures = y}) + +rollupJobStatsSearchTimeInMsLens :: + Lens' RollupJobStats Integer +rollupJobStatsSearchTimeInMsLens = + lens rstatSearchTimeInMs (\x y -> x {rstatSearchTimeInMs = y}) + +rollupJobStatsSearchTotalLens :: + Lens' RollupJobStats Integer +rollupJobStatsSearchTotalLens = + lens rstatSearchTotal (\x y -> x {rstatSearchTotal = y}) + +rollupJobStatsProcessingTimeInMsLens :: + Lens' RollupJobStats Integer +rollupJobStatsProcessingTimeInMsLens = + lens rstatProcessingTimeInMs (\x y -> x {rstatProcessingTimeInMs = y}) + +rollupJobStatsProcessingTotalLens :: + Lens' RollupJobStats Integer +rollupJobStatsProcessingTotalLens = + lens rstatProcessingTotal (\x y -> x {rstatProcessingTotal = y}) + +rollupJobStatsExtrasLens :: + Lens' RollupJobStats (KeyMap Value) +rollupJobStatsExtrasLens = + lens rstatExtras (\x y -> x {rstatExtras = y}) + +getRollupJobStatsResponseListLens :: + Lens' GetRollupJobStatsResponse [RollupJobStatsEntry] +getRollupJobStatsResponseListLens = + lens + unGetRollupJobStatsResponse + (\_ y -> GetRollupJobStatsResponse y) + +rollupJobStatsEntryJobIdLens :: + Lens' RollupJobStatsEntry RollupJobId +rollupJobStatsEntryJobIdLens = + lens rjseJobId (\x y -> x {rjseJobId = y}) + +rollupJobStatsEntryStateLens :: + Lens' RollupJobStatsEntry RollupJobStatus +rollupJobStatsEntryStateLens = + lens rjseState (\x y -> x {rjseState = y}) + +rollupJobStatsEntryStatsLens :: + Lens' RollupJobStatsEntry RollupJobStats +rollupJobStatsEntryStatsLens = + lens rjseStats (\x y -> x {rjseStats = y}) + +rollupJobStatsEntryExtrasLens :: + Lens' RollupJobStatsEntry (KeyMap Value) +rollupJobStatsEntryExtrasLens = + lens rjseExtras (\x y -> x {rjseExtras = y}) + +rollupIndexCapabilitiesJobsLens :: + Lens' RollupIndexCapabilities [RollupJobCapability] +rollupIndexCapabilitiesJobsLens = + lens ricJobs (\x y -> x {ricJobs = y}) + +rollupJobCapabilityJobIdLens :: + Lens' RollupJobCapability RollupJobId +rollupJobCapabilityJobIdLens = + lens rjcJobId (\x y -> x {rjcJobId = y}) + +rollupJobCapabilityRollupIndexLens :: + Lens' RollupJobCapability IndexName +rollupJobCapabilityRollupIndexLens = + lens rjcRollupIndexCap (\x y -> x {rjcRollupIndexCap = y}) + +rollupJobCapabilityIndexPatternLens :: + Lens' RollupJobCapability IndexPattern +rollupJobCapabilityIndexPatternLens = + lens rjcIndexPatternCap (\x y -> x {rjcIndexPatternCap = y}) + +rollupJobCapabilityFieldsLens :: + Lens' RollupJobCapability (Map Text [RollupFieldCapability]) +rollupJobCapabilityFieldsLens = + lens rjcFields (\x y -> x {rjcFields = y}) + +rollupFieldCapabilityAggLens :: + Lens' RollupFieldCapability RollupCapabilityAgg +rollupFieldCapabilityAggLens = + lens rfcAgg (\x y -> x {rfcAgg = y}) + +rollupFieldCapabilityTimeZoneLens :: + Lens' RollupFieldCapability (Maybe Text) +rollupFieldCapabilityTimeZoneLens = + lens rfcTimeZone (\x y -> x {rfcTimeZone = y}) + +rollupFieldCapabilityCalendarIntervalLens :: + Lens' RollupFieldCapability (Maybe Text) +rollupFieldCapabilityCalendarIntervalLens = + lens rfcCalendarInterval (\x y -> x {rfcCalendarInterval = y}) + +rollupFieldCapabilityFixedIntervalLens :: + Lens' RollupFieldCapability (Maybe Text) +rollupFieldCapabilityFixedIntervalLens = + lens rfcFixedInterval (\x y -> x {rfcFixedInterval = y}) + +rollupFieldCapabilityDelayLens :: + Lens' RollupFieldCapability (Maybe Text) +rollupFieldCapabilityDelayLens = + lens rfcDelay (\x y -> x {rfcDelay = y}) + +rollupFieldCapabilityExtrasLens :: + Lens' RollupFieldCapability (KeyMap Value) +rollupFieldCapabilityExtrasLens = + lens rfcExtras (\x y -> x {rfcExtras = y}) + +stopRollupJobOptionsTimeoutLens :: + Lens' StopRollupJobOptions (Maybe Text) +stopRollupJobOptionsTimeoutLens = + lens srjoTimeout (\x y -> x {srjoTimeout = y}) + +stopRollupJobOptionsWaitForCompletionLens :: + Lens' StopRollupJobOptions (Maybe Bool) +stopRollupJobOptionsWaitForCompletionLens = + lens srjoWaitForCompletion (\x y -> x {srjoWaitForCompletion = y}) + +rollupJobStartedLens :: Lens' RollupJobStarted Bool +rollupJobStartedLens = + lens unRollupJobStarted (\_ y -> RollupJobStarted y) + +rollupJobStoppedLens :: Lens' RollupJobStopped Bool +rollupJobStoppedLens = + lens unRollupJobStopped (\_ y -> RollupJobStopped y) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/SLM.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/SLM.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/SLM.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.SLM +-- Description : Types for the Elasticsearch Snapshot Lifecycle Management (SLM) API +-- +-- Defines the request and response shapes for the ES SLM API: +-- +-- * @PUT /_slm/policy/{id}@ — 'SLMPolicy' request body. +-- * @GET /_slm/policy[/{id}]@ — 'SLMPolicyInfo' / 'SLMPolicies' response. +-- * @DELETE /_slm/policy/{id}@ — no body (returns 'Acknowledged'). +-- * @POST /_slm/execute/{id}@ — 'SLMExecutionResult' response. +-- * @GET /_slm/status@ — 'SLMStatus' / 'SLMOperationMode' response. +-- +-- SLM ships in Elasticsearch 7.4 and later (ES7\/ES8\/ES9 share the same +-- surface), which is why these types live in the Common layer alongside +-- the ILM types. The wire shape mirrors the ILM API closely: SLM has the +-- same id-keyed GET response, the same @RUNNING\/STOPPING\/STOPPED@ +-- operation-mode enum, and the same id-stamping idiom in +-- "Database.Bloodhound.Common.Requests"'s @getSLMPolicy@. +-- +-- Unlike ILM (see "Database.Bloodhound.Internal.Versions.Common.Types.ILM"), +-- SLM does @not@ wrap the policy under a @policy@ key in the @PUT@ request +-- body: ES expects @schedule@, @name@, @repository@, @config@ and +-- @retention@ directly at the top level of the request body. 'SLMPolicy''s +-- 'ToJSON' therefore emits the carried 'Value' verbatim and 'FromJSON' +-- accepts any JSON object verbatim. The caller is responsible for shaping +-- the body, e.g.: +-- +-- @ +-- 'SLMPolicy' '$' 'object' +-- [ "schedule" '.=' String "\"0 0 1 * * ?\"", +-- "name" '.=' String "\"\"", +-- "repository" '.=' String "my-repo", +-- "retention" '.=' object ["expire_after" '.=' String "30d"] +-- ] +-- @ +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.SLM + ( SLMPolicyId (..), + SLMPolicy (..), + SLMPolicyInfo (..), + SLMPolicies (..), + SLMExecutionResult (..), + SLMOperationMode (..), + SLMStatus (..), + + -- * Optics + slmPolicyBodyLens, + slmPolicyInfoIdLens, + slmPolicyInfoVersionLens, + slmPolicyInfoModifiedDateLens, + slmPolicyInfoModifiedDateStringLens, + slmPolicyInfoPolicyLens, + slmPoliciesListLens, + slmExecutionSnapshotLens, + slmStatusOperationModeLens, + slmStatusSnapshotCreationCountLens, + slmStatusSnapshotDeletionCountLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( SnapshotName (..), + ) + +-- | Identifies an SLM policy in the @\/_slm\/policy\/{id}@ URL path. Wraps +-- 'Text' so it round-trips through JSON as a bare string but is distinct at +-- the Haskell type level from ILM's 'Database.Bloodhound.Internal.Versions.Common.Types.ILM.ILMPolicyId' +-- (index lifecycle policies) and from OpenSearch's plugin-local policy ids. +newtype SLMPolicyId = SLMPolicyId {unSLMPolicyId :: Text} + deriving newtype (Eq, Show, ToJSON, FromJSON) + +-- | Request body of @PUT /_slm/policy/{id}@. ES expects the SLM policy +-- fields (@schedule@, @name@, @repository@, optional @config@ and +-- @retention@) at the top level of the body — there is @no@ @policy@ +-- wrapper like ILM has. The body is therefore carried as an opaque +-- 'Value' that 'ToJSON' emits verbatim; a typed SLM policy schema is +-- tracked as a follow-up (the same approach the ILM module takes for +-- 'Database.Bloodhound.Internal.Versions.Common.Types.ILM.ILMPolicy'). +newtype SLMPolicy = SLMPolicy {unSLMPolicy :: Value} + deriving stock (Eq, Show) + +instance ToJSON SLMPolicy where + toJSON (SLMPolicy body) = body + +instance FromJSON SLMPolicy where + -- SLM request bodies are JSON objects. Reject non-objects so that + -- @decode "[1,2,3]" :: Maybe SLMPolicy@ yields 'Nothing', protecting + -- callers from trivially malformed input. (The same shape is enforced + -- by the rejection-case tests in "Test.SLMSpec".) + parseJSON = withObject "SLMPolicy" (pure . SLMPolicy . Object) + +-- | A single policy entry as returned by @GET /_slm/policy[\/{id}]@. The +-- @policy@ sub-object is the full SLM policy body (@schedule@, @name@, +-- @repository@, @config@, @retention@) and is carried as an opaque +-- 'Value' pending a typed schema — the same treatment already used for +-- 'Database.Bloodhound.Internal.Versions.Common.Types.ILM.ILMPolicyInfo'. +data SLMPolicyInfo = SLMPolicyInfo + { slmPolicyInfoId :: SLMPolicyId, + -- | @version@ is server-managed and may be @-1@ / absent for policies + -- that have never been saved. + slmPolicyInfoVersion :: Maybe Int, + -- | Epoch milliseconds. Negative or absent on unmodified policies. + slmPolicyInfoModifiedDate :: Maybe Int, + slmPolicyInfoModifiedDateString :: Maybe Text, + slmPolicyInfoPolicy :: Value + } + deriving stock (Eq, Show) + +-- | The id is the JSON object key in the outer response, not a field +-- inside the value; 'slmPolicyInfoId' is therefore filled with @""@ here +-- and the list-decoding wrapper 'SLMPolicies' overwrites it with the real +-- key. This matches the ILM @GET \/policy@ decode — see the Haddock on +-- 'Database.Bloodhound.Internal.Versions.Common.Types.ILM.ILMPolicyInfo'. +-- +-- The @modified_date@ field is tolerant of both wire shapes seen across +-- supported ES versions: early 7.x emits it as an epoch-millis 'Number' +-- alongside a @modified_date_string@ sibling, while ES 7.17+ (and 8.x\/9.x) +-- emit it as an ISO-8601 'String' and drop the @*_string@ sibling. A +-- 'Number' populates 'slmPolicyInfoModifiedDate'; a 'String' falls through +-- to 'slmPolicyInfoModifiedDateString' (an explicit @modified_date_string@ +-- sibling, when present, takes precedence on either path). +instance FromJSON SLMPolicyInfo where + parseJSON = withObject "SLMPolicyInfo" $ \o -> do + slmPolicyInfoVersion <- o .:? "version" + rawModifiedDate <- (o .:? "modified_date") :: Parser (Maybe Value) + explicitDateString <- o .:? "modified_date_string" + let (slmPolicyInfoModifiedDate, inheritedDateString) = + case rawModifiedDate of + Just (Number n) -> (Just (round n), Nothing) + Just (String s) -> (Nothing, Just s) + _ -> (Nothing, Nothing) + slmPolicyInfoModifiedDateString = explicitDateString <|> inheritedDateString + slmPolicyInfoPolicy <- o .: "policy" + return SLMPolicyInfo {slmPolicyInfoId = SLMPolicyId "", ..} + +instance ToJSON SLMPolicyInfo where + toJSON SLMPolicyInfo {..} = + omitNulls $ + catMaybes + [ fmap ("version" .=) slmPolicyInfoVersion, + fmap ("modified_date" .=) slmPolicyInfoModifiedDate, + fmap ("modified_date_string" .=) slmPolicyInfoModifiedDateString, + Just ("policy" .= slmPolicyInfoPolicy) + ] + +-- | The response body of @GET /_slm/policy[\/{id}]@. ES keys the response +-- by policy id, so the JSON is an object whose keys are ids and whose +-- values are the policy bodies. The 'FromJSON' walks the keys and folds +-- each one into the corresponding 'SLMPolicyInfo' (overriding the +-- placeholder id set by 'SLMPolicyInfo's own decoder). Round-trip the +-- whole 'SLMPolicies' through @encode . decode@ to preserve ids. +newtype SLMPolicies = SLMPolicies {unSLMPolicies :: [SLMPolicyInfo]} + deriving stock (Eq, Show) + +instance FromJSON SLMPolicies where + parseJSON = withObject "Collection of SLMPolicyInfo" parse + where + parse = fmap SLMPolicies . mapM stamp . KM.toList + stamp (rawId, v) = do + p <- parseJSON v + return p {slmPolicyInfoId = SLMPolicyId (toText rawId)} + +instance ToJSON SLMPolicies where + toJSON (SLMPolicies ps) = + Object . KM.fromList $ + [ (fromText (unSLMPolicyId (slmPolicyInfoId p)), toJSON p) + | p <- ps + ] + +-- | Response body of @POST /_slm/execute/{id}@. ES replies with a JSON +-- object whose sole field is @snapshot_name@, e.g. +-- @{"snapshot_name": ""}@. The +-- 'slmExecutionSnapshot' accessor is provided so request builders can +-- project directly to a 'SnapshotName'. +newtype SLMExecutionResult = SLMExecutionResult {slmExecutionSnapshot :: SnapshotName} + deriving stock (Eq, Show) + +instance FromJSON SLMExecutionResult where + parseJSON = withObject "SLMExecutionResult" $ \o -> + SLMExecutionResult <$> o .: "snapshot_name" + +instance ToJSON SLMExecutionResult where + toJSON (SLMExecutionResult name) = + object ["snapshot_name" .= name] + +-- | The cluster-wide SLM operation mode returned by @GET /_slm/status@. +-- The enum is identical to ILM's +-- 'Database.Bloodhound.Internal.Versions.Common.Types.ILM.ILMOperationMode' +-- — both plugins reuse the same three-valued @RUNNING\/STOPPING\/STOPPED@ +-- spelling. An unknown value fails to decode (the enum has been stable +-- since SLM shipped in ES 7.4, so a new mode would warrant a deliberate +-- constructor addition here). +data SLMOperationMode + = SLMOperationModeRunning + | SLMOperationModeStopping + | SLMOperationModeStopped + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON SLMOperationMode where + toJSON SLMOperationModeRunning = String "RUNNING" + toJSON SLMOperationModeStopping = String "STOPPING" + toJSON SLMOperationModeStopped = String "STOPPED" + +instance FromJSON SLMOperationMode where + parseJSON = withText "SLMOperationMode" parseOperationMode + where + parseOperationMode "RUNNING" = pure SLMOperationModeRunning + parseOperationMode "STOPPING" = pure SLMOperationModeStopping + parseOperationMode "STOPPED" = pure SLMOperationModeStopped + parseOperationMode other = + fail ("unknown SLM operation_mode: " <> show other) + +-- | Response body of @GET /_slm/status@. The @operation_mode@ field is +-- always present; the @snapshot_creation_count@ and +-- @snapshot_deletion_count@ counters are tolerated as 'Maybe' because +-- older ES versions omitted them. Any other field ES adds in future +-- (@policy_protection_indicator@, @retention_runs@, ...) is ignored by +-- the decoder — the wire format is forward-compatible by design. +data SLMStatus = SLMStatus + { slmStatusOperationMode :: SLMOperationMode, + slmStatusSnapshotCreationCount :: Maybe Int, + slmStatusSnapshotDeletionCount :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON SLMStatus where + parseJSON = withObject "SLMStatus" $ \o -> do + slmStatusOperationMode <- o .: "operation_mode" + slmStatusSnapshotCreationCount <- o .:? "snapshot_creation_count" + slmStatusSnapshotDeletionCount <- o .:? "snapshot_deletion_count" + return SLMStatus {..} + +instance ToJSON SLMStatus where + toJSON SLMStatus {..} = + omitNulls $ + catMaybes + [ Just ("operation_mode" .= slmStatusOperationMode), + fmap ("snapshot_creation_count" .=) slmStatusSnapshotCreationCount, + fmap ("snapshot_deletion_count" .=) slmStatusSnapshotDeletionCount + ] + +-- Lenses + +slmPolicyBodyLens :: Lens' SLMPolicy Value +slmPolicyBodyLens = lens unSLMPolicy (\x y -> x {unSLMPolicy = y}) + +slmPolicyInfoIdLens :: Lens' SLMPolicyInfo SLMPolicyId +slmPolicyInfoIdLens = lens slmPolicyInfoId (\x y -> x {slmPolicyInfoId = y}) + +slmPolicyInfoVersionLens :: Lens' SLMPolicyInfo (Maybe Int) +slmPolicyInfoVersionLens = + lens slmPolicyInfoVersion (\x y -> x {slmPolicyInfoVersion = y}) + +slmPolicyInfoModifiedDateLens :: Lens' SLMPolicyInfo (Maybe Int) +slmPolicyInfoModifiedDateLens = + lens slmPolicyInfoModifiedDate (\x y -> x {slmPolicyInfoModifiedDate = y}) + +slmPolicyInfoModifiedDateStringLens :: Lens' SLMPolicyInfo (Maybe Text) +slmPolicyInfoModifiedDateStringLens = + lens slmPolicyInfoModifiedDateString (\x y -> x {slmPolicyInfoModifiedDateString = y}) + +slmPolicyInfoPolicyLens :: Lens' SLMPolicyInfo Value +slmPolicyInfoPolicyLens = + lens slmPolicyInfoPolicy (\x y -> x {slmPolicyInfoPolicy = y}) + +slmPoliciesListLens :: Lens' SLMPolicies [SLMPolicyInfo] +slmPoliciesListLens = + lens unSLMPolicies (\(SLMPolicies _) y -> SLMPolicies y) + +slmExecutionSnapshotLens :: Lens' SLMExecutionResult SnapshotName +slmExecutionSnapshotLens = + lens slmExecutionSnapshot (\x y -> x {slmExecutionSnapshot = y}) + +slmStatusOperationModeLens :: Lens' SLMStatus SLMOperationMode +slmStatusOperationModeLens = + lens slmStatusOperationMode (\x y -> x {slmStatusOperationMode = y}) + +slmStatusSnapshotCreationCountLens :: Lens' SLMStatus (Maybe Int) +slmStatusSnapshotCreationCountLens = + lens slmStatusSnapshotCreationCount (\x y -> x {slmStatusSnapshotCreationCount = y}) + +slmStatusSnapshotDeletionCountLens :: Lens' SLMStatus (Maybe Int) +slmStatusSnapshotDeletionCountLens = + lens slmStatusSnapshotDeletionCount (\x y -> x {slmStatusSnapshotDeletionCount = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Script.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Script.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Script.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Script.hs @@ -1,7 +1,42 @@ {-# LANGUAGE OverloadedStrings #-} -module Database.Bloodhound.Internal.Versions.Common.Types.Script where +module Database.Bloodhound.Internal.Versions.Common.Types.Script + ( -- * Script + Script (..), + ScriptFields (..), + ScriptFieldValue, + ScriptSource (..), + ScriptLanguage (..), + ScriptParams (..), + ScriptParamValue, + -- * Internal encoder + -- $scriptInnerValue + scriptInnerValue, + + -- * Function score + BoostMode (..), + ScoreMode (..), + FunctionScoreFunction (..), + Weight (..), + Seed (..), + FieldValueFactor (..), + Factor (..), + FactorModifier (..), + FactorMissingFieldValue (..), + + -- * Optics + scriptLanguageLens, + scriptSourceLens, + scriptParamsLens, + scriptOptionsLens, + + -- * Helpers + functionScoreFunctionPair, + parseFunctionScoreFunction, + ) +where + import Data.Aeson.KeyMap import Database.Bloodhound.Internal.Utils.Imports import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes @@ -21,7 +56,8 @@ data Script = Script { scriptLanguage :: Maybe ScriptLanguage, scriptSource :: ScriptSource, - scriptParams :: Maybe ScriptParams + scriptParams :: Maybe ScriptParams, + scriptOptions :: Maybe Object } deriving stock (Eq, Show, Generic) @@ -34,6 +70,9 @@ scriptParamsLens :: Lens' Script (Maybe ScriptParams) scriptParamsLens = lens scriptParams (\x y -> x {scriptParams = y}) +scriptOptionsLens :: Lens' Script (Maybe Object) +scriptOptionsLens = lens scriptOptions (\x y -> x {scriptOptions = y}) + newtype ScriptLanguage = ScriptLanguage Text deriving newtype (Eq, Show, FromJSON, ToJSON) @@ -174,13 +213,26 @@ instance ToJSON Script where toJSON script = - object ["script" .= omitNulls (base script)] - where - base (Script lang (ScriptInline source) params) = - ["lang" .= lang, "source" .= source, "params" .= params] - base (Script lang (ScriptId id_) params) = - ["lang" .= lang, "id" .= id_, "params" .= params] + object ["script" .= scriptInnerValue script] +-- | The JSON object that represents a 'Script' /without/ the outer +-- @\"script\"@ wrapper — i.e. the bare object @{"lang": …, "source"|"id": …, "params": …}@. +-- +-- This is needed by endpoints that take @\"script\"@ as a sibling of other +-- top-level keys (e.g. the Update API's @{\"script\": …, \"upsert\": …, \"doc\": …}@), +-- where 'Script's 'ToJSON' instance would double-wrap it as +-- @{"script": {"script": {...}}}@. The function is therefore exported +-- specifically for endpoint body encoders; most callers should keep using +-- the regular 'ToJSON' instance. +scriptInnerValue :: Script -> Value +scriptInnerValue script = + omitNulls (base script) + where + base (Script lang (ScriptInline source) params options) = + ["lang" .= lang, "source" .= source, "params" .= params, "options" .= options] + base (Script lang (ScriptId id_) params options) = + ["lang" .= lang, "id" .= id_, "params" .= params, "options" .= options] + instance FromJSON Script where parseJSON = withObject "Script" parse where @@ -198,6 +250,7 @@ <$> o' .:? "lang" <*> parseSource o' <*> o' .:? "params" + <*> o' .:? "options" instance ToJSON ScriptParams where toJSON (ScriptParams x) = Object x diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/ScriptContexts.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/ScriptContexts.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/ScriptContexts.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.ScriptContexts +-- License : BSD-style (see the file LICENSE) +-- +-- Types for the @GET /_script_context@ endpoint, which lists the +-- Painless \/ expression execution contexts the cluster knows about +-- along with the methods (and their parameter signatures) each context +-- exposes. The endpoint is shared verbatim by Elasticsearch +-- (7.x\/8.x\/9.x) and OpenSearch (1.x\/2.x\/3.x); it takes no path +-- arguments and no query parameters, and carries no request body. See +-- +-- (the @/_script_context@ endpoint is undocumented on the 7.17 docs +-- site — @painless-contexts.html@ returns 404 — but is served by live +-- 7.17.25, 8.x and 9.x clusters). +module Database.Bloodhound.Internal.Versions.Common.Types.ScriptContexts + ( -- * Response types + ScriptContextsResponse (..), + ScriptContextInfo (..), + ScriptContextMethod (..), + ScriptContextParam (..), + + -- * Optics + scrContextsLens, + sciNameLens, + sciMethodsLens, + scmNameLens, + scmReturnTypeLens, + scmParamsLens, + scpNameLens, + scpTypeLens, + ) +where + +import Data.Aeson +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens) + +-- | Top-level response of @GET /_script_context@. The @contexts@ array +-- has one entry per execution context the server's script engines +-- expose (e.g. @aggs@, @filter@, @score@, @update@, @painless_test@). +-- The list is server-defined and varies across versions and installed +-- plugins; treat it as a diagnostic catalogue rather than a stable +-- enumeration. +data ScriptContextsResponse = ScriptContextsResponse + { -- | Every script execution context known to the cluster, with its + -- method catalogue. + scrContexts :: [ScriptContextInfo] + } + deriving stock (Eq, Show) + +instance FromJSON ScriptContextsResponse where + parseJSON = withObject "ScriptContextsResponse" $ \o -> + ScriptContextsResponse + <$> o + .:? "contexts" + .!= [] + +instance ToJSON ScriptContextsResponse where + toJSON ScriptContextsResponse {..} = + object ["contexts" .= scrContexts] + +-- | One element of the @contexts@ array: a named execution context and +-- the methods available to scripts running in it. +data ScriptContextInfo = ScriptContextInfo + { -- | Context name, e.g. @aggs@, @filter@, @score@, @update@. + sciName :: Text, + -- | Methods the context exposes to scripts. Every context lists at + -- least @execute@; richer contexts (@aggs@, @field@) surface + -- additional accessors such as @getDoc@, @getParams@, @get_score@. + sciMethods :: [ScriptContextMethod] + } + deriving stock (Eq, Show) + +instance FromJSON ScriptContextInfo where + parseJSON = withObject "ScriptContextInfo" $ \o -> + ScriptContextInfo + <$> o + .: "name" + <*> o + .:? "methods" + .!= [] + +instance ToJSON ScriptContextInfo where + toJSON ScriptContextInfo {..} = + object ["name" .= sciName, "methods" .= sciMethods] + +-- | One method exposed by a 'ScriptContextInfo'. The 'scmReturnType' +-- and 'scpType' values are fully-qualified JVM type names (e.g. +-- @java.util.Map@, @org.elasticsearch.analysis.common.AnalysisPredicateScript$Token@); +-- they are opaque transport strings intended for diagnostic display, +-- not stable across versions. +data ScriptContextMethod = ScriptContextMethod + { -- | Method name, e.g. @execute@, @getDoc@, @getParams@, @get_score@. + scmName :: Text, + -- | Fully-qualified JVM return type of the method. + scmReturnType :: Text, + -- | Formal parameters of the method. Most contexts surface + -- zero-argument methods; a handful (e.g. the @analysis@ context's + -- @execute@) take parameters. + scmParams :: [ScriptContextParam] + } + deriving stock (Eq, Show) + +instance FromJSON ScriptContextMethod where + parseJSON = withObject "ScriptContextMethod" $ \o -> + ScriptContextMethod + <$> o + .: "name" + <*> o + .: "return_type" + <*> o + .:? "params" + .!= [] + +instance ToJSON ScriptContextMethod where + toJSON ScriptContextMethod {..} = + object + [ "name" .= scmName, + "return_type" .= scmReturnType, + "params" .= scmParams + ] + +-- | One formal parameter of a 'ScriptContextMethod'. Both fields are +-- present whenever the parameter exists. +data ScriptContextParam = ScriptContextParam + { -- | Parameter name, e.g. @token@. + scpName :: Text, + -- | Fully-qualified JVM type of the parameter. The JSON key is + -- @type@; the field is named 'scpType' because @type@ is a Haskell + -- keyword and cannot be used as a record selector. + scpType :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ScriptContextParam where + parseJSON = withObject "ScriptContextParam" $ \o -> + ScriptContextParam + <$> o + .: "name" + <*> o + .: "type" + +instance ToJSON ScriptContextParam where + toJSON ScriptContextParam {..} = + object ["name" .= scpName, "type" .= scpType] + +-- Lenses for ScriptContextsResponse + +scrContextsLens :: Lens' ScriptContextsResponse [ScriptContextInfo] +scrContextsLens = + lens scrContexts (\x y -> x {scrContexts = y}) + +-- Lenses for ScriptContextInfo + +sciNameLens :: Lens' ScriptContextInfo Text +sciNameLens = lens sciName (\x y -> x {sciName = y}) + +sciMethodsLens :: Lens' ScriptContextInfo [ScriptContextMethod] +sciMethodsLens = + lens sciMethods (\x y -> x {sciMethods = y}) + +-- Lenses for ScriptContextMethod + +scmNameLens :: Lens' ScriptContextMethod Text +scmNameLens = lens scmName (\x y -> x {scmName = y}) + +scmReturnTypeLens :: Lens' ScriptContextMethod Text +scmReturnTypeLens = + lens scmReturnType (\x y -> x {scmReturnType = y}) + +scmParamsLens :: Lens' ScriptContextMethod [ScriptContextParam] +scmParamsLens = + lens scmParams (\x y -> x {scmParams = y}) + +-- Lenses for ScriptContextParam + +scpNameLens :: Lens' ScriptContextParam Text +scpNameLens = lens scpName (\x y -> x {scpName = y}) + +scpTypeLens :: Lens' ScriptContextParam Text +scpTypeLens = lens scpType (\x y -> x {scpType = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/ScriptLanguages.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/ScriptLanguages.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/ScriptLanguages.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.ScriptLanguages +-- License : BSD-style (see the file LICENSE) +-- +-- Types for the @GET /_script_language@ endpoint, which lists the +-- script languages the cluster supports and, per language, the +-- execution contexts in which each may run. The endpoint is shared by +-- Elasticsearch (7.x\/8.x\/9.x) and OpenSearch (2.x\/3.x); it takes no +-- path arguments and no query parameters, and carries no request body. +-- +-- Note: on OpenSearch 1.3 this endpoint returns HTTP 500 (a server +-- bug); callers targeting a 1.3 cluster should be prepared for +-- failure. See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.ScriptLanguages + ( -- * Response types + ScriptLanguagesResponse (..), + ScriptLanguageContext (..), + + -- * Optics + slrTypesAllowedLens, + slrLanguageContextsLens, + slcLanguageLens, + slcContextsLens, + ) +where + +import Data.Aeson +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens) +import Database.Bloodhound.Internal.Versions.Common.Types.Script + ( ScriptLanguage, + ) + +-- | Top-level response of @GET /_script_language@. +-- +-- The @types_allowed@ array lists the script source forms the cluster +-- accepts (in practice always @["inline", "stored"]@); the +-- @language_contexts@ array has one entry per supported language, each +-- naming the execution contexts in which that language may run. +data ScriptLanguagesResponse = ScriptLanguagesResponse + { -- | Script source forms accepted by the cluster, e.g. + -- @["inline", "stored"]@. + slrTypesAllowed :: [Text], + -- | One entry per supported language (@expression@, @mustache@, + -- @painless@) with its permitted execution contexts. + slrLanguageContexts :: [ScriptLanguageContext] + } + deriving stock (Eq, Show) + +instance FromJSON ScriptLanguagesResponse where + parseJSON = withObject "ScriptLanguagesResponse" $ \o -> + ScriptLanguagesResponse + <$> o + .:? "types_allowed" + .!= [] + <*> o + .:? "language_contexts" + .!= [] + +instance ToJSON ScriptLanguagesResponse where + toJSON ScriptLanguagesResponse {..} = + object + [ "types_allowed" .= slrTypesAllowed, + "language_contexts" .= slrLanguageContexts + ] + +-- | One element of the @language_contexts@ array: a supported language +-- and the execution contexts in which it may run. The 'slcLanguage' +-- values (@expression@, @mustache@, @painless@) match the @lang@ field +-- of 'Database.Bloodhound.Internal.Versions.Common.Types.Script.Script', +-- so the existing 'ScriptLanguage' newtype is reused for coherence. +data ScriptLanguageContext = ScriptLanguageContext + { -- | Language identifier, e.g. @painless@. Reuses the 'ScriptLanguage' + -- newtype shared with the script APIs. + slcLanguage :: ScriptLanguage, + -- | Execution contexts in which the language may run, e.g. + -- @["aggs", "field", "score", "update"]@ for @painless@. + slcContexts :: [Text] + } + deriving stock (Eq, Show) + +instance FromJSON ScriptLanguageContext where + parseJSON = withObject "ScriptLanguageContext" $ \o -> + ScriptLanguageContext + <$> o + .: "language" + <*> o + .:? "contexts" + .!= [] + +instance ToJSON ScriptLanguageContext where + toJSON ScriptLanguageContext {..} = + object ["language" .= slcLanguage, "contexts" .= slcContexts] + +-- Lenses for ScriptLanguagesResponse + +slrTypesAllowedLens :: Lens' ScriptLanguagesResponse [Text] +slrTypesAllowedLens = + lens slrTypesAllowed (\x y -> x {slrTypesAllowed = y}) + +slrLanguageContextsLens :: Lens' ScriptLanguagesResponse [ScriptLanguageContext] +slrLanguageContextsLens = + lens slrLanguageContexts (\x y -> x {slrLanguageContexts = y}) + +-- Lenses for ScriptLanguageContext + +slcLanguageLens :: Lens' ScriptLanguageContext ScriptLanguage +slcLanguageLens = + lens slcLanguage (\x y -> x {slcLanguage = y}) + +slcContextsLens :: Lens' ScriptLanguageContext [Text] +slcContextsLens = + lens slcContexts (\x y -> x {slcContexts = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Search.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Search.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Search.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Search.hs @@ -3,6 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} module Database.Bloodhound.Internal.Versions.Common.Types.Search @@ -12,19 +13,80 @@ Include (..), Pattern (..), PatternOrPatterns (..), + AdvanceScrollOptions (..), + ClearScrollResponse (..), ScrollId (..), + defaultAdvanceScrollOptions, + advanceScrollOptionsParams, + asoRestTotalHitsAsIntLens, Search (..), SearchResult (..), SearchTemplate (..), SearchTemplateId (..), SearchTemplateSource (..), SearchType (..), + SearchOptions (..), + TrackTotalHits (..), + defaultSearchOptions, + expandWildcardsText, DocvalueField (..), Source (..), - TimeUnits (..), TrackSortScores, unpackId, + -- * Search body: runtime mappings (.7.1.1) + RuntimeType (..), + RuntimeScript (..), + RuntimeMapping (..), + RuntimeMappings (..), + runtimeTypeText, + + -- * Search body: rescore (.7.1.2) + RescoreScoreMode (..), + RescoreQuery (..), + Rescore (..), + rescoreScoreModeText, + + -- * Search body: collapse (.7.1.3) + Collapse (..), + CollapseInnerHits (..), + + -- * Search body: retrievers (.7.1.4) + Retriever (..), + RetrieverBase (..), + StandardRetriever (..), + KnnRetriever (..), + RrfRetriever (..), + RrfRetrieverEntry (..), + TextSimilarityRetriever (..), + RuleRetriever (..), + RetrieverRulesetId (..), + unRetrieverRulesetId, + RescorerRetriever (..), + LinearRetriever (..), + LinearRetrieverEntry (..), + ScoreNormalizer (..), + PinnedRetriever (..), + SpecifiedDocument (..), + DiversifyRetriever (..), + DiversifyType (..), + RescoreVector (..), + RetrieverCollapse (..), + RetrieverRescore (..), + ChunkRescorer (..), + ChunkRescorerChunkingStrategy (..), + ChunkRescorerChunkingSettings (..), + emptyRetrieverBase, + mkStandardRetriever, + mkKnnRetriever, + mkRrfRetriever, + mkTextSimilarityRetriever, + mkRuleRetriever, + mkRescorerRetriever, + mkLinearRetriever, + mkPinnedRetriever, + mkDiversifyRetriever, + -- * Optics tookLens, timedOutLens, @@ -34,22 +96,62 @@ scrollIdLens, suggestLens, pitIdLens, + clearScrollSucceededLens, + clearScrollNumFreedLens, getTemplateScriptLangLens, getTemplateScriptSourceLens, getTemplateScriptOptionsLens, getTemplateScriptIdLens, getTemplateScriptFoundLens, + knnBodyLens, + osKnnBodyLens, + trackTotalHitsLens, + timeoutLens, + minScoreLens, + explainLens, + searchVersionLens, + seqNoPrimaryTermLens, + terminateAfterLens, + statsLens, + searchPipelineLens, + storedFieldsLens, + runtimeMappingsLens, + rescoreLens, + collapseLens, + retrieverLens, + soAllowNoIndicesLens, + soExpandWildcardsLens, + soIgnoreUnavailableLens, + soPreferenceLens, + soRoutingLens, + soRequestCacheLens, + soTypedKeysLens, + soSeqNoPrimaryTermLens, + soMaxConcurrentShardRequestsLens, + soBatchedReduceSizeLens, + soCcsMinimizeRoundtripsLens, + soAllowPartialSearchResultsLens, + soPreFilterShardSizeLens, + soCancelAfterTimeIntervalLens, + soMaxConcurrentSearchesLens, + soSourceLens, + soSourceIncludesLens, + soSourceExcludesLens, ) where -import qualified Data.HashMap.Strict as HM +import Data.HashMap.Strict qualified as HM +import Data.Word (Word32) import Database.Bloodhound.Client.Cluster import Database.Bloodhound.Internal.Utils.Imports import Database.Bloodhound.Internal.Versions.Common.Types.Aggregation +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards import Database.Bloodhound.Internal.Versions.Common.Types.Highlight +import Database.Bloodhound.Internal.Versions.Common.Types.Knn import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes import Database.Bloodhound.Internal.Versions.Common.Types.PointInTime import Database.Bloodhound.Internal.Versions.Common.Types.Query +import Database.Bloodhound.Internal.Versions.Common.Types.Retriever import Database.Bloodhound.Internal.Versions.Common.Types.Sort import Database.Bloodhound.Internal.Versions.Common.Types.Suggest @@ -77,57 +179,152 @@ source :: Maybe Source, -- | Only one Suggestion request / response per Search is supported. suggestBody :: Maybe Suggest, - pointInTime :: Maybe PointInTime + pointInTime :: Maybe PointInTime, + -- | Top-level kNN clauses (ES8+\/ES9+). Serialized as the @\"knn\"@ array + -- at the root of the search body. Each 'KnnQuery' is a bare clause. + knnBody :: Maybe [KnnQuery], + -- | OpenSearch k-NN clause. When set, owns the top-level @\"query\"@ slot + -- and overrides 'queryBody'. A caller-supplied 'filterBody' is preserved + -- by being merged into the kNN clause's own @filter@ field (which OS + -- supports natively). See 'osKnnBodyLens'. + osKnnBody :: Maybe OpenSearchKnnQuery, + -- | Number of hits to accurately count for the response, default + -- @true@ (= 'TrackTotalHitsAll' on the server). Use + -- 'TrackTotalHitsUpTo' to cap the count for performance on large + -- result sets, or 'TrackTotalHitsOff' to skip counting entirely. + trackTotalHits :: Maybe TrackTotalHits, + -- | Per-search timeout, e.g. @\"1s\"@. Renders the top-level + -- @\"timeout\"@ body field. Note that this is distinct from the + -- 'soCancelAfterTimeInterval' URI parameter. + timeout :: Maybe Text, + -- | Discard documents scoring below this threshold before sorting + -- \/ pagination. Renders @\"min_score\"@. + minScore :: Maybe Double, + -- | When @True@, include score computation details in each hit. + -- Renders @\"explain\"@. + explain :: Maybe Bool, + -- | When @True@, return a @_version@ field for each hit. Renders + -- @\"version\"@. The field is named @searchVersion@ to avoid a clash + -- with 'Status.version'; migrating the library to + -- @DuplicateRecordFields@ is tracked separately. + searchVersion :: Maybe Bool, + -- | When @True@, return @_seq_no@ and @_primary_term@ for each hit. + -- Renders @\"seq_no_primary_term\"@. See also the URI-level + -- 'soSeqNoPrimaryTerm'. + seqNoPrimaryTerm :: Maybe Bool, + -- | Maximum number of documents to collect per shard. Renders + -- @\"terminate_after\"@. Server-side default is no limit. + terminateAfter :: Maybe Int, + -- | Associative tags for the search, surfaced in + -- @\/_nodes\/stats\/_searches@. Renders @\"stats\"@ as a JSON array. + -- Note: an empty list is elided by the renderer ('omitNulls') and is + -- byte-for-byte indistinguishable from 'Nothing' on the wire. + stats :: Maybe [Text], + -- | OpenSearch-only. Selects the registered search pipeline to + -- apply to the request. Renders @\"search_pipeline\"@. + -- + -- /Warning/: Elasticsearch does not recognise this body field and + -- will reject the request if it is set on an ES backend. + searchPipeline :: Maybe Text, + -- | Deprecated since ES 7.0 in favour of 'fields', but still + -- supported by both backends. Renders @\"stored_fields\"@. Use + -- 'fields' for new code. Note: an empty list is elided by the + -- renderer ('omitNulls') and is byte-for-byte indistinguishable + -- from 'Nothing' on the wire. + storedFields :: Maybe [FieldName], + -- | Runtime field definitions evaluated at query time. Renders the + -- top-level @\"runtime_mappings\"@ body field as a JSON object keyed + -- by field name. See the + -- . + -- + -- /Warning/: OpenSearch does not accept @runtime_mappings@ in the + -- search body — runtime fields are configured via the index mappings + -- endpoint instead. Setting this field on an OpenSearch backend will + -- be rejected by the server. The field is included in the common + -- record for caller convenience; backend-aware gating is tracked as a + -- follow-up. Same gating prose as 'searchPipeline' and + -- 'soCancelAfterTimeInterval'. + runtimeMappings :: Maybe RuntimeMappings, + -- | Multi-level rescoring. Renders the top-level @\"rescore\"@ body + -- field as a JSON array of 'Rescore' clauses. See the + -- + -- and the + -- . + rescore :: Maybe [Rescore], + -- | Field collapsing for result grouping. Renders the top-level + -- @\"collapse\"@ body field. See the + -- + -- and the + -- . + collapse :: Maybe Collapse, + -- | Elasticsearch Retrievers DSL (ES 8.14+). Renders the top-level + -- @\"retriever\"@ body field. When set, owns the result ranking; + -- 'queryBody' is still sent (under @\"query\"@) for filtering. See + -- "Database.Bloodhound.Internal.Versions.Common.Types.Retriever". + -- + -- /Warning/: Elasticsearch-only. OpenSearch does not recognise the + -- @retriever@ body field and will reject the request if it is set on + -- an OS backend. The field is included in the common record for + -- caller convenience; backend-aware gating is tracked as a + -- follow-up. (Inverse of 'searchPipeline', which is OS-only; same + -- situation as 'runtimeMappings', which is ES-only.) + retriever :: Maybe Retriever } deriving stock (Eq, Show) instance ToJSON Search where - toJSON - ( Search - mquery - sFilter - sort - searchAggs - highlight - sTrackSortScores - sFrom - sSize - _ - sAfter - sFields - sScriptFields - sDocvalueFields - sSource - sSuggest - pPointInTime - ) = - omitNulls - [ "query" .= query', - "sort" .= sort, - "aggregations" .= searchAggs, - "highlight" .= highlight, - "from" .= sFrom, - "size" .= sSize, - "track_scores" .= sTrackSortScores, - "search_after" .= sAfter, - "fields" .= sFields, - "script_fields" .= sScriptFields, - "docvalue_fields" .= sDocvalueFields, - "_source" .= sSource, - "suggest" .= sSuggest, - "pit" .= pPointInTime - ] - where - query' = case sFilter of - Nothing -> mquery - Just x -> - Just - . QueryBoolQuery - $ mkBoolQuery - (maybeToList mquery) - [x] - [] - [] + toJSON Search {..} = + omitNulls + [ "query" .= querySlot, + "sort" .= sortBody, + "aggregations" .= aggBody, + "highlight" .= highlight, + "from" .= from, + "size" .= size, + "track_scores" .= trackSortScores, + "search_after" .= searchAfterKey, + "fields" .= fields, + "script_fields" .= scriptFields, + "docvalue_fields" .= docvalueFields, + "_source" .= source, + "suggest" .= suggestBody, + "pit" .= pointInTime, + "knn" .= knnBody, + "track_total_hits" .= trackTotalHits, + "timeout" .= timeout, + "min_score" .= minScore, + "explain" .= explain, + "version" .= searchVersion, + "seq_no_primary_term" .= seqNoPrimaryTerm, + "terminate_after" .= terminateAfter, + "stats" .= stats, + "search_pipeline" .= searchPipeline, + "stored_fields" .= storedFields, + "runtime_mappings" .= runtimeMappings, + "rescore" .= rescore, + "collapse" .= collapse, + "retriever" .= retriever + ] + where + -- When 'osKnnBody' is set, it owns the @query@ slot. To avoid silently + -- dropping a caller-supplied 'filterBody', merge it into the kNN + -- clause's own @filter@ field (which OS supports natively). 'queryBody' + -- cannot be merged and is overridden with a documented warning in the + -- Haddock for 'osKnnBody'. + querySlot = + case osKnnBody of + Just osknn -> Just (toJSON (mergeFilterIntoOsKnn filterBody osknn)) + Nothing -> fmap toJSON query' + query' = case filterBody of + Nothing -> queryBody + Just x -> + Just + . QueryBoolQuery + $ mkBoolQuery + (maybeToList queryBody) + [x] + [] + [] data SearchType = SearchTypeQueryThenFetch @@ -143,6 +340,182 @@ parseJSON (String "dfs_query_then_fetch") = pure $ SearchTypeDfsQueryThenFetch parseJSON _ = empty +-- | Optional URI parameters for the search endpoints +-- (@\/_search@, @\/{index}\/_search@, @\/{index1,index2,...}\/_search@). +-- +-- These are distinct from the request @body@ (which lives in 'Search') and +-- control server-side behaviour such as shard routing, result formatting, +-- and error semantics. See the Elasticsearch +-- +-- and the OpenSearch +-- +-- for the canonical list. Where the two backends disagree, the field Haddock +-- calls out the difference. +-- +-- 'defaultSearchOptions' produces no URI parameters, so the legacy +-- 'searchByIndex' \/ 'searchAll' \/ 'searchByIndices' (which use the default) +-- are byte-for-byte identical to before this type was introduced. +data SearchOptions = SearchOptions + { -- | Whether to short-circuit the request if a concrete (non-wildcard) + -- index / alias is missing. Defaults to @false@ server-side. + soAllowNoIndices :: Maybe Bool, + -- | Which wildcard patterns to expand. The server accepts a + -- comma-separated list; we model it as a 'NonEmpty' to encode "at least + -- one". Both ES and OS accept the same four values. + soExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + -- | Skip missing / closed indices silently instead of failing. + soIgnoreUnavailable :: Maybe Bool, + -- | Shard routing hint, e.g. @_local"@ or @_only_local@. Also accepts an + -- arbitrary string for custom allocation. + soPreference :: Maybe Text, + -- | Custom routing value(s). For multi-route queries pass a + -- comma-separated string, e.g. @"route1,route2"@. + soRouting :: Maybe Text, + -- | Bypass / force the query cache. + soRequestCache :: Maybe Bool, + -- | Use the @_typed_keys@ response format (e.g. @aggregations#terms@). + soTypedKeys :: Maybe Bool, + -- | Return @_seq_no@ and @_primary_term@ for each hit. + soSeqNoPrimaryTerm :: Maybe Bool, + -- | Cap the number of concurrent shard requests per search. Default 5. + soMaxConcurrentShardRequests :: Maybe Int, + -- | Number of shards to coordinate before an early partial reduce. + soBatchedReduceSize :: Maybe Int, + -- | Minimise round trips for cross-cluster search. + soCcsMinimizeRoundtrips :: Maybe Bool, + -- | Return partial results if a shard fails instead of failing the + -- whole request. Default @true@. + soAllowPartialSearchResults :: Maybe Bool, + -- | Pre-filter shard count threshold for distribution-based optimisation. + soPreFilterShardSize :: Maybe Int, + -- | OpenSearch-only. Time after which the search is cancelled at the + -- shard level. Modeled as a magnitude paired with a 'TimeUnits' suffix + -- (e.g. @(TimeUnitSeconds, 5)@ renders as @5s@). Fractional durations + -- are not representable; if you need them, fall through to raw + -- 'performBHRequest'. + -- + -- /Warning/: Elasticsearch does not recognise this parameter and will + -- reject the entire request with an @unrecognized query parameter@ + -- error if it is set on an ES backend. The field is included in the + -- common record for caller convenience; backend-aware gating is + -- tracked as a follow-up. + soCancelAfterTimeInterval :: Maybe (TimeUnits, Word32), + -- | Cap the number of concurrent @_msearch@ sub-requests the + -- coordinator will fan out. Rendered as @max_concurrent_searches@. + -- Documented for @\/_msearch@ and @\/{index}\/_msearch@ only + -- (); + -- regular @\/_search@ ignores it. Defaults to the product of + -- @node.search.concurrent_segment_search_threshold@ and + -- @data_nodes@ server-side. + -- + -- /Warning:/ meaningless on @searchByIndex*@. Included in the shared + -- 'SearchOptions' record so the @*With@ msearch variants can reuse + -- the same parameter plumbing. + soMaxConcurrentSearches :: Maybe Int, + -- | Whether to include the @_source@ field in each hit. Rendered as + -- the @_source@ URI parameter. @Just False@ disables source + -- retrieval; @Just True@ emits @_source=true@ explicitly (the server + -- treats it the same as 'Nothing', which relies on the default of + -- returning the source). + -- + -- This is the URI-level toggle, distinct from the body-level + -- 'source' field (which also supports pattern include\/exclude). + -- When both are set the URI parameter takes precedence server-side; + -- prefer setting only one. Mirrors 'gdoSource' on 'GetDocumentOptions'. + soSource :: Maybe Bool, + -- | Comma-separated field globs to include in @_source@. Rendered + -- verbatim as the @_source_includes@ URI parameter. Distinct from + -- the body-level 'source' field; when both are set the URI parameter + -- takes precedence server-side. Mirrors 'gdoSourceIncludes'. + soSourceIncludes :: Maybe Text, + -- | Comma-separated field globs to exclude from @_source@. Rendered + -- verbatim as the @_source_excludes@ URI parameter. Distinct from + -- the body-level 'source' field; when both are set the URI parameter + -- takes precedence server-side. Mirrors 'gdoSourceExcludes'. + soSourceExcludes :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'SearchOptions' with every field set to 'Nothing'. Produces an empty +-- query-string, preserving the wire behaviour of the legacy +-- parameterless 'searchByIndex' \/ 'searchAll' \/ 'searchByIndices'. +defaultSearchOptions :: SearchOptions +defaultSearchOptions = + SearchOptions + { soAllowNoIndices = Nothing, + soExpandWildcards = Nothing, + soIgnoreUnavailable = Nothing, + soPreference = Nothing, + soRouting = Nothing, + soRequestCache = Nothing, + soTypedKeys = Nothing, + soSeqNoPrimaryTerm = Nothing, + soMaxConcurrentShardRequests = Nothing, + soBatchedReduceSize = Nothing, + soCcsMinimizeRoundtrips = Nothing, + soAllowPartialSearchResults = Nothing, + soPreFilterShardSize = Nothing, + soCancelAfterTimeInterval = Nothing, + soMaxConcurrentSearches = Nothing, + soSource = Nothing, + soSourceIncludes = Nothing, + soSourceExcludes = Nothing + } + +soAllowNoIndicesLens :: Lens' SearchOptions (Maybe Bool) +soAllowNoIndicesLens = lens soAllowNoIndices (\x y -> x {soAllowNoIndices = y}) + +soExpandWildcardsLens :: Lens' SearchOptions (Maybe (NonEmpty ExpandWildcards)) +soExpandWildcardsLens = lens soExpandWildcards (\x y -> x {soExpandWildcards = y}) + +soIgnoreUnavailableLens :: Lens' SearchOptions (Maybe Bool) +soIgnoreUnavailableLens = lens soIgnoreUnavailable (\x y -> x {soIgnoreUnavailable = y}) + +soPreferenceLens :: Lens' SearchOptions (Maybe Text) +soPreferenceLens = lens soPreference (\x y -> x {soPreference = y}) + +soRoutingLens :: Lens' SearchOptions (Maybe Text) +soRoutingLens = lens soRouting (\x y -> x {soRouting = y}) + +soRequestCacheLens :: Lens' SearchOptions (Maybe Bool) +soRequestCacheLens = lens soRequestCache (\x y -> x {soRequestCache = y}) + +soTypedKeysLens :: Lens' SearchOptions (Maybe Bool) +soTypedKeysLens = lens soTypedKeys (\x y -> x {soTypedKeys = y}) + +soSeqNoPrimaryTermLens :: Lens' SearchOptions (Maybe Bool) +soSeqNoPrimaryTermLens = lens soSeqNoPrimaryTerm (\x y -> x {soSeqNoPrimaryTerm = y}) + +soMaxConcurrentShardRequestsLens :: Lens' SearchOptions (Maybe Int) +soMaxConcurrentShardRequestsLens = lens soMaxConcurrentShardRequests (\x y -> x {soMaxConcurrentShardRequests = y}) + +soBatchedReduceSizeLens :: Lens' SearchOptions (Maybe Int) +soBatchedReduceSizeLens = lens soBatchedReduceSize (\x y -> x {soBatchedReduceSize = y}) + +soCcsMinimizeRoundtripsLens :: Lens' SearchOptions (Maybe Bool) +soCcsMinimizeRoundtripsLens = lens soCcsMinimizeRoundtrips (\x y -> x {soCcsMinimizeRoundtrips = y}) + +soAllowPartialSearchResultsLens :: Lens' SearchOptions (Maybe Bool) +soAllowPartialSearchResultsLens = lens soAllowPartialSearchResults (\x y -> x {soAllowPartialSearchResults = y}) + +soPreFilterShardSizeLens :: Lens' SearchOptions (Maybe Int) +soPreFilterShardSizeLens = lens soPreFilterShardSize (\x y -> x {soPreFilterShardSize = y}) + +soCancelAfterTimeIntervalLens :: Lens' SearchOptions (Maybe (TimeUnits, Word32)) +soCancelAfterTimeIntervalLens = lens soCancelAfterTimeInterval (\x y -> x {soCancelAfterTimeInterval = y}) + +soMaxConcurrentSearchesLens :: Lens' SearchOptions (Maybe Int) +soMaxConcurrentSearchesLens = lens soMaxConcurrentSearches (\x y -> x {soMaxConcurrentSearches = y}) + +soSourceLens :: Lens' SearchOptions (Maybe Bool) +soSourceLens = lens soSource (\x y -> x {soSource = y}) + +soSourceIncludesLens :: Lens' SearchOptions (Maybe Text) +soSourceIncludesLens = lens soSourceIncludes (\x y -> x {soSourceIncludes = y}) + +soSourceExcludesLens :: Lens' SearchOptions (Maybe Text) +soSourceExcludesLens = lens soSourceExcludes (\x y -> x {soSourceExcludes = y}) + data Source = NoSource | SourcePatterns PatternOrPatterns @@ -237,10 +610,192 @@ pitIdLens :: Lens' (SearchResult a) (Maybe Text) pitIdLens = lens pitId (\x y -> x {pitId = y}) +knnBodyLens :: Lens' Search (Maybe [KnnQuery]) +knnBodyLens = lens knnBody (\x y -> x {knnBody = y}) + +osKnnBodyLens :: Lens' Search (Maybe OpenSearchKnnQuery) +osKnnBodyLens = lens osKnnBody (\x y -> x {osKnnBody = y}) + +trackTotalHitsLens :: Lens' Search (Maybe TrackTotalHits) +trackTotalHitsLens = lens trackTotalHits (\x y -> x {trackTotalHits = y}) + +timeoutLens :: Lens' Search (Maybe Text) +timeoutLens = lens timeout (\x y -> x {timeout = y}) + +minScoreLens :: Lens' Search (Maybe Double) +minScoreLens = lens minScore (\x y -> x {minScore = y}) + +explainLens :: Lens' Search (Maybe Bool) +explainLens = lens explain (\x y -> x {explain = y}) + +searchVersionLens :: Lens' Search (Maybe Bool) +searchVersionLens = lens searchVersion (\x y -> x {searchVersion = y}) + +seqNoPrimaryTermLens :: Lens' Search (Maybe Bool) +seqNoPrimaryTermLens = lens seqNoPrimaryTerm (\x y -> x {seqNoPrimaryTerm = y}) + +terminateAfterLens :: Lens' Search (Maybe Int) +terminateAfterLens = lens terminateAfter (\x y -> x {terminateAfter = y}) + +statsLens :: Lens' Search (Maybe [Text]) +statsLens = lens stats (\x y -> x {stats = y}) + +searchPipelineLens :: Lens' Search (Maybe Text) +searchPipelineLens = lens searchPipeline (\x y -> x {searchPipeline = y}) + +storedFieldsLens :: Lens' Search (Maybe [FieldName]) +storedFieldsLens = lens storedFields (\x y -> x {storedFields = y}) + +runtimeMappingsLens :: Lens' Search (Maybe RuntimeMappings) +runtimeMappingsLens = lens runtimeMappings (\x y -> x {runtimeMappings = y}) + +rescoreLens :: Lens' Search (Maybe [Rescore]) +rescoreLens = lens rescore (\x y -> x {rescore = y}) + +collapseLens :: Lens' Search (Maybe Collapse) +collapseLens = lens collapse (\x y -> x {collapse = y}) + +retrieverLens :: Lens' Search (Maybe Retriever) +retrieverLens = lens retriever (\x y -> x {retriever = y}) + +-- | Top-level @track_total_hits@ body field. Elasticsearch and OpenSearch +-- accept three shapes for this field: a boolean (@true@ = exact count, +-- @false@ = skip counting) or a positive integer (accurate up to @N@, +-- estimated beyond). See the +-- +-- and the +-- . +data TrackTotalHits + = -- | Render @track_total_hits: true@ — count the exact total. + TrackTotalHitsAll + | -- | Render @track_total_hits: false@ — skip counting; @hits.total@ is + -- @null@ in the response. + TrackTotalHitsOff + | -- | Render @track_total_hits: N@ — count accurately up to @N@, estimate + -- beyond. Useful for capping query planning cost on large matches. + TrackTotalHitsUpTo Int + deriving stock (Eq, Show) + +instance ToJSON TrackTotalHits where + toJSON TrackTotalHitsAll = Bool True + toJSON TrackTotalHitsOff = Bool False + toJSON (TrackTotalHitsUpTo n) = toJSON n + +instance FromJSON TrackTotalHits where + parseJSON (Bool True) = pure TrackTotalHitsAll + parseJSON (Bool False) = pure TrackTotalHitsOff + parseJSON v = TrackTotalHitsUpTo <$> parseJSON v + +-- | Merge a caller-supplied 'Filter' into an 'OpenSearchKnnQuery'\'s own +-- @filter@ field. If both are set, they are combined as a bool query's +-- @filter@ clause (AND semantics). If only one is set, that one wins. If +-- neither is set, the result has no @filter@. +mergeFilterIntoOsKnn :: Maybe Filter -> OpenSearchKnnQuery -> OpenSearchKnnQuery +mergeFilterIntoOsKnn sFilter osknn = + osknn {osknnFilter = combinedFilter} + where + combinedFilter = + case (sFilter, osknnFilter osknn) of + (Nothing, inner) -> inner + (outer, Nothing) -> outer + (Just outer, Just inner) -> + Just . Filter . QueryBoolQuery $ + mkBoolQuery [] [outer, inner] [] [] + newtype ScrollId = ScrollId Text deriving newtype (Eq, Ord, Show, ToJSON, FromJSON) +-- | URI-level parameters accepted by @POST /_search/scroll@ (the +-- 'advanceScroll' endpoint). Both Elasticsearch and OpenSearch accept +-- @scroll@ and @scroll_id@ as either URI parameters or JSON body fields; +-- this client always sends them in the body (see 'advanceScroll' / +-- 'advanceScrollWith'), which is the documented preferred form, so the +-- 'AdvanceScrollOptions' record only carries the parameters that are +-- /not/ already part of the request body. +-- +-- See +-- +-- and +-- . +-- +-- @'defaultAdvanceScrollOptions'@ produces no URI parameters, so +-- @'advanceScrollWith' 'defaultAdvanceScrollOptions'@ is byte-for-byte +-- identical to the legacy 'advanceScroll'. +data AdvanceScrollOptions = AdvanceScrollOptions + { -- | When @'Just' 'True'@, send @?rest_total_hits_as_int=true@ so the + -- server renders @hits.total@ as a bare integer (e.g. @5@) instead of + -- the object form @{"value": 5, "relation": "eq"}@. The + -- 'FromJSON' 'HitsTotal' instance accepts both shapes, so callers can + -- enable this without breaking response decoding. The server-side + -- default is @false@; explicit @'Just' 'False'@ is sent as + -- @rest_total_hits_as_int=false@ (matching the rendering convention + -- used by the other option records), and 'Nothing' omits the + -- parameter entirely. + asoRestTotalHitsAsInt :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'AdvanceScrollOptions' with every field set to 'Nothing'. Produces +-- an empty query string, preserving the wire behaviour of the legacy +-- parameterless 'advanceScroll'. +defaultAdvanceScrollOptions :: AdvanceScrollOptions +defaultAdvanceScrollOptions = + AdvanceScrollOptions + { asoRestTotalHitsAsInt = Nothing + } + +asoRestTotalHitsAsIntLens :: Lens' AdvanceScrollOptions (Maybe Bool) +asoRestTotalHitsAsIntLens = + lens asoRestTotalHitsAsInt (\x y -> x {asoRestTotalHitsAsInt = y}) + +-- | Render 'AdvanceScrollOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultAdvanceScrollOptions' produces an empty list (and therefore +-- no query string). Explicit @'Just' 'False'@ is sent as +-- @rest_total_hits_as_int=false@, matching the convention used by the +-- other @*OptionsParams@ renderers in this package. +advanceScrollOptionsParams :: AdvanceScrollOptions -> [(Text, Maybe Text)] +advanceScrollOptionsParams opts = + catMaybes + [ ("rest_total_hits_as_int",) . Just . boolQP <$> asoRestTotalHitsAsInt opts + ] + where + boolQP True = "true" + boolQP False = "false" + +-- | Response body for @DELETE /_search/scroll@ (Clear Scroll API). +-- Same shape as 'ClosePointInTimeResponse' from the PIT API, but kept +-- separate to preserve semantic clarity. Both Elasticsearch and OpenSearch +-- return @{"succeeded": bool, "num_freed": int}@, which is distinct from +-- the 'Acknowledged' shape used by most management endpoints — reusing +-- 'Acknowledged' here would silently break JSON decoding. +data ClearScrollResponse = ClearScrollResponse + { clearScrollSucceeded :: Bool, + clearScrollNumFreed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON ClearScrollResponse where + parseJSON = + withObject "ClearScrollResponse" $ \o -> + ClearScrollResponse + <$> o .: "succeeded" + <*> o .: "num_freed" + +instance ToJSON ClearScrollResponse where + toJSON ClearScrollResponse {..} = + object + [ "succeeded" .= clearScrollSucceeded, + "num_freed" .= clearScrollNumFreed + ] + +clearScrollSucceededLens :: Lens' ClearScrollResponse Bool +clearScrollSucceededLens = lens clearScrollSucceeded (\x y -> x {clearScrollSucceeded = y}) + +clearScrollNumFreedLens :: Lens' ClearScrollResponse Int +clearScrollNumFreedLens = lens clearScrollNumFreed (\x y -> x {clearScrollNumFreed = y}) + newtype SearchTemplateId = SearchTemplateId Text deriving stock (Eq, Show) instance ToJSON SearchTemplateId where @@ -255,54 +810,15 @@ parseJSON (String s) = pure $ SearchTemplateSource s parseJSON _ = empty -data ExpandWildcards - = ExpandWildcardsAll - | ExpandWildcardsOpen - | ExpandWildcardsClosed - | ExpandWildcardsNone - deriving stock (Eq, Show) - -instance ToJSON ExpandWildcards where - toJSON ExpandWildcardsAll = String "all" - toJSON ExpandWildcardsOpen = String "open" - toJSON ExpandWildcardsClosed = String "closed" - toJSON ExpandWildcardsNone = String "none" - -instance FromJSON ExpandWildcards where - parseJSON (String "all") = pure $ ExpandWildcardsAll - parseJSON (String "open") = pure $ ExpandWildcardsOpen - parseJSON (String "closed") = pure $ ExpandWildcardsClosed - parseJSON (String "none") = pure $ ExpandWildcardsNone - parseJSON _ = empty - -data TimeUnits - = TimeUnitDays - | TimeUnitHours - | TimeUnitMinutes - | TimeUnitSeconds - | TimeUnitMilliseconds - | TimeUnitMicroseconds - | TimeUnitNanoseconds - deriving stock (Eq, Show) - -instance ToJSON TimeUnits where - toJSON TimeUnitDays = String "d" - toJSON TimeUnitHours = String "h" - toJSON TimeUnitMinutes = String "m" - toJSON TimeUnitSeconds = String "s" - toJSON TimeUnitMilliseconds = String "ms" - toJSON TimeUnitMicroseconds = String "micros" - toJSON TimeUnitNanoseconds = String "nanos" - -instance FromJSON TimeUnits where - parseJSON (String "d") = pure $ TimeUnitDays - parseJSON (String "h") = pure $ TimeUnitHours - parseJSON (String "m") = pure $ TimeUnitMinutes - parseJSON (String "s") = pure $ TimeUnitSeconds - parseJSON (String "ms") = pure $ TimeUnitMilliseconds - parseJSON (String "micros") = pure $ TimeUnitMicroseconds - parseJSON (String "nanos") = pure $ TimeUnitNanoseconds - parseJSON _ = empty +-- $expandWildcards +-- +-- The @expand_wildcards@ sum type lives in +-- "Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards" +-- (a leaf module) so that every type module can import it without +-- risking a cycle. It is re-exported from here for backwards +-- compatibility — existing call sites that import it from +-- "Database.Bloodhound.Internal.Versions.Common.Types.Search" keep +-- working unchanged. data SearchTemplate = SearchTemplate { searchTemplate :: Either SearchTemplateId SearchTemplateSource, @@ -379,3 +895,256 @@ parseJSON (String fn) = pure $ DocvalueFieldName $ FieldName fn parseJSON (Object o) = DocvalueFieldNameAndFormat <$> o .: "field" <*> o .: "format" parseJSON _ = empty + +-- --------------------------------------------------------------------------- +-- Search body: runtime mappings (.7.1.1) +-- --------------------------------------------------------------------------- + +-- | Runtime field type for a 'RuntimeMapping'. Both Elasticsearch and +-- OpenSearch (via the mappings endpoint) accept the same six types. +data RuntimeType + = RuntimeTypeBoolean + | RuntimeTypeDate + | RuntimeTypeDouble + | RuntimeTypeKeyword + | RuntimeTypeLong + | RuntimeTypeIP + deriving stock (Eq, Show) + +-- | Wire rendering of a 'RuntimeType' value (single source of truth for +-- both 'ToJSON' and 'FromJSON'). +runtimeTypeText :: RuntimeType -> Text +runtimeTypeText RuntimeTypeBoolean = "boolean" +runtimeTypeText RuntimeTypeDate = "date" +runtimeTypeText RuntimeTypeDouble = "double" +runtimeTypeText RuntimeTypeKeyword = "keyword" +runtimeTypeText RuntimeTypeLong = "long" +runtimeTypeText RuntimeTypeIP = "ip" + +instance ToJSON RuntimeType where + toJSON = String . runtimeTypeText + +instance FromJSON RuntimeType where + parseJSON (String "boolean") = pure RuntimeTypeBoolean + parseJSON (String "date") = pure RuntimeTypeDate + parseJSON (String "double") = pure RuntimeTypeDouble + parseJSON (String "keyword") = pure RuntimeTypeKeyword + parseJSON (String "long") = pure RuntimeTypeLong + parseJSON (String "ip") = pure RuntimeTypeIP + parseJSON _ = empty + +-- | A Painless \/ expression script that computes the runtime field value. +data RuntimeScript = RuntimeScript + { runtimeScriptSource :: Text, + runtimeScriptParams :: Maybe (HM.HashMap Text Value), + runtimeScriptLang :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON RuntimeScript where + toJSON RuntimeScript {..} = + omitNulls + [ "source" .= runtimeScriptSource, + "params" .= runtimeScriptParams, + "lang" .= runtimeScriptLang + ] + +instance FromJSON RuntimeScript where + parseJSON = withObject "RuntimeScript" $ \o -> + RuntimeScript + <$> o + .: "source" + <*> o + .:? "params" + <*> o + .:? "lang" + +-- | Definition of a single runtime field: its type and optional script. +data RuntimeMapping = RuntimeMapping + { runtimeMappingType :: RuntimeType, + runtimeMappingScript :: Maybe RuntimeScript + } + deriving stock (Eq, Show) + +instance ToJSON RuntimeMapping where + toJSON RuntimeMapping {..} = + omitNulls + [ "type" .= runtimeMappingType, + "script" .= runtimeMappingScript + ] + +instance FromJSON RuntimeMapping where + parseJSON = withObject "RuntimeMapping" $ \o -> + RuntimeMapping + <$> o + .: "type" + <*> o + .:? "script" + +-- | A map of field name to 'RuntimeMapping'. Renders as a bare JSON object +-- (not wrapped in a key) so that it can be placed directly under the +-- @\"runtime_mappings\"@ body field. +newtype RuntimeMappings = RuntimeMappings (HM.HashMap Text RuntimeMapping) + deriving stock (Eq, Show) + deriving newtype (ToJSON, FromJSON) + +-- --------------------------------------------------------------------------- +-- Search body: rescore (.7.1.2) +-- --------------------------------------------------------------------------- + +-- | Score combination mode for a 'RescoreQuery'. Controls how the original +-- query score and the rescore query score are merged. +data RescoreScoreMode + = RescoreScoreModeAvg + | RescoreScoreModeMax + | RescoreScoreModeMin + | RescoreScoreModeTotal + | RescoreScoreModeMultiply + deriving stock (Eq, Show) + +-- | Wire rendering of a 'RescoreScoreMode'. +rescoreScoreModeText :: RescoreScoreMode -> Text +rescoreScoreModeText RescoreScoreModeAvg = "avg" +rescoreScoreModeText RescoreScoreModeMax = "max" +rescoreScoreModeText RescoreScoreModeMin = "min" +rescoreScoreModeText RescoreScoreModeTotal = "total" +rescoreScoreModeText RescoreScoreModeMultiply = "multiply" + +instance ToJSON RescoreScoreMode where + toJSON = String . rescoreScoreModeText + +instance FromJSON RescoreScoreMode where + parseJSON (String "avg") = pure RescoreScoreModeAvg + parseJSON (String "max") = pure RescoreScoreModeMax + parseJSON (String "min") = pure RescoreScoreModeMin + parseJSON (String "total") = pure RescoreScoreModeTotal + -- ES accepts "sum" as an alias for "total" + parseJSON (String "sum") = pure RescoreScoreModeTotal + parseJSON (String "multiply") = pure RescoreScoreModeMultiply + parseJSON _ = empty + +-- | The rescore query body. Lives under the @\"query\"@ key of a 'Rescore' +-- clause. +data RescoreQuery = RescoreQuery + { rescoreQueryRescoreQuery :: Query, + rescoreQueryQueryWeight :: Maybe Double, + rescoreQueryRescoreQueryWeight :: Maybe Double, + rescoreQueryScoreMode :: Maybe RescoreScoreMode + } + deriving stock (Eq, Show) + +instance ToJSON RescoreQuery where + toJSON RescoreQuery {..} = + omitNulls + [ "rescore_query" .= rescoreQueryRescoreQuery, + "query_weight" .= rescoreQueryQueryWeight, + "rescore_query_weight" .= rescoreQueryRescoreQueryWeight, + "score_mode" .= rescoreQueryScoreMode + ] + +instance FromJSON RescoreQuery where + parseJSON = withObject "RescoreQuery" $ \o -> + RescoreQuery + <$> o + .: "rescore_query" + <*> o + .:? "query_weight" + <*> o + .:? "rescore_query_weight" + <*> o + .:? "score_mode" + +-- | A single rescore clause. The top-level @\"rescore\"@ body field is a +-- JSON array of these. +data Rescore = Rescore + { rescoreWindowSize :: Maybe Int, + rescoreQueryBody :: RescoreQuery + } + deriving stock (Eq, Show) + +instance ToJSON Rescore where + toJSON Rescore {..} = + omitNulls + [ "window_size" .= rescoreWindowSize, + "query" .= rescoreQueryBody + ] + +instance FromJSON Rescore where + parseJSON = withObject "Rescore" $ \o -> + Rescore + <$> o + .:? "window_size" + <*> o + .: "query" + +-- --------------------------------------------------------------------------- +-- Search body: collapse (.7.1.3) +-- --------------------------------------------------------------------------- + +-- | Configuration for returning inner hits within a collapsed group. +-- Mirrors a subset of the top-level 'Search' hit options. Distinct from +-- "Database.Bloodhound.Internal.Versions.Common.Types.Query"'s @InnerHits@ +-- (used by nested queries) which only carries @from@ and @size@; a future +-- refactor could unify the two. +-- +-- The @sort@ option is not yet modelled here because 'SortSpec' lacks a +-- 'FromJSON' instance; add it once the Sort module is made round-trippable. +data CollapseInnerHits = CollapseInnerHits + { collapseInnerHitsName :: Maybe Text, + collapseInnerHitsSize :: Maybe Int, + collapseInnerHitsFrom :: Maybe From, + -- | Second-level collapse applied to this inner_hits group. Per the + -- , + -- nested collapse lives inside @inner_hits@, not at the top level. + collapseInnerHitsCollapse :: Maybe Collapse + } + deriving stock (Eq, Show) + +instance ToJSON CollapseInnerHits where + toJSON CollapseInnerHits {..} = + omitNulls + [ "name" .= collapseInnerHitsName, + "size" .= collapseInnerHitsSize, + "from" .= collapseInnerHitsFrom, + "collapse" .= collapseInnerHitsCollapse + ] + +instance FromJSON CollapseInnerHits where + parseJSON = withObject "CollapseInnerHits" $ \o -> + CollapseInnerHits + <$> o + .:? "name" + <*> o + .:? "size" + <*> o + .:? "from" + <*> o + .:? "collapse" + +-- | Field collapsing groups results by a field value, returning only the +-- top-ranked document per group. Second-level collapse is configured on +-- 'collapseInnerHits', not here (per the ES wire format). +data Collapse = Collapse + { collapseField :: FieldName, + collapseInnerHits :: Maybe [CollapseInnerHits], + collapseMaxConcurrentGroupSearches :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON Collapse where + toJSON Collapse {..} = + omitNulls + [ "field" .= collapseField, + "inner_hits" .= collapseInnerHits, + "max_concurrent_group_searches" .= collapseMaxConcurrentGroupSearches + ] + +instance FromJSON Collapse where + parseJSON = withObject "Collapse" $ \o -> + Collapse + <$> o + .: "field" + <*> o + .:? "inner_hits" + <*> o + .:? "max_concurrent_group_searches" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/SearchShards.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/SearchShards.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/SearchShards.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.SearchShards +-- +-- Request and response types for the @POST \/{indices}\/_search_shards@ +-- endpoint (also reachable via @GET@), which returns the shards and +-- nodes that a search /would/ be executed against — without running +-- the search itself. Useful for understanding routing, preference and +-- replica choice ahead of issuing the actual search. +-- +-- See +-- +-- and +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.SearchShards + ( -- * Response + SearchShardsResponse (..), + SearchShardsNode (..), + SearchShardsShard (..), + SearchShardsState (..), + + -- * URI parameters + SearchShardsOptions (..), + defaultSearchShardsOptions, + searchShardsOptionsParams, + + -- * Optics + searchShardsResponseNodesLens, + searchShardsResponseIndicesLens, + searchShardsResponseShardsLens, + searchShardsNodeNameLens, + searchShardsNodeEphemeralIdLens, + searchShardsNodeTransportAddressLens, + searchShardsNodeHostLens, + searchShardsNodeIpLens, + searchShardsNodeAttributesLens, + searchShardsNodeRolesLens, + searchShardsNodeOtherLens, + searchShardsShardIndexLens, + searchShardsShardNodeLens, + searchShardsShardPrimaryLens, + searchShardsShardShardLens, + searchShardsShardStateLens, + searchShardsShardRelocatingNodeLens, + searchShardsShardAllocationIdLens, + searchShardsShardOtherLens, + sshoAllowNoIndicesLens, + sshoExpandWildcardsLens, + sshoIgnoreUnavailableLens, + sshoLocalLens, + sshoMasterTimeoutLens, + sshoPreferenceLens, + sshoRoutingLens, + ) +where + +import Data.Aeson +import Data.Aeson.Key qualified as AK +import Data.Aeson.KeyMap qualified as X +import Data.Map.Strict qualified as M +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports (showText, typeMismatch) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( IndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Search + ( ExpandWildcards, + expandWildcardsText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Units + ( TimeUnits, + timeUnitsSuffix, + ) +import Optics.Lens + +-- | Top-level response body for @/{indices}/_search_shards@. The +-- @nodes@ map is keyed by node id (an opaque ES-generated string) and +-- is empty when no shards would be touched (e.g. the requested index +-- does not exist or no shard copies are currently assigned). The +-- @indices@ map is keyed by index name; ES currently emits an empty +-- object per index but the value is kept as a 'Value' so future +-- index-level metadata is preserved rather than rejected. The +-- @shards@ array is /nested/: each outer element corresponds to one +-- shard number, and the inner array lists every copy of that shard +-- (primary followed by any assigned replicas) that the search would +-- be routed to. +data SearchShardsResponse = SearchShardsResponse + { searchShardsResponseNodes :: M.Map Text SearchShardsNode, + searchShardsResponseIndices :: M.Map IndexName Value, + searchShardsResponseShards :: [[SearchShardsShard]] + } + deriving stock (Eq, Show) + +instance FromJSON SearchShardsResponse where + parseJSON = withObject "SearchShardsResponse" $ \o -> do + nodes <- o .:? "nodes" .!= M.empty + indices <- o .:? "indices" .!= M.empty + shards <- o .:? "shards" .!= [] + pure $ + SearchShardsResponse + { searchShardsResponseNodes = nodes, + searchShardsResponseIndices = indices, + searchShardsResponseShards = shards + } + +searchShardsResponseNodesLens :: + Lens' SearchShardsResponse (M.Map Text SearchShardsNode) +searchShardsResponseNodesLens = + lens searchShardsResponseNodes (\x y -> x {searchShardsResponseNodes = y}) + +searchShardsResponseIndicesLens :: + Lens' SearchShardsResponse (M.Map IndexName Value) +searchShardsResponseIndicesLens = + lens searchShardsResponseIndices (\x y -> x {searchShardsResponseIndices = y}) + +searchShardsResponseShardsLens :: + Lens' SearchShardsResponse [[SearchShardsShard]] +searchShardsResponseShardsLens = + lens searchShardsResponseShards (\x y -> x {searchShardsResponseShards = y}) + +-- | Per-node metadata emitted under the @nodes@ map. ES emits a +-- richer set of fields than OpenSearch; the typed subset below is the +-- union of both, with anything else preserved verbatim in +-- 'searchShardsNodeOther' (mirroring 'ShardStoreNode.shardStoreNodeOther'). +data SearchShardsNode = SearchShardsNode + { searchShardsNodeName :: Maybe Text, + searchShardsNodeEphemeralId :: Maybe Text, + searchShardsNodeTransportAddress :: Maybe Text, + searchShardsNodeHost :: Maybe Text, + searchShardsNodeIp :: Maybe Text, + searchShardsNodeAttributes :: Maybe (M.Map Text Text), + searchShardsNodeRoles :: Maybe [Text], + searchShardsNodeOther :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON SearchShardsNode where + parseJSON = withObject "SearchShardsNode" parse + where + knownKeys = + [ "name", + "ephemeral_id", + "transport_address", + "host", + "ip", + "attributes", + "roles" + ] + parse o = do + name <- o .:? "name" + ephemeralId <- o .:? "ephemeral_id" + transportAddress <- o .:? "transport_address" + host <- o .:? "host" + ip <- o .:? "ip" + attributes <- o .:? "attributes" + roles <- o .:? "roles" + let other = + case X.filterWithKey (\k _ -> AK.toText k `notElem` knownKeys) o of + km | X.null km -> Nothing + km -> Just (Object km) + pure $ + SearchShardsNode + name + ephemeralId + transportAddress + host + ip + attributes + roles + other + +searchShardsNodeNameLens :: Lens' SearchShardsNode (Maybe Text) +searchShardsNodeNameLens = + lens searchShardsNodeName (\x y -> x {searchShardsNodeName = y}) + +searchShardsNodeEphemeralIdLens :: Lens' SearchShardsNode (Maybe Text) +searchShardsNodeEphemeralIdLens = + lens searchShardsNodeEphemeralId (\x y -> x {searchShardsNodeEphemeralId = y}) + +searchShardsNodeTransportAddressLens :: Lens' SearchShardsNode (Maybe Text) +searchShardsNodeTransportAddressLens = + lens + searchShardsNodeTransportAddress + (\x y -> x {searchShardsNodeTransportAddress = y}) + +searchShardsNodeHostLens :: Lens' SearchShardsNode (Maybe Text) +searchShardsNodeHostLens = + lens searchShardsNodeHost (\x y -> x {searchShardsNodeHost = y}) + +searchShardsNodeIpLens :: Lens' SearchShardsNode (Maybe Text) +searchShardsNodeIpLens = + lens searchShardsNodeIp (\x y -> x {searchShardsNodeIp = y}) + +searchShardsNodeAttributesLens :: Lens' SearchShardsNode (Maybe (M.Map Text Text)) +searchShardsNodeAttributesLens = + lens searchShardsNodeAttributes (\x y -> x {searchShardsNodeAttributes = y}) + +searchShardsNodeRolesLens :: Lens' SearchShardsNode (Maybe [Text]) +searchShardsNodeRolesLens = + lens searchShardsNodeRoles (\x y -> x {searchShardsNodeRoles = y}) + +searchShardsNodeOtherLens :: Lens' SearchShardsNode (Maybe Value) +searchShardsNodeOtherLens = + lens searchShardsNodeOther (\x y -> x {searchShardsNodeOther = y}) + +-- | The @state@ of a shard copy within the routing table, as emitted +-- by @/_search_shards@. ES documents @INITIALIZING@, @RELOCATING@, +-- @STARTED@ and @UNASSIGNED@; OpenSearch emits the same set. Unknown +-- values (present or future) round-trip through 'SearchShardsStateOther'. +data SearchShardsState + = SearchShardsStateInitializing + | SearchShardsStateRelocating + | SearchShardsStateStarted + | SearchShardsStateUnassigned + | SearchShardsStateOther Text + deriving stock (Eq, Show) + +instance FromJSON SearchShardsState where + parseJSON (String "INITIALIZING") = pure SearchShardsStateInitializing + parseJSON (String "RELOCATING") = pure SearchShardsStateRelocating + parseJSON (String "STARTED") = pure SearchShardsStateStarted + parseJSON (String "UNASSIGNED") = pure SearchShardsStateUnassigned + parseJSON (String other) = pure $ SearchShardsStateOther other + parseJSON other = typeMismatch "SearchShardsState" other + +instance ToJSON SearchShardsState where + toJSON SearchShardsStateInitializing = String "INITIALIZING" + toJSON SearchShardsStateRelocating = String "RELOCATING" + toJSON SearchShardsStateStarted = String "STARTED" + toJSON SearchShardsStateUnassigned = String "UNASSIGNED" + toJSON (SearchShardsStateOther t) = String t + +-- | A single shard copy that the search would touch. The @node@ field +-- is the routing-table node id (a key of 'searchShardsResponseNodes'), +-- or 'Nothing' when the shard is currently unassigned. The +-- @relocating_node@ is non-null only while a shard copy is in flight +-- between two nodes. The @allocation_id@ object is server-shaped +-- (e.g. @{"id": "..."}@) and kept as a 'Map' for forward-compat. Any +-- future sibling field the parser does not know about is preserved +-- verbatim in 'searchShardsShardOther'. +data SearchShardsShard = SearchShardsShard + { searchShardsShardIndex :: IndexName, + searchShardsShardNode :: Maybe Text, + searchShardsShardPrimary :: Bool, + searchShardsShardShard :: Int, + searchShardsShardState :: SearchShardsState, + searchShardsShardRelocatingNode :: Maybe Text, + searchShardsShardAllocationId :: Maybe (M.Map Text Text), + searchShardsShardOther :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON SearchShardsShard where + parseJSON = withObject "SearchShardsShard" parse + where + knownKeys = + [ "index", + "node", + "primary", + "shard", + "state", + "relocating_node", + "allocation_id" + ] + parse o = do + index <- o .: "index" + node <- o .:? "node" + primary <- o .:? "primary" .!= False + shard <- o .:? "shard" .!= 0 + state <- o .: "state" + relocatingNode <- o .:? "relocating_node" + allocationId <- o .:? "allocation_id" + let other = + case X.filterWithKey (\k _ -> AK.toText k `notElem` knownKeys) o of + km | X.null km -> Nothing + km -> Just (Object km) + pure $ + SearchShardsShard + index + node + primary + shard + state + relocatingNode + allocationId + other + +searchShardsShardIndexLens :: Lens' SearchShardsShard IndexName +searchShardsShardIndexLens = + lens searchShardsShardIndex (\x y -> x {searchShardsShardIndex = y}) + +searchShardsShardNodeLens :: Lens' SearchShardsShard (Maybe Text) +searchShardsShardNodeLens = + lens searchShardsShardNode (\x y -> x {searchShardsShardNode = y}) + +searchShardsShardPrimaryLens :: Lens' SearchShardsShard Bool +searchShardsShardPrimaryLens = + lens searchShardsShardPrimary (\x y -> x {searchShardsShardPrimary = y}) + +searchShardsShardShardLens :: Lens' SearchShardsShard Int +searchShardsShardShardLens = + lens searchShardsShardShard (\x y -> x {searchShardsShardShard = y}) + +searchShardsShardStateLens :: Lens' SearchShardsShard SearchShardsState +searchShardsShardStateLens = + lens searchShardsShardState (\x y -> x {searchShardsShardState = y}) + +searchShardsShardRelocatingNodeLens :: + Lens' SearchShardsShard (Maybe Text) +searchShardsShardRelocatingNodeLens = + lens + searchShardsShardRelocatingNode + (\x y -> x {searchShardsShardRelocatingNode = y}) + +searchShardsShardAllocationIdLens :: + Lens' SearchShardsShard (Maybe (M.Map Text Text)) +searchShardsShardAllocationIdLens = + lens + searchShardsShardAllocationId + (\x y -> x {searchShardsShardAllocationId = y}) + +searchShardsShardOtherLens :: Lens' SearchShardsShard (Maybe Value) +searchShardsShardOtherLens = + lens searchShardsShardOther (\x y -> x {searchShardsShardOther = y}) + +-- | URI parameters accepted by @/{indices}/_search_shards@: +-- @allow_no_indices@, @expand_wildcards@ (comma-joined on the wire), +-- @ignore_unavailable@, @local@ (deprecated but still accepted — +-- returns only information from the local node), @master_timeout@ (an +-- @(units, magnitude)@ pair rendered via 'timeUnitsSuffix', e.g. +-- @('TimeUnitSeconds', 30)@ -> @30s@), @preference@ (the +-- routing-preference hint, e.g. @_only_local@, @_primary@, +-- @_shards:2,4@) and @routing@ (a custom routing value, comma-joined +-- when more than one). Every field is optional so +-- 'defaultSearchShardsOptions' renders to no query string at all — +-- byte-for-byte identical to a parameterless call. +data SearchShardsOptions = SearchShardsOptions + { sshoAllowNoIndices :: Maybe Bool, + sshoExpandWildcards :: Maybe [ExpandWildcards], + sshoIgnoreUnavailable :: Maybe Bool, + sshoLocal :: Maybe Bool, + sshoMasterTimeout :: Maybe (TimeUnits, Word32), + sshoPreference :: Maybe Text, + sshoRouting :: Maybe [Text] + } + deriving stock (Eq, Show) + +-- | 'SearchShardsOptions' with every parameter set to 'Nothing'. +-- Produces no query string, so a call made with this value is +-- byte-identical to a parameterless call. +defaultSearchShardsOptions :: SearchShardsOptions +defaultSearchShardsOptions = + SearchShardsOptions + { sshoAllowNoIndices = Nothing, + sshoExpandWildcards = Nothing, + sshoIgnoreUnavailable = Nothing, + sshoLocal = Nothing, + sshoMasterTimeout = Nothing, + sshoPreference = Nothing, + sshoRouting = Nothing + } + +sshoAllowNoIndicesLens :: Lens' SearchShardsOptions (Maybe Bool) +sshoAllowNoIndicesLens = + lens sshoAllowNoIndices (\x y -> x {sshoAllowNoIndices = y}) + +sshoExpandWildcardsLens :: + Lens' SearchShardsOptions (Maybe [ExpandWildcards]) +sshoExpandWildcardsLens = + lens sshoExpandWildcards (\x y -> x {sshoExpandWildcards = y}) + +sshoIgnoreUnavailableLens :: Lens' SearchShardsOptions (Maybe Bool) +sshoIgnoreUnavailableLens = + lens sshoIgnoreUnavailable (\x y -> x {sshoIgnoreUnavailable = y}) + +sshoLocalLens :: Lens' SearchShardsOptions (Maybe Bool) +sshoLocalLens = + lens sshoLocal (\x y -> x {sshoLocal = y}) + +sshoMasterTimeoutLens :: Lens' SearchShardsOptions (Maybe (TimeUnits, Word32)) +sshoMasterTimeoutLens = + lens sshoMasterTimeout (\x y -> x {sshoMasterTimeout = y}) + +sshoPreferenceLens :: Lens' SearchShardsOptions (Maybe Text) +sshoPreferenceLens = + lens sshoPreference (\x y -> x {sshoPreference = y}) + +sshoRoutingLens :: Lens' SearchShardsOptions (Maybe [Text]) +sshoRoutingLens = + lens sshoRouting (\x y -> x {sshoRouting = y}) + +-- | Render 'SearchShardsOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultSearchShardsOptions' produces an empty list (and therefore +-- no query string). +searchShardsOptionsParams :: SearchShardsOptions -> [(Text, Maybe Text)] +searchShardsOptionsParams opts = + catMaybes + [ ("allow_no_indices",) . Just . boolText <$> sshoAllowNoIndices opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> sshoExpandWildcards opts, + ("ignore_unavailable",) . Just . boolText <$> sshoIgnoreUnavailable opts, + ("local",) . Just . boolText <$> sshoLocal opts, + ("master_timeout",) . Just . renderDuration <$> sshoMasterTimeout opts, + ("preference",) . Just <$> sshoPreference opts, + ("routing",) . Just . renderRouting <$> sshoRouting opts + ] + where + boolText True = "true" + boolText False = "false" + renderExpandWildcards = T.intercalate "," . map expandWildcardsText + renderRouting = T.intercalate "," + renderDuration (u, n) = showText n <> timeUnitsSuffix u diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/SearchableSnapshots.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/SearchableSnapshots.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/SearchableSnapshots.hs @@ -0,0 +1,468 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.SearchableSnapshots +-- Description : Types for the Elasticsearch X-Pack Searchable Snapshots API +-- +-- Defines the request and response shapes for the ES X-Pack Searchable +-- Snapshots endpoints (under @\/_searchable_snapshots\/*@ and the +-- @\/_snapshot\/{repo}\/{snapshot}\/_mount@ mount point). A searchable +-- snapshot exposes a backed-up snapshot as a searchable, lazily-fetched +-- index, letting cold data live on cheap object storage while remaining +-- queryable. A shared cache (the @shared_cache@ storage mode) lets many +-- searchable-snapshot indices share a node-local cache. +-- +-- * @POST /_snapshot\/{repository}\/{snapshot}/_mount@ — +-- 'mountSearchableSnapshot' ('SearchableSnapshotMount' body, +-- 'SearchableSnapshotMountOptions' query params, +-- 'SearchableSnapshotMountResponse' response). +-- * @GET /_searchable_snapshots/stats@ — 'getSearchableSnapshotsStats' +-- ('SearchableSnapshotsStatsResponse'). +-- * @POST /_searchable_snapshots/{index}/_cache_stats@ — +-- 'getSearchableSnapshotsCacheStats' +-- ('SearchableSnapshotsCacheStatsResponse'). +-- * @POST /_searchable_snapshots/{index}/_clear_cache@ — +-- 'clearSearchableSnapshotsCache' (returns 'Acknowledged'). +-- +-- Searchable snapshots ship in Elasticsearch 7.x\/8.x\/9.x (the free, +-- basic X-Pack tier for @shared_partial_cache@; @shared_cache@ is +-- enterprise-only since 7.13). ES7\/ES8\/ES9 share the same wire +-- surface, which is why these types live in the Common layer alongside +-- SLM\/ILM\/RepositoriesMetering. OpenSearch does not implement this +-- API, so calls against an OpenSearch cluster will fail at runtime — +-- the types are still hosted under @Common@ to match the project's +-- SLM\/DiskUsage precedent. +-- +-- The mount request body is modelled with the documented typed fields +-- plus an @ssmExtras@ 'KeyMap' catch-all so unknown sibling fields +-- survive a @encode . decode@ round-trip (the same strategy used by +-- "Database.Bloodhound.Internal.Versions.Common.Types.Enrich" and the +-- RepositoriesMetering precedent). The stats responses are highly +-- variable across ES versions, so the stable top-level envelope is +-- typed (@total@, @indices@\/@nodes@ as a 'KeyMap') while the leaf +-- stat objects are carried as opaque 'Value's — forward-compatible by +-- design. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.SearchableSnapshots + ( -- * Mount request body + SearchableSnapshotMount (..), + defaultSearchableSnapshotMount, + searchableSnapshotMountIndexLens, + searchableSnapshotMountRenamedIndexLens, + searchableSnapshotMountIndexSettingsLens, + searchableSnapshotMountIgnoreIndexSettingsLens, + searchableSnapshotMountExtrasLens, + + -- * Mount options + SearchableSnapshotStorage (..), + searchableSnapshotStorageText, + SearchableSnapshotMountOptions (..), + defaultSearchableSnapshotMountOptions, + searchableSnapshotMountOptionsParams, + searchableSnapshotMountOptionsMasterTimeoutLens, + searchableSnapshotMountOptionsWaitForCompletionLens, + searchableSnapshotMountOptionsStorageLens, + + -- * Mount response + SearchableSnapshotMountResponse (..), + searchableSnapshotMountResponseSnapshotLens, + searchableSnapshotMountResponseExtrasLens, + + -- * Stats response + SearchableSnapshotsStatsResponse (..), + searchableSnapshotsStatsResponseTotalLens, + searchableSnapshotsStatsResponseIndicesLens, + searchableSnapshotsStatsResponseNodesLens, + searchableSnapshotsStatsResponseExtrasLens, + + -- * Cache stats response + SearchableSnapshotsCacheStatsResponse (..), + searchableSnapshotsCacheStatsResponseIndicesLens, + searchableSnapshotsCacheStatsResponseExtrasLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( IndexName, + ) + +-- | The request body for +-- @POST /_snapshot\/{repository}\/{snapshot}/_mount@. Only @index@ is +-- required (the mounted index name); the rest override how ES +-- materialises the searchable-snapshot index. Unknown sibling fields +-- are preserved in 'ssmExtras' so the structure round-trips through +-- @encode . decode@ even when ES adds new optional fields. +data SearchableSnapshotMount = SearchableSnapshotMount + { -- | @index@ — the name of the searchable-snapshot index ES will + -- create. This is the mounted index name, distinct from the source + -- index inside the snapshot. + ssmIndex :: IndexName, + -- | @renamed_index@ — an alternate name for the mounted index when + -- the source snapshot's index name must not collide with an + -- existing one. + ssmRenamedIndex :: Maybe Text, + -- | @index_settings@ — overrides applied to the mounted index's + -- settings. Carried as an opaque 'Value' because it is an + -- open-ended settings body (callers build it with the typed + -- settings and 'toJSON' it in). Mirrors the SLM\/Enrich precedent + -- for non-category-specific nested bodies. + ssmIndexSettings :: Maybe Value, + -- | @ignore_index_settings@ — settings stripped from the mounted + -- index (e.g. @[\"index.refresh_interval\"]@). + ssmIgnoreIndexSettings :: Maybe [Text], + -- | Catch-all for every other sibling field ES adds in future + -- (@storage@ on older variants, ...) so decode is forward-compatible + -- and @encode . decode@ round-trips. + ssmExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | A minimal mount body: just the required @index@, no overrides, no +-- extras. Intended as a starting point callers then overwrite with the +-- record lenses. +defaultSearchableSnapshotMount :: IndexName -> SearchableSnapshotMount +defaultSearchableSnapshotMount indexName = + SearchableSnapshotMount + { ssmIndex = indexName, + ssmRenamedIndex = Nothing, + ssmIndexSettings = Nothing, + ssmIgnoreIndexSettings = Nothing, + ssmExtras = KM.empty + } + +-- Known keys inside the mount body — used to split the decoded 'Object' +-- into the typed fields and the @ssmExtras@ catch-all. +mountKnownKeys :: [Key] +mountKnownKeys = ["index", "renamed_index", "index_settings", "ignore_index_settings"] + +instance FromJSON SearchableSnapshotMount where + parseJSON = withObject "SearchableSnapshotMount" $ \o -> do + index <- o .: "index" + renamedIndex <- o .:? "renamed_index" + indexSettings <- o .:? "index_settings" + ignoreIndexSettings <- o .:? "ignore_index_settings" + let extras = + KM.fromList $ + filter ((`notElem` mountKnownKeys) . fst) $ + KM.toList o + pure + SearchableSnapshotMount + { ssmIndex = index, + ssmRenamedIndex = renamedIndex, + ssmIndexSettings = indexSettings, + ssmIgnoreIndexSettings = ignoreIndexSettings, + ssmExtras = extras + } + +instance ToJSON SearchableSnapshotMount where + -- 'object' (not 'omitNulls') so the @ssmExtras@ catch-all survives a + -- round-trip even when it carries a @null@ or empty-array value — the + -- documented forward-compat guarantee. The known fields are + -- pre-filtered by 'catMaybes' (stripping 'Nothing's), so they never + -- contribute a 'Null' here, and the extras have already had the known + -- keys stripped on decode. + toJSON SearchableSnapshotMount {..} = + object $ + catMaybes + [ Just ("index" .= ssmIndex), + ("renamed_index" .=) <$> ssmRenamedIndex, + ("index_settings" .=) <$> ssmIndexSettings, + ("ignore_index_settings" .=) <$> ssmIgnoreIndexSettings + ] + <> [toPair kv | kv <- KM.toList ssmExtras] + where + toPair (k, v) = k .= v + +-- | The @storage@ query parameter for the mount endpoint, selecting the +-- cache strategy for the mounted index. Documented values: +-- @shared_partial_cache@ (the default since ES 7.12) and @shared_cache@ +-- (the full-copy shared cache, enterprise-only since 7.13). The custom +-- branch absorbs anything newer. +data SearchableSnapshotStorage + = SearchableSnapshotStorageSharedPartialCache + | SearchableSnapshotStorageSharedCache + | SearchableSnapshotStorageCustom Text + deriving stock (Eq, Show) + +-- | The wire spelling of each 'SearchableSnapshotStorage'. +searchableSnapshotStorageText :: SearchableSnapshotStorage -> Text +searchableSnapshotStorageText = \case + SearchableSnapshotStorageSharedPartialCache -> "shared_partial_cache" + SearchableSnapshotStorageSharedCache -> "shared_cache" + SearchableSnapshotStorageCustom t -> t + +instance ToJSON SearchableSnapshotStorage where + toJSON = toJSON . searchableSnapshotStorageText + +instance FromJSON SearchableSnapshotStorage where + parseJSON = withText "SearchableSnapshotStorage" $ \t -> pure $ + case t of + "shared_partial_cache" -> SearchableSnapshotStorageSharedPartialCache + "shared_cache" -> SearchableSnapshotStorageSharedCache + other -> SearchableSnapshotStorageCustom other + +-- | URI parameters accepted by +-- @POST /_snapshot\/{repository}\/{snapshot}/_mount@. All optional. +data SearchableSnapshotMountOptions = SearchableSnapshotMountOptions + { ssmoMasterTimeout :: Maybe Text, + -- | @wait_for_completion@ — when @false@ ES returns immediately + -- with an ack shape instead of the full snapshot-restore object; + -- defaults to @true@ on the server. + ssmoWaitForCompletion :: Maybe Bool, + ssmoStorage :: Maybe SearchableSnapshotStorage + } + deriving stock (Eq, Show) + +-- | An empty options record — encodes to no query string, reproducing +-- a parameterless mount. +defaultSearchableSnapshotMountOptions :: SearchableSnapshotMountOptions +defaultSearchableSnapshotMountOptions = + SearchableSnapshotMountOptions + { ssmoMasterTimeout = Nothing, + ssmoWaitForCompletion = Nothing, + ssmoStorage = Nothing + } + +-- | Render a 'SearchableSnapshotMountOptions' as a @(key, value)@ list +-- for 'withQueries'. 'Nothing' fields are omitted; booleans render as +-- @"true"@\/@"false"@. +searchableSnapshotMountOptionsParams :: + SearchableSnapshotMountOptions -> + [(Text, Maybe Text)] +searchableSnapshotMountOptionsParams SearchableSnapshotMountOptions {..} = + catMaybes + [ ("master_timeout",) . Just <$> ssmoMasterTimeout, + ("wait_for_completion",) . Just . boolText <$> ssmoWaitForCompletion, + ("storage",) . Just . searchableSnapshotStorageText <$> ssmoStorage + ] + where + boolText True = "true" + boolText False = "false" + +-- | Response body of @POST /_snapshot\/{repository}\/{snapshot}/_mount@. +-- When @wait_for_completion@ is @true@ (the default) ES returns a full +-- snapshot-restore object under the @snapshot@ key (carried as an +-- opaque 'Value' because its inner shape mirrors the variable restore +-- response); when @false@ ES returns an +-- @{"acknowledged": true, "shards_acknowledged": true}@ shape, whose +-- fields land in 'ssmrExtras'. Unknown sibling fields always survive a +-- round-trip via 'ssmrExtras'. +data SearchableSnapshotMountResponse = SearchableSnapshotMountResponse + { ssmrSnapshot :: Maybe Value, + ssmrExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +mountResponseKnownKeys :: [Key] +mountResponseKnownKeys = ["snapshot"] + +instance FromJSON SearchableSnapshotMountResponse where + parseJSON = withObject "SearchableSnapshotMountResponse" $ \o -> do + snapshot <- o .:? "snapshot" + let extras = + KM.fromList $ + filter ((`notElem` mountResponseKnownKeys) . fst) $ + KM.toList o + pure + SearchableSnapshotMountResponse + { ssmrSnapshot = snapshot, + ssmrExtras = extras + } + +instance ToJSON SearchableSnapshotMountResponse where + -- 'object' (not 'omitNulls') so @ssmrExtras@ round-trips verbatim. + toJSON SearchableSnapshotMountResponse {..} = + object $ + catMaybes + [ ("snapshot" .=) <$> ssmrSnapshot + ] + <> [toPair kv | kv <- KM.toList ssmrExtras] + where + toPair (k, v) = k .= v + +-- | Response body of @GET /_searchable_snapshots/stats@. ES nests the +-- cluster-wide totals under @total@ and per-index (and per-node) +-- statistics under @indices@\/@nodes@. The envelope is typed; the leaf +-- stat objects are carried as opaque 'Value's because their shape +-- (@file_cache_size@, @physical_size@, cache hit rates, ...) is not +-- stable across ES versions. Unknown top-level fields survive a +-- round-trip via 'sssreExtras'. +data SearchableSnapshotsStatsResponse = SearchableSnapshotsStatsResponse + { -- | @total@ — cluster-wide aggregate stats (opaque). + sssrTotal :: Maybe Value, + -- | @indices@ — per-index stats, keyed by index name. + sssrIndices :: Maybe (KeyMap Value), + -- | @nodes@ — per-node stats, keyed by node id (present in newer + -- ES versions). + sssrNodes :: Maybe (KeyMap Value), + sssrExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +statsResponseKnownKeys :: [Key] +statsResponseKnownKeys = ["total", "indices", "nodes"] + +instance FromJSON SearchableSnapshotsStatsResponse where + parseJSON = withObject "SearchableSnapshotsStatsResponse" $ \o -> do + total <- o .:? "total" + indices <- o .:? "indices" + nodes <- o .:? "nodes" + let extras = + KM.fromList $ + filter ((`notElem` statsResponseKnownKeys) . fst) $ + KM.toList o + pure + SearchableSnapshotsStatsResponse + { sssrTotal = total, + sssrIndices = indices, + sssrNodes = nodes, + sssrExtras = extras + } + +instance ToJSON SearchableSnapshotsStatsResponse where + -- 'object' (not 'omitNulls') so @sssrExtras@ round-trips verbatim even + -- when it carries a @null@ or empty-array value — the documented + -- forward-compat guarantee. The known fields are pre-filtered by + -- 'catMaybes' (stripping 'Nothing's), so they never contribute a 'Null'. + toJSON SearchableSnapshotsStatsResponse {..} = + object $ + catMaybes + [ ("total" .=) <$> sssrTotal, + ("indices" .=) <$> sssrIndices, + ("nodes" .=) <$> sssrNodes + ] + <> [toPair kv | kv <- KM.toList sssrExtras] + where + toPair (k, v) = k .= v + +-- | Response body of +-- @POST /_searchable_snapshots/{index}/_cache_stats@. The cache stats +-- are keyed by index name under @indices@; the leaf objects (cache +-- size, usage, per-node breakdown) are opaque 'Value's. Unknown +-- top-level fields survive a round-trip via 'sscsrExtras'. +data SearchableSnapshotsCacheStatsResponse = SearchableSnapshotsCacheStatsResponse + { sscsrIndices :: Maybe (KeyMap Value), + sscsrExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +cacheStatsResponseKnownKeys :: [Key] +cacheStatsResponseKnownKeys = ["indices"] + +instance FromJSON SearchableSnapshotsCacheStatsResponse where + parseJSON = withObject "SearchableSnapshotsCacheStatsResponse" $ \o -> do + indices <- o .:? "indices" + let extras = + KM.fromList $ + filter ((`notElem` cacheStatsResponseKnownKeys) . fst) $ + KM.toList o + pure + SearchableSnapshotsCacheStatsResponse + { sscsrIndices = indices, + sscsrExtras = extras + } + +instance ToJSON SearchableSnapshotsCacheStatsResponse where + -- 'object' (not 'omitNulls') so @sscsrExtras@ round-trips verbatim. + toJSON SearchableSnapshotsCacheStatsResponse {..} = + object $ + catMaybes + [ ("indices" .=) <$> sscsrIndices + ] + <> [toPair kv | kv <- KM.toList sscsrExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +searchableSnapshotMountIndexLens :: + Lens' SearchableSnapshotMount IndexName +searchableSnapshotMountIndexLens = + lens ssmIndex (\x y -> x {ssmIndex = y}) + +searchableSnapshotMountRenamedIndexLens :: + Lens' SearchableSnapshotMount (Maybe Text) +searchableSnapshotMountRenamedIndexLens = + lens ssmRenamedIndex (\x y -> x {ssmRenamedIndex = y}) + +searchableSnapshotMountIndexSettingsLens :: + Lens' SearchableSnapshotMount (Maybe Value) +searchableSnapshotMountIndexSettingsLens = + lens ssmIndexSettings (\x y -> x {ssmIndexSettings = y}) + +searchableSnapshotMountIgnoreIndexSettingsLens :: + Lens' SearchableSnapshotMount (Maybe [Text]) +searchableSnapshotMountIgnoreIndexSettingsLens = + lens ssmIgnoreIndexSettings (\x y -> x {ssmIgnoreIndexSettings = y}) + +searchableSnapshotMountExtrasLens :: + Lens' SearchableSnapshotMount (KeyMap Value) +searchableSnapshotMountExtrasLens = + lens ssmExtras (\x y -> x {ssmExtras = y}) + +searchableSnapshotMountOptionsMasterTimeoutLens :: + Lens' SearchableSnapshotMountOptions (Maybe Text) +searchableSnapshotMountOptionsMasterTimeoutLens = + lens ssmoMasterTimeout (\x y -> x {ssmoMasterTimeout = y}) + +searchableSnapshotMountOptionsWaitForCompletionLens :: + Lens' SearchableSnapshotMountOptions (Maybe Bool) +searchableSnapshotMountOptionsWaitForCompletionLens = + lens ssmoWaitForCompletion (\x y -> x {ssmoWaitForCompletion = y}) + +searchableSnapshotMountOptionsStorageLens :: + Lens' SearchableSnapshotMountOptions (Maybe SearchableSnapshotStorage) +searchableSnapshotMountOptionsStorageLens = + lens ssmoStorage (\x y -> x {ssmoStorage = y}) + +searchableSnapshotMountResponseSnapshotLens :: + Lens' SearchableSnapshotMountResponse (Maybe Value) +searchableSnapshotMountResponseSnapshotLens = + lens ssmrSnapshot (\x y -> x {ssmrSnapshot = y}) + +searchableSnapshotMountResponseExtrasLens :: + Lens' SearchableSnapshotMountResponse (KeyMap Value) +searchableSnapshotMountResponseExtrasLens = + lens ssmrExtras (\x y -> x {ssmrExtras = y}) + +searchableSnapshotsStatsResponseTotalLens :: + Lens' SearchableSnapshotsStatsResponse (Maybe Value) +searchableSnapshotsStatsResponseTotalLens = + lens sssrTotal (\x y -> x {sssrTotal = y}) + +searchableSnapshotsStatsResponseIndicesLens :: + Lens' SearchableSnapshotsStatsResponse (Maybe (KeyMap Value)) +searchableSnapshotsStatsResponseIndicesLens = + lens sssrIndices (\x y -> x {sssrIndices = y}) + +searchableSnapshotsStatsResponseNodesLens :: + Lens' SearchableSnapshotsStatsResponse (Maybe (KeyMap Value)) +searchableSnapshotsStatsResponseNodesLens = + lens sssrNodes (\x y -> x {sssrNodes = y}) + +searchableSnapshotsStatsResponseExtrasLens :: + Lens' SearchableSnapshotsStatsResponse (KeyMap Value) +searchableSnapshotsStatsResponseExtrasLens = + lens sssrExtras (\x y -> x {sssrExtras = y}) + +searchableSnapshotsCacheStatsResponseIndicesLens :: + Lens' SearchableSnapshotsCacheStatsResponse (Maybe (KeyMap Value)) +searchableSnapshotsCacheStatsResponseIndicesLens = + lens sscsrIndices (\x y -> x {sscsrIndices = y}) + +searchableSnapshotsCacheStatsResponseExtrasLens :: + Lens' SearchableSnapshotsCacheStatsResponse (KeyMap Value) +searchableSnapshotsCacheStatsResponseExtrasLens = + lens sscsrExtras (\x y -> x {sscsrExtras = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Security.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security.hs @@ -0,0 +1,29 @@ +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Security +-- Description : Umbrella re-export of the X-Pack Security sub-modules +-- +-- The X-Pack Security API is large; its types are split across +-- sub-modules under @Security\/@ and re-exported here so callers can +-- @import ... Common.Types.Security@ and get the full vocabulary. This +-- mirrors the +-- "Database.Bloodhound.Internal.Versions.Common.Types.Query" layout. +-- +-- 'SecretText' is re-exported here because every credential-bearing +-- field in this API surface (API keys, passwords, OAuth2 tokens, SAML +-- assertions) is wrapped in it — callers need to name the type to +-- spell field values or signatures. +module Database.Bloodhound.Internal.Versions.Common.Types.Security + ( module X, + SecretText (..), + ) +where + +import Database.Bloodhound.Internal.Utils.Secret (SecretText (..)) +import Database.Bloodhound.Internal.Versions.Common.Types.Security.ApiKeys as X +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Authentication as X +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Privileges as X +import Database.Bloodhound.Internal.Versions.Common.Types.Security.RoleMappings as X +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Roles as X +import Database.Bloodhound.Internal.Versions.Common.Types.Security.ServiceAccounts as X +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Sso as X +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Users as X diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/ApiKeys.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/ApiKeys.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/ApiKeys.hs @@ -0,0 +1,797 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Security.ApiKeys +-- Description : Types for the ES X-Pack Security API key API (/_security/api_key) +-- +-- Request and response shapes for the API-key endpoints under +-- @\/_security\/api_key*@ (ES 7.x surface — the ES 8.8+ +-- @\/_security\/api_key\/_query_api_key@ and @...\/_authenticate@ +-- endpoints are intentionally out of scope and tracked separately): +-- +-- * @POST /_security/api_key@ — 'CreateApiKeyRequest' body, +-- 'ApiKeyCreatedResponse' on success (the plaintext @api_key@ and the +-- base64 @encoded@ token are returned exactly once). +-- * @POST /_security/api_key/grant@ — 'GrantApiKeyRequest' body, +-- 'ApiKeyCreatedResponse'. Used to mint an API key on behalf of +-- another principal. +-- * @GET /_security/api_key@ — 'RetrieveApiKeyRequest' body, +-- 'ApiKeyRetrievalResponse' (the plaintext key is /not/ included on +-- retrieval). +-- * @DELETE /_security/api_key@ — 'InvalidateApiKeyRequest' body, +-- 'InvalidateApiKeyResponse'. +-- * @PUT /_security/api_key/{id}@ — 'UpdateApiKeyRequest' body, +-- 'Acknowledged' on success. +-- +-- The @role_descriptors@ field embeds the same document shape as a +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Security.Roles.Role' +-- body, keyed by role name; it is therefore decoded to a list of +-- @('RoleName', 'Role')@ pairs. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Security.ApiKeys + ( -- * Identity + ApiKeyId (..), + ApiKeyName (..), + RoleDescriptors, + + -- * Create + CreateApiKeyRequest (..), + defaultCreateApiKeyRequest, + createApiKeyRequestRoleDescriptorsLens, + ApiKeyCreatedResponse (..), + + -- * Grant + GrantApiKeyRequest (..), + GrantType (..), + grantTypeText, + ApiKeySpec (..), + defaultApiKeySpec, + + -- * Retrieve + RetrieveApiKeyRequest (..), + defaultRetrieveApiKeyRequest, + ApiKeyInfo (..), + apiKeyInfoExtrasLens, + ApiKeyRetrievalResponse (..), + + -- * Invalidate + InvalidateApiKeyRequest (..), + defaultInvalidateApiKeyRequest, + InvalidateApiKeyResponse (..), + InvalidateApiKeyError (..), + + -- * Update + UpdateApiKeyRequest (..), + + -- * Query (ES 8.x: @POST /_security/_query/api_key@) + QueryApiKeyRequest (..), + defaultQueryApiKeyRequest, + QueryApiKeyResponse (..), + ) +where + +import Data.Aeson +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', Pair, Parser, lens, omitNulls) +import Database.Bloodhound.Internal.Utils.Secret (SecretText (..)) +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Roles + ( Role (..), + RoleName (..), + ) + +------------------------------------------------------------------------------ +-- Identity +------------------------------------------------------------------------------ + +-- | The immutable id half of an API key (the @id@ segment; the +-- @api_key@ half is the secret and is returned only on create). +newtype ApiKeyId = ApiKeyId {unApiKeyId :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +-- | The human-readable name of an API key. +newtype ApiKeyName = ApiKeyName {unApiKeyName :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +-- | An API-key @role_descriptors@ map: an object keyed by role name, +-- each value a 'Role' body. Decoded to a list of @('RoleName', 'Role')@ +-- pairs so both encode and decode keep key ordering stable. +type RoleDescriptors = [(RoleName, Role)] + +------------------------------------------------------------------------------ +-- Create +------------------------------------------------------------------------------ + +-- | Request body for @POST /_security/api_key@. +data CreateApiKeyRequest = CreateApiKeyRequest + { cakName :: ApiKeyName, + -- | @role_descriptors@ — optional role grants embedded in the key. + -- 'Nothing' omits the field (the key inherits the creating user's + -- privileges); @Just []@ is normalised to 'Nothing' on encode. + cakRoleDescriptors :: Maybe RoleDescriptors, + -- | @expiration@ — ES accepts either a duration (@1d@, @7d@) or an + -- epoch-millis number. Carried as 'Text' so callers can spell + -- either; 'Nothing' omits the field (key never expires). + cakExpiration :: Maybe Text, + cakMetadata :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +-- | Minimal create request: just the name, no role descriptors, no +-- expiration, no metadata. +defaultCreateApiKeyRequest :: ApiKeyName -> CreateApiKeyRequest +defaultCreateApiKeyRequest name = + CreateApiKeyRequest + { cakName = name, + cakRoleDescriptors = Nothing, + cakExpiration = Nothing, + cakMetadata = Nothing + } + +instance ToJSON CreateApiKeyRequest where + toJSON CreateApiKeyRequest {..} = + omitNulls $ + catMaybes + [ Just ("name" .= cakName), + encodeRoleDescriptors cakRoleDescriptors, + ("expiration" .=) <$> cakExpiration, + ("metadata" .=) <$> cakMetadata + ] + +instance FromJSON CreateApiKeyRequest where + parseJSON = withObject "CreateApiKeyRequest" $ \o -> do + name <- o .: "name" + rds <- decodeRoleDescriptors =<< o .:? "role_descriptors" + expiration <- o .:? "expiration" + metadata <- o .:? "metadata" + pure + CreateApiKeyRequest + { cakName = name, + cakRoleDescriptors = rds, + cakExpiration = expiration, + cakMetadata = metadata + } + +-- | Response of @POST /_security/api_key@ and @.../_grant@. The +-- @api_key@ (plaintext secret) and @encoded@ (base64 @id:api_key@) are +-- present ONLY here — ES never returns them again on retrieval. Both +-- are wrapped in 'SecretText' so 'show' never leaks them to debug +-- output, test diffs, or exception rendering. +data ApiKeyCreatedResponse = ApiKeyCreatedResponse + { akcId :: ApiKeyId, + akcName :: ApiKeyName, + -- | The plaintext secret. Present only on create/grant. + akcApiKey :: Maybe SecretText, + -- | The base64 @id:api_key@ convenience token. Present only on + -- create/grant. + akcEncoded :: Maybe SecretText, + akcMetadata :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +instance FromJSON ApiKeyCreatedResponse where + parseJSON = withObject "ApiKeyCreatedResponse" $ \o -> do + akcId' <- o .: "id" + akcName' <- o .: "name" + apiKey <- o .:? "api_key" + encoded <- o .:? "encoded" + metadata <- o .:? "metadata" + pure + ApiKeyCreatedResponse + { akcId = akcId', + akcName = akcName', + akcApiKey = apiKey, + akcEncoded = encoded, + akcMetadata = metadata + } + +instance ToJSON ApiKeyCreatedResponse where + toJSON ApiKeyCreatedResponse {..} = + omitNulls $ + catMaybes + [ Just ("id" .= akcId), + Just ("name" .= akcName), + ("api_key" .=) <$> akcApiKey, + ("encoded" .=) <$> akcEncoded, + ("metadata" .=) <$> akcMetadata + ] + +------------------------------------------------------------------------------ +-- Grant +------------------------------------------------------------------------------ + +-- | The @grant_type@ discriminator for @POST /_security/api_key/grant@. +data GrantType + = -- | @access_token@ — grant on behalf of the bearer of an existing + -- access token (carried in 'ggrAccessToken'). + GrantTypeAccessToken + | -- | @password@ — grant on behalf of a user authenticating with + -- username + password ('ggrUsername' \/ 'ggrPassword'). + GrantTypePassword + deriving stock (Eq, Show) + +-- | The wire spelling of each 'GrantType'. +grantTypeText :: GrantType -> Text +grantTypeText GrantTypeAccessToken = "access_token" +grantTypeText GrantTypePassword = "password" + +instance ToJSON GrantType where + toJSON = toJSON . grantTypeText + +instance FromJSON GrantType where + parseJSON = withText "GrantType" $ \case + "access_token" -> pure GrantTypeAccessToken + "password" -> pure GrantTypePassword + other -> fail ("unknown grant_type: " <> show other) + +-- | The @api_key@ sub-object of a 'GrantApiKeyRequest' — a subset of +-- 'CreateApiKeyRequest' (name, optional role descriptors / expiration / +-- metadata) carried without its own @name@-required constraint. +data ApiKeySpec = ApiKeySpec + { aksName :: ApiKeyName, + aksRoleDescriptors :: Maybe RoleDescriptors, + aksExpiration :: Maybe Text, + aksMetadata :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +-- | Spec with only a name. +defaultApiKeySpec :: ApiKeyName -> ApiKeySpec +defaultApiKeySpec name = + ApiKeySpec + { aksName = name, + aksRoleDescriptors = Nothing, + aksExpiration = Nothing, + aksMetadata = Nothing + } + +instance ToJSON ApiKeySpec where + toJSON ApiKeySpec {..} = + omitNulls $ + catMaybes + [ Just ("name" .= aksName), + encodeRoleDescriptors aksRoleDescriptors, + ("expiration" .=) <$> aksExpiration, + ("metadata" .=) <$> aksMetadata + ] + +instance FromJSON ApiKeySpec where + parseJSON = withObject "ApiKeySpec" $ \o -> do + name <- o .: "name" + rds <- decodeRoleDescriptors =<< o .:? "role_descriptors" + expiration <- o .:? "expiration" + metadata <- o .:? "metadata" + pure + ApiKeySpec + { aksName = name, + aksRoleDescriptors = rds, + aksExpiration = expiration, + aksMetadata = metadata + } + +-- | Request body for @POST /_security/api_key/grant@. The fields +-- populated depend on 'gbrGrantType': @access_token@ needs +-- 'ggrAccessToken', @password@ needs 'ggrUsername' \/ 'ggrPassword'. +-- The credential-bearing fields ('ggrAccessToken', 'ggrPassword') are +-- wrapped in 'SecretText' so 'show' never leaks them. +data GrantApiKeyRequest = GrantApiKeyRequest + { ggrGrantType :: GrantType, + -- | For 'GrantTypeAccessToken': the bearer token to act as. + ggrAccessToken :: Maybe SecretText, + -- | For 'GrantTypePassword': the username to act as. + ggrUsername :: Maybe Text, + -- | For 'GrantTypePassword': that user's password. + ggrPassword :: Maybe SecretText, + ggrApiKey :: ApiKeySpec, + -- | Optional @run_as@ — a user to impersonate. + ggrRunAs :: Maybe [Text] + } + deriving stock (Eq, Show) + +instance ToJSON GrantApiKeyRequest where + toJSON GrantApiKeyRequest {..} = + omitNulls $ + catMaybes + [ Just ("grant_type" .= ggrGrantType), + ("access_token" .=) <$> ggrAccessToken, + ("username" .=) <$> ggrUsername, + ("password" .=) <$> ggrPassword, + Just ("api_key" .= ggrApiKey), + ("run_as" .=) <$> ggrRunAs + ] + +instance FromJSON GrantApiKeyRequest where + parseJSON = withObject "GrantApiKeyRequest" $ \o -> do + grantType <- o .: "grant_type" + accessToken <- o .:? "access_token" + username <- o .:? "username" + password <- o .:? "password" + apiKey <- o .: "api_key" + runAs <- o .:? "run_as" + pure + GrantApiKeyRequest + { ggrGrantType = grantType, + ggrAccessToken = accessToken, + ggrUsername = username, + ggrPassword = password, + ggrApiKey = apiKey, + ggrRunAs = runAs + } + +------------------------------------------------------------------------------ +-- Retrieve +------------------------------------------------------------------------------ + +-- | Request body for @GET /_security/api_key@. Every field optional; +-- 'defaultRetrieveApiKeyRequest' returns all keys the caller may see. +data RetrieveApiKeyRequest = RetrieveApiKeyRequest + { rakId :: Maybe ApiKeyId, + rakName :: Maybe ApiKeyName, + -- | @owner@ — restrict to keys owned by the caller. Defaults to + -- @true@ server-side when @username@ is absent. + rakOwner :: Maybe Bool, + rakRealmName :: Maybe Text, + rakUsername :: Maybe Text + } + deriving stock (Eq, Show) + +-- | Empty filter — ES returns every key the caller can see. +defaultRetrieveApiKeyRequest :: RetrieveApiKeyRequest +defaultRetrieveApiKeyRequest = + RetrieveApiKeyRequest + { rakId = Nothing, + rakName = Nothing, + rakOwner = Nothing, + rakRealmName = Nothing, + rakUsername = Nothing + } + +instance ToJSON RetrieveApiKeyRequest where + toJSON RetrieveApiKeyRequest {..} = + omitNulls $ + catMaybes + [ ("id" .=) <$> rakId, + ("name" .=) <$> rakName, + ("owner" .=) <$> rakOwner, + ("realm_name" .=) <$> rakRealmName, + ("username" .=) <$> rakUsername + ] + +instance FromJSON RetrieveApiKeyRequest where + parseJSON = withObject "RetrieveApiKeyRequest" $ \o -> do + i <- o .:? "id" + name <- o .:? "name" + owner <- o .:? "owner" + realm <- o .:? "realm_name" + username <- o .:? "username" + pure + RetrieveApiKeyRequest + { rakId = i, + rakName = name, + rakOwner = owner, + rakRealmName = realm, + rakUsername = username + } + +-- | A single API key as returned by @GET /_security/api_key@. Note the +-- absence of @api_key@ \/ @encoded@ — those are create-only. ES extends +-- this response across versions (e.g. @agent@, @creation_by@, +-- @role_template@), so unknown sibling fields survive a round-trip in +-- 'akiExtras'. +data ApiKeyInfo = ApiKeyInfo + { akiId :: ApiKeyId, + akiName :: ApiKeyName, + -- | @creation@ — epoch millis. + akiCreation :: Maybe Integer, + -- | @expiration@ — epoch millis, or 'Nothing' for a non-expiring + -- key. + akiExpiration :: Maybe Integer, + akiInvalidated :: Maybe Bool, + akiUsername :: Maybe Text, + akiRealm :: Maybe Text, + akiRoleDescriptors :: Maybe RoleDescriptors, + akiMetadata :: Maybe (KeyMap Value), + -- | Catch-all for every other sibling field ES adds in future + -- (@agent@, @creation_by@, @task@, @role_template@, ...) so decode + -- is forward-compatible and @encode . decode@ round-trips. + akiExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +apiKeyInfoKnownKeys :: [Text] +apiKeyInfoKnownKeys = + [ "id", + "name", + "creation", + "expiration", + "invalidated", + "username", + "realm", + "role_descriptors", + "metadata" + ] + +instance FromJSON ApiKeyInfo where + parseJSON = withObject "ApiKeyInfo" $ \o -> do + i <- o .: "id" + name <- o .: "name" + creation <- o .:? "creation" + expiration <- o .:? "expiration" + invalidated <- o .:? "invalidated" + username <- o .:? "username" + realm <- o .:? "realm" + rds <- decodeRoleDescriptors =<< o .:? "role_descriptors" + metadata <- o .:? "metadata" + let extras = + KM.fromList $ + filter ((`notElem` apiKeyInfoKnownKeys) . toText . fst) $ + KM.toList o + pure + ApiKeyInfo + { akiId = i, + akiName = name, + akiCreation = creation, + akiExpiration = expiration, + akiInvalidated = invalidated, + akiUsername = username, + akiRealm = realm, + akiRoleDescriptors = rds, + akiMetadata = metadata, + akiExtras = extras + } + +instance ToJSON ApiKeyInfo where + toJSON ApiKeyInfo {..} = + omitNulls $ + catMaybes + [ Just ("id" .= akiId), + Just ("name" .= akiName), + ("creation" .=) <$> akiCreation, + ("expiration" .=) <$> akiExpiration, + ("invalidated" .=) <$> akiInvalidated, + ("username" .=) <$> akiUsername, + ("realm" .=) <$> akiRealm, + encodeRoleDescriptors akiRoleDescriptors, + ("metadata" .=) <$> akiMetadata + ] + <> [toPair kv | kv <- KM.toList akiExtras] + where + toPair (k, v) = k .= v + +-- | Response of @GET /_security/api_key@: a list of 'ApiKeyInfo' and a +-- total @count@. +data ApiKeyRetrievalResponse = ApiKeyRetrievalResponse + { akrApiKeys :: [ApiKeyInfo], + akrCount :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ApiKeyRetrievalResponse where + parseJSON = withObject "ApiKeyRetrievalResponse" $ \o -> do + keys <- fromMaybe [] <$> o .:? "api_keys" + count <- o .:? "count" + pure ApiKeyRetrievalResponse {akrApiKeys = keys, akrCount = count} + +instance ToJSON ApiKeyRetrievalResponse where + toJSON ApiKeyRetrievalResponse {..} = + omitNulls $ + catMaybes + [ Just ("api_keys" .= akrApiKeys), + ("count" .=) <$> akrCount + ] + +------------------------------------------------------------------------------ +-- Invalidate +------------------------------------------------------------------------------ + +-- | Request body for @DELETE /_security/api_key@ (invalidation). +data InvalidateApiKeyRequest = InvalidateApiKeyRequest + { iakId :: Maybe ApiKeyId, + iakName :: Maybe ApiKeyName, + iakOwner :: Maybe Bool, + iakRealmName :: Maybe Text, + iakUsername :: Maybe Text, + -- | @ignore_missing@ — suppress the error when no keys match. + iakIgnoreMissing :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | Empty filter (the caller must still set at least one selector — ES +-- rejects an unqualified invalidate-all). +defaultInvalidateApiKeyRequest :: InvalidateApiKeyRequest +defaultInvalidateApiKeyRequest = + InvalidateApiKeyRequest + { iakId = Nothing, + iakName = Nothing, + iakOwner = Nothing, + iakRealmName = Nothing, + iakUsername = Nothing, + iakIgnoreMissing = Nothing + } + +instance ToJSON InvalidateApiKeyRequest where + toJSON InvalidateApiKeyRequest {..} = + omitNulls $ + catMaybes + [ ("id" .=) <$> iakId, + ("name" .=) <$> iakName, + ("owner" .=) <$> iakOwner, + ("realm_name" .=) <$> iakRealmName, + ("username" .=) <$> iakUsername, + ("ignore_missing" .=) <$> iakIgnoreMissing + ] + +instance FromJSON InvalidateApiKeyRequest where + parseJSON = withObject "InvalidateApiKeyRequest" $ \o -> do + i <- o .:? "id" + name <- o .:? "name" + owner <- o .:? "owner" + realm <- o .:? "realm_name" + username <- o .:? "username" + ignoreMissing <- o .:? "ignore_missing" + pure + InvalidateApiKeyRequest + { iakId = i, + iakName = name, + iakOwner = owner, + iakRealmName = realm, + iakUsername = username, + iakIgnoreMissing = ignoreMissing + } + +-- | One error detail from an invalidate call that partially failed. +data InvalidateApiKeyError = InvalidateApiKeyError + { iaeId :: Maybe ApiKeyId, + iaeName :: Maybe ApiKeyName, + iaeType :: Maybe Text, + iaeReason :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON InvalidateApiKeyError where + parseJSON = withObject "InvalidateApiKeyError" $ \o -> do + i <- o .:? "id" + name <- o .:? "name" + t <- o .:? "type" + reason <- o .:? "reason" + pure + InvalidateApiKeyError + { iaeId = i, + iaeName = name, + iaeType = t, + iaeReason = reason + } + +instance ToJSON InvalidateApiKeyError where + toJSON InvalidateApiKeyError {..} = + omitNulls $ + catMaybes + [ ("id" .=) <$> iaeId, + ("name" .=) <$> iaeName, + ("type" .=) <$> iaeType, + ("reason" .=) <$> iaeReason + ] + +-- | Response of @DELETE /_security/api_key@. +data InvalidateApiKeyResponse = InvalidateApiKeyResponse + { iarInvalidatedApiKeys :: [ApiKeyId], + iarPreviouslyOwnedApiKeys :: [ApiKeyId], + iarErrorCount :: Maybe Int, + iarErrorDetails :: [InvalidateApiKeyError] + } + deriving stock (Eq, Show) + +instance FromJSON InvalidateApiKeyResponse where + parseJSON = withObject "InvalidateApiKeyResponse" $ \o -> do + invalidated <- fromMaybe [] <$> o .:? "invalidated_api_keys" + previouslyOwned <- fromMaybe [] <$> o .:? "previously_owned_api_keys" + errorCount <- o .:? "error_count" + errorDetails <- fromMaybe [] <$> o .:? "error_details" + pure + InvalidateApiKeyResponse + { iarInvalidatedApiKeys = invalidated, + iarPreviouslyOwnedApiKeys = previouslyOwned, + iarErrorCount = errorCount, + iarErrorDetails = errorDetails + } + +instance ToJSON InvalidateApiKeyResponse where + toJSON InvalidateApiKeyResponse {..} = + omitNulls $ + catMaybes + [ Just ("invalidated_api_keys" .= iarInvalidatedApiKeys), + Just ("previously_owned_api_keys" .= iarPreviouslyOwnedApiKeys), + ("error_count" .=) <$> iarErrorCount, + if null iarErrorDetails then Nothing else Just ("error_details" .= iarErrorDetails) + ] + +------------------------------------------------------------------------------ +-- Update +------------------------------------------------------------------------------ + +-- | Request body for @PUT /_security/api_key/{id}@. Both fields +-- optional; ES replaces the corresponding map wholesale when present. +data UpdateApiKeyRequest = UpdateApiKeyRequest + { uakRoleDescriptors :: Maybe RoleDescriptors, + uakMetadata :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +instance ToJSON UpdateApiKeyRequest where + toJSON UpdateApiKeyRequest {..} = + omitNulls $ + catMaybes + [ encodeRoleDescriptors uakRoleDescriptors, + ("metadata" .=) <$> uakMetadata + ] + +instance FromJSON UpdateApiKeyRequest where + parseJSON = withObject "UpdateApiKeyRequest" $ \o -> do + rds <- decodeRoleDescriptors =<< o .:? "role_descriptors" + metadata <- o .:? "metadata" + pure UpdateApiKeyRequest {uakRoleDescriptors = rds, uakMetadata = metadata} + +------------------------------------------------------------------------------ +-- Query (ES 8.x: /_security/_query/api_key) +------------------------------------------------------------------------------ + +-- | Request body for @POST /_security/_query/api_key@ (ES 7.16+ \/ 8.x). +-- Unlike the simple 'RetrieveApiKeyRequest' (which takes a fixed set of +-- scalar filters), the query endpoint accepts a Query-DSL @query@, optional +-- @aggs@, and pagination \/ sort \/ search_after controls. The @query@, +-- @aggregations@, and @sort@ fields accept only a /subset/ of the full Query +-- DSL, so they are carried as opaque 'Value's — this keeps decode +-- forward-compatible and avoids emitting clauses ES rejects here. These +-- endpoints do not exist on the ES 7.x surface that 'RetrieveApiKeyRequest' +-- targets. +data QueryApiKeyRequest = QueryApiKeyRequest + { qakQuery :: Maybe Value, + -- | @aggs@ \/ @aggregations@ — encoded as @aggs@; decode accepts either + -- spelling. + qakAggregations :: Maybe Value, + qakFrom :: Maybe Int, + qakSize :: Maybe Int, + qakSort :: Maybe Value, + qakSearchAfter :: Maybe [Value] + } + deriving stock (Eq, Show) + +-- | Empty query — equivalent to a @match_all@ with default @from@ \/ @size@ +-- (the server returns the first 10 keys). +defaultQueryApiKeyRequest :: QueryApiKeyRequest +defaultQueryApiKeyRequest = + QueryApiKeyRequest + { qakQuery = Nothing, + qakAggregations = Nothing, + qakFrom = Nothing, + qakSize = Nothing, + qakSort = Nothing, + qakSearchAfter = Nothing + } + +instance ToJSON QueryApiKeyRequest where + toJSON QueryApiKeyRequest {..} = + omitNulls $ + catMaybes + [ ("query" .=) <$> qakQuery, + ("aggs" .=) <$> qakAggregations, + ("from" .=) <$> qakFrom, + ("size" .=) <$> qakSize, + ("sort" .=) <$> qakSort, + ("search_after" .=) <$> qakSearchAfter + ] + +instance FromJSON QueryApiKeyRequest where + parseJSON = withObject "QueryApiKeyRequest" $ \o -> do + query <- o .:? "query" + aggs <- + case (KM.lookup "aggs" o, KM.lookup "aggregations" o) of + (Just v, _) -> pure (Just v) + (Nothing, Just v) -> pure (Just v) + (Nothing, Nothing) -> pure Nothing + from' <- o .:? "from" + size <- o .:? "size" + sort <- o .:? "sort" + searchAfter <- o .:? "search_after" + pure + QueryApiKeyRequest + { qakQuery = query, + qakAggregations = aggs, + qakFrom = from', + qakSize = size, + qakSort = sort, + qakSearchAfter = searchAfter + } + +-- | Response of @POST /_security/_query/api_key@: a page of 'ApiKeyInfo', +-- the @total@ matching the @query@, and the @count@ returned in this page. +-- Each entry reuses 'ApiKeyInfo'; its @akiExtras@ catch-all absorbs the +-- query-only sibling fields (@realm_type@, @profile_uid@, @invalidation@, +-- @type@, @_sort@, @limited_by@, ...). Aggregation results and any future +-- top-level fields survive a round-trip in 'qkrExtras'. +data QueryApiKeyResponse = QueryApiKeyResponse + { qkrApiKeys :: [ApiKeyInfo], + qkrTotal :: Maybe Int, + qkrCount :: Maybe Int, + qkrExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +queryApiKeyResponseKnownKeys :: [Text] +queryApiKeyResponseKnownKeys = ["api_keys", "total", "count"] + +instance FromJSON QueryApiKeyResponse where + parseJSON = withObject "QueryApiKeyResponse" $ \o -> do + apiKeys <- fromMaybe [] <$> o .:? "api_keys" + total <- o .:? "total" + count <- o .:? "count" + let extras = + KM.fromList $ + filter ((`notElem` queryApiKeyResponseKnownKeys) . toText . fst) $ + KM.toList o + pure + QueryApiKeyResponse + { qkrApiKeys = apiKeys, + qkrTotal = total, + qkrCount = count, + qkrExtras = extras + } + +instance ToJSON QueryApiKeyResponse where + toJSON QueryApiKeyResponse {..} = + omitNulls $ + catMaybes + [ Just ("api_keys" .= qkrApiKeys), + ("total" .=) <$> qkrTotal, + ("count" .=) <$> qkrCount + ] + <> [toPair kv | kv <- KM.toList qkrExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- role_descriptors encode / decode helpers +------------------------------------------------------------------------------ + +-- | Encode a 'RoleDescriptors' map as @Nothing@ when empty/'Nothing', +-- otherwise as an object keyed by role name. +encodeRoleDescriptors :: Maybe RoleDescriptors -> Maybe Pair +encodeRoleDescriptors Nothing = Nothing +encodeRoleDescriptors (Just []) = Nothing +encodeRoleDescriptors (Just entries) = + Just ("role_descriptors" .= Object (KM.fromList [mkKey n .= toJSON r | (n, r) <- entries])) + where + mkKey (RoleName t) = fromText t + +-- | Decode the @role_descriptors@ object into a list of pairs. 'Nothing' +-- stays 'Nothing'; an empty object becomes @Just []@. +decodeRoleDescriptors :: Maybe Value -> Parser (Maybe RoleDescriptors) +decodeRoleDescriptors Nothing = pure Nothing +decodeRoleDescriptors (Just v) = + Just <$> withObject "role_descriptors" parseMap v + where + parseMap o = traverse parseEntry (KM.toList o) + parseEntry (k, val) = do + role <- parseJSON val + pure (RoleName (toText k), role) + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +createApiKeyRequestRoleDescriptorsLens :: + Lens' CreateApiKeyRequest (Maybe RoleDescriptors) +createApiKeyRequestRoleDescriptorsLens = + lens cakRoleDescriptors (\x y -> x {cakRoleDescriptors = y}) + +apiKeyInfoExtrasLens :: Lens' ApiKeyInfo (KeyMap Value) +apiKeyInfoExtrasLens = + lens akiExtras (\x y -> x {akiExtras = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Authentication.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Authentication.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Authentication.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Security.Authentication +-- Description : Types for the ES X-Pack Security authentication APIs (/_security/_authenticate, _whoami, _logout) +-- +-- Response shape for @GET /_security/_authenticate@, which returns +-- information about the credentials the request was made with. The same +-- endpoint validates an API key when it is supplied via the +-- @Authorization: ApiKey \@ header (there is no separate +-- @\/_security\/api_key\/_authenticate@ endpoint). +-- +-- The response overlaps a 'User' (username, roles, full_name, email, +-- metadata, enabled) but adds the authentication \/ lookup realms, the +-- @authentication_provider@, and a @principal@; it therefore has its own +-- type rather than reusing 'User'. Unknown sibling fields (e.g. @api_key@ +-- metadata when authenticated with an API key) survive a round-trip in +-- 'authExtras'. +-- +-- See +-- . +-- +-- and +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Security.Authentication + ( -- * Authenticate + AuthenticateResponse (..), + SecurityRealm (..), + authenticateResponseExtrasLens, + + -- * GET /_security/_whoami + WhoAmIResponse (..), + whoAmIResponseExtrasLens, + + -- * POST /_security/_logout + LogoutRequest (..), + defaultLogoutRequest, + LogoutResponse (..), + ) +where + +import Data.Aeson +import Data.Aeson.Key (toText) +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (catMaybes, fromMaybe) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens, omitNulls) +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Roles + ( RoleName (..), + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Users + ( UserName (..), + ) + +------------------------------------------------------------------------------ +-- Realm +------------------------------------------------------------------------------ + +-- | One of the @authentication_realm@ \/ @lookup_realm@ sub-objects in an +-- 'AuthenticateResponse': a name + type pair. +data SecurityRealm = SecurityRealm + { srName :: Maybe Text, + srType :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SecurityRealm where + parseJSON = withObject "SecurityRealm" $ \o -> do + name <- o .:? "name" + typ <- o .:? "type" + pure SecurityRealm {srName = name, srType = typ} + +instance ToJSON SecurityRealm where + toJSON SecurityRealm {..} = + omitNulls $ + catMaybes + [ ("name" .=) <$> srName, + ("type" .=) <$> srType + ] + +------------------------------------------------------------------------------ +-- Authenticate response +------------------------------------------------------------------------------ + +-- | Response of @GET /_security/_authenticate@: the principal the request +-- authenticated as, plus the realms that resolved it. +data AuthenticateResponse = AuthenticateResponse + { authUsername :: UserName, + authRoles :: [RoleName], + authFullName :: Maybe Text, + authEmail :: Maybe Text, + authEnabled :: Maybe Bool, + authMetadata :: KeyMap Value, + -- | @authentication_realm@ — the realm that authenticated the + -- credential. + authAuthenticationRealm :: Maybe SecurityRealm, + -- | @lookup_realm@ — the realm the user was looked up in (may differ + -- from the authentication realm for delegated authentication). + authLookupRealm :: Maybe SecurityRealm, + -- | @authentication_provider@ — e.g. @reserved@, @realm1@, @_api_key@. + authAuthenticationProvider :: Maybe Text, + -- | @principal@ — the principal identifier (usually the username, but + -- a distinct field on the wire). + authPrincipal :: Maybe Text, + -- | Catch-all for every other sibling field ES adds in future (e.g. + -- @api_key@ metadata when authenticated with an API key) so decode is + -- forward-compatible and @encode . decode@ round-trips. + authExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +authenticateKnownKeys :: [Text] +authenticateKnownKeys = + [ "username", + "roles", + "full_name", + "email", + "enabled", + "metadata", + "authentication_realm", + "lookup_realm", + "authentication_provider", + "principal" + ] + +instance FromJSON AuthenticateResponse where + parseJSON = withObject "AuthenticateResponse" $ \o -> do + username <- o .: "username" + roles <- fromMaybe [] <$> o .:? "roles" + fullName <- o .:? "full_name" + email <- o .:? "email" + enabled <- o .:? "enabled" + metadata <- fromMaybe KM.empty <$> o .:? "metadata" + authRealm <- o .:? "authentication_realm" + lookupRealm <- o .:? "lookup_realm" + authProvider <- o .:? "authentication_provider" + principal <- o .:? "principal" + let extras = + KM.fromList $ + filter ((`notElem` authenticateKnownKeys) . toText . fst) $ + KM.toList o + pure + AuthenticateResponse + { authUsername = username, + authRoles = roles, + authFullName = fullName, + authEmail = email, + authEnabled = enabled, + authMetadata = metadata, + authAuthenticationRealm = authRealm, + authLookupRealm = lookupRealm, + authAuthenticationProvider = authProvider, + authPrincipal = principal, + authExtras = extras + } + +instance ToJSON AuthenticateResponse where + toJSON AuthenticateResponse {..} = + omitNulls $ + catMaybes + [ Just ("username" .= authUsername), + Just ("roles" .= authRoles), + ("full_name" .=) <$> authFullName, + ("email" .=) <$> authEmail, + ("enabled" .=) <$> authEnabled, + Just ("metadata" .= authMetadata), + ("authentication_realm" .=) <$> authAuthenticationRealm, + ("lookup_realm" .=) <$> authLookupRealm, + ("authentication_provider" .=) <$> authAuthenticationProvider, + ("principal" .=) <$> authPrincipal + ] + <> [toPair kv | kv <- KM.toList authExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- GET /_security/_whoami +------------------------------------------------------------------------------ + +-- | Response of @GET /_security/_whoami@ (ES 7.16+): a slimmer view of the +-- current authenticated user than 'AuthenticateResponse'. The wire object +-- carries @username@, @roles@, the optional @principal@ \/ @delegate@ +-- fields, the @authentication_realm@ (and optionally the @lookup_realm@). +-- @principal@, @delegate@ and @lookup_realm@ are 'Maybe' for cross-version +-- robustness; unknown sibling fields survive a round-trip in 'wmExtras'. +data WhoAmIResponse = WhoAmIResponse + { wmUsername :: UserName, + wmRoles :: [RoleName], + wmPrincipal :: Maybe Text, + wmDelegate :: Maybe Bool, + wmAuthenticationRealm :: SecurityRealm, + wmLookupRealm :: Maybe SecurityRealm, + wmExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +whoAmIResponseKnownKeys :: [Text] +whoAmIResponseKnownKeys = + [ "username", + "roles", + "principal", + "delegate", + "authentication_realm", + "lookup_realm" + ] + +instance FromJSON WhoAmIResponse where + parseJSON = withObject "WhoAmIResponse" $ \o -> do + username <- o .: "username" + roles <- fromMaybe [] <$> o .:? "roles" + principal <- o .:? "principal" + delegate <- o .:? "delegate" + authRealm <- o .: "authentication_realm" + lookupRealm <- o .:? "lookup_realm" + let extras = + KM.fromList $ + filter ((`notElem` whoAmIResponseKnownKeys) . toText . fst) $ + KM.toList o + pure + WhoAmIResponse + { wmUsername = username, + wmRoles = roles, + wmPrincipal = principal, + wmDelegate = delegate, + wmAuthenticationRealm = authRealm, + wmLookupRealm = lookupRealm, + wmExtras = extras + } + +instance ToJSON WhoAmIResponse where + toJSON WhoAmIResponse {..} = + omitNulls $ + catMaybes + [ Just ("username" .= wmUsername), + Just ("roles" .= wmRoles), + ("principal" .=) <$> wmPrincipal, + ("delegate" .=) <$> wmDelegate, + Just ("authentication_realm" .= wmAuthenticationRealm), + ("lookup_realm" .=) <$> wmLookupRealm + ] + <> [toPair kv | kv <- KM.toList wmExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- POST /_security/_logout +------------------------------------------------------------------------------ + +-- | Request body for @POST /_security/_logout@: the SAML\/OIDC SSO access +-- @token@ to invalidate (and, optionally, its @refresh_token@). ES rejects +-- an empty body, so the @token@ is required; pass 'defaultLogoutRequest' +-- and set 'lrToken'. +data LogoutRequest = LogoutRequest + { lrToken :: Text, + lrRefreshToken :: Maybe Text + } + deriving stock (Eq, Show) + +-- | Minimal logout request carrying only the access token. +defaultLogoutRequest :: Text -> LogoutRequest +defaultLogoutRequest token = + LogoutRequest {lrToken = token, lrRefreshToken = Nothing} + +instance ToJSON LogoutRequest where + toJSON LogoutRequest {..} = + omitNulls $ + catMaybes + [ Just ("token" .= lrToken), + ("refresh_token" .=) <$> lrRefreshToken + ] + +instance FromJSON LogoutRequest where + parseJSON = withObject "LogoutRequest" $ \o -> do + token <- o .: "token" + refreshToken <- o .:? "refresh_token" + pure LogoutRequest {lrToken = token, lrRefreshToken = refreshToken} + +-- | Response of @POST /_security/_logout@: @{"changed":true}@ when a +-- SAML\/OIDC SSO token was found and removed, @{"changed":false}@ when no +-- token matched. +newtype LogoutResponse = LogoutResponse + { loChanged :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON LogoutResponse where + parseJSON = withObject "LogoutResponse" $ \o -> + LogoutResponse <$> o .: "changed" + +instance ToJSON LogoutResponse where + toJSON LogoutResponse {..} = object ["changed" .= loChanged] + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +authenticateResponseExtrasLens :: Lens' AuthenticateResponse (KeyMap Value) +authenticateResponseExtrasLens = + lens authExtras (\x y -> x {authExtras = y}) + +whoAmIResponseExtrasLens :: Lens' WhoAmIResponse (KeyMap Value) +whoAmIResponseExtrasLens = + lens wmExtras (\x y -> x {wmExtras = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Privileges.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Privileges.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Privileges.hs @@ -0,0 +1,765 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Security.Privileges +-- Description : Shared privilege vocabulary for the ES X-Pack Security API +-- +-- The privilege model used across the Security sub-categories: cluster +-- privileges, index privileges (with field security and an optional +-- filter query), and application privileges. These types are factored +-- out because they appear in three places: +-- +-- * 'Role' bodies (@/_security\/role*@) — see +-- "Database.Bloodhound.Internal.Versions.Common.Types.Security.Roles". +-- * 'User' @has_privileges@ requests and the API-key @role_descriptors@ +-- body — see "Database.Bloodhound.Internal.Versions.Common.Types.Security.Users" +-- and "...Security.ApiKeys". +-- +-- Cluster, index and application privilege /names/ are open-ended +-- string vocabularies that ES extends across versions, so they are +-- carried as newtypes around 'Text' (matching the project's +-- 'IndexPattern' \/ 'FieldName' precedent) rather than a closed +-- sum-type that would bit-rot. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Security.Privileges + ( -- * Privilege-name newtypes + ClusterPrivilege (..), + IndexPrivilegeName (..), + ApplicationName (..), + ApplicationPrivilegeName (..), + ResourceName (..), + + -- * Field-level security + FieldSecurity (..), + defaultFieldSecurity, + fieldSecurityGrantLens, + fieldSecurityExceptLens, + + -- * Index privilege entry + IndexPrivilege (..), + defaultIndexPrivilege, + indexPrivilegeNamesLens, + indexPrivilegePrivilegesLens, + indexPrivilegeFieldSecurityLens, + indexPrivilegeQueryLens, + indexPrivilegeExtrasLens, + + -- * Application privilege entry + ApplicationPrivilege (..), + defaultApplicationPrivilege, + applicationPrivilegeApplicationLens, + applicationPrivilegePrivilegesLens, + applicationPrivilegeResourcesLens, + applicationPrivilegeExtrasLens, + + -- * Application privilege CRUD (/_security/privilege/*) + ActionName (..), + + -- ** PUT request body + ApplicationPrivilegeDefinition (..), + defaultApplicationPrivilegeDefinition, + applicationPrivilegeDefinitionActionsLens, + applicationPrivilegeDefinitionMetadataLens, + applicationPrivilegeDefinitionExtrasLens, + + -- ** GET leaf + ApplicationPrivilegeInfo (..), + applicationPrivilegeInfoApplicationLens, + applicationPrivilegeInfoNameLens, + applicationPrivilegeInfoActionsLens, + applicationPrivilegeInfoMetadataLens, + applicationPrivilegeInfoExtrasLens, + + -- ** Responses + PrivilegesListResponse (..), + privilegesListResponseEntriesLens, + PrivilegeCreatedResponse (..), + privilegeCreatedResponseCreatedLens, + PrivilegeDeletedResponse (..), + privilegeDeletedResponseFoundLens, + ClearPrivilegeCacheResponse (..), + clearPrivilegeCacheBodyLens, + ) +where + +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (catMaybes) +import Data.String (IsString) +import Data.Text (Text) +import Data.Vector qualified as V +import Database.Bloodhound.Internal.Utils.Imports (Lens', Parser, lens, omitNulls) +import Database.Bloodhound.Internal.Versions.Common.Types.Indices + ( IndexPattern (..), + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( FieldName (..), + ) + +------------------------------------------------------------------------------ +-- Privilege-name newtypes +------------------------------------------------------------------------------ + +-- | A cluster-level privilege name (@all@, @monitor@, @manage@, +-- @manage_security@, ...). ES documents ~40 stable values but adds new +-- ones across versions, so this is an opaque wrapper around 'Text' +-- rather than a closed sum-type. +newtype ClusterPrivilege = ClusterPrivilege {unClusterPrivilege :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +-- | An index-level privilege name (@read@, @write@, @create@, @delete@, +-- @view_index_metadata@, ...). Same open-ended-vocabulary rationale as +-- 'ClusterPrivilege'. +newtype IndexPrivilegeName = IndexPrivilegeName {unIndexPrivilegeName :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +-- | An application name (first path segment of an application +-- privilege, e.g. @myapp@). +newtype ApplicationName = ApplicationName {unApplicationName :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +-- | An application privilege name (application-defined, e.g. @read@, +-- @write@ within an application's own vocabulary). +newtype ApplicationPrivilegeName = ApplicationPrivilegeName + { unApplicationPrivilegeName :: Text + } + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +-- | A resource string within an application privilege (e.g. @*@, +-- @index:1@). Resources are application-specific opaque strings. +newtype ResourceName = ResourceName {unResourceName :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +------------------------------------------------------------------------------ +-- Field-level security +------------------------------------------------------------------------------ + +-- | The @field_security@ sub-object of an 'IndexPrivilege'. Both +-- @grant@ and @except@ accept either a single bare field name or an +-- array of field names on decode; both are always emitted as arrays on +-- encode. Either side may be 'Nothing' (an absent @grant@ means "all +-- fields" per the ES semantics). +data FieldSecurity = FieldSecurity + { fsGrant :: Maybe (NonEmpty FieldName), + fsExcept :: Maybe (NonEmpty FieldName) + } + deriving stock (Eq, Show) + +-- | @grant = Nothing, except = Nothing@ — encodes to an empty object +-- (matching the @{}@ ES accepts as "default field security"). +defaultFieldSecurity :: FieldSecurity +defaultFieldSecurity = + FieldSecurity + { fsGrant = Nothing, + fsExcept = Nothing + } + +instance FromJSON FieldSecurity where + parseJSON = withObject "FieldSecurity" $ \o -> do + grant <- parseFieldList =<< o .:? "grant" + except <- parseFieldList =<< o .:? "except" + pure FieldSecurity {fsGrant = grant, fsExcept = except} + where + parseFieldList :: Maybe Value -> Parser (Maybe (NonEmpty FieldName)) + parseFieldList Nothing = pure Nothing + parseFieldList (Just (Array xs)) + | V.null xs = pure Nothing + | otherwise = Just <$> toNonEmptyM (V.toList xs) + parseFieldList (Just v@(String _)) = Just . (:| []) <$> parseJSON v + parseFieldList _ = fail "field_security grant/except must be a string or array of strings" + +instance ToJSON FieldSecurity where + toJSON FieldSecurity {..} = + omitNulls $ + catMaybes + [ ("grant" .=) <$> fsGrant, + ("except" .=) <$> fsExcept + ] + +------------------------------------------------------------------------------ +-- Index privilege entry +------------------------------------------------------------------------------ + +-- | A single entry in a role's @indices@ array. The stable ES fields +-- are typed; unknown sibling fields survive a round-trip in +-- 'ipExtras' (the same forward-compat strategy used by +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Enrich.EnrichPolicyConfig'). +data IndexPrivilege = IndexPrivilege + { ipNames :: NonEmpty IndexPattern, + ipPrivileges :: NonEmpty IndexPrivilegeName, + ipFieldSecurity :: Maybe FieldSecurity, + -- | Optional filter restricting the documents the privilege grants + -- access to. Carried as an opaque 'Value' because it is a standard + -- ES query DSL body (callers build it with the typed 'Query' and + -- 'toJSON' it in). + ipQuery :: Maybe Value, + ipExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | Minimal index privilege: one pattern, one privilege, no +-- field-security, no query, no extras. +defaultIndexPrivilege :: + IndexPattern -> + IndexPrivilegeName -> + IndexPrivilege +defaultIndexPrivilege name priv = + IndexPrivilege + { ipNames = name :| [], + ipPrivileges = priv :| [], + ipFieldSecurity = Nothing, + ipQuery = Nothing, + ipExtras = KM.empty + } + +indexPrivilegeKnownKeys :: [Key] +indexPrivilegeKnownKeys = ["names", "privileges", "field_security", "query"] + +instance FromJSON IndexPrivilege where + parseJSON = withObject "IndexPrivilege" $ \o -> do + names <- parseNames =<< o .: "names" + privileges <- parsePrivileges =<< o .: "privileges" + fieldSecurity <- o .:? "field_security" + query <- o .:? "query" + let extras = + KM.fromList $ + filter ((`notElem` indexPrivilegeKnownKeys) . fst) $ + KM.toList o + pure + IndexPrivilege + { ipNames = names, + ipPrivileges = privileges, + ipFieldSecurity = fieldSecurity, + ipQuery = query, + ipExtras = extras + } + where + parseNames :: Value -> Parser (NonEmpty IndexPattern) + parseNames = parseStringOrArray "index privilege 'names'" + + parsePrivileges :: Value -> Parser (NonEmpty IndexPrivilegeName) + parsePrivileges = parseStringOrArray "index privilege 'privileges'" + +instance ToJSON IndexPrivilege where + toJSON IndexPrivilege {..} = + object $ + catMaybes + [ Just ("names" .= ipNames), + Just ("privileges" .= ipPrivileges), + ("field_security" .=) <$> ipFieldSecurity, + ("query" .=) <$> ipQuery + ] + <> [toPair kv | kv <- KM.toList ipExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- Application privilege entry +------------------------------------------------------------------------------ + +-- | A single entry in a role's @applications@ array. @application@, +-- @privileges@ and @resources@ are typed; unknown siblings go to +-- 'apvExtras'. +data ApplicationPrivilege = ApplicationPrivilege + { apvApplication :: ApplicationName, + apvPrivileges :: [ApplicationPrivilegeName], + apvResources :: [ResourceName], + apvExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | Minimal application privilege: one application, no privileges, the +-- wildcard resource (@"*"@). +defaultApplicationPrivilege :: ApplicationName -> ApplicationPrivilege +defaultApplicationPrivilege app = + ApplicationPrivilege + { apvApplication = app, + apvPrivileges = [], + apvResources = ["*"], + apvExtras = KM.empty + } + +applicationPrivilegeKnownKeys :: [Key] +applicationPrivilegeKnownKeys = ["application", "privileges", "resources"] + +instance FromJSON ApplicationPrivilege where + parseJSON = withObject "ApplicationPrivilege" $ \o -> do + application <- o .: "application" + privileges <- parseOptList "application privilege 'privileges'" =<< o .:? "privileges" + resources <- parseOptList "application privilege 'resources'" =<< o .:? "resources" + let extras = + KM.fromList $ + filter ((`notElem` applicationPrivilegeKnownKeys) . fst) $ + KM.toList o + pure + ApplicationPrivilege + { apvApplication = application, + apvPrivileges = privileges, + apvResources = resources, + apvExtras = extras + } + +instance ToJSON ApplicationPrivilege where + toJSON ApplicationPrivilege {..} = + object $ + catMaybes + [ Just ("application" .= apvApplication), + Just ("privileges" .= apvPrivileges), + Just ("resources" .= apvResources) + ] + <> [toPair kv | kv <- KM.toList apvExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- Parsing helpers +------------------------------------------------------------------------------ + +-- | Parse a field that ES accepts either as a JSON array of strings or +-- as a single bare string, yielding a 'NonEmpty'. An empty array fails +-- (these fields are documented as required-and-non-empty). +parseStringOrArray :: + (FromJSON a) => + String -> + Value -> + Parser (NonEmpty a) +parseStringOrArray label (Array xs) + | V.null xs = fail (label <> " array must be non-empty") + | otherwise = toNonEmptyM (V.toList xs) +parseStringOrArray _ v@(String _) = (:| []) <$> parseJSON v +parseStringOrArray label _ = fail (label <> " must be a string or array of strings") + +-- | Like 'parseStringOrArray' but for /optional/ fields: @Nothing@ or an +-- empty array yields @[]@, a bare string yields a singleton, otherwise +-- the full list. Used for @resources@ and other list fields where ES +-- tolerates an absent value. +parseOptList :: + (FromJSON a) => + String -> + Maybe Value -> + Parser [a] +parseOptList _ Nothing = pure [] +parseOptList _ (Just (Array xs)) = traverse parseJSON (V.toList xs) +parseOptList _ (Just v@(String _)) = (: []) <$> parseJSON v +parseOptList label (Just _) = fail (label <> " must be a string or array of strings") + +-- | Parse every element of a non-empty list, failing the whole parse +-- if any element is malformed. The empty case has already been +-- excluded by callers. +toNonEmptyM :: (FromJSON a) => [Value] -> Parser (NonEmpty a) +toNonEmptyM [] = fail "unexpected empty array" +toNonEmptyM (h : rest) = (:|) <$> parseJSON h <*> traverse parseJSON rest + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +fieldSecurityGrantLens :: Lens' FieldSecurity (Maybe (NonEmpty FieldName)) +fieldSecurityGrantLens = lens fsGrant (\x y -> x {fsGrant = y}) + +fieldSecurityExceptLens :: Lens' FieldSecurity (Maybe (NonEmpty FieldName)) +fieldSecurityExceptLens = lens fsExcept (\x y -> x {fsExcept = y}) + +indexPrivilegeNamesLens :: Lens' IndexPrivilege (NonEmpty IndexPattern) +indexPrivilegeNamesLens = lens ipNames (\x y -> x {ipNames = y}) + +indexPrivilegePrivilegesLens :: + Lens' IndexPrivilege (NonEmpty IndexPrivilegeName) +indexPrivilegePrivilegesLens = + lens ipPrivileges (\x y -> x {ipPrivileges = y}) + +indexPrivilegeFieldSecurityLens :: + Lens' IndexPrivilege (Maybe FieldSecurity) +indexPrivilegeFieldSecurityLens = + lens ipFieldSecurity (\x y -> x {ipFieldSecurity = y}) + +indexPrivilegeQueryLens :: Lens' IndexPrivilege (Maybe Value) +indexPrivilegeQueryLens = lens ipQuery (\x y -> x {ipQuery = y}) + +indexPrivilegeExtrasLens :: Lens' IndexPrivilege (KeyMap Value) +indexPrivilegeExtrasLens = lens ipExtras (\x y -> x {ipExtras = y}) + +applicationPrivilegeApplicationLens :: + Lens' ApplicationPrivilege ApplicationName +applicationPrivilegeApplicationLens = + lens apvApplication (\x y -> x {apvApplication = y}) + +applicationPrivilegePrivilegesLens :: + Lens' ApplicationPrivilege [ApplicationPrivilegeName] +applicationPrivilegePrivilegesLens = + lens apvPrivileges (\x y -> x {apvPrivileges = y}) + +applicationPrivilegeResourcesLens :: + Lens' ApplicationPrivilege [ResourceName] +applicationPrivilegeResourcesLens = + lens apvResources (\x y -> x {apvResources = y}) + +applicationPrivilegeExtrasLens :: + Lens' ApplicationPrivilege (KeyMap Value) +applicationPrivilegeExtrasLens = + lens apvExtras (\x y -> x {apvExtras = y}) + +------------------------------------------------------------------------------ +-- Application privilege CRUD (/_security/privilege/*) +-- +-- The @/_security/privilege*@ endpoints manage application privileges +-- /as definitions/: each privilege is identified by an +-- @@\/@@ pair and grants a list of @actions@. This +-- is distinct from the role-binding 'ApplicationPrivilege' above, which +-- records how a /role/ references a privilege (application + privilege +-- names + resources). The two shapes are not interchangeable on the wire: +-- definitions carry @actions@\/@metadata@, role bindings carry +-- @privileges@\/@resources@. +-- +-- Wire envelopes (see +-- +-- and friends): +-- + +-- * @PUT /_security/privilege/{app}/{name}@ — 'ApplicationPrivilegeDefinition' + +-- body, 'PrivilegeCreatedResponse' (the @created@ leaf of the +-- @{app:{name:{created}}}@ envelope). + +-- * @GET /_security/privilege[/{app}[/{name}]]@ — 'PrivilegesListResponse' + +-- (an @{app:{name:leaf}}@ object; the leaf is 'ApplicationPrivilegeInfo'). + +-- * @DELETE /_security/privilege/{app}/{name}@ — 'PrivilegeDeletedResponse' + +-- (the @found@ leaf of the @{app:{name:{found}}}@ envelope). + +-- * @POST /_security/privilege/{apps}/_clear_cache@ — + +-- 'ClearPrivilegeCacheResponse'. + +-- | An action name granted by an application privilege (e.g. +-- @data:read\/*@, @action:login@). Action names are an open-ended, +-- application-defined string vocabulary (ES only requires they contain +-- @\/@, @*@ or @:@), so — like 'ClusterPrivilege' — this is an opaque +-- 'Text' wrapper rather than a closed sum-type. +newtype ActionName = ActionName {unActionName :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +------------------------------------------------------------------------------ +-- PUT request body +------------------------------------------------------------------------------ + +-- | The body of @PUT /_security/privilege/{app}/{name}@. @actions@ is +-- required and must be non-empty (ES rejects an empty array); @metadata@ +-- is an optional opaque object whose @_*@-prefixed keys are reserved for +-- system use. Unknown sibling fields round-trip in 'apdExtras'. +data ApplicationPrivilegeDefinition = ApplicationPrivilegeDefinition + { apdActions :: NonEmpty ActionName, + apdMetadata :: Maybe Value, + apdExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | Minimal privilege definition: the given @actions@, no metadata, no +-- extras. +defaultApplicationPrivilegeDefinition :: + NonEmpty ActionName -> + ApplicationPrivilegeDefinition +defaultApplicationPrivilegeDefinition actions = + ApplicationPrivilegeDefinition + { apdActions = actions, + apdMetadata = Nothing, + apdExtras = KM.empty + } + +applicationPrivilegeDefinitionKnownKeys :: [Key] +applicationPrivilegeDefinitionKnownKeys = ["actions", "metadata"] + +instance FromJSON ApplicationPrivilegeDefinition where + parseJSON = withObject "ApplicationPrivilegeDefinition" $ \o -> do + actions <- parseStringOrArray "privilege definition 'actions'" =<< o .: "actions" + metadata <- o .:? "metadata" + let extras = + KM.fromList $ + filter ((`notElem` applicationPrivilegeDefinitionKnownKeys) . fst) $ + KM.toList o + pure + ApplicationPrivilegeDefinition + { apdActions = actions, + apdMetadata = metadata, + apdExtras = extras + } + +instance ToJSON ApplicationPrivilegeDefinition where + toJSON ApplicationPrivilegeDefinition {..} = + object $ + catMaybes + [ Just ("actions" .= apdActions), + ("metadata" .=) <$> apdMetadata + ] + <> [toPair kv | kv <- KM.toList apdExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- GET leaf +------------------------------------------------------------------------------ + +-- | A single privilege as returned by @GET /_security/privilege*@. ES +-- echoes both @application@ and @name@ alongside the @actions@ and +-- optional @metadata@. Unknown sibling fields round-trip in 'apiExtras'. +data ApplicationPrivilegeInfo = ApplicationPrivilegeInfo + { apiApplication :: ApplicationName, + apiName :: ApplicationPrivilegeName, + apiActions :: [ActionName], + apiMetadata :: Maybe Value, + apiExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +applicationPrivilegeInfoKnownKeys :: [Key] +applicationPrivilegeInfoKnownKeys = + ["application", "name", "actions", "metadata"] + +instance FromJSON ApplicationPrivilegeInfo where + parseJSON = withObject "ApplicationPrivilegeInfo" $ \o -> do + application <- o .: "application" + name <- o .: "name" + actions <- parseOptList "privilege info 'actions'" =<< o .:? "actions" + metadata <- o .:? "metadata" + let extras = + KM.fromList $ + filter ((`notElem` applicationPrivilegeInfoKnownKeys) . fst) $ + KM.toList o + pure + ApplicationPrivilegeInfo + { apiApplication = application, + apiName = name, + apiActions = actions, + apiMetadata = metadata, + apiExtras = extras + } + +instance ToJSON ApplicationPrivilegeInfo where + toJSON ApplicationPrivilegeInfo {..} = + object $ + catMaybes + [ Just ("application" .= apiApplication), + Just ("name" .= apiName), + Just ("actions" .= apiActions), + ("metadata" .=) <$> apiMetadata + ] + <> [toPair kv | kv <- KM.toList apiExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- GET list response (two-level {app:{name:leaf}}) +------------------------------------------------------------------------------ + +-- | Response of @GET /_security/privilege[/{app}[/{name}]]@: an ES object +-- keyed by application name, then by privilege name, whose leaf is an +-- 'ApplicationPrivilegeInfo'. The decoder folds the two-level object into +-- a list of @(application, [(privilege, info)])@ pairs so the list-all, +-- list-app and get-one variants share one response type. The encoder +-- reproduces the object-keyed shape. +newtype PrivilegesListResponse = PrivilegesListResponse + { privilegesListEntries :: + [(ApplicationName, [(ApplicationPrivilegeName, ApplicationPrivilegeInfo)])] + } + deriving stock (Eq, Show) + +instance FromJSON PrivilegesListResponse where + parseJSON = withObject "PrivilegesListResponse" $ \o -> do + entries <- traverse parseApp (KM.toList o) + pure (PrivilegesListResponse entries) + where + parseApp (appKey, appVal) = + withObject "PrivilegesListResponse application" parseNames appVal + where + parseNames appObj = do + namePairs <- traverse parseName (KM.toList appObj) + pure (ApplicationName (toText appKey), namePairs) + parseName (nameKey, leafVal) = do + info <- parseJSON leafVal + pure (ApplicationPrivilegeName (toText nameKey), info) + +instance ToJSON PrivilegesListResponse where + toJSON (PrivilegesListResponse entries) = + Object $ + KM.fromList + [ ( fromText (unApplicationName app), + Object + ( KM.fromList + [ (fromText (unApplicationPrivilegeName n), toJSON info) + | (n, info) <- namePairs + ] + ) + ) + | (app, namePairs) <- entries + ] + +------------------------------------------------------------------------------ +-- PUT / DELETE response leaves (two-level envelope, leaf-only projection) +------------------------------------------------------------------------------ + +-- | Response of @PUT /_security/privilege/{app}/{name}@. ES wraps the +-- boolean in a two-level @{app:{name:{created}}}@ envelope; since the +-- request always targets a single privilege, the decoder descends to that +-- leaf and exposes only @created@ (@false@ when an existing privilege was +-- updated rather than created). 'toJSON' emits the leaf alone — the +-- application\/privilege names are not retained by this projection. +newtype PrivilegeCreatedResponse = PrivilegeCreatedResponse + { pcCreated :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON PrivilegeCreatedResponse where + parseJSON = + parsePrivilegeEnvelopeLeaf "PrivilegeCreatedResponse" $ \leaf -> + PrivilegeCreatedResponse <$> leaf .: "created" + +instance ToJSON PrivilegeCreatedResponse where + toJSON PrivilegeCreatedResponse {..} = object ["created" .= pcCreated] + +-- | Response of @DELETE /_security/privilege/{app}/{name}@. Like +-- 'PrivilegeCreatedResponse', ES wraps @found@ in @{app:{name:{found}}}@; +-- the decoder descends to the leaf. @found@ is @false@ when the privilege +-- did not exist. +newtype PrivilegeDeletedResponse = PrivilegeDeletedResponse + { pdFound :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON PrivilegeDeletedResponse where + parseJSON = + parsePrivilegeEnvelopeLeaf "PrivilegeDeletedResponse" $ \leaf -> do + found <- leaf .:? "found" + pure PrivilegeDeletedResponse {pdFound = found} + +instance ToJSON PrivilegeDeletedResponse where + toJSON PrivilegeDeletedResponse {..} = + omitNulls $ catMaybes [("found" .=) <$> pdFound] + +------------------------------------------------------------------------------ +-- Clear-cache response +------------------------------------------------------------------------------ + +-- | Response of @POST /_security/privilege/{apps}/_clear_cache@. ES +-- returns a (frequently empty) object whose concrete shape varies across +-- versions, so the body is carried opaquely and round-trips whatever ES +-- sends. +newtype ClearPrivilegeCacheResponse = ClearPrivilegeCacheResponse + { cpcBody :: KeyMap Value + } + deriving stock (Eq, Show) + +instance FromJSON ClearPrivilegeCacheResponse where + parseJSON = withObject "ClearPrivilegeCacheResponse" $ \o -> + pure (ClearPrivilegeCacheResponse o) + +instance ToJSON ClearPrivilegeCacheResponse where + toJSON (ClearPrivilegeCacheResponse o) = Object o + +------------------------------------------------------------------------------ +-- Envelope-descent helper +------------------------------------------------------------------------------ + +-- | Both 'PrivilegeCreatedResponse' and 'PrivilegeDeletedResponse' arrive +-- as a two-level @{app:{name:leaf}}@ envelope. The request always targets +-- a single privilege, so the envelope has exactly one application and one +-- name; this helper descends to that leaf object and hands it to +-- @parseLeaf@. It also accepts a /bare/ leaf object (no envelope) so that +-- 'toJSON' — which emits only the leaf — round-trips, and so partial or +-- proxy responses that drop the envelope still decode. Descent is tried +-- first: a bare leaf fails to descend (its single value is not an +-- object), then the leaf parser runs directly. A malformed (empty or +-- shallow) envelope fails to parse. +parsePrivilegeEnvelopeLeaf :: + String -> + (Object -> Parser a) -> + Value -> + Parser a +parsePrivilegeEnvelopeLeaf label parseLeaf v = + descend v <|> withObject (label <> " leaf") parseLeaf v + where + descend = withObject label descApp + descApp o = + case KM.toList o of + [] -> fail (label <> ": empty envelope, expected {app:{name:{...}}}") + ((_, appVal) : _) -> + withObject (label <> " application") descName appVal + descName appObj = + case KM.toList appObj of + [] -> fail (label <> ": empty application object") + ((_, leafVal) : _) -> + withObject (label <> " leaf") parseLeaf leafVal + +------------------------------------------------------------------------------ +-- Lenses (CRUD layer) +------------------------------------------------------------------------------ + +applicationPrivilegeDefinitionActionsLens :: + Lens' ApplicationPrivilegeDefinition (NonEmpty ActionName) +applicationPrivilegeDefinitionActionsLens = + lens apdActions (\x y -> x {apdActions = y}) + +applicationPrivilegeDefinitionMetadataLens :: + Lens' ApplicationPrivilegeDefinition (Maybe Value) +applicationPrivilegeDefinitionMetadataLens = + lens apdMetadata (\x y -> x {apdMetadata = y}) + +applicationPrivilegeDefinitionExtrasLens :: + Lens' ApplicationPrivilegeDefinition (KeyMap Value) +applicationPrivilegeDefinitionExtrasLens = + lens apdExtras (\x y -> x {apdExtras = y}) + +applicationPrivilegeInfoApplicationLens :: + Lens' ApplicationPrivilegeInfo ApplicationName +applicationPrivilegeInfoApplicationLens = + lens apiApplication (\x y -> x {apiApplication = y}) + +applicationPrivilegeInfoNameLens :: + Lens' ApplicationPrivilegeInfo ApplicationPrivilegeName +applicationPrivilegeInfoNameLens = + lens apiName (\x y -> x {apiName = y}) + +applicationPrivilegeInfoActionsLens :: + Lens' ApplicationPrivilegeInfo [ActionName] +applicationPrivilegeInfoActionsLens = + lens apiActions (\x y -> x {apiActions = y}) + +applicationPrivilegeInfoMetadataLens :: + Lens' ApplicationPrivilegeInfo (Maybe Value) +applicationPrivilegeInfoMetadataLens = + lens apiMetadata (\x y -> x {apiMetadata = y}) + +applicationPrivilegeInfoExtrasLens :: + Lens' ApplicationPrivilegeInfo (KeyMap Value) +applicationPrivilegeInfoExtrasLens = + lens apiExtras (\x y -> x {apiExtras = y}) + +privilegesListResponseEntriesLens :: + Lens' + PrivilegesListResponse + [(ApplicationName, [(ApplicationPrivilegeName, ApplicationPrivilegeInfo)])] +privilegesListResponseEntriesLens = + lens privilegesListEntries (\_ y -> PrivilegesListResponse y) + +privilegeCreatedResponseCreatedLens :: + Lens' PrivilegeCreatedResponse Bool +privilegeCreatedResponseCreatedLens = + lens pcCreated (\x y -> x {pcCreated = y}) + +privilegeDeletedResponseFoundLens :: + Lens' PrivilegeDeletedResponse (Maybe Bool) +privilegeDeletedResponseFoundLens = + lens pdFound (\x y -> x {pdFound = y}) + +clearPrivilegeCacheBodyLens :: + Lens' ClearPrivilegeCacheResponse (KeyMap Value) +clearPrivilegeCacheBodyLens = + lens cpcBody (\x y -> x {cpcBody = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/RoleMappings.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/RoleMappings.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/RoleMappings.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Security.RoleMappings +-- Description : Types for the ES X-Pack Security role mapping API +-- +-- Request and response shapes for the role-mapping endpoints under +-- @\/_security\/role_mapping*@: +-- +-- * @PUT /_security/role_mapping/{name}@ — 'RoleMapping' body, +-- 'Acknowledged' on success. +-- * @GET /_security/role_mapping[/{name}]@ — 'RoleMappingsListResponse' +-- (an ES object keyed by mapping name, decoded to a list of +-- @('RoleMappingName', 'RoleMapping')@ pairs). +-- * @DELETE /_security/role_mapping/{name}@ — 'Acknowledged'. +-- +-- The 'romRules' field is a recursive rule tree ('RoleMappingRule'): +-- composite @all@ \/ @any@ \/ @except@ rules nest arbitrarily deep, +-- and leaf rules are field rules (@username@, @dn@, @groups@, +-- @realm.name@, @metadata.*@) carried as a 'KeyMap' so the typed +-- surface tracks the structural recursion while staying +-- forward-compatible with new field-rule kinds ES may add. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Security.RoleMappings + ( -- * Identity + RoleMappingName (..), + + -- * Rule tree + RoleMappingRule (..), + + -- * Body + RoleMapping (..), + defaultRoleMapping, + roleMappingEnabledLens, + roleMappingRolesLens, + roleMappingRulesLens, + roleMappingMetadataLens, + roleMappingExtrasLens, + + -- * List response + RoleMappingsListResponse (..), + roleMappingsListResponseEntriesLens, + ) +where + +import Data.Aeson +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Aeson.Types (Parser) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) +import Data.Text (Text) +import Data.Vector qualified as V +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens, omitNulls) +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Roles + ( RoleName (..), + ) + +------------------------------------------------------------------------------ +-- Identity +------------------------------------------------------------------------------ + +-- | A role-mapping name — the @\/_security\/role_mapping\/{name}@ path +-- segment and the JSON object key in the list response. +newtype RoleMappingName = RoleMappingName {unRoleMappingName :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +------------------------------------------------------------------------------ +-- Rule tree +------------------------------------------------------------------------------ + +-- | The recursive @rules@ body of a 'RoleMapping'. ES encodes each rule +-- as a single-key JSON object; the four documented keys get typed +-- branches, everything else falls into 'RuleCustom'. +data RoleMappingRule + = -- | @{"all":[...]}@ — matches when every sub-rule matches. + RuleAll (NonEmpty RoleMappingRule) + | -- | @{"any":[...]}@ — matches when at least one sub-rule matches. + RuleAny (NonEmpty RoleMappingRule) + | -- | @{"except":{...}}@ — matches when the nested rule does NOT. + RuleExcept RoleMappingRule + | -- | @{"field":{...}}@ — a field rule. The inner object maps a + -- field path (@username@, @dn@, @groups@, @realm.name@, + -- @metadata.*@, ...) to a value or pattern; carried as an opaque + -- 'KeyMap' because the leaf shapes are heterogeneous (string, list, + -- or a @{value, template}@ object) and ES extends them. + RuleField (KeyMap Value) + | -- | Any future single-key rule ES adds; preserved verbatim so + -- @encode . decode@ round-trips. + RuleCustom Key Value + deriving stock (Eq, Show) + +instance FromJSON RoleMappingRule where + parseJSON = withObject "RoleMappingRule" $ \o -> + case KM.toList o of + [(k, v)] + | k == "all" -> RuleAll <$> parseSubRules v + | k == "any" -> RuleAny <$> parseSubRules v + | k == "except" -> RuleExcept <$> parseJSON v + | k == "field" -> RuleField <$> parseFieldObj v + | otherwise -> pure (RuleCustom k v) + [] -> fail "role mapping rule: empty object" + _ -> fail "role mapping rule: expected a single-key object" + where + parseSubRules :: Value -> Parser (NonEmpty RoleMappingRule) + parseSubRules = withArray "rule list" $ \arr -> + case NE.nonEmpty (V.toList arr) of + Nothing -> fail "role mapping all/any rule: empty array" + Just xs -> traverse parseJSON xs + + parseFieldObj :: Value -> Parser (KeyMap Value) + parseFieldObj = withObject "field rule" pure + +instance ToJSON RoleMappingRule where + toJSON = \case + RuleAll rs -> object ["all" .= NE.toList rs] + RuleAny rs -> object ["any" .= NE.toList rs] + RuleExcept r -> object ["except" .= r] + RuleField km -> object ["field" .= Object km] + RuleCustom k v -> Object (KM.singleton k v) + +------------------------------------------------------------------------------ +-- Body +------------------------------------------------------------------------------ + +-- | A role mapping document — the PUT body and the value in the list +-- response. @enabled@ defaults to @true@ when absent. +data RoleMapping = RoleMapping + { -- | @enabled@ — whether the mapping is active. 'Nothing' on encode + -- means "let the server default (@true@) apply". + romEnabled :: Maybe Bool, + -- | @roles@ — role names granted when @romRules@ matches. + romRoles :: [RoleName], + -- | @rules@ — the matcher that decides whether the mapping applies + -- to an authenticated principal. + romRules :: RoleMappingRule, + -- | @metadata@ — user-provided metadata. + romMetadata :: KeyMap Value, + -- | Catch-all for unknown sibling fields. + romExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | A role mapping with @enabled = Nothing@, no roles, a trivial +-- @any@ rule over the empty list (caller-overwritable), no metadata. +defaultRoleMapping :: RoleMapping +defaultRoleMapping = + RoleMapping + { romEnabled = Nothing, + romRoles = [], + romRules = RuleAny (RuleField KM.empty :| []), + romMetadata = KM.empty, + romExtras = KM.empty + } + +roleMappingKnownKeys :: [Text] +roleMappingKnownKeys = ["enabled", "roles", "rules", "metadata"] + +instance FromJSON RoleMapping where + parseJSON = withObject "RoleMapping" $ \o -> do + enabled <- o .:? "enabled" + roles <- fromMaybe [] <$> o .:? "roles" + rules <- o .: "rules" + metadata <- fromMaybe KM.empty <$> o .:? "metadata" + let extras = + KM.fromList $ + filter + ((`notElem` roleMappingKnownKeys) . toText . fst) + (KM.toList o) + pure + RoleMapping + { romEnabled = enabled, + romRoles = roles, + romRules = rules, + romMetadata = metadata, + romExtras = extras + } + +instance ToJSON RoleMapping where + toJSON RoleMapping {..} = + omitNulls $ + catMaybes + [ ("enabled" .=) <$> romEnabled, + Just ("roles" .= romRoles), + Just ("rules" .= romRules), + Just ("metadata" .= romMetadata) + ] + <> [toPair kv | kv <- KM.toList romExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- List response +------------------------------------------------------------------------------ + +-- | Response of @GET /_security/role_mapping[/{name}]@: an ES object +-- keyed by mapping name, each value a 'RoleMapping'. Decoded to a list +-- of @('RoleMappingName', 'RoleMapping')@ pairs. +newtype RoleMappingsListResponse = RoleMappingsListResponse + { roleMappingsListEntries :: [(RoleMappingName, RoleMapping)] + } + deriving stock (Eq, Show) + +instance FromJSON RoleMappingsListResponse where + parseJSON = withObject "RoleMappingsListResponse" $ \o -> do + entries <- traverse parseEntry (KM.toList o) + pure (RoleMappingsListResponse entries) + where + parseEntry (k, v) = do + rm <- parseJSON v + pure (RoleMappingName (toText k), rm) + +instance ToJSON RoleMappingsListResponse where + toJSON (RoleMappingsListResponse entries) = + Object + (KM.fromList [(fromText (unRoleMappingName n), toJSON rm) | (n, rm) <- entries]) + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +roleMappingEnabledLens :: Lens' RoleMapping (Maybe Bool) +roleMappingEnabledLens = lens romEnabled (\x y -> x {romEnabled = y}) + +roleMappingRolesLens :: Lens' RoleMapping [RoleName] +roleMappingRolesLens = lens romRoles (\x y -> x {romRoles = y}) + +roleMappingRulesLens :: Lens' RoleMapping RoleMappingRule +roleMappingRulesLens = lens romRules (\x y -> x {romRules = y}) + +roleMappingMetadataLens :: Lens' RoleMapping (KeyMap Value) +roleMappingMetadataLens = lens romMetadata (\x y -> x {romMetadata = y}) + +roleMappingExtrasLens :: Lens' RoleMapping (KeyMap Value) +roleMappingExtrasLens = lens romExtras (\x y -> x {romExtras = y}) + +roleMappingsListResponseEntriesLens :: + Lens' RoleMappingsListResponse [(RoleMappingName, RoleMapping)] +roleMappingsListResponseEntriesLens = + lens roleMappingsListEntries (\_ y -> RoleMappingsListResponse y) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Roles.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Roles.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Roles.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Security.Roles +-- Description : Types for the ES X-Pack Security role API (/_security/role/*) +-- +-- Request and response shapes for the role-management endpoints under +-- @\/_security\/role*@: +-- +-- * @PUT /_security/role/{name}@ — 'Role' body, 'RoleCreatedResponse' on +-- success (@{"role":{"created":true}}@ — @created@ is @false@ on +-- overwrite). +-- * @GET /_security/role[/{name}]@ — 'RolesListResponse' (an ES object +-- keyed by role name, decoded to a list of @('RoleName', 'Role')@ +-- pairs so the common single-role case still round-trips cleanly). +-- * @DELETE /_security/role/{name}@ — 'RoleDeletedResponse' +-- (@{"found":true,"acknowledged":true}@). +-- * @POST /_security/role/{name}/_clear_cache@ — 'ClearRoleCacheResponse' +-- (@{"cleared":[...names]}@). +-- +-- The 'Role' body is the same document shape used by API-key +-- @role_descriptors@ (see +-- "Database.Bloodhound.Internal.Versions.Common.Types.Security.ApiKeys"), +-- which is why the cluster \/ index \/ application privilege fields come +-- from "Database.Bloodhound.Internal.Versions.Common.Types.Security.Privileges". +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Security.Roles + ( -- * Identity + RoleName (..), + + -- * Role body + Role (..), + defaultRole, + roleClusterLens, + roleIndicesLens, + roleApplicationsLens, + roleRunAsLens, + roleMetadataLens, + roleTransientMetadataLens, + roleExtrasLens, + + -- * PUT response + RoleCreatedResponse (..), + roleCreatedResponseCreatedLens, + + -- * DELETE response + RoleDeletedResponse (..), + roleDeletedResponseFoundLens, + roleDeletedResponseAcknowledgedLens, + + -- * List response + RolesListResponse (..), + rolesListResponseEntriesLens, + + -- * Clear cache response + ClearRoleCacheResponse (..), + clearRoleCacheResponseClearedLens, + ) +where + +import Data.Aeson +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', Parser, lens, omitNulls) +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Privileges + ( ApplicationPrivilege (..), + ClusterPrivilege (..), + IndexPrivilege (..), + ) + +------------------------------------------------------------------------------ +-- Identity +------------------------------------------------------------------------------ + +-- | A role name, used both as the URL path segment for +-- @\/_security\/role\/{name}@ and as the JSON object key in the list +-- response. Wraps 'Text' for round-trip-as-bare-string while staying +-- distinct at the type level from other security identifiers. +newtype RoleName = RoleName {unRoleName :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +------------------------------------------------------------------------------ +-- Role body +------------------------------------------------------------------------------ + +-- | A role document — the PUT body for @\/_security\/role\/{name}@ and +-- the value associated with each role name in the GET response. The +-- typed fields are the stable documented ones; 'rExtras' carries +-- everything else so @encode . decode@ round-trips even when ES adds +-- new optional sibling fields. +data Role = Role + { -- | @cluster@ — cluster-level privileges. May be empty. + rCluster :: [ClusterPrivilege], + -- | @indices@ — per-index privilege entries. + rIndices :: [IndexPrivilege], + -- | @applications@ — application privilege entries. + rApplications :: [ApplicationPrivilege], + -- | @run_as@ — usernames the role may impersonate. Carried as + -- 'Text' (rather than a dedicated 'UserName') so this module has no + -- dependency on the Users module; the strings are usernames per the + -- ES semantics. + rRunAs :: [Text], + -- | @metadata@ — user-provided metadata. ES filters keys starting + -- with @_@ (reserved) on input; callers must pre-strip them. + rMetadata :: KeyMap Value, + -- | @transient_metadata@ — effective metadata merged from the role + -- and its owner. Present only in GET responses; never sent on PUT. + rTransientMetadata :: Maybe (KeyMap Value), + -- | Catch-all for unknown sibling fields. + rExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | A role with all privilege lists empty and no metadata — a starting +-- point callers overwrite via the record lenses. +defaultRole :: Role +defaultRole = + Role + { rCluster = [], + rIndices = [], + rApplications = [], + rRunAs = [], + rMetadata = KM.empty, + rTransientMetadata = Nothing, + rExtras = KM.empty + } + +roleKnownKeys :: [Text] +roleKnownKeys = + [ "cluster", + "indices", + "applications", + "run_as", + "metadata", + "transient_metadata" + ] + +instance FromJSON Role where + parseJSON = withObject "Role" $ \o -> do + cluster <- fromMaybe [] <$> o .:? "cluster" + indices <- fromMaybe [] <$> o .:? "indices" + applications <- fromMaybe [] <$> o .:? "applications" + runAs <- fromMaybe [] <$> o .:? "run_as" + metadata <- fromMaybe KM.empty <$> o .:? "metadata" + transientMetadata <- o .:? "transient_metadata" + let extras = + KM.fromList $ + filter + ((`notElem` roleKnownKeys) . toText . fst) + (KM.toList o) + pure + Role + { rCluster = cluster, + rIndices = indices, + rApplications = applications, + rRunAs = runAs, + rMetadata = metadata, + rTransientMetadata = transientMetadata, + rExtras = extras + } + +instance ToJSON Role where + toJSON Role {..} = + omitNulls $ + catMaybes + [ Just ("cluster" .= rCluster), + Just ("indices" .= rIndices), + Just ("applications" .= rApplications), + Just ("run_as" .= rRunAs), + -- @metadata@ encodes to a non-'Null' 'Object', so it + -- survives 'omitNulls' (which drops only 'Null' and empty + -- arrays, not empty objects). + Just ("metadata" .= rMetadata), + ("transient_metadata" .=) <$> rTransientMetadata + ] + <> [toPair kv | kv <- KM.toList rExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- PUT response +------------------------------------------------------------------------------ + +-- | Response of @PUT /_security/role/{name}@. ES wraps the boolean in a +-- nested @role@ object: @{"role":{"created":true}}@. @created@ is +-- @false@ when the call updated an existing role rather than creating a +-- new one. +newtype RoleCreatedResponse = RoleCreatedResponse + { rcCreated :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON RoleCreatedResponse where + parseJSON = withObject "RoleCreatedResponse" $ \o -> do + -- Pull the nested object as an opaque 'Value' so the inferred type + -- of 'roleVal' is NOT 'RoleCreatedResponse' (which would recurse + -- back into this instance). + roleVal <- (o .: "role") :: Parser Value + withObject + "RoleCreatedResponse.role" + (\obj -> RoleCreatedResponse <$> obj .: "created") + roleVal + +instance ToJSON RoleCreatedResponse where + toJSON RoleCreatedResponse {..} = + object ["role" .= object ["created" .= rcCreated]] + +------------------------------------------------------------------------------ +-- DELETE response +------------------------------------------------------------------------------ + +-- | Response of @DELETE /_security/role/{name}@. @found@ is @false@ +-- when the role did not exist (ES still returns 200 + acknowledged). +data RoleDeletedResponse = RoleDeletedResponse + { rdFound :: Maybe Bool, + rdAcknowledged :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON RoleDeletedResponse where + parseJSON = withObject "RoleDeletedResponse" $ \o -> do + found <- o .:? "found" + ack <- o .: "acknowledged" + pure RoleDeletedResponse {rdFound = found, rdAcknowledged = ack} + +instance ToJSON RoleDeletedResponse where + toJSON RoleDeletedResponse {..} = + omitNulls $ + catMaybes + [ ("found" .=) <$> rdFound, + Just ("acknowledged" .= rdAcknowledged) + ] + +------------------------------------------------------------------------------ +-- List response +------------------------------------------------------------------------------ + +-- | Response of @GET /_security/role[/{name}]@: an ES object keyed by +-- role name, each value a 'Role'. The decoder folds the object into a +-- list of @('RoleName', 'Role')@ pairs so both the list-all and +-- get-one variants share one response type. The encoder reproduces the +-- object-keyed shape. +newtype RolesListResponse = RolesListResponse + { rolesListEntries :: [(RoleName, Role)] + } + deriving stock (Eq, Show) + +instance FromJSON RolesListResponse where + parseJSON = withObject "RolesListResponse" $ \o -> do + let kvPairs = KM.toList o + entries <- traverse parseEntry kvPairs + pure (RolesListResponse entries) + where + parseEntry (k, v) = do + role <- parseJSON v + -- The object key is the role name on the wire; reattach it as + -- a 'RoleName'. 'toText' round-trips the 'Key' to 'Text' + -- losslessly for role names (which cannot contain NUL bytes). + pure (RoleName (toText k), role) + +instance ToJSON RolesListResponse where + toJSON (RolesListResponse entries) = + Object (KM.fromList [(fromText (unRoleName n), toJSON r) | (n, r) <- entries]) + +------------------------------------------------------------------------------ +-- Clear cache response +------------------------------------------------------------------------------ + +-- | Response of @POST /_security/role/{name}/_clear_cache@: +-- @{"cleared":[...names]}@. Lists the role names whose cache was +-- cleared. +newtype ClearRoleCacheResponse = ClearRoleCacheResponse + { clearedRoles :: [RoleName] + } + deriving stock (Eq, Show) + +instance FromJSON ClearRoleCacheResponse where + parseJSON = withObject "ClearRoleCacheResponse" $ \o -> do + cleared <- fromMaybe [] <$> o .:? "cleared" + pure (ClearRoleCacheResponse cleared) + +instance ToJSON ClearRoleCacheResponse where + toJSON (ClearRoleCacheResponse names) = + object ["cleared" .= names] + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +roleClusterLens :: Lens' Role [ClusterPrivilege] +roleClusterLens = lens rCluster (\x y -> x {rCluster = y}) + +roleIndicesLens :: Lens' Role [IndexPrivilege] +roleIndicesLens = lens rIndices (\x y -> x {rIndices = y}) + +roleApplicationsLens :: Lens' Role [ApplicationPrivilege] +roleApplicationsLens = lens rApplications (\x y -> x {rApplications = y}) + +roleRunAsLens :: Lens' Role [Text] +roleRunAsLens = lens rRunAs (\x y -> x {rRunAs = y}) + +roleMetadataLens :: Lens' Role (KeyMap Value) +roleMetadataLens = lens rMetadata (\x y -> x {rMetadata = y}) + +roleTransientMetadataLens :: + Lens' Role (Maybe (KeyMap Value)) +roleTransientMetadataLens = + lens rTransientMetadata (\x y -> x {rTransientMetadata = y}) + +roleExtrasLens :: Lens' Role (KeyMap Value) +roleExtrasLens = lens rExtras (\x y -> x {rExtras = y}) + +roleCreatedResponseCreatedLens :: Lens' RoleCreatedResponse Bool +roleCreatedResponseCreatedLens = + lens rcCreated (\x y -> x {rcCreated = y}) + +roleDeletedResponseFoundLens :: + Lens' RoleDeletedResponse (Maybe Bool) +roleDeletedResponseFoundLens = + lens rdFound (\x y -> x {rdFound = y}) + +roleDeletedResponseAcknowledgedLens :: + Lens' RoleDeletedResponse Bool +roleDeletedResponseAcknowledgedLens = + lens rdAcknowledged (\x y -> x {rdAcknowledged = y}) + +rolesListResponseEntriesLens :: + Lens' RolesListResponse [(RoleName, Role)] +rolesListResponseEntriesLens = + lens rolesListEntries (\_ y -> RolesListResponse y) + +clearRoleCacheResponseClearedLens :: + Lens' ClearRoleCacheResponse [RoleName] +clearRoleCacheResponseClearedLens = + lens clearedRoles (\x y -> x {clearedRoles = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/ServiceAccounts.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/ServiceAccounts.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/ServiceAccounts.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Security.ServiceAccounts +-- Description : Types for the ES X-Pack Security service account API (/_security/service/*) +-- +-- Request and response shapes for the service-account endpoints under +-- @\/_security\/service*@. Service accounts are reserved principals +-- (@\@\/@\@, e.g. @elastic\/fleet-server@) that +-- authenticate with service tokens rather than passwords. +-- +-- * @GET /_security/service@ — 'ServiceAccountsListResponse' (an ES +-- object keyed by the full @\@\/@\@ principal, +-- decoded to a list of pairs so list-all and get-one share one type). +-- * @GET /_security/service/{namespace}[/{service}]@ — same shape. +-- * @POST /_security/service/{namespace}/{service}/credential/token[/{token_name}]@ +-- — 'CreateServiceTokenResponse' (the secret token @value@ is returned +-- exactly once). +-- * @GET /_security/service/{namespace}/{service}/credential@ — +-- 'GetServiceCredentialsResponse' (index-backed @tokens@ plus the +-- file-backed @nodes_credentials@). +-- * @DELETE /_security/service/{namespace}/{service}/credential/token/{token_name}@ +-- — 'ServiceTokenDeletedResponse' (@{"found":true}@; 404 + @found=false@ +-- when absent). +-- +-- The read-only @role_descriptor@ is structurally a 'Role', so it is +-- reused rather than duplicated. Service tokens never expire. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Security.ServiceAccounts + ( -- * Identity + ServiceAccountNamespace (..), + ServiceAccountService (..), + ServiceTokenName (..), + + -- * Service account body + ServiceAccount (..), + defaultServiceAccount, + serviceAccountRoleDescriptorLens, + serviceAccountExtrasLens, + + -- * List response + ServiceAccountsListResponse (..), + serviceAccountsListResponseEntriesLens, + + -- * Create-token response + ServiceTokenSecret (..), + serviceTokenSecretNameLens, + serviceTokenSecretValueLens, + serviceTokenSecretExtrasLens, + CreateServiceTokenResponse (..), + createServiceTokenResponseCreatedLens, + createServiceTokenResponseTokenLens, + createServiceTokenResponseExtrasLens, + + -- * Get-credentials response + GetServiceCredentialsResponse (..), + getServiceCredentialsResponseServiceAccountLens, + getServiceCredentialsResponseCountLens, + getServiceCredentialsResponseTokensLens, + getServiceCredentialsResponseNodesCredentialsLens, + getServiceCredentialsResponseExtrasLens, + + -- * Delete-token response + ServiceTokenDeletedResponse (..), + serviceTokenDeletedResponseFoundLens, + serviceTokenDeletedResponseExtrasLens, + ) +where + +import Data.Aeson +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (catMaybes) +import Data.String (IsString) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens, omitNulls) +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Roles (Role) + +------------------------------------------------------------------------------ +-- Identity +------------------------------------------------------------------------------ + +-- | The namespace half of a service account principal (e.g. @elastic@). +newtype ServiceAccountNamespace = ServiceAccountNamespace + { unServiceAccountNamespace :: Text + } + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +-- | The service half of a service account principal (e.g. @fleet-server@). +newtype ServiceAccountService = ServiceAccountService + { unServiceAccountService :: Text + } + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +-- | A service account token identifier. +newtype ServiceTokenName = ServiceTokenName + { unServiceTokenName :: Text + } + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +------------------------------------------------------------------------------ +-- Service account body +------------------------------------------------------------------------------ + +-- | A service account as returned by @GET /_security/service*@. The +-- @role_descriptor@ is the reserved role the account acts under; it is +-- structurally a 'Role'. Unknown sibling fields round-trip in 'saExtras'. +data ServiceAccount = ServiceAccount + { saRoleDescriptor :: Maybe Role, + saExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | An empty service account — a starting point callers overwrite via the +-- record lenses. +defaultServiceAccount :: ServiceAccount +defaultServiceAccount = + ServiceAccount + { saRoleDescriptor = Nothing, + saExtras = KM.empty + } + +serviceAccountKnownKeys :: [Text] +serviceAccountKnownKeys = ["role_descriptor"] + +instance FromJSON ServiceAccount where + parseJSON = withObject "ServiceAccount" $ \o -> do + roleDescriptor <- o .:? "role_descriptor" + let extras = + KM.fromList $ + filter + ((`notElem` serviceAccountKnownKeys) . toText . fst) + (KM.toList o) + pure + ServiceAccount + { saRoleDescriptor = roleDescriptor, + saExtras = extras + } + +instance ToJSON ServiceAccount where + toJSON ServiceAccount {..} = + omitNulls $ + catMaybes + [ ("role_descriptor" .=) <$> saRoleDescriptor + ] + <> [k .= v | (k, v) <- KM.toList saExtras] + +------------------------------------------------------------------------------ +-- List response +------------------------------------------------------------------------------ + +-- | Response of @GET /_security/service*@: an ES object keyed by the full +-- @\\/\@ principal. The decoder folds the object +-- into a list of @('Text', 'ServiceAccount')@ pairs so list-all and +-- get-one share one response type. The encoder reproduces the +-- object-keyed shape. +newtype ServiceAccountsListResponse = ServiceAccountsListResponse + { serviceAccountsListEntries :: [(Text, ServiceAccount)] + } + deriving stock (Eq, Show) + +instance FromJSON ServiceAccountsListResponse where + parseJSON = withObject "ServiceAccountsListResponse" $ \o -> do + let kvPairs = KM.toList o + entries <- traverse parseEntry kvPairs + pure (ServiceAccountsListResponse entries) + where + parseEntry (k, v) = do + account <- parseJSON v + pure (toText k, account) + +instance ToJSON ServiceAccountsListResponse where + toJSON (ServiceAccountsListResponse entries) = + Object (KM.fromList [(fromText n, toJSON a) | (n, a) <- entries]) + +------------------------------------------------------------------------------ +-- Create-token response +------------------------------------------------------------------------------ + +-- | The @token@ sub-object of 'CreateServiceTokenResponse': the token +-- @name@ and its secret bearer @value@. The @value@ is the credential to +-- send in an @Authorization: Bearer@ header; it is returned exactly once +-- on creation. +data ServiceTokenSecret = ServiceTokenSecret + { stsName :: Maybe Text, + stsValue :: Maybe Text, + stsExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +serviceTokenSecretKnownKeys :: [Text] +serviceTokenSecretKnownKeys = ["name", "value"] + +instance FromJSON ServiceTokenSecret where + parseJSON = withObject "ServiceTokenSecret" $ \o -> do + name <- o .:? "name" + value <- o .:? "value" + let extras = + KM.fromList $ + filter + ((`notElem` serviceTokenSecretKnownKeys) . toText . fst) + (KM.toList o) + pure + ServiceTokenSecret + { stsName = name, + stsValue = value, + stsExtras = extras + } + +instance ToJSON ServiceTokenSecret where + toJSON ServiceTokenSecret {..} = + omitNulls $ + catMaybes + [ ("name" .=) <$> stsName, + ("value" .=) <$> stsValue + ] + <> [k .= v | (k, v) <- KM.toList stsExtras] + +-- | Response of @POST ...\/credential\/token@: whether the token was +-- created and its secret 'ServiceTokenSecret'. +data CreateServiceTokenResponse = CreateServiceTokenResponse + { cstrCreated :: Maybe Bool, + cstrToken :: Maybe ServiceTokenSecret, + cstrExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +createServiceTokenResponseKnownKeys :: [Text] +createServiceTokenResponseKnownKeys = ["created", "token"] + +instance FromJSON CreateServiceTokenResponse where + parseJSON = withObject "CreateServiceTokenResponse" $ \o -> do + created <- o .:? "created" + token <- o .:? "token" + let extras = + KM.fromList $ + filter + ((`notElem` createServiceTokenResponseKnownKeys) . toText . fst) + (KM.toList o) + pure + CreateServiceTokenResponse + { cstrCreated = created, + cstrToken = token, + cstrExtras = extras + } + +instance ToJSON CreateServiceTokenResponse where + toJSON CreateServiceTokenResponse {..} = + omitNulls $ + catMaybes + [ ("created" .=) <$> cstrCreated, + ("token" .=) <$> cstrToken + ] + <> [k .= v | (k, v) <- KM.toList cstrExtras] + +------------------------------------------------------------------------------ +-- Get-credentials response +------------------------------------------------------------------------------ + +-- | Response of @GET ...\/credential@: the index-backed @tokens@ (a map +-- of token name to an empty object — secret values are not returned) and +-- the file-backed @nodes_credentials@ collected from across the cluster. +-- The latter is a deeply-nested, node-status-shaped object, carried as an +-- opaque 'Value'. +data GetServiceCredentialsResponse = GetServiceCredentialsResponse + { gscrServiceAccount :: Maybe Text, + gscrCount :: Maybe Int, + gscrTokens :: Maybe (KeyMap Value), + gscrNodesCredentials :: Maybe Value, + gscrExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +getServiceCredentialsResponseKnownKeys :: [Text] +getServiceCredentialsResponseKnownKeys = + ["service_account", "count", "tokens", "nodes_credentials"] + +instance FromJSON GetServiceCredentialsResponse where + parseJSON = withObject "GetServiceCredentialsResponse" $ \o -> do + serviceAccount <- o .:? "service_account" + count <- o .:? "count" + tokens <- o .:? "tokens" + nodesCredentials <- o .:? "nodes_credentials" + let extras = + KM.fromList $ + filter + ((`notElem` getServiceCredentialsResponseKnownKeys) . toText . fst) + (KM.toList o) + pure + GetServiceCredentialsResponse + { gscrServiceAccount = serviceAccount, + gscrCount = count, + gscrTokens = tokens, + gscrNodesCredentials = nodesCredentials, + gscrExtras = extras + } + +instance ToJSON GetServiceCredentialsResponse where + toJSON GetServiceCredentialsResponse {..} = + omitNulls $ + catMaybes + [ ("service_account" .=) <$> gscrServiceAccount, + ("count" .=) <$> gscrCount, + ("tokens" .=) <$> gscrTokens, + ("nodes_credentials" .=) <$> gscrNodesCredentials + ] + <> [k .= v | (k, v) <- KM.toList gscrExtras] + +------------------------------------------------------------------------------ +-- Delete-token response +------------------------------------------------------------------------------ + +-- | Response of @DELETE ...\/credential\/token\/{token_name}@: whether +-- the token was found and deleted. A missing token yields 404 with +-- @found=false@ (surfaced via 'StatusDependant'). +data ServiceTokenDeletedResponse = ServiceTokenDeletedResponse + { stdFound :: Maybe Bool, + stdExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +serviceTokenDeletedResponseKnownKeys :: [Text] +serviceTokenDeletedResponseKnownKeys = ["found"] + +instance FromJSON ServiceTokenDeletedResponse where + parseJSON = withObject "ServiceTokenDeletedResponse" $ \o -> do + found <- o .:? "found" + let extras = + KM.fromList $ + filter + ((`notElem` serviceTokenDeletedResponseKnownKeys) . toText . fst) + (KM.toList o) + pure + ServiceTokenDeletedResponse + { stdFound = found, + stdExtras = extras + } + +instance ToJSON ServiceTokenDeletedResponse where + toJSON ServiceTokenDeletedResponse {..} = + omitNulls $ + catMaybes + [ ("found" .=) <$> stdFound + ] + <> [k .= v | (k, v) <- KM.toList stdExtras] + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +serviceAccountRoleDescriptorLens :: Lens' ServiceAccount (Maybe Role) +serviceAccountRoleDescriptorLens = + lens saRoleDescriptor (\x y -> x {saRoleDescriptor = y}) + +serviceAccountExtrasLens :: Lens' ServiceAccount (KeyMap Value) +serviceAccountExtrasLens = + lens saExtras (\x y -> x {saExtras = y}) + +serviceAccountsListResponseEntriesLens :: + Lens' ServiceAccountsListResponse [(Text, ServiceAccount)] +serviceAccountsListResponseEntriesLens = + lens + serviceAccountsListEntries + (\_ y -> ServiceAccountsListResponse y) + +serviceTokenSecretNameLens :: Lens' ServiceTokenSecret (Maybe Text) +serviceTokenSecretNameLens = + lens stsName (\x y -> x {stsName = y}) + +serviceTokenSecretValueLens :: Lens' ServiceTokenSecret (Maybe Text) +serviceTokenSecretValueLens = + lens stsValue (\x y -> x {stsValue = y}) + +serviceTokenSecretExtrasLens :: Lens' ServiceTokenSecret (KeyMap Value) +serviceTokenSecretExtrasLens = + lens stsExtras (\x y -> x {stsExtras = y}) + +createServiceTokenResponseCreatedLens :: + Lens' CreateServiceTokenResponse (Maybe Bool) +createServiceTokenResponseCreatedLens = + lens cstrCreated (\x y -> x {cstrCreated = y}) + +createServiceTokenResponseTokenLens :: + Lens' CreateServiceTokenResponse (Maybe ServiceTokenSecret) +createServiceTokenResponseTokenLens = + lens cstrToken (\x y -> x {cstrToken = y}) + +createServiceTokenResponseExtrasLens :: + Lens' CreateServiceTokenResponse (KeyMap Value) +createServiceTokenResponseExtrasLens = + lens cstrExtras (\x y -> x {cstrExtras = y}) + +getServiceCredentialsResponseServiceAccountLens :: + Lens' GetServiceCredentialsResponse (Maybe Text) +getServiceCredentialsResponseServiceAccountLens = + lens gscrServiceAccount (\x y -> x {gscrServiceAccount = y}) + +getServiceCredentialsResponseCountLens :: + Lens' GetServiceCredentialsResponse (Maybe Int) +getServiceCredentialsResponseCountLens = + lens gscrCount (\x y -> x {gscrCount = y}) + +getServiceCredentialsResponseTokensLens :: + Lens' GetServiceCredentialsResponse (Maybe (KeyMap Value)) +getServiceCredentialsResponseTokensLens = + lens gscrTokens (\x y -> x {gscrTokens = y}) + +getServiceCredentialsResponseNodesCredentialsLens :: + Lens' GetServiceCredentialsResponse (Maybe Value) +getServiceCredentialsResponseNodesCredentialsLens = + lens gscrNodesCredentials (\x y -> x {gscrNodesCredentials = y}) + +getServiceCredentialsResponseExtrasLens :: + Lens' GetServiceCredentialsResponse (KeyMap Value) +getServiceCredentialsResponseExtrasLens = + lens gscrExtras (\x y -> x {gscrExtras = y}) + +serviceTokenDeletedResponseFoundLens :: + Lens' ServiceTokenDeletedResponse (Maybe Bool) +serviceTokenDeletedResponseFoundLens = + lens stdFound (\x y -> x {stdFound = y}) + +serviceTokenDeletedResponseExtrasLens :: + Lens' ServiceTokenDeletedResponse (KeyMap Value) +serviceTokenDeletedResponseExtrasLens = + lens stdExtras (\x y -> x {stdExtras = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Sso.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Sso.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Sso.hs @@ -0,0 +1,856 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Security.Sso +-- Description : Types for the ES X-Pack Security SSO / token APIs +-- +-- Request and response shapes for the single-sign-on and OAuth2 token +-- endpoints under @\/_security\/oauth2@, @\/_security\/oidc@, and +-- @\/_security\/saml@ (ES X-Pack only — OpenSearch does not implement +-- these). The SAML and OpenID Connect flows are SP-initiated SSO: a +-- @...\/prepare@ call mints an authentication-request URL, the user's +-- browser is redirected to the IdP, and the resulting @...\/authenticate@ +-- call exchanges the IdP response for an Elasticsearch access\/refresh +-- token pair. +-- +-- OAuth2 token API (@\/_security\/oauth2\/token@): +-- +-- * @POST /_security/oauth2/token@ — 'GetTokenRequest' body, +-- 'GetTokenResponse'. Mints a bearer token via one of four grant +-- types ('OAuth2GrantType'). @client_credentials@ yields an +-- access-only token; @password@ \/ @_kerberos@ also return a +-- @refresh_token@. +-- * @DELETE /_security/oauth2/token@ — 'InvalidateTokenRequest' body, +-- 'InvalidateTokenResponse'. Revokes a token (or every token for a +-- realm\/user). The natural DELETE counterpart to the POST above. +-- +-- SAML API (@\/_security\/saml@): +-- +-- * @POST /_security/saml/prepare@ — 'SamlPrepareRequest' body, +-- 'SamlPrepareResponse' (the redirect URL + the request @id@ the +-- caller must echo back at authenticate time). +-- * @POST /_security/saml/authenticate@ — 'SamlAuthenticateRequest' +-- body, 'SsoTokenResponse' (an access\/refresh token pair). +-- * @POST /_security/saml/logout@ — 'SamlLogoutRequest' body, +-- 'SsoRedirectResponse' (an optional IdP logout redirect URL). +-- +-- OpenID Connect API (@\/_security\/oidc@): +-- +-- * @POST /_security/oidc/prepare@ — 'OidcPrepareRequest' body, +-- 'OidcPrepareResponse' (the redirect URL + the @state@ \/ @nonce@ +-- the caller must echo back at authenticate time). +-- * @POST /_security/oidc/authenticate@ — 'OidcAuthenticateRequest' +-- body, 'SsoTokenResponse'. +-- * @POST /_security/oidc/logout@ — 'OidcLogoutRequest' body, +-- 'SsoRedirectResponse'. +-- +-- The SAML and OIDC @authenticate@ responses share the +-- 'SsoTokenResponse' token-pair shape; the OAuth2 @POST@ response +-- ('GetTokenResponse') additionally carries the elaborate +-- 'TokenAuthentication' detail block. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Security.Sso + ( -- * Identity + SsoToken (..), + SsoRefreshToken (..), + + -- * OAuth2 token — get (POST /_security/oauth2/token) + OAuth2GrantType (..), + oAuth2GrantTypeText, + GetTokenRequest (..), + defaultGetTokenRequest, + GetTokenResponse (..), + TokenAuthentication (..), + SsoRealmInfo (..), + tokenAuthenticationExtrasLens, + + -- * OAuth2 token — invalidate (DELETE /_security/oauth2/token) + InvalidateTokenRequest (..), + defaultInvalidateTokenRequest, + InvalidateTokenResponse (..), + InvalidateTokenError (..), + + -- * Shared authenticate / logout responses + SsoTokenResponse (..), + SsoRedirectResponse (..), + + -- * SAML (/_security/saml/*) + SamlPrepareRequest (..), + defaultSamlPrepareRequest, + SamlPrepareResponse (..), + SamlAuthenticateRequest (..), + SamlLogoutRequest (..), + + -- * OpenID Connect (/_security/oidc/*) + OidcPrepareRequest (..), + defaultOidcPrepareRequest, + OidcPrepareResponse (..), + OidcAuthenticateRequest (..), + OidcLogoutRequest (..), + ) +where + +import Data.Aeson +import Data.Aeson.Key (toText) +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens, omitNulls) +import Database.Bloodhound.Internal.Utils.Secret (SecretText (..)) + +------------------------------------------------------------------------------ +-- Identity +------------------------------------------------------------------------------ + +-- | An Elasticsearch access token — the @access_token@ string returned +-- by every token-minting endpoint. Sent back to ES in an +-- @Authorization: Bearer ...@ header. The inner 'SecretText' ensures +-- 'show' never leaks the token. +newtype SsoToken = SsoToken {unSsoToken :: SecretText} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +-- | An Elasticsearch refresh token — the @refresh_token@ string used to +-- mint a new access token before the old one expires. Returned by the +-- @password@, @_kerberos@, and SAML\/OIDC authenticate flows (but NOT +-- by @client_credentials@). The inner 'SecretText' ensures 'show' +-- never leaks the token. +newtype SsoRefreshToken = SsoRefreshToken {unSsoRefreshToken :: SecretText} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +------------------------------------------------------------------------------ +-- OAuth2 token — get (POST /_security/oauth2/token) +------------------------------------------------------------------------------ + +-- | The @grant_type@ discriminator for @POST /_security/oauth2/token@. +data OAuth2GrantType + = -- | @password@ — exchange a username + password for a token pair. + OAuth2GrantPassword + | -- | @_kerberos@ — exchange a SPNEGO Kerberos ticket for a token + -- pair (the leading underscore is part of the wire spelling). + OAuth2GrantKerberos + | -- | @client_credentials@ — mint a token for the authenticated + -- caller; access-only (no refresh token). + OAuth2GrantClientCredentials + | -- | @refresh_token@ — refresh an existing token pair. + OAuth2GrantRefreshToken + deriving stock (Eq, Show) + +-- | The wire spelling of each 'OAuth2GrantType'. +oAuth2GrantTypeText :: OAuth2GrantType -> Text +oAuth2GrantTypeText OAuth2GrantPassword = "password" +oAuth2GrantTypeText OAuth2GrantKerberos = "_kerberos" +oAuth2GrantTypeText OAuth2GrantClientCredentials = "client_credentials" +oAuth2GrantTypeText OAuth2GrantRefreshToken = "refresh_token" + +instance ToJSON OAuth2GrantType where + toJSON = toJSON . oAuth2GrantTypeText + +instance FromJSON OAuth2GrantType where + parseJSON = withText "OAuth2GrantType" $ \case + "password" -> pure OAuth2GrantPassword + "_kerberos" -> pure OAuth2GrantKerberos + "client_credentials" -> pure OAuth2GrantClientCredentials + "refresh_token" -> pure OAuth2GrantRefreshToken + other -> fail ("unknown grant_type: " <> show other) + +-- | Request body for @POST /_security/oauth2/token@. The fields +-- populated depend on 'gtqGrantType': @password@ needs +-- 'gtqUsername' \/ 'gtqPassword'; @_kerberos@ needs 'gtqKerberosTicket'; +-- @refresh_token@ needs 'gtqRefreshToken'; @client_credentials@ needs +-- none of these. Credential-bearing fields ('gtqPassword', +-- 'gtqKerberosTicket') are wrapped in 'SecretText' so 'show' never +-- leaks them. +data GetTokenRequest = GetTokenRequest + { gtqGrantType :: OAuth2GrantType, + gtqUsername :: Maybe Text, + gtqPassword :: Maybe SecretText, + gtqKerberosTicket :: Maybe SecretText, + gtqRefreshToken :: Maybe SsoRefreshToken, + -- | @scope@ — currently always issued as @FULL@ regardless of the + -- value sent. + gtqScope :: Maybe Text + } + deriving stock (Eq, Show) + +-- | Minimal @client_credentials@ request — a token for the caller with +-- no extra selectors. +defaultGetTokenRequest :: GetTokenRequest +defaultGetTokenRequest = + GetTokenRequest + { gtqGrantType = OAuth2GrantClientCredentials, + gtqUsername = Nothing, + gtqPassword = Nothing, + gtqKerberosTicket = Nothing, + gtqRefreshToken = Nothing, + gtqScope = Nothing + } + +instance ToJSON GetTokenRequest where + toJSON GetTokenRequest {..} = + omitNulls $ + catMaybes + [ Just ("grant_type" .= gtqGrantType), + ("username" .=) <$> gtqUsername, + ("password" .=) <$> gtqPassword, + ("kerberos_ticket" .=) <$> gtqKerberosTicket, + ("refresh_token" .=) <$> gtqRefreshToken, + ("scope" .=) <$> gtqScope + ] + +instance FromJSON GetTokenRequest where + parseJSON = withObject "GetTokenRequest" $ \o -> do + grantType <- o .: "grant_type" + username <- o .:? "username" + password <- o .:? "password" + kerberosTicket <- o .:? "kerberos_ticket" + refreshToken <- o .:? "refresh_token" + scope <- o .:? "scope" + pure + GetTokenRequest + { gtqGrantType = grantType, + gtqUsername = username, + gtqPassword = password, + gtqKerberosTicket = kerberosTicket, + gtqRefreshToken = refreshToken, + gtqScope = scope + } + +-- | A realm reference — the shape of the @authentication_realm@ and +-- @lookup_realm@ sub-objects inside 'TokenAuthentication'. +data SsoRealmInfo = SsoRealmInfo + { sriName :: Maybe Text, + sriType :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SsoRealmInfo where + parseJSON = withObject "SsoRealmInfo" $ \o -> do + name <- o .:? "name" + typ <- o .:? "type" + pure SsoRealmInfo {sriName = name, sriType = typ} + +instance ToJSON SsoRealmInfo where + toJSON SsoRealmInfo {..} = + omitNulls $ + catMaybes + [ ("name" .=) <$> sriName, + ("type" .=) <$> sriType + ] + +-- | The nested @authentication@ object in a 'GetTokenResponse' — a +-- description of the user the access token represents, annotated with +-- the realms that authenticated and looked up the user. ES emits +-- @null@ (not omitted) for an unset @full_name@ \/ @email@. +data TokenAuthentication = TokenAuthentication + { taUsername :: Maybe Text, + taRoles :: Maybe [Text], + taFullName :: Maybe Text, + taEmail :: Maybe Text, + taMetadata :: Maybe (KeyMap Value), + taEnabled :: Maybe Bool, + taAuthenticationRealm :: Maybe SsoRealmInfo, + taLookupRealm :: Maybe SsoRealmInfo, + taAuthenticationType :: Maybe Text, + -- | Catch-all for future sibling fields so decode is + -- forward-compatible and @encode . decode@ round-trips. + taExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +tokenAuthenticationKnownKeys :: [Text] +tokenAuthenticationKnownKeys = + [ "username", + "roles", + "full_name", + "email", + "metadata", + "enabled", + "authentication_realm", + "lookup_realm", + "authentication_type" + ] + +instance FromJSON TokenAuthentication where + parseJSON = withObject "TokenAuthentication" $ \o -> do + username <- o .:? "username" + roles <- o .:? "roles" + fullName <- o .:? "full_name" + email <- o .:? "email" + metadata <- o .:? "metadata" + enabled <- o .:? "enabled" + authRealm <- o .:? "authentication_realm" + lookupRealm <- o .:? "lookup_realm" + authType <- o .:? "authentication_type" + let extras = + KM.fromList $ + filter ((`notElem` tokenAuthenticationKnownKeys) . toText . fst) $ + KM.toList o + pure + TokenAuthentication + { taUsername = username, + taRoles = roles, + taFullName = fullName, + taEmail = email, + taMetadata = metadata, + taEnabled = enabled, + taAuthenticationRealm = authRealm, + taLookupRealm = lookupRealm, + taAuthenticationType = authType, + taExtras = extras + } + +instance ToJSON TokenAuthentication where + toJSON TokenAuthentication {..} = + omitNulls $ + catMaybes + [ ("username" .=) <$> taUsername, + ("roles" .=) <$> taRoles, + ("full_name" .=) <$> taFullName, + ("email" .=) <$> taEmail, + ("metadata" .=) <$> taMetadata, + ("enabled" .=) <$> taEnabled, + ("authentication_realm" .=) <$> taAuthenticationRealm, + ("lookup_realm" .=) <$> taLookupRealm, + ("authentication_type" .=) <$> taAuthenticationType + ] + <> [toPair kv | kv <- KM.toList taExtras] + where + toPair (k, v) = k .= v + +-- | Response of @POST /_security/oauth2/token@. The @refresh_token@ is +-- absent for @client_credentials@; the +-- @kerberos_authentication_response_token@ is present only for +-- @_kerberos@ with mutual authentication. The @authentication@ detail +-- block is the only place the realm metadata appears. +data GetTokenResponse = GetTokenResponse + { gtrAccessToken :: SsoToken, + -- | @type@ — always @Bearer@. + gtrType :: Maybe Text, + gtrExpiresIn :: Int, + gtrRefreshToken :: Maybe SsoRefreshToken, + gtrKerberosAuthenticationResponseToken :: Maybe SecretText, + gtrAuthentication :: Maybe TokenAuthentication + } + deriving stock (Eq, Show) + +instance FromJSON GetTokenResponse where + parseJSON = withObject "GetTokenResponse" $ \o -> do + accessToken <- o .: "access_token" + typ <- o .:? "type" + expiresIn <- o .: "expires_in" + refreshToken <- o .:? "refresh_token" + kerberosResponseToken <- o .:? "kerberos_authentication_response_token" + authentication <- o .:? "authentication" + pure + GetTokenResponse + { gtrAccessToken = accessToken, + gtrType = typ, + gtrExpiresIn = expiresIn, + gtrRefreshToken = refreshToken, + gtrKerberosAuthenticationResponseToken = kerberosResponseToken, + gtrAuthentication = authentication + } + +instance ToJSON GetTokenResponse where + toJSON GetTokenResponse {..} = + omitNulls $ + catMaybes + [ Just ("access_token" .= gtrAccessToken), + ("type" .=) <$> gtrType, + Just ("expires_in" .= gtrExpiresIn), + ("refresh_token" .=) <$> gtrRefreshToken, + ("kerberos_authentication_response_token" .=) + <$> gtrKerberosAuthenticationResponseToken, + ("authentication" .=) <$> gtrAuthentication + ] + +------------------------------------------------------------------------------ +-- OAuth2 token — invalidate (DELETE /_security/oauth2/token) +------------------------------------------------------------------------------ + +-- | Request body for @DELETE /_security/oauth2/token@. Either +-- 'ittToken' \/ 'ittRefreshToken' (single-token invalidation) OR +-- 'ittRealmName' \/ 'ittUsername' (bulk per-realm\/user) — ES rejects +-- mixing the two groups. The credential-bearing 'ittToken' is wrapped +-- in 'SecretText' so 'show' never leaks it. +data InvalidateTokenRequest = InvalidateTokenRequest + { ittToken :: Maybe SecretText, + ittRefreshToken :: Maybe SsoRefreshToken, + ittRealmName :: Maybe Text, + ittUsername :: Maybe Text + } + deriving stock (Eq, Show) + +-- | Empty filter — the caller must set at least one selector (ES +-- rejects an empty body). +defaultInvalidateTokenRequest :: InvalidateTokenRequest +defaultInvalidateTokenRequest = + InvalidateTokenRequest + { ittToken = Nothing, + ittRefreshToken = Nothing, + ittRealmName = Nothing, + ittUsername = Nothing + } + +instance ToJSON InvalidateTokenRequest where + toJSON InvalidateTokenRequest {..} = + omitNulls $ + catMaybes + [ ("token" .=) <$> ittToken, + ("refresh_token" .=) <$> ittRefreshToken, + ("realm_name" .=) <$> ittRealmName, + ("username" .=) <$> ittUsername + ] + +instance FromJSON InvalidateTokenRequest where + parseJSON = withObject "InvalidateTokenRequest" $ \o -> do + token <- o .:? "token" + refreshToken <- o .:? "refresh_token" + realmName <- o .:? "realm_name" + username <- o .:? "username" + pure + InvalidateTokenRequest + { ittToken = token, + ittRefreshToken = refreshToken, + ittRealmName = realmName, + ittUsername = username + } + +-- | One error detail from an invalidate call that partially failed. +-- @caused_by@ nests recursively (the same shape), mirroring the ES +-- exception chain. +data InvalidateTokenError = InvalidateTokenError + { iteType :: Maybe Text, + iteReason :: Maybe Text, + iteCausedBy :: Maybe InvalidateTokenError + } + deriving stock (Eq, Show) + +instance FromJSON InvalidateTokenError where + parseJSON = withObject "InvalidateTokenError" $ \o -> do + typ <- o .:? "type" + reason <- o .:? "reason" + causedBy <- o .:? "caused_by" + pure + InvalidateTokenError + { iteType = typ, + iteReason = reason, + iteCausedBy = causedBy + } + +instance ToJSON InvalidateTokenError where + toJSON InvalidateTokenError {..} = + omitNulls $ + catMaybes + [ ("type" .=) <$> iteType, + ("reason" .=) <$> iteReason, + ("caused_by" .=) <$> iteCausedBy + ] + +-- | Response of @DELETE /_security/oauth2/token@. +data InvalidateTokenResponse = InvalidateTokenResponse + { itrInvalidatedTokens :: Int, + itrPreviouslyInvalidatedTokens :: Int, + itrErrorCount :: Maybe Int, + itrErrorDetails :: [InvalidateTokenError] + } + deriving stock (Eq, Show) + +instance FromJSON InvalidateTokenResponse where + parseJSON = withObject "InvalidateTokenResponse" $ \o -> do + invalidated <- fromMaybe 0 <$> o .:? "invalidated_tokens" + previouslyInvalidated <- fromMaybe 0 <$> o .:? "previously_invalidated_tokens" + errorCount <- o .:? "error_count" + errorDetails <- fromMaybe [] <$> o .:? "error_details" + pure + InvalidateTokenResponse + { itrInvalidatedTokens = invalidated, + itrPreviouslyInvalidatedTokens = previouslyInvalidated, + itrErrorCount = errorCount, + itrErrorDetails = errorDetails + } + +instance ToJSON InvalidateTokenResponse where + toJSON InvalidateTokenResponse {..} = + omitNulls $ + catMaybes + [ Just ("invalidated_tokens" .= itrInvalidatedTokens), + Just ("previously_invalidated_tokens" .= itrPreviouslyInvalidatedTokens), + ("error_count" .=) <$> itrErrorCount, + if null itrErrorDetails + then Nothing + else Just ("error_details" .= itrErrorDetails) + ] + +------------------------------------------------------------------------------ +-- Shared authenticate / logout responses +------------------------------------------------------------------------------ + +-- | The access\/refresh token pair returned by the SAML and OIDC +-- @authenticate@ endpoints. SAML additionally populates @username@ and +-- @realm@; OIDC populates @type@ (@Bearer@). Every field except +-- @access_token@ and @expires_in@ is optional because each flow emits a +-- different subset. +data SsoTokenResponse = SsoTokenResponse + { strAccessToken :: SsoToken, + strExpiresIn :: Int, + strRefreshToken :: Maybe SsoRefreshToken, + strUsername :: Maybe Text, + strRealm :: Maybe Text, + -- | @type@ — always @Bearer@ when present (OIDC). + strType :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SsoTokenResponse where + parseJSON = withObject "SsoTokenResponse" $ \o -> do + accessToken <- o .: "access_token" + expiresIn <- o .: "expires_in" + refreshToken <- o .:? "refresh_token" + username <- o .:? "username" + realm <- o .:? "realm" + typ <- o .:? "type" + pure + SsoTokenResponse + { strAccessToken = accessToken, + strExpiresIn = expiresIn, + strRefreshToken = refreshToken, + strUsername = username, + strRealm = realm, + strType = typ + } + +instance ToJSON SsoTokenResponse where + toJSON SsoTokenResponse {..} = + omitNulls $ + catMaybes + [ Just ("access_token" .= strAccessToken), + Just ("expires_in" .= strExpiresIn), + ("refresh_token" .=) <$> strRefreshToken, + ("username" .=) <$> strUsername, + ("realm" .=) <$> strRealm, + ("type" .=) <$> strType + ] + +-- | The optional redirect URL returned by the SAML and OIDC @logout@ +-- endpoints — when the realm is configured for single logout, ES hands +-- back an IdP URL to redirect the browser to. +newtype SsoRedirectResponse = SsoRedirectResponse + { srdRedirect :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SsoRedirectResponse where + parseJSON = withObject "SsoRedirectResponse" $ \o -> do + redirect <- o .:? "redirect" + pure SsoRedirectResponse {srdRedirect = redirect} + +instance ToJSON SsoRedirectResponse where + toJSON SsoRedirectResponse {..} = + omitNulls $ + catMaybes + [ ("redirect" .=) <$> srdRedirect + ] + +------------------------------------------------------------------------------ +-- SAML (/_security/saml/*) +------------------------------------------------------------------------------ + +-- | Request body for @POST /_security/saml/prepare@. Exactly one of +-- 'sprAcs' (an Assertion Consumer Service URL) or 'sprRealm' (a realm +-- name) is required. +data SamlPrepareRequest = SamlPrepareRequest + { sprAcs :: Maybe Text, + sprRealm :: Maybe Text, + sprRelayState :: Maybe Text + } + deriving stock (Eq, Show) + +-- | Empty — the caller must set 'sprAcs' or 'sprRealm'. +defaultSamlPrepareRequest :: SamlPrepareRequest +defaultSamlPrepareRequest = + SamlPrepareRequest + { sprAcs = Nothing, + sprRealm = Nothing, + sprRelayState = Nothing + } + +instance ToJSON SamlPrepareRequest where + toJSON SamlPrepareRequest {..} = + omitNulls $ + catMaybes + [ ("acs" .=) <$> sprAcs, + ("realm" .=) <$> sprRealm, + ("relay_state" .=) <$> sprRelayState + ] + +instance FromJSON SamlPrepareRequest where + parseJSON = withObject "SamlPrepareRequest" $ \o -> do + acs <- o .:? "acs" + realm <- o .:? "realm" + relayState <- o .:? "relay_state" + pure + SamlPrepareRequest + { sprAcs = acs, + sprRealm = realm, + sprRelayState = relayState + } + +-- | Response of @POST /_security/saml/prepare@. The @id@ must be +-- stored and echoed back as one of 'sarIds' at authenticate time. +data SamlPrepareResponse = SamlPrepareResponse + { sppId :: Text, + sppRealm :: Text, + sppRedirect :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SamlPrepareResponse where + parseJSON = withObject "SamlPrepareResponse" $ \o -> do + i <- o .: "id" + realm <- o .: "realm" + redirect <- o .: "redirect" + pure + SamlPrepareResponse + { sppId = i, + sppRealm = realm, + sppRedirect = redirect + } + +instance ToJSON SamlPrepareResponse where + toJSON SamlPrepareResponse {..} = + object + [ "id" .= sppId, + "realm" .= sppRealm, + "redirect" .= sppRedirect + ] + +-- | Request body for @POST /_security/saml/authenticate@. The +-- @content@ field is the base64-encoded SAML @@ from the +-- IdP — a bearer assertion that authenticates the caller — and is +-- wrapped in 'SecretText' so 'show' never leaks it. +data SamlAuthenticateRequest = SamlAuthenticateRequest + { -- | @content@ — the base64-encoded SAML @@ from the IdP. + sarContent :: SecretText, + -- | @ids@ — every outstanding SAML request id for this user + -- (including the one from 'sppId'). + sarIds :: [Text], + sarRealm :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON SamlAuthenticateRequest where + toJSON SamlAuthenticateRequest {..} = + omitNulls $ + catMaybes + [ Just ("content" .= sarContent), + if null sarIds then Nothing else Just ("ids" .= sarIds), + ("realm" .=) <$> sarRealm + ] + +instance FromJSON SamlAuthenticateRequest where + parseJSON = withObject "SamlAuthenticateRequest" $ \o -> do + content <- o .: "content" + ids <- fromMaybe [] <$> o .:? "ids" + realm <- o .:? "realm" + pure + SamlAuthenticateRequest + { sarContent = content, + sarIds = ids, + sarRealm = realm + } + +-- | Request body for @POST /_security/saml/logout@. +data SamlLogoutRequest = SamlLogoutRequest + { -- | @token@ — the access token to invalidate. + slrToken :: SsoToken, + slrRefreshToken :: Maybe SsoRefreshToken + } + deriving stock (Eq, Show) + +instance ToJSON SamlLogoutRequest where + toJSON SamlLogoutRequest {..} = + omitNulls $ + catMaybes + [ Just ("token" .= slrToken), + ("refresh_token" .=) <$> slrRefreshToken + ] + +instance FromJSON SamlLogoutRequest where + parseJSON = withObject "SamlLogoutRequest" $ \o -> do + token <- o .: "token" + refreshToken <- o .:? "refresh_token" + pure + SamlLogoutRequest + { slrToken = token, + slrRefreshToken = refreshToken + } + +------------------------------------------------------------------------------ +-- OpenID Connect (/_security/oidc/*) +------------------------------------------------------------------------------ + +-- | Request body for @POST /_security/oidc/prepare@. Exactly one of +-- 'oprRealm' or 'oprIss' (a 3rd-party-SSO issuer) is required; +-- 'oprLoginHint' is valid only with 'oprIss'. 'oprState' and +-- 'oprNonce' are generated server-side when omitted (and returned in +-- the response to echo back at authenticate time). +data OidcPrepareRequest = OidcPrepareRequest + { oprRealm :: Maybe Text, + oprState :: Maybe Text, + oprNonce :: Maybe Text, + oprIss :: Maybe Text, + oprLoginHint :: Maybe Text + } + deriving stock (Eq, Show) + +-- | Empty — the caller must set 'oprRealm' or 'oprIss'. +defaultOidcPrepareRequest :: OidcPrepareRequest +defaultOidcPrepareRequest = + OidcPrepareRequest + { oprRealm = Nothing, + oprState = Nothing, + oprNonce = Nothing, + oprIss = Nothing, + oprLoginHint = Nothing + } + +instance ToJSON OidcPrepareRequest where + toJSON OidcPrepareRequest {..} = + omitNulls $ + catMaybes + [ ("realm" .=) <$> oprRealm, + ("state" .=) <$> oprState, + ("nonce" .=) <$> oprNonce, + ("iss" .=) <$> oprIss, + ("login_hint" .=) <$> oprLoginHint + ] + +instance FromJSON OidcPrepareRequest where + parseJSON = withObject "OidcPrepareRequest" $ \o -> do + realm <- o .:? "realm" + state <- o .:? "state" + nonce <- o .:? "nonce" + iss <- o .:? "iss" + loginHint <- o .:? "login_hint" + pure + OidcPrepareRequest + { oprRealm = realm, + oprState = state, + oprNonce = nonce, + oprIss = iss, + oprLoginHint = loginHint + } + +-- | Response of @POST /_security/oidc/prepare@. The @state@ and +-- @nonce@ must be echoed back at authenticate time (whether caller- or +-- server-supplied). +data OidcPrepareResponse = OidcPrepareResponse + { oppRedirect :: Text, + oppState :: Text, + oppNonce :: Text, + oppRealm :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON OidcPrepareResponse where + parseJSON = withObject "OidcPrepareResponse" $ \o -> do + redirect <- o .: "redirect" + state <- o .: "state" + nonce <- o .: "nonce" + realm <- o .:? "realm" + pure + OidcPrepareResponse + { oppRedirect = redirect, + oppState = state, + oppNonce = nonce, + oppRealm = realm + } + +instance ToJSON OidcPrepareResponse where + toJSON OidcPrepareResponse {..} = + omitNulls $ + catMaybes + [ Just ("redirect" .= oppRedirect), + Just ("state" .= oppState), + Just ("nonce" .= oppNonce), + ("realm" .=) <$> oppRealm + ] + +-- | Request body for @POST /_security/oidc/authenticate@. +data OidcAuthenticateRequest = OidcAuthenticateRequest + { oarRedirectUri :: Text, + oarState :: Text, + oarNonce :: Text, + oarRealm :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON OidcAuthenticateRequest where + toJSON OidcAuthenticateRequest {..} = + omitNulls $ + catMaybes + [ Just ("redirect_uri" .= oarRedirectUri), + Just ("state" .= oarState), + Just ("nonce" .= oarNonce), + ("realm" .=) <$> oarRealm + ] + +instance FromJSON OidcAuthenticateRequest where + parseJSON = withObject "OidcAuthenticateRequest" $ \o -> do + redirectUri <- o .: "redirect_uri" + state <- o .: "state" + nonce <- o .: "nonce" + realm <- o .:? "realm" + pure + OidcAuthenticateRequest + { oarRedirectUri = redirectUri, + oarState = state, + oarNonce = nonce, + oarRealm = realm + } + +-- | Request body for @POST /_security/oidc/logout@. The access-token +-- field is sent as @token@ on the wire (the documented example +-- spelling; the ES 7.17 reference table names it @access_token@ but the +-- server accepts @token@). +data OidcLogoutRequest = OidcLogoutRequest + { olrToken :: SsoToken, + olrRefreshToken :: Maybe SsoRefreshToken + } + deriving stock (Eq, Show) + +instance ToJSON OidcLogoutRequest where + toJSON OidcLogoutRequest {..} = + omitNulls $ + catMaybes + [ Just ("token" .= olrToken), + ("refresh_token" .=) <$> olrRefreshToken + ] + +instance FromJSON OidcLogoutRequest where + parseJSON = withObject "OidcLogoutRequest" $ \o -> do + token <- + o .:? "token" >>= \case + Just t -> pure t + Nothing -> o .: "access_token" + refreshToken <- o .:? "refresh_token" + pure + OidcLogoutRequest + { olrToken = token, + olrRefreshToken = refreshToken + } + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +tokenAuthenticationExtrasLens :: Lens' TokenAuthentication (KeyMap Value) +tokenAuthenticationExtrasLens = + lens taExtras (\x y -> x {taExtras = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Users.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Users.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Security/Users.hs @@ -0,0 +1,789 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Security.Users +-- Description : Types for the ES X-Pack Security user API (/_security/user/*) +-- +-- Request and response shapes for the user-management endpoints under +-- @\/_security\/user*@: +-- +-- * @PUT /_security/user/{username}@ — 'UserCreateBody' body, +-- 'UserCreatedResponse' on success (@{"created":true}@ — @created@ +-- is @false@ on overwrite). The same endpoint creates and updates. +-- * @GET /_security/user[/{username}]@ — 'UsersListResponse' (an ES +-- object keyed by username, decoded to a list of +-- @('UserName', 'User')@ pairs). +-- * @DELETE /_security/user/{username}@ — 'UserDeletedResponse' +-- (@{"found":true,"acknowledged":true}@). +-- * @PUT /_security/user/{username}/_enable@ — 'Acknowledged'. +-- * @PUT /_security/user/{username}/_disable@ — 'Acknowledged'. +-- * @POST /_security/user/{username}/_password@ — 'ChangePasswordBody' +-- body, 'Acknowledged' on success. +-- * @POST /_security/user[/{username}]/_has_privileges@ — +-- 'HasPrivilegesRequest' body, 'HasPrivilegesResponse' (a nested +-- boolean tree reporting each requested privilege). +-- * @GET /_security/user/_privileges@ — 'UserPrivileges' (the current +-- user's effective privileges). +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Security.Users + ( -- * Identity + UserName (..), + + -- * User (GET response) + User (..), + userRolesLens, + userFullNameLens, + userEmailLens, + userEnabledLens, + userMetadataLens, + userExtrasLens, + + -- * Create/update body + UserCreateBody (..), + defaultUserCreateBody, + userCreateBodyPasswordLens, + userCreateBodyRolesLens, + userCreateBodyFullNameLens, + userCreateBodyEmailLens, + userCreateBodyEnabledLens, + userCreateBodyMetadataLens, + + -- * PUT / DELETE responses + UserCreatedResponse (..), + UserDeletedResponse (..), + + -- * List response + UsersListResponse (..), + + -- * Change password + ChangePasswordBody (..), + + -- * Has privileges + HasPrivilegesRequest (..), + defaultHasPrivilegesRequest, + hasPrivilegesRequestClusterLens, + hasPrivilegesRequestIndexLens, + hasPrivilegesRequestApplicationLens, + HasPrivilegesResponse (..), + HasPrivilegesIndexResult (..), + HasPrivilegesApplicationResult (..), + + -- * Effective privileges (GET /_security/user/_privileges) + UserPrivileges (..), + UserIndexPrivileges (..), + UserApplicationPrivileges (..), + ) +where + +import Data.Aeson +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', Pair, Parser, lens, omitNulls) +import Database.Bloodhound.Internal.Utils.Secret (SecretText (..)) +import Database.Bloodhound.Internal.Versions.Common.Types.Indices + ( IndexPattern (..), + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Privileges + ( ApplicationName (..), + ApplicationPrivilegeName (..), + ClusterPrivilege (..), + IndexPrivilegeName (..), + ResourceName (..), + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Security.Roles + ( RoleName (..), + ) + +------------------------------------------------------------------------------ +-- Identity +------------------------------------------------------------------------------ + +-- | A username — the @\/_security\/user\/{username}@ path segment and +-- the JSON object key in the list response. +newtype UserName = UserName {unUserName :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +------------------------------------------------------------------------------ +-- User (GET response) +------------------------------------------------------------------------------ + +-- | A user record — the value associated with each username in the GET +-- response. ES emits @null@ for an unset @full_name@ \/ @email@ rather +-- than omitting them, so those stay 'Maybe' on decode and encode. +data User = User + { uUsername :: UserName, + uRoles :: [RoleName], + uFullName :: Maybe Text, + uEmail :: Maybe Text, + uEnabled :: Bool, + uMetadata :: KeyMap Value, + uExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +userKnownKeys :: [Text] +userKnownKeys = ["username", "roles", "full_name", "email", "enabled", "metadata"] + +instance FromJSON User where + parseJSON = withObject "User" $ \o -> do + username <- o .: "username" + roles <- fromMaybe [] <$> o .:? "roles" + fullName <- o .:? "full_name" + email <- o .:? "email" + enabled <- fromMaybe True <$> o .:? "enabled" + metadata <- fromMaybe KM.empty <$> o .:? "metadata" + let extras = + KM.fromList $ + filter ((`notElem` userKnownKeys) . toText . fst) $ + KM.toList o + pure + User + { uUsername = username, + uRoles = roles, + uFullName = fullName, + uEmail = email, + uEnabled = enabled, + uMetadata = metadata, + uExtras = extras + } + +instance ToJSON User where + toJSON User {..} = + omitNulls $ + catMaybes + [ Just ("username" .= uUsername), + Just ("roles" .= uRoles), + Just ("full_name" .= uFullName), + Just ("email" .= uEmail), + Just ("enabled" .= uEnabled), + Just ("metadata" .= uMetadata) + ] + <> [toPair kv | kv <- KM.toList uExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- Create/update body +------------------------------------------------------------------------------ + +-- | The PUT body for @\/_security\/user\/{username}@. The same endpoint +-- handles create and update, so every field is 'Maybe' except @roles@ +-- (which ES replaces wholesale when present). 'ucbPassword' is required +-- on create but absent on a pure-update. It is wrapped in 'SecretText' +-- so 'show' never leaks it. +data UserCreateBody = UserCreateBody + { ucbPassword :: Maybe SecretText, + ucbRoles :: [RoleName], + ucbFullName :: Maybe Text, + ucbEmail :: Maybe Text, + ucbEnabled :: Maybe Bool, + ucbMetadata :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | Empty body — @enabled@ left to the server default (@true@ on +-- create, unchanged on update), no password, no roles. +defaultUserCreateBody :: UserCreateBody +defaultUserCreateBody = + UserCreateBody + { ucbPassword = Nothing, + ucbRoles = [], + ucbFullName = Nothing, + ucbEmail = Nothing, + ucbEnabled = Nothing, + ucbMetadata = KM.empty + } + +instance ToJSON UserCreateBody where + toJSON UserCreateBody {..} = + omitNulls $ + catMaybes + [ ("password" .=) <$> ucbPassword, + Just ("roles" .= ucbRoles), + ("full_name" .=) <$> ucbFullName, + ("email" .=) <$> ucbEmail, + ("enabled" .=) <$> ucbEnabled, + Just ("metadata" .= ucbMetadata) + ] + +instance FromJSON UserCreateBody where + parseJSON = withObject "UserCreateBody" $ \o -> do + password <- o .:? "password" + roles <- fromMaybe [] <$> o .:? "roles" + fullName <- o .:? "full_name" + email <- o .:? "email" + enabled <- o .:? "enabled" + metadata <- fromMaybe KM.empty <$> o .:? "metadata" + pure + UserCreateBody + { ucbPassword = password, + ucbRoles = roles, + ucbFullName = fullName, + ucbEmail = email, + ucbEnabled = enabled, + ucbMetadata = metadata + } + +------------------------------------------------------------------------------ +-- PUT / DELETE responses +------------------------------------------------------------------------------ + +-- | Response of @PUT /_security/user/{username}@: +-- @{"created":true}@ (false when the user was updated rather than +-- created). +newtype UserCreatedResponse = UserCreatedResponse + { ucCreated :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON UserCreatedResponse where + parseJSON = withObject "UserCreatedResponse" $ \o -> + -- Explicit 'UserCreatedResponse <$>' breaks the otherwise-recursive + -- inference of @o .: "created"@ back into this instance. + UserCreatedResponse <$> o .: "created" + +instance ToJSON UserCreatedResponse where + toJSON UserCreatedResponse {..} = object ["created" .= ucCreated] + +-- | Response of @DELETE /_security/user/{username}@: +-- @{"found":true,"acknowledged":true}@. @found@ is @false@ (or absent +-- on older ES) when the user did not exist. +data UserDeletedResponse = UserDeletedResponse + { udFound :: Maybe Bool, + udAcknowledged :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON UserDeletedResponse where + parseJSON = withObject "UserDeletedResponse" $ \o -> do + found <- o .:? "found" + ack <- o .: "acknowledged" + pure UserDeletedResponse {udFound = found, udAcknowledged = ack} + +instance ToJSON UserDeletedResponse where + toJSON UserDeletedResponse {..} = + omitNulls $ + catMaybes + [ ("found" .=) <$> udFound, + Just ("acknowledged" .= udAcknowledged) + ] + +------------------------------------------------------------------------------ +-- List response +------------------------------------------------------------------------------ + +-- | Response of @GET /_security/user[/{username}]@: an ES object keyed +-- by username, each value a 'User'. +newtype UsersListResponse = UsersListResponse + { usersListEntries :: [(UserName, User)] + } + deriving stock (Eq, Show) + +instance FromJSON UsersListResponse where + parseJSON = withObject "UsersListResponse" $ \o -> do + entries <- traverse parseEntry (KM.toList o) + pure (UsersListResponse entries) + where + parseEntry (k, v) = do + u <- parseJSON v + pure (UserName (toText k), u) + +instance ToJSON UsersListResponse where + toJSON (UsersListResponse entries) = + Object (KM.fromList [(fromText (unUserName n), toJSON u) | (n, u) <- entries]) + +------------------------------------------------------------------------------ +-- Change password +------------------------------------------------------------------------------ + +-- | Body of @POST /_security/user/{username}/_password@: +-- @{"password":"..."}@. The password is wrapped in 'SecretText' so +-- 'show' never leaks it. +newtype ChangePasswordBody = ChangePasswordBody + { cpbPassword :: SecretText + } + deriving stock (Eq, Show) + +instance ToJSON ChangePasswordBody where + toJSON (ChangePasswordBody pw) = object ["password" .= pw] + +instance FromJSON ChangePasswordBody where + parseJSON = withObject "ChangePasswordBody" $ \o -> + ChangePasswordBody <$> o .: "password" + +------------------------------------------------------------------------------ +-- Has privileges +------------------------------------------------------------------------------ + +-- | Request body for @POST /_security/user[/{username}]/_has_privileges@. +-- The wire shape nests privileges under per-pattern and per-resource +-- objects; the encoder builds that nesting from the flat Haskell lists. +data HasPrivilegesRequest = HasPrivilegesRequest + { -- | @cluster@ — cluster privileges to check. + hprCluster :: [ClusterPrivilege], + -- | @index@ — @(pattern, privileges)@ pairs; encoded as + -- @{pattern: {privileges: [...]}}@. + hprIndex :: [(IndexPattern, [IndexPrivilegeName])], + -- | @application@ — @(application, per-resource)@ pairs; encoded as + -- @{app: {resource: {privileges: [...]}}}@. + hprApplication :: [(ApplicationName, [(ResourceName, [ApplicationPrivilegeName])])] + } + deriving stock (Eq, Show) + +-- | An empty request — checks nothing, @has_all_requested@ will be +-- @true@. +defaultHasPrivilegesRequest :: HasPrivilegesRequest +defaultHasPrivilegesRequest = + HasPrivilegesRequest + { hprCluster = [], + hprIndex = [], + hprApplication = [] + } + +instance ToJSON HasPrivilegesRequest where + toJSON HasPrivilegesRequest {..} = + omitNulls $ + catMaybes + [ if null hprCluster then Nothing else Just ("cluster" .= hprCluster), + if null hprIndex then Nothing else Just ("index" .= object indexPairs), + if null hprApplication then Nothing else Just ("application" .= object appPairs) + ] + where + -- One object key per index pattern: + -- @{pattern: {privileges: [...]}}@. The generator is at the + -- outer level, producing one 'Pair' per pattern. + indexPairs :: [Pair] + indexPairs = + [ fromText (unIndexPattern p) .= object ["privileges" .= ps] + | (p, ps) <- hprIndex + ] + -- One object key per application, nesting one object per resource: + -- @{app: {resource: {privileges: [...]}}}@. + appPairs :: [Pair] + appPairs = + [ fromText (unApplicationName a) + .= object + [ fromText (unResourceName r) .= object ["privileges" .= ps] + | (r, ps) <- rss + ] + | (a, rss) <- hprApplication + ] + +instance FromJSON HasPrivilegesRequest where + parseJSON = withObject "HasPrivilegesRequest" $ \o -> do + cluster <- fromMaybe [] <$> o .:? "cluster" + index <- parseIndexSection =<< o .:? "index" + application <- parseApplicationSection =<< o .:? "application" + pure + HasPrivilegesRequest + { hprCluster = cluster, + hprIndex = index, + hprApplication = application + } + where + parseIndexSection :: Maybe Value -> Parser [(IndexPattern, [IndexPrivilegeName])] + parseIndexSection Nothing = pure [] + parseIndexSection (Just v) = + withObject + "HasPrivilegesRequest.index" + ( \o' -> + fmap concat $ + traverse parseIndexEntry (KM.toList o') + ) + v + + parseIndexEntry :: (Key, Value) -> Parser [(IndexPattern, [IndexPrivilegeName])] + parseIndexEntry (k, v) = do + privs <- + withObject + "has-privileges index entry" + (\o' -> fromMaybe [] <$> o' .:? "privileges") + v + pure [(IndexPattern (toText k), privs)] + + parseApplicationSection :: + Maybe Value -> + Parser [(ApplicationName, [(ResourceName, [ApplicationPrivilegeName])])] + parseApplicationSection Nothing = pure [] + parseApplicationSection (Just v) = + withObject + "HasPrivilegesRequest.application" + ( \o' -> + traverse parseAppEntry (KM.toList o') + ) + v + + parseAppEntry :: + (Key, Value) -> + Parser (ApplicationName, [(ResourceName, [ApplicationPrivilegeName])]) + parseAppEntry (k, v) = do + resources <- + withObject + "has-privileges application entry" + ( \o' -> + traverse parseResourceEntry (KM.toList o') + ) + v + pure (ApplicationName (toText k), resources) + + parseResourceEntry :: + (Key, Value) -> + Parser (ResourceName, [ApplicationPrivilegeName]) + parseResourceEntry (k, v) = do + privs <- + withObject + "has-privileges resource entry" + (\o' -> fromMaybe [] <$> o' .:? "privileges") + v + pure (ResourceName (toText k), privs) + +-- | The index privileges result for a single pattern: a per-privilege +-- boolean map. +newtype HasPrivilegesIndexResult = HasPrivilegesIndexResult + { hpirPrivileges :: [(IndexPrivilegeName, Bool)] + } + deriving stock (Eq, Show) + +instance FromJSON HasPrivilegesIndexResult where + parseJSON = withObject "HasPrivilegesIndexResult" $ \o -> + pure $ + HasPrivilegesIndexResult + [ (IndexPrivilegeName (toText k), b) + | (k, v) <- KM.toList o, + Just b <- [parseBool v] + ] + +instance ToJSON HasPrivilegesIndexResult where + toJSON (HasPrivilegesIndexResult ps) = + Object $ + KM.fromList + [ fromText (unIndexPrivilegeName p) .= Bool b + | (p, b) <- ps + ] + +-- | The application privileges result for a single application: a +-- per-resource, per-privilege boolean tree. +newtype HasPrivilegesApplicationResult = HasPrivilegesApplicationResult + { hparResources :: [(ResourceName, [(ApplicationPrivilegeName, Bool)])] + } + deriving stock (Eq, Show) + +instance FromJSON HasPrivilegesApplicationResult where + parseJSON = withObject "HasPrivilegesApplicationResult" $ \o -> do + rs <- traverse parseResource (KM.toList o) + pure (HasPrivilegesApplicationResult rs) + where + parseResource (k, v) = do + privs <- + withObject + "has-privileges application resource" + ( \o' -> + pure + [ (ApplicationPrivilegeName (toText k'), b) + | (k', v') <- KM.toList o', + Just b <- [parseBool v'] + ] + ) + v + pure (ResourceName (toText k), privs) + +instance ToJSON HasPrivilegesApplicationResult where + toJSON (HasPrivilegesApplicationResult rs) = + Object $ + KM.fromList + [ fromText (unResourceName r) .= object privPairs + | (r, ps) <- rs, + let privPairs = + [ fromText (unApplicationPrivilegeName p) .= Bool b + | (p, b) <- ps + ] + ] + +-- | Response of @POST /_security/user[/{username}]/_has_privileges@: +-- the requesting username, an overall @has_all_requested@ flag, and a +-- per-privilege boolean tree mirroring the 'HasPrivilegesRequest' +-- shape. +data HasPrivilegesResponse = HasPrivilegesResponse + { hpUsername :: UserName, + hpHasAllRequested :: Bool, + hpCluster :: [(ClusterPrivilege, Bool)], + hpIndex :: [(IndexPattern, [(IndexPrivilegeName, Bool)])], + hpApplication :: [(ApplicationName, [(ResourceName, [(ApplicationPrivilegeName, Bool)])])] + } + deriving stock (Eq, Show) + +instance FromJSON HasPrivilegesResponse where + parseJSON = withObject "HasPrivilegesResponse" $ \o -> do + username <- o .: "username" + hasAll <- o .: "has_all_requested" + cluster <- parseClusterBools =<< o .:? "cluster" + index <- parseIndexResults =<< o .:? "index" + application <- parseApplicationResults =<< o .:? "application" + pure + HasPrivilegesResponse + { hpUsername = username, + hpHasAllRequested = hasAll, + hpCluster = cluster, + hpIndex = index, + hpApplication = application + } + where + parseClusterBools :: Maybe Value -> Parser [(ClusterPrivilege, Bool)] + parseClusterBools Nothing = pure [] + parseClusterBools (Just v) = + withObject + "HasPrivilegesResponse.cluster" + (\o' -> pure [(ClusterPrivilege (toText k), b) | (k, v') <- KM.toList o', Just b <- [parseBool v']]) + v + + parseIndexResults :: + Maybe Value -> + Parser [(IndexPattern, [(IndexPrivilegeName, Bool)])] + parseIndexResults Nothing = pure [] + parseIndexResults (Just v) = + withObject + "HasPrivilegesResponse.index" + ( \o' -> + traverse + (\(k, v') -> (IndexPattern (toText k),) . hpirPrivileges <$> parseJSON v') + (KM.toList o') + ) + v + + parseApplicationResults :: + Maybe Value -> + Parser [(ApplicationName, [(ResourceName, [(ApplicationPrivilegeName, Bool)])])] + parseApplicationResults Nothing = pure [] + parseApplicationResults (Just v) = + withObject + "HasPrivilegesResponse.application" + ( \o' -> + traverse + (\(k, v') -> (ApplicationName (toText k),) . hparResources <$> parseJSON v') + (KM.toList o') + ) + v + +instance ToJSON HasPrivilegesResponse where + toJSON HasPrivilegesResponse {..} = + omitNulls $ + catMaybes + [ Just ("username" .= hpUsername), + Just ("has_all_requested" .= hpHasAllRequested), + if null hpCluster + then Nothing + else + Just + ( "cluster" + .= object + [fromText (unClusterPrivilege p) .= Bool b | (p, b) <- hpCluster] + ), + if null hpIndex + then Nothing + else + Just + ( "index" + .= object + [ fromText (unIndexPattern p) .= toJSON (HasPrivilegesIndexResult ps) + | (p, ps) <- hpIndex + ] + ), + if null hpApplication + then Nothing + else + Just + ( "application" + .= object + [ fromText (unApplicationName a) .= toJSON (HasPrivilegesApplicationResult rs) + | (a, rs) <- hpApplication + ] + ) + ] + +-- | Extract a 'Bool' from a 'Value' that ES guarantees is a JSON +-- boolean. Returns 'Nothing' for non-bool leaves, in which case the +-- list-comprehension decoders above /silently skip/ that entry. ES +-- contractually returns booleans for every requested privilege, so in +-- practice no entry is dropped; the silent-skip is a deliberate +-- forward-compat choice (a future non-bool leaf would not abort the +-- whole parse). Callers that need lossless accounting should compare +-- the request privilege set against the response keys. +parseBool :: Value -> Maybe Bool +parseBool (Bool b) = Just b +parseBool _ = Nothing + +------------------------------------------------------------------------------ +-- Effective privileges (GET /_security/user/_privileges) +------------------------------------------------------------------------------ + +-- | One index-privileges entry in the @GET /_security/user/_privileges@ +-- response: @{names, privileges}@ (no field-security or query, unlike +-- the richer 'IndexPrivilege' in a role body). +data UserIndexPrivileges = UserIndexPrivileges + { uipNames :: [IndexPattern], + uipPrivileges :: [IndexPrivilegeName] + } + deriving stock (Eq, Show) + +instance FromJSON UserIndexPrivileges where + parseJSON = withObject "UserIndexPrivileges" $ \o -> do + names <- fromMaybe [] <$> o .:? "names" + privs <- fromMaybe [] <$> o .:? "privileges" + pure UserIndexPrivileges {uipNames = names, uipPrivileges = privs} + +instance ToJSON UserIndexPrivileges where + toJSON UserIndexPrivileges {..} = + object + [ "names" .= uipNames, + "privileges" .= uipPrivileges + ] + +-- | One application-privileges entry in the +-- @GET /_security/user/_privileges@ response: @{application, +-- privileges, resources}@. +data UserApplicationPrivileges = UserApplicationPrivileges + { uapApplication :: ApplicationName, + uapPrivileges :: [ApplicationPrivilegeName], + uapResources :: [ResourceName] + } + deriving stock (Eq, Show) + +instance FromJSON UserApplicationPrivileges where + parseJSON = withObject "UserApplicationPrivileges" $ \o -> do + app <- o .: "application" + privs <- fromMaybe [] <$> o .:? "privileges" + resources <- fromMaybe [] <$> o .:? "resources" + pure + UserApplicationPrivileges + { uapApplication = app, + uapPrivileges = privs, + uapResources = resources + } + +instance ToJSON UserApplicationPrivileges where + toJSON UserApplicationPrivileges {..} = + object + [ "application" .= uapApplication, + "privileges" .= uapPrivileges, + "resources" .= uapResources + ] + +-- | Response of @GET /_security/user/_privileges@: the current user's +-- effective privileges. +data UserPrivileges = UserPrivileges + { upUsername :: UserName, + upCluster :: [ClusterPrivilege], + upIndex :: [UserIndexPrivileges], + upApplication :: [UserApplicationPrivileges], + upRunAs :: [Text], + upExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +userPrivilegesKnownKeys :: [Text] +userPrivilegesKnownKeys = + ["username", "cluster", "index", "application", "run_as"] + +instance FromJSON UserPrivileges where + parseJSON = withObject "UserPrivileges" $ \o -> do + username <- o .: "username" + cluster <- fromMaybe [] <$> o .:? "cluster" + index <- fromMaybe [] <$> o .:? "index" + application <- fromMaybe [] <$> o .:? "application" + runAs <- fromMaybe [] <$> o .:? "run_as" + let extras = + KM.fromList $ + filter ((`notElem` userPrivilegesKnownKeys) . toText . fst) $ + KM.toList o + pure + UserPrivileges + { upUsername = username, + upCluster = cluster, + upIndex = index, + upApplication = application, + upRunAs = runAs, + upExtras = extras + } + +instance ToJSON UserPrivileges where + toJSON UserPrivileges {..} = + omitNulls $ + catMaybes + [ Just ("username" .= upUsername), + Just ("cluster" .= upCluster), + Just ("index" .= upIndex), + Just ("application" .= upApplication), + Just ("run_as" .= upRunAs) + ] + <> [toPair kv | kv <- KM.toList upExtras] + where + toPair (k, v) = k .= v + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +userRolesLens :: Lens' User [RoleName] +userRolesLens = lens uRoles (\x y -> x {uRoles = y}) + +userFullNameLens :: Lens' User (Maybe Text) +userFullNameLens = lens uFullName (\x y -> x {uFullName = y}) + +userEmailLens :: Lens' User (Maybe Text) +userEmailLens = lens uEmail (\x y -> x {uEmail = y}) + +userEnabledLens :: Lens' User Bool +userEnabledLens = lens uEnabled (\x y -> x {uEnabled = y}) + +userMetadataLens :: Lens' User (KeyMap Value) +userMetadataLens = lens uMetadata (\x y -> x {uMetadata = y}) + +userExtrasLens :: Lens' User (KeyMap Value) +userExtrasLens = lens uExtras (\x y -> x {uExtras = y}) + +userCreateBodyPasswordLens :: Lens' UserCreateBody (Maybe SecretText) +userCreateBodyPasswordLens = + lens ucbPassword (\x y -> x {ucbPassword = y}) + +userCreateBodyRolesLens :: Lens' UserCreateBody [RoleName] +userCreateBodyRolesLens = lens ucbRoles (\x y -> x {ucbRoles = y}) + +userCreateBodyFullNameLens :: Lens' UserCreateBody (Maybe Text) +userCreateBodyFullNameLens = + lens ucbFullName (\x y -> x {ucbFullName = y}) + +userCreateBodyEmailLens :: Lens' UserCreateBody (Maybe Text) +userCreateBodyEmailLens = lens ucbEmail (\x y -> x {ucbEmail = y}) + +userCreateBodyEnabledLens :: Lens' UserCreateBody (Maybe Bool) +userCreateBodyEnabledLens = + lens ucbEnabled (\x y -> x {ucbEnabled = y}) + +userCreateBodyMetadataLens :: + Lens' UserCreateBody (KeyMap Value) +userCreateBodyMetadataLens = + lens ucbMetadata (\x y -> x {ucbMetadata = y}) + +hasPrivilegesRequestClusterLens :: + Lens' HasPrivilegesRequest [ClusterPrivilege] +hasPrivilegesRequestClusterLens = + lens hprCluster (\x y -> x {hprCluster = y}) + +hasPrivilegesRequestIndexLens :: + Lens' HasPrivilegesRequest [(IndexPattern, [IndexPrivilegeName])] +hasPrivilegesRequestIndexLens = + lens hprIndex (\x y -> x {hprIndex = y}) + +hasPrivilegesRequestApplicationLens :: + Lens' + HasPrivilegesRequest + [(ApplicationName, [(ResourceName, [ApplicationPrivilegeName])])] +hasPrivilegesRequestApplicationLens = + lens hprApplication (\x y -> x {hprApplication = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Snapshots.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Snapshots.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Snapshots.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Snapshots.hs @@ -7,15 +7,21 @@ {-# LANGUAGE UndecidableInstances #-} module Database.Bloodhound.Internal.Versions.Common.Types.Snapshots - ( FsSnapshotRepo (..), + ( CreateSnapshotResponse (..), + FsSnapshotRepo (..), GenericSnapshotRepo (..), GenericSnapshotRepoSettings (..), RRGroupRefNum (..), RestoreIndexSettings (..), RestoreRenamePattern (..), RestoreRenameToken (..), + SnapshotCleanupResult (..), + SnapshotCloneSettings (..), SnapshotCreateSettings (..), + SnapshotFeatureState (..), + SnapshotFileCounts (..), SnapshotInfo (..), + SnapshotIndexStatus (..), SnapshotNodeVerification (..), SnapshotPattern (..), SnapshotRepo (..), @@ -24,16 +30,37 @@ SnapshotRepoPattern (..), SnapshotRepoSelection (..), SnapshotRepoType (..), + SnapshotRepoTimeoutOptions (..), SnapshotRepoUpdateSettings (..), + SnapshotResponse (..), SnapshotRestoreSettings (..), SnapshotSelection (..), + SnapshotSelectionOptions (..), + SnapshotMasterTimeoutOptions (..), + SnapshotRepoGetOptions (..), SnapshotShardFailure (..), + SnapshotShardStage (..), + SnapshotShardStats (..), + SnapshotShardStatus (..), + SnapshotSortField (..), + SnapshotSortOrder (..), SnapshotState (..), + SnapshotStats (..), + SnapshotStatus (..), + SnapshotStatusOptions (..), SnapshotVerification (..), defaultSnapshotCreateSettings, + defaultSnapshotCloneSettings, defaultSnapshotRepoUpdateSettings, + defaultSnapshotRepoTimeoutOptions, + defaultSnapshotRepoGetOptions, + defaultSnapshotStatusOptions, defaultSnapshotRestoreSettings, + defaultSnapshotSelectionOptions, + defaultSnapshotMasterTimeoutOptions, mkRRGroupRefNum, + renderSnapshotSortField, + renderSnapshotSortOrder, -- * Optics snapshotRepoNameLens, @@ -55,7 +82,10 @@ snapshotRestoreSettingsIncludeAliasesLens, snapshotRestoreSettingsIndexSettingsOverridesLens, snapshotRestoreSettingsIgnoreIndexSettingsLens, + snapshotRestoreSettingsMasterTimeoutLens, snapshotRepoUpdateSettingsUpdateVerifyLens, + snapshotRepoUpdateSettingsMasterTimeoutLens, + snapshotRepoUpdateSettingsTimeoutLens, fsSnapshotRepoNameLens, fsSnapshotRepoLocationLens, fsSnapshotRepoCompressMetadataLens, @@ -67,6 +97,9 @@ snapshotCreateSettingsIgnoreUnavailableLens, snapshotCreateSettingsIncludeGlobalStateLens, snapshotCreateSettingsPartialLens, + snapshotCreateSettingsMasterTimeoutLens, + snapshotCreateSettingsMetadataLens, + snapshotCreateSettingsFeatureStatesLens, snapshotInfoShardsLens, snapshotInfoFailuresLens, snapshotInfoDurationLens, @@ -75,20 +108,84 @@ snapshotInfoStateLens, snapshotInfoIndicesLens, snapshotInfoNameLens, + snapshotInfoUuidLens, + snapshotInfoVersionIdLens, + snapshotInfoVersionLens, + snapshotInfoIncludeGlobalStateLens, + snapshotInfoMetadataLens, + snapshotInfoDataStreamsLens, + snapshotInfoFeatureStatesLens, + snapshotFeatureStateNameLens, + snapshotFeatureStateIndicesLens, snapshotShardFailureIndexLens, snapshotShardFailureNodeIdLens, snapshotShardFailureReasonLens, snapshotShardFailureShardIdLens, + snapshotCleanupDeletedBytesLens, + snapshotCleanupDeletedBlobsLens, + snapshotCloneSettingsIndicesLens, + snapshotCloneSettingsMasterTimeoutLens, + snapshotFileCountsFileCountLens, + snapshotFileCountsSizeInBytesLens, + snapshotShardStatsInitializingLens, + snapshotShardStatsStartedLens, + snapshotShardStatsFinalizingLens, + snapshotShardStatsDoneLens, + snapshotShardStatsFailedLens, + snapshotShardStatsTotalLens, + snapshotStatsIncrementalLens, + snapshotStatsTotalLens, + snapshotStatsProcessedLens, + snapshotStatsStartTimeLens, + snapshotStatsTimeLens, + snapshotShardStatusStageLens, + snapshotShardStatusStatsLens, + snapshotShardStatusNodeLens, + snapshotShardStatusReasonLens, + snapshotShardStatusDescriptionLens, + snapshotIndexStatusShardStatsLens, + snapshotIndexStatusStatsLens, + snapshotIndexStatusShardsLens, + snapshotStatusSnapshotLens, + snapshotStatusRepositoryLens, + snapshotStatusUuidLens, + snapshotStatusStateLens, + snapshotStatusIncludeGlobalStateLens, + snapshotStatusShardsStatsLens, + snapshotStatusStatsLens, + snapshotStatusIndicesLens, restoreRenamePatternLens, restoreIndexSettingsOverrideReplicasLens, + ssoMasterTimeoutLens, + ssoVerboseLens, + ssoIndexDetailsLens, + ssoIncludeRepositoryLens, + ssoSortLens, + ssoOrderLens, + ssoSizeLens, + ssoOffsetLens, + ssoAfterLens, + ssoFromSortValueLens, + ssoIgnoreUnavailableSnapshotsLens, + ssoIndexNamesLens, + ssoSlmPolicyFilterLens, + smtoMasterTimeoutLens, + srtoMasterTimeoutLens, + srtoTimeoutLens, + srgoLocalLens, + srgoMasterTimeoutLens, + sstoIgnoreUnavailableLens, + sstoMasterTimeoutLens, ) where import Control.Monad.Catch -import qualified Data.Aeson.Key as X -import qualified Data.Aeson.KeyMap as X -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T +import Data.Aeson.Key qualified as X +import Data.Aeson.KeyMap qualified as X +import Data.HashMap.Strict qualified as HM +import Data.Text qualified as T +import Data.Word (Word32) +import Database.Bloodhound.Internal.Client.BHRequest (Acknowledged (..)) import Database.Bloodhound.Internal.Utils.Imports import Database.Bloodhound.Internal.Utils.StringlyTyped import Database.Bloodhound.Internal.Versions.Common.Types.Indices @@ -252,7 +349,12 @@ -- omitting it. One example here would be -- "index.refresh_interval". Any setting specified here will -- revert back to the server default during the restore process. - snapRestoreIgnoreIndexSettings :: Maybe (NonEmpty Text) + snapRestoreIgnoreIndexSettings :: Maybe (NonEmpty Text), + -- | @master_timeout@ URI parameter, the time to wait for the + -- master node to process the request. Rendered via + -- 'timeUnitsSuffix' (e.g. @('TimeUnitSeconds', 30)@ -> @30s@). + -- 'Nothing' (the default) omits the parameter. + snapRestoreMasterTimeout :: Maybe (TimeUnits, Word32) } deriving stock (Eq, Show) @@ -286,23 +388,49 @@ snapshotRestoreSettingsIgnoreIndexSettingsLens :: Lens' SnapshotRestoreSettings (Maybe (NonEmpty Text)) snapshotRestoreSettingsIgnoreIndexSettingsLens = lens snapRestoreIgnoreIndexSettings (\x y -> x {snapRestoreIgnoreIndexSettings = y}) -newtype SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings +snapshotRestoreSettingsMasterTimeoutLens :: Lens' SnapshotRestoreSettings (Maybe (TimeUnits, Word32)) +snapshotRestoreSettingsMasterTimeoutLens = lens snapRestoreMasterTimeout (\x y -> x {snapRestoreMasterTimeout = y}) + +data SnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings { -- | After creation/update, synchronously check that nodes can -- write to this repo. Defaults to True. You may use False if you -- need a faster response and plan on verifying manually later -- with 'verifySnapshotRepo'. - repoUpdateVerify :: Bool + repoUpdateVerify :: Bool, + -- | @master_timeout@ URI parameter, the time to wait for the + -- master node to process the request. Rendered via + -- 'timeUnitsSuffix' (e.g. @('TimeUnitSeconds', 30)@ -> @30s@). + -- 'Nothing' (the default) omits the parameter. + repoUpdateMasterTimeout :: Maybe (TimeUnits, Word32), + -- | @timeout@ URI parameter, the time to wait for the operation + -- to complete. Rendered via 'timeUnitsSuffix' (e.g. + -- @('TimeUnitSeconds', 30)@ -> @30s@). 'Nothing' (the default) + -- omits the parameter. + repoUpdateTimeout :: Maybe (TimeUnits, Word32) } deriving stock (Eq, Show) snapshotRepoUpdateSettingsUpdateVerifyLens :: Lens' SnapshotRepoUpdateSettings Bool snapshotRepoUpdateSettingsUpdateVerifyLens = lens repoUpdateVerify (\x y -> x {repoUpdateVerify = y}) +snapshotRepoUpdateSettingsMasterTimeoutLens :: Lens' SnapshotRepoUpdateSettings (Maybe (TimeUnits, Word32)) +snapshotRepoUpdateSettingsMasterTimeoutLens = lens repoUpdateMasterTimeout (\x y -> x {repoUpdateMasterTimeout = y}) + +snapshotRepoUpdateSettingsTimeoutLens :: Lens' SnapshotRepoUpdateSettings (Maybe (TimeUnits, Word32)) +snapshotRepoUpdateSettingsTimeoutLens = lens repoUpdateTimeout (\x y -> x {repoUpdateTimeout = y}) + -- | Reasonable defaults for repo creation/update -- -- * repoUpdateVerify True +-- * repoUpdateMasterTimeout Nothing +-- * repoUpdateTimeout Nothing defaultSnapshotRepoUpdateSettings :: SnapshotRepoUpdateSettings -defaultSnapshotRepoUpdateSettings = SnapshotRepoUpdateSettings True +defaultSnapshotRepoUpdateSettings = + SnapshotRepoUpdateSettings + { repoUpdateVerify = True, + repoUpdateMasterTimeout = Nothing, + repoUpdateTimeout = Nothing + } -- | A filesystem-based snapshot repo that ships with -- Elasticsearch. This is an instance of 'SnapshotRepo' so it can be @@ -409,7 +537,24 @@ snapIncludeGlobalState :: Bool, -- | If some indices failed to snapshot (e.g. if not all primary -- shards are available), should the process proceed? - snapPartial :: Bool + snapPartial :: Bool, + -- | @master_timeout@ URI parameter, the time to wait for the + -- master node to process the request. Rendered via + -- 'timeUnitsSuffix' (e.g. @('TimeUnitSeconds', 30)@ -> @30s@). + -- 'Nothing' (the default) omits the parameter. + snapMasterTimeout :: Maybe (TimeUnits, Word32), + -- | Arbitrary user-supplied metadata attached to the snapshot + -- (ES 7.10+), rendered verbatim as a JSON object. 'Nothing' (the + -- default) omits the field. Keys with a null value are not + -- permitted by the server; an empty object @{}@ is allowed. + snapMetadata :: Maybe Object, + -- | The feature states to include in the snapshot (ES 7.12+), as + -- a non-empty list of feature names (e.g. @["data_streams", + -- "templates"]@). The special token @"all"@ captures every + -- feature state and @"none"@ captures none. 'Nothing' (the + -- default) lets the server pick its default (currently + -- @["none"]@ for a snapshot that names specific indices). + snapFeatureStates :: Maybe (NonEmpty Text) } deriving stock (Eq, Show) @@ -428,6 +573,15 @@ snapshotCreateSettingsPartialLens :: Lens' SnapshotCreateSettings Bool snapshotCreateSettingsPartialLens = lens snapPartial (\x y -> x {snapPartial = y}) +snapshotCreateSettingsMasterTimeoutLens :: Lens' SnapshotCreateSettings (Maybe (TimeUnits, Word32)) +snapshotCreateSettingsMasterTimeoutLens = lens snapMasterTimeout (\x y -> x {snapMasterTimeout = y}) + +snapshotCreateSettingsMetadataLens :: Lens' SnapshotCreateSettings (Maybe Object) +snapshotCreateSettingsMetadataLens = lens snapMetadata (\x y -> x {snapMetadata = y}) + +snapshotCreateSettingsFeatureStatesLens :: Lens' SnapshotCreateSettings (Maybe (NonEmpty Text)) +snapshotCreateSettingsFeatureStatesLens = lens snapFeatureStates (\x y -> x {snapFeatureStates = y}) + -- | Reasonable defaults for snapshot creation -- -- * snapWaitForCompletion False @@ -435,6 +589,9 @@ -- * snapIgnoreUnavailable False -- * snapIncludeGlobalState True -- * snapPartial False +-- * snapMasterTimeout Nothing +-- * snapMetadata Nothing +-- * snapFeatureStates Nothing defaultSnapshotCreateSettings :: SnapshotCreateSettings defaultSnapshotCreateSettings = SnapshotCreateSettings @@ -442,7 +599,10 @@ snapIndices = Nothing, snapIgnoreUnavailable = False, snapIncludeGlobalState = True, - snapPartial = False + snapPartial = False, + snapMasterTimeout = Nothing, + snapMetadata = Nothing, + snapFeatureStates = Nothing } data SnapshotSelection @@ -459,7 +619,17 @@ deriving stock (Eq, Show) -- | General information about the state of a snapshot. Has some --- redundancies with 'SnapshotStatus' +-- redundancies with 'SnapshotStatus'. The fields +-- 'snapInfoVersionId', 'snapInfoVersion', 'snapInfoIncludeGlobalState', +-- 'snapInfoMetadata', 'snapInfoDataStreams' and 'snapInfoFeatureStates' +-- are optional: they are present in modern (ES 7+\/OS) responses but +-- absent from older servers, so they are parsed with '.:?' and default +-- to 'Nothing' on older servers (where the keys are absent). On modern +-- servers the keys are present (possibly as empty arrays, decoding to +-- 'Just []') and parse to 'Just'. 'snapInfoDataStreams' (@data_streams@, +-- ES 7.x+) is the list of data-stream names captured; +-- 'snapInfoFeatureStates' (@feature_states@, ES 7.12+) is the list of +-- 'SnapshotFeatureState' records (feature name + owned indices) captured. data SnapshotInfo = SnapshotInfo { snapInfoShards :: ShardResult, snapInfoFailures :: [SnapshotShardFailure], @@ -468,7 +638,41 @@ snapInfoStartTime :: UTCTime, snapInfoState :: SnapshotState, snapInfoIndices :: [IndexName], - snapInfoName :: SnapshotName + snapInfoName :: SnapshotName, + -- | Server-assigned UUID of the snapshot (@uuid@). Always present + -- on modern servers (ES 5.x+/OpenSearch); parsed leniently as + -- 'Nothing' when absent so older payloads still decode. Distinct + -- from 'snapInfoName': the name is the user-supplied identifier + -- passed at creation time, while the UUID is assigned by the + -- server and used for cross-cluster references. + snapInfoUuid :: Maybe Text, + -- | Numeric ID of the Elasticsearch version that took the + -- snapshot, encoded as + -- @major * 100000 + minor * 1000 + patch@ (e.g. @8170000@ for + -- version @"8.17.0"@ — the display form of the same value is in + -- 'snapInfoVersion'). Absent on older servers. + snapInfoVersionId :: Maybe Int, + -- | Display version string of the node that took the snapshot, + -- e.g. @"7.17.0"@. Absent on older servers. + snapInfoVersion :: Maybe Text, + -- | Whether global state was included when the snapshot was + -- taken. Absent on older servers. + snapInfoIncludeGlobalState :: Maybe Bool, + -- | Arbitrary user-supplied metadata attached to the snapshot, + -- preserved verbatim. Absent on older servers and on snapshots + -- created without metadata. + snapInfoMetadata :: Maybe Object, + -- | Data-stream names captured by the snapshot (@data_streams@). + -- ES 7.x+; absent (and 'Nothing') on older servers, present + -- (possibly @[]@) on modern ones even when the snapshot captures + -- no data stream. + snapInfoDataStreams :: Maybe [Text], + -- | Feature states captured by the snapshot (@feature_states@). + -- ES 7.12+; absent (and 'Nothing') on older servers, present + -- (possibly @[]@) on modern ones even when no feature state is + -- captured. Each entry is a 'SnapshotFeatureState' (feature name + -- + owned indices). + snapInfoFeatureStates :: Maybe [SnapshotFeatureState] } deriving stock (Eq, Show) @@ -490,6 +694,20 @@ .: "indices" <*> o .: "snapshot" + <*> o + .:? "uuid" + <*> o + .:? "version_id" + <*> o + .:? "version" + <*> o + .:? "include_global_state" + <*> o + .:? "metadata" + <*> o + .:? "data_streams" + <*> o + .:? "feature_states" snapshotInfoShardsLens :: Lens' SnapshotInfo ShardResult snapshotInfoShardsLens = lens snapInfoShards (\x y -> x {snapInfoShards = y}) @@ -515,6 +733,347 @@ snapshotInfoNameLens :: Lens' SnapshotInfo SnapshotName snapshotInfoNameLens = lens snapInfoName (\x y -> x {snapInfoName = y}) +snapshotInfoUuidLens :: Lens' SnapshotInfo (Maybe Text) +snapshotInfoUuidLens = lens snapInfoUuid (\x y -> x {snapInfoUuid = y}) + +snapshotInfoVersionIdLens :: Lens' SnapshotInfo (Maybe Int) +snapshotInfoVersionIdLens = lens snapInfoVersionId (\x y -> x {snapInfoVersionId = y}) + +snapshotInfoVersionLens :: Lens' SnapshotInfo (Maybe Text) +snapshotInfoVersionLens = lens snapInfoVersion (\x y -> x {snapInfoVersion = y}) + +snapshotInfoIncludeGlobalStateLens :: Lens' SnapshotInfo (Maybe Bool) +snapshotInfoIncludeGlobalStateLens = lens snapInfoIncludeGlobalState (\x y -> x {snapInfoIncludeGlobalState = y}) + +snapshotInfoMetadataLens :: Lens' SnapshotInfo (Maybe Object) +snapshotInfoMetadataLens = lens snapInfoMetadata (\x y -> x {snapInfoMetadata = y}) + +snapshotInfoDataStreamsLens :: Lens' SnapshotInfo (Maybe [Text]) +snapshotInfoDataStreamsLens = lens snapInfoDataStreams (\x y -> x {snapInfoDataStreams = y}) + +snapshotInfoFeatureStatesLens :: Lens' SnapshotInfo (Maybe [SnapshotFeatureState]) +snapshotInfoFeatureStatesLens = lens snapInfoFeatureStates (\x y -> x {snapInfoFeatureStates = y}) + +-- | Wrapper for the @{"snapshot": }@ payload returned +-- by create-snapshot when @wait_for_completion=true@. The inner +-- object has the same shape as 'SnapshotInfo', so this just unwraps +-- the single @"snapshot"@ key. +newtype SnapshotResponse = SnapshotResponse + { snapshotResponseSnapshot :: SnapshotInfo + } + deriving stock (Eq, Show) + +instance FromJSON SnapshotResponse where + parseJSON = withObject "SnapshotResponse" $ \o -> + SnapshotResponse <$> o .: "snapshot" + +-- | Response of 'Database.Bloodhound.Common.Requests.createSnapshot'. +-- The Elasticsearch create-snapshot API returns one of two response +-- shapes depending on the 'snapWaitForCompletion' setting: +-- +-- * @wait_for_completion=false@ (the default): @{"acknowledged": }@, +-- decoded to 'CreateSnapshotAcknowledged'. +-- * @wait_for_completion=true@: a full snapshot object +-- @{"snapshot": {…}}@, decoded to 'CreateSnapshotCompleted'. +-- +-- The 'FromJSON' instance branches on the JSON shape (presence of the +-- @"acknowledged"@ vs @"snapshot"@ key), so it decodes correctly +-- whichever value of 'snapWaitForCompletion' the caller selected and +-- is robust even if the flag and the returned shape ever disagree. +data CreateSnapshotResponse + = CreateSnapshotAcknowledged Acknowledged + | CreateSnapshotCompleted SnapshotResponse + deriving stock (Eq, Show) + +instance FromJSON CreateSnapshotResponse where + parseJSON = withObject "CreateSnapshotResponse" $ \o -> + case X.lookup "snapshot" o of + Just _ -> CreateSnapshotCompleted <$> parseJSON (Object o) + Nothing -> + case X.lookup "acknowledged" o of + Just _ -> CreateSnapshotAcknowledged <$> parseJSON (Object o) + Nothing -> + fail $ + "CreateSnapshotResponse: expected an \"acknowledged\" or \"snapshot\" field, got keys: " + <> show (X.keys o) + +-- | One feature state captured by a snapshot — an entry of the +-- @feature_states@ array on 'SnapshotInfo' (ES 7.12+). The +-- @feature_name@ identifies the feature (e.g. @"geoip"@, +-- @"kibana"@, @"async_search"@); @indices@ lists the internal +-- indices the feature owns that were included in the snapshot +-- (e.g. @[".geoip_databases"]@). +data SnapshotFeatureState = SnapshotFeatureState + { snapshotFeatureStateName :: Text, + snapshotFeatureStateIndices :: [IndexName] + } + deriving stock (Eq, Show) + +instance FromJSON SnapshotFeatureState where + parseJSON = withObject "SnapshotFeatureState" parse + where + parse o = + SnapshotFeatureState + <$> o + .: "feature_name" + <*> o + .: "indices" + +snapshotFeatureStateNameLens :: Lens' SnapshotFeatureState Text +snapshotFeatureStateNameLens = lens snapshotFeatureStateName (\x y -> x {snapshotFeatureStateName = y}) + +snapshotFeatureStateIndicesLens :: Lens' SnapshotFeatureState [IndexName] +snapshotFeatureStateIndicesLens = lens snapshotFeatureStateIndices (\x y -> x {snapshotFeatureStateIndices = y}) + +-- | Sort order for 'GET /_snapshot/{repo}/{snapshots}'. Matches the +-- values documented by Elasticsearch and OpenSearch for the @sort@ +-- query parameter. +data SnapshotSortField + = SortSnapshotByStartTime + | -- | Deprecated by Elasticsearch; prefer 'SortSnapshotByStartTime'. + SortSnapshotByDuration + | SortSnapshotByName + | SortSnapshotByRepository + | SortSnapshotByIndices + deriving stock (Eq, Show) + +-- | Render a 'SnapshotSortField' as the wire string expected by the +-- @sort@ parameter. +renderSnapshotSortField :: SnapshotSortField -> Text +renderSnapshotSortField SortSnapshotByStartTime = "start_time" +renderSnapshotSortField SortSnapshotByDuration = "duration" +renderSnapshotSortField SortSnapshotByName = "name" +renderSnapshotSortField SortSnapshotByRepository = "repository" +renderSnapshotSortField SortSnapshotByIndices = "indices" + +-- | Sort direction for the @order@ query parameter of +-- 'GET /_snapshot/{repo}/{snapshots}'. Matches the @asc@\/@desc@ +-- values documented by Elasticsearch and OpenSearch. +data SnapshotSortOrder + = SortOrderAsc + | SortOrderDesc + deriving stock (Eq, Show) + +-- | Render a 'SnapshotSortOrder' as the wire string expected by the +-- @order@ parameter. +renderSnapshotSortOrder :: SnapshotSortOrder -> Text +renderSnapshotSortOrder SortOrderAsc = "asc" +renderSnapshotSortOrder SortOrderDesc = "desc" + +-- | Optional URI parameters accepted by @GET /_snapshot\/{repo}\/{snapshots}@: +-- @master_timeout@, @verbose@, @index_details@, @include_repository@, +-- @sort@, @size@, @offset@, @after@, @from_sort_value@, @order@, +-- @ignore_unavailable@, @index_names@ and @slm_policy_filter@. Every +-- field is optional, so 'defaultSnapshotSelectionOptions' renders to +-- no parameters at all — byte-for-byte identical to a parameterless +-- 'getSnapshots' call. +-- +-- /Backend coverage:/ Elasticsearch accepts the full parameter set. +-- OpenSearch only honours @master_timeout@, @verbose@ and +-- @ignore_unavailable@; the paging\/sorting parameters (@sort@, +-- @order@, @size@, @offset@, @after@, @from_sort_value@, +-- @index_names@, @slm_policy_filter@) are Elasticsearch-specific and +-- will be rejected by an OpenSearch cluster if set. +data SnapshotSelectionOptions = SnapshotSelectionOptions + { ssoMasterTimeout :: Maybe (TimeUnits, Word32), + ssoVerbose :: Maybe Bool, + ssoIndexDetails :: Maybe Bool, + ssoIncludeRepository :: Maybe Bool, + ssoSort :: Maybe SnapshotSortField, + -- | Sort direction. Ignored by the server unless 'ssoSort' is also set. + ssoOrder :: Maybe SnapshotSortOrder, + ssoSize :: Maybe Word32, + ssoOffset :: Maybe Word32, + ssoAfter :: Maybe Text, + ssoFromSortValue :: Maybe Text, + ssoIgnoreUnavailableSnapshots :: Maybe Bool, + -- | Elasticsearch 8.x and later only. Setting this against an + -- Elasticsearch 7.x cluster (or any OpenSearch version) is + -- rejected with an HTTP 400. + ssoIndexNames :: Maybe Bool, + ssoSlmPolicyFilter :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'SnapshotSelectionOptions' with every parameter set to 'Nothing'. +-- Produces no query string, so 'getSnapshotsWith' with this value +-- emits a request identical to 'getSnapshots'. +defaultSnapshotSelectionOptions :: SnapshotSelectionOptions +defaultSnapshotSelectionOptions = + SnapshotSelectionOptions + { ssoMasterTimeout = Nothing, + ssoVerbose = Nothing, + ssoIndexDetails = Nothing, + ssoIncludeRepository = Nothing, + ssoSort = Nothing, + ssoOrder = Nothing, + ssoSize = Nothing, + ssoOffset = Nothing, + ssoAfter = Nothing, + ssoFromSortValue = Nothing, + ssoIgnoreUnavailableSnapshots = Nothing, + ssoIndexNames = Nothing, + ssoSlmPolicyFilter = Nothing + } + +ssoMasterTimeoutLens :: Lens' SnapshotSelectionOptions (Maybe (TimeUnits, Word32)) +ssoMasterTimeoutLens = lens ssoMasterTimeout (\x y -> x {ssoMasterTimeout = y}) + +ssoVerboseLens :: Lens' SnapshotSelectionOptions (Maybe Bool) +ssoVerboseLens = lens ssoVerbose (\x y -> x {ssoVerbose = y}) + +ssoIndexDetailsLens :: Lens' SnapshotSelectionOptions (Maybe Bool) +ssoIndexDetailsLens = lens ssoIndexDetails (\x y -> x {ssoIndexDetails = y}) + +ssoIncludeRepositoryLens :: Lens' SnapshotSelectionOptions (Maybe Bool) +ssoIncludeRepositoryLens = lens ssoIncludeRepository (\x y -> x {ssoIncludeRepository = y}) + +ssoSortLens :: Lens' SnapshotSelectionOptions (Maybe SnapshotSortField) +ssoSortLens = lens ssoSort (\x y -> x {ssoSort = y}) + +ssoOrderLens :: Lens' SnapshotSelectionOptions (Maybe SnapshotSortOrder) +ssoOrderLens = lens ssoOrder (\x y -> x {ssoOrder = y}) + +ssoSizeLens :: Lens' SnapshotSelectionOptions (Maybe Word32) +ssoSizeLens = lens ssoSize (\x y -> x {ssoSize = y}) + +ssoOffsetLens :: Lens' SnapshotSelectionOptions (Maybe Word32) +ssoOffsetLens = lens ssoOffset (\x y -> x {ssoOffset = y}) + +ssoAfterLens :: Lens' SnapshotSelectionOptions (Maybe Text) +ssoAfterLens = lens ssoAfter (\x y -> x {ssoAfter = y}) + +ssoFromSortValueLens :: Lens' SnapshotSelectionOptions (Maybe Text) +ssoFromSortValueLens = lens ssoFromSortValue (\x y -> x {ssoFromSortValue = y}) + +ssoIgnoreUnavailableSnapshotsLens :: Lens' SnapshotSelectionOptions (Maybe Bool) +ssoIgnoreUnavailableSnapshotsLens = lens ssoIgnoreUnavailableSnapshots (\x y -> x {ssoIgnoreUnavailableSnapshots = y}) + +ssoIndexNamesLens :: Lens' SnapshotSelectionOptions (Maybe Bool) +ssoIndexNamesLens = lens ssoIndexNames (\x y -> x {ssoIndexNames = y}) + +ssoSlmPolicyFilterLens :: Lens' SnapshotSelectionOptions (Maybe Text) +ssoSlmPolicyFilterLens = lens ssoSlmPolicyFilter (\x y -> x {ssoSlmPolicyFilter = y}) + +-- | Optional URI parameters for the snapshot endpoints that expose +-- only @master_timeout@: +-- +-- * 'Requests.cleanupSnapshotRepoWith' (POST /_snapshot/{repository}/_cleanup) +-- * 'Requests.deleteSnapshotWith' (DELETE /_snapshot/{repository}/{snapshot}) +-- +-- The other snapshot endpoints take additional documented params and +-- therefore have their own options records: +-- 'SnapshotRepoTimeoutOptions' (verify \/ delete repo), +-- 'SnapshotRepoGetOptions' (get repo) and 'SnapshotStatusOptions' +-- (get status). +-- +-- Every field is optional, so 'defaultSnapshotMasterTimeoutOptions' +-- renders to no parameters at all — byte-for-byte identical to the +-- parameterless plain variant of each endpoint. +data SnapshotMasterTimeoutOptions = SnapshotMasterTimeoutOptions + { smtoMasterTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'SnapshotMasterTimeoutOptions' with every parameter set to +-- 'Nothing'. Produces no query string. +defaultSnapshotMasterTimeoutOptions :: SnapshotMasterTimeoutOptions +defaultSnapshotMasterTimeoutOptions = + SnapshotMasterTimeoutOptions + { smtoMasterTimeout = Nothing + } + +smtoMasterTimeoutLens :: Lens' SnapshotMasterTimeoutOptions (Maybe (TimeUnits, Word32)) +smtoMasterTimeoutLens = lens smtoMasterTimeout (\x y -> x {smtoMasterTimeout = y}) + +-- | Optional URI parameters for the snapshot-repository endpoints that +-- expose @master_timeout@ and @timeout@: +-- +-- * 'Requests.verifySnapshotRepoWith' (POST /_snapshot/{repository}/_verify) +-- * 'Requests.deleteSnapshotRepoWith' (DELETE /_snapshot/{repository}) +-- +-- Every field is optional, so 'defaultSnapshotRepoTimeoutOptions' +-- renders to no parameters at all — byte-for-byte identical to the +-- parameterless plain variant of each endpoint. +data SnapshotRepoTimeoutOptions = SnapshotRepoTimeoutOptions + { srtoMasterTimeout :: Maybe (TimeUnits, Word32), + srtoTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'SnapshotRepoTimeoutOptions' with every parameter set to +-- 'Nothing'. Produces no query string. +defaultSnapshotRepoTimeoutOptions :: SnapshotRepoTimeoutOptions +defaultSnapshotRepoTimeoutOptions = + SnapshotRepoTimeoutOptions + { srtoMasterTimeout = Nothing, + srtoTimeout = Nothing + } + +srtoMasterTimeoutLens :: Lens' SnapshotRepoTimeoutOptions (Maybe (TimeUnits, Word32)) +srtoMasterTimeoutLens = lens srtoMasterTimeout (\x y -> x {srtoMasterTimeout = y}) + +srtoTimeoutLens :: Lens' SnapshotRepoTimeoutOptions (Maybe (TimeUnits, Word32)) +srtoTimeoutLens = lens srtoTimeout (\x y -> x {srtoTimeout = y}) + +-- | Optional URI parameters for 'Requests.getSnapshotReposWith' +-- (GET /_snapshot, GET /_snapshot/{repository}), which exposes +-- @master_timeout@ and @local@. The @local@ boolean returns only the +-- local cluster's snapshot repository information, ignoring remote +-- cluster repositories. +-- +-- Every field is optional, so 'defaultSnapshotRepoGetOptions' +-- renders to no parameters at all — byte-for-byte identical to +-- 'getSnapshotRepos'. +data SnapshotRepoGetOptions = SnapshotRepoGetOptions + { srgoLocal :: Maybe Bool, + srgoMasterTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'SnapshotRepoGetOptions' with every parameter set to 'Nothing'. +-- Produces no query string. +defaultSnapshotRepoGetOptions :: SnapshotRepoGetOptions +defaultSnapshotRepoGetOptions = + SnapshotRepoGetOptions + { srgoLocal = Nothing, + srgoMasterTimeout = Nothing + } + +srgoLocalLens :: Lens' SnapshotRepoGetOptions (Maybe Bool) +srgoLocalLens = lens srgoLocal (\x y -> x {srgoLocal = y}) + +srgoMasterTimeoutLens :: Lens' SnapshotRepoGetOptions (Maybe (TimeUnits, Word32)) +srgoMasterTimeoutLens = lens srgoMasterTimeout (\x y -> x {srgoMasterTimeout = y}) + +-- | Optional URI parameters for 'Requests.getSnapshotStatusWith' +-- (GET /_snapshot/{repository}/{snapshot}/_status), which exposes +-- @master_timeout@ and @ignore_unavailable@. +-- +-- Every field is optional, so 'defaultSnapshotStatusOptions' +-- renders to no parameters at all — byte-for-byte identical to +-- 'getSnapshotStatus'. +data SnapshotStatusOptions = SnapshotStatusOptions + { sstoIgnoreUnavailable :: Maybe Bool, + sstoMasterTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'SnapshotStatusOptions' with every parameter set to 'Nothing'. +-- Produces no query string. +defaultSnapshotStatusOptions :: SnapshotStatusOptions +defaultSnapshotStatusOptions = + SnapshotStatusOptions + { sstoIgnoreUnavailable = Nothing, + sstoMasterTimeout = Nothing + } + +sstoIgnoreUnavailableLens :: Lens' SnapshotStatusOptions (Maybe Bool) +sstoIgnoreUnavailableLens = lens sstoIgnoreUnavailable (\x y -> x {sstoIgnoreUnavailable = y}) + +sstoMasterTimeoutLens :: Lens' SnapshotStatusOptions (Maybe (TimeUnits, Word32)) +sstoMasterTimeoutLens = lens sstoMasterTimeout (\x y -> x {sstoMasterTimeout = y}) + data SnapshotShardFailure = SnapshotShardFailure { snapShardFailureIndex :: IndexName, snapShardFailureNodeId :: Maybe NodeName, -- I'm not 100% sure this isn't actually 'FullNodeId' @@ -598,6 +1157,7 @@ -- * snapRestoreIncludeAliases True -- * snapRestoreIndexSettingsOverrides Nothing -- * snapRestoreIgnoreIndexSettings Nothing +-- * snapRestoreMasterTimeout Nothing defaultSnapshotRestoreSettings :: SnapshotRestoreSettings defaultSnapshotRestoreSettings = SnapshotRestoreSettings @@ -610,7 +1170,8 @@ snapRestorePartial = False, snapRestoreIncludeAliases = True, snapRestoreIndexSettingsOverrides = Nothing, - snapRestoreIgnoreIndexSettings = Nothing + snapRestoreIgnoreIndexSettings = Nothing, + snapRestoreMasterTimeout = Nothing } -- | Index settings that can be overridden. The docs only mention you @@ -628,3 +1189,364 @@ restoreIndexSettingsOverrideReplicasLens :: Lens' RestoreIndexSettings (Maybe ReplicaCount) restoreIndexSettingsOverrideReplicasLens = lens restoreOverrideReplicas (\x y -> x {restoreOverrideReplicas = y}) + +-- ---------------------------------------------------------------------------- +-- Snapshot repository cleanup (POST /_snapshot/{repository}/_cleanup) +-- ---------------------------------------------------------------------------- + +-- | Result of running 'Requests.cleanupSnapshotRepo'. Wraps the +-- @results@ object returned by @POST /_snapshot/{repository}/_cleanup@, +-- which reports the volume of stale data removed from the repository +-- (bytes freed and blobs deleted). Field types mirror 'SnapshotFileCounts' +-- (plain 'Int') for consistency with the rest of this module. +data SnapshotCleanupResult = SnapshotCleanupResult + { snapshotCleanupDeletedBytes :: Int, + snapshotCleanupDeletedBlobs :: Int + } + deriving stock (Eq, Show) + +instance FromJSON SnapshotCleanupResult where + parseJSON = withObject "SnapshotCleanupResult" parse + where + parse o = do + results <- o .: "results" + SnapshotCleanupResult + <$> results + .: "deleted_bytes" + <*> results + .: "deleted_blobs" + +snapshotCleanupDeletedBytesLens :: Lens' SnapshotCleanupResult Int +snapshotCleanupDeletedBytesLens = + lens snapshotCleanupDeletedBytes (\x y -> x {snapshotCleanupDeletedBytes = y}) + +snapshotCleanupDeletedBlobsLens :: Lens' SnapshotCleanupResult Int +snapshotCleanupDeletedBlobsLens = + lens snapshotCleanupDeletedBlobs (\x y -> x {snapshotCleanupDeletedBlobs = y}) + +-- ---------------------------------------------------------------------------- +-- Snapshot clone (POST /_snapshot/{repository}/{snapshot}/_clone) +-- ---------------------------------------------------------------------------- + +-- | Settings for 'Requests.cloneSnapshot'. The @target@ snapshot name +-- is supplied as a separate positional argument to 'cloneSnapshot' +-- (matching the source name), so this record carries only the optional +-- body\/query parameters of the endpoint: +-- +-- * 'snapCloneIndices' — @Nothing@ (the default) clones every index +-- in the source snapshot; @'Just' sel@ restricts the clone to the +-- indices matched by 'IndexSelection' (rendered comma-separated, +-- mirroring 'SnapshotCreateSettings'). +-- * 'snapCloneMasterTimeout' — @master_timeout@ URI parameter, +-- rendered via 'timeUnitsSuffix' (e.g. @('TimeUnitSeconds', 30)@ -> +-- @30s@). 'Nothing' (the default) omits the parameter. +data SnapshotCloneSettings = SnapshotCloneSettings + { snapCloneIndices :: Maybe IndexSelection, + snapCloneMasterTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +snapshotCloneSettingsIndicesLens :: Lens' SnapshotCloneSettings (Maybe IndexSelection) +snapshotCloneSettingsIndicesLens = + lens snapCloneIndices (\x y -> x {snapCloneIndices = y}) + +snapshotCloneSettingsMasterTimeoutLens :: Lens' SnapshotCloneSettings (Maybe (TimeUnits, Word32)) +snapshotCloneSettingsMasterTimeoutLens = + lens snapCloneMasterTimeout (\x y -> x {snapCloneMasterTimeout = y}) + +-- | Reasonable defaults for snapshot cloning: +-- +-- * snapCloneIndices Nothing +-- * snapCloneMasterTimeout Nothing +defaultSnapshotCloneSettings :: SnapshotCloneSettings +defaultSnapshotCloneSettings = + SnapshotCloneSettings + { snapCloneIndices = Nothing, + snapCloneMasterTimeout = Nothing + } + +-- ---------------------------------------------------------------------------- +-- Snapshot status (GET /_snapshot/{repository}/{snapshot}/_status) +-- ---------------------------------------------------------------------------- + +-- | File count and total size for a snapshot, shard, or index. Appears in +-- 'SnapshotStats' under @incremental@, @total@, and @processed@. +data SnapshotFileCounts = SnapshotFileCounts + { sfcFileCount :: Int, + sfcSizeInBytes :: Int + } + deriving stock (Eq, Show) + +instance FromJSON SnapshotFileCounts where + parseJSON = withObject "SnapshotFileCounts" parse + where + parse o = + SnapshotFileCounts + <$> o + .: "file_count" + <*> o + .: "size_in_bytes" + +snapshotFileCountsFileCountLens :: Lens' SnapshotFileCounts Int +snapshotFileCountsFileCountLens = lens sfcFileCount (\x y -> x {sfcFileCount = y}) + +snapshotFileCountsSizeInBytesLens :: Lens' SnapshotFileCounts Int +snapshotFileCountsSizeInBytesLens = lens sfcSizeInBytes (\x y -> x {sfcSizeInBytes = y}) + +-- | Counts of shards in each stage of the snapshot process. Present at +-- the snapshot, per-index, and (when summed) per-shard level. +data SnapshotShardStats = SnapshotShardStats + { snapShardStatsInitializing :: Int, + snapShardStatsStarted :: Int, + snapShardStatsFinalizing :: Int, + snapShardStatsDone :: Int, + snapShardStatsFailed :: Int, + snapShardStatsTotal :: Int + } + deriving stock (Eq, Show) + +instance FromJSON SnapshotShardStats where + parseJSON = withObject "SnapshotShardStats" parse + where + parse o = + SnapshotShardStats + <$> o + .: "initializing" + <*> o + .: "started" + <*> o + .: "finalizing" + <*> o + .: "done" + <*> o + .: "failed" + <*> o + .: "total" + +snapshotShardStatsInitializingLens :: Lens' SnapshotShardStats Int +snapshotShardStatsInitializingLens = lens snapShardStatsInitializing (\x y -> x {snapShardStatsInitializing = y}) + +snapshotShardStatsStartedLens :: Lens' SnapshotShardStats Int +snapshotShardStatsStartedLens = lens snapShardStatsStarted (\x y -> x {snapShardStatsStarted = y}) + +snapshotShardStatsFinalizingLens :: Lens' SnapshotShardStats Int +snapshotShardStatsFinalizingLens = lens snapShardStatsFinalizing (\x y -> x {snapShardStatsFinalizing = y}) + +snapshotShardStatsDoneLens :: Lens' SnapshotShardStats Int +snapshotShardStatsDoneLens = lens snapShardStatsDone (\x y -> x {snapShardStatsDone = y}) + +snapshotShardStatsFailedLens :: Lens' SnapshotShardStats Int +snapshotShardStatsFailedLens = lens snapShardStatsFailed (\x y -> x {snapShardStatsFailed = y}) + +snapshotShardStatsTotalLens :: Lens' SnapshotShardStats Int +snapshotShardStatsTotalLens = lens snapShardStatsTotal (\x y -> x {snapShardStatsTotal = y}) + +-- | File/size bookkeeping for a snapshot, index, or shard. @processed@ +-- is only present while the snapshot is running. +data SnapshotStats = SnapshotStats + { ssStatsIncremental :: Maybe SnapshotFileCounts, + ssStatsTotal :: Maybe SnapshotFileCounts, + ssStatsProcessed :: Maybe SnapshotFileCounts, + ssStatsStartTime :: Maybe UTCTime, + ssStatsTime :: Maybe NominalDiffTime + } + deriving stock (Eq, Show) + +instance FromJSON SnapshotStats where + parseJSON = withObject "SnapshotStats" parse + where + parse o = + SnapshotStats + <$> o + .:? "incremental" + <*> o + .:? "total" + <*> o + .:? "processed" + <*> (fmap posixMS <$> o .:? "start_time_in_millis") + <*> (fmap unMS <$> o .:? "time_in_millis") + +snapshotStatsIncrementalLens :: Lens' SnapshotStats (Maybe SnapshotFileCounts) +snapshotStatsIncrementalLens = lens ssStatsIncremental (\x y -> x {ssStatsIncremental = y}) + +snapshotStatsTotalLens :: Lens' SnapshotStats (Maybe SnapshotFileCounts) +snapshotStatsTotalLens = lens ssStatsTotal (\x y -> x {ssStatsTotal = y}) + +snapshotStatsProcessedLens :: Lens' SnapshotStats (Maybe SnapshotFileCounts) +snapshotStatsProcessedLens = lens ssStatsProcessed (\x y -> x {ssStatsProcessed = y}) + +snapshotStatsStartTimeLens :: Lens' SnapshotStats (Maybe UTCTime) +snapshotStatsStartTimeLens = lens ssStatsStartTime (\x y -> x {ssStatsStartTime = y}) + +snapshotStatsTimeLens :: Lens' SnapshotStats (Maybe NominalDiffTime) +snapshotStatsTimeLens = lens ssStatsTime (\x y -> x {ssStatsTime = y}) + +-- | Stage of an individual shard snapshot. Reported in +-- 'SnapshotShardStatus'. Note that the failed-stage token is @FAILURE@, +-- which differs from the top-level 'SnapshotState' (where the failed +-- state is @FAILED@). +data SnapshotShardStage + = ShardSnapshotDone + | ShardSnapshotStarted + | ShardSnapshotInit + | ShardSnapshotFinalize + | ShardSnapshotFailure + deriving stock (Eq, Show) + +instance FromJSON SnapshotShardStage where + parseJSON = withText "SnapshotShardStage" parse + where + parse "DONE" = return ShardSnapshotDone + parse "STARTED" = return ShardSnapshotStarted + parse "INIT" = return ShardSnapshotInit + parse "FINALIZE" = return ShardSnapshotFinalize + parse "FAILURE" = return ShardSnapshotFailure + parse t = fail ("Invalid snapshot shard stage " <> T.unpack t) + +-- | Per-shard status inside 'SnapshotIndexStatus'. @snapShardStatusNode@ +-- is the node ID running the shard snapshot; @snapShardStatusReason@ is +-- set when the shard failed; @snapShardStatusDescription@ is set when +-- the shard's stats are missing (typically because the node left the +-- cluster mid-snapshot). +data SnapshotShardStatus = SnapshotShardStatus + { snapShardStatusStage :: SnapshotShardStage, + snapShardStatusStats :: Maybe SnapshotStats, + snapShardStatusNode :: Maybe FullNodeId, + snapShardStatusReason :: Maybe Text, + snapShardStatusDescription :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SnapshotShardStatus where + parseJSON = withObject "SnapshotShardStatus" parse + where + parse o = + SnapshotShardStatus + <$> o + .: "stage" + <*> o + .:? "stats" + <*> (fmap FullNodeId <$> o .:? "node") + <*> o + .:? "reason" + <*> o + .:? "description" + +snapshotShardStatusStageLens :: Lens' SnapshotShardStatus SnapshotShardStage +snapshotShardStatusStageLens = lens snapShardStatusStage (\x y -> x {snapShardStatusStage = y}) + +snapshotShardStatusStatsLens :: Lens' SnapshotShardStatus (Maybe SnapshotStats) +snapshotShardStatusStatsLens = lens snapShardStatusStats (\x y -> x {snapShardStatusStats = y}) + +snapshotShardStatusNodeLens :: Lens' SnapshotShardStatus (Maybe FullNodeId) +snapshotShardStatusNodeLens = lens snapShardStatusNode (\x y -> x {snapShardStatusNode = y}) + +snapshotShardStatusReasonLens :: Lens' SnapshotShardStatus (Maybe Text) +snapshotShardStatusReasonLens = lens snapShardStatusReason (\x y -> x {snapShardStatusReason = y}) + +snapshotShardStatusDescriptionLens :: Lens' SnapshotShardStatus (Maybe Text) +snapshotShardStatusDescriptionLens = lens snapShardStatusDescription (\x y -> x {snapShardStatusDescription = y}) + +-- | Per-index status inside 'SnapshotStatus'. @sisShards@ is keyed by +-- shard ID (an unparsed 'Text' since ES encodes shard numbers as JSON +-- object keys). +data SnapshotIndexStatus = SnapshotIndexStatus + { sisShardStats :: SnapshotShardStats, + sisStats :: Maybe SnapshotStats, + sisShards :: HM.HashMap Text SnapshotShardStatus + } + deriving stock (Eq, Show) + +instance FromJSON SnapshotIndexStatus where + parseJSON = withObject "SnapshotIndexStatus" parse + where + parse o = + SnapshotIndexStatus + <$> o + .: "shards_stats" + <*> o + .:? "stats" + <*> o + .:? "shards" + .!= mempty + +snapshotIndexStatusShardStatsLens :: Lens' SnapshotIndexStatus SnapshotShardStats +snapshotIndexStatusShardStatsLens = lens sisShardStats (\x y -> x {sisShardStats = y}) + +snapshotIndexStatusStatsLens :: Lens' SnapshotIndexStatus (Maybe SnapshotStats) +snapshotIndexStatusStatsLens = lens sisStats (\x y -> x {sisStats = y}) + +snapshotIndexStatusShardsLens :: Lens' SnapshotIndexStatus (HM.HashMap Text SnapshotShardStatus) +snapshotIndexStatusShardsLens = lens sisShards (\x y -> x {sisShards = y}) + +-- | Detailed status of a snapshot as returned by +-- @GET /_snapshot/{repository}/{snapshot}/_status@. Carries shard-level +-- progress (files snapshotted, sizes, stages) needed to monitor +-- non-blocking snapshot workflows. Has some overlap with 'SnapshotInfo' +-- but the @/_status@ endpoint is the canonical source for in-flight +-- snapshots. +data SnapshotStatus = SnapshotStatus + { snapshotStatusSnapshot :: SnapshotName, + snapshotStatusRepository :: SnapshotRepoName, + snapshotStatusUuid :: Text, + snapshotStatusState :: SnapshotState, + snapshotStatusIncludeGlobalState :: Bool, + snapshotStatusShardsStats :: SnapshotShardStats, + snapshotStatusStats :: Maybe SnapshotStats, + snapshotStatusIndices :: HM.HashMap Text SnapshotIndexStatus + } + deriving stock (Eq, Show) + +instance FromJSON SnapshotStatus where + parseJSON = withObject "SnapshotStatus" parse + where + parse o = + SnapshotStatus + <$> o + .: "snapshot" + <*> o + .: "repository" + <*> o + .: "uuid" + <*> o + .: "state" + <*> o + .:? "include_global_state" + .!= False + <*> o + .: "shards_stats" + <*> o + .:? "stats" + <*> o + .:? "indices" + .!= mempty + +snapshotStatusSnapshotLens :: Lens' SnapshotStatus SnapshotName +snapshotStatusSnapshotLens = lens snapshotStatusSnapshot (\x y -> x {snapshotStatusSnapshot = y}) + +snapshotStatusRepositoryLens :: Lens' SnapshotStatus SnapshotRepoName +snapshotStatusRepositoryLens = lens snapshotStatusRepository (\x y -> x {snapshotStatusRepository = y}) + +snapshotStatusUuidLens :: Lens' SnapshotStatus Text +snapshotStatusUuidLens = lens snapshotStatusUuid (\x y -> x {snapshotStatusUuid = y}) + +snapshotStatusStateLens :: Lens' SnapshotStatus SnapshotState +snapshotStatusStateLens = lens snapshotStatusState (\x y -> x {snapshotStatusState = y}) + +snapshotStatusIncludeGlobalStateLens :: Lens' SnapshotStatus Bool +snapshotStatusIncludeGlobalStateLens = + lens + snapshotStatusIncludeGlobalState + (\x y -> x {snapshotStatusIncludeGlobalState = y}) + +snapshotStatusShardsStatsLens :: Lens' SnapshotStatus SnapshotShardStats +snapshotStatusShardsStatsLens = + lens + snapshotStatusShardsStats + (\x y -> x {snapshotStatusShardsStats = y}) + +snapshotStatusStatsLens :: Lens' SnapshotStatus (Maybe SnapshotStats) +snapshotStatusStatsLens = lens snapshotStatusStats (\x y -> x {snapshotStatusStats = y}) + +snapshotStatusIndicesLens :: Lens' SnapshotStatus (HM.HashMap Text SnapshotIndexStatus) +snapshotStatusIndicesLens = lens snapshotStatusIndices (\x y -> x {snapshotStatusIndices = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Sort.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Sort.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Sort.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Sort.hs @@ -8,12 +8,13 @@ -- | 'SortMode' prescribes how to handle sorting array/multi-valued fields. -- --- http://www.elastic.co/guide/en/elasticsearch/reference/current/search-request-sort.html#_sort_mode_option +-- http://www.elastic.co/guide/en/elasticsearch/reference/7.17/search-request-sort.html#_sort_mode_option data SortMode = SortMin | SortMax | SortSum | SortAvg + | SortMedian deriving stock (Eq, Show) instance ToJSON SortMode where @@ -21,25 +22,40 @@ toJSON SortMax = String "max" toJSON SortSum = String "sum" toJSON SortAvg = String "avg" + toJSON SortMedian = String "median" -- | 'mkSort' defaults everything but the 'FieldName' and the 'SortOrder' so -- that you can concisely describe the usual kind of 'SortSpec's you want. mkSort :: FieldName -> SortOrder -> DefaultSort mkSort fieldName sOrder = DefaultSort fieldName sOrder Nothing Nothing Nothing Nothing +-- | 'mkGeoDistanceSort' defaults everything but the 'SortOrder' and the +-- 'GeoPoint' so the common geo sort is as concise as 'mkSort'. Use the +-- record update syntax to set @distance_type@/@mode@/@ignore_unmapped@/@nested@. +mkGeoDistanceSort :: SortOrder -> GeoPoint -> GeoDistanceSort +mkGeoDistanceSort order geoPoint = + GeoDistanceSort + { gdsSortOrder = order, + gdsGeoPoint = geoPoint, + gdsDistanceUnit = Nothing, + gdsDistanceType = Nothing, + gdsSortMode = Nothing, + gdsIgnoreUnmapped = Nothing, + gdsNested = Nothing + } + -- | 'Sort' is a synonym for a list of 'SortSpec's. Sort behavior is order -- dependent with later sorts acting as tie-breakers for earlier sorts. type Sort = [SortSpec] -- | The two main kinds of 'SortSpec' are 'DefaultSortSpec' and --- 'GeoDistanceSortSpec'. The latter takes a 'SortOrder', 'GeoPoint', and --- 'DistanceUnit' to express "nearness" to a single geographical point as a --- sort specification. +-- 'GeoDistanceSortSpec'. The latter wraps a 'GeoDistanceSort' to express +-- "nearness" to a single geographical point as a sort specification. -- --- +-- data SortSpec = DefaultSortSpec DefaultSort - | GeoDistanceSortSpec SortOrder GeoPoint DistanceUnit + | GeoDistanceSortSpec GeoDistanceSort deriving stock (Eq, Show) instance ToJSON SortSpec where @@ -51,7 +67,7 @@ dsIgnoreUnmapped dsSortMode dsMissingSort - dsNestedFilter + dsNestedSort ) ) = object [fromText dsSortFieldName .= omitNulls base] @@ -61,22 +77,34 @@ "unmapped_type" .= dsIgnoreUnmapped, "mode" .= dsSortMode, "missing" .= dsMissingSort, - "nested_filter" .= dsNestedFilter + "nested" .= dsNestedSort ] - toJSON (GeoDistanceSortSpec gdsSortOrder (GeoPoint (FieldName field) gdsLatLon) units) = - object - [ "unit" .= units, - fromText field .= gdsLatLon, - "order" .= gdsSortOrder - ] + toJSON (GeoDistanceSortSpec gds) = + object ["_geo_distance" .= omitNulls body] + where + GeoPoint (FieldName field) gdsLatLon = gdsGeoPoint gds + body = + [ fromText field .= gdsLatLon, + "order" .= gdsSortOrder gds, + "unit" .= gdsDistanceUnit gds, + "distance_type" .= gdsDistanceType gds, + "mode" .= gdsSortMode gds, + "ignore_unmapped" .= gdsIgnoreUnmapped gds, + "nested" .= gdsNested gds + ] -- | 'DefaultSort' is usually the kind of 'SortSpec' you'll want. There's a -- 'mkSort' convenience function for when you want to specify only the most -- common parameters. -- --- The `ignoreUnmapped`, when `Just` field is used to set the elastic 'unmapped_type' +-- The @ignoreUnmapped@, when @Just@, sets the elastic @unmapped_type@ +-- (a field-type name string such as @\"long\"@ or @\"keyword\"@). -- --- +-- The @nestedSort@ field replaces the legacy @nestedFilter@. Elasticsearch +-- 7.0 removed the flat @nested_filter@\/@nested_path@\/@nested_offset@ keys +-- in favour of the @nested@ object modelled by 'NestedSortValue'. +-- +-- data DefaultSort = DefaultSort { sortFieldName :: FieldName, sortOrder :: SortOrder, @@ -84,7 +112,7 @@ ignoreUnmapped :: Maybe Text, sortMode :: Maybe SortMode, missingSort :: Maybe SortMissingValue, - nestedFilter :: Maybe Filter + nestedSort :: Maybe NestedSortValue } deriving stock (Eq, Show) @@ -103,13 +131,87 @@ defaultSortMissingSortLens :: Lens' DefaultSort (Maybe SortMissingValue) defaultSortMissingSortLens = lens missingSort (\x y -> x {missingSort = y}) -defaultSortNestedFilterLens :: Lens' DefaultSort (Maybe Filter) -defaultSortNestedFilterLens = lens nestedFilter (\x y -> x {nestedFilter = y}) +defaultSortNestedSortLens :: Lens' DefaultSort (Maybe NestedSortValue) +defaultSortNestedSortLens = lens nestedSort (\x y -> x {nestedSort = y}) +-- | 'GeoDistanceSort' expresses "nearness" to a single geographical point as +-- a sort specification. Serialized under the @_geo_distance@ key per the +-- Elasticsearch sort spec. The 'GeoPoint' carries both the geo field name +-- and the 'LatLon' reference point. The @distance_type@/@mode@/@unit@/@ignore_unmapped@/@nested@ +-- fields are optional and dropped from the wire when 'Nothing'. +-- +-- +data GeoDistanceSort = GeoDistanceSort + { gdsSortOrder :: SortOrder, + gdsGeoPoint :: GeoPoint, + gdsDistanceUnit :: Maybe DistanceUnit, + gdsDistanceType :: Maybe DistanceType, + gdsSortMode :: Maybe SortMode, + gdsIgnoreUnmapped :: Maybe Bool, + gdsNested :: Maybe NestedSortValue + } + deriving stock (Eq, Show) + +geoDistanceSortSortOrderLens :: Lens' GeoDistanceSort SortOrder +geoDistanceSortSortOrderLens = lens gdsSortOrder (\x y -> x {gdsSortOrder = y}) + +geoDistanceSortGeoPointLens :: Lens' GeoDistanceSort GeoPoint +geoDistanceSortGeoPointLens = lens gdsGeoPoint (\x y -> x {gdsGeoPoint = y}) + +geoDistanceSortDistanceUnitLens :: Lens' GeoDistanceSort (Maybe DistanceUnit) +geoDistanceSortDistanceUnitLens = lens gdsDistanceUnit (\x y -> x {gdsDistanceUnit = y}) + +geoDistanceSortDistanceTypeLens :: Lens' GeoDistanceSort (Maybe DistanceType) +geoDistanceSortDistanceTypeLens = lens gdsDistanceType (\x y -> x {gdsDistanceType = y}) + +geoDistanceSortSortModeLens :: Lens' GeoDistanceSort (Maybe SortMode) +geoDistanceSortSortModeLens = lens gdsSortMode (\x y -> x {gdsSortMode = y}) + +geoDistanceSortIgnoreUnmappedLens :: Lens' GeoDistanceSort (Maybe Bool) +geoDistanceSortIgnoreUnmappedLens = lens gdsIgnoreUnmapped (\x y -> x {gdsIgnoreUnmapped = y}) + +geoDistanceSortNestedLens :: Lens' GeoDistanceSort (Maybe NestedSortValue) +geoDistanceSortNestedLens = lens gdsNested (\x y -> x {gdsNested = y}) + +-- | 'NestedSortValue' mirrors the ES @_types.NestedSortValue@ shape, used by +-- the @nested@ option of both 'DefaultSort' and 'GeoDistanceSort'. It +-- replaced the flat @nested_filter@/@nested_path@/@nested_offset@ keys +-- removed in Elasticsearch 7.0. +-- +-- +data NestedSortValue = NestedSortValue + { nestedSortPath :: FieldName, + nestedSortFilter :: Maybe Filter, + nestedSortMaxChildren :: Maybe Int, + nestedSortNested :: Maybe NestedSortValue + } + deriving stock (Eq, Show) + +instance ToJSON NestedSortValue where + toJSON (NestedSortValue nsPath nsFilter nsMaxChildren nsNested) = + omitNulls + [ "path" .= nsPath, + "filter" .= nsFilter, + "max_children" .= nsMaxChildren, + "nested" .= nsNested + ] + +nestedSortValuePathLens :: Lens' NestedSortValue FieldName +nestedSortValuePathLens = lens nestedSortPath (\x y -> x {nestedSortPath = y}) + +nestedSortValueFilterLens :: Lens' NestedSortValue (Maybe Filter) +nestedSortValueFilterLens = lens nestedSortFilter (\x y -> x {nestedSortFilter = y}) + +nestedSortValueMaxChildrenLens :: Lens' NestedSortValue (Maybe Int) +nestedSortValueMaxChildrenLens = lens nestedSortMaxChildren (\x y -> x {nestedSortMaxChildren = y}) + +nestedSortValueNestedLens :: Lens' NestedSortValue (Maybe NestedSortValue) +nestedSortValueNestedLens = lens nestedSortNested (\x y -> x {nestedSortNested = y}) + -- | 'SortOrder' is 'Ascending' or 'Descending', as you might expect. These get -- encoded into "asc" or "desc" when turned into JSON. -- --- +-- data SortOrder = Ascending | Descending @@ -122,7 +224,7 @@ -- | 'Missing' prescribes how to handle missing fields. A missing field can be -- sorted last, first, or using a custom value as a substitute. -- --- +-- data SortMissingValue = LastMissing | FirstMissing diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Suggest.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Suggest.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Suggest.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Suggest.hs @@ -3,10 +3,12 @@ module Database.Bloodhound.Internal.Versions.Common.Types.Suggest where -import qualified Data.Aeson.KeyMap as X +import Data.Aeson.KeyMap qualified as X +import Data.Map.Strict qualified as Map import Database.Bloodhound.Internal.Utils.Imports import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes import Database.Bloodhound.Internal.Versions.Common.Types.Query (Query, TemplateQueryKeyValuePairs) +import Database.Bloodhound.Internal.Versions.Common.Types.Query.Commons (Fuzziness) import GHC.Generics data Suggest = Suggest @@ -46,21 +48,76 @@ suggestTypeLens :: Lens' Suggest SuggestType suggestTypeLens = lens suggestType (\x y -> x {suggestType = y}) +-- | The suggester body of a 'Suggest' request. Each constructor wraps +-- a typed record for one of the suggesters documented at +-- +-- (and identically by OpenSearch). On the wire each variant renders as +-- a single-key object whose key names the suggester (@"phrase"@, +-- @"term"@, @"completion"@); the wrapping 'Suggest' places that object +-- under the user-chosen suggestion name. See the individual suggester +-- types for the field semantics. data SuggestType = SuggestTypePhraseSuggester PhraseSuggester + | SuggestTypeTermSuggester TermSuggester + | SuggestTypeCompletionSuggester CompletionSuggester + | -- | 'SuggestTypeContextSuggester' is a documentation-flavoured wrapper + -- around 'CompletionSuggester'. The ES \"context suggester\" + -- () + -- is not a separate wire endpoint: it is a completion suggester that + -- carries @contexts@ filters. This constructor therefore serialises + -- identically to 'SuggestTypeCompletionSuggester' (as + -- @{"completion": ...}@), and decoding a completion-shaped body always + -- yields 'SuggestTypeCompletionSuggester'. The constructor exists so + -- callers can signal intent at construction time; the wrapped + -- 'CompletionSuggester' should carry a non-empty + -- 'completionSuggesterContexts' field. + SuggestTypeContextSuggester ContextSuggester + | -- | Escape hatch for suggester types not yet modelled here, or for + -- undocumented\/future variants the server emits. The 'Text' is the + -- tag rendered as the object key and the 'Value' is the suggester body + -- preserved verbatim. 'FromJSON' produces this constructor for any + -- single-key object whose key is not @phrase@, @term@, or @completion@. + -- + -- Two caveats: (1) constructing @'SuggestTypeCustom' \"phrase\" v@ (or + -- any reserved tag) does /not/ round-trip — 'FromJSON' routes it + -- back through the typed 'PhraseSuggester' parser; use a + -- non-reserved tag. (2) Round-trip is semantically lossless ('Eq' on + -- 'Value' is preserved via @decode . encode == id@); byte-identical + -- re-emission is /not/ guaranteed for multi-key bodies, which aeson + -- reorders through its hash-ordered 'Data.Aeson.KeyMap.KeyMap'. + SuggestTypeCustom Text Value deriving stock (Eq, Show, Generic) instance ToJSON SuggestType where toJSON (SuggestTypePhraseSuggester x) = object ["phrase" .= x] + toJSON (SuggestTypeTermSuggester x) = + object ["term" .= x] + toJSON (SuggestTypeCompletionSuggester x) = + object ["completion" .= x] + toJSON (SuggestTypeContextSuggester (ContextSuggester x)) = + -- The context suggester is wire-identical to a completion + -- suggester (it /is/ a completion suggester carrying contexts); + -- emit the @completion@ tag so the server accepts the request. + object ["completion" .= x] + toJSON (SuggestTypeCustom tag x) = + object [fromText tag .= x] instance FromJSON SuggestType where parseJSON = withObject "SuggestType" parse where - parse o = phraseSuggester `taggedWith` "phrase" - where - taggedWith parser k = parser =<< o .: k - phraseSuggester = pure . SuggestTypePhraseSuggester + parse o = + case X.toList o of + [(k, v)] -> dispatch (toText k) v + _ -> fail "SuggestType must be a single-key object naming the suggester" + dispatch "phrase" v = SuggestTypePhraseSuggester <$> parseJSON v + dispatch "term" v = SuggestTypeTermSuggester <$> parseJSON v + dispatch "completion" v = SuggestTypeCompletionSuggester <$> parseJSON v + -- @"context"@ is not a real wire tag (the context suggester + -- serialises as @"completion"@); any other tag is surfaced as + -- 'SuggestTypeCustom' so unknown\/future suggester types + -- round-trip losslessly. + dispatch tag v = pure (SuggestTypeCustom tag v) data PhraseSuggester = PhraseSuggester { phraseSuggesterField :: FieldName, @@ -118,6 +175,15 @@ suggestTypePhraseSuggesterLens :: Lens' SuggestType PhraseSuggester suggestTypePhraseSuggesterLens = lens (\(SuggestTypePhraseSuggester x) -> x) (const SuggestTypePhraseSuggester) +suggestTypeTermSuggesterLens :: Lens' SuggestType TermSuggester +suggestTypeTermSuggesterLens = lens (\(SuggestTypeTermSuggester x) -> x) (const SuggestTypeTermSuggester) + +suggestTypeCompletionSuggesterLens :: Lens' SuggestType CompletionSuggester +suggestTypeCompletionSuggesterLens = lens (\(SuggestTypeCompletionSuggester x) -> x) (const SuggestTypeCompletionSuggester) + +suggestTypeContextSuggesterLens :: Lens' SuggestType ContextSuggester +suggestTypeContextSuggesterLens = lens (\(SuggestTypeContextSuggester x) -> x) (const SuggestTypeContextSuggester) + mkPhraseSuggester :: FieldName -> PhraseSuggester mkPhraseSuggester fName = PhraseSuggester @@ -232,6 +298,399 @@ phraseSuggesterCollatePruneLens :: Lens' PhraseSuggesterCollate Bool phraseSuggesterCollatePruneLens = lens phraseSuggesterCollatePrune (\x y -> x {phraseSuggesterCollatePrune = y}) + +-- ---------------------------------------------------------------------- +-- Term suggester +-- ---------------------------------------------------------------------- + +-- | Sort order for the term suggester's candidate ranking, rendered as +-- @score@ (the server default; rank by similarity) or @frequency@ (rank +-- by document frequency first, then similarity). See +-- . +data TermSuggesterSort + = TermSuggesterSortScore + | TermSuggesterSortFrequency + deriving stock (Eq, Show, Generic) + +instance ToJSON TermSuggesterSort where + toJSON TermSuggesterSortScore = "score" + toJSON TermSuggesterSortFrequency = "frequency" + +instance FromJSON TermSuggesterSort where + parseJSON = withText "TermSuggesterSort" parse + where + parse "score" = pure TermSuggesterSortScore + parse "frequency" = pure TermSuggesterSortFrequency + parse s = fail ("Unexpected TermSuggesterSort: " <> show s) + +-- | String-distance algorithm the term suggester uses to rank +-- candidates, rendered verbatim as the @string_distance@ value. +-- @internal@ (the default) is Lucene's built-in Levenshtein; the others +-- trade accuracy for performance. +data TermSuggesterStringDistance + = TermSuggesterStringDistanceInternal + | TermSuggesterStringDistanceDamerauLevenshtein + | TermSuggesterStringDistanceLevenshtein + | TermSuggesterStringDistanceJaroWinkler + | TermSuggesterStringDistanceNgram + deriving stock (Eq, Show, Generic) + +instance ToJSON TermSuggesterStringDistance where + toJSON TermSuggesterStringDistanceInternal = "internal" + toJSON TermSuggesterStringDistanceDamerauLevenshtein = "damerau_levenshtein" + toJSON TermSuggesterStringDistanceLevenshtein = "levenshtein" + toJSON TermSuggesterStringDistanceJaroWinkler = "jarowinkler" + toJSON TermSuggesterStringDistanceNgram = "ngram" + +instance FromJSON TermSuggesterStringDistance where + parseJSON = withText "TermSuggesterStringDistance" parse + where + parse "internal" = pure TermSuggesterStringDistanceInternal + parse "damerau_levenshtein" = pure TermSuggesterStringDistanceDamerauLevenshtein + parse "levenshtein" = pure TermSuggesterStringDistanceLevenshtein + parse "jarowinkler" = pure TermSuggesterStringDistanceJaroWinkler + parse "ngram" = pure TermSuggesterStringDistanceNgram + parse s = fail ("Unexpected TermSuggesterStringDistance: " <> show s) + +-- | The @term@ suggester, the simplest of the four documented suggester +-- types. It offers term-level corrections for a single field based on +-- edit distance. The field set mirrors +-- +-- and is identical in OpenSearch. Many fields overlap with +-- 'DirectGenerators' (the per-candidate body of a phrase suggester's +-- @direct_generator@); they are repeated here because the term +-- suggester carries them at the top level of its own body, plus the +-- @sort@ and @string_distance@ knobs that are not legal inside a +-- @direct_generator@. +data TermSuggester = TermSuggester + { termSuggesterField :: FieldName, + termSuggesterAnalyzer :: Maybe Analyzer, + termSuggesterSize :: Maybe Int, + termSuggesterSort :: Maybe TermSuggesterSort, + -- | @suggest_mode@ controls suggestion inclusion for terms present + -- in the source. Defaults to @missing@ server-side. The field is + -- non-'Maybe' (and therefore always emitted, like + -- 'directGeneratorSuggestMode' on 'DirectGenerators'); on decode, + -- however, it /intentionally diverges/ from 'DirectGenerators' by + -- defaulting a missing field to 'DirectGeneratorSuggestModeMissing' + -- rather than rejecting the body, so a minimal + -- @{"term":{"field":"x"}}@ decodes successfully. + termSuggesterSuggestMode :: DirectGeneratorSuggestModeTypes, + termSuggesterMaxEdits :: Maybe Double, + termSuggesterPrefixLength :: Maybe Int, + termSuggesterMinWordLength :: Maybe Int, + termSuggesterMaxInspections :: Maybe Int, + termSuggesterMinDocFreq :: Maybe Double, + termSuggesterMaxTermFreq :: Maybe Double, + termSuggesterStringDistance :: Maybe TermSuggesterStringDistance, + termSuggesterPreFilter :: Maybe Text, + termSuggesterPostFilter :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance ToJSON TermSuggester where + toJSON TermSuggester {..} = + omitNulls + [ "field" .= termSuggesterField, + "analyzer" .= termSuggesterAnalyzer, + "size" .= termSuggesterSize, + "sort" .= termSuggesterSort, + "suggest_mode" .= termSuggesterSuggestMode, + "max_edits" .= termSuggesterMaxEdits, + "prefix_length" .= termSuggesterPrefixLength, + "min_word_length" .= termSuggesterMinWordLength, + "max_inspections" .= termSuggesterMaxInspections, + "min_doc_freq" .= termSuggesterMinDocFreq, + "max_term_freq" .= termSuggesterMaxTermFreq, + "string_distance" .= termSuggesterStringDistance, + "pre_filter" .= termSuggesterPreFilter, + "post_filter" .= termSuggesterPostFilter + ] + +instance FromJSON TermSuggester where + parseJSON = withObject "TermSuggester" parse + where + parse o = + TermSuggester + <$> o .: "field" + <*> o .:? "analyzer" + <*> o .:? "size" + <*> o .:? "sort" + <*> o .:? "suggest_mode" .!= DirectGeneratorSuggestModeMissing + <*> o .:? "max_edits" + <*> o .:? "prefix_length" + <*> o .:? "min_word_length" + <*> o .:? "max_inspections" + <*> o .:? "min_doc_freq" + <*> o .:? "max_term_freq" + <*> o .:? "string_distance" + <*> o .:? "pre_filter" + <*> o .:? "post_filter" + +-- | Minimal 'TermSuggester' targeting a field with every tuning knob +-- at its server default (only @field@ is required by the docs). +mkTermSuggester :: FieldName -> TermSuggester +mkTermSuggester fName = + TermSuggester + { termSuggesterField = fName, + termSuggesterAnalyzer = Nothing, + termSuggesterSize = Nothing, + termSuggesterSort = Nothing, + termSuggesterSuggestMode = DirectGeneratorSuggestModeMissing, + termSuggesterMaxEdits = Nothing, + termSuggesterPrefixLength = Nothing, + termSuggesterMinWordLength = Nothing, + termSuggesterMaxInspections = Nothing, + termSuggesterMinDocFreq = Nothing, + termSuggesterMaxTermFreq = Nothing, + termSuggesterStringDistance = Nothing, + termSuggesterPreFilter = Nothing, + termSuggesterPostFilter = Nothing + } + +termSuggesterFieldLens :: Lens' TermSuggester FieldName +termSuggesterFieldLens = lens termSuggesterField (\x y -> x {termSuggesterField = y}) + +termSuggesterAnalyzerLens :: Lens' TermSuggester (Maybe Analyzer) +termSuggesterAnalyzerLens = lens termSuggesterAnalyzer (\x y -> x {termSuggesterAnalyzer = y}) + +termSuggesterSizeLens :: Lens' TermSuggester (Maybe Int) +termSuggesterSizeLens = lens termSuggesterSize (\x y -> x {termSuggesterSize = y}) + +termSuggesterSortLens :: Lens' TermSuggester (Maybe TermSuggesterSort) +termSuggesterSortLens = lens termSuggesterSort (\x y -> x {termSuggesterSort = y}) + +termSuggesterSuggestModeLens :: Lens' TermSuggester DirectGeneratorSuggestModeTypes +termSuggesterSuggestModeLens = lens termSuggesterSuggestMode (\x y -> x {termSuggesterSuggestMode = y}) + +termSuggesterMaxEditsLens :: Lens' TermSuggester (Maybe Double) +termSuggesterMaxEditsLens = lens termSuggesterMaxEdits (\x y -> x {termSuggesterMaxEdits = y}) + +termSuggesterPrefixLengthLens :: Lens' TermSuggester (Maybe Int) +termSuggesterPrefixLengthLens = lens termSuggesterPrefixLength (\x y -> x {termSuggesterPrefixLength = y}) + +termSuggesterMinWordLengthLens :: Lens' TermSuggester (Maybe Int) +termSuggesterMinWordLengthLens = lens termSuggesterMinWordLength (\x y -> x {termSuggesterMinWordLength = y}) + +termSuggesterMaxInspectionsLens :: Lens' TermSuggester (Maybe Int) +termSuggesterMaxInspectionsLens = lens termSuggesterMaxInspections (\x y -> x {termSuggesterMaxInspections = y}) + +termSuggesterMinDocFreqLens :: Lens' TermSuggester (Maybe Double) +termSuggesterMinDocFreqLens = lens termSuggesterMinDocFreq (\x y -> x {termSuggesterMinDocFreq = y}) + +termSuggesterMaxTermFreqLens :: Lens' TermSuggester (Maybe Double) +termSuggesterMaxTermFreqLens = lens termSuggesterMaxTermFreq (\x y -> x {termSuggesterMaxTermFreq = y}) + +termSuggesterStringDistanceLens :: Lens' TermSuggester (Maybe TermSuggesterStringDistance) +termSuggesterStringDistanceLens = lens termSuggesterStringDistance (\x y -> x {termSuggesterStringDistance = y}) + +termSuggesterPreFilterLens :: Lens' TermSuggester (Maybe Text) +termSuggesterPreFilterLens = lens termSuggesterPreFilter (\x y -> x {termSuggesterPreFilter = y}) + +termSuggesterPostFilterLens :: Lens' TermSuggester (Maybe Text) +termSuggesterPostFilterLens = lens termSuggesterPostFilter (\x y -> x {termSuggesterPostFilter = y}) + +-- ---------------------------------------------------------------------- +-- Completion suggester +-- ---------------------------------------------------------------------- + +-- | A single filter value inside a completion suggester's @contexts@ +-- map. ES supports two context flavours — @category@ (string) and +-- @geo@ — but on the wire a bare value is always a JSON string (the +-- server interprets it according to the field's context definition) and +-- a boosted value is always the object form below. The lat\/lon object +-- form for geo contexts is not modelled here; track as a follow-up if a +-- caller needs it, or fall through to 'SuggestTypeCustom'. +data ContextQueryValue + = -- | Bare value (a category string or a geohash), rendered as a JSON + -- string. Decoding a bare JSON string always yields this + -- constructor; the category\/geo distinction is server-side. + ContextQueryValueText Text + | -- | Boosted value: @{"context": , "boost": }@. + ContextQueryValueBoosted Text Int + deriving stock (Eq, Show, Generic) + +instance ToJSON ContextQueryValue where + toJSON (ContextQueryValueText t) = toJSON t + toJSON (ContextQueryValueBoosted t b) = object ["context" .= t, "boost" .= b] + +instance FromJSON ContextQueryValue where + parseJSON (String t) = pure (ContextQueryValueText t) + parseJSON v = + -- @boost@ is optional on the wire (it defaults to @1@ server-side), + -- so a bare @{"context": "x"}@ is accepted for interop with + -- externally-supplied bodies. Re-encoding always emits @boost@ + -- explicitly, which round-trips because the decoded + -- 'ContextQueryValueBoosted' carries the defaulted value. + withObject + "ContextQueryValue" + (\o -> ContextQueryValueBoosted <$> o .: "context" <*> o .:? "boost" .!= 1) + v + +-- | Fuzzy sub-block of a completion suggester. Rendered as the +-- @fuzzy@ object. Every field is optional; a record of all-@Nothing@ +-- fields renders as @{}@, which the server treats identically to +-- @true@. Use 'Fuzziness' (re-exported from the query layer) for the +-- @fuzziness@ knob. +data CompletionSuggesterFuzzy = CompletionSuggesterFuzzy + { completionSuggesterFuzzyFuzziness :: Maybe Fuzziness, + completionSuggesterFuzzyTranspositions :: Maybe Bool, + completionSuggesterFuzzyMinLength :: Maybe Int, + completionSuggesterFuzzyPrefixLength :: Maybe Int, + completionSuggesterFuzzyUnicodeAware :: Maybe Bool + } + deriving stock (Eq, Show, Generic) + +instance ToJSON CompletionSuggesterFuzzy where + toJSON CompletionSuggesterFuzzy {..} = + omitNulls + [ "fuzziness" .= completionSuggesterFuzzyFuzziness, + "transpositions" .= completionSuggesterFuzzyTranspositions, + "min_length" .= completionSuggesterFuzzyMinLength, + "prefix_length" .= completionSuggesterFuzzyPrefixLength, + "unicode_aware" .= completionSuggesterFuzzyUnicodeAware + ] + +instance FromJSON CompletionSuggesterFuzzy where + parseJSON = withObject "CompletionSuggesterFuzzy" parse + where + parse o = + CompletionSuggesterFuzzy + <$> o .:? "fuzziness" + <*> o .:? "transpositions" + <*> o .:? "min_length" + <*> o .:? "prefix_length" + <*> o .:? "unicode_aware" + +completionSuggesterFuzzyFuzzinessLens :: Lens' CompletionSuggesterFuzzy (Maybe Fuzziness) +completionSuggesterFuzzyFuzzinessLens = lens completionSuggesterFuzzyFuzziness (\x y -> x {completionSuggesterFuzzyFuzziness = y}) + +completionSuggesterFuzzyTranspositionsLens :: Lens' CompletionSuggesterFuzzy (Maybe Bool) +completionSuggesterFuzzyTranspositionsLens = lens completionSuggesterFuzzyTranspositions (\x y -> x {completionSuggesterFuzzyTranspositions = y}) + +completionSuggesterFuzzyMinLengthLens :: Lens' CompletionSuggesterFuzzy (Maybe Int) +completionSuggesterFuzzyMinLengthLens = lens completionSuggesterFuzzyMinLength (\x y -> x {completionSuggesterFuzzyMinLength = y}) + +completionSuggesterFuzzyPrefixLengthLens :: Lens' CompletionSuggesterFuzzy (Maybe Int) +completionSuggesterFuzzyPrefixLengthLens = lens completionSuggesterFuzzyPrefixLength (\x y -> x {completionSuggesterFuzzyPrefixLength = y}) + +completionSuggesterFuzzyUnicodeAwareLens :: Lens' CompletionSuggesterFuzzy (Maybe Bool) +completionSuggesterFuzzyUnicodeAwareLens = lens completionSuggesterFuzzyUnicodeAware (\x y -> x {completionSuggesterFuzzyUnicodeAware = y}) + +-- | The @completion@ suggester, an auto-complete style suggester backed +-- by an in-memory FST. Field set mirrors +-- . +-- The @contexts@ field carries the context filters used by the sibling +-- \"context suggester\" — modelled here (rather than as a separate wire +-- shape) because the two are wire-identical apart from intent. See +-- 'SuggestTypeContextSuggester' for the intent-signalling wrapper. +-- +-- @contexts@ is a 'Map.Map' (not an association list) because the wire +-- shape is a JSON object, whose key order is unordered; using 'Map.Map' +-- gives order-independent equality, so @decode . encode == id@ holds +-- irrespective of how aeson orders object keys through its hash-ordered +-- 'Data.Aeson.KeyMap.KeyMap' on the wire. +data CompletionSuggester = CompletionSuggester + { completionSuggesterField :: FieldName, + completionSuggesterAnalyzer :: Maybe Analyzer, + completionSuggesterSize :: Maybe Int, + completionSuggesterSkipDuplicates :: Maybe Bool, + completionSuggesterFuzzy :: Maybe CompletionSuggesterFuzzy, + -- | Optional @contexts@ filters: a map from context name to a + -- non-empty list of filter values. 'Nothing' renders no @contexts@ + -- field; an empty map renders @"contexts": {}@. The two are + -- distinguished on the wire so the value round-trips. + completionSuggesterContexts :: Maybe (Map.Map Text (NonEmpty ContextQueryValue)) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON CompletionSuggester where + toJSON CompletionSuggester {..} = + omitNulls + [ "field" .= completionSuggesterField, + "analyzer" .= completionSuggesterAnalyzer, + "size" .= completionSuggesterSize, + "skip_duplicates" .= completionSuggesterSkipDuplicates, + "fuzzy" .= completionSuggesterFuzzy, + -- @Nothing@ renders as @null@ (elided by 'omitNulls'); @Just m@ + -- renders as the @contexts@ object via aeson's 'Map' instance. + -- An empty map renders as @"contexts": {}@, which decodes back + -- to @Just mempty@, preserving the @Nothing@ / @Just mempty@ + -- distinction required for round-trip. + "contexts" .= completionSuggesterContexts + ] + +instance FromJSON CompletionSuggester where + parseJSON = withObject "CompletionSuggester" parse + where + parse o = + CompletionSuggester + <$> o .: "field" + <*> o .:? "analyzer" + <*> o .:? "size" + <*> o .:? "skip_duplicates" + <*> o .:? "fuzzy" + <*> o .:? "contexts" + +-- | Minimal 'CompletionSuggester' targeting a field with every optional +-- knob at its server default. +mkCompletionSuggester :: FieldName -> CompletionSuggester +mkCompletionSuggester fName = + CompletionSuggester + { completionSuggesterField = fName, + completionSuggesterAnalyzer = Nothing, + completionSuggesterSize = Nothing, + completionSuggesterSkipDuplicates = Nothing, + completionSuggesterFuzzy = Nothing, + completionSuggesterContexts = Nothing + } + +completionSuggesterFieldLens :: Lens' CompletionSuggester FieldName +completionSuggesterFieldLens = lens completionSuggesterField (\x y -> x {completionSuggesterField = y}) + +completionSuggesterAnalyzerLens :: Lens' CompletionSuggester (Maybe Analyzer) +completionSuggesterAnalyzerLens = lens completionSuggesterAnalyzer (\x y -> x {completionSuggesterAnalyzer = y}) + +completionSuggesterSizeLens :: Lens' CompletionSuggester (Maybe Int) +completionSuggesterSizeLens = lens completionSuggesterSize (\x y -> x {completionSuggesterSize = y}) + +completionSuggesterSkipDuplicatesLens :: Lens' CompletionSuggester (Maybe Bool) +completionSuggesterSkipDuplicatesLens = lens completionSuggesterSkipDuplicates (\x y -> x {completionSuggesterSkipDuplicates = y}) + +completionSuggesterFuzzyLens :: Lens' CompletionSuggester (Maybe CompletionSuggesterFuzzy) +completionSuggesterFuzzyLens = lens completionSuggesterFuzzy (\x y -> x {completionSuggesterFuzzy = y}) + +completionSuggesterContextsLens :: Lens' CompletionSuggester (Maybe (Map.Map Text (NonEmpty ContextQueryValue))) +completionSuggesterContextsLens = lens completionSuggesterContexts (\x y -> x {completionSuggesterContexts = y}) + +-- ---------------------------------------------------------------------- +-- Context suggester (intent wrapper around a completion suggester) +-- ---------------------------------------------------------------------- + +-- | Intent-signalling wrapper around 'CompletionSuggester'. The ES +-- \"context suggester\" +-- () +-- is not a separate wire shape: it is a completion suggester that +-- carries @contexts@ filters. This newtype therefore derives its JSON +-- instances from 'CompletionSuggester', and 'SuggestTypeContextSuggester' +-- serialises it under the @completion@ tag. Construct it with a +-- 'CompletionSuggester' whose 'completionSuggesterContexts' is +-- non-empty. Decoding always yields 'SuggestTypeCompletionSuggester' +-- (see 'SuggestType'). +newtype ContextSuggester = ContextSuggester + { unContextSuggester :: CompletionSuggester + } + deriving stock (Eq, Show, Generic) + deriving newtype (ToJSON, FromJSON) + +-- | Build a 'ContextSuggester' from a 'CompletionSuggester'. No checks +-- are performed; callers are expected to supply a non-empty +-- 'completionSuggesterContexts'. +mkContextSuggester :: CompletionSuggester -> ContextSuggester +mkContextSuggester = ContextSuggester + +contextSuggesterCompletionSuggesterLens :: Lens' ContextSuggester CompletionSuggester +contextSuggesterCompletionSuggesterLens = lens unContextSuggester (\x y -> x {unContextSuggester = y}) data SuggestOptions = SuggestOptions { suggestOptionsText :: Text, diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Task.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Task.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Task.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Task.hs @@ -2,15 +2,20 @@ module Database.Bloodhound.Internal.Versions.Common.Types.Task where +import Control.Monad (forM) import Data.Aeson +import Data.Aeson.Key (toText) +import Data.Aeson.KeyMap qualified as KM import Data.Text (Text) +import Data.Word (Word32) +import Database.Bloodhound.Internal.Versions.Common.Types.Units (TimeUnits) import GHC.Generics import Optics.Lens data TaskResponse a = TaskResponse { taskResponseCompleted :: Bool, taskResponseTask :: Task a, - taskResponseReponse :: Maybe a, + taskResponseResponse :: Maybe a, taskResponseError :: Maybe Object } deriving stock (Eq, Show, Generic) @@ -20,7 +25,7 @@ TaskResponse <$> v .: "completed" <*> v .: "task" - <*> v .:? "reponse" + <*> (v .:? "response" >>= maybe (v .:? "reponse") (pure . Just)) <*> v .:? "error" taskResponseCompletedLens :: Lens' (TaskResponse a) Bool @@ -29,8 +34,8 @@ taskResponseTaskLens :: Lens' (TaskResponse a) (Task a) taskResponseTaskLens = lens taskResponseTask (\x y -> x {taskResponseTask = y}) -taskResponseReponseLens :: Lens' (TaskResponse a) (Maybe a) -taskResponseReponseLens = lens taskResponseReponse (\x y -> x {taskResponseReponse = y}) +taskResponseResponseLens :: Lens' (TaskResponse a) (Maybe a) +taskResponseResponseLens = lens taskResponseResponse (\x y -> x {taskResponseResponse = y}) taskResponseErrorLens :: Lens' (TaskResponse a) (Maybe Object) taskResponseErrorLens = lens taskResponseError (\x y -> x {taskResponseError = y}) @@ -44,7 +49,9 @@ taskDescription :: Text, taskStartTimeInMillis :: Integer, taskRunningTimeInNanos :: Integer, - taskCancellable :: Bool + taskCancellable :: Bool, + taskParentTaskId :: Maybe Text, + taskHeaders :: Maybe Object } deriving stock (Eq, Show, Generic) @@ -60,6 +67,8 @@ <*> v .: "start_time_in_millis" <*> v .: "running_time_in_nanos" <*> v .: "cancellable" + <*> v .:? "parent_task_id" + <*> v .:? "headers" newtype TaskNodeId = TaskNodeId Text deriving stock (Eq, Show) @@ -93,3 +102,297 @@ taskCancellableLens :: Lens' (Task a) Bool taskCancellableLens = lens taskCancellable (\x y -> x {taskCancellable = y}) + +taskParentTaskIdLens :: Lens' (Task a) (Maybe Text) +taskParentTaskIdLens = lens taskParentTaskId (\x y -> x {taskParentTaskId = y}) + +taskHeadersLens :: Lens' (Task a) (Maybe Object) +taskHeadersLens = lens taskHeaders (\x y -> x {taskHeaders = y}) + +-- $taskParentTaskIdSentinel +-- +-- /Note/: like 'TaskInfo', Elasticsearch emits @"parent_task_id": "-1"@ +-- (present, not absent) for top-level tasks with no parent on the +-- single-task GET endpoint. The decoder keeps this verbatim, so +-- 'taskParentTaskId' is @'Just' "-1"@ — not 'Nothing' — for such +-- tasks. Callers that want \"has no parent\" semantics should test for +-- both 'Nothing' and @'Just' "-1"@. + +-- $taskList +-- +-- /List tasks/ (@GET /_tasks@) returns every currently running task on +-- the cluster (optionally filtered). Unlike the single-task 'Task a' +-- record, the list endpoint does not return a typed per-task @status@ +-- payload, so 'TaskInfo' models only the task's own fields. The response +-- is grouped by node by default; see 'TaskListResponse' and +-- 'taskListFlat'. + +-- | A single task as returned by @GET /_tasks@. Each 'taskInfoNode' +-- carries its originating node id, so flattening a 'TaskListResponse' +-- with 'taskListFlat' loses no task-level context. +data TaskInfo = TaskInfo + { taskInfoNode :: Text, + taskInfoId :: Int, + taskInfoType :: Text, + taskInfoAction :: Text, + taskInfoDescription :: Maybe Text, + taskInfoStartTimeInMillis :: Integer, + taskInfoRunningTimeInNanos :: Integer, + taskInfoCancellable :: Bool, + taskInfoParentTaskId :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON TaskInfo where + parseJSON = withObject "TaskInfo" $ \v -> + TaskInfo + <$> v .: "node" + <*> v .: "id" + <*> v .: "type" + <*> v .: "action" + <*> v .:? "description" + <*> v .: "start_time_in_millis" + <*> v .: "running_time_in_nanos" + <*> v .: "cancellable" + <*> v .:? "parent_task_id" + +taskInfoNodeLens :: Lens' TaskInfo Text +taskInfoNodeLens = lens taskInfoNode (\x y -> x {taskInfoNode = y}) + +taskInfoIdLens :: Lens' TaskInfo Int +taskInfoIdLens = lens taskInfoId (\x y -> x {taskInfoId = y}) + +taskInfoTypeLens :: Lens' TaskInfo Text +taskInfoTypeLens = lens taskInfoType (\x y -> x {taskInfoType = y}) + +taskInfoActionLens :: Lens' TaskInfo Text +taskInfoActionLens = lens taskInfoAction (\x y -> x {taskInfoAction = y}) + +taskInfoDescriptionLens :: Lens' TaskInfo (Maybe Text) +taskInfoDescriptionLens = lens taskInfoDescription (\x y -> x {taskInfoDescription = y}) + +taskInfoStartTimeInMillisLens :: Lens' TaskInfo Integer +taskInfoStartTimeInMillisLens = lens taskInfoStartTimeInMillis (\x y -> x {taskInfoStartTimeInMillis = y}) + +taskInfoRunningTimeInNanosLens :: Lens' TaskInfo Integer +taskInfoRunningTimeInNanosLens = lens taskInfoRunningTimeInNanos (\x y -> x {taskInfoRunningTimeInNanos = y}) + +taskInfoCancellableLens :: Lens' TaskInfo Bool +taskInfoCancellableLens = lens taskInfoCancellable (\x y -> x {taskInfoCancellable = y}) + +taskInfoParentTaskIdLens :: Lens' TaskInfo (Maybe Text) +taskInfoParentTaskIdLens = lens taskInfoParentTaskId (\x y -> x {taskInfoParentTaskId = y}) + +-- $parentTaskIdSentinel +-- +-- /Note/: Elasticsearch emits @"parent_task_id": "-1"@ (present, not +-- absent) for top-level tasks with no parent. The decoder keeps this +-- verbatim, so 'taskInfoParentTaskId' is @'Just' "-1"@ — not +-- 'Nothing' — for such tasks. Callers that want \"has no parent\" +-- semantics should test for both 'Nothing' and @'Just' "-1"@. + +-- | One node entry within the @nodes@ map of a 'TaskListResponse'. The +-- @tasks@ sub-object is decoded into a flat list of 'TaskInfo'. Node +-- envelope fields other than the id are optional because backends (ES +-- vs OpenSearch) and versions differ in which they emit. +-- +-- /Note/: 'taskListNodeId' is a placeholder (@""@) when a node value is +-- decoded in isolation; the 'TaskListResponse' decoder stamps it with +-- the @nodes@ map key (the real node id), mirroring the +-- 'Database.Bloodhound.Internal.Versions.Common.Types.ILM.ILMPolicies' +-- id-stamping convention. +data TaskListNode = TaskListNode + { taskListNodeId :: Text, + taskListNodeName :: Maybe Text, + taskListNodeTransportAddress :: Maybe Text, + taskListNodeHost :: Maybe Text, + taskListNodeIp :: Maybe Text, + taskListNodeTasks :: [TaskInfo] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON TaskListNode where + parseJSON = withObject "TaskListNode" $ \v -> do + tasksObj <- v .:? "tasks" .!= KM.empty + tasks <- forM (KM.toList tasksObj) $ \(_, taskVal) -> parseJSON taskVal + name <- v .:? "name" + transportAddress <- v .:? "transport_address" + host <- v .:? "host" + ip <- v .:? "ip" + pure + TaskListNode + { taskListNodeId = "", + taskListNodeName = name, + taskListNodeTransportAddress = transportAddress, + taskListNodeHost = host, + taskListNodeIp = ip, + taskListNodeTasks = tasks + } + +taskListNodeIdLens :: Lens' TaskListNode Text +taskListNodeIdLens = lens taskListNodeId (\x y -> x {taskListNodeId = y}) + +taskListNodeNameLens :: Lens' TaskListNode (Maybe Text) +taskListNodeNameLens = lens taskListNodeName (\x y -> x {taskListNodeName = y}) + +taskListNodeTransportAddressLens :: Lens' TaskListNode (Maybe Text) +taskListNodeTransportAddressLens = lens taskListNodeTransportAddress (\x y -> x {taskListNodeTransportAddress = y}) + +taskListNodeHostLens :: Lens' TaskListNode (Maybe Text) +taskListNodeHostLens = lens taskListNodeHost (\x y -> x {taskListNodeHost = y}) + +taskListNodeIpLens :: Lens' TaskListNode (Maybe Text) +taskListNodeIpLens = lens taskListNodeIp (\x y -> x {taskListNodeIp = y}) + +taskListNodeTasksLens :: Lens' TaskListNode [TaskInfo] +taskListNodeTasksLens = lens taskListNodeTasks (\x y -> x {taskListNodeTasks = y}) + +-- | The response of @GET /_tasks@ with the default @group_by=nodes@ +-- (the server default). The top-level @nodes@ object is decoded into a +-- list of 'TaskListNode'; the map key (the node id) is stamped onto +-- 'taskListNodeId'. Use 'taskListFlat' to recover a flat list of every +-- task across all nodes. +-- +-- /Note/: the @group_by@ URI parameter (@parents@ or @none@) changes +-- the response shape; only the default @nodes@ grouping is modelled +-- here, matching the precedent of other list endpoints in this module. +newtype TaskListResponse = TaskListResponse + { taskListResponseNodes :: [TaskListNode] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON TaskListResponse where + parseJSON = withObject "TaskListResponse" $ \o -> do + nodesMap <- o .: "nodes" + nodes <- forM (KM.toList nodesMap) $ \(nodeKey, nodeVal) -> do + node <- parseJSON nodeVal + pure (node {taskListNodeId = toText nodeKey}) + pure (TaskListResponse nodes) + +taskListResponseNodesLens :: Lens' TaskListResponse [TaskListNode] +taskListResponseNodesLens = lens taskListResponseNodes (\x y -> x {taskListResponseNodes = y}) + +-- | Flatten a 'TaskListResponse' into the list of every 'TaskInfo' it +-- contains, across all nodes. This recovers the @['TaskInfo']@ view +-- implied by the @GET /_tasks@ acceptance. +taskListFlat :: TaskListResponse -> [TaskInfo] +taskListFlat = concatMap taskListNodeTasks . taskListResponseNodes + +-- | @group_by@ URI parameter for @GET /_tasks@. Controls how the server +-- groups tasks in the response. Only 'TaskListGroupByNodes' (the server +-- default) is faithfully modelled by 'TaskListResponse'; the other +-- variants still render correctly on the wire but their response shape +-- is not decoded. +data TaskListGroupBy + = TaskListGroupByNodes + | TaskListGroupByParents + | TaskListGroupByNone + deriving stock (Eq, Show) + +renderTaskListGroupBy :: TaskListGroupBy -> Text +renderTaskListGroupBy TaskListGroupByNodes = "nodes" +renderTaskListGroupBy TaskListGroupByParents = "parents" +renderTaskListGroupBy TaskListGroupByNone = "none" + +-- | The commonly-used URI parameters accepted by @GET /_tasks@: +-- @nodes@, @actions@, @detailed@, @parent_task_id@, +-- @wait_for_completion@, @timeout@ and @group_by@. Every field is +-- optional so 'defaultTaskListOptions' renders to no parameters at all +-- — byte-for-byte identical to a parameterless call. +data TaskListOptions = TaskListOptions + { taskListOptionsNodes :: Maybe [Text], + taskListOptionsActions :: Maybe [Text], + taskListOptionsDetailed :: Maybe Bool, + taskListOptionsParentTaskId :: Maybe Text, + taskListOptionsWaitForCompletion :: Maybe Bool, + taskListOptionsTimeout :: Maybe (TimeUnits, Word32), + taskListOptionsGroupBy :: Maybe TaskListGroupBy + } + deriving stock (Eq, Show) + +-- | 'TaskListOptions' with every parameter set to 'Nothing'. Produces no +-- query string, so @'listTasks' ('Just' 'defaultTaskListOptions')@ emits +-- a request identical to @'listTasks' 'Nothing'@. +defaultTaskListOptions :: TaskListOptions +defaultTaskListOptions = + TaskListOptions + { taskListOptionsNodes = Nothing, + taskListOptionsActions = Nothing, + taskListOptionsDetailed = Nothing, + taskListOptionsParentTaskId = Nothing, + taskListOptionsWaitForCompletion = Nothing, + taskListOptionsTimeout = Nothing, + taskListOptionsGroupBy = Nothing + } + +taskListOptionsNodesLens :: Lens' TaskListOptions (Maybe [Text]) +taskListOptionsNodesLens = lens taskListOptionsNodes (\x y -> x {taskListOptionsNodes = y}) + +taskListOptionsActionsLens :: Lens' TaskListOptions (Maybe [Text]) +taskListOptionsActionsLens = lens taskListOptionsActions (\x y -> x {taskListOptionsActions = y}) + +taskListOptionsDetailedLens :: Lens' TaskListOptions (Maybe Bool) +taskListOptionsDetailedLens = lens taskListOptionsDetailed (\x y -> x {taskListOptionsDetailed = y}) + +taskListOptionsParentTaskIdLens :: Lens' TaskListOptions (Maybe Text) +taskListOptionsParentTaskIdLens = lens taskListOptionsParentTaskId (\x y -> x {taskListOptionsParentTaskId = y}) + +taskListOptionsWaitForCompletionLens :: Lens' TaskListOptions (Maybe Bool) +taskListOptionsWaitForCompletionLens = lens taskListOptionsWaitForCompletion (\x y -> x {taskListOptionsWaitForCompletion = y}) + +taskListOptionsTimeoutLens :: Lens' TaskListOptions (Maybe (TimeUnits, Word32)) +taskListOptionsTimeoutLens = lens taskListOptionsTimeout (\x y -> x {taskListOptionsTimeout = y}) + +taskListOptionsGroupByLens :: Lens' TaskListOptions (Maybe TaskListGroupBy) +taskListOptionsGroupByLens = lens taskListOptionsGroupBy (\x y -> x {taskListOptionsGroupBy = y}) + +-- $taskGet +-- +-- /Get task/ (@GET /_tasks/{task_id}@) returns the current state of a +-- single task. Unlike the list endpoint, it cannot be filtered by node +-- or action, so 'TaskGetOptions' exposes only the URI parameters +-- documented at +-- +-- and +-- : +-- @wait_for_completion@ and @timeout@. +-- +-- /Note/: @detailed@ is intentionally omitted. Unlike @GET /_tasks@ +-- ('TaskListOptions'), the single-task endpoint always returns the full +-- task description, so Elasticsearch and OpenSearch reject +-- @?detailed=...@ with HTTP 400 (@contains unrecognized parameter: +-- [detailed]@). The same applies to @nodes@, @actions@, @parent_task_id@ +-- and @group_by@ — see 'TaskListOptions' for those. +-- +-- OpenSearch additionally documents @master_timeout@, +-- @cluster_manager_timeout@ and @request_timeout@ for this endpoint; +-- they are intentionally omitted here to match the Elasticsearch +-- contract. A future bead can widen the type if cross-backend parity is +-- needed. + +-- | The URI parameters accepted by @GET /_tasks/{task_id}@: +-- @wait_for_completion@ and @timeout@. Every field is optional so +-- 'defaultTaskGetOptions' renders to no parameters at all — +-- byte-for-byte identical to a parameterless call. +data TaskGetOptions = TaskGetOptions + { taskGetOptionsWaitForCompletion :: Maybe Bool, + taskGetOptionsTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'TaskGetOptions' with every parameter set to 'Nothing'. Produces no +-- query string, so @'Database.Bloodhound.Common.Requests.getTaskWith' +-- 'defaultTaskGetOptions'@ emits a request identical to +-- 'Database.Bloodhound.Common.Requests.getTask'. +defaultTaskGetOptions :: TaskGetOptions +defaultTaskGetOptions = + TaskGetOptions + { taskGetOptionsWaitForCompletion = Nothing, + taskGetOptionsTimeout = Nothing + } + +taskGetOptionsWaitForCompletionLens :: Lens' TaskGetOptions (Maybe Bool) +taskGetOptionsWaitForCompletionLens = lens taskGetOptionsWaitForCompletion (\x y -> x {taskGetOptionsWaitForCompletion = y}) + +taskGetOptionsTimeoutLens :: Lens' TaskGetOptions (Maybe (TimeUnits, Word32)) +taskGetOptionsTimeoutLens = lens taskGetOptionsTimeout (\x y -> x {taskGetOptionsTimeout = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/TermVectors.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/TermVectors.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/TermVectors.hs @@ -0,0 +1,708 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.TermVectors +-- +-- Request and response types for the +-- @POST \/{index}\/_termvectors\/{id}@ endpoint, which returns +-- information and statistics about the terms in the fields of a +-- particular document. +-- +-- The endpoint is documented at +-- +-- (Elasticsearch) and +-- +-- (OpenSearch). Both backends share the same wire shape, so this +-- module lives in the Common layer and is re-exported by every +-- version-specific client. +-- +-- The companion @POST \/_mtermvectors@ (multi term vectors) endpoint +-- is also covered by this module — see 'MultiTermVectorsDoc', +-- 'MultiTermVectors', and 'MultiTermVectorsResponse'. The +-- @per_field_analyzer@ request field is the only documented body +-- field not yet modelled here. +-- +-- The URI-level parameters (@routing@, @preference@, @realtime@, +-- @version@, @version_type@) are carried by 'TermVectorsOptions' and +-- surfaced through the @...With@ request builders +-- ('Database.Bloodhound.Common.Requests.getTermVectorsWith', +-- 'Database.Bloodhound.Common.Requests.getMultiTermVectorsWith', +-- 'Database.Bloodhound.Common.Requests.getMultiTermVectorsByIndexWith'). +module Database.Bloodhound.Internal.Versions.Common.Types.TermVectors + ( -- * Single-document request + TermVectorsRequest (..), + defaultTermVectorsRequest, + TermVectorsFilter (..), + defaultTermVectorsFilter, + + -- * Single-document request optics + termVectorsRequestFieldsLens, + termVectorsRequestOffsetsLens, + termVectorsRequestPositionsLens, + termVectorsRequestTermStatisticsLens, + termVectorsRequestFieldStatisticsLens, + termVectorsRequestPayloadLens, + termVectorsRequestFilterLens, + termVectorsFilterMaxNumTermsLens, + termVectorsFilterMinTermFreqLens, + termVectorsFilterMaxTermFreqLens, + termVectorsFilterMinDocFreqLens, + termVectorsFilterMaxDocFreqLens, + + -- * URI options + TermVectorsOptions (..), + defaultTermVectorsOptions, + termVectorsOptionsParams, + + -- * URI options optics + tvoPreferenceLens, + tvoRealtimeLens, + tvoRoutingLens, + tvoVersionLens, + tvoVersionTypeLens, + + -- * Multi-document request + MultiTermVectorsDoc (..), + mkMultiTermVectorsDoc, + MultiTermVectors (..), + MultiTermVectorsResponse (..), + + -- * Multi-document request optics + multiTermVectorsDocIndexLens, + multiTermVectorsDocIdLens, + multiTermVectorsDocFieldsLens, + multiTermVectorsDocOffsetsLens, + multiTermVectorsDocPositionsLens, + multiTermVectorsDocTermStatisticsLens, + multiTermVectorsDocFieldStatisticsLens, + multiTermVectorsDocPayloadLens, + multiTermVectorsDocFilterLens, + multiTermVectorsDocsLens, + multiTermVectorsResponseDocsLens, + + -- * Response + TermVectors (..), + FieldTermVectors (..), + FieldStatistics (..), + TermVectorStats (..), + TermVectorToken (..), + + -- * Response optics + termVectorsIndexLens, + termVectorsIdLens, + termVectorsVersionLens, + termVectorsFoundLens, + termVectorsTookLens, + termVectorsFieldVectorsLens, + fieldTermVectorsFieldStatisticsLens, + fieldTermVectorsTermsLens, + fieldStatisticsDocCountLens, + fieldStatisticsSumDocFreqLens, + fieldStatisticsSumTotalTermFreqLens, + termVectorStatsTermFreqLens, + termVectorStatsDocFreqLens, + termVectorStatsTotalTermFreqLens, + termVectorStatsTokensLens, + termVectorTokenPositionLens, + termVectorTokenStartOffsetLens, + termVectorTokenEndOffsetLens, + termVectorTokenPayloadLens, + ) +where + +import Data.Aeson +import Data.Aeson.Types (Pair) +import Data.HashMap.Strict (HashMap) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Word (Word64) +import Database.Bloodhound.Internal.Utils.Imports + ( showText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( DocId (..), + FieldName (..), + IndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.VersionType + ( VersionType, + renderVersionType, + ) +import Optics.Lens + +-- | Body for @POST \/{index}\/_termvectors\/{id}@. Every field is +-- 'Maybe'; 'defaultTermVectorsRequest' leaves them all 'Nothing' so +-- the server falls back to its documented defaults +-- (@offsets=true@, @positions=true@, @field_statistics=true@, +-- @term_statistics=false@, @payload=true@, no @fields@ filter). +-- +-- Note that the server defaults are not echoed back by the encoder: +-- a 'Nothing' field is simply omitted, producing the same wire shape +-- as a request with no body at all when no field is set. +data TermVectorsRequest = TermVectorsRequest + { termVectorsRequestFields :: Maybe [FieldName], + termVectorsRequestOffsets :: Maybe Bool, + termVectorsRequestPositions :: Maybe Bool, + termVectorsRequestTermStatistics :: Maybe Bool, + termVectorsRequestFieldStatistics :: Maybe Bool, + termVectorsRequestPayload :: Maybe Bool, + termVectorsRequestFilter :: Maybe TermVectorsFilter + } + deriving stock (Eq, Show) + +-- | 'TermVectorsRequest' with every field set to 'Nothing'. Sending +-- this to the server reproduces the legacy parameterless behaviour of +-- the endpoint. +defaultTermVectorsRequest :: TermVectorsRequest +defaultTermVectorsRequest = + TermVectorsRequest + { termVectorsRequestFields = Nothing, + termVectorsRequestOffsets = Nothing, + termVectorsRequestPositions = Nothing, + termVectorsRequestTermStatistics = Nothing, + termVectorsRequestFieldStatistics = Nothing, + termVectorsRequestPayload = Nothing, + termVectorsRequestFilter = Nothing + } + +instance ToJSON TermVectorsRequest where + toJSON req = + object $ + termVectorsParamPairs + (termVectorsRequestFields req) + (termVectorsRequestOffsets req) + (termVectorsRequestPositions req) + (termVectorsRequestTermStatistics req) + (termVectorsRequestFieldStatistics req) + (termVectorsRequestPayload req) + (termVectorsRequestFilter req) + +-- | Optional filter applied to the terms returned. Every field +-- corresponds to a constraint documented at +-- . +-- All fields are 'Maybe' to mirror the request-shape convention used +-- elsewhere in this package. +data TermVectorsFilter = TermVectorsFilter + { termVectorsFilterMaxNumTerms :: Maybe Int, + termVectorsFilterMinTermFreq :: Maybe Int, + termVectorsFilterMaxTermFreq :: Maybe Int, + termVectorsFilterMinDocFreq :: Maybe Int, + termVectorsFilterMaxDocFreq :: Maybe Int + } + deriving stock (Eq, Show) + +-- | 'TermVectorsFilter' with every threshold set to 'Nothing'. +defaultTermVectorsFilter :: TermVectorsFilter +defaultTermVectorsFilter = + TermVectorsFilter + { termVectorsFilterMaxNumTerms = Nothing, + termVectorsFilterMinTermFreq = Nothing, + termVectorsFilterMaxTermFreq = Nothing, + termVectorsFilterMinDocFreq = Nothing, + termVectorsFilterMaxDocFreq = Nothing + } + +instance ToJSON TermVectorsFilter where + toJSON f = + object $ + catMaybes + [ ("max_num_terms" .=) <$> termVectorsFilterMaxNumTerms f, + ("min_term_freq" .=) <$> termVectorsFilterMinTermFreq f, + ("max_term_freq" .=) <$> termVectorsFilterMaxTermFreq f, + ("min_doc_freq" .=) <$> termVectorsFilterMinDocFreq f, + ("max_doc_freq" .=) <$> termVectorsFilterMaxDocFreq f + ] + +-- | Lenses for 'TermVectorsRequest'. +termVectorsRequestFieldsLens :: Lens' TermVectorsRequest (Maybe [FieldName]) +termVectorsRequestFieldsLens = lens termVectorsRequestFields (\x y -> x {termVectorsRequestFields = y}) + +termVectorsRequestOffsetsLens :: Lens' TermVectorsRequest (Maybe Bool) +termVectorsRequestOffsetsLens = lens termVectorsRequestOffsets (\x y -> x {termVectorsRequestOffsets = y}) + +termVectorsRequestPositionsLens :: Lens' TermVectorsRequest (Maybe Bool) +termVectorsRequestPositionsLens = lens termVectorsRequestPositions (\x y -> x {termVectorsRequestPositions = y}) + +termVectorsRequestTermStatisticsLens :: Lens' TermVectorsRequest (Maybe Bool) +termVectorsRequestTermStatisticsLens = + lens termVectorsRequestTermStatistics (\x y -> x {termVectorsRequestTermStatistics = y}) + +termVectorsRequestFieldStatisticsLens :: Lens' TermVectorsRequest (Maybe Bool) +termVectorsRequestFieldStatisticsLens = + lens termVectorsRequestFieldStatistics (\x y -> x {termVectorsRequestFieldStatistics = y}) + +termVectorsRequestPayloadLens :: Lens' TermVectorsRequest (Maybe Bool) +termVectorsRequestPayloadLens = lens termVectorsRequestPayload (\x y -> x {termVectorsRequestPayload = y}) + +termVectorsRequestFilterLens :: Lens' TermVectorsRequest (Maybe TermVectorsFilter) +termVectorsRequestFilterLens = lens termVectorsRequestFilter (\x y -> x {termVectorsRequestFilter = y}) + +-- | Lenses for 'TermVectorsFilter'. +termVectorsFilterMaxNumTermsLens :: Lens' TermVectorsFilter (Maybe Int) +termVectorsFilterMaxNumTermsLens = + lens termVectorsFilterMaxNumTerms (\x y -> x {termVectorsFilterMaxNumTerms = y}) + +termVectorsFilterMinTermFreqLens :: Lens' TermVectorsFilter (Maybe Int) +termVectorsFilterMinTermFreqLens = + lens termVectorsFilterMinTermFreq (\x y -> x {termVectorsFilterMinTermFreq = y}) + +termVectorsFilterMaxTermFreqLens :: Lens' TermVectorsFilter (Maybe Int) +termVectorsFilterMaxTermFreqLens = + lens termVectorsFilterMaxTermFreq (\x y -> x {termVectorsFilterMaxTermFreq = y}) + +termVectorsFilterMinDocFreqLens :: Lens' TermVectorsFilter (Maybe Int) +termVectorsFilterMinDocFreqLens = + lens termVectorsFilterMinDocFreq (\x y -> x {termVectorsFilterMinDocFreq = y}) + +termVectorsFilterMaxDocFreqLens :: Lens' TermVectorsFilter (Maybe Int) +termVectorsFilterMaxDocFreqLens = + lens termVectorsFilterMaxDocFreq (\x y -> x {termVectorsFilterMaxDocFreq = y}) + +-- * URI options + +-- + +-- $termVectorsOptions +-- +-- The @POST \/{index}\/_termvectors\/{id}@ and @POST \/_mtermvectors@ +-- endpoints accept a small set of URI-level parameters documented at +-- +-- and +-- : +-- @preference@, @realtime@, @routing@, @version@, and @version_type@. +-- These select the shard, freshness window, and optimistic-concurrency +-- contract for the lookup; they are distinct from the request-body +-- fields modelled on 'TermVectorsRequest' / 'MultiTermVectorsDoc' +-- (which shape the per-document term-vector output itself). + +-- | URI parameters of the @POST \/{index}\/_termvectors\/{id}@, +-- @POST \/_mtermvectors@, and @POST \/{index}\/_mtermvectors@ +-- endpoints. See +-- . +-- +-- Every field is 'Maybe'; 'defaultTermVectorsOptions' leaves them all +-- @Nothing@ so the legacy parameterless 'Database.Bloodhound.Common.Requests.getTermVectors' +-- \/ 'Database.Bloodhound.Common.Requests.getMultiTermVectors' entry +-- points remain byte-for-byte identical on the wire, and +-- 'termVectorsOptionsParams' drops @Nothing@ fields via 'catMaybes'. +data TermVectorsOptions = TermVectorsOptions + { -- | @preference@ — shard/route preference, e.g. @"_local"@. + tvoPreference :: Maybe Text, + -- | @realtime@ — when @Just False@, fetch term vectors from the + -- index rather than the translog (realtime). The server's default + -- is @true@ when the parameter is omitted (as + -- 'defaultTermVectorsOptions' does). + tvoRealtime :: Maybe Bool, + -- | @routing@ — target shard routing value. Must match the value + -- used at index time for routed documents. + tvoRouting :: Maybe Text, + -- | @version@ — report term vectors only if the document's current + -- version matches. Typically combined with + -- 'tvoVersionType' = external. + tvoVersion :: Maybe Word64, + -- | @version_type@ — how to interpret 'tvoVersion'. See the + -- 'VersionType' renderer for the accepted values. + tvoVersionType :: Maybe VersionType + } + deriving stock (Eq, Show) + +-- | 'TermVectorsOptions' with every field @Nothing@. Emits an empty +-- query string, preserving the wire behaviour of the legacy +-- parameterless 'Database.Bloodhound.Common.Requests.getTermVectors' +-- \/ 'Database.Bloodhound.Common.Requests.getMultiTermVectors' / +-- 'Database.Bloodhound.Common.Requests.getMultiTermVectorsByIndex'. +defaultTermVectorsOptions :: TermVectorsOptions +defaultTermVectorsOptions = + TermVectorsOptions + { tvoPreference = Nothing, + tvoRealtime = Nothing, + tvoRouting = Nothing, + tvoVersion = Nothing, + tvoVersionType = Nothing + } + +-- | Render a 'TermVectorsOptions' record as a @key=value@ list for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. +-- @Nothing@ fields are omitted; the order of the list is stable but +-- unspecified. +termVectorsOptionsParams :: TermVectorsOptions -> [(Text, Maybe Text)] +termVectorsOptionsParams TermVectorsOptions {..} = + catMaybes + [ ("preference",) . Just <$> tvoPreference, + ("realtime",) . Just . boolText <$> tvoRealtime, + ("routing",) . Just <$> tvoRouting, + ("version",) . Just . showText <$> tvoVersion, + ("version_type",) . Just . renderVersionType <$> tvoVersionType + ] + +tvoPreferenceLens :: Lens' TermVectorsOptions (Maybe Text) +tvoPreferenceLens = lens tvoPreference (\x y -> x {tvoPreference = y}) + +tvoRealtimeLens :: Lens' TermVectorsOptions (Maybe Bool) +tvoRealtimeLens = lens tvoRealtime (\x y -> x {tvoRealtime = y}) + +tvoRoutingLens :: Lens' TermVectorsOptions (Maybe Text) +tvoRoutingLens = lens tvoRouting (\x y -> x {tvoRouting = y}) + +tvoVersionLens :: Lens' TermVectorsOptions (Maybe Word64) +tvoVersionLens = lens tvoVersion (\x y -> x {tvoVersion = y}) + +tvoVersionTypeLens :: Lens' TermVectorsOptions (Maybe VersionType) +tvoVersionTypeLens = lens tvoVersionType (\x y -> x {tvoVersionType = y}) + +-- | Render a 'Bool' as the wire @true@/@false@ string. +boolText :: Bool -> Text +boolText True = "true" +boolText False = "false" + +-- * Multi-document request + +-- + +-- $multiDoc +-- +-- The @POST \/_mtermvectors@ endpoint takes a body of the shape +-- @{"docs": [...]}@ where each entry mirrors the single-document +-- request body but adds @_index@ and @_id@ selectors. When the index +-- is supplied in the URL path (@POST \/{index}\/_mtermvectors@), +-- the per-doc @_index@ may be omitted. +-- See +-- +-- and +-- . + +-- | One document entry in a 'MultiTermVectors' body. Fields mirror +-- 'TermVectorsRequest' so each document can override the +-- @fields@\/@offsets@\/@positions@\/@term_statistics@\/ +-- @field_statistics@\/@payload@\/@filter@ knobs independently. +-- 'multiTermVectorsDocIndex' is only required when the index is not +-- already in the URL path (i.e. when calling +-- 'Database.Bloodhound.Common.Requests.getMultiTermVectors' rather +-- than the by-index variant). +data MultiTermVectorsDoc = MultiTermVectorsDoc + { multiTermVectorsDocIndex :: Maybe IndexName, + multiTermVectorsDocId :: DocId, + multiTermVectorsDocFields :: Maybe [FieldName], + multiTermVectorsDocOffsets :: Maybe Bool, + multiTermVectorsDocPositions :: Maybe Bool, + multiTermVectorsDocTermStatistics :: Maybe Bool, + multiTermVectorsDocFieldStatistics :: Maybe Bool, + multiTermVectorsDocPayload :: Maybe Bool, + multiTermVectorsDocFilter :: Maybe TermVectorsFilter + } + deriving stock (Eq, Show) + +-- | Construct a 'MultiTermVectorsDoc' from just its id, with no +-- @_index@ and no per-doc parameter overrides. The most common case +-- when targeting a single index via the URL-path variant +-- ('Database.Bloodhound.Common.Requests.getMultiTermVectorsByIndex'). +mkMultiTermVectorsDoc :: DocId -> MultiTermVectorsDoc +mkMultiTermVectorsDoc docId = + MultiTermVectorsDoc + { multiTermVectorsDocIndex = Nothing, + multiTermVectorsDocId = docId, + multiTermVectorsDocFields = Nothing, + multiTermVectorsDocOffsets = Nothing, + multiTermVectorsDocPositions = Nothing, + multiTermVectorsDocTermStatistics = Nothing, + multiTermVectorsDocFieldStatistics = Nothing, + multiTermVectorsDocPayload = Nothing, + multiTermVectorsDocFilter = Nothing + } + +-- | Lenses for 'MultiTermVectorsDoc'. +multiTermVectorsDocIndexLens :: Lens' MultiTermVectorsDoc (Maybe IndexName) +multiTermVectorsDocIndexLens = + lens multiTermVectorsDocIndex (\x y -> x {multiTermVectorsDocIndex = y}) + +multiTermVectorsDocIdLens :: Lens' MultiTermVectorsDoc DocId +multiTermVectorsDocIdLens = + lens multiTermVectorsDocId (\x y -> x {multiTermVectorsDocId = y}) + +multiTermVectorsDocFieldsLens :: Lens' MultiTermVectorsDoc (Maybe [FieldName]) +multiTermVectorsDocFieldsLens = + lens multiTermVectorsDocFields (\x y -> x {multiTermVectorsDocFields = y}) + +multiTermVectorsDocOffsetsLens :: Lens' MultiTermVectorsDoc (Maybe Bool) +multiTermVectorsDocOffsetsLens = + lens multiTermVectorsDocOffsets (\x y -> x {multiTermVectorsDocOffsets = y}) + +multiTermVectorsDocPositionsLens :: Lens' MultiTermVectorsDoc (Maybe Bool) +multiTermVectorsDocPositionsLens = + lens multiTermVectorsDocPositions (\x y -> x {multiTermVectorsDocPositions = y}) + +multiTermVectorsDocTermStatisticsLens :: Lens' MultiTermVectorsDoc (Maybe Bool) +multiTermVectorsDocTermStatisticsLens = + lens multiTermVectorsDocTermStatistics (\x y -> x {multiTermVectorsDocTermStatistics = y}) + +multiTermVectorsDocFieldStatisticsLens :: Lens' MultiTermVectorsDoc (Maybe Bool) +multiTermVectorsDocFieldStatisticsLens = + lens multiTermVectorsDocFieldStatistics (\x y -> x {multiTermVectorsDocFieldStatistics = y}) + +multiTermVectorsDocPayloadLens :: Lens' MultiTermVectorsDoc (Maybe Bool) +multiTermVectorsDocPayloadLens = + lens multiTermVectorsDocPayload (\x y -> x {multiTermVectorsDocPayload = y}) + +multiTermVectorsDocFilterLens :: Lens' MultiTermVectorsDoc (Maybe TermVectorsFilter) +multiTermVectorsDocFilterLens = + lens multiTermVectorsDocFilter (\x y -> x {multiTermVectorsDocFilter = y}) + +-- | Helper used by both 'TermVectorsRequest' and 'MultiTermVectorsDoc' +-- encoders. Returns the JSON pairs for the seven shared request-body +-- fields, omitting any field set to 'Nothing' so the server falls +-- back to its documented defaults. +termVectorsParamPairs :: + Maybe [FieldName] -> + Maybe Bool -> + Maybe Bool -> + Maybe Bool -> + Maybe Bool -> + Maybe Bool -> + Maybe TermVectorsFilter -> + [Pair] +termVectorsParamPairs fields offsets positions termStats fieldStats payload filt = + catMaybes + [ ("fields" .=) <$> fields, + ("offsets" .=) <$> offsets, + ("positions" .=) <$> positions, + ("term_statistics" .=) <$> termStats, + ("field_statistics" .=) <$> fieldStats, + ("payload" .=) <$> payload, + ("filter" .=) <$> filt + ] + +instance ToJSON MultiTermVectorsDoc where + toJSON MultiTermVectorsDoc {..} = + object $ + case multiTermVectorsDocIndex of + Just idx -> basePairs <> ["_index" .= idx] + Nothing -> basePairs + where + basePairs = + ["_id" .= multiTermVectorsDocId] + <> termVectorsParamPairs + multiTermVectorsDocFields + multiTermVectorsDocOffsets + multiTermVectorsDocPositions + multiTermVectorsDocTermStatistics + multiTermVectorsDocFieldStatistics + multiTermVectorsDocPayload + multiTermVectorsDocFilter + +-- | Body for @POST \/_mtermvectors@ and @POST \/{index}\/_mtermvectors@. +-- Wraps a list of 'MultiTermVectorsDoc' entries and encodes as +-- @{"docs": [...]}@. +newtype MultiTermVectors = MultiTermVectors + { multiTermVectorsDocs :: [MultiTermVectorsDoc] + } + deriving stock (Eq, Show) + +multiTermVectorsDocsLens :: Lens' MultiTermVectors [MultiTermVectorsDoc] +multiTermVectorsDocsLens = + lens multiTermVectorsDocs (\x y -> x {multiTermVectorsDocs = y}) + +instance ToJSON MultiTermVectors where + toJSON MultiTermVectors {..} = object ["docs" .= multiTermVectorsDocs] + +-- | Response body for @POST \/_mtermvectors@. The server returns one +-- 'TermVectors' entry per requested document, in request order, +-- wrapped in a @{"docs": [...]}@ envelope. +newtype MultiTermVectorsResponse = MultiTermVectorsResponse + { multiTermVectorsResponseDocs :: [TermVectors] + } + deriving stock (Eq, Show) + +multiTermVectorsResponseDocsLens :: Lens' MultiTermVectorsResponse [TermVectors] +multiTermVectorsResponseDocsLens = + lens multiTermVectorsResponseDocs (\x y -> x {multiTermVectorsResponseDocs = y}) + +instance FromJSON MultiTermVectorsResponse where + parseJSON = + withObject "MultiTermVectorsResponse" $ \o -> do + docs <- o .: "docs" + MultiTermVectorsResponse <$> mapM parseJSON docs + +-- | Response body for @POST \/{index}\/_termvectors\/{id}@. +-- +-- The @_index@ and @_id@ fields are kept as raw 'Text' (matching the +-- 'Database.Bloodhound.Internal.Client.BHRequest.EsResult' wrapper) +-- rather than parsed into 'Database.Bloodhound.Internal.Versions.Common.Types.Newtypes.IndexName', +-- so that unusual system-index names that fail the +-- 'IndexName' validator do not cause the whole response to be +-- rejected. The spec marks @_id@ as optional on this response; +-- 'termVectorsId' therefore defaults to @'DocId' ""@ when the server +-- omits it (rather than failing the decode or exposing a 'Maybe'). +data TermVectors = TermVectors + { termVectorsIndex :: Text, + termVectorsId :: DocId, + termVectorsVersion :: Maybe Int, + termVectorsFound :: Bool, + termVectorsTook :: Maybe Int, + termVectorsFieldVectors :: HashMap FieldName FieldTermVectors + } + deriving stock (Eq, Show) + +instance FromJSON TermVectors where + parseJSON = + withObject "TermVectors" $ \o -> do + termVectorsIndex <- o .: "_index" + termVectorsId <- o .:? "_id" .!= DocId "" + termVectorsVersion <- o .:? "_version" + termVectorsFound <- o .:? "found" .!= False + termVectorsTook <- o .:? "took" + termVectorsFieldVectors <- o .:? "term_vectors" .!= mempty + pure TermVectors {..} + +-- | Per-field term-vector block. The @field_statistics@ object is +-- only present when the request asked for it +-- ('termVectorsRequestFieldStatistics' = @Just True@); @terms@ is +-- always present when the field exists in the document, and is empty +-- if the field has no indexed terms. +data FieldTermVectors = FieldTermVectors + { fieldTermVectorsFieldStatistics :: Maybe FieldStatistics, + fieldTermVectorsTerms :: HashMap Text TermVectorStats + } + deriving stock (Eq, Show) + +instance FromJSON FieldTermVectors where + parseJSON = + withObject "FieldTermVectors" $ \o -> do + fieldTermVectorsFieldStatistics <- o .:? "field_statistics" + fieldTermVectorsTerms <- o .:? "terms" .!= mempty + pure FieldTermVectors {..} + +-- | Aggregate statistics for a field, reported when +-- 'termVectorsRequestFieldStatistics' is @Just True@. +data FieldStatistics = FieldStatistics + { fieldStatisticsDocCount :: Maybe Int, + fieldStatisticsSumDocFreq :: Maybe Int, + fieldStatisticsSumTotalTermFreq :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON FieldStatistics where + parseJSON = + withObject "FieldStatistics" $ \o -> do + fieldStatisticsDocCount <- o .:? "doc_count" + fieldStatisticsSumDocFreq <- o .:? "sum_doc_freq" + fieldStatisticsSumTotalTermFreq <- o .:? "sum_ttf" + pure FieldStatistics {..} + +-- | Statistics for a single term, keyed by the term text in +-- 'fieldTermVectorsTerms'. @doc_freq@ and @ttf@ are only present when +-- 'termVectorsRequestTermStatistics' is @Just True@. +data TermVectorStats = TermVectorStats + { termVectorStatsTermFreq :: Maybe Int, + termVectorStatsDocFreq :: Maybe Int, + termVectorStatsTotalTermFreq :: Maybe Int, + termVectorStatsTokens :: [TermVectorToken] + } + deriving stock (Eq, Show) + +instance FromJSON TermVectorStats where + parseJSON = + withObject "TermVectorStats" $ \o -> do + termVectorStatsTermFreq <- o .:? "term_freq" + termVectorStatsDocFreq <- o .:? "doc_freq" + termVectorStatsTotalTermFreq <- o .:? "ttf" + termVectorStatsTokens <- o .:? "tokens" .!= [] + pure TermVectorStats {..} + +-- | A single token occurrence of a term. @position@, @start_offset@, +-- @end_offset@ are present when the request enabled +-- @positions@\/@offsets@ respectively; @payload@ is present when +-- @payloads@ are enabled and the token carries one. +data TermVectorToken = TermVectorToken + { termVectorTokenPosition :: Maybe Int, + termVectorTokenStartOffset :: Maybe Int, + termVectorTokenEndOffset :: Maybe Int, + termVectorTokenPayload :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON TermVectorToken where + parseJSON = + withObject "TermVectorToken" $ \o -> do + termVectorTokenPosition <- o .:? "position" + termVectorTokenStartOffset <- o .:? "start_offset" + termVectorTokenEndOffset <- o .:? "end_offset" + termVectorTokenPayload <- o .:? "payload" + pure TermVectorToken {..} + +-- | Lenses for 'TermVectors'. +termVectorsIndexLens :: Lens' TermVectors Text +termVectorsIndexLens = lens termVectorsIndex (\x y -> x {termVectorsIndex = y}) + +termVectorsIdLens :: Lens' TermVectors DocId +termVectorsIdLens = lens termVectorsId (\x y -> x {termVectorsId = y}) + +termVectorsVersionLens :: Lens' TermVectors (Maybe Int) +termVectorsVersionLens = lens termVectorsVersion (\x y -> x {termVectorsVersion = y}) + +termVectorsFoundLens :: Lens' TermVectors Bool +termVectorsFoundLens = lens termVectorsFound (\x y -> x {termVectorsFound = y}) + +termVectorsTookLens :: Lens' TermVectors (Maybe Int) +termVectorsTookLens = lens termVectorsTook (\x y -> x {termVectorsTook = y}) + +termVectorsFieldVectorsLens :: Lens' TermVectors (HashMap FieldName FieldTermVectors) +termVectorsFieldVectorsLens = + lens termVectorsFieldVectors (\x y -> x {termVectorsFieldVectors = y}) + +-- | Lenses for 'FieldTermVectors'. +fieldTermVectorsFieldStatisticsLens :: Lens' FieldTermVectors (Maybe FieldStatistics) +fieldTermVectorsFieldStatisticsLens = + lens fieldTermVectorsFieldStatistics (\x y -> x {fieldTermVectorsFieldStatistics = y}) + +fieldTermVectorsTermsLens :: Lens' FieldTermVectors (HashMap Text TermVectorStats) +fieldTermVectorsTermsLens = + lens fieldTermVectorsTerms (\x y -> x {fieldTermVectorsTerms = y}) + +-- | Lenses for 'FieldStatistics'. +fieldStatisticsDocCountLens :: Lens' FieldStatistics (Maybe Int) +fieldStatisticsDocCountLens = + lens fieldStatisticsDocCount (\x y -> x {fieldStatisticsDocCount = y}) + +fieldStatisticsSumDocFreqLens :: Lens' FieldStatistics (Maybe Int) +fieldStatisticsSumDocFreqLens = + lens fieldStatisticsSumDocFreq (\x y -> x {fieldStatisticsSumDocFreq = y}) + +fieldStatisticsSumTotalTermFreqLens :: Lens' FieldStatistics (Maybe Int) +fieldStatisticsSumTotalTermFreqLens = + lens fieldStatisticsSumTotalTermFreq (\x y -> x {fieldStatisticsSumTotalTermFreq = y}) + +-- | Lenses for 'TermVectorStats'. +termVectorStatsTermFreqLens :: Lens' TermVectorStats (Maybe Int) +termVectorStatsTermFreqLens = + lens termVectorStatsTermFreq (\x y -> x {termVectorStatsTermFreq = y}) + +termVectorStatsDocFreqLens :: Lens' TermVectorStats (Maybe Int) +termVectorStatsDocFreqLens = + lens termVectorStatsDocFreq (\x y -> x {termVectorStatsDocFreq = y}) + +termVectorStatsTotalTermFreqLens :: Lens' TermVectorStats (Maybe Int) +termVectorStatsTotalTermFreqLens = + lens termVectorStatsTotalTermFreq (\x y -> x {termVectorStatsTotalTermFreq = y}) + +termVectorStatsTokensLens :: Lens' TermVectorStats [TermVectorToken] +termVectorStatsTokensLens = + lens termVectorStatsTokens (\x y -> x {termVectorStatsTokens = y}) + +-- | Lenses for 'TermVectorToken'. +termVectorTokenPositionLens :: Lens' TermVectorToken (Maybe Int) +termVectorTokenPositionLens = + lens termVectorTokenPosition (\x y -> x {termVectorTokenPosition = y}) + +termVectorTokenStartOffsetLens :: Lens' TermVectorToken (Maybe Int) +termVectorTokenStartOffsetLens = + lens termVectorTokenStartOffset (\x y -> x {termVectorTokenStartOffset = y}) + +termVectorTokenEndOffsetLens :: Lens' TermVectorToken (Maybe Int) +termVectorTokenEndOffsetLens = + lens termVectorTokenEndOffset (\x y -> x {termVectorTokenEndOffset = y}) + +termVectorTokenPayloadLens :: Lens' TermVectorToken (Maybe Text) +termVectorTokenPayloadLens = + lens termVectorTokenPayload (\x y -> x {termVectorTokenPayload = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/TextStructure.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/TextStructure.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/TextStructure.hs @@ -0,0 +1,954 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.TextStructure +-- +-- Request and response types for the @/_text_structure@ family of +-- endpoints, which inspect a sample of plain-text / NDJSON data and +-- infer its structure (format, charset, delimiter, column names, +-- suggested ES mappings and ingest pipeline, per-field stats). +-- +-- The REST surface is identical across Elasticsearch 7.17, 8.x and 9.x, +-- so the types live in the Common layer and are re-exported by every ES +-- client module. The feature is ES-only (it shipped under the X-Pack +-- flag in older 7.x releases and is part of the @text_structure@ module +-- on the basic / free license tier on 7.17+); calls against an +-- OpenSearch cluster will fail at runtime. +-- +-- This module hosts the response shape shared by 'findStructure', +-- @find_field_structure@ and @find_message_structure@ +-- ('FindStructureResponse'), the @find_structure@ URI parameters +-- ('FindStructureOptions'), and the dedicated request \/ response types +-- for @test_grok_pattern@ ('TestGrokPatternRequest' / +-- 'TestGrokPatternResponse'). Unlike most JSON-bodied endpoints, the +-- @find_structure@ /request/ body is a raw plain-text or NDJSON stream +-- (the sample to analyse), not a JSON value; the builders thread it +-- through as a lazy 'L.ByteString' and never call 'encode' on it. The +-- /response/ is a normal JSON object in every case. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.TextStructure + ( -- * find_structure / find_field_structure / find_message_structure response + FindStructureResponse (..), + FindStructureFieldStats (..), + FindStructureTopHit (..), + + -- * find_structure URI parameters + FindStructureOptions (..), + defaultFindStructureOptions, + findStructureOptionsParams, + + -- * find_message_structure request body + FindMessageStructureRequest (..), + + -- * find_message_structure URI parameters + FindMessageStructureOptions (..), + defaultFindMessageStructureOptions, + findMessageStructureOptionsParams, + + -- * find_field_structure URI parameters + FindFieldStructureOptions (..), + defaultFindFieldStructureOptions, + findFieldStructureOptionsParams, + + -- * test_grok_pattern request body and response + TestGrokPatternRequest (..), + TestGrokPatternResponse (..), + TestGrokPatternOptions (..), + defaultTestGrokPatternOptions, + testGrokPatternOptionsParams, + + -- * Optics + fsrNumLinesAnalyzedLens, + fsrNumMessagesAnalyzedLens, + fsrSampleStartLens, + fsrCharsetLens, + fsrHasByteOrderMarkerLens, + fsrFormatLens, + fsrNeedClientTimezoneLens, + fsrColumnNamesLens, + fsrHasHeaderRowLens, + fsrDelimiterLens, + fsrQuoteLens, + fsrExcludeLinesPatternLens, + fsrGrokPatternLens, + fsrMappingsLens, + fsrIngestPipelineLens, + fsrFieldStatsLens, + fsrExplanationLens, + fssCountLens, + fssCardinalityLens, + fssMinValueLens, + fssMaxValueLens, + fssMeanValueLens, + fssMedianValueLens, + fssTopHitsLens, + fthValueLens, + fthCountLens, + fsoCharsetLens, + fsoColumnNamesLens, + fsoDelimiterLens, + fsoExplainLens, + fsoFormatLens, + fsoGrokPatternLens, + fsoHasHeaderRowLens, + fsoLinesToSampleLens, + fsoMaxColumnsPerLineLens, + fsoMaxSampleSizeBytesLens, + fsoOverrideLens, + fsoPreferIndentedLens, + fsoQuoteLens, + fsoShouldTrimFieldsLens, + fsoSkipLinesLens, + fsoTimestampFieldLens, + fsoTimestampFormatLens, + fmsrMessagesLens, + fmsoCharsetLens, + fmsoColumnNamesLens, + fmsoDelimiterLens, + fmsoExplainLens, + fmsoFormatLens, + fmsoGrokPatternLens, + fmsoQuoteLens, + fmsoShouldTrimFieldsLens, + fmsoEcsCompatibilityLens, + fmsoTimestampFieldLens, + fmsoTimestampFormatLens, + ffsoIndexLens, + ffsoFieldLens, + ffsoDocumentsToSampleLens, + ffsoColumnNamesLens, + ffsoDelimiterLens, + ffsoQuoteLens, + ffsoShouldTrimFieldsLens, + ffsoFormatLens, + ffsoEcsCompatibilityLens, + ffsoGrokPatternLens, + ffsoTimestampFieldLens, + ffsoTimestampFormatLens, + ffsoExplainLens, + ffsoTimeoutLens, + tgprGrokPatternLens, + tgprTextLens, + tgprMatchesLens, + tgpoEcsCompatibilityLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap (KeyMap) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Optics.Lens + +-- | Top-level response body of @POST /_text_structure/find_structure@. +-- Captured live against ES 7.17.25 (basic license) on 2026-06-26. The +-- server always emits the format-classification fields +-- ('fsrNumLinesAnalyzed', 'fsrCharset', 'fsrFormat', ...); the +-- format-specific fields ('fsrColumnNames', 'fsrDelimiter', +-- 'fsrGrokPattern', ...) are present only when the inferred format +-- makes them meaningful (e.g. 'fsrColumnNames' is set for @delimited@ +-- output, 'fsrGrokPattern' for @semi_structured_text@). The +-- 'fsrExplanation' array is populated only when the request opts into +-- @explain=true@. +data FindStructureResponse = FindStructureResponse + { -- | Number of lines of the sample that the server actually looked + -- at. Capped by 'fsoLinesToSample' / 'fsoMaxSampleSizeBytes' when + -- set on the request. + fsrNumLinesAnalyzed :: Maybe Int, + -- | Number of messages analysed. For multi-line formats the server + -- collapses line groups into a single message, so this is less + -- than or equal to 'fsrNumLinesAnalyzed'. + fsrNumMessagesAnalyzed :: Maybe Int, + -- | Verbatim prefix of the sample that was classified (the server + -- returns the first few hundred bytes so the caller can correlate + -- the result with the input). + fsrSampleStart :: Maybe Text, + -- | Inferred character encoding, e.g. @"UTF-8"@. + fsrCharset :: Maybe Text, + -- | Whether the sample begins with a UTF byte-order marker. + fsrHasByteOrderMarker :: Maybe Bool, + -- | Inferred high-level format: @"delimited"@, @"ndjson"@, + -- @"xml"@, @"semi_structured_text"@. + fsrFormat :: Maybe Text, + -- | Whether the server needs the client timezone to interpret + -- timestamp fields whose format omits the offset. + fsrNeedClientTimezone :: Maybe Bool, + -- | @column_names@ — header row for @delimited@ output. Present + -- only when the server detected (or was told via + -- 'fsoColumnNames') a header. + fsrColumnNames :: Maybe [Text], + -- | @has_header_row@ — present only for @delimited@ output. + fsrHasHeaderRow :: Maybe Bool, + -- | @delimiter@ — present only for @delimited@ output. + fsrDelimiter :: Maybe Text, + -- | @quote@ — present only for @delimited@ output that uses a + -- quote character. + fsrQuote :: Maybe Text, + -- | @exclude_lines_pattern@ — regex of lines to skip (e.g. the + -- detected header on @delimited@ output). + fsrExcludeLinesPattern :: Maybe Text, + -- | @grok_pattern@ — present only for @semi_structured_text@ + -- output. + fsrGrokPattern :: Maybe Text, + -- | @mappings@ — suggested ES index mappings ('Value' because the + -- shape is the free-form mapping object also accepted by + -- @PUT /{index}/_mapping@). + fsrMappings :: Maybe Value, + -- | @ingest_pipeline@ — suggested ES ingest pipeline ('Value' for + -- the same reason). + fsrIngestPipeline :: Maybe Value, + -- | @field_stats@ — per-field summary statistics, keyed by column + -- name. Present when the format is @delimited@ or @ndjson@ and + -- the sample was large enough to compute stats. + fsrFieldStats :: Maybe (KeyMap FindStructureFieldStats), + -- | @explanation@ — array of human-readable diagnostic strings + -- produced by the classifier. Present only when the request set + -- 'fsoExplain' to @Just True@. + fsrExplanation :: Maybe [Text] + } + deriving stock (Eq, Show) + +instance FromJSON FindStructureResponse where + parseJSON = withObject "FindStructureResponse" $ \o -> + FindStructureResponse + <$> o .:? "num_lines_analyzed" + <*> o .:? "num_messages_analyzed" + <*> o .:? "sample_start" + <*> o .:? "charset" + <*> o .:? "has_byte_order_marker" + <*> o .:? "format" + <*> o .:? "need_client_timezone" + <*> o .:? "column_names" + <*> o .:? "has_header_row" + <*> o .:? "delimiter" + <*> o .:? "quote" + <*> o .:? "exclude_lines_pattern" + <*> o .:? "grok_pattern" + <*> o .:? "mappings" + <*> o .:? "ingest_pipeline" + <*> o .:? "field_stats" + <*> o .:? "explanation" + +instance ToJSON FindStructureResponse where + toJSON FindStructureResponse {..} = + object $ + catMaybes + [ ("num_lines_analyzed" .=) <$> fsrNumLinesAnalyzed, + ("num_messages_analyzed" .=) <$> fsrNumMessagesAnalyzed, + ("sample_start" .=) <$> fsrSampleStart, + ("charset" .=) <$> fsrCharset, + ("has_byte_order_marker" .=) <$> fsrHasByteOrderMarker, + ("format" .=) <$> fsrFormat, + ("need_client_timezone" .=) <$> fsrNeedClientTimezone, + ("column_names" .=) <$> fsrColumnNames, + ("has_header_row" .=) <$> fsrHasHeaderRow, + ("delimiter" .=) <$> fsrDelimiter, + ("quote" .=) <$> fsrQuote, + ("exclude_lines_pattern" .=) <$> fsrExcludeLinesPattern, + ("grok_pattern" .=) <$> fsrGrokPattern, + ("mappings" .=) <$> fsrMappings, + ("ingest_pipeline" .=) <$> fsrIngestPipeline, + ("field_stats" .=) <$> fsrFieldStats, + ("explanation" .=) <$> fsrExplanation + ] + +-- | Per-field statistics returned under @field_stats@. The numeric +-- aggregates ('fssMinValue' etc.) are modelled as 'Value' because the +-- server emits them as JSON numbers for numeric/date columns and as +-- JSON strings for non-numeric columns; narrowing to 'Scientific' +-- would force a runtime parse failure on the latter. Callers that +-- know the column is numeric can use 'Data.Aeson.fromJSON' on the +-- 'Value' to recover a 'Scientific' or 'Double'. +data FindStructureFieldStats = FindStructureFieldStats + { fssCount :: Maybe Int, + fssCardinality :: Maybe Int, + -- | @min_value@ — minimum value (numeric columns emit a JSON + -- number, non-numeric a JSON string). 'Value' covers both. + fssMinValue :: Maybe Value, + -- | @max_value@ — maximum value. Same polymorphism as + -- 'fssMinValue'. + fssMaxValue :: Maybe Value, + -- | @mean_value@ — arithmetic mean of numeric values. Absent for + -- non-numeric columns; when present, usually a JSON number. + fssMeanValue :: Maybe Value, + -- | @median_value@ — median of numeric values. Absent for + -- non-numeric columns; when present, usually a JSON number. + fssMedianValue :: Maybe Value, + -- | @top_hits@ — most frequent values, ordered by descending + -- @count@. Server-capped (default 10). + fssTopHits :: Maybe [FindStructureTopHit] + } + deriving stock (Eq, Show) + +instance FromJSON FindStructureFieldStats where + parseJSON = withObject "FindStructureFieldStats" $ \o -> + FindStructureFieldStats + <$> o .:? "count" + <*> o .:? "cardinality" + <*> o .:? "min_value" + <*> o .:? "max_value" + <*> o .:? "mean_value" + <*> o .:? "median_value" + <*> o .:? "top_hits" + +instance ToJSON FindStructureFieldStats where + toJSON FindStructureFieldStats {..} = + object $ + catMaybes + [ ("count" .=) <$> fssCount, + ("cardinality" .=) <$> fssCardinality, + ("min_value" .=) <$> fssMinValue, + ("max_value" .=) <$> fssMaxValue, + ("mean_value" .=) <$> fssMeanValue, + ("median_value" .=) <$> fssMedianValue, + ("top_hits" .=) <$> fssTopHits + ] + +-- | One entry of the @top_hits@ array inside a +-- 'FindStructureFieldStats'. The @value@ field is 'Value' (not +-- 'Scientific') because the server emits the original field value +-- verbatim: JSON numbers for numeric columns, JSON strings for +-- keyword/text columns, JSON booleans for boolean columns. A narrower +-- type would force a parse failure on the common case of non-numeric +-- data. +data FindStructureTopHit = FindStructureTopHit + { -- | @value@ — the field value, exactly as the server emits it. + fthValue :: Value, + -- | @count@ — how often @value@ occurred in the sample. + fthCount :: Int + } + deriving stock (Eq, Show) + +instance FromJSON FindStructureTopHit where + parseJSON = withObject "FindStructureTopHit" $ \o -> + FindStructureTopHit + <$> o .: "value" + <*> o .: "count" + +instance ToJSON FindStructureTopHit where + toJSON FindStructureTopHit {..} = + object + [ "value" .= fthValue, + "count" .= fthCount + ] + +-- Lenses for FindStructureResponse + +fsrNumLinesAnalyzedLens :: Lens' FindStructureResponse (Maybe Int) +fsrNumLinesAnalyzedLens = + lens fsrNumLinesAnalyzed (\x y -> x {fsrNumLinesAnalyzed = y}) + +fsrNumMessagesAnalyzedLens :: Lens' FindStructureResponse (Maybe Int) +fsrNumMessagesAnalyzedLens = + lens fsrNumMessagesAnalyzed (\x y -> x {fsrNumMessagesAnalyzed = y}) + +fsrSampleStartLens :: Lens' FindStructureResponse (Maybe Text) +fsrSampleStartLens = + lens fsrSampleStart (\x y -> x {fsrSampleStart = y}) + +fsrCharsetLens :: Lens' FindStructureResponse (Maybe Text) +fsrCharsetLens = lens fsrCharset (\x y -> x {fsrCharset = y}) + +fsrHasByteOrderMarkerLens :: Lens' FindStructureResponse (Maybe Bool) +fsrHasByteOrderMarkerLens = + lens fsrHasByteOrderMarker (\x y -> x {fsrHasByteOrderMarker = y}) + +fsrFormatLens :: Lens' FindStructureResponse (Maybe Text) +fsrFormatLens = lens fsrFormat (\x y -> x {fsrFormat = y}) + +fsrNeedClientTimezoneLens :: Lens' FindStructureResponse (Maybe Bool) +fsrNeedClientTimezoneLens = + lens fsrNeedClientTimezone (\x y -> x {fsrNeedClientTimezone = y}) + +fsrColumnNamesLens :: Lens' FindStructureResponse (Maybe [Text]) +fsrColumnNamesLens = + lens fsrColumnNames (\x y -> x {fsrColumnNames = y}) + +fsrHasHeaderRowLens :: Lens' FindStructureResponse (Maybe Bool) +fsrHasHeaderRowLens = + lens fsrHasHeaderRow (\x y -> x {fsrHasHeaderRow = y}) + +fsrDelimiterLens :: Lens' FindStructureResponse (Maybe Text) +fsrDelimiterLens = lens fsrDelimiter (\x y -> x {fsrDelimiter = y}) + +fsrQuoteLens :: Lens' FindStructureResponse (Maybe Text) +fsrQuoteLens = lens fsrQuote (\x y -> x {fsrQuote = y}) + +fsrExcludeLinesPatternLens :: Lens' FindStructureResponse (Maybe Text) +fsrExcludeLinesPatternLens = + lens fsrExcludeLinesPattern (\x y -> x {fsrExcludeLinesPattern = y}) + +fsrGrokPatternLens :: Lens' FindStructureResponse (Maybe Text) +fsrGrokPatternLens = + lens fsrGrokPattern (\x y -> x {fsrGrokPattern = y}) + +fsrMappingsLens :: Lens' FindStructureResponse (Maybe Value) +fsrMappingsLens = lens fsrMappings (\x y -> x {fsrMappings = y}) + +fsrIngestPipelineLens :: Lens' FindStructureResponse (Maybe Value) +fsrIngestPipelineLens = + lens fsrIngestPipeline (\x y -> x {fsrIngestPipeline = y}) + +fsrFieldStatsLens :: + Lens' FindStructureResponse (Maybe (KeyMap FindStructureFieldStats)) +fsrFieldStatsLens = + lens fsrFieldStats (\x y -> x {fsrFieldStats = y}) + +fsrExplanationLens :: Lens' FindStructureResponse (Maybe [Text]) +fsrExplanationLens = + lens fsrExplanation (\x y -> x {fsrExplanation = y}) + +-- Lenses for FindStructureFieldStats + +fssCountLens :: Lens' FindStructureFieldStats (Maybe Int) +fssCountLens = lens fssCount (\x y -> x {fssCount = y}) + +fssCardinalityLens :: Lens' FindStructureFieldStats (Maybe Int) +fssCardinalityLens = + lens fssCardinality (\x y -> x {fssCardinality = y}) + +fssMinValueLens :: Lens' FindStructureFieldStats (Maybe Value) +fssMinValueLens = + lens fssMinValue (\x y -> x {fssMinValue = y}) + +fssMaxValueLens :: Lens' FindStructureFieldStats (Maybe Value) +fssMaxValueLens = + lens fssMaxValue (\x y -> x {fssMaxValue = y}) + +fssMeanValueLens :: Lens' FindStructureFieldStats (Maybe Value) +fssMeanValueLens = + lens fssMeanValue (\x y -> x {fssMeanValue = y}) + +fssMedianValueLens :: Lens' FindStructureFieldStats (Maybe Value) +fssMedianValueLens = + lens fssMedianValue (\x y -> x {fssMedianValue = y}) + +fssTopHitsLens :: Lens' FindStructureFieldStats (Maybe [FindStructureTopHit]) +fssTopHitsLens = + lens fssTopHits (\x y -> x {fssTopHits = y}) + +-- Lenses for FindStructureTopHit + +fthValueLens :: Lens' FindStructureTopHit Value +fthValueLens = lens fthValue (\x y -> x {fthValue = y}) + +fthCountLens :: Lens' FindStructureTopHit Int +fthCountLens = lens fthCount (\x y -> x {fthCount = y}) + +-- | URI parameters accepted by @POST /_text_structure/find_structure@. +-- Every field is 'Maybe'; 'defaultFindStructureOptions' emits no query +-- string at all, which delegates every inference to the server. +-- +-- The @column_names@, @delimiter@, @has_header_row@, @format@, +-- @grok_pattern@ and @timestamp_field@ parameters are /overrides/: the +-- server applies them verbatim instead of inferring the corresponding +-- property from the sample. @override@ must be @Just True@ for the +-- server to honour an override that contradicts the inferred structure. +data FindStructureOptions = FindStructureOptions + { -- | @charset@ — override the inferred character encoding. + fsoCharset :: Maybe Text, + -- | @column_names@ — override the inferred (or absent) header. + fsoColumnNames :: Maybe [Text], + -- | @delimiter@ — override the inferred delimiter (single character). + fsoDelimiter :: Maybe Text, + -- | @explain@ — when @Just True@, populate 'fsrExplanation' with the + -- classifier's diagnostic trace. + fsoExplain :: Maybe Bool, + -- | @format@ — override the inferred high-level format. + fsoFormat :: Maybe Text, + -- | @grok_pattern@ — override the inferred grok pattern + -- (@semi_structured_text@ only). + fsoGrokPattern :: Maybe Text, + -- | @has_header_row@ — override the inferred header presence + -- (@delimited@ only). + fsoHasHeaderRow :: Maybe Bool, + -- | @lines_to_sample@ — cap on the number of lines to inspect. + fsoLinesToSample :: Maybe Int, + -- | @max_columns_per_line@ — refuse to classify a line with more + -- columns than this (treats it as malformed). + fsoMaxColumnsPerLine :: Maybe Int, + -- | @max_sample_size_bytes@ — cap on the byte size of the inspected + -- prefix. + fsoMaxSampleSizeBytes :: Maybe Int, + -- | @override@ — when @Just True@, accept overrides that contradict + -- the inferred structure. + fsoOverride :: Maybe Bool, + -- | @prefer_indented@ — when @Just True@, group multi-line log + -- records by indentation. + fsoPreferIndented :: Maybe Bool, + -- | @quote@ — override the inferred quote character (@delimited@ + -- only). + fsoQuote :: Maybe Text, + -- | @should_trim_fields@ — when @Just True@, trim whitespace around + -- delimited field values. + fsoShouldTrimFields :: Maybe Bool, + -- | @skip_lines@ — number of leading lines to skip before + -- classification (typically a shebang or comment block). + fsoSkipLines :: Maybe Int, + -- | @timestamp_field@ — name of the field to treat as the event + -- timestamp. + fsoTimestampField :: Maybe Text, + -- | @timestamp_format@ — format string matching + -- 'fsoTimestampField' values. + fsoTimestampFormat :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'FindStructureOptions' with every parameter set to 'Nothing'. The +-- server infers everything from the sample. +defaultFindStructureOptions :: FindStructureOptions +defaultFindStructureOptions = + FindStructureOptions + { fsoCharset = Nothing, + fsoColumnNames = Nothing, + fsoDelimiter = Nothing, + fsoExplain = Nothing, + fsoFormat = Nothing, + fsoGrokPattern = Nothing, + fsoHasHeaderRow = Nothing, + fsoLinesToSample = Nothing, + fsoMaxColumnsPerLine = Nothing, + fsoMaxSampleSizeBytes = Nothing, + fsoOverride = Nothing, + fsoPreferIndented = Nothing, + fsoQuote = Nothing, + fsoShouldTrimFields = Nothing, + fsoSkipLines = Nothing, + fsoTimestampField = Nothing, + fsoTimestampFormat = Nothing + } + +-- | Render 'FindStructureOptions' as a @(key, value)@ list suitable +-- for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultFindStructureOptions' produces an empty list (and therefore +-- no query string). +findStructureOptionsParams :: FindStructureOptions -> [(Text, Maybe Text)] +findStructureOptionsParams FindStructureOptions {..} = + catMaybes + [ ("charset",) . Just <$> fsoCharset, + ("column_names",) . Just . renderList <$> fsoColumnNames, + ("delimiter",) . Just <$> fsoDelimiter, + ("explain",) . Just . boolText <$> fsoExplain, + ("format",) . Just <$> fsoFormat, + ("grok_pattern",) . Just <$> fsoGrokPattern, + ("has_header_row",) . Just . boolText <$> fsoHasHeaderRow, + ("lines_to_sample",) . Just . T.pack . show <$> fsoLinesToSample, + ("max_columns_per_line",) . Just . T.pack . show <$> fsoMaxColumnsPerLine, + ("max_sample_size_bytes",) . Just . T.pack . show <$> fsoMaxSampleSizeBytes, + ("override",) . Just . boolText <$> fsoOverride, + ("prefer_indented",) . Just . boolText <$> fsoPreferIndented, + ("quote",) . Just <$> fsoQuote, + ("should_trim_fields",) . Just . boolText <$> fsoShouldTrimFields, + ("skip_lines",) . Just . T.pack . show <$> fsoSkipLines, + ("timestamp_field",) . Just <$> fsoTimestampField, + ("timestamp_format",) . Just <$> fsoTimestampFormat + ] + where + boolText True = "true" + boolText False = "false" + renderList = T.intercalate "," + +-- Lenses for FindStructureOptions + +fsoCharsetLens :: Lens' FindStructureOptions (Maybe Text) +fsoCharsetLens = lens fsoCharset (\x y -> x {fsoCharset = y}) + +fsoColumnNamesLens :: Lens' FindStructureOptions (Maybe [Text]) +fsoColumnNamesLens = + lens fsoColumnNames (\x y -> x {fsoColumnNames = y}) + +fsoDelimiterLens :: Lens' FindStructureOptions (Maybe Text) +fsoDelimiterLens = lens fsoDelimiter (\x y -> x {fsoDelimiter = y}) + +fsoExplainLens :: Lens' FindStructureOptions (Maybe Bool) +fsoExplainLens = lens fsoExplain (\x y -> x {fsoExplain = y}) + +fsoFormatLens :: Lens' FindStructureOptions (Maybe Text) +fsoFormatLens = lens fsoFormat (\x y -> x {fsoFormat = y}) + +fsoGrokPatternLens :: Lens' FindStructureOptions (Maybe Text) +fsoGrokPatternLens = + lens fsoGrokPattern (\x y -> x {fsoGrokPattern = y}) + +fsoHasHeaderRowLens :: Lens' FindStructureOptions (Maybe Bool) +fsoHasHeaderRowLens = + lens fsoHasHeaderRow (\x y -> x {fsoHasHeaderRow = y}) + +fsoLinesToSampleLens :: Lens' FindStructureOptions (Maybe Int) +fsoLinesToSampleLens = + lens fsoLinesToSample (\x y -> x {fsoLinesToSample = y}) + +fsoMaxColumnsPerLineLens :: Lens' FindStructureOptions (Maybe Int) +fsoMaxColumnsPerLineLens = + lens fsoMaxColumnsPerLine (\x y -> x {fsoMaxColumnsPerLine = y}) + +fsoMaxSampleSizeBytesLens :: Lens' FindStructureOptions (Maybe Int) +fsoMaxSampleSizeBytesLens = + lens fsoMaxSampleSizeBytes (\x y -> x {fsoMaxSampleSizeBytes = y}) + +fsoOverrideLens :: Lens' FindStructureOptions (Maybe Bool) +fsoOverrideLens = lens fsoOverride (\x y -> x {fsoOverride = y}) + +fsoPreferIndentedLens :: Lens' FindStructureOptions (Maybe Bool) +fsoPreferIndentedLens = + lens fsoPreferIndented (\x y -> x {fsoPreferIndented = y}) + +fsoQuoteLens :: Lens' FindStructureOptions (Maybe Text) +fsoQuoteLens = lens fsoQuote (\x y -> x {fsoQuote = y}) + +fsoShouldTrimFieldsLens :: Lens' FindStructureOptions (Maybe Bool) +fsoShouldTrimFieldsLens = + lens fsoShouldTrimFields (\x y -> x {fsoShouldTrimFields = y}) + +fsoSkipLinesLens :: Lens' FindStructureOptions (Maybe Int) +fsoSkipLinesLens = lens fsoSkipLines (\x y -> x {fsoSkipLines = y}) + +fsoTimestampFieldLens :: Lens' FindStructureOptions (Maybe Text) +fsoTimestampFieldLens = + lens fsoTimestampField (\x y -> x {fsoTimestampField = y}) + +fsoTimestampFormatLens :: Lens' FindStructureOptions (Maybe Text) +fsoTimestampFormatLens = + lens fsoTimestampFormat (\x y -> x {fsoTimestampFormat = y}) + +------------------------------------------------------------------------------ +-- find_message_structure +------------------------------------------------------------------------------ + +-- | Request body of @POST /_text_structure/find_message_structure@ +-- (ES 7.16+, shared across 7.x\/8.x\/9.x). Unlike 'findStructure', whose +-- body is a raw text stream, this endpoint takes a JSON object whose +-- single @messages@ field is the array of log message strings to +-- classify. The response reuses 'FindStructureResponse' (the classifier +-- output is shape-compatible with @find_structure@'s). +-- +-- See +-- . +newtype FindMessageStructureRequest = FindMessageStructureRequest + { fmsrMessages :: [Text] + } + deriving stock (Eq, Show) + +instance ToJSON FindMessageStructureRequest where + toJSON FindMessageStructureRequest {..} = + object ["messages" .= fmsrMessages] + +instance FromJSON FindMessageStructureRequest where + parseJSON = withObject "FindMessageStructureRequest" $ \o -> + FindMessageStructureRequest <$> o .:? "messages" .!= [] + +fmsrMessagesLens :: Lens' FindMessageStructureRequest [Text] +fmsrMessagesLens = + lens fmsrMessages (\x y -> x {fmsrMessages = y}) + +-- | URI parameters accepted by +-- @POST /_text_structure/find_message_structure@. This is the +-- message-classifier subset of 'FindStructureOptions': the +-- @lines_to_sample@ \/ @max_sample_size_bytes@ \/ @skip_lines@ \/ override +-- parameters do not apply (the input is an explicit message list, not a +-- byte stream), but the format, delimiter, quote, grok, timestamp and +-- @explain@ overrides do. Every field is 'Maybe'; +-- 'defaultFindMessageStructureOptions' emits no query string. +data FindMessageStructureOptions = FindMessageStructureOptions + { fmsoCharset :: Maybe Text, + fmsoColumnNames :: Maybe [Text], + fmsoDelimiter :: Maybe Text, + fmsoExplain :: Maybe Bool, + fmsoFormat :: Maybe Text, + fmsoGrokPattern :: Maybe Text, + fmsoQuote :: Maybe Text, + fmsoShouldTrimFields :: Maybe Bool, + fmsoEcsCompatibility :: Maybe Text, + fmsoTimestampField :: Maybe Text, + fmsoTimestampFormat :: Maybe Text + } + deriving stock (Eq, Show) + +defaultFindMessageStructureOptions :: FindMessageStructureOptions +defaultFindMessageStructureOptions = + FindMessageStructureOptions + { fmsoCharset = Nothing, + fmsoColumnNames = Nothing, + fmsoDelimiter = Nothing, + fmsoExplain = Nothing, + fmsoFormat = Nothing, + fmsoGrokPattern = Nothing, + fmsoQuote = Nothing, + fmsoShouldTrimFields = Nothing, + fmsoEcsCompatibility = Nothing, + fmsoTimestampField = Nothing, + fmsoTimestampFormat = Nothing + } + +findMessageStructureOptionsParams :: + FindMessageStructureOptions -> [(Text, Maybe Text)] +findMessageStructureOptionsParams FindMessageStructureOptions {..} = + catMaybes + [ ("charset",) . Just <$> fmsoCharset, + ("column_names",) . Just . renderList <$> fmsoColumnNames, + ("delimiter",) . Just <$> fmsoDelimiter, + ("explain",) . Just . boolText <$> fmsoExplain, + ("format",) . Just <$> fmsoFormat, + ("grok_pattern",) . Just <$> fmsoGrokPattern, + ("quote",) . Just <$> fmsoQuote, + ("should_trim_fields",) . Just . boolText <$> fmsoShouldTrimFields, + ("ecs_compatibility",) . Just <$> fmsoEcsCompatibility, + ("timestamp_field",) . Just <$> fmsoTimestampField, + ("timestamp_format",) . Just <$> fmsoTimestampFormat + ] + where + boolText True = "true" + boolText False = "false" + renderList = T.intercalate "," + +fmsoCharsetLens :: Lens' FindMessageStructureOptions (Maybe Text) +fmsoCharsetLens = lens fmsoCharset (\x y -> x {fmsoCharset = y}) + +fmsoColumnNamesLens :: Lens' FindMessageStructureOptions (Maybe [Text]) +fmsoColumnNamesLens = + lens fmsoColumnNames (\x y -> x {fmsoColumnNames = y}) + +fmsoDelimiterLens :: Lens' FindMessageStructureOptions (Maybe Text) +fmsoDelimiterLens = lens fmsoDelimiter (\x y -> x {fmsoDelimiter = y}) + +fmsoExplainLens :: Lens' FindMessageStructureOptions (Maybe Bool) +fmsoExplainLens = lens fmsoExplain (\x y -> x {fmsoExplain = y}) + +fmsoFormatLens :: Lens' FindMessageStructureOptions (Maybe Text) +fmsoFormatLens = lens fmsoFormat (\x y -> x {fmsoFormat = y}) + +fmsoGrokPatternLens :: Lens' FindMessageStructureOptions (Maybe Text) +fmsoGrokPatternLens = + lens fmsoGrokPattern (\x y -> x {fmsoGrokPattern = y}) + +fmsoQuoteLens :: Lens' FindMessageStructureOptions (Maybe Text) +fmsoQuoteLens = lens fmsoQuote (\x y -> x {fmsoQuote = y}) + +fmsoShouldTrimFieldsLens :: + Lens' FindMessageStructureOptions (Maybe Bool) +fmsoShouldTrimFieldsLens = + lens fmsoShouldTrimFields (\x y -> x {fmsoShouldTrimFields = y}) + +fmsoEcsCompatibilityLens :: Lens' FindMessageStructureOptions (Maybe Text) +fmsoEcsCompatibilityLens = + lens fmsoEcsCompatibility (\x y -> x {fmsoEcsCompatibility = y}) + +fmsoTimestampFieldLens :: Lens' FindMessageStructureOptions (Maybe Text) +fmsoTimestampFieldLens = + lens fmsoTimestampField (\x y -> x {fmsoTimestampField = y}) + +fmsoTimestampFormatLens :: Lens' FindMessageStructureOptions (Maybe Text) +fmsoTimestampFormatLens = + lens fmsoTimestampFormat (\x y -> x {fmsoTimestampFormat = y}) + +------------------------------------------------------------------------------ +-- find_field_structure +------------------------------------------------------------------------------ + +-- | URI parameters accepted by +-- @GET /_text_structure/find_field_structure@ (ES 7.16+, shared across +-- 7.x\/8.x\/9.x). Unlike the POST variants, the input is not a body but +-- a reference to an existing @index@ \/ @field@ whose stored values the +-- server samples and classifies; both are therefore required path\/query +-- inputs. The remaining fields are the same classifier overrides as +-- 'FindMessageStructureOptions' plus a @documents_to_sample@ cap and a +-- @timeout@. +data FindFieldStructureOptions = FindFieldStructureOptions + { ffsoIndex :: Maybe Text, + ffsoField :: Maybe Text, + ffsoDocumentsToSample :: Maybe Int, + ffsoColumnNames :: Maybe [Text], + ffsoDelimiter :: Maybe Text, + ffsoQuote :: Maybe Text, + ffsoShouldTrimFields :: Maybe Bool, + ffsoFormat :: Maybe Text, + ffsoEcsCompatibility :: Maybe Text, + ffsoGrokPattern :: Maybe Text, + ffsoTimestampField :: Maybe Text, + ffsoTimestampFormat :: Maybe Text, + ffsoExplain :: Maybe Bool, + ffsoTimeout :: Maybe Text + } + deriving stock (Eq, Show) + +defaultFindFieldStructureOptions :: FindFieldStructureOptions +defaultFindFieldStructureOptions = + FindFieldStructureOptions + { ffsoIndex = Nothing, + ffsoField = Nothing, + ffsoDocumentsToSample = Nothing, + ffsoColumnNames = Nothing, + ffsoDelimiter = Nothing, + ffsoQuote = Nothing, + ffsoShouldTrimFields = Nothing, + ffsoFormat = Nothing, + ffsoEcsCompatibility = Nothing, + ffsoGrokPattern = Nothing, + ffsoTimestampField = Nothing, + ffsoTimestampFormat = Nothing, + ffsoExplain = Nothing, + ffsoTimeout = Nothing + } + +findFieldStructureOptionsParams :: + FindFieldStructureOptions -> [(Text, Maybe Text)] +findFieldStructureOptionsParams FindFieldStructureOptions {..} = + catMaybes + [ ("index",) . Just <$> ffsoIndex, + ("field",) . Just <$> ffsoField, + ("documents_to_sample",) . Just . T.pack . show <$> ffsoDocumentsToSample, + ("column_names",) . Just . renderList <$> ffsoColumnNames, + ("delimiter",) . Just <$> ffsoDelimiter, + ("quote",) . Just <$> ffsoQuote, + ("should_trim_fields",) . Just . boolText <$> ffsoShouldTrimFields, + ("format",) . Just <$> ffsoFormat, + ("ecs_compatibility",) . Just <$> ffsoEcsCompatibility, + ("grok_pattern",) . Just <$> ffsoGrokPattern, + ("timestamp_field",) . Just <$> ffsoTimestampField, + ("timestamp_format",) . Just <$> ffsoTimestampFormat, + ("explain",) . Just . boolText <$> ffsoExplain, + ("timeout",) . Just <$> ffsoTimeout + ] + where + boolText True = "true" + boolText False = "false" + renderList = T.intercalate "," + +ffsoIndexLens :: Lens' FindFieldStructureOptions (Maybe Text) +ffsoIndexLens = lens ffsoIndex (\x y -> x {ffsoIndex = y}) + +ffsoFieldLens :: Lens' FindFieldStructureOptions (Maybe Text) +ffsoFieldLens = lens ffsoField (\x y -> x {ffsoField = y}) + +ffsoDocumentsToSampleLens :: Lens' FindFieldStructureOptions (Maybe Int) +ffsoDocumentsToSampleLens = + lens ffsoDocumentsToSample (\x y -> x {ffsoDocumentsToSample = y}) + +ffsoColumnNamesLens :: Lens' FindFieldStructureOptions (Maybe [Text]) +ffsoColumnNamesLens = + lens ffsoColumnNames (\x y -> x {ffsoColumnNames = y}) + +ffsoDelimiterLens :: Lens' FindFieldStructureOptions (Maybe Text) +ffsoDelimiterLens = lens ffsoDelimiter (\x y -> x {ffsoDelimiter = y}) + +ffsoQuoteLens :: Lens' FindFieldStructureOptions (Maybe Text) +ffsoQuoteLens = lens ffsoQuote (\x y -> x {ffsoQuote = y}) + +ffsoShouldTrimFieldsLens :: Lens' FindFieldStructureOptions (Maybe Bool) +ffsoShouldTrimFieldsLens = + lens ffsoShouldTrimFields (\x y -> x {ffsoShouldTrimFields = y}) + +ffsoFormatLens :: Lens' FindFieldStructureOptions (Maybe Text) +ffsoFormatLens = lens ffsoFormat (\x y -> x {ffsoFormat = y}) + +ffsoEcsCompatibilityLens :: Lens' FindFieldStructureOptions (Maybe Text) +ffsoEcsCompatibilityLens = + lens ffsoEcsCompatibility (\x y -> x {ffsoEcsCompatibility = y}) + +ffsoGrokPatternLens :: Lens' FindFieldStructureOptions (Maybe Text) +ffsoGrokPatternLens = + lens ffsoGrokPattern (\x y -> x {ffsoGrokPattern = y}) + +ffsoTimestampFieldLens :: Lens' FindFieldStructureOptions (Maybe Text) +ffsoTimestampFieldLens = + lens ffsoTimestampField (\x y -> x {ffsoTimestampField = y}) + +ffsoTimestampFormatLens :: Lens' FindFieldStructureOptions (Maybe Text) +ffsoTimestampFormatLens = + lens ffsoTimestampFormat (\x y -> x {ffsoTimestampFormat = y}) + +ffsoExplainLens :: Lens' FindFieldStructureOptions (Maybe Bool) +ffsoExplainLens = lens ffsoExplain (\x y -> x {ffsoExplain = y}) + +ffsoTimeoutLens :: Lens' FindFieldStructureOptions (Maybe Text) +ffsoTimeoutLens = lens ffsoTimeout (\x y -> x {ffsoTimeout = y}) + +------------------------------------------------------------------------------ +-- test_grok_pattern +------------------------------------------------------------------------------ + +-- | Request body of @POST /_text_structure/test_grok_pattern@ +-- (ES 7.16+, shared across 7.x\/8.x\/9.x). The server compiles +-- @tgprGrokPattern@ and matches it against each entry of @tgprText@, +-- returning the per-input match offsets in 'TestGrokPatternResponse'. +-- +-- See +-- . +data TestGrokPatternRequest = TestGrokPatternRequest + { tgprGrokPattern :: Text, + tgprText :: [Text] + } + deriving stock (Eq, Show) + +instance ToJSON TestGrokPatternRequest where + toJSON TestGrokPatternRequest {..} = + object + [ "grok_pattern" .= tgprGrokPattern, + "text" .= tgprText + ] + +instance FromJSON TestGrokPatternRequest where + parseJSON = withObject "TestGrokPatternRequest" $ \o -> + TestGrokPatternRequest + <$> o .: "grok_pattern" + <*> o .:? "text" .!= [] + +tgprGrokPatternLens :: Lens' TestGrokPatternRequest Text +tgprGrokPatternLens = + lens tgprGrokPattern (\x y -> x {tgprGrokPattern = y}) + +tgprTextLens :: Lens' TestGrokPatternRequest [Text] +tgprTextLens = lens tgprText (\x y -> x {tgprText = y}) + +-- | Response body of @POST /_text_structure/test_grok_pattern@. The +-- @matches@ array has one element per input string in +-- 'tgprText'; each element is the server's match descriptor (a JSON +-- object mapping each named capture to its matched substring, plus +-- positional metadata). The element shape is intentionally opaque +-- ('Value') because it varies with the grok pattern's capture names and +-- is not worth modelling exhaustively. +data TestGrokPatternResponse = TestGrokPatternResponse + { tgprMatches :: [Value] + } + deriving stock (Eq, Show) + +instance ToJSON TestGrokPatternResponse where + toJSON TestGrokPatternResponse {..} = + object ["matches" .= tgprMatches] + +instance FromJSON TestGrokPatternResponse where + parseJSON = withObject "TestGrokPatternResponse" $ \o -> + TestGrokPatternResponse <$> o .:? "matches" .!= [] + +tgprMatchesLens :: Lens' TestGrokPatternResponse [Value] +tgprMatchesLens = lens tgprMatches (\x y -> x {tgprMatches = y}) + +-- | URI parameters accepted by +-- @POST /_text_structure/test_grok_pattern@. The only documented +-- parameter is @ecs_compatibility@ (@disabled@ or @v1@), which selects +-- the Elastic Common Schema grok pattern set the server prepends to the +-- caller's pattern. +data TestGrokPatternOptions = TestGrokPatternOptions + { tgpoEcsCompatibility :: Maybe Text + } + deriving stock (Eq, Show) + +defaultTestGrokPatternOptions :: TestGrokPatternOptions +defaultTestGrokPatternOptions = + TestGrokPatternOptions {tgpoEcsCompatibility = Nothing} + +testGrokPatternOptionsParams :: + TestGrokPatternOptions -> [(Text, Maybe Text)] +testGrokPatternOptionsParams TestGrokPatternOptions {..} = + catMaybes + [ ("ecs_compatibility",) . Just <$> tgpoEcsCompatibility + ] + +tgpoEcsCompatibilityLens :: Lens' TestGrokPatternOptions (Maybe Text) +tgpoEcsCompatibilityLens = + lens tgpoEcsCompatibility (\x y -> x {tgpoEcsCompatibility = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Transform.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Transform.hs @@ -0,0 +1,1738 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Transform +-- Description : Types for the Elasticsearch X-Pack Transform API +-- +-- Defines the request and response shapes for the ES X-Pack Transform +-- endpoints (under @\/_transform\/*@). A transform continuously or on +-- schedule materialises a destination index from a pivot (aggregation) +-- or a latest-selection over one or more source indices. +-- +-- * @PUT /_transform/{transform_id}@ — create ('TransformConfig'), +-- returns 'PutTransformResponse' (with 'PutTransformOptions'). +-- * @POST /_transform/{transform_id}/_update@ — update, returns +-- 'Acknowledged' (with 'UpdateTransformOptions'). +-- * @GET /_transform[/{transform_id}]@ — 'TransformsResponse'. +-- * @DELETE /_transform/{transform_id}@ — 'DeleteTransformResponse' +-- (with 'DeleteTransformOptions'). +-- * @POST /_transform/{transform_id}/_start@ — returns 'Acknowledged' +-- (with 'StartTransformOptions'). +-- * @POST /_transform/{transform_id}/_stop@ — 'StopTransformResponse' +-- (with 'StopTransformOptions'). +-- * @POST /_transform/_preview@ — 'PreviewTransformResponse' (body is a +-- 'TransformConfig'; with 'PreviewTransformOptions'). +-- * @GET /_transform/_stats[/{transform_id}]@ — 'TransformStatsResponse' +-- (with 'GetTransformStatsOptions'). +-- * @GET /_transform/{transform_id}/_explain@ — 'TransformExplainResponse'. +-- +-- The Transform API ships in the free (basic) X-Pack tier and is +-- available across ES7\/ES8\/ES9 with the same wire surface, which is why +-- these types live in the Common layer alongside SLM\/ILM\/Enrich. +-- OpenSearch implements a /different/ transform plugin under +-- @_plugins\/_transform\/*@ with a distinct wire shape; the types in this +-- module are ES-only. +-- +-- The config body uses the same forward-compatible strategy as +-- "Database.Bloodhound.Internal.Versions.Common.Types.Enrich": the stable +-- category-specific fields are typed, the large generic query\/aggregation +-- DSL bodies (the @pivot@, the @source.query@) are carried as opaque +-- 'Value's, and every record carries an @extras@ 'KeyMap' catch-all so +-- unknown sibling fields survive a round-trip through @encode . decode@. +-- The @pivot@ body is kept opaque for the same reason +-- "Database.Bloodhound.Internal.Versions.Common.Types.Watcher" keeps the +-- watch body opaque: a typed pivot\/group_by\/aggregations codec would be +-- large and brittle and would duplicate the query\/aggregation DSL. The +-- smaller, stable @latest@ transform config is fully typed. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Transform + ( -- * Identity + TransformId (..), + + -- * Enums + TransformState (..), + transformStateText, + TransformHealth (..), + transformHealthText, + + -- * Config components + TransformSource (..), + defaultTransformSource, + transformSourceIndexLens, + transformSourceQueryLens, + transformSourceRuntimeMappingsLens, + transformSourceExtrasLens, + TransformDestination (..), + defaultTransformDestination, + transformDestinationIndexLens, + transformDestinationPipelineLens, + transformDestinationExtrasLens, + TransformLatest (..), + defaultTransformLatest, + transformLatestUniqueKeyLens, + transformLatestSortLens, + transformLatestExtrasLens, + TransformSync (..), + defaultTransformSync, + transformSyncTimeLens, + transformSyncExtrasLens, + TransformSyncTime (..), + defaultTransformSyncTime, + transformSyncTimeFieldLens, + transformSyncTimeDelayLens, + transformSyncTimeScheduleLens, + transformSyncTimeExtrasLens, + TransformSettings (..), + defaultTransformSettings, + transformSettingsMaxPageSearchSizeLens, + transformSettingsDocsPerSecondLens, + transformSettingsAlignCheckpointsLens, + transformSettingsDatesAsEpochMillisLens, + transformSettingsExtrasLens, + + -- * Transform config (PUT body / GET value) + TransformConfig (..), + defaultTransformConfig, + transformConfigSourceLens, + transformConfigDestLens, + transformConfigPivotLens, + transformConfigLatestLens, + transformConfigDescriptionLens, + transformConfigFrequencyLens, + transformConfigSyncLens, + transformConfigSettingsLens, + transformConfigIdLens, + transformConfigVersionLens, + transformConfigCreateTimeLens, + transformConfigExtrasLens, + + -- * PUT response + PutTransformResponse (..), + putTransformResponseIdLens, + putTransformResponseAcknowledgedLens, + putTransformResponseExtrasLens, + + -- * GET response + TransformsResponse (..), + transformsResponseCountLens, + transformsResponseTransformsLens, + transformsResponseExtrasLens, + + -- * DELETE response + DeleteTransformResponse (..), + deleteTransformResponseAcknowledgedLens, + deleteTransformResponseDeletedTasksCountLens, + deleteTransformResponseExtrasLens, + + -- * STOP response + StopTransformResponse (..), + stopTransformResponseAcknowledgedLens, + stopTransformResponseStoppedLens, + stopTransformResponseExtrasLens, + + -- * PREVIEW response + PreviewTransformResponse (..), + previewTransformResponsePreviewLens, + previewTransformResponseGeneratedDestIndexLens, + previewTransformResponseExtrasLens, + + -- * Stats response + TransformStatsResponse (..), + transformStatsResponseCountLens, + transformStatsResponseStatsLens, + transformStatsResponseExtrasLens, + TransformStats (..), + transformStatsIdLens, + transformStatsStateLens, + transformStatsHealthLens, + transformStatsCheckpointingLens, + transformStatsDocumentsIndexedLens, + transformStatsDocumentsProcessedLens, + transformStatsDocumentsDeletedLens, + transformStatsDocumentsFailedLens, + transformStatsExtrasLens, + + -- * Explain response + TransformExplainResponse (..), + transformExplainResponseTransformsLens, + transformExplainResponseExtrasLens, + TransformExplainEntry (..), + transformExplainEntryIdLens, + transformExplainEntryExtrasLens, + + -- * URI options + PutTransformOptions (..), + defaultPutTransformOptions, + putTransformOptionsParams, + putTransformOptionsDeferValidationLens, + putTransformOptionsTimeoutLens, + UpdateTransformOptions (..), + defaultUpdateTransformOptions, + updateTransformOptionsParams, + updateTransformOptionsDeferValidationLens, + GetTransformsOptions (..), + defaultGetTransformsOptions, + getTransformsOptionsParams, + getTransformsOptionsFromLens, + getTransformsOptionsSizeLens, + getTransformsOptionsAllowNoMatchLens, + getTransformsOptionsExcludeGeneratedLens, + DeleteTransformOptions (..), + defaultDeleteTransformOptions, + deleteTransformOptionsParams, + deleteTransformOptionsForceLens, + deleteTransformOptionsDeleteDestIndexLens, + StartTransformOptions (..), + defaultStartTransformOptions, + startTransformOptionsParams, + startTransformOptionsDeferValidationLens, + startTransformOptionsTimeoutLens, + StopTransformOptions (..), + defaultStopTransformOptions, + stopTransformOptionsParams, + stopTransformOptionsWaitForCheckpointLens, + stopTransformOptionsWaitForCompletionLens, + stopTransformOptionsAllowNoMatchLens, + stopTransformOptionsTimeoutLens, + PreviewTransformOptions (..), + defaultPreviewTransformOptions, + previewTransformOptionsParams, + previewTransformOptionsTimeoutLens, + GetTransformStatsOptions (..), + defaultGetTransformStatsOptions, + getTransformStatsOptionsParams, + getTransformStatsOptionsFromLens, + getTransformStatsOptionsSizeLens, + getTransformStatsOptionsAllowNoMatchLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (IsString) +import Data.Text (Text) +import Data.Vector qualified as V +import Database.Bloodhound.Internal.Utils.Imports (Lens', Parser, lens, showText) +import Database.Bloodhound.Internal.Versions.Common.Types.Indices + ( IndexPattern (..), + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( FieldName (..), + IndexName, + ) + +-- | Identifies a transform in the @\/_transform\/{transform_id}@ URL path. +-- Wraps 'Text' so it round-trips through JSON as a bare string but is +-- distinct at the Haskell type level from Enrich\/SLM policy ids. +newtype TransformId = TransformId {unTransformId :: Text} + deriving newtype (Eq, Show, Ord, IsString, ToJSON, FromJSON) + +-- | The running state of a transform task as reported by +-- @GET /_transform\/_stats@. Documented values: @stopped@, @started@, +-- @indexing@, @failed@, @idle@; the custom branch absorbs anything newer. +data TransformState + = TransformStateStopped + | TransformStateStarted + | TransformStateIndexing + | TransformStateFailed + | TransformStateIdle + | TransformStateCustom Text + deriving stock (Eq, Show) + +-- | The wire spelling of each 'TransformState'. +transformStateText :: TransformState -> Text +transformStateText = \case + TransformStateStopped -> "stopped" + TransformStateStarted -> "started" + TransformStateIndexing -> "indexing" + TransformStateFailed -> "failed" + TransformStateIdle -> "idle" + TransformStateCustom t -> t + +instance ToJSON TransformState where + toJSON = toJSON . transformStateText + +instance FromJSON TransformState where + parseJSON = withText "TransformState" $ \t -> pure $ + case t of + "stopped" -> TransformStateStopped + "started" -> TransformStateStarted + "indexing" -> TransformStateIndexing + "failed" -> TransformStateFailed + "idle" -> TransformStateIdle + other -> TransformStateCustom other + +-- | The health indicator of a transform as reported by stats. Documented +-- values: @green@, @yellow@, @red@; the custom branch absorbs anything +-- newer. +data TransformHealth + = TransformHealthGreen + | TransformHealthYellow + | TransformHealthRed + | TransformHealthCustom Text + deriving stock (Eq, Show) + +transformHealthText :: TransformHealth -> Text +transformHealthText = \case + TransformHealthGreen -> "green" + TransformHealthYellow -> "yellow" + TransformHealthRed -> "red" + TransformHealthCustom t -> t + +instance ToJSON TransformHealth where + toJSON = toJSON . transformHealthText + +instance FromJSON TransformHealth where + parseJSON = withText "TransformHealth" $ \t -> pure $ + case t of + "green" -> TransformHealthGreen + "yellow" -> TransformHealthYellow + "red" -> TransformHealthRed + other -> TransformHealthCustom other + +-- | The @source@ of a transform: one or more source indices (or wildcard +-- patterns), an optional filter @query@, and optional @runtime_mappings@. +-- Both @query@ and @runtime_mappings@ are arbitrary query\/runtime DSL +-- bodies, so they are carried as opaque 'Value's (the same approach +-- Enrich takes for its @query@). Unknown sibling fields are preserved in +-- 'tsocExtras'. +data TransformSource = TransformSource + { -- | @index@ — one or more source indices (or wildcard patterns). + -- Accepted on decode either as a JSON array of strings or as a single + -- bare string; always emitted as an array on encode. + tsocIndex :: NonEmpty IndexPattern, + -- | @query@ — optional filter restricting which source documents are + -- eligible. Opaque query DSL body. + tsocQuery :: Maybe Value, + -- | @runtime_mappings@ — optional runtime fields evaluated per query. + -- Opaque because it is a free-form mapping object. + tsocRuntimeMappings :: Maybe Value, + tsocExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | A minimal source: a single 'IndexPattern', no query, no runtime +-- mappings, no extras. Intended as a starting point callers then overwrite +-- with the record lenses. +defaultTransformSource :: + IndexPattern -> + TransformSource +defaultTransformSource index = + TransformSource + { tsocIndex = index :| [], + tsocQuery = Nothing, + tsocRuntimeMappings = Nothing, + tsocExtras = KM.empty + } + +sourceKnownKeys :: [Key] +sourceKnownKeys = ["index", "query", "runtime_mappings"] + +instance FromJSON TransformSource where + parseJSON = withObject "TransformSource" $ \o -> do + index <- parseIndexList =<< o .: "index" + query <- o .:? "query" + runtime <- o .:? "runtime_mappings" + let extras = + KM.fromList . filter ((`notElem` sourceKnownKeys) . fst) $ KM.toList o + pure + TransformSource + { tsocIndex = index, + tsocQuery = query, + tsocRuntimeMappings = runtime, + tsocExtras = extras + } + where + -- ES accepts @index@ as either a JSON array or a single string; a + -- single string is normalised to a one-element 'NonEmpty' list. + parseIndexList :: Value -> Parser (NonEmpty IndexPattern) + parseIndexList (Array xs) + | V.null xs = fail "transform source 'index' array must be non-empty" + | otherwise = toNonEmptyM (V.toList xs) + parseIndexList v@(String _) = (:| []) <$> parseJSON v + parseIndexList _ = fail "transform source 'index' must be a string or array of strings" + + toNonEmptyM :: (FromJSON a) => [Value] -> Parser (NonEmpty a) + toNonEmptyM [] = fail "transform source 'index': unexpected empty array" + toNonEmptyM (h : rest) = (:|) <$> parseJSON h <*> traverse parseJSON rest + +instance ToJSON TransformSource where + toJSON TransformSource {..} = + object $ + catMaybes + [ Just ("index" .= NE.toList tsocIndex), + ("query" .=) <$> tsocQuery, + ("runtime_mappings" .=) <$> tsocRuntimeMappings + ] + <> [toPair kv | kv <- KM.toList tsocExtras] + where + toPair (k, v) = k .= v + +-- | The @dest@ination of a transform: the target 'IndexName' plus an +-- optional ingest @pipeline@ name. Unknown sibling fields are preserved +-- in 'tdestExtras'. +data TransformDestination = TransformDestination + { tdestIndex :: IndexName, + tdestPipeline :: Maybe Text, + tdestExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +defaultTransformDestination :: + IndexName -> + TransformDestination +defaultTransformDestination index = + TransformDestination + { tdestIndex = index, + tdestPipeline = Nothing, + tdestExtras = KM.empty + } + +destKnownKeys :: [Key] +destKnownKeys = ["index", "pipeline"] + +instance FromJSON TransformDestination where + parseJSON = withObject "TransformDestination" $ \o -> do + index <- o .: "index" + pipeline <- o .:? "pipeline" + let extras = + KM.fromList . filter ((`notElem` destKnownKeys) . fst) $ KM.toList o + pure + TransformDestination + { tdestIndex = index, + tdestPipeline = pipeline, + tdestExtras = extras + } + +instance ToJSON TransformDestination where + toJSON TransformDestination {..} = + object $ + catMaybes + [ Just ("index" .= tdestIndex), + ("pipeline" .=) <$> tdestPipeline + ] + <> [toPair kv | kv <- KM.toList tdestExtras] + where + toPair (k, v) = k .= v + +-- | The @latest@ config: selects the most-recent document per +-- @unique_key@ window, ordered by @sort@. Both are stable category-specific +-- fields so they are typed; the @unique_key@ array tolerates a bare-string +-- on decode (normalised to a singleton 'NonEmpty'). Unknown sibling fields +-- are preserved in 'tlExtras'. +data TransformLatest = TransformLatest + { tlUniqueKey :: NonEmpty FieldName, + tlSort :: FieldName, + tlExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +defaultTransformLatest :: + NonEmpty FieldName -> + FieldName -> + TransformLatest +defaultTransformLatest uniqueKey sort = + TransformLatest + { tlUniqueKey = uniqueKey, + tlSort = sort, + tlExtras = KM.empty + } + +latestKnownKeys :: [Key] +latestKnownKeys = ["unique_key", "sort"] + +instance FromJSON TransformLatest where + parseJSON = withObject "TransformLatest" $ \o -> do + uniqueKey <- parseUniqueKey =<< o .: "unique_key" + sort <- o .: "sort" + let extras = + KM.fromList . filter ((`notElem` latestKnownKeys) . fst) $ KM.toList o + pure + TransformLatest + { tlUniqueKey = uniqueKey, + tlSort = sort, + tlExtras = extras + } + where + parseUniqueKey :: Value -> Parser (NonEmpty FieldName) + parseUniqueKey (Array xs) + | V.null xs = fail "transform latest 'unique_key' array must be non-empty" + | otherwise = toNonEmptyM (V.toList xs) + parseUniqueKey v@(String _) = (:| []) <$> parseJSON v + parseUniqueKey _ = fail "transform latest 'unique_key' must be a string or array of strings" + + toNonEmptyM :: (FromJSON a) => [Value] -> Parser (NonEmpty a) + toNonEmptyM [] = fail "transform latest 'unique_key': unexpected empty array" + toNonEmptyM (h : rest) = (:|) <$> parseJSON h <*> traverse parseJSON rest + +instance ToJSON TransformLatest where + toJSON TransformLatest {..} = + object $ + [ "unique_key" .= NE.toList tlUniqueKey, + "sort" .= tlSort + ] + <> [toPair kv | kv <- KM.toList tlExtras] + where + toPair (k, v) = k .= v + +-- | The @sync@ config of a continuous transform. Carries a 'TransformSyncTime' +-- under the @time@ key plus an extras catch-all. +data TransformSync = TransformSync + { tsyTime :: Maybe TransformSyncTime, + tsyExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +defaultTransformSync :: TransformSync +defaultTransformSync = + TransformSync + { tsyTime = Nothing, + tsyExtras = KM.empty + } + +syncKnownKeys :: [Key] +syncKnownKeys = ["time"] + +instance FromJSON TransformSync where + parseJSON = withObject "TransformSync" $ \o -> do + time <- o .:? "time" + let extras = + KM.fromList . filter ((`notElem` syncKnownKeys) . fst) $ KM.toList o + pure + TransformSync + { tsyTime = time, + tsyExtras = extras + } + +instance ToJSON TransformSync where + toJSON TransformSync {..} = + object $ + catMaybes + [ ("time" .=) <$> tsyTime + ] + <> [toPair kv | kv <- KM.toList tsyExtras] + where + toPair (k, v) = k .= v + +-- | The @time@ sub-object of 'TransformSync': the @field@ used to +-- determine new documents, an optional @delay@, and an optional +-- @schedule@ (cron-style, opaque 'Value' because the shape is large and +-- version-dependent). Unknown sibling fields are preserved in 'tstExtras'. +data TransformSyncTime = TransformSyncTime + { tstField :: FieldName, + tstDelay :: Maybe Text, + tstSchedule :: Maybe Value, + tstExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +defaultTransformSyncTime :: + FieldName -> + TransformSyncTime +defaultTransformSyncTime field = + TransformSyncTime + { tstField = field, + tstDelay = Nothing, + tstSchedule = Nothing, + tstExtras = KM.empty + } + +syncTimeKnownKeys :: [Key] +syncTimeKnownKeys = ["field", "delay", "schedule"] + +instance FromJSON TransformSyncTime where + parseJSON = withObject "TransformSyncTime" $ \o -> do + field <- o .: "field" + delay <- o .:? "delay" + schedule <- o .:? "schedule" + let extras = + KM.fromList . filter ((`notElem` syncTimeKnownKeys) . fst) $ KM.toList o + pure + TransformSyncTime + { tstField = field, + tstDelay = delay, + tstSchedule = schedule, + tstExtras = extras + } + +instance ToJSON TransformSyncTime where + toJSON TransformSyncTime {..} = + object $ + catMaybes + [ Just ("field" .= tstField), + ("delay" .=) <$> tstDelay, + ("schedule" .=) <$> tstSchedule + ] + <> [toPair kv | kv <- KM.toList tstExtras] + where + toPair (k, v) = k .= v + +-- | The @settings@ sub-object of a 'TransformConfig'. Only the stable, +-- documented scalars are typed; everything else rides in 'tsExtras'. +data TransformSettings = TransformSettings + { tsMaxPageSearchSize :: Maybe Int, + tsDocsPerSecond :: Maybe Int, + tsAlignCheckpoints :: Maybe Bool, + tsDatesAsEpochMillis :: Maybe Bool, + tsExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +defaultTransformSettings :: TransformSettings +defaultTransformSettings = + TransformSettings + { tsMaxPageSearchSize = Nothing, + tsDocsPerSecond = Nothing, + tsAlignCheckpoints = Nothing, + tsDatesAsEpochMillis = Nothing, + tsExtras = KM.empty + } + +settingsKnownKeys :: [Key] +settingsKnownKeys = + ["max_page_search_size", "docs_per_second", "align_checkpoints", "dates_as_epoch_millis"] + +instance FromJSON TransformSettings where + parseJSON = withObject "TransformSettings" $ \o -> do + maxPageSearchSize <- o .:? "max_page_search_size" + docsPerSecond <- o .:? "docs_per_second" + alignCheckpoints <- o .:? "align_checkpoints" + datesAsEpochMillis <- o .:? "dates_as_epoch_millis" + let extras = + KM.fromList . filter ((`notElem` settingsKnownKeys) . fst) $ KM.toList o + pure + TransformSettings + { tsMaxPageSearchSize = maxPageSearchSize, + tsDocsPerSecond = docsPerSecond, + tsAlignCheckpoints = alignCheckpoints, + tsDatesAsEpochMillis = datesAsEpochMillis, + tsExtras = extras + } + +instance ToJSON TransformSettings where + toJSON TransformSettings {..} = + object $ + catMaybes + [ ("max_page_search_size" .=) <$> tsMaxPageSearchSize, + ("docs_per_second" .=) <$> tsDocsPerSecond, + ("align_checkpoints" .=) <$> tsAlignCheckpoints, + ("dates_as_epoch_millis" .=) <$> tsDatesAsEpochMillis + ] + <> [toPair kv | kv <- KM.toList tsExtras] + where + toPair (k, v) = k .= v + +-- | The transform configuration — the PUT body for +-- @PUT /_transform/{transform_id}@, the POST body for +-- @POST /_transform/_preview@, and the per-entry value in the GET +-- @transforms@ array. The @source@ and @dest@ are required (the +-- definitional core of a transform). Exactly one of @pivot@ or @latest@ +-- is present: the @pivot@ body is an opaque 'Value' (the +-- group_by\/aggregations DSL is large and already typed elsewhere — the +-- same rationale Enrich uses for @query@ and Watcher for the watch body), +-- while the smaller @latest@ config is fully typed ('TransformLatest'). +-- The GET-only fields (@id@, @version@, @create_time@) are 'Maybe' and +-- omitted on encode when absent, so the same type serves both PUT and GET. +-- @create_time@ is carried as an opaque 'Value' because ES 7.x emits it +-- as epoch-millis while 8.x\/9.x emit an ISO-8601 string. Unknown sibling +-- fields are preserved in 'tcExtras'. +data TransformConfig = TransformConfig + { tcSource :: TransformSource, + tcDest :: TransformDestination, + -- | @pivot@ — the aggregation\/group_by body. Opaque 'Value'; at most + -- one of 'tcPivot' \/ 'tcLatest'. + tcPivot :: Maybe Value, + -- | @latest@ — the latest-selection config. Typed; at most one of + -- 'tcPivot' \/ 'tcLatest'. + tcLatest :: Maybe TransformLatest, + tcDescription :: Maybe Text, + -- | @frequency@ — the execution interval (e.g. @"1m"@). + tcFrequency :: Maybe Text, + tcSync :: Maybe TransformSync, + tcSettings :: Maybe TransformSettings, + -- | @id@ — GET-only; absent from the PUT body (the id rides in the + -- URL path). + tcId :: Maybe TransformId, + -- | @version@ — GET-only server-reported version. + tcVersion :: Maybe Text, + -- | @create_time@ — GET-only. Epoch-millis (ES 7.x) or ISO-8601 (ES + -- 8.x\/9.x); carried as 'Value' to tolerate both. + tcCreateTime :: Maybe Value, + tcExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +-- | A minimal config: the supplied source and destination, no pivot\/latest, +-- no description\/frequency\/sync\/settings, no GET-only fields. Intended as +-- a starting point callers then overwrite with the record lenses; callers +-- must set exactly one of 'tcPivot' or 'tcLatest' before sending the PUT. +defaultTransformConfig :: + TransformSource -> + TransformDestination -> + TransformConfig +defaultTransformConfig source dest = + TransformConfig + { tcSource = source, + tcDest = dest, + tcPivot = Nothing, + tcLatest = Nothing, + tcDescription = Nothing, + tcFrequency = Nothing, + tcSync = Nothing, + tcSettings = Nothing, + tcId = Nothing, + tcVersion = Nothing, + tcCreateTime = Nothing, + tcExtras = KM.empty + } + +configKnownKeys :: [Key] +configKnownKeys = + [ "source", + "dest", + "pivot", + "latest", + "description", + "frequency", + "sync", + "settings", + "id", + "version", + "create_time" + ] + +instance FromJSON TransformConfig where + parseJSON = withObject "TransformConfig" $ \o -> do + source <- o .: "source" + dest <- o .: "dest" + pivot <- o .:? "pivot" + latest <- o .:? "latest" + description <- o .:? "description" + frequency <- o .:? "frequency" + sync <- o .:? "sync" + settings <- o .:? "settings" + identity <- o .:? "id" + version <- o .:? "version" + createTime <- o .:? "create_time" + let extras = + KM.fromList . filter ((`notElem` configKnownKeys) . fst) $ KM.toList o + pure + TransformConfig + { tcSource = source, + tcDest = dest, + tcPivot = pivot, + tcLatest = latest, + tcDescription = description, + tcFrequency = frequency, + tcSync = sync, + tcSettings = settings, + tcId = identity, + tcVersion = version, + tcCreateTime = createTime, + tcExtras = extras + } + +instance ToJSON TransformConfig where + -- 'object' (not 'omitNulls') so the @tcExtras@ catch-all survives a + -- round-trip even when it carries a @null@ or empty-array value — the + -- documented forward-compat guarantee. The known fields are pre-filtered + -- by 'catMaybes' (stripping 'Nothing's), so they never contribute a + -- 'Null' here, and the extras have already had the known keys stripped + -- on decode. + toJSON TransformConfig {..} = + object $ + catMaybes + [ Just ("source" .= tcSource), + Just ("dest" .= tcDest), + ("pivot" .=) <$> tcPivot, + ("latest" .=) <$> tcLatest, + ("description" .=) <$> tcDescription, + ("frequency" .=) <$> tcFrequency, + ("sync" .=) <$> tcSync, + ("settings" .=) <$> tcSettings, + ("id" .=) <$> tcId, + ("version" .=) <$> tcVersion, + ("create_time" .=) <$> tcCreateTime + ] + <> [toPair kv | kv <- KM.toList tcExtras] + where + toPair (k, v) = k .= v + +-- | Response body of @PUT /_transform/{transform_id}@: the id of the +-- created transform and an @acknowledged@ flag. Unknown sibling fields +-- are preserved in 'ptrExtras'. +data PutTransformResponse = PutTransformResponse + { ptrId :: Maybe TransformId, + ptrAcknowledged :: Maybe Bool, + ptrExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +putTransformResponseKnownKeys :: [Key] +putTransformResponseKnownKeys = ["id", "acknowledged"] + +instance FromJSON PutTransformResponse where + parseJSON = withObject "PutTransformResponse" $ \o -> do + identity <- o .:? "id" + acknowledged <- o .:? "acknowledged" + let extras = + KM.fromList . filter ((`notElem` putTransformResponseKnownKeys) . fst) $ KM.toList o + pure + PutTransformResponse + { ptrId = identity, + ptrAcknowledged = acknowledged, + ptrExtras = extras + } + +instance ToJSON PutTransformResponse where + toJSON PutTransformResponse {..} = + object $ + catMaybes + [ ("id" .=) <$> ptrId, + ("acknowledged" .=) <$> ptrAcknowledged + ] + <> [toPair kv | kv <- KM.toList ptrExtras] + where + toPair (k, v) = k .= v + +-- | Response body of @GET /_transform[/{transform_id}]@: a @count@ and the +-- @transforms@ array of 'TransformConfig' entries. Unknown sibling fields +-- are preserved in 'trExtras'. +data TransformsResponse = TransformsResponse + { trCount :: Maybe Int, + trTransforms :: [TransformConfig], + trExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +transformsResponseKnownKeys :: [Key] +transformsResponseKnownKeys = ["count", "transforms"] + +instance FromJSON TransformsResponse where + parseJSON = withObject "TransformsResponse" $ \o -> do + count <- o .:? "count" + transforms <- fromMaybe [] <$> (o .:? "transforms") + let extras = + KM.fromList . filter ((`notElem` transformsResponseKnownKeys) . fst) $ KM.toList o + pure + TransformsResponse + { trCount = count, + trTransforms = transforms, + trExtras = extras + } + +instance ToJSON TransformsResponse where + toJSON TransformsResponse {..} = + object $ + catMaybes + [ ("count" .=) <$> trCount, + Just ("transforms" .= trTransforms) + ] + <> [toPair kv | kv <- KM.toList trExtras] + where + toPair (k, v) = k .= v + +-- | Response body of @DELETE /_transform/{transform_id}@: an +-- @acknowledged@ flag plus, on ES 8+, the @deleted_tasks_count@. Unknown +-- sibling fields are preserved in 'dtrExtras'. +data DeleteTransformResponse = DeleteTransformResponse + { dtrAcknowledged :: Maybe Bool, + dtrDeletedTasksCount :: Maybe Int, + dtrExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +deleteTransformResponseKnownKeys :: [Key] +deleteTransformResponseKnownKeys = ["acknowledged", "deleted_tasks_count"] + +instance FromJSON DeleteTransformResponse where + parseJSON = withObject "DeleteTransformResponse" $ \o -> do + acknowledged <- o .:? "acknowledged" + deletedTasksCount <- o .:? "deleted_tasks_count" + let extras = + KM.fromList . filter ((`notElem` deleteTransformResponseKnownKeys) . fst) $ KM.toList o + pure + DeleteTransformResponse + { dtrAcknowledged = acknowledged, + dtrDeletedTasksCount = deletedTasksCount, + dtrExtras = extras + } + +instance ToJSON DeleteTransformResponse where + toJSON DeleteTransformResponse {..} = + object $ + catMaybes + [ ("acknowledged" .=) <$> dtrAcknowledged, + ("deleted_tasks_count" .=) <$> dtrDeletedTasksCount + ] + <> [toPair kv | kv <- KM.toList dtrExtras] + where + toPair (k, v) = k .= v + +-- | Response body of @POST /_transform/{transform_id}/_stop@: an +-- @acknowledged@ flag plus, on ES 8+, a @stopped@ flag. Unknown sibling +-- fields are preserved in 'stopTExtras'. +data StopTransformResponse = StopTransformResponse + { stopTAcknowledged :: Maybe Bool, + stopTStopped :: Maybe Bool, + stopTExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +stopTransformResponseKnownKeys :: [Key] +stopTransformResponseKnownKeys = ["acknowledged", "stopped"] + +instance FromJSON StopTransformResponse where + parseJSON = withObject "StopTransformResponse" $ \o -> do + acknowledged <- o .:? "acknowledged" + stopped <- o .:? "stopped" + let extras = + KM.fromList . filter ((`notElem` stopTransformResponseKnownKeys) . fst) $ KM.toList o + pure + StopTransformResponse + { stopTAcknowledged = acknowledged, + stopTStopped = stopped, + stopTExtras = extras + } + +instance ToJSON StopTransformResponse where + toJSON StopTransformResponse {..} = + object $ + catMaybes + [ ("acknowledged" .=) <$> stopTAcknowledged, + ("stopped" .=) <$> stopTStopped + ] + <> [toPair kv | kv <- KM.toList stopTExtras] + where + toPair (k, v) = k .= v + +-- | Response body of @POST /_transform/_preview@: a @preview@ array of +-- sample destination documents and an optional @generated_dest_index@ +-- mapping object. Both are carried as opaque 'Value's because their shape +-- is caller-defined (the preview documents mirror the destination +-- mapping). Unknown sibling fields are preserved in 'prtvExtras'. +data PreviewTransformResponse = PreviewTransformResponse + { prtvPreview :: Maybe [Value], + prtvGeneratedDestIndex :: Maybe Value, + prtvExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +previewTransformResponseKnownKeys :: [Key] +previewTransformResponseKnownKeys = ["preview", "generated_dest_index"] + +instance FromJSON PreviewTransformResponse where + parseJSON = withObject "PreviewTransformResponse" $ \o -> do + preview <- o .:? "preview" + generatedDestIndex <- o .:? "generated_dest_index" + let extras = + KM.fromList . filter ((`notElem` previewTransformResponseKnownKeys) . fst) $ KM.toList o + pure + PreviewTransformResponse + { prtvPreview = preview, + prtvGeneratedDestIndex = generatedDestIndex, + prtvExtras = extras + } + +instance ToJSON PreviewTransformResponse where + toJSON PreviewTransformResponse {..} = + object $ + catMaybes + [ ("preview" .=) <$> prtvPreview, + ("generated_dest_index" .=) <$> prtvGeneratedDestIndex + ] + <> [toPair kv | kv <- KM.toList prtvExtras] + where + toPair (k, v) = k .= v + +-- | Response body of @GET /_transform/_stats[/{transform_id}]@: a @count@ +-- and the @transforms@ array of per-transform 'TransformStats'. Unknown +-- sibling fields are preserved in 'tstrExtras'. +data TransformStatsResponse = TransformStatsResponse + { tstrCount :: Maybe Int, + tstrStats :: [TransformStats], + tstrExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +transformStatsResponseKnownKeys :: [Key] +transformStatsResponseKnownKeys = ["count", "transforms"] + +instance FromJSON TransformStatsResponse where + parseJSON = withObject "TransformStatsResponse" $ \o -> do + count <- o .:? "count" + stats <- fromMaybe [] <$> (o .:? "transforms") + let extras = + KM.fromList . filter ((`notElem` transformStatsResponseKnownKeys) . fst) $ KM.toList o + pure + TransformStatsResponse + { tstrCount = count, + tstrStats = stats, + tstrExtras = extras + } + +instance ToJSON TransformStatsResponse where + toJSON TransformStatsResponse {..} = + object $ + catMaybes + [ ("count" .=) <$> tstrCount, + Just ("transforms" .= tstrStats) + ] + <> [toPair kv | kv <- KM.toList tstrExtras] + where + toPair (k, v) = k .= v + +-- | One entry of the @GET /_transform/_stats@ @transforms@ array. The +-- stable scalar counters are typed; the nested @checkpointing@ object is +-- carried as an opaque 'Value' because its shape (checkpoint progress, +-- changes_last_detected_at, etc.) is large and version-dependent. Unknown +-- sibling fields are preserved in 'tstatExtras'. +data TransformStats = TransformStats + { tstatId :: Maybe TransformId, + tstatState :: Maybe TransformState, + tstatHealth :: Maybe TransformHealth, + tstatCheckpointing :: Maybe Value, + tstatDocumentsIndexed :: Maybe Integer, + tstatDocumentsProcessed :: Maybe Integer, + tstatDocumentsDeleted :: Maybe Integer, + tstatDocumentsFailed :: Maybe Integer, + tstatExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +transformStatsKnownKeys :: [Key] +transformStatsKnownKeys = + [ "id", + "state", + "health", + "checkpointing", + "documents_indexed", + "documents_processed", + "documents_deleted", + "documents_failed" + ] + +instance FromJSON TransformStats where + parseJSON = withObject "TransformStats" $ \o -> do + identity <- o .:? "id" + state <- o .:? "state" + health <- o .:? "health" + checkpointing <- o .:? "checkpointing" + documentsIndexed <- o .:? "documents_indexed" + documentsProcessed <- o .:? "documents_processed" + documentsDeleted <- o .:? "documents_deleted" + documentsFailed <- o .:? "documents_failed" + let extras = + KM.fromList . filter ((`notElem` transformStatsKnownKeys) . fst) $ KM.toList o + pure + TransformStats + { tstatId = identity, + tstatState = state, + tstatHealth = health, + tstatCheckpointing = checkpointing, + tstatDocumentsIndexed = documentsIndexed, + tstatDocumentsProcessed = documentsProcessed, + tstatDocumentsDeleted = documentsDeleted, + tstatDocumentsFailed = documentsFailed, + tstatExtras = extras + } + +instance ToJSON TransformStats where + toJSON TransformStats {..} = + object $ + catMaybes + [ ("id" .=) <$> tstatId, + ("state" .=) <$> tstatState, + ("health" .=) <$> tstatHealth, + ("checkpointing" .=) <$> tstatCheckpointing, + ("documents_indexed" .=) <$> tstatDocumentsIndexed, + ("documents_processed" .=) <$> tstatDocumentsProcessed, + ("documents_deleted" .=) <$> tstatDocumentsDeleted, + ("documents_failed" .=) <$> tstatDocumentsFailed + ] + <> [toPair kv | kv <- KM.toList tstatExtras] + where + toPair (k, v) = k .= v + +-- | Response body of @GET /_transform/{transform_id}/_explain@: a +-- @transforms@ array of 'TransformExplainEntry'. The explain payload is +-- highly version-dependent (the per-transform @state@ object reshuffled +-- across ES7\/8\/9), so each entry carries only the stable @id@ plus an +-- extras catch-all. Unknown top-level fields are preserved in 'texrExtras'. +data TransformExplainResponse = TransformExplainResponse + { texrTransforms :: [TransformExplainEntry], + texrExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +transformExplainResponseKnownKeys :: [Key] +transformExplainResponseKnownKeys = ["transforms"] + +instance FromJSON TransformExplainResponse where + parseJSON = withObject "TransformExplainResponse" $ \o -> do + transforms <- fromMaybe [] <$> (o .:? "transforms") + let extras = + KM.fromList . filter ((`notElem` transformExplainResponseKnownKeys) . fst) $ KM.toList o + pure + TransformExplainResponse + { texrTransforms = transforms, + texrExtras = extras + } + +instance ToJSON TransformExplainResponse where + toJSON TransformExplainResponse {..} = + object $ + [ "transforms" .= texrTransforms + ] + <> [toPair kv | kv <- KM.toList texrExtras] + where + toPair (k, v) = k .= v + +-- | One entry of the @GET /_transform/{id}/_explain@ @transforms@ array. +-- Carries the transform @id@ plus an extras catch-all for the +-- version-dependent @state@\/@checkpointing@\/@reasons@ sub-objects. +data TransformExplainEntry = TransformExplainEntry + { teeId :: Maybe TransformId, + teeExtras :: KeyMap Value + } + deriving stock (Eq, Show) + +transformExplainEntryKnownKeys :: [Key] +transformExplainEntryKnownKeys = ["id"] + +instance FromJSON TransformExplainEntry where + parseJSON = withObject "TransformExplainEntry" $ \o -> do + identity <- o .:? "id" + let extras = + KM.fromList . filter ((`notElem` transformExplainEntryKnownKeys) . fst) $ KM.toList o + pure + TransformExplainEntry + { teeId = identity, + teeExtras = extras + } + +instance ToJSON TransformExplainEntry where + toJSON TransformExplainEntry {..} = + object $ + catMaybes + [ ("id" .=) <$> teeId + ] + <> [toPair kv | kv <- KM.toList teeExtras] + where + toPair (k, v) = k .= v + +-- | URI parameters accepted by @PUT /_transform/{transform_id}@. The +-- @defer_validation@ flag skips source\/dest validation; @timeout@ bounds +-- the validation waits. +data PutTransformOptions = PutTransformOptions + { ptoDeferValidation :: Maybe Bool, + ptoTimeout :: Maybe Text + } + deriving stock (Eq, Show) + +defaultPutTransformOptions :: PutTransformOptions +defaultPutTransformOptions = + PutTransformOptions + { ptoDeferValidation = Nothing, + ptoTimeout = Nothing + } + +putTransformOptionsParams :: PutTransformOptions -> [(Text, Maybe Text)] +putTransformOptionsParams PutTransformOptions {..} = + catMaybes + [ ("defer_validation",) . Just . boolText <$> ptoDeferValidation, + ("timeout",) . Just <$> ptoTimeout + ] + +-- | URI parameters accepted by @POST /_transform/{transform_id}/_update@. +data UpdateTransformOptions = UpdateTransformOptions + { utoDeferValidation :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultUpdateTransformOptions :: UpdateTransformOptions +defaultUpdateTransformOptions = + UpdateTransformOptions + { utoDeferValidation = Nothing + } + +updateTransformOptionsParams :: UpdateTransformOptions -> [(Text, Maybe Text)] +updateTransformOptionsParams UpdateTransformOptions {..} = + catMaybes + [ ("defer_validation",) . Just . boolText <$> utoDeferValidation + ] + +-- | URI parameters accepted by @GET /_transform[/{transform_id}]@. +data GetTransformsOptions = GetTransformsOptions + { gtoFrom :: Maybe Int, + gtoSize :: Maybe Int, + gtoAllowNoMatch :: Maybe Bool, + gtoExcludeGenerated :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultGetTransformsOptions :: GetTransformsOptions +defaultGetTransformsOptions = + GetTransformsOptions + { gtoFrom = Nothing, + gtoSize = Nothing, + gtoAllowNoMatch = Nothing, + gtoExcludeGenerated = Nothing + } + +getTransformsOptionsParams :: GetTransformsOptions -> [(Text, Maybe Text)] +getTransformsOptionsParams GetTransformsOptions {..} = + catMaybes + [ ("from",) . Just . showText <$> gtoFrom, + ("size",) . Just . showText <$> gtoSize, + ("allow_no_match",) . Just . boolText <$> gtoAllowNoMatch, + ("exclude_generated",) . Just . boolText <$> gtoExcludeGenerated + ] + +-- | URI parameters accepted by @DELETE /_transform/{transform_id}@. The +-- @force@ flag deletes a transform regardless of its state; the ES 8+ +-- @delete_dest_index@ flag also removes the destination index. +data DeleteTransformOptions = DeleteTransformOptions + { dtoForce :: Maybe Bool, + dtoDeleteDestIndex :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultDeleteTransformOptions :: DeleteTransformOptions +defaultDeleteTransformOptions = + DeleteTransformOptions + { dtoForce = Nothing, + dtoDeleteDestIndex = Nothing + } + +deleteTransformOptionsParams :: DeleteTransformOptions -> [(Text, Maybe Text)] +deleteTransformOptionsParams DeleteTransformOptions {..} = + catMaybes + [ ("force",) . Just . boolText <$> dtoForce, + ("delete_dest_index",) . Just . boolText <$> dtoDeleteDestIndex + ] + +-- | URI parameters accepted by @POST /_transform/{transform_id}/_start@. +data StartTransformOptions = StartTransformOptions + { stoDeferValidation :: Maybe Bool, + stoTimeout :: Maybe Text + } + deriving stock (Eq, Show) + +defaultStartTransformOptions :: StartTransformOptions +defaultStartTransformOptions = + StartTransformOptions + { stoDeferValidation = Nothing, + stoTimeout = Nothing + } + +startTransformOptionsParams :: StartTransformOptions -> [(Text, Maybe Text)] +startTransformOptionsParams StartTransformOptions {..} = + catMaybes + [ ("defer_validation",) . Just . boolText <$> stoDeferValidation, + ("timeout",) . Just <$> stoTimeout + ] + +-- | URI parameters accepted by @POST /_transform/{transform_id}/_stop@. +-- The @wait_for_checkpoint@ flag blocks until the active checkpoint +-- finishes; @wait_for_completion@ bounds that wait with a timeout. +data StopTransformOptions = StopTransformOptions + { sopoWaitForCheckpoint :: Maybe Bool, + sopoWaitForCompletion :: Maybe Text, + sopoTimeout :: Maybe Text, + sopoAllowNoMatch :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultStopTransformOptions :: StopTransformOptions +defaultStopTransformOptions = + StopTransformOptions + { sopoWaitForCheckpoint = Nothing, + sopoWaitForCompletion = Nothing, + sopoTimeout = Nothing, + sopoAllowNoMatch = Nothing + } + +stopTransformOptionsParams :: StopTransformOptions -> [(Text, Maybe Text)] +stopTransformOptionsParams StopTransformOptions {..} = + catMaybes + [ ("wait_for_checkpoint",) . Just . boolText <$> sopoWaitForCheckpoint, + ("wait_for_completion",) . Just <$> sopoWaitForCompletion, + ("timeout",) . Just <$> sopoTimeout, + ("allow_no_match",) . Just . boolText <$> sopoAllowNoMatch + ] + +-- | URI parameters accepted by @POST /_transform/_preview@. +data PreviewTransformOptions = PreviewTransformOptions + { protoTimeout :: Maybe Text + } + deriving stock (Eq, Show) + +defaultPreviewTransformOptions :: PreviewTransformOptions +defaultPreviewTransformOptions = + PreviewTransformOptions + { protoTimeout = Nothing + } + +previewTransformOptionsParams :: PreviewTransformOptions -> [(Text, Maybe Text)] +previewTransformOptionsParams PreviewTransformOptions {..} = + catMaybes + [ ("timeout",) . Just <$> protoTimeout + ] + +-- | URI parameters accepted by @GET /_transform/_stats[/{transform_id}]@. +data GetTransformStatsOptions = GetTransformStatsOptions + { gtsoFrom :: Maybe Int, + gtsoSize :: Maybe Int, + gtsoAllowNoMatch :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultGetTransformStatsOptions :: GetTransformStatsOptions +defaultGetTransformStatsOptions = + GetTransformStatsOptions + { gtsoFrom = Nothing, + gtsoSize = Nothing, + gtsoAllowNoMatch = Nothing + } + +getTransformStatsOptionsParams :: GetTransformStatsOptions -> [(Text, Maybe Text)] +getTransformStatsOptionsParams GetTransformStatsOptions {..} = + catMaybes + [ ("from",) . Just . showText <$> gtsoFrom, + ("size",) . Just . showText <$> gtsoSize, + ("allow_no_match",) . Just . boolText <$> gtsoAllowNoMatch + ] + +-- | Render a 'Bool' as the @true@\/@false@ string ES expects in query +-- parameters. +boolText :: Bool -> Text +boolText True = "true" +boolText False = "false" + +------------------------------------------------------------------------------ +-- Lenses +------------------------------------------------------------------------------ + +transformSourceIndexLens :: + Lens' TransformSource (NonEmpty IndexPattern) +transformSourceIndexLens = + lens tsocIndex (\x y -> x {tsocIndex = y}) + +transformSourceQueryLens :: + Lens' TransformSource (Maybe Value) +transformSourceQueryLens = + lens tsocQuery (\x y -> x {tsocQuery = y}) + +transformSourceRuntimeMappingsLens :: + Lens' TransformSource (Maybe Value) +transformSourceRuntimeMappingsLens = + lens tsocRuntimeMappings (\x y -> x {tsocRuntimeMappings = y}) + +transformSourceExtrasLens :: + Lens' TransformSource (KeyMap Value) +transformSourceExtrasLens = + lens tsocExtras (\x y -> x {tsocExtras = y}) + +transformDestinationIndexLens :: + Lens' TransformDestination IndexName +transformDestinationIndexLens = + lens tdestIndex (\x y -> x {tdestIndex = y}) + +transformDestinationPipelineLens :: + Lens' TransformDestination (Maybe Text) +transformDestinationPipelineLens = + lens tdestPipeline (\x y -> x {tdestPipeline = y}) + +transformDestinationExtrasLens :: + Lens' TransformDestination (KeyMap Value) +transformDestinationExtrasLens = + lens tdestExtras (\x y -> x {tdestExtras = y}) + +transformLatestUniqueKeyLens :: + Lens' TransformLatest (NonEmpty FieldName) +transformLatestUniqueKeyLens = + lens tlUniqueKey (\x y -> x {tlUniqueKey = y}) + +transformLatestSortLens :: Lens' TransformLatest FieldName +transformLatestSortLens = + lens tlSort (\x y -> x {tlSort = y}) + +transformLatestExtrasLens :: + Lens' TransformLatest (KeyMap Value) +transformLatestExtrasLens = + lens tlExtras (\x y -> x {tlExtras = y}) + +transformSyncTimeLens :: + Lens' TransformSync (Maybe TransformSyncTime) +transformSyncTimeLens = + lens tsyTime (\x y -> x {tsyTime = y}) + +transformSyncExtrasLens :: + Lens' TransformSync (KeyMap Value) +transformSyncExtrasLens = + lens tsyExtras (\x y -> x {tsyExtras = y}) + +transformSyncTimeFieldLens :: + Lens' TransformSyncTime FieldName +transformSyncTimeFieldLens = + lens tstField (\x y -> x {tstField = y}) + +transformSyncTimeDelayLens :: + Lens' TransformSyncTime (Maybe Text) +transformSyncTimeDelayLens = + lens tstDelay (\x y -> x {tstDelay = y}) + +transformSyncTimeScheduleLens :: + Lens' TransformSyncTime (Maybe Value) +transformSyncTimeScheduleLens = + lens tstSchedule (\x y -> x {tstSchedule = y}) + +transformSyncTimeExtrasLens :: + Lens' TransformSyncTime (KeyMap Value) +transformSyncTimeExtrasLens = + lens tstExtras (\x y -> x {tstExtras = y}) + +transformSettingsMaxPageSearchSizeLens :: + Lens' TransformSettings (Maybe Int) +transformSettingsMaxPageSearchSizeLens = + lens tsMaxPageSearchSize (\x y -> x {tsMaxPageSearchSize = y}) + +transformSettingsDocsPerSecondLens :: + Lens' TransformSettings (Maybe Int) +transformSettingsDocsPerSecondLens = + lens tsDocsPerSecond (\x y -> x {tsDocsPerSecond = y}) + +transformSettingsAlignCheckpointsLens :: + Lens' TransformSettings (Maybe Bool) +transformSettingsAlignCheckpointsLens = + lens tsAlignCheckpoints (\x y -> x {tsAlignCheckpoints = y}) + +transformSettingsDatesAsEpochMillisLens :: + Lens' TransformSettings (Maybe Bool) +transformSettingsDatesAsEpochMillisLens = + lens tsDatesAsEpochMillis (\x y -> x {tsDatesAsEpochMillis = y}) + +transformSettingsExtrasLens :: + Lens' TransformSettings (KeyMap Value) +transformSettingsExtrasLens = + lens tsExtras (\x y -> x {tsExtras = y}) + +transformConfigSourceLens :: + Lens' TransformConfig TransformSource +transformConfigSourceLens = + lens tcSource (\x y -> x {tcSource = y}) + +transformConfigDestLens :: + Lens' TransformConfig TransformDestination +transformConfigDestLens = + lens tcDest (\x y -> x {tcDest = y}) + +transformConfigPivotLens :: + Lens' TransformConfig (Maybe Value) +transformConfigPivotLens = + lens tcPivot (\x y -> x {tcPivot = y}) + +transformConfigLatestLens :: + Lens' TransformConfig (Maybe TransformLatest) +transformConfigLatestLens = + lens tcLatest (\x y -> x {tcLatest = y}) + +transformConfigDescriptionLens :: + Lens' TransformConfig (Maybe Text) +transformConfigDescriptionLens = + lens tcDescription (\x y -> x {tcDescription = y}) + +transformConfigFrequencyLens :: + Lens' TransformConfig (Maybe Text) +transformConfigFrequencyLens = + lens tcFrequency (\x y -> x {tcFrequency = y}) + +transformConfigSyncLens :: + Lens' TransformConfig (Maybe TransformSync) +transformConfigSyncLens = + lens tcSync (\x y -> x {tcSync = y}) + +transformConfigSettingsLens :: + Lens' TransformConfig (Maybe TransformSettings) +transformConfigSettingsLens = + lens tcSettings (\x y -> x {tcSettings = y}) + +transformConfigIdLens :: + Lens' TransformConfig (Maybe TransformId) +transformConfigIdLens = + lens tcId (\x y -> x {tcId = y}) + +transformConfigVersionLens :: + Lens' TransformConfig (Maybe Text) +transformConfigVersionLens = + lens tcVersion (\x y -> x {tcVersion = y}) + +transformConfigCreateTimeLens :: + Lens' TransformConfig (Maybe Value) +transformConfigCreateTimeLens = + lens tcCreateTime (\x y -> x {tcCreateTime = y}) + +transformConfigExtrasLens :: + Lens' TransformConfig (KeyMap Value) +transformConfigExtrasLens = + lens tcExtras (\x y -> x {tcExtras = y}) + +putTransformResponseIdLens :: + Lens' PutTransformResponse (Maybe TransformId) +putTransformResponseIdLens = + lens ptrId (\x y -> x {ptrId = y}) + +putTransformResponseAcknowledgedLens :: + Lens' PutTransformResponse (Maybe Bool) +putTransformResponseAcknowledgedLens = + lens ptrAcknowledged (\x y -> x {ptrAcknowledged = y}) + +putTransformResponseExtrasLens :: + Lens' PutTransformResponse (KeyMap Value) +putTransformResponseExtrasLens = + lens ptrExtras (\x y -> x {ptrExtras = y}) + +transformsResponseCountLens :: + Lens' TransformsResponse (Maybe Int) +transformsResponseCountLens = + lens trCount (\x y -> x {trCount = y}) + +transformsResponseTransformsLens :: + Lens' TransformsResponse [TransformConfig] +transformsResponseTransformsLens = + lens trTransforms (\x y -> x {trTransforms = y}) + +transformsResponseExtrasLens :: + Lens' TransformsResponse (KeyMap Value) +transformsResponseExtrasLens = + lens trExtras (\x y -> x {trExtras = y}) + +deleteTransformResponseAcknowledgedLens :: + Lens' DeleteTransformResponse (Maybe Bool) +deleteTransformResponseAcknowledgedLens = + lens dtrAcknowledged (\x y -> x {dtrAcknowledged = y}) + +deleteTransformResponseDeletedTasksCountLens :: + Lens' DeleteTransformResponse (Maybe Int) +deleteTransformResponseDeletedTasksCountLens = + lens dtrDeletedTasksCount (\x y -> x {dtrDeletedTasksCount = y}) + +deleteTransformResponseExtrasLens :: + Lens' DeleteTransformResponse (KeyMap Value) +deleteTransformResponseExtrasLens = + lens dtrExtras (\x y -> x {dtrExtras = y}) + +stopTransformResponseAcknowledgedLens :: + Lens' StopTransformResponse (Maybe Bool) +stopTransformResponseAcknowledgedLens = + lens stopTAcknowledged (\x y -> x {stopTAcknowledged = y}) + +stopTransformResponseStoppedLens :: + Lens' StopTransformResponse (Maybe Bool) +stopTransformResponseStoppedLens = + lens stopTStopped (\x y -> x {stopTStopped = y}) + +stopTransformResponseExtrasLens :: + Lens' StopTransformResponse (KeyMap Value) +stopTransformResponseExtrasLens = + lens stopTExtras (\x y -> x {stopTExtras = y}) + +previewTransformResponsePreviewLens :: + Lens' PreviewTransformResponse (Maybe [Value]) +previewTransformResponsePreviewLens = + lens prtvPreview (\x y -> x {prtvPreview = y}) + +previewTransformResponseGeneratedDestIndexLens :: + Lens' PreviewTransformResponse (Maybe Value) +previewTransformResponseGeneratedDestIndexLens = + lens prtvGeneratedDestIndex (\x y -> x {prtvGeneratedDestIndex = y}) + +previewTransformResponseExtrasLens :: + Lens' PreviewTransformResponse (KeyMap Value) +previewTransformResponseExtrasLens = + lens prtvExtras (\x y -> x {prtvExtras = y}) + +transformStatsResponseCountLens :: + Lens' TransformStatsResponse (Maybe Int) +transformStatsResponseCountLens = + lens tstrCount (\x y -> x {tstrCount = y}) + +transformStatsResponseStatsLens :: + Lens' TransformStatsResponse [TransformStats] +transformStatsResponseStatsLens = + lens tstrStats (\x y -> x {tstrStats = y}) + +transformStatsResponseExtrasLens :: + Lens' TransformStatsResponse (KeyMap Value) +transformStatsResponseExtrasLens = + lens tstrExtras (\x y -> x {tstrExtras = y}) + +transformStatsIdLens :: + Lens' TransformStats (Maybe TransformId) +transformStatsIdLens = + lens tstatId (\x y -> x {tstatId = y}) + +transformStatsStateLens :: + Lens' TransformStats (Maybe TransformState) +transformStatsStateLens = + lens tstatState (\x y -> x {tstatState = y}) + +transformStatsHealthLens :: + Lens' TransformStats (Maybe TransformHealth) +transformStatsHealthLens = + lens tstatHealth (\x y -> x {tstatHealth = y}) + +transformStatsCheckpointingLens :: + Lens' TransformStats (Maybe Value) +transformStatsCheckpointingLens = + lens tstatCheckpointing (\x y -> x {tstatCheckpointing = y}) + +transformStatsDocumentsIndexedLens :: + Lens' TransformStats (Maybe Integer) +transformStatsDocumentsIndexedLens = + lens tstatDocumentsIndexed (\x y -> x {tstatDocumentsIndexed = y}) + +transformStatsDocumentsProcessedLens :: + Lens' TransformStats (Maybe Integer) +transformStatsDocumentsProcessedLens = + lens tstatDocumentsProcessed (\x y -> x {tstatDocumentsProcessed = y}) + +transformStatsDocumentsDeletedLens :: + Lens' TransformStats (Maybe Integer) +transformStatsDocumentsDeletedLens = + lens tstatDocumentsDeleted (\x y -> x {tstatDocumentsDeleted = y}) + +transformStatsDocumentsFailedLens :: + Lens' TransformStats (Maybe Integer) +transformStatsDocumentsFailedLens = + lens tstatDocumentsFailed (\x y -> x {tstatDocumentsFailed = y}) + +transformStatsExtrasLens :: + Lens' TransformStats (KeyMap Value) +transformStatsExtrasLens = + lens tstatExtras (\x y -> x {tstatExtras = y}) + +transformExplainResponseTransformsLens :: + Lens' TransformExplainResponse [TransformExplainEntry] +transformExplainResponseTransformsLens = + lens texrTransforms (\x y -> x {texrTransforms = y}) + +transformExplainResponseExtrasLens :: + Lens' TransformExplainResponse (KeyMap Value) +transformExplainResponseExtrasLens = + lens texrExtras (\x y -> x {texrExtras = y}) + +transformExplainEntryIdLens :: + Lens' TransformExplainEntry (Maybe TransformId) +transformExplainEntryIdLens = + lens teeId (\x y -> x {teeId = y}) + +transformExplainEntryExtrasLens :: + Lens' TransformExplainEntry (KeyMap Value) +transformExplainEntryExtrasLens = + lens teeExtras (\x y -> x {teeExtras = y}) + +putTransformOptionsDeferValidationLens :: + Lens' PutTransformOptions (Maybe Bool) +putTransformOptionsDeferValidationLens = + lens ptoDeferValidation (\x y -> x {ptoDeferValidation = y}) + +updateTransformOptionsDeferValidationLens :: + Lens' UpdateTransformOptions (Maybe Bool) +updateTransformOptionsDeferValidationLens = + lens utoDeferValidation (\x y -> x {utoDeferValidation = y}) + +getTransformsOptionsFromLens :: + Lens' GetTransformsOptions (Maybe Int) +getTransformsOptionsFromLens = + lens gtoFrom (\x y -> x {gtoFrom = y}) + +getTransformsOptionsSizeLens :: + Lens' GetTransformsOptions (Maybe Int) +getTransformsOptionsSizeLens = + lens gtoSize (\x y -> x {gtoSize = y}) + +getTransformsOptionsAllowNoMatchLens :: + Lens' GetTransformsOptions (Maybe Bool) +getTransformsOptionsAllowNoMatchLens = + lens gtoAllowNoMatch (\x y -> x {gtoAllowNoMatch = y}) + +getTransformsOptionsExcludeGeneratedLens :: + Lens' GetTransformsOptions (Maybe Bool) +getTransformsOptionsExcludeGeneratedLens = + lens gtoExcludeGenerated (\x y -> x {gtoExcludeGenerated = y}) + +deleteTransformOptionsForceLens :: + Lens' DeleteTransformOptions (Maybe Bool) +deleteTransformOptionsForceLens = + lens dtoForce (\x y -> x {dtoForce = y}) + +deleteTransformOptionsDeleteDestIndexLens :: + Lens' DeleteTransformOptions (Maybe Bool) +deleteTransformOptionsDeleteDestIndexLens = + lens dtoDeleteDestIndex (\x y -> x {dtoDeleteDestIndex = y}) + +startTransformOptionsDeferValidationLens :: + Lens' StartTransformOptions (Maybe Bool) +startTransformOptionsDeferValidationLens = + lens stoDeferValidation (\x y -> x {stoDeferValidation = y}) + +stopTransformOptionsWaitForCheckpointLens :: + Lens' StopTransformOptions (Maybe Bool) +stopTransformOptionsWaitForCheckpointLens = + lens sopoWaitForCheckpoint (\x y -> x {sopoWaitForCheckpoint = y}) + +stopTransformOptionsWaitForCompletionLens :: + Lens' StopTransformOptions (Maybe Text) +stopTransformOptionsWaitForCompletionLens = + lens sopoWaitForCompletion (\x y -> x {sopoWaitForCompletion = y}) + +stopTransformOptionsAllowNoMatchLens :: + Lens' StopTransformOptions (Maybe Bool) +stopTransformOptionsAllowNoMatchLens = + lens sopoAllowNoMatch (\x y -> x {sopoAllowNoMatch = y}) + +getTransformStatsOptionsFromLens :: + Lens' GetTransformStatsOptions (Maybe Int) +getTransformStatsOptionsFromLens = + lens gtsoFrom (\x y -> x {gtsoFrom = y}) + +getTransformStatsOptionsSizeLens :: + Lens' GetTransformStatsOptions (Maybe Int) +getTransformStatsOptionsSizeLens = + lens gtsoSize (\x y -> x {gtsoSize = y}) + +getTransformStatsOptionsAllowNoMatchLens :: + Lens' GetTransformStatsOptions (Maybe Bool) +getTransformStatsOptionsAllowNoMatchLens = + lens gtsoAllowNoMatch (\x y -> x {gtsoAllowNoMatch = y}) + +putTransformOptionsTimeoutLens :: + Lens' PutTransformOptions (Maybe Text) +putTransformOptionsTimeoutLens = + lens ptoTimeout (\x y -> x {ptoTimeout = y}) + +startTransformOptionsTimeoutLens :: + Lens' StartTransformOptions (Maybe Text) +startTransformOptionsTimeoutLens = + lens stoTimeout (\x y -> x {stoTimeout = y}) + +stopTransformOptionsTimeoutLens :: + Lens' StopTransformOptions (Maybe Text) +stopTransformOptionsTimeoutLens = + lens sopoTimeout (\x y -> x {sopoTimeout = y}) + +previewTransformOptionsTimeoutLens :: + Lens' PreviewTransformOptions (Maybe Text) +previewTransformOptionsTimeoutLens = + lens protoTimeout (\x y -> x {protoTimeout = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Units.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Units.hs --- a/src/Database/Bloodhound/Internal/Versions/Common/Types/Units.hs +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Units.hs @@ -5,6 +5,7 @@ Interval (..), TimeInterval (..), FixedInterval (..), + TimeUnits (..), TimeZoneOffset (..), TimeOffset (..), ExtendedBounds (..), @@ -12,6 +13,7 @@ kilobytes, megabytes, parseStringInterval, + timeUnitsSuffix, fixedIntervalDurationLens, fixedIntervalUnitLens, timeZoneOffsetHoursLens, @@ -21,13 +23,14 @@ ) where +import Data.Char (isDigit) import Data.Int -import qualified Data.Text as T +import Data.Text qualified as T import Data.Word import Database.Bloodhound.Internal.Utils.Imports import Text.Printf (printf) import Text.Read (Read (..)) -import qualified Text.Read as TR +import Text.Read qualified as TR -- | A measure of bytes used for various configurations. You may want -- to use smart constructors like 'gigabytes' for larger values. @@ -131,6 +134,59 @@ instance ToJSON FixedInterval where toJSON (FixedInterval duration unit) = String (showText duration <> T.pack (show unit)) + +-- | Parses the wire form produced by the 'ToJSON' instance (e.g. @\"1h\"@, +-- @\"30m\"@, @\"7d\"@): a leading decimal duration followed by a single +-- 'TimeInterval' suffix. The complement of the 'ToJSON' instance, so a +-- 'FixedInterval' round-trips through JSON. +instance FromJSON FixedInterval where + parseJSON = withText "FixedInterval" $ \t -> + case T.span isDigit t of + (d, u) + | T.null d -> fail ("FixedInterval: missing duration in " <> show t) + | otherwise -> case (TR.readMaybe (T.unpack d), TR.readMaybe (T.unpack u)) of + (Just duration, Just unit) -> + return FixedInterval {fixedIntervalDuration = duration, fixedIntervalUnit = unit} + _ -> fail ("FixedInterval: cannot parse " <> show t) + +-- | Coarse time units accepted in URI parameters such as @timeout@, +-- @master_timeout@, or @cancel_after_time_interval@. The set matches +-- both the Elasticsearch and OpenSearch time-unit grammars +-- (e.g. ). +data TimeUnits + = TimeUnitDays + | TimeUnitHours + | TimeUnitMinutes + | TimeUnitSeconds + | TimeUnitMilliseconds + | TimeUnitMicroseconds + | TimeUnitNanoseconds + deriving stock (Eq, Ord, Show) + +-- | Wire suffix for a 'TimeUnits' value (e.g. 'TimeUnitSeconds' -> @"s"@, +-- 'TimeUnitMilliseconds' -> @"ms"@). Both the 'ToJSON' instance and the +-- various URI param renderers go through this function. +timeUnitsSuffix :: TimeUnits -> Text +timeUnitsSuffix TimeUnitDays = "d" +timeUnitsSuffix TimeUnitHours = "h" +timeUnitsSuffix TimeUnitMinutes = "m" +timeUnitsSuffix TimeUnitSeconds = "s" +timeUnitsSuffix TimeUnitMilliseconds = "ms" +timeUnitsSuffix TimeUnitMicroseconds = "micros" +timeUnitsSuffix TimeUnitNanoseconds = "nanos" + +instance ToJSON TimeUnits where + toJSON = String . timeUnitsSuffix + +instance FromJSON TimeUnits where + parseJSON (String "d") = pure TimeUnitDays + parseJSON (String "h") = pure TimeUnitHours + parseJSON (String "m") = pure TimeUnitMinutes + parseJSON (String "s") = pure TimeUnitSeconds + parseJSON (String "ms") = pure TimeUnitMilliseconds + parseJSON (String "micros") = pure TimeUnitMicroseconds + parseJSON (String "nanos") = pure TimeUnitNanoseconds + parseJSON _ = empty data TimeZoneOffset = TimeZoneOffset { timeZoneOffsetHours :: Int8, diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Validate.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Validate.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Validate +-- License : BSD-style (see the file LICENSE) +-- +-- Types for the @POST \/{index}/_validate/query@ endpoint, shared +-- verbatim by Elasticsearch (7.x\/8.x\/9.x) and OpenSearch +-- (1.x\/2.x\/3.x). See +-- +-- * +-- * +module Database.Bloodhound.Internal.Versions.Common.Types.Validate + ( -- * Response types + ValidateQueryResponse (..), + ValidateExplanation (..), + + -- * Request body + ValidateQuery (..), + + -- * URI parameters + ValidateOptions (..), + defaultValidateOptions, + validateOptionsParams, + + -- * Optics + validateQueryResponseValidLens, + validateQueryResponseShardsLens, + validateQueryResponseExplanationsLens, + validateExplanationIndexLens, + validateExplanationShardLens, + validateExplanationValidLens, + validateExplanationExplanationLens, + validateExplanationErrorLens, + voExplainLens, + voAllLens, + voRewriteLens, + voIgnoreUnavailableLens, + voAllowNoIndicesLens, + voExpandWildcardsLens, + voQLens, + voAnalyzerLens, + voAnalyzeWildcardLens, + voDefaultOperatorLens, + voDfLens, + voLenientLens, + voDefaultFieldLens, + ) +where + +import Data.Aeson +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens) +import Database.Bloodhound.Internal.Versions.Common.Types.Count + ( CountShards, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( IndexName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Query + ( Query, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Query.Commons + ( BooleanOperator (And, Or), + ) + +-- | Top-level response of @POST \/{index}/_validate/query@. The +-- @valid@ flag is always present and reports whether the supplied +-- 'Query' parsed successfully against the (resolved) index mapping. +-- +-- The @_shards@ object is only present when the request was sent with +-- @all=true@ (or when the server independently decided to broadcast +-- the validation across the cluster); it is therefore modelled as a +-- 'Maybe'. Likewise the @explanations@ array is only present when the +-- request opted into detailed feedback via @explain=true@. Both +-- default to 'Nothing' on the minimal @{"valid":bool}@ response +-- returned by a parameterless call. +data ValidateQueryResponse = ValidateQueryResponse + { -- | Whether the supplied 'Query' parsed successfully. + validateQueryResponseValid :: Bool, + -- | Shard-level execution summary. Present only when the request + -- set 'voAll' to @Just True@; 'Nothing' on the minimal response. + validateQueryResponseShards :: Maybe CountShards, + -- | Per-index explanations. Present only when the request set + -- 'voExplain' to @Just True@; 'Nothing' on the minimal + -- response. When present, the array has one entry per + -- concrete index that the validation considered. + validateQueryResponseExplanations :: Maybe [ValidateExplanation] + } + deriving stock (Eq, Show) + +instance FromJSON ValidateQueryResponse where + parseJSON = withObject "ValidateQueryResponse" $ \o -> + ValidateQueryResponse + <$> o + .: "valid" + <*> o + .:? "_shards" + <*> o + .:? "explanations" + +instance ToJSON ValidateQueryResponse where + toJSON ValidateQueryResponse {..} = + object $ + catMaybes + [ Just ("valid" .= validateQueryResponseValid), + ("_shards" .=) <$> validateQueryResponseShards, + ("explanations" .=) <$> validateQueryResponseExplanations + ] + +-- | One element of the @explanations@ array returned by +-- @POST \/{index}/_validate/query?explain=true@. Each entry reports +-- the validation outcome for a single concrete index (and, when +-- present, a specific shard). +-- +-- The 'validateExplanationExplanation' field is a human-readable +-- description produced by the server's Lucene query rewrite +-- pipeline. Its exact format is server-defined, not stable across +-- versions, and intended for diagnostic display rather than +-- programmatic parsing. +data ValidateExplanation = ValidateExplanation + { -- | Index the validation considered. The server omits @index@ + -- when validation is not scoped to a specific index (rare). + validateExplanationIndex :: Maybe IndexName, + -- | Shard identifier the validation considered. Present only in + -- the @?explain=true@ form on a single-index request; absent + -- otherwise. + validateExplanationShard :: Maybe Text, + -- | Per-index validity flag. Always present in the explanations + -- array. + validateExplanationValid :: Bool, + -- | Human-readable Lucene rewrite of the parsed query, produced + -- by the server. Present only when the rewrite pipeline was + -- invoked; absent on parse failures and on per-shard entries + -- that did not produce a rewrite. + validateExplanationExplanation :: Maybe Text, + -- | Server-supplied error message describing why validation + -- failed. Present (and 'Just') only when + -- 'validateExplanationValid' is @False@; absent on a successful + -- parse. + validateExplanationError :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ValidateExplanation where + parseJSON = withObject "ValidateExplanation" $ \o -> + ValidateExplanation + <$> o + .:? "index" + <*> o + .:? "shard" + <*> o + .: "valid" + <*> o + .:? "explanation" + <*> o + .:? "error" + +instance ToJSON ValidateExplanation where + toJSON ValidateExplanation {..} = + object $ + catMaybes + [ ("index" .=) <$> validateExplanationIndex, + ("shard" .=) <$> validateExplanationShard, + Just ("valid" .= validateExplanationValid), + ("explanation" .=) <$> validateExplanationExplanation, + ("error" .=) <$> validateExplanationError + ] + +-- Lenses for ValidateQueryResponse + +validateQueryResponseValidLens :: Lens' ValidateQueryResponse Bool +validateQueryResponseValidLens = + lens validateQueryResponseValid (\x y -> x {validateQueryResponseValid = y}) + +validateQueryResponseShardsLens :: Lens' ValidateQueryResponse (Maybe CountShards) +validateQueryResponseShardsLens = + lens validateQueryResponseShards (\x y -> x {validateQueryResponseShards = y}) + +validateQueryResponseExplanationsLens :: Lens' ValidateQueryResponse (Maybe [ValidateExplanation]) +validateQueryResponseExplanationsLens = + lens + validateQueryResponseExplanations + (\x y -> x {validateQueryResponseExplanations = y}) + +-- Lenses for ValidateExplanation + +validateExplanationIndexLens :: Lens' ValidateExplanation (Maybe IndexName) +validateExplanationIndexLens = + lens validateExplanationIndex (\x y -> x {validateExplanationIndex = y}) + +validateExplanationShardLens :: Lens' ValidateExplanation (Maybe Text) +validateExplanationShardLens = + lens validateExplanationShard (\x y -> x {validateExplanationShard = y}) + +validateExplanationValidLens :: Lens' ValidateExplanation Bool +validateExplanationValidLens = + lens validateExplanationValid (\x y -> x {validateExplanationValid = y}) + +validateExplanationExplanationLens :: Lens' ValidateExplanation (Maybe Text) +validateExplanationExplanationLens = + lens validateExplanationExplanation (\x y -> x {validateExplanationExplanation = y}) + +validateExplanationErrorLens :: Lens' ValidateExplanation (Maybe Text) +validateExplanationErrorLens = + lens validateExplanationError (\x y -> x {validateExplanationError = y}) + +-- | Request body of the @_validate/query@ endpoint: a 'Query' wrapped +-- as @{"query": ...}@. The server rejects the larger 'Search' body +-- shape, so the request builder takes a 'Query' directly and wraps it +-- in this newtype. Mirrors +-- "Database.Bloodhound.Internal.Versions.Common.Types.Count".CountQuery +-- and +-- "Database.Bloodhound.Internal.Versions.Common.Types.Explain".ExplainQuery. +newtype ValidateQuery = ValidateQuery {validateQueryQuery :: Query} + deriving stock (Eq, Show) + +instance ToJSON ValidateQuery where + toJSON (ValidateQuery q) = object ["query" .= q] + +-- | URI parameters accepted by @POST \/{index}/_validate/query@ and +-- @POST /_validate/query@. See +-- +-- and +-- . +-- +-- Every field is 'Maybe'; 'defaultValidateOptions' leaves them all +-- @Nothing@, which emits no query string and is therefore +-- byte-for-byte equivalent to the legacy parameterless +-- 'Database.Bloodhound.Common.Requests.validateQuery'. +-- +-- The two parameters most users reach for: +-- +-- * 'voExplain' — request detailed per-index explanations (the +-- @explanations@ array on 'ValidateQueryResponse'). +-- * 'voAll' — broadcast the validation across the cluster and +-- surface the @_shards@ summary on 'ValidateQueryResponse'. +-- +-- The remaining parameters mirror the URI search surface +-- (@expand_wildcards@, @ignore_unavailable@, @allow_no_indices@, the +-- query-parsing knobs @q@\/@df@\/@analyzer@\/@analyze_wildcard@\/ +-- @default_operator@\/@lenient@, plus the Lucene-rewrite knob +-- @rewrite@ and the legacy @default_field@). The query-parsing +-- parameters only affect the URI-query form of @_validate/query@ +-- (when @q=...@ is used in place of a JSON body); they are modelled +-- here prospectively for completeness and have no effect when the +-- request is driven by a JSON 'ValidateQuery' body. +data ValidateOptions = ValidateOptions + { -- | @explain@ — when @Just True@, the response gains the + -- @explanations@ array (one entry per concrete index). + voExplain :: Maybe Bool, + -- | @all@ — when @Just True@, broadcast validation across the + -- cluster. The response gains the @_shards@ summary. + voAll :: Maybe Bool, + -- | @rewrite@ — Lucene rewrite method used when @explain=true@ + -- (e.g. @"constant_score_boolean"@, @"top_terms_N"@). + voRewrite :: Maybe Text, + -- | @ignore_unavailable@ — skip missing\/closed indices silently. + voIgnoreUnavailable :: Maybe Bool, + -- | @allow_no_indices@ — short-circuit if no concrete index + -- matches the request. + voAllowNoIndices :: Maybe Bool, + -- | @expand_wildcards@ — wildcard-pattern expansion policy. + -- Reuses the 'ExpandWildcards' sum type shared with the count, + -- search and explain endpoints. + voExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + -- | @q@ — URI-form query string (alternative to a JSON + -- 'ValidateQuery' body). + voQ :: Maybe Text, + -- | @analyzer@ — analyzer to apply to the query string. + voAnalyzer :: Maybe Text, + -- | @analyze_wildcard@ — when @Just True@, wildcard terms are + -- analyzed. + voAnalyzeWildcard :: Maybe Bool, + -- | @default_operator@ — default boolean operator for the + -- query-string form (@AND@\/@OR@). ES accepts @and@\/@AND@\/ + -- @or@\/@OR@ on the wire; we emit the canonical uppercase form + -- used in the ES docs prose, matching the convention in + -- "Database.Bloodhound.Internal.Versions.Common.Types.Explain". + voDefaultOperator :: Maybe BooleanOperator, + -- | @df@ — default field for query-string terms without an + -- explicit field prefix. + voDf :: Maybe Text, + -- | @lenient@ — when @Just True@, format-based failures are + -- ignored. + voLenient :: Maybe Bool, + -- | @default_field@ — legacy override of the index-time default + -- field. Prefer the field-prefixed query-string form or the + -- @indices_query@ field; modelled here for completeness. + voDefaultField :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'ValidateOptions' with every field @Nothing@. Emits an empty +-- query string, preserving the wire behaviour of the parameterless +-- @POST \/{index}/_validate/query@. +defaultValidateOptions :: ValidateOptions +defaultValidateOptions = + ValidateOptions + { voExplain = Nothing, + voAll = Nothing, + voRewrite = Nothing, + voIgnoreUnavailable = Nothing, + voAllowNoIndices = Nothing, + voExpandWildcards = Nothing, + voQ = Nothing, + voAnalyzer = Nothing, + voAnalyzeWildcard = Nothing, + voDefaultOperator = Nothing, + voDf = Nothing, + voLenient = Nothing, + voDefaultField = Nothing + } + +-- | Render a 'ValidateOptions' record as a @(key, value)@ list +-- suitable for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. +-- 'Nothing' fields are omitted, so 'defaultValidateOptions' produces +-- an empty list (and therefore no query string). The order of the +-- list is stable but /unspecified/ — callers and tests should treat +-- it as a set. +validateOptionsParams :: ValidateOptions -> [(Text, Maybe Text)] +validateOptionsParams ValidateOptions {..} = + catMaybes + [ ("explain",) . Just . boolText <$> voExplain, + ("all",) . Just . boolText <$> voAll, + ("rewrite",) . Just <$> voRewrite, + ("ignore_unavailable",) . Just . boolText <$> voIgnoreUnavailable, + ("allow_no_indices",) . Just . boolText <$> voAllowNoIndices, + ("expand_wildcards",) . Just . renderExpandWildcards <$> voExpandWildcards, + ("q",) . Just <$> voQ, + ("analyzer",) . Just <$> voAnalyzer, + ("analyze_wildcard",) . Just . boolText <$> voAnalyzeWildcard, + ("default_operator",) . Just . renderDefaultOperator <$> voDefaultOperator, + ("df",) . Just <$> voDf, + ("lenient",) . Just . boolText <$> voLenient, + ("default_field",) . Just <$> voDefaultField + ] + where + boolText True = "true" + boolText False = "false" + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + -- The @_validate/query@ URI parameter accepts @AND@\/@and@\/ + -- @OR@\/@or@ (all four forms); we emit the canonical uppercase + -- form used in the ES docs prose, whereas 'BooleanOperator'\'s + -- 'ToJSON' renders lowercase @and@\/@or@ (the JSON body form). + -- Render uppercase here to match the documented canonical + -- query-string contract, mirroring + -- 'Database.Bloodhound.Internal.Versions.Common.Types.Explain.explainOptionsParams'. + renderDefaultOperator And = "AND" + renderDefaultOperator Or = "OR" + +-- Lenses for ValidateOptions + +voExplainLens :: Lens' ValidateOptions (Maybe Bool) +voExplainLens = lens voExplain (\x y -> x {voExplain = y}) + +voAllLens :: Lens' ValidateOptions (Maybe Bool) +voAllLens = lens voAll (\x y -> x {voAll = y}) + +voRewriteLens :: Lens' ValidateOptions (Maybe Text) +voRewriteLens = lens voRewrite (\x y -> x {voRewrite = y}) + +voIgnoreUnavailableLens :: Lens' ValidateOptions (Maybe Bool) +voIgnoreUnavailableLens = + lens voIgnoreUnavailable (\x y -> x {voIgnoreUnavailable = y}) + +voAllowNoIndicesLens :: Lens' ValidateOptions (Maybe Bool) +voAllowNoIndicesLens = + lens voAllowNoIndices (\x y -> x {voAllowNoIndices = y}) + +voExpandWildcardsLens :: Lens' ValidateOptions (Maybe (NonEmpty ExpandWildcards)) +voExpandWildcardsLens = + lens voExpandWildcards (\x y -> x {voExpandWildcards = y}) + +voQLens :: Lens' ValidateOptions (Maybe Text) +voQLens = lens voQ (\x y -> x {voQ = y}) + +voAnalyzerLens :: Lens' ValidateOptions (Maybe Text) +voAnalyzerLens = lens voAnalyzer (\x y -> x {voAnalyzer = y}) + +voAnalyzeWildcardLens :: Lens' ValidateOptions (Maybe Bool) +voAnalyzeWildcardLens = + lens voAnalyzeWildcard (\x y -> x {voAnalyzeWildcard = y}) + +voDefaultOperatorLens :: Lens' ValidateOptions (Maybe BooleanOperator) +voDefaultOperatorLens = + lens voDefaultOperator (\x y -> x {voDefaultOperator = y}) + +voDfLens :: Lens' ValidateOptions (Maybe Text) +voDfLens = lens voDf (\x y -> x {voDf = y}) + +voLenientLens :: Lens' ValidateOptions (Maybe Bool) +voLenientLens = lens voLenient (\x y -> x {voLenient = y}) + +voDefaultFieldLens :: Lens' ValidateOptions (Maybe Text) +voDefaultFieldLens = lens voDefaultField (\x y -> x {voDefaultField = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/VectorTile.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/VectorTile.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/VectorTile.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.VectorTile +-- +-- Path-parameter and URI-parameter types for the +-- @GET \/{index}\/_mvt\/{field}\/{zoom}\/{x}\/{y}@ endpoint (also reachable +-- via @POST@), which renders the results of a geospatial search as a +-- binary Mapbox Vector Tile (MVT, encoded as a Google Protobuf). +-- +-- The endpoint was added in Elasticsearch 7.15.0 and is also available +-- in OpenSearch (which forked from ES 7.10 but later back-ported the +-- endpoint). The wire format is identical across backends, so the +-- request builder lives in the Common layer and is re-exported by the +-- per-backend client modules. +-- +-- The response body is /binary/ (protobuf). It is returned verbatim as +-- a lazy 'Data.ByteString.Lazy.ByteString' by +-- 'Database.Bloodhound.Common.Requests.searchVectorTile'; callers are +-- responsible for decoding the protobuf with a library such as +-- @vector-tile@. +-- +-- See +-- +-- and +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.VectorTile + ( -- * Path parameters + TileZoom (..), + TileX (..), + TileY (..), + + -- * URI parameters + VectorTileOptions (..), + defaultVectorTileOptions, + vectorTileOptionsParams, + VectorTileGridAgg (..), + VectorTileGridType (..), + VectorTileTrackTotalHits (..), + + -- * Optics + vtoExactBoundsLens, + vtoExtentLens, + vtoGridAggLens, + vtoGridPrecisionLens, + vtoGridTypeLens, + vtoSizeLens, + vtoTrackTotalHitsLens, + vtoWithLabelsLens, + ) +where + +import Data.Aeson + ( FromJSON (..), + ToJSON (..), + ) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Word (Word8) +import Database.Bloodhound.Internal.Utils.Imports (showText) +import Optics.Lens + +-- | Zoom level of the target tile. Elasticsearch constrains @zoom@ to +-- the inclusive range @[0, 29]@; the constructor does /not/ enforce +-- this bounds check — an out-of-range value surfaces as a server error +-- (HTTP 400) rather than a client-side exception. +newtype TileZoom = TileZoom {unTileZoom :: Word} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON, Enum, Num, Real, Integral) + +-- | @x@ coordinate of the target tile. Must satisfy +-- @0 <= x < 2^zoom@; an out-of-range value surfaces as a server error. +newtype TileX = TileX {unTileX :: Word} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON, Enum, Num, Real, Integral) + +-- | @y@ coordinate of the target tile. Must satisfy +-- @0 <= y < 2^zoom@; an out-of-range value surfaces as a server error. +newtype TileY = TileY {unTileY :: Word} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON, Enum, Num, Real, Integral) + +-- | Selects the grid aggregation used to build the @aggs@ layer of the +-- vector tile. Renders as the @grid_agg@ query parameter (and the +-- @grid_agg@ body field). The two backends agree on the wire values. +data VectorTileGridAgg + = -- | @geotile@ — rectangular grid (default when @grid_agg@ is implied + -- by the presence of @grid_precision@). + VectorTileGridAggGeotile + | -- | @geohex@ — H3 hexagonal grid (ES 7.16+). + VectorTileGridAggGeohex + deriving stock (Eq, Show) + +instance ToJSON VectorTileGridAgg where + toJSON VectorTileGridAggGeotile = "geotile" + toJSON VectorTileGridAggGeohex = "geohex" + +instance FromJSON VectorTileGridAgg where + parseJSON "geotile" = pure VectorTileGridAggGeotile + parseJSON "geohex" = pure VectorTileGridAggGeohex + parseJSON v = fail ("Unknown grid_agg: " <> show v) + +-- | Shape of the feature emitted per grid cell in the @aggs@ layer. +-- Renders as the @grid_type@ query parameter (and the @grid_type@ body +-- field). +data VectorTileGridType + = -- | @grid@ — one polygon feature per cell (the full cell area). + VectorTileGridTypeGrid + | -- | @point@ — one point feature per cell (a representative point). + VectorTileGridTypePoint + | -- | @centroid@ — one point feature per cell (the cell centroid). + VectorTileGridTypeCentroid + deriving stock (Eq, Show) + +instance ToJSON VectorTileGridType where + toJSON VectorTileGridTypeGrid = "grid" + toJSON VectorTileGridTypePoint = "point" + toJSON VectorTileGridTypeCentroid = "centroid" + +instance FromJSON VectorTileGridType where + parseJSON "grid" = pure VectorTileGridTypeGrid + parseJSON "point" = pure VectorTileGridTypePoint + parseJSON "centroid" = pure VectorTileGridTypeCentroid + parseJSON v = fail ("Unknown grid_type: " <> show v) + +-- | @track_total_hits@ for the MVT endpoint. The wire shape accepts a +-- boolean (count all hits accurately vs. skip counting) or an integer +-- (count accurately up to a cap). This dedicated sum type renders as +-- the @?track_total_hits=...@ URI parameter; it is intentionally not +-- shared with +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Search.TrackTotalHits' +-- because that type carries JSON encoding +-- ('ToJSON'\/'FromJSON') and an 'Int' payload, whereas the URI form +-- needs @"true"@\/@"false"@\/@N@ strings and a non-negative 'Word'. +data VectorTileTrackTotalHits + = -- | @true@ — count every matching hit accurately. + VectorTileTrackTotalHitsAll + | -- | @false@ — skip hit counting entirely. + VectorTileTrackTotalHitsOff + | -- | @N@ — count accurately up to @N@ hits. + VectorTileTrackTotalHitsUpTo Word + deriving stock (Eq, Show) + +-- | Optional URI parameters accepted by the +-- @\/{index}\/_mvt\/{field}\/{zoom}\/{x}\/{y}@ endpoint. +-- +-- Every parameter here has a counterpart in the JSON body. When both +-- are supplied, the URI parameter takes precedence per the ES docs. +-- 'defaultVectorTileOptions' produces no URI parameters, so +-- 'Database.Bloodhound.Common.Requests.searchVectorTile' (which uses +-- the default) relies entirely on the server's body defaults for +-- @buffer@, @extent@, @grid_precision@, @grid_type@, @exact_bounds@, +-- @size@ and @track_total_hits@. +data VectorTileOptions = VectorTileOptions + { -- | @exact_bounds@ — when @True@, the @meta@ layer uses the + -- @geo_bounds@ aggregation bbox; otherwise it uses the tile bbox. + vtoExactBounds :: Maybe Bool, + -- | @extent@ — tile side size in pixels. Server body default is + -- @4096@; the URI parameter has no stated default and overrides + -- the body value when set. + vtoExtent :: Maybe Word, + -- | @grid_agg@ — selects the grid aggregation (@geotile@ or + -- @geohex@). When omitted at both URI and body level, no @aggs@ + -- layer is emitted unless @vtoGridPrecision@ implies one. + vtoGridAgg :: Maybe VectorTileGridAgg, + -- | @grid_precision@ — additional zoom levels in the @aggs@ layer, + -- in the inclusive range @[0, 8]@. @0@ produces no @aggs@ layer. + -- Server body default is @8@; the URI parameter overrides it when + -- set. + vtoGridPrecision :: Maybe Word8, + -- | @grid_type@ — shape of the features emitted in the @aggs@ + -- layer (@grid@, @point@, or @centroid@). + vtoGridType :: Maybe VectorTileGridType, + -- | @size@ — maximum number of features in the @hits@ layer, in + -- the inclusive range @[0, 10000]@. @0@ produces no @hits@ layer. + -- Server body default is @10000@; the URI parameter overrides it + -- when set. + vtoSize :: Maybe Word, + -- | @track_total_hits@ — see 'VectorTileTrackTotalHits'. + vtoTrackTotalHits :: Maybe VectorTileTrackTotalHits, + -- | @with_labels@ — when @True@, add label-position point features + -- (ES-only; OpenSearch ignores the parameter). + vtoWithLabels :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | The zero-parameter form: every field is 'Nothing', so +-- 'vectorTileOptionsParams' renders the empty list and the request +-- relies entirely on server-side defaults. +defaultVectorTileOptions :: VectorTileOptions +defaultVectorTileOptions = + VectorTileOptions + { vtoExactBounds = Nothing, + vtoExtent = Nothing, + vtoGridAgg = Nothing, + vtoGridPrecision = Nothing, + vtoGridType = Nothing, + vtoSize = Nothing, + vtoTrackTotalHits = Nothing, + vtoWithLabels = Nothing + } + +-- | Render 'VectorTileOptions' as the URI query-parameter list expected +-- by the MVT endpoint. 'Nothing' fields are omitted so that +-- 'defaultVectorTileOptions' produces the empty list (byte-for-byte +-- identical to a request with no query string). +vectorTileOptionsParams :: VectorTileOptions -> [(Text, Maybe Text)] +vectorTileOptionsParams VectorTileOptions {..} = + catMaybes + [ ("exact_bounds",) . Just . boolQP <$> vtoExactBounds, + ("extent",) . Just . showText <$> vtoExtent, + ("grid_agg",) . Just . gridAggText <$> vtoGridAgg, + ("grid_precision",) . Just . showText <$> vtoGridPrecision, + ("grid_type",) . Just . gridTypeText <$> vtoGridType, + ("size",) . Just . showText <$> vtoSize, + ("track_total_hits",) . Just . trackTotalHitsText <$> vtoTrackTotalHits, + ("with_labels",) . Just . boolQP <$> vtoWithLabels + ] + where + boolQP True = "true" + boolQP False = "false" + gridAggText VectorTileGridAggGeotile = "geotile" + gridAggText VectorTileGridAggGeohex = "geohex" + gridTypeText VectorTileGridTypeGrid = "grid" + gridTypeText VectorTileGridTypePoint = "point" + gridTypeText VectorTileGridTypeCentroid = "centroid" + trackTotalHitsText VectorTileTrackTotalHitsAll = "true" + trackTotalHitsText VectorTileTrackTotalHitsOff = "false" + trackTotalHitsText (VectorTileTrackTotalHitsUpTo n) = showText n + +vtoExactBoundsLens :: Lens' VectorTileOptions (Maybe Bool) +vtoExactBoundsLens = + lens vtoExactBounds (\x y -> x {vtoExactBounds = y}) + +vtoExtentLens :: Lens' VectorTileOptions (Maybe Word) +vtoExtentLens = + lens vtoExtent (\x y -> x {vtoExtent = y}) + +vtoGridAggLens :: Lens' VectorTileOptions (Maybe VectorTileGridAgg) +vtoGridAggLens = + lens vtoGridAgg (\x y -> x {vtoGridAgg = y}) + +vtoGridPrecisionLens :: Lens' VectorTileOptions (Maybe Word8) +vtoGridPrecisionLens = + lens vtoGridPrecision (\x y -> x {vtoGridPrecision = y}) + +vtoGridTypeLens :: Lens' VectorTileOptions (Maybe VectorTileGridType) +vtoGridTypeLens = + lens vtoGridType (\x y -> x {vtoGridType = y}) + +vtoSizeLens :: Lens' VectorTileOptions (Maybe Word) +vtoSizeLens = + lens vtoSize (\x y -> x {vtoSize = y}) + +vtoTrackTotalHitsLens :: + Lens' VectorTileOptions (Maybe VectorTileTrackTotalHits) +vtoTrackTotalHitsLens = + lens vtoTrackTotalHits (\x y -> x {vtoTrackTotalHits = y}) + +vtoWithLabelsLens :: Lens' VectorTileOptions (Maybe Bool) +vtoWithLabelsLens = + lens vtoWithLabels (\x y -> x {vtoWithLabels = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/VersionType.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/VersionType.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/VersionType.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Shared @version_type@ parameter used by the Index, Bulk and Reindex +-- APIs to control how the externally-supplied @_version@ field is +-- interpreted. The OpenSearch\/ES spec enum is three values: +-- +-- * @internal@ — the default; the server bumps the existing version. +-- * @external@ — use the caller-supplied version, fail on collision. +-- * @external_gte@ — use the caller-supplied version if it is greater +-- than or equal to the stored one. Used for cumulative indexing. +-- +-- @external_gt@ is intentionally absent: it appears in /no/ spec enum +-- (@[internal,external,external_gte]@) and the server rejects it. +-- +-- See +-- +-- (Index API) and +-- +-- (Bulk API @_version_type@ per-op metadata). +module Database.Bloodhound.Internal.Versions.Common.Types.VersionType + ( VersionType (..), + renderVersionType, + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withText) +import Data.Text (Text) +import GHC.Generics (Generic) + +data VersionType + = VersionTypeInternal + | VersionTypeExternal + | VersionTypeExternalGTE + deriving stock (Eq, Show, Generic) + +instance ToJSON VersionType where + toJSON = + String . renderVersionType + +instance FromJSON VersionType where + parseJSON = withText "VersionType" $ \s -> case s of + "internal" -> pure VersionTypeInternal + "external" -> pure VersionTypeExternal + "external_gte" -> pure VersionTypeExternalGTE + _ -> fail $ "Expected one of [internal, external, external_gte], found: " <> show s + +-- | Render as the bare URI / metadata value (without quotes), e.g. +-- @\"external_gte\"@. Suitable both for the per-op @_version_type@ +-- metadata field of a bulk line and the @version_type=@ query-string +-- parameter of the Index API. +renderVersionType :: VersionType -> Text +renderVersionType = \case + VersionTypeInternal -> "internal" + VersionTypeExternal -> "external" + VersionTypeExternalGTE -> "external_gte" diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/VotingConfigExclusion.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/VotingConfigExclusion.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/VotingConfigExclusion.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.Common.Types.VotingConfigExclusion + ( -- * Voting config exclusions + VotingConfigExclusionOptions (..), + defaultVotingConfigExclusionOptions, + votingConfigExclusionOptionsParams, + ) +where + +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes + ( FullNodeId (..), + NodeName (..), + ) + +-- | Options for @POST /_cluster/voting_config_exclusions@ — the +-- manually-added voting config exclusions ES uses when a node has +-- left the cluster permanently and you need to bump the voting +-- configuration down without waiting for auto-converge. Either list +-- is optional, but the server requires at least one @node_ids@ or +-- @node_names@ entry; pass 'mempty' to construct the no-param record +-- (then add ids/names via record updates, or use the smart defaults +-- via 'defaultVotingConfigExclusionOptions'). +-- +-- The two fields are mutually independent on the wire: ES renders +-- them as two separate comma-separated query parameters +-- (@node_ids=a,b&node_names=c,d@). An empty list in either field +-- means that parameter is omitted entirely, not rendered as an empty +-- string. +-- +-- Note: this endpoint is Elasticsearch-only — OpenSearch does not +-- expose voting config exclusions in its cluster API surface. Calls +-- against an OpenSearch cluster will return HTTP 404. +-- +-- () +data VotingConfigExclusionOptions = VotingConfigExclusionOptions + { votingConfigExclusionOptionsNodeIds :: [FullNodeId], + votingConfigExclusionOptionsNodeNames :: [NodeName] + } + deriving stock (Eq, Show) + +-- | 'mempty'-style default: empty @node_ids@ and @node_names@ lists. +-- Renders no query parameters; callers must populate at least one +-- field before sending or ES will reject the request with +-- @validation_exception@. +defaultVotingConfigExclusionOptions :: VotingConfigExclusionOptions +defaultVotingConfigExclusionOptions = + VotingConfigExclusionOptions + { votingConfigExclusionOptionsNodeIds = [], + votingConfigExclusionOptionsNodeNames = [] + } + +-- | Render a 'VotingConfigExclusionOptions' as the @(key, value)@ +-- pairs ES expects on the query string. Empty lists are omitted (not +-- rendered as empty strings) so the absence of @node_names@ in the +-- common case of \"ids only\" produces a single clean +-- @node_ids=a,b,c@ query parameter. +votingConfigExclusionOptionsParams :: VotingConfigExclusionOptions -> [(Text, Maybe Text)] +votingConfigExclusionOptionsParams opts = + catMaybes + [ renderList "node_ids" (coerceFullNodeId <$> votingConfigExclusionOptionsNodeIds opts), + renderList "node_names" (coerceNodeName <$> votingConfigExclusionOptionsNodeNames opts) + ] + where + renderList _ [] = Nothing + renderList k xs = Just (k, Just (T.intercalate "," xs)) + coerceFullNodeId (FullNodeId t) = t + coerceNodeName (NodeName t) = t diff --git a/src/Database/Bloodhound/Internal/Versions/Common/Types/Watcher.hs b/src/Database/Bloodhound/Internal/Versions/Common/Types/Watcher.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/Common/Types/Watcher.hs @@ -0,0 +1,738 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.Common.Types.Watcher +-- Description : Types for the Elasticsearch X-Pack Watcher API +-- +-- Defines the request and response shapes for the ES Watcher API: +-- +-- * @PUT /_watcher/watch/{id}@ — 'WatchBody' request, 'Acknowledged' on success. +-- * @GET /_watcher/watch/{id}@ — 'Watch' response. +-- * @DELETE /_watcher/watch/{id}@ — 'Acknowledged'. +-- * @POST /_watcher/watch/{id}/_execute@ — 'ExecuteWatchResponse'; an optional +-- 'ExecuteWatchRequest' body runs an inline watch instead of the stored one. +-- * @PUT /_watcher/watch/{id}/_ack@ — 'AckWatchResponse'. +-- * @PUT /_watcher/watch/{id}/_activate@ — 'WatchStateResponse'. +-- * @PUT /_watcher/watch/{id}/_deactivate@ — 'WatchStateResponse'. +-- * @GET /_watcher/_stats[/{metric}]@ — 'WatcherStatsResponse'. +-- * @GET /_watcher/settings@ — 'WatcherSettings'. +-- * @PUT /_watcher/settings@ — 'WatcherSettings' body, 'Acknowledged' on success. +-- * @POST /_watcher/_start@ — 'Acknowledged'. +-- * @POST /_watcher/_stop@ — 'Acknowledged'. +-- +-- Watcher is an X-Pack feature (Platinum or Enterprise licence, available on +-- Elasticsearch 2.1+). It ships on ES 7.x, 8.x and 9.x with the same REST +-- surface — the types therefore live in the Common layer alongside SLM\/ILM, +-- even though OpenSearch does not implement Watcher (calls against an +-- OpenSearch cluster will fail at runtime). The watch DSL itself +-- (trigger\/input\/condition\/transform\/actions) is large and fast-moving, so +-- per the project's MlAnomalyJob \/ Enrich precedent those sub-objects are +-- carried as opaque 'Value's while the envelope and the small status\/state +-- enums are typed. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.Common.Types.Watcher + ( -- * Identifiers + WatchId (..), + + -- * Watch CRUD + WatchBody (..), + Watch (..), + WatchStatus (..), + WatchState (..), + watchStateText, + parseWatchState, + + -- * Execute watch + ExecuteWatchRequest (..), + ExecuteWatchResponse (..), + ExecuteWatchOptions (..), + defaultExecuteWatchOptions, + executeWatchOptionsParams, + + -- * Acknowledge / activate / deactivate + AckWatchResponse (..), + WatchStateResponse (..), + AckState (..), + ackStateText, + parseAckState, + WatchExecutionState (..), + watchExecutionStateText, + parseWatchExecutionState, + + -- * Cluster stats + WatcherStatsResponse (..), + WatcherStatsSummary (..), + WatcherStatsMetric (..), + watcherStatsMetricPath, + + -- * Settings + WatcherSettings (..), + + -- * Optics + watchIdLens, + watchFoundLens, + watchVersionLens, + watchSeqNoLens, + watchPrimaryTermLens, + watchBodyLens, + watchStatusLens, + wsStateLens, + wsVersionLens, + wsActionsLens, + wsExtrasLens, + watchBodyContentLens, + ewrIdLens, + ewrWatchRecordLens, + ewrExtrasLens, + ewoDebugLens, + ewoRecordExecutionLens, + awrAckStateLens, + awrWatchStatusLens, + awrExtrasLens, + wsrAckStateLens, + wsrStateLens, + wsrVersionLens, + wsrExtrasLens, + watcherStatsNodesLens, + watcherStatsClusterNameLens, + watcherStatsStatsLens, + watcherStatsExtrasLens, + wssWatchCountLens, + wssExecutionStateLens, + wssThreadPoolLens, + wssPendingWatchesLens, + wssExtrasLens, + watcherSettingsPersistentLens, + watcherSettingsTransientLens, + watcherSettingsDefaultsLens, + watcherSettingsExtrasLens, + ) +where + +import Data.Aeson +import Data.Aeson.Key (fromText) +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens, omitNulls) + +-- | Identifies a watch in the @\/_watcher\/watch\/{id}@ URL path. Wraps +-- 'Text' so it round-trips through JSON as a bare string but is distinct at +-- the Haskell type level from 'Database.Bloodhound.Internal.Versions.Common.Types.SLM.SLMPolicyId' +-- and other id newtypes. +newtype WatchId = WatchId {unWatchId :: Text} + deriving newtype (Eq, Show, ToJSON, FromJSON) + +-- | Request body of @PUT /_watcher/watch/{id}@ and the optional inline body +-- of @POST /_watcher/watch/{id}/_execute@. The watch DSL +-- (trigger\/input\/condition\/transform\/actions\/metadata) is large and +-- version-evolving, so per the MlAnomalyJob\/Enrich precedent the body is +-- carried as an opaque 'Value' that 'ToJSON' emits verbatim; a typed watch +-- schema is tracked as a follow-up (the same treatment SLM gives +-- 'Database.Bloodhound.Internal.Versions.Common.Types.SLM.SLMPolicy'). +newtype WatchBody = WatchBody {unWatchBody :: Value} + deriving stock (Eq, Show) + +instance ToJSON WatchBody where + toJSON (WatchBody body) = body + +instance FromJSON WatchBody where + -- Watch bodies are JSON objects. Reject non-objects so trivially + -- malformed input decodes to 'Nothing' (mirrors SLMPolicy's guard). + parseJSON = withObject "WatchBody" (pure . WatchBody . Object) + +-- | The high-level state of a stored watch, as reported by the @status.state@ +-- field of a 'Watch'. The enum has been stable since Watcher shipped in +-- ES 2.1. +data WatchState + = WatchStateActive + | WatchStateInactive + | WatchStateAcknowledged + | WatchStateExecutionFailed + | WatchStateCustom Text + deriving stock (Eq, Show) + +watchStateText :: WatchState -> Text +watchStateText WatchStateActive = "active" +watchStateText WatchStateInactive = "inactive" +watchStateText WatchStateAcknowledged = "acknowledged" +watchStateText WatchStateExecutionFailed = "execution_failed" +watchStateText (WatchStateCustom t) = t + +parseWatchState :: Text -> WatchState +parseWatchState "active" = WatchStateActive +parseWatchState "inactive" = WatchStateInactive +parseWatchState "acknowledged" = WatchStateAcknowledged +parseWatchState "execution_failed" = WatchStateExecutionFailed +parseWatchState other = WatchStateCustom other + +instance ToJSON WatchState where + toJSON = String . watchStateText + +instance FromJSON WatchState where + parseJSON = withText "WatchState" (pure . parseWatchState) + +-- | The @status@ sub-object of a 'Watch' response: the operationally +-- interesting bits (version, state) are typed; the per-action execution +-- state (@status.actions@) is carried as an opaque 'KeyMap' since action +-- names are caller-defined, and any other field ES adds (@last_checked@, +-- @last_met_condition@, @last_execution_time@, ...) lands in the +-- 'wsExtras' catch-all so the decoder is forward-compatible. +data WatchStatus = WatchStatus + { wsVersion :: Maybe Int, + wsState :: Maybe WatchState, + -- | @status.actions@ — per-action execution state keyed by action + -- name. Opaque because action names and their per-action status + -- payloads are caller-defined. + wsActions :: Maybe (KeyMap Value), + -- | Forward-compat catch-all for every other @status.*@ sibling. + wsExtras :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +instance FromJSON WatchStatus where + parseJSON = withObject "WatchStatus" $ \o -> do + wsVersion <- o .:? "version" + wsState <- o .:? "state" + wsActions <- o .:? "actions" + let wsExtras = stripKeys ["version", "state", "actions"] o + pure WatchStatus {..} + +instance ToJSON WatchStatus where + toJSON WatchStatus {..} = + mergeExtras + wsExtras + ( omitNulls $ + catMaybes + [ ("version",) . toJSON <$> wsVersion, + ("state",) . toJSON <$> wsState, + ("actions",) . toJSON <$> wsActions + ] + ) + +-- | Response of @GET /_watcher/watch/{id}@. The top-level fields are typed +-- (@_id@, @_version@, @_seq_no@, @_primary_term@, @found@); the @watch@ +-- sub-object (the full DSL) and any other ES-added sibling are carried as +-- opaque 'Value' / 'KeyMap Value' catch-alls. +data Watch = Watch + { watchId :: WatchId, + watchFound :: Maybe Bool, + watchVersion :: Maybe Int, + watchSeqNo :: Maybe Int, + watchPrimaryTerm :: Maybe Int, + -- | @watch@ — the full watch DSL (trigger\/input\/condition\/transform\/ + -- actions\/metadata). Opaque 'Value'. + watchBody :: Maybe Value, + -- | @status@ — typed execution status. 'Nothing' if ES omits the + -- sub-object (e.g. on a freshly-PUT watch whose status has not yet + -- been computed). + watchStatus :: Maybe WatchStatus + } + deriving stock (Eq, Show) + +instance FromJSON Watch where + parseJSON = withObject "Watch" $ \o -> do + rawId <- o .:? "_id" + watchFound <- o .:? "found" + watchVersion <- o .:? "_version" + watchSeqNo <- o .:? "_seq_no" + watchPrimaryTerm <- o .:? "_primary_term" + watchBody <- o .:? "watch" + watchStatus <- o .:? "status" + let watchId = maybe (WatchId "") WatchId rawId + pure Watch {..} + +instance ToJSON Watch where + toJSON Watch {..} = + omitNulls $ + catMaybes + [ Just ("_id" .= watchId), + ("found",) . toJSON <$> watchFound, + ("_version",) . toJSON <$> watchVersion, + ("_seq_no",) . toJSON <$> watchSeqNo, + ("_primary_term",) . toJSON <$> watchPrimaryTerm, + ("watch",) . toJSON <$> watchBody, + ("status",) . toJSON <$> watchStatus + ] + +-- | Request body of @POST /_watcher/watch/{id}/_execute@. When supplied, +-- the watch is run inline (the stored watch with the same id is ignored); +-- when omitted, the stored watch is executed. Carried as an opaque +-- 'Value' for the same reason as 'WatchBody'. +newtype ExecuteWatchRequest = ExecuteWatchRequest {unExecuteWatchRequest :: Value} + deriving stock (Eq, Show) + +instance ToJSON ExecuteWatchRequest where + toJSON (ExecuteWatchRequest body) = body + +instance FromJSON ExecuteWatchRequest where + parseJSON = withObject "ExecuteWatchRequest" (pure . ExecuteWatchRequest . Object) + +-- | Response of @POST /_watcher/watch/{id}/_execute@. The @_id@ is typed +-- (stamped from the watch id); @watch_record@ (the full execution trace — +-- input_event, metadata, actions, state transitions) is opaque because it +-- is large and varies by watch configuration; any other sibling lands in +-- the 'ewrExtras' catch-all. +data ExecuteWatchResponse = ExecuteWatchResponse + { ewrId :: WatchId, + ewrWatchRecord :: Maybe Value, + ewrExtras :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +instance FromJSON ExecuteWatchResponse where + parseJSON = withObject "ExecuteWatchResponse" $ \o -> do + rawId <- o .:? "_id" + ewrWatchRecord <- o .:? "watch_record" + let knownKeys = ["_id", "watch_record"] + ewrExtras = stripKeys knownKeys o + ewrId = maybe (WatchId "") WatchId rawId + pure ExecuteWatchResponse {..} + +instance ToJSON ExecuteWatchResponse where + toJSON ExecuteWatchResponse {..} = + mergeExtras + ewrExtras + ( omitNulls $ + catMaybes + [ Just ("_id" .= ewrId), + ("watch_record",) . toJSON <$> ewrWatchRecord + ] + ) + +-- | URI parameters accepted by @POST /_watcher/watch/{id}/_execute@. See +-- . +data ExecuteWatchOptions = ExecuteWatchOptions + { -- | @debug@ — when @True@, the response includes the @watch_record@ + -- with extra debug information about each action's execution. + ewoDebug :: Maybe Bool, + -- | @record_execution@ — when @False@, the execution bypasses the + -- usual watch-record persistence (the @.watches@ index is not + -- updated). Defaults to @True@ on the server when omitted. + ewoRecordExecution :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'ExecuteWatchOptions' with both parameters @Nothing@ — reproduces the +-- parameterless 'executeWatch' behaviour. +defaultExecuteWatchOptions :: ExecuteWatchOptions +defaultExecuteWatchOptions = + ExecuteWatchOptions + { ewoDebug = Nothing, + ewoRecordExecution = Nothing + } + +-- | Render an 'ExecuteWatchOptions' as a @(key, value)@ list for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. 'Nothing' +-- fields are omitted. +executeWatchOptionsParams :: ExecuteWatchOptions -> [(Text, Maybe Text)] +executeWatchOptionsParams ExecuteWatchOptions {..} = + catMaybes + [ ("debug",) . Just . boolText <$> ewoDebug, + ("record_execution",) . Just . boolText <$> ewoRecordExecution + ] + where + boolText True = "true" + boolText False = "false" + +-- | The acknowledge state of a watch, reported as @ack_state@ by the +-- ack\/activate\/deactivate endpoints. @acks_needed@ means the watch still +-- requires acknowledgement; @acks_required@ means the watch's @ack_action@ +-- has not yet been satisfied. An unknown value round-trips through +-- 'AckStateCustom'. +data AckState + = AckStateAcksNeeded + | AckStateAcksRequired + | AckStateCustom Text + deriving stock (Eq, Show) + +ackStateText :: AckState -> Text +ackStateText AckStateAcksNeeded = "acks_needed" +ackStateText AckStateAcksRequired = "acks_required" +ackStateText (AckStateCustom t) = t + +parseAckState :: Text -> AckState +parseAckState "acks_needed" = AckStateAcksNeeded +parseAckState "acks_required" = AckStateAcksRequired +parseAckState other = AckStateCustom other + +instance ToJSON AckState where + toJSON = String . ackStateText + +instance FromJSON AckState where + parseJSON = withText "AckState" (pure . parseAckState) + +-- | The execution state reported by activate\/deactivate (and nested inside +-- the ack response's @ack_watch_status@). @active@\/@inactive@ are the two +-- values the activate\/deactivate endpoints can produce directly; the +-- remaining constructors cover the broader @status.state@ enum Watcher +-- reports elsewhere, so the same type is reused for 'WatchStatus'. +data WatchExecutionState + = WatchExecutionStateActive + | WatchExecutionStateInactive + | WatchExecutionStateAcknowledged + | WatchExecutionStateFailed + | WatchExecutionStateExecutionNotRun + | WatchExecutionStateThrottled + | WatchExecutionStateExecuted + | WatchExecutionStateCustom Text + deriving stock (Eq, Show) + +watchExecutionStateText :: WatchExecutionState -> Text +watchExecutionStateText WatchExecutionStateActive = "active" +watchExecutionStateText WatchExecutionStateInactive = "inactive" +watchExecutionStateText WatchExecutionStateAcknowledged = "acknowledged" +watchExecutionStateText WatchExecutionStateFailed = "failed" +watchExecutionStateText WatchExecutionStateExecutionNotRun = "execution_not_run" +watchExecutionStateText WatchExecutionStateThrottled = "throttled" +watchExecutionStateText WatchExecutionStateExecuted = "executed" +watchExecutionStateText (WatchExecutionStateCustom t) = t + +parseWatchExecutionState :: Text -> WatchExecutionState +parseWatchExecutionState "active" = WatchExecutionStateActive +parseWatchExecutionState "inactive" = WatchExecutionStateInactive +parseWatchExecutionState "acknowledged" = WatchExecutionStateAcknowledged +parseWatchExecutionState "failed" = WatchExecutionStateFailed +parseWatchExecutionState "execution_not_run" = WatchExecutionStateExecutionNotRun +parseWatchExecutionState "throttled" = WatchExecutionStateThrottled +parseWatchExecutionState "executed" = WatchExecutionStateExecuted +parseWatchExecutionState other = WatchExecutionStateCustom other + +instance ToJSON WatchExecutionState where + toJSON = String . watchExecutionStateText + +instance FromJSON WatchExecutionState where + parseJSON = withText "WatchExecutionState" (pure . parseWatchExecutionState) + +-- | Response of @PUT /_watcher/watch/{id}/_ack@. ES replies with a +-- top-level @ack_state@ plus a nested @ack_watch_status@ carrying the +-- watch's current @ack_state@\/@state@\/@version@. +data AckWatchResponse = AckWatchResponse + { awrAckState :: Maybe AckState, + awrWatchStatus :: Maybe WatchStateResponse, + awrExtras :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +instance FromJSON AckWatchResponse where + parseJSON = withObject "AckWatchResponse" $ \o -> do + awrAckState <- o .:? "ack_state" + awrWatchStatus <- o .:? "ack_watch_status" + let awrExtras = stripKeys ["ack_state", "ack_watch_status"] o + pure AckWatchResponse {..} + +instance ToJSON AckWatchResponse where + toJSON AckWatchResponse {..} = + mergeExtras + awrExtras + ( omitNulls $ + catMaybes + [ ("ack_state",) . toJSON <$> awrAckState, + ("ack_watch_status",) . toJSON <$> awrWatchStatus + ] + ) + +-- | Response of @PUT /_watcher/watch/{id}/_activate@ and +-- @PUT /_watcher/watch/{id}/_deactivate@, and the nested +-- @ack_watch_status@ shape inside an 'AckWatchResponse'. ES replies with +-- @ack_state@, @state@ and @version@ (all optional across versions). +data WatchStateResponse = WatchStateResponse + { wsrAckState :: Maybe AckState, + wsrState :: Maybe WatchExecutionState, + wsrVersion :: Maybe Int, + wsrExtras :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +instance FromJSON WatchStateResponse where + parseJSON = withObject "WatchStateResponse" $ \o -> do + wsrAckState <- o .:? "ack_state" + wsrState <- o .:? "state" + wsrVersion <- o .:? "version" + let wsrExtras = stripKeys ["ack_state", "state", "version"] o + pure WatchStateResponse {..} + +instance ToJSON WatchStateResponse where + toJSON WatchStateResponse {..} = + mergeExtras + wsrExtras + ( omitNulls $ + catMaybes + [ ("ack_state",) . toJSON <$> wsrAckState, + ("state",) . toJSON <$> wsrState, + ("version",) . toJSON <$> wsrVersion + ] + ) + +-- | Metric path segment for @GET /_watcher/_stats/{metric}@. @Nothing@ (or +-- 'WatcherStatsMetricAll') requests every metric; the other constructors +-- narrow the response. Unknown values round-trip through +-- 'WatcherStatsMetricCustom'. +data WatcherStatsMetric + = WatcherStatsMetricAll + | WatcherStatsMetricQueuedWatches + | WatcherStatsMetricPendingWatches + | WatcherStatsMetricExecutionThreadPool + | WatcherStatsMetricCustom Text + deriving stock (Eq, Show) + +-- | Render a 'WatcherStatsMetric' as the single path segment ES expects +-- (or the empty string for 'WatcherStatsMetricAll', so the caller can +-- unconditionally append it). +watcherStatsMetricPath :: WatcherStatsMetric -> Text +watcherStatsMetricPath WatcherStatsMetricAll = "_all" +watcherStatsMetricPath WatcherStatsMetricQueuedWatches = "queued_watches" +watcherStatsMetricPath WatcherStatsMetricPendingWatches = "pending_watches" +watcherStatsMetricPath WatcherStatsMetricExecutionThreadPool = "execution_thread_pool" +watcherStatsMetricPath (WatcherStatsMetricCustom t) = t + +-- | The per-cluster summary nested under @stats@ in a +-- 'WatcherStatsResponse'. Operationally interesting counters (@watch_count@, +-- @pending_watches@, @execution_state@) are typed; @thread_pool@ and any +-- other sibling are opaque. +data WatcherStatsSummary = WatcherStatsSummary + { wssWatchCount :: Maybe Int, + wssExecutionState :: Maybe Text, + -- | @thread_pool@ — opaque 'Value' (thread-pool queue\/rejected + -- counters; shape varies across ES versions). + wssThreadPool :: Maybe Value, + wssPendingWatches :: Maybe Int, + wssExtras :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +instance FromJSON WatcherStatsSummary where + parseJSON = withObject "WatcherStatsSummary" $ \o -> do + wssWatchCount <- o .:? "watch_count" + wssExecutionState <- o .:? "execution_state" + wssThreadPool <- o .:? "thread_pool" + wssPendingWatches <- o .:? "pending_watches" + let wssExtras = stripKeys ["watch_count", "execution_state", "thread_pool", "pending_watches"] o + pure WatcherStatsSummary {..} + +instance ToJSON WatcherStatsSummary where + toJSON WatcherStatsSummary {..} = + mergeExtras + wssExtras + ( omitNulls $ + catMaybes + [ ("watch_count",) . toJSON <$> wssWatchCount, + ("execution_state",) . toJSON <$> wssExecutionState, + ("thread_pool",) . toJSON <$> wssThreadPool, + ("pending_watches",) . toJSON <$> wssPendingWatches + ] + ) + +-- | Response of @GET /_watcher/_stats[/{metric}]@. The @_nodes@ summary, +-- @cluster_name@ and the @stats@ summary are typed at the top level; +-- anything else ES adds lands in 'watcherStatsExtras'. +data WatcherStatsResponse = WatcherStatsResponse + { watcherStatsNodes :: Maybe Value, + watcherStatsClusterName :: Maybe Text, + watcherStatsStats :: Maybe WatcherStatsSummary, + watcherStatsExtras :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +instance FromJSON WatcherStatsResponse where + parseJSON = withObject "WatcherStatsResponse" $ \o -> do + watcherStatsNodes <- o .:? "_nodes" + watcherStatsClusterName <- o .:? "cluster_name" + watcherStatsStats <- o .:? "stats" + let watcherStatsExtras = stripKeys ["_nodes", "cluster_name", "stats"] o + pure WatcherStatsResponse {..} + +instance ToJSON WatcherStatsResponse where + toJSON WatcherStatsResponse {..} = + mergeExtras + watcherStatsExtras + ( omitNulls $ + catMaybes + [ ("_nodes",) . toJSON <$> watcherStatsNodes, + ("cluster_name",) . toJSON <$> watcherStatsClusterName, + ("stats",) . toJSON <$> watcherStatsStats + ] + ) + +-- | Request body of @PUT /_watcher/settings@ and response body of +-- @GET /_watcher/settings@. ES uses the standard cluster-settings +-- envelope (@persistent@, @transient@, @defaults@), carried here as +-- opaque 'Value's because the @xpack.watcher.*@ settings tree is large +-- and version-evolving; any other sibling lands in +-- 'watcherSettingsExtras'. +data WatcherSettings = WatcherSettings + { watcherSettingsPersistent :: Maybe Value, + watcherSettingsTransient :: Maybe Value, + watcherSettingsDefaults :: Maybe Value, + watcherSettingsExtras :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +instance FromJSON WatcherSettings where + parseJSON = withObject "WatcherSettings" $ \o -> do + watcherSettingsPersistent <- o .:? "persistent" + watcherSettingsTransient <- o .:? "transient" + watcherSettingsDefaults <- o .:? "defaults" + let watcherSettingsExtras = stripKeys ["persistent", "transient", "defaults"] o + pure WatcherSettings {..} + +instance ToJSON WatcherSettings where + toJSON WatcherSettings {..} = + mergeExtras + watcherSettingsExtras + ( omitNulls $ + catMaybes + [ ("persistent",) . toJSON <$> watcherSettingsPersistent, + ("transient",) . toJSON <$> watcherSettingsTransient, + ("defaults",) . toJSON <$> watcherSettingsDefaults + ] + ) + +-- Lenses + +watchIdLens :: Lens' Watch WatchId +watchIdLens = lens watchId (\x y -> x {watchId = y}) + +watchFoundLens :: Lens' Watch (Maybe Bool) +watchFoundLens = lens watchFound (\x y -> x {watchFound = y}) + +watchVersionLens :: Lens' Watch (Maybe Int) +watchVersionLens = lens watchVersion (\x y -> x {watchVersion = y}) + +watchSeqNoLens :: Lens' Watch (Maybe Int) +watchSeqNoLens = lens watchSeqNo (\x y -> x {watchSeqNo = y}) + +watchPrimaryTermLens :: Lens' Watch (Maybe Int) +watchPrimaryTermLens = lens watchPrimaryTerm (\x y -> x {watchPrimaryTerm = y}) + +watchBodyLens :: Lens' Watch (Maybe Value) +watchBodyLens = lens watchBody (\x y -> x {watchBody = y}) + +watchStatusLens :: Lens' Watch (Maybe WatchStatus) +watchStatusLens = lens watchStatus (\x y -> x {watchStatus = y}) + +wsStateLens :: Lens' WatchStatus (Maybe WatchState) +wsStateLens = lens wsState (\x y -> x {wsState = y}) + +wsVersionLens :: Lens' WatchStatus (Maybe Int) +wsVersionLens = lens wsVersion (\x y -> x {wsVersion = y}) + +wsActionsLens :: Lens' WatchStatus (Maybe (KeyMap Value)) +wsActionsLens = lens wsActions (\x y -> x {wsActions = y}) + +wsExtrasLens :: Lens' WatchStatus (Maybe (KeyMap Value)) +wsExtrasLens = lens wsExtras (\x y -> x {wsExtras = y}) + +watchBodyContentLens :: Lens' WatchBody Value +watchBodyContentLens = lens unWatchBody (\x y -> x {unWatchBody = y}) + +ewrIdLens :: Lens' ExecuteWatchResponse WatchId +ewrIdLens = lens ewrId (\x y -> x {ewrId = y}) + +ewrWatchRecordLens :: Lens' ExecuteWatchResponse (Maybe Value) +ewrWatchRecordLens = lens ewrWatchRecord (\x y -> x {ewrWatchRecord = y}) + +ewrExtrasLens :: Lens' ExecuteWatchResponse (Maybe (KeyMap Value)) +ewrExtrasLens = lens ewrExtras (\x y -> x {ewrExtras = y}) + +ewoDebugLens :: Lens' ExecuteWatchOptions (Maybe Bool) +ewoDebugLens = lens ewoDebug (\x y -> x {ewoDebug = y}) + +ewoRecordExecutionLens :: Lens' ExecuteWatchOptions (Maybe Bool) +ewoRecordExecutionLens = lens ewoRecordExecution (\x y -> x {ewoRecordExecution = y}) + +awrAckStateLens :: Lens' AckWatchResponse (Maybe AckState) +awrAckStateLens = lens awrAckState (\x y -> x {awrAckState = y}) + +awrWatchStatusLens :: Lens' AckWatchResponse (Maybe WatchStateResponse) +awrWatchStatusLens = lens awrWatchStatus (\x y -> x {awrWatchStatus = y}) + +awrExtrasLens :: Lens' AckWatchResponse (Maybe (KeyMap Value)) +awrExtrasLens = lens awrExtras (\x y -> x {awrExtras = y}) + +wsrAckStateLens :: Lens' WatchStateResponse (Maybe AckState) +wsrAckStateLens = lens wsrAckState (\x y -> x {wsrAckState = y}) + +wsrStateLens :: Lens' WatchStateResponse (Maybe WatchExecutionState) +wsrStateLens = lens wsrState (\x y -> x {wsrState = y}) + +wsrVersionLens :: Lens' WatchStateResponse (Maybe Int) +wsrVersionLens = lens wsrVersion (\x y -> x {wsrVersion = y}) + +wsrExtrasLens :: Lens' WatchStateResponse (Maybe (KeyMap Value)) +wsrExtrasLens = lens wsrExtras (\x y -> x {wsrExtras = y}) + +watcherStatsNodesLens :: Lens' WatcherStatsResponse (Maybe Value) +watcherStatsNodesLens = lens watcherStatsNodes (\x y -> x {watcherStatsNodes = y}) + +watcherStatsClusterNameLens :: Lens' WatcherStatsResponse (Maybe Text) +watcherStatsClusterNameLens = + lens watcherStatsClusterName (\x y -> x {watcherStatsClusterName = y}) + +watcherStatsStatsLens :: Lens' WatcherStatsResponse (Maybe WatcherStatsSummary) +watcherStatsStatsLens = + lens watcherStatsStats (\x y -> x {watcherStatsStats = y}) + +watcherStatsExtrasLens :: Lens' WatcherStatsResponse (Maybe (KeyMap Value)) +watcherStatsExtrasLens = + lens watcherStatsExtras (\x y -> x {watcherStatsExtras = y}) + +wssWatchCountLens :: Lens' WatcherStatsSummary (Maybe Int) +wssWatchCountLens = lens wssWatchCount (\x y -> x {wssWatchCount = y}) + +wssExecutionStateLens :: Lens' WatcherStatsSummary (Maybe Text) +wssExecutionStateLens = + lens wssExecutionState (\x y -> x {wssExecutionState = y}) + +wssThreadPoolLens :: Lens' WatcherStatsSummary (Maybe Value) +wssThreadPoolLens = lens wssThreadPool (\x y -> x {wssThreadPool = y}) + +wssPendingWatchesLens :: Lens' WatcherStatsSummary (Maybe Int) +wssPendingWatchesLens = + lens wssPendingWatches (\x y -> x {wssPendingWatches = y}) + +wssExtrasLens :: Lens' WatcherStatsSummary (Maybe (KeyMap Value)) +wssExtrasLens = lens wssExtras (\x y -> x {wssExtras = y}) + +watcherSettingsPersistentLens :: Lens' WatcherSettings (Maybe Value) +watcherSettingsPersistentLens = + lens watcherSettingsPersistent (\x y -> x {watcherSettingsPersistent = y}) + +watcherSettingsTransientLens :: Lens' WatcherSettings (Maybe Value) +watcherSettingsTransientLens = + lens watcherSettingsTransient (\x y -> x {watcherSettingsTransient = y}) + +watcherSettingsDefaultsLens :: Lens' WatcherSettings (Maybe Value) +watcherSettingsDefaultsLens = + lens watcherSettingsDefaults (\x y -> x {watcherSettingsDefaults = y}) + +watcherSettingsExtrasLens :: Lens' WatcherSettings (Maybe (KeyMap Value)) +watcherSettingsExtrasLens = + lens watcherSettingsExtras (\x y -> x {watcherSettingsExtras = y}) + +-------------------------------------------------------------------------------- +-- Internal helpers +-------------------------------------------------------------------------------- + +-- | Drop the supplied top-level keys from a 'KeyMap', returning 'Nothing' +-- when nothing remains. Used to build forward-compatible @extras@ +-- catch-alls: every key the typed decoder already consumed is removed, and +-- any unrecognised sibling survives in the returned 'KeyMap'. +stripKeys :: [Text] -> KeyMap Value -> Maybe (KeyMap Value) +stripKeys keys km = + let stripped = foldr (KM.delete . fromText) km keys + in if KM.null stripped then Nothing else Just stripped + +-- | Merge an @extras@ 'KeyMap' (if any) into a JSON 'Value' produced by +-- 'omitNulls'. The base value is expected to be an 'Object'; non-object +-- bases are returned unchanged (defensive — should not happen for the +-- types in this module). +mergeExtras :: Maybe (KeyMap Value) -> Value -> Value +mergeExtras Nothing base = base +mergeExtras (Just extras) (Object base) = + Object (KM.union base extras) +mergeExtras _ base = base diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/DataStream.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/DataStream.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/DataStream.hs @@ -0,0 +1,1673 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.DataStream +-- Description : Types for representing Elasticsearch Data Streams +-- +-- Defines the request/response shapes for ES Data Streams ('DataStream', +-- 'DataStreamName', 'DataStreamStatus', 'DataStreamTimestampField', +-- 'DataStreamIndex', 'GetDataStreamsResponse'). 'DataStreamInfo' is a +-- type alias for 'DataStream' matching the naming used by the +-- @GET /_data_stream@ endpoint (see 'Database.Bloodhound.ElasticSearch7.Client.getDataStreams'). +-- +-- The 'DataStreamStat' and 'DataStreamStats' types model the +-- @GET /_data_stream/_stats@ response (see +-- 'Database.Bloodhound.ElasticSearch7.Client.getDataStreamStats'). +-- +-- The wire format for Data Streams is identical across ES 7.x, 8.x and +-- 9.x, so these types are re-exported unchanged from +-- "Database.Bloodhound.ElasticSearch8.Types" and +-- "Database.Bloodhound.ElasticSearch9.Types". The full Data Streams API +-- (PUT, POST, HEAD, DELETE, _stats, _migrate, _promote, lifecycle) is +-- implemented in +-- "Database.Bloodhound.ElasticSearch7.Requests" and re-exported by the +-- ES8 and ES9 client modules. +module Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.DataStream + ( DataStreamName (..), + DataStream (..), + DataStreamInfo, + DataStreamStatus (..), + DataStreamTimestampField (..), + DataStreamIndex (..), + GetDataStreamsResponse (..), + DataStreamStat (..), + DataStreamStats (..), + DataStreamLifecycleDownsampling (..), + SamplingMethod (..), + DataStreamLifecycle (..), + DataStreamLifecycleInfo (..), + DataStreamGlobalRetention (..), + GetDataStreamLifecyclesResponse (..), + ModifyDataStreamAction (..), + ModifyDataStreamRequest (..), + PutDataStreamsLifecycleRequest (..), + DataStreamFailureStoreLifecycle (..), + DataStreamFailureStore (..), + UpdateDataStreamOptionsRequest (..), + DataStreamOptions (..), + DataStreamOptionsEntry (..), + GetDataStreamOptionsResponse (..), + dataStreamNameLens, + dataStreamTimestampFieldLens, + dataStreamIndicesLens, + dataStreamGenerationLens, + dataStreamStatusLens, + dataStreamTemplateLens, + dataStreamIlmPolicyLens, + dataStreamHiddenLens, + dataStreamSystemLens, + dataStreamReplicatedLens, + dataStreamMetaLens, + dataStreamStatNameLens, + dataStreamStatBackingIndicesLens, + dataStreamStatStoreSizeBytesLens, + dataStreamStatStoreSizeLens, + dataStreamStatMaximumTimestampLens, + dataStreamStatsShardsLens, + dataStreamStatsCountLens, + dataStreamStatsBackingIndicesLens, + dataStreamStatsTotalStoreSizeBytesLens, + dataStreamStatsTotalStoreSizeLens, + dataStreamStatsDataStreamsLens, + dataStreamLifecycleDownsamplingAfterLens, + dataStreamLifecycleDownsamplingFixedIntervalLens, + dataStreamLifecycleDataRetentionLens, + dataStreamLifecycleEnabledLens, + dataStreamLifecycleDownsamplingLens, + dataStreamLifecycleDownsamplingMethodLens, + dataStreamLifecycleEffectiveRetentionLens, + dataStreamLifecycleRetentionDeterminedByLens, + dataStreamLifecycleInfoNameLens, + dataStreamLifecycleInfoLifecycleLens, + dataStreamLifecyclesLens, + dataStreamGlobalRetentionMaxRetentionLens, + dataStreamGlobalRetentionDefaultRetentionLens, + dataStreamLifecyclesGlobalRetentionLens, + modifyDataStreamActionsLens, + putDataStreamsLifecycleRequestStreamsLens, + dataStreamFailureStoreLifecycleDataRetentionLens, + dataStreamFailureStoreLifecycleEnabledLens, + dataStreamFailureStoreEnabledLens, + dataStreamFailureStoreLifecycleLens, + updateDataStreamOptionsRequestFailureStoreLens, + dataStreamOptionsFailureStoreLens, + dataStreamOptionsEntryNameLens, + dataStreamOptionsEntryOptionsLens, + getDataStreamOptionsResponseDataStreamsLens, + + -- * Data stream lifecycle stats (GET /_lifecycle/stats) + DataStreamLifecycleStats (..), + DataStreamLifecycleStatsEntry (..), + dataStreamLifecycleStatsLastRunDurationInMillisLens, + dataStreamLifecycleStatsLastRunDurationLens, + dataStreamLifecycleStatsTimeBetweenStartsInMillisLens, + dataStreamLifecycleStatsTimeBetweenStartsLens, + dataStreamLifecycleStatsCountLens, + dataStreamLifecycleStatsDataStreamsLens, + dataStreamLifecycleStatsEntryNameLens, + dataStreamLifecycleStatsEntryBackingIndicesInTotalLens, + dataStreamLifecycleStatsEntryBackingIndicesInErrorLens, + + -- * Explain data stream lifecycle (GET /{index}/_lifecycle/explain) + ExplainDataStreamLifecycleResponse (..), + ExplainDataStreamLifecycleIndex (..), + explainDataStreamLifecycleResponseIndicesLens, + explainDataStreamLifecycleIndexIndexLens, + explainDataStreamLifecycleIndexManagedByLifecycleLens, + explainDataStreamLifecycleIndexCreationDateMillisLens, + explainDataStreamLifecycleIndexTimeSinceIndexCreationLens, + explainDataStreamLifecycleIndexRolloverDateMillisLens, + explainDataStreamLifecycleIndexTimeSinceRolloverLens, + explainDataStreamLifecycleIndexLifecycleLens, + explainDataStreamLifecycleIndexGenerationTimeLens, + explainDataStreamLifecycleIndexErrorLens, + ExplainDataStreamLifecycleOptions (..), + defaultExplainDataStreamLifecycleOptions, + GetDataStreamMappingsOptions (..), + defaultGetDataStreamMappingsOptions, + UpdateDataStreamMappingsOptions (..), + defaultUpdateDataStreamMappingsOptions, + GetDataStreamSettingsOptions (..), + defaultGetDataStreamSettingsOptions, + UpdateDataStreamSettingsOptions (..), + defaultUpdateDataStreamSettingsOptions, + + -- * Data stream mappings (GET/PUT /_data_stream/{name}/_mappings) + GetDataStreamMappingsResponse (..), + GetDataStreamMappingsEntry (..), + UpdateDataStreamMappingsResponse (..), + UpdateDataStreamMappingsEntry (..), + getDataStreamMappingsResponseDataStreamsLens, + getDataStreamMappingsEntryNameLens, + getDataStreamMappingsEntryMappingsLens, + getDataStreamMappingsEntryEffectiveMappingsLens, + updateDataStreamMappingsResponseDataStreamsLens, + updateDataStreamMappingsEntryNameLens, + updateDataStreamMappingsEntryAppliedToDataStreamLens, + updateDataStreamMappingsEntryErrorLens, + updateDataStreamMappingsEntryMappingsLens, + updateDataStreamMappingsEntryEffectiveMappingsLens, + + -- * Data stream settings (GET/PUT /_data_stream/{name}/_settings) + GetDataStreamSettingsResponse (..), + GetDataStreamSettingsEntry (..), + UpdateDataStreamSettingsResponse (..), + UpdateDataStreamSettingsEntry (..), + IndexSettingsResults (..), + IndexSettingError (..), + getDataStreamSettingsResponseDataStreamsLens, + getDataStreamSettingsEntryNameLens, + getDataStreamSettingsEntrySettingsLens, + getDataStreamSettingsEntryEffectiveSettingsLens, + updateDataStreamSettingsResponseDataStreamsLens, + updateDataStreamSettingsEntryNameLens, + updateDataStreamSettingsEntryAppliedToDataStreamLens, + updateDataStreamSettingsEntryErrorLens, + updateDataStreamSettingsEntrySettingsLens, + updateDataStreamSettingsEntryEffectiveSettingsLens, + updateDataStreamSettingsEntryIndexSettingsResultsLens, + indexSettingsResultsAppliedToDataStreamOnlyLens, + indexSettingsResultsAppliedToDataStreamAndBackingIndicesLens, + indexSettingsResultsErrorsLens, + indexSettingErrorIndexLens, + indexSettingErrorErrorLens, + ) +where + +import Data.Int (Int64) +import Data.Map.Strict qualified as M +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Indices (SamplingMethod (..), TemplateName) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes (IndexName) +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes (ShardResult) +import GHC.Generics + +newtype DataStreamName = DataStreamName Text deriving newtype (Eq, Show, ToJSON, FromJSON) + +-- | Health status of a data stream. Elasticsearch emits this as the +-- @_types.HealthStatus@ enum, which accepts both lower- and upper-case +-- spellings of @green@\/@yellow@\/@red@ plus the degenerate @unknown@ and +-- @unavailable@ states (seen during cluster startup, when stats are +-- missing, or when a failure store is involved). Both casings decode to +-- the same constructor; on encode the primary colours use the uppercase +-- wire form and the degenerate states use lowercase, matching the ES +-- spec examples. +data DataStreamStatus = Green | Yellow | Red | Unknown | Unavailable + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamStatus where + parseJSON = withText "DataStreamStatus" $ \case + "green" -> pure Green + "GREEN" -> pure Green + "yellow" -> pure Yellow + "YELLOW" -> pure Yellow + "red" -> pure Red + "RED" -> pure Red + "unknown" -> pure Unknown + "unavailable" -> pure Unavailable + _ -> fail "Invalid DataStreamStatus" + +instance ToJSON DataStreamStatus where + toJSON Green = "GREEN" + toJSON Yellow = "YELLOW" + toJSON Red = "RED" + toJSON Unknown = "unknown" + toJSON Unavailable = "unavailable" + +newtype DataStreamTimestampField = DataStreamTimestampField + { dataStreamTimestampFieldName :: Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamTimestampField where + parseJSON = withObject "DataStreamTimestampField" $ \o -> + DataStreamTimestampField <$> o .: "name" + +instance ToJSON DataStreamTimestampField where + toJSON (DataStreamTimestampField name) = object ["name" .= name] + +data DataStreamIndex = DataStreamIndex + { dataStreamIndexName :: IndexName, + dataStreamIndexUuid :: Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamIndex where + parseJSON = withObject "DataStreamIndex" $ \o -> + DataStreamIndex + <$> o .: "index_name" + <*> o .: "index_uuid" + +instance ToJSON DataStreamIndex where + toJSON DataStreamIndex {..} = + object + [ "index_name" .= dataStreamIndexName, + "index_uuid" .= dataStreamIndexUuid + ] + +data DataStream = DataStream + { dataStreamName :: DataStreamName, + dataStreamTimestampField :: DataStreamTimestampField, + dataStreamIndices :: [DataStreamIndex], + dataStreamGeneration :: Int, + dataStreamStatus :: DataStreamStatus, + dataStreamTemplate :: TemplateName, + dataStreamIlmPolicy :: Maybe Text, + -- NB: @hidden@ is strict 'Bool' because ES documents it as + -- always-present on the @GET /_data_stream@ response; the + -- @system@\/@replicated@ flags below are documented as optional + -- informational fields and are therefore 'Maybe'. + dataStreamHidden :: Bool, + -- | @system@ (Boolean). If @true@ the stream is created and managed + -- by an Elastic stack component and cannot be modified through + -- normal user interaction. Informational, response-only; emitted by + -- ES on the @GET /_data_stream@ response and parsed as 'Nothing' + -- when the server omits it (older ES 7.x patch releases). + dataStreamSystem :: Maybe Bool, + -- | @replicated@ (Boolean). If @true@ the stream is created and + -- managed by cross-cluster replication and the local cluster cannot + -- write into it or change its mappings. Informational, + -- response-only; 'Nothing' when the server omits it. + dataStreamReplicated :: Maybe Bool, + -- | @_meta@ (object). Custom metadata copied from the @_meta@ object + -- of the stream's matching index template. Per the ES docs this + -- property is omitted by the server when empty, so it is decoded as + -- 'Nothing' in that case (and when explicitly @null@). Typed as + -- 'Object' (not 'Value') to match both the documented \"(object)\" + -- wire type and the closest existing precedent + -- 'ComponentTemplate.cpMeta' — the index-template @_meta@ is the + -- exact source of this field, so a non-object payload would be a + -- server bug we surface as a decode failure rather than paper over. + dataStreamMeta :: Maybe Object + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStream where + parseJSON = withObject "DataStream" $ \o -> + DataStream + <$> o .: "name" + <*> o .: "timestamp_field" + <*> o .: "indices" + <*> o .: "generation" + <*> o .: "status" + <*> o .: "template" + <*> o .:? "ilm_policy" + <*> o .: "hidden" + <*> o .:? "system" + <*> o .:? "replicated" + <*> o .:? "_meta" + +instance ToJSON DataStream where + toJSON DataStream {..} = + object + [ "name" .= dataStreamName, + "timestamp_field" .= dataStreamTimestampField, + "indices" .= dataStreamIndices, + "generation" .= dataStreamGeneration, + "status" .= dataStreamStatus, + "template" .= dataStreamTemplate, + "ilm_policy" .= dataStreamIlmPolicy, + "hidden" .= dataStreamHidden, + "system" .= dataStreamSystem, + "replicated" .= dataStreamReplicated, + "_meta" .= dataStreamMeta + ] + +-- | Convenience alias for 'DataStream' matching the @GET /_data_stream@ +-- response vocabulary (each entry in the @data_streams@ array is an +-- \"info\" record for one stream). The two names refer to the same type +-- and are interchangeable. +type DataStreamInfo = DataStream + +newtype GetDataStreamsResponse = GetDataStreamsResponse + { dataStreams :: [DataStream] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON GetDataStreamsResponse where + parseJSON = withObject "GetDataStreamsResponse" $ \o -> + GetDataStreamsResponse <$> o .: "data_streams" + +instance ToJSON GetDataStreamsResponse where + toJSON (GetDataStreamsResponse streams) = object ["data_streams" .= streams] + +-- | Per-stream statistics returned inside the @data_streams@ array of a +-- 'DataStreamStats' response from @GET /_data_stream/_stats@. The +-- @data_stream@ field carries the stream's name (re-exported here as a +-- 'DataStreamName' for consistency with the rest of the API); the size +-- fields are reported both as a raw byte count ('Int64') and as a +-- human-readable string, mirroring what Elasticsearch emits. The +-- human-readable 'dataStreamStatStoreSize' is only sent by ES when the +-- request carries @human=true@; it is decoded as 'Nothing' otherwise +-- (the byte count in 'dataStreamStatStoreSizeBytes' is always present). +data DataStreamStat = DataStreamStat + { dataStreamStatName :: DataStreamName, + dataStreamStatBackingIndices :: Int, + dataStreamStatStoreSizeBytes :: Int64, + dataStreamStatStoreSize :: Maybe Text, + dataStreamStatMaximumTimestamp :: Int64 + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamStat where + parseJSON = withObject "DataStreamStat" $ \o -> + DataStreamStat + <$> (DataStreamName <$> o .: "data_stream") + <*> o .: "backing_indices" + <*> o .: "store_size_bytes" + <*> o .:? "store_size" + <*> o .: "maximum_timestamp" + +instance ToJSON DataStreamStat where + toJSON DataStreamStat {..} = + object + [ "data_stream" .= dataStreamStatName, + "backing_indices" .= dataStreamStatBackingIndices, + "store_size_bytes" .= dataStreamStatStoreSizeBytes, + "store_size" .= dataStreamStatStoreSize, + "maximum_timestamp" .= dataStreamStatMaximumTimestamp + ] + +-- | Top-level response of @GET /_data_stream/_stats@. Carries the +-- @_shards@ summary, cluster-wide aggregates (@data_stream_count@, +-- @backing_indices@, @total_store_size_bytes@, @total_store_size@) and +-- the per-stream breakdown in @data_streams@. The @_shards@ field is +-- decoded strictly: Elasticsearch always returns it for this endpoint. +-- Like 'dataStreamStatStoreSize', the human-readable +-- 'dataStreamStatsTotalStoreSize' is only emitted when @human=true@ and +-- is decoded as 'Nothing' otherwise ('dataStreamStatsTotalStoreSizeBytes' +-- is always present). +data DataStreamStats = DataStreamStats + { dataStreamStatsShards :: ShardResult, + dataStreamStatsCount :: Int, + dataStreamStatsBackingIndices :: Int, + dataStreamStatsTotalStoreSizeBytes :: Int64, + dataStreamStatsTotalStoreSize :: Maybe Text, + dataStreamStatsDataStreams :: [DataStreamStat] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamStats where + parseJSON = withObject "DataStreamStats" $ \o -> + DataStreamStats + <$> o .: "_shards" + <*> o .: "data_stream_count" + <*> o .: "backing_indices" + <*> o .: "total_store_size_bytes" + <*> o .:? "total_store_size" + <*> o .: "data_streams" + +instance ToJSON DataStreamStats where + toJSON DataStreamStats {..} = + object + [ "_shards" .= dataStreamStatsShards, + "data_stream_count" .= dataStreamStatsCount, + "backing_indices" .= dataStreamStatsBackingIndices, + "total_store_size_bytes" .= dataStreamStatsTotalStoreSizeBytes, + "total_store_size" .= dataStreamStatsTotalStoreSize, + "data_streams" .= dataStreamStatsDataStreams + ] + +-- $dataStreamLifecycle +-- +-- /Data Stream Lifecycle/ (ES 8.x+) manages retention and downsampling +-- for a data stream without a full ILM policy. The wire format is +-- identical across ES 7.x, 8.x and 9.x (the lifecycle API was +-- back-filled to ES 7.17.x), so these types live alongside the rest of +-- the Data Stream types and are re-exported unchanged from the ES8 and +-- ES9 type modules. See "Database.Bloodhound.ElasticSearch7.Requests" +-- for the request builders. + +-- | Per-rollover downsampling configuration executed for the managed +-- backing index after rollover. Both fields are optional: @after@ is +-- the time after which downsampling should be performed (e.g. +-- @\"10d\"@), @fixed_interval@ is the fixed interval for the downsampled +-- data (e.g. @\"1h\"@). +data DataStreamLifecycleDownsampling = DataStreamLifecycleDownsampling + { dataStreamLifecycleDownsamplingAfter :: Maybe Text, + dataStreamLifecycleDownsamplingFixedInterval :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamLifecycleDownsampling where + parseJSON = withObject "DataStreamLifecycleDownsampling" $ \o -> + DataStreamLifecycleDownsampling + <$> o .:? "after" + <*> o .:? "fixed_interval" + +instance ToJSON DataStreamLifecycleDownsampling where + toJSON DataStreamLifecycleDownsampling {..} = + omitNulls + [ "after" .= dataStreamLifecycleDownsamplingAfter, + "fixed_interval" .= dataStreamLifecycleDownsamplingFixedInterval + ] + +-- | Downsampling method used when 'dataStreamLifecycleDownsampling' is +-- defined. @aggregate@ is the default; @last_value@ requires the +-- downsampling array to be present. This is the shared 'SamplingMethod' +-- enum from "Database.Bloodhound.Internal.Versions.Common.Types.Indices", +-- re-exported here so callers of the ES7 data-stream lifecycle API can +-- spell it next to 'DataStreamLifecycle'. + +-- | Lifecycle configuration for a data stream. Used both as the PUT +-- request body (path carries the stream name) and as the @lifecycle@ +-- field inside a 'DataStreamLifecycleInfo' from @GET +-- /_data_stream/{name}/_lifecycle@. All fields are optional: an empty +-- 'DataStreamLifecycle' is a valid PUT body that toggles the lifecycle +-- on for the named stream (per ES docs, @enabled@ defaults to @true@ +-- when the lifecycle is set). +data DataStreamLifecycle = DataStreamLifecycle + { dataStreamLifecycleDataRetention :: Maybe Text, + dataStreamLifecycleEnabled :: Maybe Bool, + dataStreamLifecycleDownsampling :: Maybe [DataStreamLifecycleDownsampling], + dataStreamLifecycleDownsamplingMethod :: Maybe SamplingMethod, + -- | Read-only field set by ES on GET responses. The effective + -- retention actually applied to the stream, which may differ from + -- 'dataStreamLifecycleDataRetention' when 'global_retention' + -- overrides it. Never sent on PUT. + dataStreamLifecycleEffectiveRetention :: Maybe Text, + -- | Read-only field set by ES on GET responses. Identifies which + -- source determined 'dataStreamLifecycleEffectiveRetention': + -- @data_stream_configuration@, @default_global_retention@, + -- @max_global_retention@ or @default_failures_retention@. Never + -- sent on PUT. + dataStreamLifecycleRetentionDeterminedBy :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamLifecycle where + parseJSON = withObject "DataStreamLifecycle" $ \o -> + DataStreamLifecycle + <$> o .:? "data_retention" + <*> o .:? "enabled" + <*> o .:? "downsampling" + <*> o .:? "downsampling_method" + <*> o .:? "effective_retention" + <*> o .:? "retention_determined_by" + +instance ToJSON DataStreamLifecycle where + toJSON DataStreamLifecycle {..} = + omitNulls + [ "data_retention" .= dataStreamLifecycleDataRetention, + "enabled" .= dataStreamLifecycleEnabled, + "downsampling" .= dataStreamLifecycleDownsampling, + "downsampling_method" .= dataStreamLifecycleDownsamplingMethod, + "effective_retention" .= dataStreamLifecycleEffectiveRetention, + "retention_determined_by" .= dataStreamLifecycleRetentionDeterminedBy + ] + +-- | One entry inside the @data_streams@ array of a +-- 'GetDataStreamLifecyclesResponse'. The per-stream name is read from +-- the @name@ JSON key. The 'lifecycle' field is 'Nothing' when the +-- stream is not managed by a lifecycle: ES omits the @lifecycle@ key +-- entirely for unmanaged streams; we additionally tolerate an explicit +-- @null@ for robustness (both decode to 'Nothing'). +data DataStreamLifecycleInfo = DataStreamLifecycleInfo + { dataStreamLifecycleInfoName :: DataStreamName, + dataStreamLifecycleInfoLifecycle :: Maybe DataStreamLifecycle + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamLifecycleInfo where + parseJSON = withObject "DataStreamLifecycleInfo" $ \o -> + DataStreamLifecycleInfo + <$> (DataStreamName <$> o .: "name") + <*> o .:? "lifecycle" + +instance ToJSON DataStreamLifecycleInfo where + toJSON DataStreamLifecycleInfo {..} = + omitNulls + [ "name" .= dataStreamLifecycleInfoName, + "lifecycle" .= dataStreamLifecycleInfoLifecycle + ] + +-- | Cluster-wide retention bounds returned at the top level of a +-- 'GetDataStreamLifecyclesResponse'. The @max_retention@ caps any +-- per-stream retention; @default_retention@ applies when a stream has +-- no explicit 'dataStreamLifecycleDataRetention'. Either field may be +-- absent (Nothing) when the cluster has not configured global retention. +data DataStreamGlobalRetention = DataStreamGlobalRetention + { dataStreamGlobalRetentionMaxRetention :: Maybe Text, + dataStreamGlobalRetentionDefaultRetention :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamGlobalRetention where + parseJSON = withObject "DataStreamGlobalRetention" $ \o -> + DataStreamGlobalRetention + <$> o .:? "max_retention" + <*> o .:? "default_retention" + +instance ToJSON DataStreamGlobalRetention where + toJSON DataStreamGlobalRetention {..} = + omitNulls + [ "max_retention" .= dataStreamGlobalRetentionMaxRetention, + "default_retention" .= dataStreamGlobalRetentionDefaultRetention + ] + +-- | Top-level response of @GET /_data_stream/{name}/_lifecycle@. +-- Carries a flat list of 'DataStreamLifecycleInfo' entries in the +-- @data_streams@ array plus the cluster-wide 'global_retention' bounds. +-- Per the ES docs, @global_retention@ is documented as Required on the +-- response, but we decode it leniently as 'Maybe' to tolerate clusters +-- where it is not yet configured. +data GetDataStreamLifecyclesResponse = GetDataStreamLifecyclesResponse + { dataStreamLifecycles :: [DataStreamLifecycleInfo], + dataStreamLifecyclesGlobalRetention :: Maybe DataStreamGlobalRetention + } + deriving stock (Eq, Show, Generic) + +instance FromJSON GetDataStreamLifecyclesResponse where + parseJSON = withObject "GetDataStreamLifecyclesResponse" $ \o -> + GetDataStreamLifecyclesResponse + <$> o .: "data_streams" + <*> o .:? "global_retention" + +instance ToJSON GetDataStreamLifecyclesResponse where + toJSON GetDataStreamLifecyclesResponse {..} = + omitNulls + [ "data_streams" .= dataStreamLifecycles, + "global_retention" .= dataStreamLifecyclesGlobalRetention + ] + +-- | Request body for the bulk @PUT /_data_stream/_lifecycle@ endpoint +-- (ES 8.11+, back-filled to ES 7.17.x). Carries a flat list of +-- 'DataStreamLifecycleInfo' entries (one per stream) in the +-- @data_streams@ array; each entry pairs the stream name with its +-- 'DataStreamLifecycle' configuration. The wire format is identical to +-- the body of 'GetDataStreamLifecyclesResponse' minus the +-- @global_retention@ field, which is never sent on PUT. +newtype PutDataStreamsLifecycleRequest = PutDataStreamsLifecycleRequest + { putDataStreamsLifecycleRequestStreams :: [DataStreamLifecycleInfo] + } + deriving stock (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid) + +instance FromJSON PutDataStreamsLifecycleRequest where + parseJSON = withObject "PutDataStreamsLifecycleRequest" $ \o -> + PutDataStreamsLifecycleRequest <$> o .: "data_streams" + +instance ToJSON PutDataStreamsLifecycleRequest where + toJSON (PutDataStreamsLifecycleRequest streams) = + object ["data_streams" .= streams] + +-- Lenses + +dataStreamNameLens :: Lens' DataStream DataStreamName +dataStreamNameLens = lens dataStreamName (\x y -> x {dataStreamName = y}) + +dataStreamTimestampFieldLens :: Lens' DataStream DataStreamTimestampField +dataStreamTimestampFieldLens = lens dataStreamTimestampField (\x y -> x {dataStreamTimestampField = y}) + +dataStreamIndicesLens :: Lens' DataStream [DataStreamIndex] +dataStreamIndicesLens = lens dataStreamIndices (\x y -> x {dataStreamIndices = y}) + +dataStreamGenerationLens :: Lens' DataStream Int +dataStreamGenerationLens = lens dataStreamGeneration (\x y -> x {dataStreamGeneration = y}) + +dataStreamStatusLens :: Lens' DataStream DataStreamStatus +dataStreamStatusLens = lens dataStreamStatus (\x y -> x {dataStreamStatus = y}) + +dataStreamTemplateLens :: Lens' DataStream TemplateName +dataStreamTemplateLens = lens dataStreamTemplate (\x y -> x {dataStreamTemplate = y}) + +dataStreamIlmPolicyLens :: Lens' DataStream (Maybe Text) +dataStreamIlmPolicyLens = lens dataStreamIlmPolicy (\x y -> x {dataStreamIlmPolicy = y}) + +dataStreamHiddenLens :: Lens' DataStream Bool +dataStreamHiddenLens = lens dataStreamHidden (\x y -> x {dataStreamHidden = y}) + +dataStreamSystemLens :: Lens' DataStream (Maybe Bool) +dataStreamSystemLens = lens dataStreamSystem (\x y -> x {dataStreamSystem = y}) + +dataStreamReplicatedLens :: Lens' DataStream (Maybe Bool) +dataStreamReplicatedLens = lens dataStreamReplicated (\x y -> x {dataStreamReplicated = y}) + +dataStreamMetaLens :: Lens' DataStream (Maybe Object) +dataStreamMetaLens = lens dataStreamMeta (\x y -> x {dataStreamMeta = y}) + +dataStreamStatNameLens :: Lens' DataStreamStat DataStreamName +dataStreamStatNameLens = lens dataStreamStatName (\x y -> x {dataStreamStatName = y}) + +dataStreamStatBackingIndicesLens :: Lens' DataStreamStat Int +dataStreamStatBackingIndicesLens = lens dataStreamStatBackingIndices (\x y -> x {dataStreamStatBackingIndices = y}) + +dataStreamStatStoreSizeBytesLens :: Lens' DataStreamStat Int64 +dataStreamStatStoreSizeBytesLens = lens dataStreamStatStoreSizeBytes (\x y -> x {dataStreamStatStoreSizeBytes = y}) + +dataStreamStatStoreSizeLens :: Lens' DataStreamStat (Maybe Text) +dataStreamStatStoreSizeLens = lens dataStreamStatStoreSize (\x y -> x {dataStreamStatStoreSize = y}) + +dataStreamStatMaximumTimestampLens :: Lens' DataStreamStat Int64 +dataStreamStatMaximumTimestampLens = lens dataStreamStatMaximumTimestamp (\x y -> x {dataStreamStatMaximumTimestamp = y}) + +dataStreamStatsShardsLens :: Lens' DataStreamStats ShardResult +dataStreamStatsShardsLens = lens dataStreamStatsShards (\x y -> x {dataStreamStatsShards = y}) + +dataStreamStatsCountLens :: Lens' DataStreamStats Int +dataStreamStatsCountLens = lens dataStreamStatsCount (\x y -> x {dataStreamStatsCount = y}) + +dataStreamStatsBackingIndicesLens :: Lens' DataStreamStats Int +dataStreamStatsBackingIndicesLens = lens dataStreamStatsBackingIndices (\x y -> x {dataStreamStatsBackingIndices = y}) + +dataStreamStatsTotalStoreSizeBytesLens :: Lens' DataStreamStats Int64 +dataStreamStatsTotalStoreSizeBytesLens = lens dataStreamStatsTotalStoreSizeBytes (\x y -> x {dataStreamStatsTotalStoreSizeBytes = y}) + +dataStreamStatsTotalStoreSizeLens :: Lens' DataStreamStats (Maybe Text) +dataStreamStatsTotalStoreSizeLens = lens dataStreamStatsTotalStoreSize (\x y -> x {dataStreamStatsTotalStoreSize = y}) + +dataStreamStatsDataStreamsLens :: Lens' DataStreamStats [DataStreamStat] +dataStreamStatsDataStreamsLens = lens dataStreamStatsDataStreams (\x y -> x {dataStreamStatsDataStreams = y}) + +-- Data Stream Lifecycle lenses + +dataStreamLifecycleDownsamplingAfterLens :: Lens' DataStreamLifecycleDownsampling (Maybe Text) +dataStreamLifecycleDownsamplingAfterLens = lens dataStreamLifecycleDownsamplingAfter (\x y -> x {dataStreamLifecycleDownsamplingAfter = y}) + +dataStreamLifecycleDownsamplingFixedIntervalLens :: Lens' DataStreamLifecycleDownsampling (Maybe Text) +dataStreamLifecycleDownsamplingFixedIntervalLens = lens dataStreamLifecycleDownsamplingFixedInterval (\x y -> x {dataStreamLifecycleDownsamplingFixedInterval = y}) + +dataStreamLifecycleDataRetentionLens :: Lens' DataStreamLifecycle (Maybe Text) +dataStreamLifecycleDataRetentionLens = lens dataStreamLifecycleDataRetention (\x y -> x {dataStreamLifecycleDataRetention = y}) + +dataStreamLifecycleEnabledLens :: Lens' DataStreamLifecycle (Maybe Bool) +dataStreamLifecycleEnabledLens = lens dataStreamLifecycleEnabled (\x y -> x {dataStreamLifecycleEnabled = y}) + +dataStreamLifecycleDownsamplingLens :: Lens' DataStreamLifecycle (Maybe [DataStreamLifecycleDownsampling]) +dataStreamLifecycleDownsamplingLens = lens dataStreamLifecycleDownsampling (\x y -> x {dataStreamLifecycleDownsampling = y}) + +dataStreamLifecycleDownsamplingMethodLens :: Lens' DataStreamLifecycle (Maybe SamplingMethod) +dataStreamLifecycleDownsamplingMethodLens = lens dataStreamLifecycleDownsamplingMethod (\x y -> x {dataStreamLifecycleDownsamplingMethod = y}) + +dataStreamLifecycleInfoNameLens :: Lens' DataStreamLifecycleInfo DataStreamName +dataStreamLifecycleInfoNameLens = lens dataStreamLifecycleInfoName (\x y -> x {dataStreamLifecycleInfoName = y}) + +dataStreamLifecycleInfoLifecycleLens :: Lens' DataStreamLifecycleInfo (Maybe DataStreamLifecycle) +dataStreamLifecycleInfoLifecycleLens = lens dataStreamLifecycleInfoLifecycle (\x y -> x {dataStreamLifecycleInfoLifecycle = y}) + +dataStreamLifecyclesLens :: Lens' GetDataStreamLifecyclesResponse [DataStreamLifecycleInfo] +dataStreamLifecyclesLens = lens dataStreamLifecycles (\x y -> x {dataStreamLifecycles = y}) + +-- Additional Data Stream Lifecycle lenses + +dataStreamLifecycleEffectiveRetentionLens :: Lens' DataStreamLifecycle (Maybe Text) +dataStreamLifecycleEffectiveRetentionLens = lens dataStreamLifecycleEffectiveRetention (\x y -> x {dataStreamLifecycleEffectiveRetention = y}) + +dataStreamLifecycleRetentionDeterminedByLens :: Lens' DataStreamLifecycle (Maybe Text) +dataStreamLifecycleRetentionDeterminedByLens = lens dataStreamLifecycleRetentionDeterminedBy (\x y -> x {dataStreamLifecycleRetentionDeterminedBy = y}) + +dataStreamGlobalRetentionMaxRetentionLens :: Lens' DataStreamGlobalRetention (Maybe Text) +dataStreamGlobalRetentionMaxRetentionLens = lens dataStreamGlobalRetentionMaxRetention (\x y -> x {dataStreamGlobalRetentionMaxRetention = y}) + +dataStreamGlobalRetentionDefaultRetentionLens :: Lens' DataStreamGlobalRetention (Maybe Text) +dataStreamGlobalRetentionDefaultRetentionLens = lens dataStreamGlobalRetentionDefaultRetention (\x y -> x {dataStreamGlobalRetentionDefaultRetention = y}) + +dataStreamLifecyclesGlobalRetentionLens :: Lens' GetDataStreamLifecyclesResponse (Maybe DataStreamGlobalRetention) +dataStreamLifecyclesGlobalRetentionLens = lens dataStreamLifecyclesGlobalRetention (\x y -> x {dataStreamLifecyclesGlobalRetention = y}) + +-- $modifyDataStream +-- +-- /Modify data stream/ (ES 7.16+) changes the backing indices of one or +-- more data streams in a single batched request. The wire format is +-- identical across ES 7.x, 8.x and 9.x, so the request builder lives +-- in "Database.Bloodhound.ElasticSearch7.Requests" and is re-exported +-- by the ES8 and ES9 client modules. + +-- | One action inside a 'ModifyDataStreamRequest'. Each action +-- references a single ('DataStreamName', 'IndexName') pair: either +-- adding an existing index as a backing index for the named stream, or +-- removing a backing index from it. +-- +-- Per the ES docs, adding indices with @add_backing_index@ can +-- potentially result in improper data stream behavior; this is +-- considered an expert-level API. +data ModifyDataStreamAction + = AddBackingIndex DataStreamName IndexName + | RemoveBackingIndex DataStreamName IndexName + deriving stock (Eq, Show, Generic) + +instance FromJSON ModifyDataStreamAction where + parseJSON = withObject "ModifyDataStreamAction" $ \o -> do + mAdd <- o .:? "add_backing_index" + mRem <- o .:? "remove_backing_index" + case (mAdd, mRem) of + (Just _, Just _) -> + fail + "Invalid ModifyDataStreamAction: 'add_backing_index' and 'remove_backing_index' are mutually exclusive" + (Just innerVal, Nothing) -> inner AddBackingIndex innerVal + (Nothing, Just innerVal) -> inner RemoveBackingIndex innerVal + (Nothing, Nothing) -> + fail + "Invalid ModifyDataStreamAction (expected exactly one of 'add_backing_index' or 'remove_backing_index')" + where + inner ctor = withObject "ModifyDataStreamAction target" $ \t -> + ctor <$> t .: "data_stream" <*> t .: "index" + +instance ToJSON ModifyDataStreamAction where + toJSON (AddBackingIndex dsName ixName) = + object + [ "add_backing_index" + .= object ["data_stream" .= dsName, "index" .= ixName] + ] + toJSON (RemoveBackingIndex dsName ixName) = + object + [ "remove_backing_index" + .= object ["data_stream" .= dsName, "index" .= ixName] + ] + +-- | Request body for @POST /_data_stream/_modify@ (see +-- 'Database.Bloodhound.ElasticSearch7.Client.modifyDataStream'). Wraps +-- a list of 'ModifyDataStreamAction's. ES evaluates the actions +-- atomically and in order; an empty list is rejected by the server +-- (surfaced as an 'EsError' via 'StatusDependant'). +newtype ModifyDataStreamRequest = ModifyDataStreamRequest + { modifyDataStreamActions :: [ModifyDataStreamAction] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ModifyDataStreamRequest where + parseJSON = withObject "ModifyDataStreamRequest" $ \o -> + ModifyDataStreamRequest <$> o .: "actions" + +instance ToJSON ModifyDataStreamRequest where + toJSON (ModifyDataStreamRequest actions) = + object ["actions" .= actions] + +modifyDataStreamActionsLens :: Lens' ModifyDataStreamRequest [ModifyDataStreamAction] +modifyDataStreamActionsLens = lens modifyDataStreamActions (\x y -> x {modifyDataStreamActions = y}) + +putDataStreamsLifecycleRequestStreamsLens :: Lens' PutDataStreamsLifecycleRequest [DataStreamLifecycleInfo] +putDataStreamsLifecycleRequestStreamsLens = lens putDataStreamsLifecycleRequestStreams (\x y -> x {putDataStreamsLifecycleRequestStreams = y}) + +-- $dataStreamOptions +-- +-- /Data Stream Options/ (ES 8.19+, also in ES 9.x) expose per-stream +-- feature toggles that live outside the lifecycle and ILM machinery. +-- The only documented option today is the @failure_store@, but the +-- wire shape is open-ended (@options@ is an arbitrary object), so the +-- 'DataStreamOptions' wrapper is structured to admit further fields +-- later without breaking the public API. +-- +-- The wire format is identical across ES 8.19+ and 9.x, so the +-- request builders live in +-- "Database.Bloodhound.ElasticSearch7.Requests" (the shared +-- version-agnostic home) and are re-exported by the ES8 and ES9 +-- client modules. Note: the endpoints do NOT exist in ES 7.x; the +-- shared placement follows the project's \"one wire format, one +-- builder\" convention rather than the actual server availability. + +-- | Lifecycle configuration for the failure store of a data stream. +-- This is a strict subset of 'DataStreamLifecycle' (no downsampling, +-- no read-only fields) — the failure store lifecycle only honours the +-- @data_retention@ and @enabled@ keys. +data DataStreamFailureStoreLifecycle = DataStreamFailureStoreLifecycle + { dataStreamFailureStoreLifecycleDataRetention :: Maybe Text, + dataStreamFailureStoreLifecycleEnabled :: Maybe Bool + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamFailureStoreLifecycle where + parseJSON = withObject "DataStreamFailureStoreLifecycle" $ \o -> + DataStreamFailureStoreLifecycle + <$> o .:? "data_retention" + <*> o .:? "enabled" + +instance ToJSON DataStreamFailureStoreLifecycle where + toJSON DataStreamFailureStoreLifecycle {..} = + omitNulls + [ "data_retention" .= dataStreamFailureStoreLifecycleDataRetention, + "enabled" .= dataStreamFailureStoreLifecycleEnabled + ] + +-- | Configuration for the failure store of a data stream. Used both as +-- the interior of 'UpdateDataStreamOptionsRequest' (PUT) and as the +-- @options.failure_store@ field of a 'DataStreamOptions' (GET). All +-- fields are optional: an empty 'DataStreamFailureStore' is a valid +-- PUT body that simply clears any explicit @enabled@ override (per ES +-- docs, @enabled@ defaults to @true@ when set). +data DataStreamFailureStore = DataStreamFailureStore + { dataStreamFailureStoreEnabled :: Maybe Bool, + dataStreamFailureStoreLifecycle :: Maybe DataStreamFailureStoreLifecycle + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamFailureStore where + parseJSON = withObject "DataStreamFailureStore" $ \o -> + DataStreamFailureStore + <$> o .:? "enabled" + <*> o .:? "lifecycle" + +instance ToJSON DataStreamFailureStore where + toJSON DataStreamFailureStore {..} = + omitNulls + [ "enabled" .= dataStreamFailureStoreEnabled, + "lifecycle" .= dataStreamFailureStoreLifecycle + ] + +-- | Request body for @PUT /_data_stream\/{name}/_options@ (see +-- 'Database.Bloodhound.ElasticSearch7.Client.updateDataStreamOptions'). +-- Carries at most one 'DataStreamFailureStore'; the @failure_store@ +-- key is omitted from the encoded body when the value is 'Nothing'. +-- +-- The wire format of the wrapped 'DataStreamFailureStore' is +-- intentionally identical to that of the @failure_store@ field inside +-- a 'DataStreamOptions' (GET response side); the two newtypes are +-- kept distinct so the PUT-request and GET-response shapes can +-- diverge in future without breaking the public API. +-- +-- The ES docs mark the PUT body as Required but do not specify the +-- server's reaction to an empty body (@{ }@, no @failure_store@ +-- key); callers should prefer sending an explicit +-- 'DataStreamFailureStore'. +newtype UpdateDataStreamOptionsRequest = UpdateDataStreamOptionsRequest + { updateDataStreamOptionsRequestFailureStore :: Maybe DataStreamFailureStore + } + deriving stock (Eq, Show, Generic) + +instance FromJSON UpdateDataStreamOptionsRequest where + parseJSON = withObject "UpdateDataStreamOptionsRequest" $ \o -> + UpdateDataStreamOptionsRequest <$> o .:? "failure_store" + +instance ToJSON UpdateDataStreamOptionsRequest where + toJSON (UpdateDataStreamOptionsRequest mFailureStore) = + omitNulls ["failure_store" .= mFailureStore] + +-- | Per-stream options returned inside the @data_streams@ array of a +-- 'GetDataStreamOptionsResponse' from +-- @GET /_data_stream\/{name}/_options@. The @failure_store@ field is +-- the only documented option today; it is decoded as 'Nothing' when +-- the stream has no options set (ES omits the key entirely for +-- unoptioned streams). +-- +-- The @options@ object is open-ended on the server side; this type +-- silently ignores unknown keys (via 'aeson''s default +-- 'withObject' behaviour) so that future ES options decode without +-- breaking clients. The wire format of the wrapped +-- 'DataStreamFailureStore' is intentionally identical to that inside +-- an 'UpdateDataStreamOptionsRequest' (PUT request side); the two +-- newtypes are kept distinct so the GET-response and PUT-request +-- shapes can diverge in future without breaking the public API. +newtype DataStreamOptions = DataStreamOptions + { dataStreamOptionsFailureStore :: Maybe DataStreamFailureStore + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamOptions where + parseJSON = withObject "DataStreamOptions" $ \o -> + DataStreamOptions <$> o .:? "failure_store" + +instance ToJSON DataStreamOptions where + toJSON (DataStreamOptions mFailureStore) = + omitNulls ["failure_store" .= mFailureStore] + +-- | One entry inside the @data_streams@ array of a +-- 'GetDataStreamOptionsResponse'. The per-stream name is read from +-- the @name@ JSON key. The @options@ field is 'Nothing' when the +-- stream has no options set: ES omits the @options@ key entirely for +-- unoptioned streams; we additionally tolerate an explicit @null@ for +-- robustness (both decode to 'Nothing'). +data DataStreamOptionsEntry = DataStreamOptionsEntry + { dataStreamOptionsEntryName :: DataStreamName, + dataStreamOptionsEntryOptions :: Maybe DataStreamOptions + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamOptionsEntry where + parseJSON = withObject "DataStreamOptionsEntry" $ \o -> + DataStreamOptionsEntry + <$> (DataStreamName <$> o .: "name") + <*> o .:? "options" + +instance ToJSON DataStreamOptionsEntry where + toJSON DataStreamOptionsEntry {..} = + omitNulls + [ "name" .= dataStreamOptionsEntryName, + "options" .= dataStreamOptionsEntryOptions + ] + +-- | Top-level response of @GET /_data_stream\/{name}/_options@. +-- Carries a flat list of 'DataStreamOptionsEntry' values in the +-- @data_streams@ array. An entry with @options = Nothing@ indicates +-- the corresponding stream has no options set. +newtype GetDataStreamOptionsResponse = GetDataStreamOptionsResponse + { getDataStreamOptionsResponseDataStreams :: [DataStreamOptionsEntry] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON GetDataStreamOptionsResponse where + parseJSON = withObject "GetDataStreamOptionsResponse" $ \o -> + GetDataStreamOptionsResponse <$> o .: "data_streams" + +instance ToJSON GetDataStreamOptionsResponse where + toJSON (GetDataStreamOptionsResponse entries) = + object ["data_streams" .= entries] + +-- Data Stream Options lenses + +dataStreamFailureStoreLifecycleDataRetentionLens :: Lens' DataStreamFailureStoreLifecycle (Maybe Text) +dataStreamFailureStoreLifecycleDataRetentionLens = lens dataStreamFailureStoreLifecycleDataRetention (\x y -> x {dataStreamFailureStoreLifecycleDataRetention = y}) + +dataStreamFailureStoreLifecycleEnabledLens :: Lens' DataStreamFailureStoreLifecycle (Maybe Bool) +dataStreamFailureStoreLifecycleEnabledLens = lens dataStreamFailureStoreLifecycleEnabled (\x y -> x {dataStreamFailureStoreLifecycleEnabled = y}) + +dataStreamFailureStoreEnabledLens :: Lens' DataStreamFailureStore (Maybe Bool) +dataStreamFailureStoreEnabledLens = lens dataStreamFailureStoreEnabled (\x y -> x {dataStreamFailureStoreEnabled = y}) + +dataStreamFailureStoreLifecycleLens :: Lens' DataStreamFailureStore (Maybe DataStreamFailureStoreLifecycle) +dataStreamFailureStoreLifecycleLens = lens dataStreamFailureStoreLifecycle (\x y -> x {dataStreamFailureStoreLifecycle = y}) + +updateDataStreamOptionsRequestFailureStoreLens :: Lens' UpdateDataStreamOptionsRequest (Maybe DataStreamFailureStore) +updateDataStreamOptionsRequestFailureStoreLens = lens updateDataStreamOptionsRequestFailureStore (\x y -> x {updateDataStreamOptionsRequestFailureStore = y}) + +dataStreamOptionsFailureStoreLens :: Lens' DataStreamOptions (Maybe DataStreamFailureStore) +dataStreamOptionsFailureStoreLens = lens dataStreamOptionsFailureStore (\x y -> x {dataStreamOptionsFailureStore = y}) + +dataStreamOptionsEntryNameLens :: Lens' DataStreamOptionsEntry DataStreamName +dataStreamOptionsEntryNameLens = lens dataStreamOptionsEntryName (\x y -> x {dataStreamOptionsEntryName = y}) + +dataStreamOptionsEntryOptionsLens :: Lens' DataStreamOptionsEntry (Maybe DataStreamOptions) +dataStreamOptionsEntryOptionsLens = lens dataStreamOptionsEntryOptions (\x y -> x {dataStreamOptionsEntryOptions = y}) + +getDataStreamOptionsResponseDataStreamsLens :: Lens' GetDataStreamOptionsResponse [DataStreamOptionsEntry] +getDataStreamOptionsResponseDataStreamsLens = lens getDataStreamOptionsResponseDataStreams (\x y -> x {getDataStreamOptionsResponseDataStreams = y}) + +-- $dataStreamLifecycleStats +-- +-- /Data Stream Lifecycle Stats/ (ES 8.12+, also in ES 9.x) returns +-- runtime statistics about the data stream lifecycle service across +-- the cluster. The endpoint is @GET /_lifecycle/stats@ — note that +-- the path lives at the index level (no @_data_stream@ segment), +-- because the lifecycle service manages the backing indices rather +-- than the streams directly. +-- +-- The wire format is identical across ES 8.x and 9.x, so the request +-- builder lives in "Database.Bloodhound.ElasticSearch8.Requests" and +-- is re-exported by the ES9 client module. + +-- | Per-stream entry inside the @data_streams@ array of a +-- 'DataStreamLifecycleStats' response from @GET /_lifecycle/stats@. +-- The @backing_indices_in_total@ \/ @backing_indices_in_error@ pair +-- summarises the health of the stream's backing indices at query +-- time. +data DataStreamLifecycleStatsEntry = DataStreamLifecycleStatsEntry + { dataStreamLifecycleStatsEntryName :: DataStreamName, + dataStreamLifecycleStatsEntryBackingIndicesInTotal :: Int, + dataStreamLifecycleStatsEntryBackingIndicesInError :: Int + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamLifecycleStatsEntry where + parseJSON = withObject "DataStreamLifecycleStatsEntry" $ \o -> + DataStreamLifecycleStatsEntry + <$> (DataStreamName <$> o .: "name") + <*> o .: "backing_indices_in_total" + <*> o .: "backing_indices_in_error" + +instance ToJSON DataStreamLifecycleStatsEntry where + toJSON DataStreamLifecycleStatsEntry {..} = + object + [ "name" .= dataStreamLifecycleStatsEntryName, + "backing_indices_in_total" .= dataStreamLifecycleStatsEntryBackingIndicesInTotal, + "backing_indices_in_error" .= dataStreamLifecycleStatsEntryBackingIndicesInError + ] + +-- | Top-level response of @GET /_lifecycle/stats@. Carries aggregate +-- timing information about the lifecycle service's run loop plus a +-- per-stream breakdown of backing-index health in @data_streams@. +-- +-- /Field-name note/: the ES OpenAPI schema lists the stream-count +-- field as @data_stream_count@ (singular), but the documented JSON +-- example and observed server responses emit @data_streams_count@ +-- (plural). We accept either key on decode to tolerate both; on +-- encode we emit the plural form, matching the documented example. +-- +-- The human-readable @last_run_duration@ and @time_between_starts@ +-- strings are only emitted by ES when the request carries +-- @human=true@; they are decoded as 'Nothing' otherwise (the +-- @..._in_millis@ numeric variants are always present on a populated +-- response, but are decoded leniently as 'Maybe' to tolerate the +-- empty-cluster response shape). +data DataStreamLifecycleStats = DataStreamLifecycleStats + { dataStreamLifecycleStatsLastRunDurationInMillis :: Maybe Int64, + dataStreamLifecycleStatsLastRunDuration :: Maybe Text, + dataStreamLifecycleStatsTimeBetweenStartsInMillis :: Maybe Int64, + dataStreamLifecycleStatsTimeBetweenStarts :: Maybe Text, + dataStreamLifecycleStatsCount :: Int, + dataStreamLifecycleStatsDataStreams :: [DataStreamLifecycleStatsEntry] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON DataStreamLifecycleStats where + parseJSON = withObject "DataStreamLifecycleStats" $ \o -> do + mSingular <- o .:? "data_stream_count" + mPlural <- o .:? "data_streams_count" + count <- case (mSingular, mPlural) of + (Just c, _) -> pure c + (_, Just c) -> pure c + (Nothing, Nothing) -> fail "Missing key \"data_streams_count\" (or \"data_stream_count\")" + DataStreamLifecycleStats + <$> o .:? "last_run_duration_in_millis" + <*> o .:? "last_run_duration" + <*> o .:? "time_between_starts_in_millis" + <*> o .:? "time_between_starts" + <*> pure count + <*> o .:? "data_streams" .!= [] + +instance ToJSON DataStreamLifecycleStats where + toJSON DataStreamLifecycleStats {..} = + omitNulls + [ "last_run_duration_in_millis" .= dataStreamLifecycleStatsLastRunDurationInMillis, + "last_run_duration" .= dataStreamLifecycleStatsLastRunDuration, + "time_between_starts_in_millis" .= dataStreamLifecycleStatsTimeBetweenStartsInMillis, + "time_between_starts" .= dataStreamLifecycleStatsTimeBetweenStarts, + "data_streams_count" .= dataStreamLifecycleStatsCount, + "data_streams" .= dataStreamLifecycleStatsDataStreams + ] + +-- $explainDataStreamLifecycle +-- +-- /Explain Data Stream Lifecycle/ (ES 8.11+, also in ES 9.x) returns +-- the per-index lifecycle status for one or more backing indices. The +-- endpoint is @GET /{index}/_lifecycle/explain@ — note that the path +-- parameter is an @index@ (typically a backing index of the form +-- @.ds---@), not a data-stream name; the +-- @index@ path parameter accepts a comma-separated list, matching the +-- rest of the indices API. +-- +-- The wire format is identical across ES 8.x and 9.x, so the request +-- builder lives in "Database.Bloodhound.ElasticSearch8.Requests" and +-- is re-exported by the ES9 client module. + +-- | Per-index entry inside the @indices@ map of an +-- 'ExplainDataStreamLifecycleResponse' from +-- @GET /{index}/_lifecycle/explain@. +-- +-- The @error@ field is 'Nothing' on success; on lifecycle execution +-- errors ES emits it as a string (often itself a JSON object +-- stringified), so callers needing structured access must decode it +-- themselves. Almost all timing fields are optional and are +-- mutually-absent when the index is not lifecycle-managed. +data ExplainDataStreamLifecycleIndex = ExplainDataStreamLifecycleIndex + { explainDataStreamLifecycleIndexIndex :: IndexName, + explainDataStreamLifecycleIndexManagedByLifecycle :: Bool, + explainDataStreamLifecycleIndexCreationDateMillis :: Maybe Int64, + explainDataStreamLifecycleIndexTimeSinceIndexCreation :: Maybe Text, + explainDataStreamLifecycleIndexRolloverDateMillis :: Maybe Int64, + explainDataStreamLifecycleIndexTimeSinceRollover :: Maybe Text, + explainDataStreamLifecycleIndexLifecycle :: Maybe DataStreamLifecycle, + explainDataStreamLifecycleIndexGenerationTime :: Maybe Text, + explainDataStreamLifecycleIndexError :: Maybe Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ExplainDataStreamLifecycleIndex where + parseJSON = withObject "ExplainDataStreamLifecycleIndex" $ \o -> + ExplainDataStreamLifecycleIndex + <$> o .: "index" + <*> o .: "managed_by_lifecycle" + <*> o .:? "index_creation_date_millis" + <*> o .:? "time_since_index_creation" + <*> o .:? "rollover_date_millis" + <*> o .:? "time_since_rollover" + <*> o .:? "lifecycle" + <*> o .:? "generation_time" + <*> o .:? "error" + +instance ToJSON ExplainDataStreamLifecycleIndex where + toJSON ExplainDataStreamLifecycleIndex {..} = + omitNulls + [ "index" .= explainDataStreamLifecycleIndexIndex, + "managed_by_lifecycle" .= explainDataStreamLifecycleIndexManagedByLifecycle, + "index_creation_date_millis" .= explainDataStreamLifecycleIndexCreationDateMillis, + "time_since_index_creation" .= explainDataStreamLifecycleIndexTimeSinceIndexCreation, + "rollover_date_millis" .= explainDataStreamLifecycleIndexRolloverDateMillis, + "time_since_rollover" .= explainDataStreamLifecycleIndexTimeSinceRollover, + "lifecycle" .= explainDataStreamLifecycleIndexLifecycle, + "generation_time" .= explainDataStreamLifecycleIndexGenerationTime, + "error" .= explainDataStreamLifecycleIndexError + ] + +-- | Top-level response of @GET /{index}/_lifecycle/explain@. The +-- @indices@ field is a 'Map' keyed by index name (the same name as +-- the entry's @index@ field). Map keys are decoded via the +-- 'FromJSONKey' instance on 'IndexName' and are therefore /not/ +-- subject to the value-level 'mkIndexNameSystem' validation that +-- 'IndexName'\'s 'FromJSON' performs — the server may legitimately +-- echo back indices whose names the client would refuse to create. +-- An entry with @managed_by_lifecycle = False@ indicates the +-- corresponding backing index is not under DSL management. +newtype ExplainDataStreamLifecycleResponse = ExplainDataStreamLifecycleResponse + { explainDataStreamLifecycleResponseIndices :: M.Map IndexName ExplainDataStreamLifecycleIndex + } + deriving stock (Eq, Show, Generic) + +instance FromJSON ExplainDataStreamLifecycleResponse where + parseJSON = withObject "ExplainDataStreamLifecycleResponse" $ \o -> + ExplainDataStreamLifecycleResponse <$> o .: "indices" + +instance ToJSON ExplainDataStreamLifecycleResponse where + toJSON (ExplainDataStreamLifecycleResponse indices) = + object ["indices" .= indices] + +-- | URI query parameters accepted by +-- @GET /{index}/_lifecycle/explain@. Each field maps 1:1 to a +-- query-string parameter documented at +-- . +data ExplainDataStreamLifecycleOptions = ExplainDataStreamLifecycleOptions + { -- | @include_defaults@ — when @'Just' 'True'@, return default + -- lifecycle values for entries that have no explicit configuration. + explainDataStreamLifecycleOptionsIncludeDefaults :: Maybe Bool, + -- | @master_timeout@ — time to wait for the master node to respond + -- (e.g. @\"30s\"@, @\"1m\"@). 'Nothing' uses the server default. + explainDataStreamLifecycleOptionsMasterTimeout :: Maybe Text + } + +-- | 'ExplainDataStreamLifecycleOptions' with every parameter set to +-- 'Nothing'. Produces no query string, so a call made with this value +-- is byte-identical to a parameterless call. +defaultExplainDataStreamLifecycleOptions :: ExplainDataStreamLifecycleOptions +defaultExplainDataStreamLifecycleOptions = + ExplainDataStreamLifecycleOptions + { explainDataStreamLifecycleOptionsIncludeDefaults = Nothing, + explainDataStreamLifecycleOptionsMasterTimeout = Nothing + } + +-- | URI query parameters accepted by +-- @GET /_data_stream\/{name}/_mappings@ (ES 9.1+). +data GetDataStreamMappingsOptions = GetDataStreamMappingsOptions + { -- | @master_timeout@ — time to wait for the master node to respond. + getDataStreamMappingsOptionsMasterTimeout :: Maybe Text + } + +-- | 'GetDataStreamMappingsOptions' with every parameter set to +-- 'Nothing'. Produces no query string. +defaultGetDataStreamMappingsOptions :: GetDataStreamMappingsOptions +defaultGetDataStreamMappingsOptions = + GetDataStreamMappingsOptions + { getDataStreamMappingsOptionsMasterTimeout = Nothing + } + +-- | URI query parameters accepted by +-- @PUT /_data_stream\/{name}/_mappings@ (ES 9.2+). +data UpdateDataStreamMappingsOptions = UpdateDataStreamMappingsOptions + { -- | @dry_run@ — when @'Just' 'True'@, simulate the update without + -- applying it. The response carries the @mappings@\/@effective_mappings@ + -- that /would/ result from the change. + updateDataStreamMappingsOptionsDryRun :: Maybe Bool, + -- | @master_timeout@ — time to wait for the master node to respond. + updateDataStreamMappingsOptionsMasterTimeout :: Maybe Text, + -- | @timeout@ — time to wait for the update to take effect on each + -- backing index. + updateDataStreamMappingsOptionsTimeout :: Maybe Text + } + +-- | 'UpdateDataStreamMappingsOptions' with every parameter set to +-- 'Nothing'. Produces no query string. +defaultUpdateDataStreamMappingsOptions :: UpdateDataStreamMappingsOptions +defaultUpdateDataStreamMappingsOptions = + UpdateDataStreamMappingsOptions + { updateDataStreamMappingsOptionsDryRun = Nothing, + updateDataStreamMappingsOptionsMasterTimeout = Nothing, + updateDataStreamMappingsOptionsTimeout = Nothing + } + +-- | URI query parameters accepted by +-- @GET /_data_stream\/{name}/_settings@ (ES 9.1+). +data GetDataStreamSettingsOptions = GetDataStreamSettingsOptions + { -- | @master_timeout@ — time to wait for the master node to respond. + getDataStreamSettingsOptionsMasterTimeout :: Maybe Text + } + +-- | 'GetDataStreamSettingsOptions' with every parameter set to +-- 'Nothing'. Produces no query string. +defaultGetDataStreamSettingsOptions :: GetDataStreamSettingsOptions +defaultGetDataStreamSettingsOptions = + GetDataStreamSettingsOptions + { getDataStreamSettingsOptionsMasterTimeout = Nothing + } + +-- | URI query parameters accepted by +-- @PUT /_data_stream\/{name}/_settings@ (ES 9.1+, also documented as +-- available in 8.19). +data UpdateDataStreamSettingsOptions = UpdateDataStreamSettingsOptions + { -- | @dry_run@ — when @'Just' 'True'@, simulate the update without + -- applying it. + updateDataStreamSettingsOptionsDryRun :: Maybe Bool, + -- | @master_timeout@ — time to wait for the master node to respond. + updateDataStreamSettingsOptionsMasterTimeout :: Maybe Text, + -- | @timeout@ — time to wait for the update to take effect on each + -- backing index. + updateDataStreamSettingsOptionsTimeout :: Maybe Text + } + +-- | 'UpdateDataStreamSettingsOptions' with every parameter set to +-- 'Nothing'. Produces no query string. +defaultUpdateDataStreamSettingsOptions :: UpdateDataStreamSettingsOptions +defaultUpdateDataStreamSettingsOptions = + UpdateDataStreamSettingsOptions + { updateDataStreamSettingsOptionsDryRun = Nothing, + updateDataStreamSettingsOptionsMasterTimeout = Nothing, + updateDataStreamSettingsOptionsTimeout = Nothing + } + +-- $dataStreamMappings +-- +-- /Data Stream Mappings/ (ES 9.1+ for GET, 9.2+ for PUT) expose and +-- override the mapping configuration that lives at the data-stream +-- level rather than on the backing indices or the index template. +-- The wire format is specific to ES 9.x, so the request builders +-- live in "Database.Bloodhound.ElasticSearch9.Requests". Note that +-- ES uses the plural @_mappings@ path segment for both endpoints +-- (not the singular @_mapping@ used by the indices API), matching +-- the documented operation paths +-- (operation-indices-get-data-stream-mappings, +-- operation-indices-put-data-stream-mappings). +-- +-- The @mappings@ and @effective_mappings@ objects are kept opaque as +-- 'Value' because the ES mapping object is schema-unstable across +-- releases; callers needing structured access should decode 'Value' +-- into their own type. The PUT request body is similarly polymorphic +-- (see 'Database.Bloodhound.ElasticSearch9.Requests.putDataStreamMappings'). + +-- | Per-stream entry in a 'GetDataStreamMappingsResponse'. The +-- @mappings@ object is the user-provided mapping override for the +-- stream; @effective_mappings@ is the merge of @mappings@ with the +-- template's mappings (what will be applied on the next rollover). +data GetDataStreamMappingsEntry = GetDataStreamMappingsEntry + { getDataStreamMappingsEntryName :: DataStreamName, + getDataStreamMappingsEntryMappings :: Value, + getDataStreamMappingsEntryEffectiveMappings :: Value + } + deriving stock (Eq, Show, Generic) + +instance FromJSON GetDataStreamMappingsEntry where + parseJSON = withObject "GetDataStreamMappingsEntry" $ \o -> + GetDataStreamMappingsEntry + <$> (DataStreamName <$> o .: "name") + <*> o .: "mappings" + <*> o .: "effective_mappings" + +instance ToJSON GetDataStreamMappingsEntry where + toJSON GetDataStreamMappingsEntry {..} = + object + [ "name" .= getDataStreamMappingsEntryName, + "mappings" .= getDataStreamMappingsEntryMappings, + "effective_mappings" .= getDataStreamMappingsEntryEffectiveMappings + ] + +-- | Top-level response of @GET /_data_stream\/{name}/_mappings@. +-- Carries a flat list of 'GetDataStreamMappingsEntry' values in the +-- @data_streams@ array. +newtype GetDataStreamMappingsResponse = GetDataStreamMappingsResponse + { getDataStreamMappingsResponseDataStreams :: [GetDataStreamMappingsEntry] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON GetDataStreamMappingsResponse where + parseJSON = withObject "GetDataStreamMappingsResponse" $ \o -> + GetDataStreamMappingsResponse <$> o .: "data_streams" + +instance ToJSON GetDataStreamMappingsResponse where + toJSON (GetDataStreamMappingsResponse streams) = + object ["data_streams" .= streams] + +-- | Per-stream entry in an 'UpdateDataStreamMappingsResponse'. The +-- @applied_to_data_stream@ flag is the success signal: ES returns +-- HTTP 200 regardless, surfacing per-stream failures via +-- @applied_to_data_stream = False@ plus a populated @error@ string +-- (rather than via an HTTP error status). The @mappings@ and +-- @effective_mappings@ objects are present even on failure (possibly +-- as empty objects), mirroring 'GetDataStreamMappingsEntry'. +data UpdateDataStreamMappingsEntry = UpdateDataStreamMappingsEntry + { updateDataStreamMappingsEntryName :: DataStreamName, + updateDataStreamMappingsEntryAppliedToDataStream :: Bool, + updateDataStreamMappingsEntryError :: Maybe Text, + updateDataStreamMappingsEntryMappings :: Value, + updateDataStreamMappingsEntryEffectiveMappings :: Value + } + deriving stock (Eq, Show, Generic) + +instance FromJSON UpdateDataStreamMappingsEntry where + parseJSON = withObject "UpdateDataStreamMappingsEntry" $ \o -> + UpdateDataStreamMappingsEntry + <$> (DataStreamName <$> o .: "name") + <*> o .: "applied_to_data_stream" + <*> o .:? "error" + <*> o .:? "mappings" .!= Object mempty + <*> o .:? "effective_mappings" .!= Object mempty + +instance ToJSON UpdateDataStreamMappingsEntry where + toJSON UpdateDataStreamMappingsEntry {..} = + omitNulls + [ "name" .= updateDataStreamMappingsEntryName, + "applied_to_data_stream" .= updateDataStreamMappingsEntryAppliedToDataStream, + "error" .= updateDataStreamMappingsEntryError, + "mappings" .= updateDataStreamMappingsEntryMappings, + "effective_mappings" .= updateDataStreamMappingsEntryEffectiveMappings + ] + +-- | Top-level response of @PUT /_data_stream\/{name}/_mappings@. +newtype UpdateDataStreamMappingsResponse = UpdateDataStreamMappingsResponse + { updateDataStreamMappingsResponseDataStreams :: [UpdateDataStreamMappingsEntry] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON UpdateDataStreamMappingsResponse where + parseJSON = withObject "UpdateDataStreamMappingsResponse" $ \o -> + UpdateDataStreamMappingsResponse <$> o .: "data_streams" + +instance ToJSON UpdateDataStreamMappingsResponse where + toJSON (UpdateDataStreamMappingsResponse streams) = + object ["data_streams" .= streams] + +-- $dataStreamSettings +-- +-- /Data Stream Settings/ (ES 9.1+ for GET, 9.1+ for PUT; PUT also +-- documented as available in 8.19) expose and override the +-- index-settings configuration that lives at the data-stream level +-- rather than on the backing indices or the index template. The +-- wire format is specific to ES 9.x, so the request builders live +-- in "Database.Bloodhound.ElasticSearch9.Requests". +-- +-- Like the mappings endpoints, the @settings@ and +-- @effective_settings@ objects are kept opaque as 'Value'. The PUT +-- request body is polymorphic. +-- +-- /Numeric-as-string/: ES returns numeric settings values (e.g. +-- @number_of_shards@) as JSON strings inside the @settings@ object. +-- 'Value' preserves these verbatim without coercion; callers should +-- decode with that in mind. + +-- | Per-stream entry in a 'GetDataStreamSettingsResponse'. The +-- @settings@ object is the user-provided settings override for the +-- stream; @effective_settings@ is the merge of @settings@ with the +-- template's settings (what will be applied on the next rollover). +data GetDataStreamSettingsEntry = GetDataStreamSettingsEntry + { getDataStreamSettingsEntryName :: DataStreamName, + getDataStreamSettingsEntrySettings :: Value, + getDataStreamSettingsEntryEffectiveSettings :: Value + } + deriving stock (Eq, Show, Generic) + +instance FromJSON GetDataStreamSettingsEntry where + parseJSON = withObject "GetDataStreamSettingsEntry" $ \o -> + GetDataStreamSettingsEntry + <$> (DataStreamName <$> o .: "name") + <*> o .: "settings" + <*> o .: "effective_settings" + +instance ToJSON GetDataStreamSettingsEntry where + toJSON GetDataStreamSettingsEntry {..} = + object + [ "name" .= getDataStreamSettingsEntryName, + "settings" .= getDataStreamSettingsEntrySettings, + "effective_settings" .= getDataStreamSettingsEntryEffectiveSettings + ] + +-- | Top-level response of @GET /_data_stream\/{name}/_settings@. +newtype GetDataStreamSettingsResponse = GetDataStreamSettingsResponse + { getDataStreamSettingsResponseDataStreams :: [GetDataStreamSettingsEntry] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON GetDataStreamSettingsResponse where + parseJSON = withObject "GetDataStreamSettingsResponse" $ \o -> + GetDataStreamSettingsResponse <$> o .: "data_streams" + +instance ToJSON GetDataStreamSettingsResponse where + toJSON (GetDataStreamSettingsResponse streams) = + object ["data_streams" .= streams] + +-- | Per-setting application breakdown returned inside an +-- 'UpdateDataStreamSettingsEntry'. The two lists classify the +-- requested settings by where they were actually applied: live +-- settings (e.g. @index.number_of_replicas@) are applied to both +-- the data stream and its backing indices immediately +-- ('appliedToDataStreamAndBackingIndices'); rollover-only settings +-- (e.g. @index.number_of_shards@) are applied to the stream and +-- take effect on the next rollover +-- ('appliedToDataStreamOnly'). Per-index errors, when present, are +-- reported in 'indexSettingsResultsErrors'. +data IndexSettingsResults = IndexSettingsResults + { indexSettingsResultsAppliedToDataStreamOnly :: [Text], + indexSettingsResultsAppliedToDataStreamAndBackingIndices :: [Text], + indexSettingsResultsErrors :: [IndexSettingError] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON IndexSettingsResults where + parseJSON = withObject "IndexSettingsResults" $ \o -> + IndexSettingsResults + <$> o .:? "applied_to_data_stream_only" .!= [] + <*> o .:? "applied_to_data_stream_and_backing_indices" .!= [] + <*> o .:? "errors" .!= [] + +instance ToJSON IndexSettingsResults where + toJSON IndexSettingsResults {..} = + omitNulls + [ "applied_to_data_stream_only" .= indexSettingsResultsAppliedToDataStreamOnly, + "applied_to_data_stream_and_backing_indices" .= indexSettingsResultsAppliedToDataStreamAndBackingIndices, + "errors" .= indexSettingsResultsErrors + ] + +-- | Per-index error inside 'indexSettingsResultsErrors'. The @index@ +-- field names the backing index that rejected the setting; @error@ +-- is the server-supplied error string. +data IndexSettingError = IndexSettingError + { indexSettingErrorIndex :: Text, + indexSettingErrorError :: Text + } + deriving stock (Eq, Show, Generic) + +instance FromJSON IndexSettingError where + parseJSON = withObject "IndexSettingError" $ \o -> + IndexSettingError + <$> o .: "index" + <*> o .: "error" + +instance ToJSON IndexSettingError where + toJSON IndexSettingError {..} = + object + [ "index" .= indexSettingErrorIndex, + "error" .= indexSettingErrorError + ] + +-- | Per-stream entry in an 'UpdateDataStreamSettingsResponse'. Mirrors +-- 'GetDataStreamSettingsEntry' but adds the success signal +-- @applied_to_data_stream@ (ES returns HTTP 200 regardless, +-- surfacing per-stream failures via @applied_to_data_stream = False@ +-- plus a populated @error@), the optional top-level @error@ string +-- for whole-stream rejection, and the per-setting application +-- breakdown in 'updateDataStreamSettingsEntryIndexSettingsResults'. +data UpdateDataStreamSettingsEntry = UpdateDataStreamSettingsEntry + { updateDataStreamSettingsEntryName :: DataStreamName, + updateDataStreamSettingsEntryAppliedToDataStream :: Bool, + updateDataStreamSettingsEntryError :: Maybe Text, + updateDataStreamSettingsEntrySettings :: Value, + updateDataStreamSettingsEntryEffectiveSettings :: Value, + updateDataStreamSettingsEntryIndexSettingsResults :: Maybe IndexSettingsResults + } + deriving stock (Eq, Show, Generic) + +instance FromJSON UpdateDataStreamSettingsEntry where + parseJSON = withObject "UpdateDataStreamSettingsEntry" $ \o -> + UpdateDataStreamSettingsEntry + <$> (DataStreamName <$> o .: "name") + <*> o .: "applied_to_data_stream" + <*> o .:? "error" + <*> o .:? "settings" .!= Object mempty + <*> o .:? "effective_settings" .!= Object mempty + <*> o .:? "index_settings_results" + +instance ToJSON UpdateDataStreamSettingsEntry where + toJSON UpdateDataStreamSettingsEntry {..} = + omitNulls + [ "name" .= updateDataStreamSettingsEntryName, + "applied_to_data_stream" .= updateDataStreamSettingsEntryAppliedToDataStream, + "error" .= updateDataStreamSettingsEntryError, + "settings" .= updateDataStreamSettingsEntrySettings, + "effective_settings" .= updateDataStreamSettingsEntryEffectiveSettings, + "index_settings_results" .= updateDataStreamSettingsEntryIndexSettingsResults + ] + +-- | Top-level response of @PUT /_data_stream\/{name}/_settings@. +newtype UpdateDataStreamSettingsResponse = UpdateDataStreamSettingsResponse + { updateDataStreamSettingsResponseDataStreams :: [UpdateDataStreamSettingsEntry] + } + deriving stock (Eq, Show, Generic) + +instance FromJSON UpdateDataStreamSettingsResponse where + parseJSON = withObject "UpdateDataStreamSettingsResponse" $ \o -> + UpdateDataStreamSettingsResponse <$> o .: "data_streams" + +instance ToJSON UpdateDataStreamSettingsResponse where + toJSON (UpdateDataStreamSettingsResponse streams) = + object ["data_streams" .= streams] + +-- Data Stream Lifecycle Stats lenses + +dataStreamLifecycleStatsLastRunDurationInMillisLens :: Lens' DataStreamLifecycleStats (Maybe Int64) +dataStreamLifecycleStatsLastRunDurationInMillisLens = lens dataStreamLifecycleStatsLastRunDurationInMillis (\x y -> x {dataStreamLifecycleStatsLastRunDurationInMillis = y}) + +dataStreamLifecycleStatsLastRunDurationLens :: Lens' DataStreamLifecycleStats (Maybe Text) +dataStreamLifecycleStatsLastRunDurationLens = lens dataStreamLifecycleStatsLastRunDuration (\x y -> x {dataStreamLifecycleStatsLastRunDuration = y}) + +dataStreamLifecycleStatsTimeBetweenStartsInMillisLens :: Lens' DataStreamLifecycleStats (Maybe Int64) +dataStreamLifecycleStatsTimeBetweenStartsInMillisLens = lens dataStreamLifecycleStatsTimeBetweenStartsInMillis (\x y -> x {dataStreamLifecycleStatsTimeBetweenStartsInMillis = y}) + +dataStreamLifecycleStatsTimeBetweenStartsLens :: Lens' DataStreamLifecycleStats (Maybe Text) +dataStreamLifecycleStatsTimeBetweenStartsLens = lens dataStreamLifecycleStatsTimeBetweenStarts (\x y -> x {dataStreamLifecycleStatsTimeBetweenStarts = y}) + +dataStreamLifecycleStatsCountLens :: Lens' DataStreamLifecycleStats Int +dataStreamLifecycleStatsCountLens = lens dataStreamLifecycleStatsCount (\x y -> x {dataStreamLifecycleStatsCount = y}) + +dataStreamLifecycleStatsDataStreamsLens :: Lens' DataStreamLifecycleStats [DataStreamLifecycleStatsEntry] +dataStreamLifecycleStatsDataStreamsLens = lens dataStreamLifecycleStatsDataStreams (\x y -> x {dataStreamLifecycleStatsDataStreams = y}) + +dataStreamLifecycleStatsEntryNameLens :: Lens' DataStreamLifecycleStatsEntry DataStreamName +dataStreamLifecycleStatsEntryNameLens = lens dataStreamLifecycleStatsEntryName (\x y -> x {dataStreamLifecycleStatsEntryName = y}) + +dataStreamLifecycleStatsEntryBackingIndicesInTotalLens :: Lens' DataStreamLifecycleStatsEntry Int +dataStreamLifecycleStatsEntryBackingIndicesInTotalLens = lens dataStreamLifecycleStatsEntryBackingIndicesInTotal (\x y -> x {dataStreamLifecycleStatsEntryBackingIndicesInTotal = y}) + +dataStreamLifecycleStatsEntryBackingIndicesInErrorLens :: Lens' DataStreamLifecycleStatsEntry Int +dataStreamLifecycleStatsEntryBackingIndicesInErrorLens = lens dataStreamLifecycleStatsEntryBackingIndicesInError (\x y -> x {dataStreamLifecycleStatsEntryBackingIndicesInError = y}) + +-- Explain Data Stream Lifecycle lenses + +explainDataStreamLifecycleResponseIndicesLens :: Lens' ExplainDataStreamLifecycleResponse (M.Map IndexName ExplainDataStreamLifecycleIndex) +explainDataStreamLifecycleResponseIndicesLens = lens explainDataStreamLifecycleResponseIndices (\x y -> x {explainDataStreamLifecycleResponseIndices = y}) + +explainDataStreamLifecycleIndexIndexLens :: Lens' ExplainDataStreamLifecycleIndex IndexName +explainDataStreamLifecycleIndexIndexLens = lens explainDataStreamLifecycleIndexIndex (\x y -> x {explainDataStreamLifecycleIndexIndex = y}) + +explainDataStreamLifecycleIndexManagedByLifecycleLens :: Lens' ExplainDataStreamLifecycleIndex Bool +explainDataStreamLifecycleIndexManagedByLifecycleLens = lens explainDataStreamLifecycleIndexManagedByLifecycle (\x y -> x {explainDataStreamLifecycleIndexManagedByLifecycle = y}) + +explainDataStreamLifecycleIndexCreationDateMillisLens :: Lens' ExplainDataStreamLifecycleIndex (Maybe Int64) +explainDataStreamLifecycleIndexCreationDateMillisLens = lens explainDataStreamLifecycleIndexCreationDateMillis (\x y -> x {explainDataStreamLifecycleIndexCreationDateMillis = y}) + +explainDataStreamLifecycleIndexTimeSinceIndexCreationLens :: Lens' ExplainDataStreamLifecycleIndex (Maybe Text) +explainDataStreamLifecycleIndexTimeSinceIndexCreationLens = lens explainDataStreamLifecycleIndexTimeSinceIndexCreation (\x y -> x {explainDataStreamLifecycleIndexTimeSinceIndexCreation = y}) + +explainDataStreamLifecycleIndexRolloverDateMillisLens :: Lens' ExplainDataStreamLifecycleIndex (Maybe Int64) +explainDataStreamLifecycleIndexRolloverDateMillisLens = lens explainDataStreamLifecycleIndexRolloverDateMillis (\x y -> x {explainDataStreamLifecycleIndexRolloverDateMillis = y}) + +explainDataStreamLifecycleIndexTimeSinceRolloverLens :: Lens' ExplainDataStreamLifecycleIndex (Maybe Text) +explainDataStreamLifecycleIndexTimeSinceRolloverLens = lens explainDataStreamLifecycleIndexTimeSinceRollover (\x y -> x {explainDataStreamLifecycleIndexTimeSinceRollover = y}) + +explainDataStreamLifecycleIndexLifecycleLens :: Lens' ExplainDataStreamLifecycleIndex (Maybe DataStreamLifecycle) +explainDataStreamLifecycleIndexLifecycleLens = lens explainDataStreamLifecycleIndexLifecycle (\x y -> x {explainDataStreamLifecycleIndexLifecycle = y}) + +explainDataStreamLifecycleIndexGenerationTimeLens :: Lens' ExplainDataStreamLifecycleIndex (Maybe Text) +explainDataStreamLifecycleIndexGenerationTimeLens = lens explainDataStreamLifecycleIndexGenerationTime (\x y -> x {explainDataStreamLifecycleIndexGenerationTime = y}) + +explainDataStreamLifecycleIndexErrorLens :: Lens' ExplainDataStreamLifecycleIndex (Maybe Text) +explainDataStreamLifecycleIndexErrorLens = lens explainDataStreamLifecycleIndexError (\x y -> x {explainDataStreamLifecycleIndexError = y}) + +-- Data Stream Mappings lenses + +getDataStreamMappingsResponseDataStreamsLens :: Lens' GetDataStreamMappingsResponse [GetDataStreamMappingsEntry] +getDataStreamMappingsResponseDataStreamsLens = lens getDataStreamMappingsResponseDataStreams (\x y -> x {getDataStreamMappingsResponseDataStreams = y}) + +getDataStreamMappingsEntryNameLens :: Lens' GetDataStreamMappingsEntry DataStreamName +getDataStreamMappingsEntryNameLens = lens getDataStreamMappingsEntryName (\x y -> x {getDataStreamMappingsEntryName = y}) + +getDataStreamMappingsEntryMappingsLens :: Lens' GetDataStreamMappingsEntry Value +getDataStreamMappingsEntryMappingsLens = lens getDataStreamMappingsEntryMappings (\x y -> x {getDataStreamMappingsEntryMappings = y}) + +getDataStreamMappingsEntryEffectiveMappingsLens :: Lens' GetDataStreamMappingsEntry Value +getDataStreamMappingsEntryEffectiveMappingsLens = lens getDataStreamMappingsEntryEffectiveMappings (\x y -> x {getDataStreamMappingsEntryEffectiveMappings = y}) + +updateDataStreamMappingsResponseDataStreamsLens :: Lens' UpdateDataStreamMappingsResponse [UpdateDataStreamMappingsEntry] +updateDataStreamMappingsResponseDataStreamsLens = lens updateDataStreamMappingsResponseDataStreams (\x y -> x {updateDataStreamMappingsResponseDataStreams = y}) + +updateDataStreamMappingsEntryNameLens :: Lens' UpdateDataStreamMappingsEntry DataStreamName +updateDataStreamMappingsEntryNameLens = lens updateDataStreamMappingsEntryName (\x y -> x {updateDataStreamMappingsEntryName = y}) + +updateDataStreamMappingsEntryAppliedToDataStreamLens :: Lens' UpdateDataStreamMappingsEntry Bool +updateDataStreamMappingsEntryAppliedToDataStreamLens = lens updateDataStreamMappingsEntryAppliedToDataStream (\x y -> x {updateDataStreamMappingsEntryAppliedToDataStream = y}) + +updateDataStreamMappingsEntryErrorLens :: Lens' UpdateDataStreamMappingsEntry (Maybe Text) +updateDataStreamMappingsEntryErrorLens = lens updateDataStreamMappingsEntryError (\x y -> x {updateDataStreamMappingsEntryError = y}) + +updateDataStreamMappingsEntryMappingsLens :: Lens' UpdateDataStreamMappingsEntry Value +updateDataStreamMappingsEntryMappingsLens = lens updateDataStreamMappingsEntryMappings (\x y -> x {updateDataStreamMappingsEntryMappings = y}) + +updateDataStreamMappingsEntryEffectiveMappingsLens :: Lens' UpdateDataStreamMappingsEntry Value +updateDataStreamMappingsEntryEffectiveMappingsLens = lens updateDataStreamMappingsEntryEffectiveMappings (\x y -> x {updateDataStreamMappingsEntryEffectiveMappings = y}) + +-- Data Stream Settings lenses + +getDataStreamSettingsResponseDataStreamsLens :: Lens' GetDataStreamSettingsResponse [GetDataStreamSettingsEntry] +getDataStreamSettingsResponseDataStreamsLens = lens getDataStreamSettingsResponseDataStreams (\x y -> x {getDataStreamSettingsResponseDataStreams = y}) + +getDataStreamSettingsEntryNameLens :: Lens' GetDataStreamSettingsEntry DataStreamName +getDataStreamSettingsEntryNameLens = lens getDataStreamSettingsEntryName (\x y -> x {getDataStreamSettingsEntryName = y}) + +getDataStreamSettingsEntrySettingsLens :: Lens' GetDataStreamSettingsEntry Value +getDataStreamSettingsEntrySettingsLens = lens getDataStreamSettingsEntrySettings (\x y -> x {getDataStreamSettingsEntrySettings = y}) + +getDataStreamSettingsEntryEffectiveSettingsLens :: Lens' GetDataStreamSettingsEntry Value +getDataStreamSettingsEntryEffectiveSettingsLens = lens getDataStreamSettingsEntryEffectiveSettings (\x y -> x {getDataStreamSettingsEntryEffectiveSettings = y}) + +updateDataStreamSettingsResponseDataStreamsLens :: Lens' UpdateDataStreamSettingsResponse [UpdateDataStreamSettingsEntry] +updateDataStreamSettingsResponseDataStreamsLens = lens updateDataStreamSettingsResponseDataStreams (\x y -> x {updateDataStreamSettingsResponseDataStreams = y}) + +updateDataStreamSettingsEntryNameLens :: Lens' UpdateDataStreamSettingsEntry DataStreamName +updateDataStreamSettingsEntryNameLens = lens updateDataStreamSettingsEntryName (\x y -> x {updateDataStreamSettingsEntryName = y}) + +updateDataStreamSettingsEntryAppliedToDataStreamLens :: Lens' UpdateDataStreamSettingsEntry Bool +updateDataStreamSettingsEntryAppliedToDataStreamLens = lens updateDataStreamSettingsEntryAppliedToDataStream (\x y -> x {updateDataStreamSettingsEntryAppliedToDataStream = y}) + +updateDataStreamSettingsEntryErrorLens :: Lens' UpdateDataStreamSettingsEntry (Maybe Text) +updateDataStreamSettingsEntryErrorLens = lens updateDataStreamSettingsEntryError (\x y -> x {updateDataStreamSettingsEntryError = y}) + +updateDataStreamSettingsEntrySettingsLens :: Lens' UpdateDataStreamSettingsEntry Value +updateDataStreamSettingsEntrySettingsLens = lens updateDataStreamSettingsEntrySettings (\x y -> x {updateDataStreamSettingsEntrySettings = y}) + +updateDataStreamSettingsEntryEffectiveSettingsLens :: Lens' UpdateDataStreamSettingsEntry Value +updateDataStreamSettingsEntryEffectiveSettingsLens = lens updateDataStreamSettingsEntryEffectiveSettings (\x y -> x {updateDataStreamSettingsEntryEffectiveSettings = y}) + +updateDataStreamSettingsEntryIndexSettingsResultsLens :: Lens' UpdateDataStreamSettingsEntry (Maybe IndexSettingsResults) +updateDataStreamSettingsEntryIndexSettingsResultsLens = lens updateDataStreamSettingsEntryIndexSettingsResults (\x y -> x {updateDataStreamSettingsEntryIndexSettingsResults = y}) + +indexSettingsResultsAppliedToDataStreamOnlyLens :: Lens' IndexSettingsResults [Text] +indexSettingsResultsAppliedToDataStreamOnlyLens = lens indexSettingsResultsAppliedToDataStreamOnly (\x y -> x {indexSettingsResultsAppliedToDataStreamOnly = y}) + +indexSettingsResultsAppliedToDataStreamAndBackingIndicesLens :: Lens' IndexSettingsResults [Text] +indexSettingsResultsAppliedToDataStreamAndBackingIndicesLens = lens indexSettingsResultsAppliedToDataStreamAndBackingIndices (\x y -> x {indexSettingsResultsAppliedToDataStreamAndBackingIndices = y}) + +indexSettingsResultsErrorsLens :: Lens' IndexSettingsResults [IndexSettingError] +indexSettingsResultsErrorsLens = lens indexSettingsResultsErrors (\x y -> x {indexSettingsResultsErrors = y}) + +indexSettingErrorIndexLens :: Lens' IndexSettingError Text +indexSettingErrorIndexLens = lens indexSettingErrorIndex (\x y -> x {indexSettingErrorIndex = y}) + +indexSettingErrorErrorLens :: Lens' IndexSettingError Text +indexSettingErrorErrorLens = lens indexSettingErrorError (\x y -> x {indexSettingErrorError = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/EventQueryLanguage.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/EventQueryLanguage.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/EventQueryLanguage.hs @@ -0,0 +1,712 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.EventQueryLanguage + ( EQLRequest (..), + EQLResult (..), + EQLHits (..), + EQLHit (..), + EQLSequence (..), + EQLTotal (..), + EQLTotalRelation (..), + EQLResultPosition (..), + EQLSearchId (..), + EQLStatus (..), + EQLSearchOptions (..), + defaultEQLSearchOptions, + eqlSearchOptionsParams7, + eqlSearchOptionsParams8, + EQLRequestBodyES7 (..), + EQLRequestBodyES8 (..), + eqlQueryLens, + eqlWaitForCompletionTimeoutLens, + eqlKeepOnCompletionLens, + eqlKeepAliveLens, + eqlSizeLens, + eqlFetchSizeLens, + eqlFieldsLens, + eqlFilterLens, + eqlResultPositionLens, + eqlTiebreakerFieldLens, + eqlEventCategoryFieldLens, + eqlTimestampFieldLens, + eqlRuntimeMappingsLens, + eqlAllowPartialSearchResultsLens, + eqlAllowPartialSequenceResultsLens, + eqlCaseSensitiveLens, + esoAllowNoIndicesLens, + esoAllowPartialSearchResultsLens, + esoAllowPartialSequenceResultsLens, + esoExpandWildcardsLens, + esoIgnoreUnavailableLens, + esoCcsMinimizeRoundtripsLens, + esoKeepAliveLens, + esoKeepOnCompletionLens, + esoWaitForCompletionTimeoutLens, + eqlIdLens, + eqlIsRunningLens, + eqlIsPartialLens, + eqlTimedOutLens, + eqlTookLens, + eqlHitsLens, + eqlHitsTotalLens, + eqlHitsEventsLens, + eqlHitsSequencesLens, + eqlSequenceEventsLens, + eqlSequenceJoinKeysLens, + eqlHitIndexLens, + eqlHitDocIdLens, + eqlHitScoreLens, + eqlHitSourceLens, + eqlHitVersionLens, + eqlHitSeqNoLens, + eqlHitPrimaryTermLens, + eqlHitFieldsLens, + eqlTotalValueLens, + eqlTotalRelationLens, + eqlSearchIdLens, + eqlStatusIdLens, + eqlStatusIsRunningLens, + eqlStatusIsPartialLens, + eqlStatusStartTimeInMillisLens, + eqlStatusCompletionStatusLens, + eqlStatusExpirationTimeInMillisLens, + resultPositionToText, + resultPositionFromText, + ) +where + +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes (HitFields) +import Database.Bloodhound.Internal.Versions.Common.Types.Query (Filter) +import Database.Bloodhound.Internal.Versions.Common.Types.Search + ( ExpandWildcards, + RuntimeMappings, + expandWildcardsText, + ) + +-- | Request body for the EQL @POST /{index}/_eql/search@ API +-- (Elasticsearch >= 7.10). +-- +-- Only 'eqlQuery' is required; it holds the EQL source +-- (e.g. @"process where process.name == \"cmd.exe\""@). Optional fields are +-- forwarded verbatim to the server and rendered as JSON @null@-dropped keys. +-- +-- 'eqlRuntimeMappings' is documented at every version. The three boolean +-- fields 'eqlAllowPartialSearchResults', +-- 'eqlAllowPartialSequenceResults' and 'eqlCaseSensitive' are +-- /8.x-only/: they are absent from the +-- +-- and first appear in the 8.x docs. They are kept on this record so a +-- single type serves every backend, but the /wire/ emission is gated by +-- version: the ES7 request builder encodes via 'EQLRequestBodyES7' +-- (which omits them), while the ES8 and ES9 builders encode via +-- 'EQLRequestBodyES8' (which emits them). The bare 'ToJSON' instance +-- below emits the full (8.x) shape, so direct @encode req@ calls round-trip +-- every field; use the newtype wrappers to control the on-the-wire shape. +-- +-- Note that @allow_partial_search_results@ (default @true@) and +-- @allow_partial_sequence_results@ (default @false@) are also accepted as +-- URI query parameters via 'EQLSearchOptions' on 8.x+; when both are +-- supplied the query parameter takes precedence server-side. The ES7 URI +-- renderer 'eqlSearchOptionsParams7' omits them; the ES8\/ES9 renderer +-- 'eqlSearchOptionsParams8' emits them. +-- +-- For more information see +-- . +data EQLRequest = EQLRequest + { eqlQuery :: Text, + eqlWaitForCompletionTimeout :: Maybe Text, + eqlKeepOnCompletion :: Maybe Bool, + eqlKeepAlive :: Maybe Text, + eqlSize :: Maybe Int, + eqlFetchSize :: Maybe Int, + eqlFields :: Maybe [Value], + eqlFilter :: Maybe Filter, + eqlResultPosition :: Maybe EQLResultPosition, + eqlTiebreakerField :: Maybe Text, + eqlEventCategoryField :: Maybe Text, + eqlTimestampField :: Maybe Text, + eqlRuntimeMappings :: Maybe RuntimeMappings, + eqlAllowPartialSearchResults :: Maybe Bool, + eqlAllowPartialSequenceResults :: Maybe Bool, + eqlCaseSensitive :: Maybe Bool + } + deriving stock (Eq, Show) + +instance ToJSON EQLRequest where + toJSON EQLRequest {..} = + omitNulls + [ "query" .= eqlQuery, + "wait_for_completion_timeout" .= eqlWaitForCompletionTimeout, + "keep_on_completion" .= eqlKeepOnCompletion, + "keep_alive" .= eqlKeepAlive, + "size" .= eqlSize, + "fetch_size" .= eqlFetchSize, + "fields" .= eqlFields, + "filter" .= eqlFilter, + "result_position" .= eqlResultPosition, + "tiebreaker_field" .= eqlTiebreakerField, + "event_category_field" .= eqlEventCategoryField, + "timestamp_field" .= eqlTimestampField, + "runtime_mappings" .= eqlRuntimeMappings, + "allow_partial_search_results" .= eqlAllowPartialSearchResults, + "allow_partial_sequence_results" .= eqlAllowPartialSequenceResults, + "case_sensitive" .= eqlCaseSensitive + ] + +instance FromJSON EQLRequest where + parseJSON (Object o) = + EQLRequest + <$> o .: "query" + <*> o .:? "wait_for_completion_timeout" + <*> o .:? "keep_on_completion" + <*> o .:? "keep_alive" + <*> o .:? "size" + <*> o .:? "fetch_size" + <*> o .:? "fields" + <*> o .:? "filter" + <*> o .:? "result_position" + <*> o .:? "tiebreaker_field" + <*> o .:? "event_category_field" + <*> o .:? "timestamp_field" + <*> o .:? "runtime_mappings" + <*> o .:? "allow_partial_search_results" + <*> o .:? "allow_partial_sequence_results" + <*> o .:? "case_sensitive" + parseJSON x = typeMismatch "EQLRequest" x + +eqlQueryLens :: Lens' EQLRequest Text +eqlQueryLens = lens eqlQuery (\x y -> x {eqlQuery = y}) + +eqlWaitForCompletionTimeoutLens :: Lens' EQLRequest (Maybe Text) +eqlWaitForCompletionTimeoutLens = + lens eqlWaitForCompletionTimeout (\x y -> x {eqlWaitForCompletionTimeout = y}) + +eqlKeepOnCompletionLens :: Lens' EQLRequest (Maybe Bool) +eqlKeepOnCompletionLens = + lens eqlKeepOnCompletion (\x y -> x {eqlKeepOnCompletion = y}) + +eqlKeepAliveLens :: Lens' EQLRequest (Maybe Text) +eqlKeepAliveLens = lens eqlKeepAlive (\x y -> x {eqlKeepAlive = y}) + +eqlSizeLens :: Lens' EQLRequest (Maybe Int) +eqlSizeLens = lens eqlSize (\x y -> x {eqlSize = y}) + +eqlFetchSizeLens :: Lens' EQLRequest (Maybe Int) +eqlFetchSizeLens = lens eqlFetchSize (\x y -> x {eqlFetchSize = y}) + +eqlFieldsLens :: Lens' EQLRequest (Maybe [Value]) +eqlFieldsLens = lens eqlFields (\x y -> x {eqlFields = y}) + +eqlFilterLens :: Lens' EQLRequest (Maybe Filter) +eqlFilterLens = lens eqlFilter (\x y -> x {eqlFilter = y}) + +eqlResultPositionLens :: Lens' EQLRequest (Maybe EQLResultPosition) +eqlResultPositionLens = + lens eqlResultPosition (\x y -> x {eqlResultPosition = y}) + +eqlTiebreakerFieldLens :: Lens' EQLRequest (Maybe Text) +eqlTiebreakerFieldLens = + lens eqlTiebreakerField (\x y -> x {eqlTiebreakerField = y}) + +eqlEventCategoryFieldLens :: Lens' EQLRequest (Maybe Text) +eqlEventCategoryFieldLens = + lens eqlEventCategoryField (\x y -> x {eqlEventCategoryField = y}) + +eqlTimestampFieldLens :: Lens' EQLRequest (Maybe Text) +eqlTimestampFieldLens = + lens eqlTimestampField (\x y -> x {eqlTimestampField = y}) + +eqlRuntimeMappingsLens :: Lens' EQLRequest (Maybe RuntimeMappings) +eqlRuntimeMappingsLens = + lens eqlRuntimeMappings (\x y -> x {eqlRuntimeMappings = y}) + +eqlAllowPartialSearchResultsLens :: Lens' EQLRequest (Maybe Bool) +eqlAllowPartialSearchResultsLens = + lens eqlAllowPartialSearchResults (\x y -> x {eqlAllowPartialSearchResults = y}) + +eqlAllowPartialSequenceResultsLens :: Lens' EQLRequest (Maybe Bool) +eqlAllowPartialSequenceResultsLens = + lens eqlAllowPartialSequenceResults (\x y -> x {eqlAllowPartialSequenceResults = y}) + +eqlCaseSensitiveLens :: Lens' EQLRequest (Maybe Bool) +eqlCaseSensitiveLens = + lens eqlCaseSensitive (\x y -> x {eqlCaseSensitive = y}) + +-- | Newtype wrapper used by the Elasticsearch 7 request builder to render +-- an 'EQLRequest' on the wire. It is byte-identical to 'EQLRequestBodyES8' +-- /except/ that it omits the three 8.x-only body keys +-- (@allow_partial_search_results@, @allow_partial_sequence_results@, +-- @case_sensitive@), which are absent from the +-- . +-- Wrap with 'EQLRequestBodyES7' before encoding for the ES7 wire path. +newtype EQLRequestBodyES7 = EQLRequestBodyES7 {unEQLRequestBodyES7 :: EQLRequest} + +instance ToJSON EQLRequestBodyES7 where + toJSON (EQLRequestBodyES7 EQLRequest {..}) = + omitNulls + [ "query" .= eqlQuery, + "wait_for_completion_timeout" .= eqlWaitForCompletionTimeout, + "keep_on_completion" .= eqlKeepOnCompletion, + "keep_alive" .= eqlKeepAlive, + "size" .= eqlSize, + "fetch_size" .= eqlFetchSize, + "fields" .= eqlFields, + "filter" .= eqlFilter, + "result_position" .= eqlResultPosition, + "tiebreaker_field" .= eqlTiebreakerField, + "event_category_field" .= eqlEventCategoryField, + "timestamp_field" .= eqlTimestampField, + "runtime_mappings" .= eqlRuntimeMappings + ] + +-- | Newtype wrapper used by the Elasticsearch 8 and 9 request builders to +-- render an 'EQLRequest' on the wire. It emits every field, including +-- the 8.x-only @allow_partial_search_results@, +-- @allow_partial_sequence_results@ and @case_sensitive@ keys. The output +-- is identical to the bare 'ToJSON' instance of 'EQLRequest'; this +-- wrapper exists only so the ES8\/ES9 request builders read symmetrically +-- with 'EQLRequestBodyES7'. +newtype EQLRequestBodyES8 = EQLRequestBodyES8 {unEQLRequestBodyES8 :: EQLRequest} + +instance ToJSON EQLRequestBodyES8 where + toJSON (EQLRequestBodyES8 req) = toJSON req + +-- | URI parameters accepted by @POST /{index}/_eql/search@: +-- @allow_no_indices@, @allow_partial_search_results@, +-- @allow_partial_sequence_results@, @expand_wildcards@ (comma-joined on +-- the wire), @ignore_unavailable@, @ccs_minimize_roundtrips@, +-- @keep_alive@, @keep_on_completion@ and @wait_for_completion_timeout@. +-- +-- The last five mirror body fields of 'EQLRequest'; Elasticsearch accepts +-- either form and, when both are supplied, the query parameter takes +-- precedence. Every field is optional so 'defaultEQLSearchOptions' renders +-- to no query string at all — byte-for-byte identical to a parameterless +-- call, which is what 'eqlSearch' (the simple form) produces. +-- +-- @allow_partial_search_results@ and @allow_partial_sequence_results@ are +-- 8.x-only URI parameters; the ES7 renderer 'eqlSearchOptionsParams7' +-- /omits/ them, the ES8\/ES9 renderer 'eqlSearchOptionsParams8' emits +-- them. Both renderers share this single record type so callers configure +-- options uniformly across backends. +-- +-- For more information see +-- . +data EQLSearchOptions = EQLSearchOptions + { esoAllowNoIndices :: Maybe Bool, + esoAllowPartialSearchResults :: Maybe Bool, + esoAllowPartialSequenceResults :: Maybe Bool, + esoExpandWildcards :: Maybe [ExpandWildcards], + esoIgnoreUnavailable :: Maybe Bool, + esoCcsMinimizeRoundtrips :: Maybe Bool, + esoKeepAlive :: Maybe Text, + esoKeepOnCompletion :: Maybe Bool, + esoWaitForCompletionTimeout :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'EQLSearchOptions' with every parameter set to 'Nothing'. Produces no +-- query string, so a call made with this value is byte-identical to a +-- parameterless call. +defaultEQLSearchOptions :: EQLSearchOptions +defaultEQLSearchOptions = + EQLSearchOptions + { esoAllowNoIndices = Nothing, + esoAllowPartialSearchResults = Nothing, + esoAllowPartialSequenceResults = Nothing, + esoExpandWildcards = Nothing, + esoIgnoreUnavailable = Nothing, + esoCcsMinimizeRoundtrips = Nothing, + esoKeepAlive = Nothing, + esoKeepOnCompletion = Nothing, + esoWaitForCompletionTimeout = Nothing + } + +esoAllowNoIndicesLens :: Lens' EQLSearchOptions (Maybe Bool) +esoAllowNoIndicesLens = + lens esoAllowNoIndices (\x y -> x {esoAllowNoIndices = y}) + +esoAllowPartialSearchResultsLens :: Lens' EQLSearchOptions (Maybe Bool) +esoAllowPartialSearchResultsLens = + lens esoAllowPartialSearchResults (\x y -> x {esoAllowPartialSearchResults = y}) + +esoAllowPartialSequenceResultsLens :: Lens' EQLSearchOptions (Maybe Bool) +esoAllowPartialSequenceResultsLens = + lens esoAllowPartialSequenceResults (\x y -> x {esoAllowPartialSequenceResults = y}) + +esoExpandWildcardsLens :: Lens' EQLSearchOptions (Maybe [ExpandWildcards]) +esoExpandWildcardsLens = + lens esoExpandWildcards (\x y -> x {esoExpandWildcards = y}) + +esoIgnoreUnavailableLens :: Lens' EQLSearchOptions (Maybe Bool) +esoIgnoreUnavailableLens = + lens esoIgnoreUnavailable (\x y -> x {esoIgnoreUnavailable = y}) + +esoCcsMinimizeRoundtripsLens :: Lens' EQLSearchOptions (Maybe Bool) +esoCcsMinimizeRoundtripsLens = + lens esoCcsMinimizeRoundtrips (\x y -> x {esoCcsMinimizeRoundtrips = y}) + +esoKeepAliveLens :: Lens' EQLSearchOptions (Maybe Text) +esoKeepAliveLens = + lens esoKeepAlive (\x y -> x {esoKeepAlive = y}) + +esoKeepOnCompletionLens :: Lens' EQLSearchOptions (Maybe Bool) +esoKeepOnCompletionLens = + lens esoKeepOnCompletion (\x y -> x {esoKeepOnCompletion = y}) + +esoWaitForCompletionTimeoutLens :: Lens' EQLSearchOptions (Maybe Text) +esoWaitForCompletionTimeoutLens = + lens esoWaitForCompletionTimeout (\x y -> x {esoWaitForCompletionTimeout = y}) + +-- | Render 'EQLSearchOptions' as a list of @(key, value)@ pairs suitable +-- for 'withQueries', emitting only the URI parameters documented by the +-- : +-- @allow_no_indices@, @expand_wildcards@, @ignore_unavailable@, +-- @ccs_minimize_roundtrips@, @keep_alive@, @keep_on_completion@ and +-- @wait_for_completion_timeout@. The 8.x-only @allow_partial_search_results@ +-- and @allow_partial_sequence_results@ parameters are /deliberately +-- omitted/ so the ES7 request builder never emits undocumented +-- parameters; use 'eqlSearchOptionsParams8' on the ES8\/ES9 path. +-- 'Nothing' fields are omitted, so 'defaultEQLSearchOptions' produces an +-- empty list (and therefore no query string). The order of the returned +-- list is stable but /unspecified/ — callers (including tests) should +-- treat it as a set; the underlying 'withQueries' is order-insensitive. +eqlSearchOptionsParams7 :: EQLSearchOptions -> [(Text, Maybe Text)] +eqlSearchOptionsParams7 opts = + catMaybes + [ ("allow_no_indices",) . Just . boolText <$> esoAllowNoIndices opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> esoExpandWildcards opts, + ("ignore_unavailable",) . Just . boolText <$> esoIgnoreUnavailable opts, + ("ccs_minimize_roundtrips",) . Just . boolText <$> esoCcsMinimizeRoundtrips opts, + ("keep_alive",) . Just <$> esoKeepAlive opts, + ("keep_on_completion",) . Just . boolText <$> esoKeepOnCompletion opts, + ("wait_for_completion_timeout",) . Just <$> esoWaitForCompletionTimeout opts + ] + where + boolText True = "true" + boolText False = "false" + renderExpandWildcards = T.intercalate "," . map expandWildcardsText + +-- | Render 'EQLSearchOptions' as a list of @(key, value)@ pairs suitable +-- for 'withQueries', emitting the full set of URI parameters documented +-- by the +-- : +-- every parameter from 'eqlSearchOptionsParams7' /plus/ the 8.x-only +-- @allow_partial_search_results@ and @allow_partial_sequence_results@. +-- Used by the ES8 and ES9 request builders. 'Nothing' fields are omitted, +-- so 'defaultEQLSearchOptions' produces an empty list (and therefore no +-- query string). The order of the returned list is stable but +-- /unspecified/ — callers (including tests) should treat it as a set; the +-- underlying 'withQueries' is order-insensitive. +eqlSearchOptionsParams8 :: EQLSearchOptions -> [(Text, Maybe Text)] +eqlSearchOptionsParams8 opts = + eqlSearchOptionsParams7 opts + <> catMaybes + [ ("allow_partial_search_results",) . Just . boolText <$> esoAllowPartialSearchResults opts, + ("allow_partial_sequence_results",) . Just . boolText <$> esoAllowPartialSequenceResults opts + ] + where + boolText True = "true" + boolText False = "false" + +-- | Position of the matched events in the result set. @EQLHead@ returns +-- the earliest matches, @EQLTail@ returns the most recent matches +-- (default). +data EQLResultPosition = EQLHead | EQLTail + deriving stock (Eq, Show) + +resultPositionToText :: EQLResultPosition -> Text +resultPositionToText EQLHead = "head" +resultPositionToText EQLTail = "tail" + +resultPositionFromText :: Text -> Maybe EQLResultPosition +resultPositionFromText "head" = Just EQLHead +resultPositionFromText "tail" = Just EQLTail +resultPositionFromText _ = Nothing + +instance ToJSON EQLResultPosition where + toJSON = toJSON . resultPositionToText + +instance FromJSON EQLResultPosition where + parseJSON v = do + s <- parseJSON v + maybe (fail $ "unknown result_position: " <> show s) pure (resultPositionFromText s) + +-- | Total count returned at the top level and inside 'eqlHits'. Mirrors +-- the ES @{"value": N, "relation": "eq" | "gte"}@ shape, but defined +-- locally (rather than reusing 'HitsTotal') so that it has a +-- 'ToJSON' instance and the relation is modelled as a dedicated sum. +data EQLTotalRelation = EQLTotalEq | EQLTotalGte + deriving stock (Eq, Show) + +instance ToJSON EQLTotalRelation where + toJSON EQLTotalEq = "eq" + toJSON EQLTotalGte = "gte" + +instance FromJSON EQLTotalRelation where + parseJSON (String "eq") = pure EQLTotalEq + parseJSON (String "gte") = pure EQLTotalGte + parseJSON x = typeMismatch "EQLTotalRelation" x + +data EQLTotal = EQLTotal + { eqlTotalValue :: Int, + eqlTotalRelation :: EQLTotalRelation + } + deriving stock (Eq, Show) + +instance ToJSON EQLTotal where + toJSON EQLTotal {..} = + object + [ "value" .= eqlTotalValue, + "relation" .= eqlTotalRelation + ] + +instance FromJSON EQLTotal where + parseJSON (Object o) = + EQLTotal + <$> o .: "value" + <*> o .: "relation" + parseJSON x = typeMismatch "EQLTotal" x + +eqlTotalValueLens :: Lens' EQLTotal Int +eqlTotalValueLens = lens eqlTotalValue (\x y -> x {eqlTotalValue = y}) + +eqlTotalRelationLens :: Lens' EQLTotal EQLTotalRelation +eqlTotalRelationLens = + lens eqlTotalRelation (\x y -> x {eqlTotalRelation = y}) + +-- | EQL events do not carry @sort@, @highlight@ or @inner_hits@ (those +-- are regular-search concerns) but they do carry sequence-number +-- metadata (@_seq_no@, @_primary_term@, @_version@). The shape is +-- therefore modelled separately from the regular-search 'Hit'. +data EQLHit a = EQLHit + { eqlHitIndex :: Maybe Text, + eqlHitDocId :: Maybe Text, + eqlHitScore :: Maybe Double, + eqlHitSource :: Maybe a, + eqlHitVersion :: Maybe Int, + eqlHitSeqNo :: Maybe Int, + eqlHitPrimaryTerm :: Maybe Int, + eqlHitFields :: Maybe HitFields + } + deriving stock (Eq, Show) + +instance (FromJSON a) => FromJSON (EQLHit a) where + parseJSON (Object v) = + EQLHit + <$> v .:? "_index" + <*> v .:? "_id" + <*> v .:? "_score" + <*> v .:? "_source" + <*> v .:? "_version" + <*> v .:? "_seq_no" + <*> v .:? "_primary_term" + <*> v .:? "fields" + parseJSON _ = empty + +eqlHitIndexLens :: Lens' (EQLHit a) (Maybe Text) +eqlHitIndexLens = lens eqlHitIndex (\x y -> x {eqlHitIndex = y}) + +eqlHitDocIdLens :: Lens' (EQLHit a) (Maybe Text) +eqlHitDocIdLens = lens eqlHitDocId (\x y -> x {eqlHitDocId = y}) + +eqlHitScoreLens :: Lens' (EQLHit a) (Maybe Double) +eqlHitScoreLens = lens eqlHitScore (\x y -> x {eqlHitScore = y}) + +eqlHitSourceLens :: Lens' (EQLHit a) (Maybe a) +eqlHitSourceLens = lens eqlHitSource (\x y -> x {eqlHitSource = y}) + +eqlHitVersionLens :: Lens' (EQLHit a) (Maybe Int) +eqlHitVersionLens = lens eqlHitVersion (\x y -> x {eqlHitVersion = y}) + +eqlHitSeqNoLens :: Lens' (EQLHit a) (Maybe Int) +eqlHitSeqNoLens = lens eqlHitSeqNo (\x y -> x {eqlHitSeqNo = y}) + +eqlHitPrimaryTermLens :: Lens' (EQLHit a) (Maybe Int) +eqlHitPrimaryTermLens = + lens eqlHitPrimaryTerm (\x y -> x {eqlHitPrimaryTerm = y}) + +eqlHitFieldsLens :: Lens' (EQLHit a) (Maybe HitFields) +eqlHitFieldsLens = lens eqlHitFields (\x y -> x {eqlHitFields = y}) + +-- | EQL @hits@ container. Unlike 'SearchHits', EQL nests matched events +-- under the @events@ key (rather than @hits.hits@) and makes both +-- @total@ and @max_score@ optional. Sequence queries (@sequence ...@) +-- populate 'eqlHitsSequences' instead of 'eqlHitsEvents'; event queries +-- populate 'eqlHitsEvents' and leave 'eqlHitsSequences' as @Nothing@. +data EQLHits a = EQLHits + { eqlHitsTotal :: Maybe EQLTotal, + eqlHitsEvents :: [EQLHit a], + eqlHitsSequences :: Maybe [EQLSequence a] + } + deriving stock (Eq, Show) + +instance (FromJSON a) => FromJSON (EQLHits a) where + parseJSON (Object v) = + EQLHits + <$> v .:? "total" + <*> (v .:? "events" .!= []) + <*> v .:? "sequences" + parseJSON _ = empty + +eqlHitsTotalLens :: Lens' (EQLHits a) (Maybe EQLTotal) +eqlHitsTotalLens = lens eqlHitsTotal (\x y -> x {eqlHitsTotal = y}) + +eqlHitsEventsLens :: Lens' (EQLHits a) [EQLHit a] +eqlHitsEventsLens = lens eqlHitsEvents (\x y -> x {eqlHitsEvents = y}) + +eqlHitsSequencesLens :: Lens' (EQLHits a) (Maybe [EQLSequence a]) +eqlHitsSequencesLens = lens eqlHitsSequences (\x y -> x {eqlHitsSequences = y}) + +-- | One matched sequence returned by an EQL @sequence@ query. The +-- @events@ array is the ordered list of events that matched the +-- sequence clauses (carrying the same shape as 'EQLHit' elsewhere in +-- the result set); @join_keys@ carries the values that joined the +-- events into a sequence (typically the @by@ fields of the query). +-- @join_keys@ is modelled as @[Value]@ because the elements are +-- heterogeneous (one entry per @by@ field, type depends on the field). +data EQLSequence a = EQLSequence + { eqlSequenceEvents :: [EQLHit a], + eqlSequenceJoinKeys :: Maybe [Value] + } + deriving stock (Eq, Show) + +instance (FromJSON a) => FromJSON (EQLSequence a) where + parseJSON (Object v) = + EQLSequence + <$> (v .:? "events" .!= []) + <*> v .:? "join_keys" + parseJSON _ = empty + +eqlSequenceEventsLens :: Lens' (EQLSequence a) [EQLHit a] +eqlSequenceEventsLens = lens eqlSequenceEvents (\x y -> x {eqlSequenceEvents = y}) + +eqlSequenceJoinKeysLens :: Lens' (EQLSequence a) (Maybe [Value]) +eqlSequenceJoinKeysLens = lens eqlSequenceJoinKeys (\x y -> x {eqlSequenceJoinKeys = y}) + +-- | Server-assigned identifier for an async EQL search. Returned in the +-- initial 'EQLResult' when 'eqlWaitForCompletionTimeout' elapses before +-- the search finishes; pass it to 'getEQLSearch' (and the status/delete +-- endpoints) to retrieve or manage the deferred results. +-- +-- Modelled as a 'Text' newtype (rather than a record) so it round-trips +-- as a bare JSON string on the wire, matching @ScrollId@ and the other +-- search-handle newtypes. +newtype EQLSearchId = EQLSearchId {unEQLSearchId :: Text} + deriving newtype (Eq, Ord, Show, ToJSON, FromJSON) + +-- | Response body for the EQL @POST /{index}/_eql/search@ API and the +-- async follow-up @GET /_eql/search\/{id}@. +eqlSearchIdLens :: Lens' EQLSearchId Text +eqlSearchIdLens = lens unEQLSearchId (\x y -> x {unEQLSearchId = y}) + +-- | Response body for the EQL @POST /{index}/_eql/search@ API. +-- +-- Parses exactly the fields the ES 7.17 EQL search response documents +-- (): +-- @id@, @is_partial@, @is_running@, @took@, @timed_out@, and @hits@ +-- (which nests @total@, @events@, @sequences@). Every field is optional: +-- synchronous responses omit @id@\/@is_running@, while async responses +-- (when @wait_for_completion_timeout@ elapses) populate 'eqlId' and leave +-- 'eqlHits' empty until the follow-up @GET /_eql/search\/{id}@. +-- 'eqlIsPartial' is set by the GET endpoint when a search returned partial +-- results (e.g. after a shard failure or a timeout); callers polling for +-- completion should treat @'Just' 'True'@ as terminal rather than +-- retrying. Top-level @total@, @did_timeout@, and @pits@ keys (emitted by +-- later ES versions) are intentionally not modelled here. +data EQLResult a = EQLResult + { eqlId :: Maybe EQLSearchId, + eqlIsRunning :: Maybe Bool, + eqlIsPartial :: Maybe Bool, + eqlTimedOut :: Maybe Bool, + eqlTook :: Maybe Int, + eqlHits :: Maybe (EQLHits a) + } + deriving stock (Eq, Show) + +instance (FromJSON a) => FromJSON (EQLResult a) where + parseJSON (Object v) = + EQLResult + <$> v .:? "id" + <*> v .:? "is_running" + <*> v .:? "is_partial" + <*> v .:? "timed_out" + <*> v .:? "took" + <*> v .:? "hits" + parseJSON x = typeMismatch "EQLResult" x + +eqlIdLens :: Lens' (EQLResult a) (Maybe EQLSearchId) +eqlIdLens = lens eqlId (\x y -> x {eqlId = y}) + +eqlIsRunningLens :: Lens' (EQLResult a) (Maybe Bool) +eqlIsRunningLens = lens eqlIsRunning (\x y -> x {eqlIsRunning = y}) + +-- | See 'eqlIsPartial'. +eqlIsPartialLens :: Lens' (EQLResult a) (Maybe Bool) +eqlIsPartialLens = lens eqlIsPartial (\x y -> x {eqlIsPartial = y}) + +eqlTimedOutLens :: Lens' (EQLResult a) (Maybe Bool) +eqlTimedOutLens = lens eqlTimedOut (\x y -> x {eqlTimedOut = y}) + +eqlTookLens :: Lens' (EQLResult a) (Maybe Int) +eqlTookLens = lens eqlTook (\x y -> x {eqlTook = y}) + +eqlHitsLens :: Lens' (EQLResult a) (Maybe (EQLHits a)) +eqlHitsLens = lens eqlHits (\x y -> x {eqlHits = y}) + +-- | Response body for the EQL status API +-- @GET /_eql/search/status\/{id}@ (Elasticsearch >= 7.10). +-- +-- This lightweight endpoint returns only the status of an async EQL +-- search without fetching the results. When 'eqlStatusIsRunning' is +-- @'Just' 'False'@, 'eqlStatusCompletionStatus' holds the HTTP status +-- code of the completed search (200 on success, 404 if the search +-- found no matching index, etc.). 'eqlStatusStartTimeInMillis' is +-- present for running searches; 'eqlStatusExpirationTimeInMillis' may +-- be present on some server versions. +-- +-- For more information see +-- . +data EQLStatus = EQLStatus + { eqlStatusId :: Maybe EQLSearchId, + eqlStatusIsRunning :: Maybe Bool, + eqlStatusIsPartial :: Maybe Bool, + eqlStatusStartTimeInMillis :: Maybe Int, + eqlStatusCompletionStatus :: Maybe Int, + eqlStatusExpirationTimeInMillis :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON EQLStatus where + parseJSON (Object v) = + EQLStatus + <$> v .:? "id" + <*> v .:? "is_running" + <*> v .:? "is_partial" + <*> v .:? "start_time_in_millis" + <*> v .:? "completion_status" + <*> v .:? "expiration_time_in_millis" + parseJSON x = typeMismatch "EQLStatus" x + +eqlStatusIdLens :: Lens' EQLStatus (Maybe EQLSearchId) +eqlStatusIdLens = lens eqlStatusId (\x y -> x {eqlStatusId = y}) + +eqlStatusIsRunningLens :: Lens' EQLStatus (Maybe Bool) +eqlStatusIsRunningLens = lens eqlStatusIsRunning (\x y -> x {eqlStatusIsRunning = y}) + +eqlStatusIsPartialLens :: Lens' EQLStatus (Maybe Bool) +eqlStatusIsPartialLens = lens eqlStatusIsPartial (\x y -> x {eqlStatusIsPartial = y}) + +eqlStatusStartTimeInMillisLens :: Lens' EQLStatus (Maybe Int) +eqlStatusStartTimeInMillisLens = + lens eqlStatusStartTimeInMillis (\x y -> x {eqlStatusStartTimeInMillis = y}) + +eqlStatusCompletionStatusLens :: Lens' EQLStatus (Maybe Int) +eqlStatusCompletionStatusLens = lens eqlStatusCompletionStatus (\x y -> x {eqlStatusCompletionStatus = y}) + +eqlStatusExpirationTimeInMillisLens :: Lens' EQLStatus (Maybe Int) +eqlStatusExpirationTimeInMillisLens = + lens eqlStatusExpirationTimeInMillis (\x y -> x {eqlStatusExpirationTimeInMillis = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/PointInTime.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/PointInTime.hs --- a/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/PointInTime.hs +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/PointInTime.hs @@ -1,10 +1,39 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.PointInTime +-- +-- Request and response types for the Elasticsearch point-in-time +-- endpoints: @POST \/{index}\/_pit@ (open) and @DELETE \/_pit@ (close). +-- ES9 defines its own open/close variants that additionally surface an +-- @_shards@ summary on open +-- (see "Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.PointInTime"). +-- +-- Elasticsearch only ever documented @POST \/{index}\/_pit@ (open) and +-- @DELETE \/_pit@ (close); there is no list-all PITs endpoint on any ES +-- version (verified live: @GET \/_pit@ returns @405@ on 7.17, 8.19 and +-- 9.4 — see bloodhound-cfv). OpenSearch's @GET \/_search\/point_in_time\/_all@ +-- is unrelated and lives in the OpenSearch2\/3 type modules. +-- +-- See +-- . module Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.PointInTime where import Database.Bloodhound.Internal.Utils.Imports +-- | Response body for @POST /{index}/_pit@ (open point in time) on +-- Elasticsearch 7. The wire shape is a single field: +-- +-- @ +-- { "id": "" } +-- @ +-- +-- ES7 surfaces only the pit id — unlike OpenSearch (which adds @_shards@ +-- and @creation_time@) and ES9 (which adds @_shards@). 'oPitId' maps to +-- the wire @id@ key and is the value to feed into 'ClosePointInTime' or +-- a search's @pit.id@. data OpenPointInTimeResponse = OpenPointInTimeResponse { oPitId :: Text } @@ -21,6 +50,16 @@ parseJSON (Object o) = OpenPointInTimeResponse <$> o .: "id" parseJSON x = typeMismatch "OpenPointInTimeResponse" x +-- | Request body for @DELETE /_pit@ (close point in time) on +-- Elasticsearch 7. The wire shape is a single field: +-- +-- @ +-- { "id": "" } +-- @ +-- +-- The value is a /single/ @id@ string — contrast OpenSearch's +-- ClosePointInTime, whose @pit_id@ is a JSON array even for one pit. +-- 'cPitId' is the value previously obtained from 'OpenPointInTimeResponse'. data ClosePointInTime = ClosePointInTime { cPitId :: Text } @@ -37,6 +76,17 @@ closePointInTimeIdLens :: Lens' ClosePointInTime Text closePointInTimeIdLens = lens cPitId (\x y -> x {cPitId = y}) +-- | Response body for @DELETE /_pit@ (close point in time) on +-- Elasticsearch 7. The wire shape is: +-- +-- @ +-- { "succeeded": \, "num_freed": \ } +-- @ +-- +-- 'succeeded' is whether the close completed for every requested pit; +-- 'numFreed' (wire @num_freed@) is the number of search contexts +-- released. Contrast OpenSearch's ClosePointInTimeResponse, which +-- returns a per-pit @pits@ array instead of an aggregate flag. data ClosePointInTimeResponse = ClosePointInTimeResponse { succeeded :: Bool, numFreed :: Int diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/SyncedFlush.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/SyncedFlush.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/SyncedFlush.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.SyncedFlush +-- License : BSD-style (see the file LICENSE) +-- +-- Types for the deprecated @POST \/{index}/_flush/synced@ endpoint +-- (synced flush), Elasticsearch 7.x only. Synced flush was deprecated in +-- 7.6 and removed in 8.0; a regular flush has the same effect on 7.6+ +-- (see +-- ). +-- Consumers should prefer 'Database.Bloodhound.Common.Requests.flushIndex'. +module Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.SyncedFlush + ( -- * Response types + SyncedFlushResult (..), + SyncedFlushShardGroup (..), + SyncedFlushFailure (..), + + -- * URI parameters + SyncedFlushOptions (..), + defaultSyncedFlushOptions, + syncedFlushOptionsParams, + + -- * Optics + sfrShardsLens, + sfrIndicesLens, + sfsgTotalLens, + sfsgSuccessfulLens, + sfsgFailedLens, + sfsgFailuresLens, + sffShardLens, + sffReasonLens, + sffRoutingLens, + sfoIgnoreUnavailableLens, + sfoAllowNoIndicesLens, + sfoExpandWildcardsLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports (Lens', lens) +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes + ( ShardResult, + ) + +-- | Top-level response of the deprecated @POST \/{index}/_flush/synced@ +-- endpoint. The wire shape is a @_shards@ summary plus one top-level key +-- per concrete index, reporting how many of that index's shards were +-- successfully sync-flushed. Because index names are not statically +-- known, the per-index payload is collected into a 'KeyMap' — exactly +-- the strategy used by 'DiskUsageResponse'. +data SyncedFlushResult = SyncedFlushResult + { -- | Top-level shard execution summary (the canonical @_shards@ + -- envelope). + sfrShards :: ShardResult, + -- | One entry per targeted index, keyed by index name. Built by + -- collecting every top-level key other than @_shards@. + sfrIndices :: KeyMap SyncedFlushShardGroup + } + deriving stock (Eq, Show) + +instance FromJSON SyncedFlushResult where + parseJSON = withObject "SyncedFlushResult" $ \o -> do + shards <- o .: "_shards" + indices <- traverse parseJSON (KM.delete "_shards" o) + pure $ SyncedFlushResult shards indices + +instance ToJSON SyncedFlushResult where + toJSON SyncedFlushResult {..} = + Object $ KM.insert "_shards" (toJSON sfrShards) (toJSON <$> sfrIndices) + +-- | Per-index shard-group outcome of a synced flush. Mirrors the wire +-- shape @{total, successful, failed, failures}@ documented for the +-- synced-flush response (note: the counts sit at the top level of the +-- per-index object, not nested under a @_shards@ key). +data SyncedFlushShardGroup = SyncedFlushShardGroup + { sfsgTotal :: Int, + sfsgSuccessful :: Int, + sfsgFailed :: Int, + -- | Per-shard failure explanations; absent (empty) when every shard + -- sync-flushed cleanly. + sfsgFailures :: [SyncedFlushFailure] + } + deriving stock (Eq, Show) + +instance FromJSON SyncedFlushShardGroup where + parseJSON = withObject "SyncedFlushShardGroup" $ \o -> + SyncedFlushShardGroup + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "failed" .!= 0 + <*> o .:? "failures" .!= [] + +instance ToJSON SyncedFlushShardGroup where + toJSON SyncedFlushShardGroup {..} = + object + [ "total" .= sfsgTotal, + "successful" .= sfsgSuccessful, + "failed" .= sfsgFailed, + "failures" .= sfsgFailures + ] + +-- | A single shard-level failure reported by a synced flush. The +-- @routing@ object carries the shard placement that failed; its full +-- shape (@state@, @primary@, @node@, @relocating_node@, @shard@, +-- @index@) is not statically modelled here because the endpoint is +-- deprecated, so it is preserved verbatim as a JSON 'Value' for +-- round-tripping and inspection. +data SyncedFlushFailure = SyncedFlushFailure + { sffShard :: Int, + sffReason :: Text, + sffRouting :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON SyncedFlushFailure where + parseJSON = withObject "SyncedFlushFailure" $ \o -> + SyncedFlushFailure + <$> o .:? "shard" .!= 0 + <*> o .:? "reason" .!= "" + <*> o .:? "routing" + +instance ToJSON SyncedFlushFailure where + toJSON SyncedFlushFailure {..} = + object $ + catMaybes + [ Just ("shard" .= sffShard), + Just ("reason" .= sffReason), + ("routing" .=) <$> sffRouting + ] + +-- Lenses for SyncedFlushResult + +sfrShardsLens :: Lens' SyncedFlushResult ShardResult +sfrShardsLens = lens sfrShards (\x y -> x {sfrShards = y}) + +sfrIndicesLens :: Lens' SyncedFlushResult (KeyMap SyncedFlushShardGroup) +sfrIndicesLens = lens sfrIndices (\x y -> x {sfrIndices = y}) + +-- Lenses for SyncedFlushShardGroup + +sfsgTotalLens :: Lens' SyncedFlushShardGroup Int +sfsgTotalLens = lens sfsgTotal (\x y -> x {sfsgTotal = y}) + +sfsgSuccessfulLens :: Lens' SyncedFlushShardGroup Int +sfsgSuccessfulLens = lens sfsgSuccessful (\x y -> x {sfsgSuccessful = y}) + +sfsgFailedLens :: Lens' SyncedFlushShardGroup Int +sfsgFailedLens = lens sfsgFailed (\x y -> x {sfsgFailed = y}) + +sfsgFailuresLens :: Lens' SyncedFlushShardGroup [SyncedFlushFailure] +sfsgFailuresLens = lens sfsgFailures (\x y -> x {sfsgFailures = y}) + +-- Lenses for SyncedFlushFailure + +sffShardLens :: Lens' SyncedFlushFailure Int +sffShardLens = lens sffShard (\x y -> x {sffShard = y}) + +sffReasonLens :: Lens' SyncedFlushFailure Text +sffReasonLens = lens sffReason (\x y -> x {sffReason = y}) + +sffRoutingLens :: Lens' SyncedFlushFailure (Maybe Value) +sffRoutingLens = lens sffRouting (\x y -> x {sffRouting = y}) + +-- | URI parameters accepted by @POST \/{index}/_flush/synced@. See +-- . +-- Every field is 'Maybe'; 'defaultSyncedFlushOptions' leaves them all +-- @Nothing@, which emits no query string. +data SyncedFlushOptions = SyncedFlushOptions + { -- | @ignore_unavailable@ — error on missing\/closed indices. + sfoIgnoreUnavailable :: Maybe Bool, + -- | @allow_no_indices@ — short-circuit if no concrete index matches. + sfoAllowNoIndices :: Maybe Bool, + -- | @expand_wildcards@ — wildcard-pattern expansion policy. Reuses + -- the 'ExpandWildcards' sum type shared across the index APIs. + sfoExpandWildcards :: Maybe (NonEmpty ExpandWildcards) + } + deriving stock (Eq, Show) + +-- | 'SyncedFlushOptions' with every field @Nothing@. Emits an empty +-- query string, preserving the wire behaviour of the parameterless +-- @POST \/{index}/_flush/synced@. +defaultSyncedFlushOptions :: SyncedFlushOptions +defaultSyncedFlushOptions = + SyncedFlushOptions + { sfoIgnoreUnavailable = Nothing, + sfoAllowNoIndices = Nothing, + sfoExpandWildcards = Nothing + } + +-- | Render a 'SyncedFlushOptions' record as a @(key, value)@ list +-- suitable for +-- 'Database.Bloodhound.Internal.Client.BHRequest.withQueries'. 'Nothing' +-- fields are omitted, so 'defaultSyncedFlushOptions' produces an empty +-- list (and therefore no query string). +syncedFlushOptionsParams :: SyncedFlushOptions -> [(Text, Maybe Text)] +syncedFlushOptionsParams SyncedFlushOptions {..} = + catMaybes + [ ("ignore_unavailable",) . Just . boolText <$> sfoIgnoreUnavailable, + ("allow_no_indices",) . Just . boolText <$> sfoAllowNoIndices, + ("expand_wildcards",) . Just . renderExpandWildcards <$> sfoExpandWildcards + ] + where + boolText True = "true" + boolText False = "false" + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + +-- Lenses for SyncedFlushOptions + +sfoIgnoreUnavailableLens :: Lens' SyncedFlushOptions (Maybe Bool) +sfoIgnoreUnavailableLens = + lens sfoIgnoreUnavailable (\x y -> x {sfoIgnoreUnavailable = y}) + +sfoAllowNoIndicesLens :: Lens' SyncedFlushOptions (Maybe Bool) +sfoAllowNoIndicesLens = + lens sfoAllowNoIndices (\x y -> x {sfoAllowNoIndices = y}) + +sfoExpandWildcardsLens :: + Lens' SyncedFlushOptions (Maybe (NonEmpty ExpandWildcards)) +sfoExpandWildcardsLens = + lens sfoExpandWildcards (\x y -> x {sfoExpandWildcards = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/TermsEnum.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/TermsEnum.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch7/Types/TermsEnum.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.TermsEnum +-- +-- Request and response types for the @GET \/{index}\/_terms_enum@ +-- endpoint, which returns a list of terms in a field for auto-complete +-- use cases. The endpoint was introduced in Elasticsearch 7.10 and the +-- wire format is identical across ES 7.x, 8.x and 9.x, so the types +-- live here and are re-exported by the ES8 and ES9 type modules. +-- +-- The request carries the @field@ to inspect (required), an optional +-- @string@ prefix, and an optional @search_after@ cursor for paginating +-- beyond the first @size@ terms; the server returns the matching +-- @terms@ (capped at @size@, default 10) together with a @_shards@ +-- summary and a @complete@ flag indicating whether the returned list is +-- exhaustive or truncated (e.g. on timeout). +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.TermsEnum + ( -- * Term value + TermValue (..), + + -- * Request body + TermsEnumRequest (..), + defaultTermsEnumRequest, + + -- * URI parameters + TermsEnumOptions (..), + defaultTermsEnumOptions, + termsEnumOptionsParams, + + -- * Response + TermsEnumResponse (..), + + -- * Optics + termsEnumRequestFieldLens, + termsEnumRequestStringLens, + termsEnumRequestSizeLens, + termsEnumRequestTimeoutLens, + termsEnumRequestCaseInsensitiveLens, + termsEnumRequestIndexFilterLens, + termsEnumRequestSearchAfterLens, + teoAllowNoIndicesLens, + teoExpandWildcardsLens, + teoIgnoreUnavailableLens, + termsEnumResponseShardsLens, + termsEnumResponseTermsLens, + termsEnumResponseCompleteLens, + ) +where + +import Data.Aeson +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( FieldName, + unFieldName, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes + ( ShardResult, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Query (Query) +import Database.Bloodhound.Internal.Versions.Common.Types.Search + ( ExpandWildcards, + expandWildcardsText, + ) +import Optics.Lens + +-- | A single term returned by @/_terms_enum@. The server emits bare +-- JSON strings in the @terms@ array; the newtype keeps them distinct +-- from arbitrary 'Text' at the type level while deriving the trivial +-- 'ToJSON' / 'FromJSON' instances. +newtype TermValue = TermValue {unTermValue :: Text} + deriving stock (Eq, Show, Ord) + deriving newtype (ToJSON, FromJSON) + +-- | Body of @GET /{index}/_terms_enum@. Only @field@ is required; every +-- other field is optional and omitted from the encoded body when +-- 'Nothing'. The @string@ prefix distinguishes 'Nothing' (the key is +-- omitted entirely) from @'Just' ""@ (the key is sent as +-- @"string":""@); the server treats both identically and returns every +-- term up to @size@. The @search_after@ cursor is the last term returned +-- by a previous page; the server returns terms that sort strictly after +-- it, enabling pagination beyond a single @size@-capped response. +data TermsEnumRequest = TermsEnumRequest + { termsEnumRequestField :: FieldName, + termsEnumRequestString :: Maybe Text, + termsEnumRequestSize :: Maybe Int, + termsEnumRequestTimeout :: Maybe Text, + termsEnumRequestCaseInsensitive :: Maybe Bool, + termsEnumRequestIndexFilter :: Maybe Query, + termsEnumRequestSearchAfter :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON TermsEnumRequest where + toJSON req = + object $ + ("field" .= unFieldName (termsEnumRequestField req)) + : catMaybes + [ ("string" .=) <$> termsEnumRequestString req, + ("size" .=) <$> termsEnumRequestSize req, + ("timeout" .=) <$> termsEnumRequestTimeout req, + ("case_insensitive" .=) <$> termsEnumRequestCaseInsensitive req, + ("index_filter" .=) <$> termsEnumRequestIndexFilter req, + ("search_after" .=) <$> termsEnumRequestSearchAfter req + ] + +termsEnumRequestFieldLens :: Lens' TermsEnumRequest FieldName +termsEnumRequestFieldLens = + lens termsEnumRequestField (\x y -> x {termsEnumRequestField = y}) + +termsEnumRequestStringLens :: Lens' TermsEnumRequest (Maybe Text) +termsEnumRequestStringLens = + lens termsEnumRequestString (\x y -> x {termsEnumRequestString = y}) + +termsEnumRequestSizeLens :: Lens' TermsEnumRequest (Maybe Int) +termsEnumRequestSizeLens = + lens termsEnumRequestSize (\x y -> x {termsEnumRequestSize = y}) + +termsEnumRequestTimeoutLens :: Lens' TermsEnumRequest (Maybe Text) +termsEnumRequestTimeoutLens = + lens termsEnumRequestTimeout (\x y -> x {termsEnumRequestTimeout = y}) + +termsEnumRequestCaseInsensitiveLens :: Lens' TermsEnumRequest (Maybe Bool) +termsEnumRequestCaseInsensitiveLens = + lens + termsEnumRequestCaseInsensitive + (\x y -> x {termsEnumRequestCaseInsensitive = y}) + +termsEnumRequestIndexFilterLens :: Lens' TermsEnumRequest (Maybe Query) +termsEnumRequestIndexFilterLens = + lens + termsEnumRequestIndexFilter + (\x y -> x {termsEnumRequestIndexFilter = y}) + +termsEnumRequestSearchAfterLens :: Lens' TermsEnumRequest (Maybe Text) +termsEnumRequestSearchAfterLens = + lens + termsEnumRequestSearchAfter + (\x y -> x {termsEnumRequestSearchAfter = y}) + +-- | 'TermsEnumRequest' carrying only the required @field@. Every +-- optional body field is 'Nothing', so the encoded body is exactly +-- @{"field":""}@. +defaultTermsEnumRequest :: FieldName -> TermsEnumRequest +defaultTermsEnumRequest field = + TermsEnumRequest + { termsEnumRequestField = field, + termsEnumRequestString = Nothing, + termsEnumRequestSize = Nothing, + termsEnumRequestTimeout = Nothing, + termsEnumRequestCaseInsensitive = Nothing, + termsEnumRequestIndexFilter = Nothing, + termsEnumRequestSearchAfter = Nothing + } + +-- | URI parameters accepted by @/{index}/_terms_enum@: +-- @allow_no_indices@, @expand_wildcards@ (comma-joined on the wire) and +-- @ignore_unavailable@. Every field is optional so +-- 'defaultTermsEnumOptions' renders to no query string at all — +-- byte-for-byte identical to a parameterless call. +data TermsEnumOptions = TermsEnumOptions + { teoAllowNoIndices :: Maybe Bool, + teoExpandWildcards :: Maybe [ExpandWildcards], + teoIgnoreUnavailable :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'TermsEnumOptions' with every parameter set to 'Nothing'. Produces +-- no query string, so a call made with this value is byte-identical to +-- a parameterless call. +defaultTermsEnumOptions :: TermsEnumOptions +defaultTermsEnumOptions = + TermsEnumOptions + { teoAllowNoIndices = Nothing, + teoExpandWildcards = Nothing, + teoIgnoreUnavailable = Nothing + } + +teoAllowNoIndicesLens :: Lens' TermsEnumOptions (Maybe Bool) +teoAllowNoIndicesLens = + lens teoAllowNoIndices (\x y -> x {teoAllowNoIndices = y}) + +teoExpandWildcardsLens :: Lens' TermsEnumOptions (Maybe [ExpandWildcards]) +teoExpandWildcardsLens = + lens teoExpandWildcards (\x y -> x {teoExpandWildcards = y}) + +teoIgnoreUnavailableLens :: Lens' TermsEnumOptions (Maybe Bool) +teoIgnoreUnavailableLens = + lens teoIgnoreUnavailable (\x y -> x {teoIgnoreUnavailable = y}) + +-- | Render 'TermsEnumOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultTermsEnumOptions' produces an empty list (and therefore no +-- query string). +termsEnumOptionsParams :: TermsEnumOptions -> [(Text, Maybe Text)] +termsEnumOptionsParams opts = + catMaybes + [ ("allow_no_indices",) . Just . boolText <$> teoAllowNoIndices opts, + ("expand_wildcards",) . Just . renderExpandWildcards <$> teoExpandWildcards opts, + ("ignore_unavailable",) . Just . boolText <$> teoIgnoreUnavailable opts + ] + where + boolText True = "true" + boolText False = "false" + renderExpandWildcards = T.intercalate "," . map expandWildcardsText + +-- | Top-level response body for @/{index}/_terms_enum@. The @_shards@ +-- summary is 'Nothing' when the server omits it (older patch levels) +-- and 'Just' the usual 'ShardResult' otherwise. The @terms@ array is +-- empty — not absent — when no terms match. The @complete@ flag is +-- @false@ when the server truncated the result set (e.g. on timeout or +-- @size@ cap). Real ES responses always include @complete@; the +-- @'.!= False'@ default is a defensive guard against future server +-- shape drift, so a caller that needs to distinguish \"exhaustive\" +-- from \"unknown\" should treat a 'False' read with no @_shards@ as +-- suspect rather than authoritative. +data TermsEnumResponse = TermsEnumResponse + { termsEnumResponseShards :: Maybe ShardResult, + termsEnumResponseTerms :: [TermValue], + termsEnumResponseComplete :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON TermsEnumResponse where + parseJSON = withObject "TermsEnumResponse" $ \o -> + TermsEnumResponse + <$> o .:? "_shards" + <*> o .:? "terms" .!= [] + <*> o .:? "complete" .!= False + +termsEnumResponseShardsLens :: Lens' TermsEnumResponse (Maybe ShardResult) +termsEnumResponseShardsLens = + lens termsEnumResponseShards (\x y -> x {termsEnumResponseShards = y}) + +termsEnumResponseTermsLens :: Lens' TermsEnumResponse [TermValue] +termsEnumResponseTermsLens = + lens termsEnumResponseTerms (\x y -> x {termsEnumResponseTerms = y}) + +termsEnumResponseCompleteLens :: Lens' TermsEnumResponse Bool +termsEnumResponseCompleteLens = + lens termsEnumResponseComplete (\x y -> x {termsEnumResponseComplete = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/BehavioralAnalytics.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/BehavioralAnalytics.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/BehavioralAnalytics.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.BehavioralAnalytics +-- +-- Request and response types for the Behavioral Analytics API +-- (@\/_application\/analytics*@, Elasticsearch 8.7+), which backs the +-- \"Search Curator\"\/ behavioral analytics collection feature used by +-- search applications. A /collection/ is a named sink for client-side +-- search events (searches, clicks, page views); each collection is +-- backed by an Elasticsearch index that the events are written to. +-- +-- The API is ES8-specific (it does not exist in ES7 nor in OpenSearch). +-- +-- Surface covered: +-- +-- * @GET /_application/analytics[\/{name}]@ — list every collection or +-- fetch a single one ('getAnalyticsCollections'). +-- * @PUT /_application/analytics\/{name}@ — create or replace a +-- collection ('putAnalyticsCollection'). +-- * @DELETE /_application/analytics\/{name}@ — delete a collection and +-- its backing index ('deleteAnalyticsCollection'). +-- * @POST /_application/analytics\/{collection_name}\/event\/{event_type}@ — +-- ingest a single behavioral event ('postAnalyticsEvent' / +-- 'postAnalyticsEventWith'). +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.BehavioralAnalytics + ( -- * Identity + AnalyticsCollectionName (..), + unAnalyticsCollectionName, + analyticsCollectionNameLens, + + -- * Event type + AnalyticsEventType (..), + unAnalyticsEventType, + analyticsEventTypeSearch, + analyticsEventTypeSearchClick, + analyticsEventTypePageView, + analyticsEventTypeLens, + + -- * Collection (GET response) + AnalyticsCollection (..), + AnalyticsCollectionsResponse (..), + + -- * PUT response + AnalyticsCollectionPutResponse (..), + analyticsCollectionPutResponseAcknowledgedLens, + analyticsCollectionPutResponseNameLens, + + -- * Event response + AnalyticsEventResponse (..), + analyticsEventResponseAcceptedLens, + analyticsEventResponseEventLens, + + -- * Event URI parameters + AnalyticsEventOptions (..), + defaultAnalyticsEventOptions, + analyticsEventOptionsParams, + analyticsEventOptionsDebugLens, + ) +where + +import Data.Aeson +import Data.Aeson.Key (toText) +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (catMaybes) +import Data.String (IsString) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (Hashable, Lens', lens) + +-- | The @@ path segment of +-- @\/_application\/analytics\/@. A plain opaque identifier with +-- no validation rules; it doubles as the collection's name in the GET +-- response map. +newtype AnalyticsCollectionName = AnalyticsCollectionName Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unAnalyticsCollectionName :: AnalyticsCollectionName -> Text +unAnalyticsCollectionName (AnalyticsCollectionName x) = x + +analyticsCollectionNameLens :: Lens' AnalyticsCollectionName Text +analyticsCollectionNameLens = + lens unAnalyticsCollectionName (\_ y -> AnalyticsCollectionName y) + +-- | The @@ path segment of the event-ingest endpoint. The +-- documented event types are 'analyticsEventTypeSearch', +-- 'analyticsEventTypeSearchClick' and 'analyticsEventTypePageView', but +-- the server accepts any string, so the type wraps 'Text' (with +-- 'IsString') and exposes the known values as smart constructors. +newtype AnalyticsEventType = AnalyticsEventType Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unAnalyticsEventType :: AnalyticsEventType -> Text +unAnalyticsEventType (AnalyticsEventType x) = x + +analyticsEventTypeSearch :: AnalyticsEventType +analyticsEventTypeSearch = AnalyticsEventType "search" + +analyticsEventTypeSearchClick :: AnalyticsEventType +analyticsEventTypeSearchClick = AnalyticsEventType "search_click" + +analyticsEventTypePageView :: AnalyticsEventType +analyticsEventTypePageView = AnalyticsEventType "page_view" + +analyticsEventTypeLens :: Lens' AnalyticsEventType Text +analyticsEventTypeLens = + lens unAnalyticsEventType (\_ y -> AnalyticsEventType y) + +-- | A single behavioral analytics collection, as returned by +-- @GET /_application/analytics[\/{name}]@. The response is a JSON +-- object keyed by collection name; 'acName' carries that key and +-- 'acBody' carries the per-collection definition verbatim (an opaque +-- 'Value', because the collection-definition schema is small but +-- version-evolving — typically just @{\"name\": ...}@). +data AnalyticsCollection = AnalyticsCollection + { acName :: Text, + acBody :: Value + } + deriving stock (Eq, Show) + +-- | Wrapper used to decode the name-keyed map returned by +-- @GET /_application/analytics@. The 'FromJSON' instance walks the +-- top-level object and pairs each key with its value; the request +-- builders unwrap it via 'unAnalyticsCollectionsResponse'. +newtype AnalyticsCollectionsResponse = AnalyticsCollectionsResponse + { unAnalyticsCollectionsResponse :: [AnalyticsCollection] + } + deriving stock (Eq, Show) + +instance FromJSON AnalyticsCollectionsResponse where + parseJSON = withObject "AnalyticsCollectionsResponse" $ \o -> + AnalyticsCollectionsResponse + <$> traverse + ( \(k, v) -> + pure $ AnalyticsCollection (toText k) v + ) + (KM.toList o) + +-- | Response body of @PUT /_application\/analytics\/{name}@ +-- (Elasticsearch 8.7+). The server echoes the @name@ and reports +-- @acknowledged@. +data AnalyticsCollectionPutResponse = AnalyticsCollectionPutResponse + { acprAcknowledged :: Bool, + acprName :: Text + } + deriving stock (Eq, Show) + +instance ToJSON AnalyticsCollectionPutResponse where + toJSON AnalyticsCollectionPutResponse {..} = + object + [ "acknowledged" .= acprAcknowledged, + "name" .= acprName + ] + +instance FromJSON AnalyticsCollectionPutResponse where + parseJSON = withObject "AnalyticsCollectionPutResponse" $ \o -> + AnalyticsCollectionPutResponse + <$> o .:? "acknowledged" .!= False + <*> o .:? "name" .!= "" + +analyticsCollectionPutResponseAcknowledgedLens :: + Lens' AnalyticsCollectionPutResponse Bool +analyticsCollectionPutResponseAcknowledgedLens = + lens acprAcknowledged (\x y -> x {acprAcknowledged = y}) + +analyticsCollectionPutResponseNameLens :: + Lens' AnalyticsCollectionPutResponse Text +analyticsCollectionPutResponseNameLens = + lens acprName (\x y -> x {acprName = y}) + +-- | Response body of +-- @POST /_application/analytics/{collection_name}/event/{event_type}@. +-- @aerAccepted@ is @True@ when the server enqueued the event; +-- @aerEvent@ echoes the stored event payload (an opaque 'Value'). +data AnalyticsEventResponse = AnalyticsEventResponse + { aerAccepted :: Bool, + aerEvent :: Value + } + deriving stock (Eq, Show) + +instance ToJSON AnalyticsEventResponse where + toJSON AnalyticsEventResponse {..} = + object + [ "accepted" .= aerAccepted, + "event" .= aerEvent + ] + +instance FromJSON AnalyticsEventResponse where + parseJSON = withObject "AnalyticsEventResponse" $ \o -> + AnalyticsEventResponse + <$> o .:? "accepted" .!= False + <*> o .:? "event" .!= Null + +analyticsEventResponseAcceptedLens :: Lens' AnalyticsEventResponse Bool +analyticsEventResponseAcceptedLens = + lens aerAccepted (\x y -> x {aerAccepted = y}) + +analyticsEventResponseEventLens :: Lens' AnalyticsEventResponse Value +analyticsEventResponseEventLens = + lens aerEvent (\x y -> x {aerEvent = y}) + +-- | URI parameters accepted by +-- @POST /_application/analytics/{collection_name}/event/{event_type}@. +-- The only documented parameter is @debug@ (boolean): when @Just True@ +-- the server validates the event without persisting it and returns +-- diagnostic detail in 'aerEvent'. +data AnalyticsEventOptions = AnalyticsEventOptions + { aeoDebug :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultAnalyticsEventOptions :: AnalyticsEventOptions +defaultAnalyticsEventOptions = + AnalyticsEventOptions {aeoDebug = Nothing} + +-- | Render 'AnalyticsEventOptions' as a @(key, value)@ list suitable for +-- 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultAnalyticsEventOptions' produces @[]@. +analyticsEventOptionsParams :: AnalyticsEventOptions -> [(Text, Maybe Text)] +analyticsEventOptionsParams AnalyticsEventOptions {..} = + catMaybes + [ ("debug",) . Just . boolText <$> aeoDebug + ] + where + boolText True = "true" + boolText False = "false" + +analyticsEventOptionsDebugLens :: Lens' AnalyticsEventOptions (Maybe Bool) +analyticsEventOptionsDebugLens = + lens aeoDebug (\x y -> x {aeoDebug = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/Connectors.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/Connectors.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/Connectors.hs @@ -0,0 +1,845 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Connectors +-- +-- Request and response types for the Elasticsearch Connectors API +-- (@\/_connector*@, Elasticsearch 8.8+). A /connector/ is the +-- configuration entity the Elastic Connector Framework uses to sync an +-- external data source into an Elasticsearch index; a /connector sync +-- job/ represents a single run of that sync. +-- +-- The API is ES8-specific (it does not exist in ES7 nor — under this +-- path — in OpenSearch, which exposes its own unrelated ML +-- @\/_plugins\/_ml\/connectors@ surface). +-- +-- The response envelopes are deliberately /not/ uniform across the 29 +-- operations, so this module declares a dedicated type per envelope +-- shape rather than one catch-all: +-- +-- * Bare entity (GET) — 'Connector' \/ 'ConnectorSyncJob'. +-- * @{"result": }@ — 'ConnectorMutationResult' (check-in, +-- the 14 @update-*@ ops, sync-job @\/_cancel@). +-- * @{"result", "id"}@ — 'ConnectorCreateResponse' (POST and +-- PUT create). +-- * @{"id"}@ (bare, no result) — 'ConnectorSyncJobCreateResponse'. +-- * @{"acknowledged": true}@ — 'Acknowledged' (DELETE). +-- * @{"count", "results"}@ — 'ConnectorListResponse' \/ +-- 'ConnectorSyncJobListResponse' (GET list). +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Connectors + ( -- * Identity + ConnectorId (..), + unConnectorId, + connectorIdLens, + ConnectorSyncJobId (..), + unConnectorSyncJobId, + connectorSyncJobIdLens, + + -- * Entities (GET responses) + Connector (..), + ConnectorSyncJob (..), + + -- * Envelope responses + ConnectorMutationResult (..), + connectorMutationResultResultLens, + ConnectorCreateResponse (..), + connectorCreateResponseResultLens, + connectorCreateResponseIdLens, + ConnectorSyncJobCreateResponse (..), + connectorSyncJobCreateResponseIdLens, + ConnectorListResponse (..), + connectorListResponseCountLens, + connectorListResponseResultsLens, + ConnectorSyncJobListResponse (..), + connectorSyncJobListResponseCountLens, + connectorSyncJobListResponseResultsLens, + + -- * List query parameters + ConnectorListOptions (..), + defaultConnectorListOptions, + connectorListOptionsParams, + ConnectorSyncJobListOptions (..), + defaultConnectorSyncJobListOptions, + connectorSyncJobListOptionsParams, + + -- * Create / update request bodies + CreateConnectorRequest (..), + defaultCreateConnectorRequest, + UpdateConnectorApiKeyRequest (..), + UpdateConnectorConfigurationRequest (..), + UpdateConnectorErrorRequest (..), + UpdateConnectorFeaturesRequest (..), + UpdateConnectorFilteringRequest (..), + UpdateConnectorFilteringValidationRequest (..), + UpdateConnectorIndexNameRequest (..), + UpdateConnectorNameDescriptionRequest (..), + UpdateConnectorNativeRequest (..), + UpdateConnectorPipelineRequest (..), + UpdateConnectorSchedulingRequest (..), + UpdateConnectorServiceTypeRequest (..), + UpdateConnectorStatusRequest (..), + CreateConnectorSyncJobRequest (..), + ClaimConnectorSyncJobRequest (..), + SetConnectorSyncJobErrorRequest (..), + SetConnectorSyncJobStatsRequest (..), + ) +where + +import Data.Aeson +import Data.Aeson.Key (fromText) +import Data.Aeson.KeyMap (KeyMap) +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (catMaybes) +import Data.String (IsString) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports + ( Hashable, + Lens', + lens, + omitNulls, + showText, + ) + +------------------------------------------------------------------------------ +-- Identity +------------------------------------------------------------------------------ + +-- | The @@ path segment of @\/_connector\/@. +newtype ConnectorId = ConnectorId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unConnectorId :: ConnectorId -> Text +unConnectorId (ConnectorId x) = x + +connectorIdLens :: Lens' ConnectorId Text +connectorIdLens = lens unConnectorId (\_ y -> ConnectorId y) + +-- | The @@ path segment of +-- @\/_connector\/_sync_job\/@. +newtype ConnectorSyncJobId = ConnectorSyncJobId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unConnectorSyncJobId :: ConnectorSyncJobId -> Text +unConnectorSyncJobId (ConnectorSyncJobId x) = x + +connectorSyncJobIdLens :: Lens' ConnectorSyncJobId Text +connectorSyncJobIdLens = + lens unConnectorSyncJobId (\_ y -> ConnectorSyncJobId y) + +------------------------------------------------------------------------------ +-- Entities (bare GET responses) +------------------------------------------------------------------------------ + +-- The stable scalar fields typed out of 'Connector'; everything else +-- (the @configuration@, @filtering@, @pipeline@, @scheduling@, +-- @features@, @custom_scheduling@, @sync_cursor@ sub-objects and the +-- string-or-number timestamp fields) lands in the 'cExtras' +-- forward-compat catch-all. The catch-all keeps the decoder robust to +-- the large and fast-moving connector schema. +connectorKnownKeys :: [Text] +connectorKnownKeys = + [ "id", + "name", + "description", + "index_name", + "is_native", + "language", + "service_type", + "status", + "error", + "api_key_id", + "api_key_secret_id", + "sync_now" + ] + +-- | A connector entity, as returned by @GET /_connector/{id}@. The +-- operationally-useful scalar fields are typed; the complex +-- sub-objects and timestamps land in 'cExtras' as an opaque +-- 'KeyMap'. +data Connector = Connector + { cId :: Maybe Text, + cName :: Maybe Text, + cDescription :: Maybe Text, + cIndexName :: Maybe Text, + cIsNative :: Maybe Bool, + cLanguage :: Maybe Text, + cServiceType :: Maybe Text, + cStatus :: Maybe Text, + cError :: Maybe Text, + cApiKeyId :: Maybe Text, + cApiKeySecretId :: Maybe Text, + cSyncNow :: Maybe Bool, + cExtras :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +instance FromJSON Connector where + parseJSON = withObject "Connector" $ \o -> do + cId <- o .:? "id" + cName <- o .:? "name" + cDescription <- o .:? "description" + cIndexName <- o .:? "index_name" + cIsNative <- o .:? "is_native" + cLanguage <- o .:? "language" + cServiceType <- o .:? "service_type" + cStatus <- o .:? "status" + cError <- o .:? "error" + cApiKeyId <- o .:? "api_key_id" + cApiKeySecretId <- o .:? "api_key_secret_id" + cSyncNow <- o .:? "sync_now" + let cExtras = stripKeys connectorKnownKeys o + pure Connector {..} + +instance ToJSON Connector where + toJSON Connector {..} = + mergeExtras cExtras $ + omitNulls $ + catMaybes + [ ("id",) . toJSON <$> cId, + ("name",) . toJSON <$> cName, + ("description",) . toJSON <$> cDescription, + ("index_name",) . toJSON <$> cIndexName, + ("is_native",) . toJSON <$> cIsNative, + ("language",) . toJSON <$> cLanguage, + ("service_type",) . toJSON <$> cServiceType, + ("status",) . toJSON <$> cStatus, + ("error",) . toJSON <$> cError, + ("api_key_id",) . toJSON <$> cApiKeyId, + ("api_key_secret_id",) . toJSON <$> cApiKeySecretId, + ("sync_now",) . toJSON <$> cSyncNow + ] + +connectorSyncJobKnownKeys :: [Text] +connectorSyncJobKnownKeys = + ["id", "job_type", "trigger_method", "status", "error", "worker_hostname"] + +-- | A connector sync-job entity, as returned by +-- @GET /_connector/_sync_job/{id}@. The stable scalar fields are +-- typed; the @connector@ sub-object, timestamps and per-run counts +-- land in 'csjExtras'. +data ConnectorSyncJob = ConnectorSyncJob + { csjId :: Maybe Text, + csjJobType :: Maybe Text, + csjTriggerMethod :: Maybe Text, + csjStatus :: Maybe Text, + csjError :: Maybe Text, + csjWorkerHostname :: Maybe Text, + csjExtras :: Maybe (KeyMap Value) + } + deriving stock (Eq, Show) + +instance FromJSON ConnectorSyncJob where + parseJSON = withObject "ConnectorSyncJob" $ \o -> do + csjId <- o .:? "id" + csjJobType <- o .:? "job_type" + csjTriggerMethod <- o .:? "trigger_method" + csjStatus <- o .:? "status" + csjError <- o .:? "error" + csjWorkerHostname <- o .:? "worker_hostname" + let csjExtras = stripKeys connectorSyncJobKnownKeys o + pure ConnectorSyncJob {..} + +instance ToJSON ConnectorSyncJob where + toJSON ConnectorSyncJob {..} = + mergeExtras csjExtras $ + omitNulls $ + catMaybes + [ ("id",) . toJSON <$> csjId, + ("job_type",) . toJSON <$> csjJobType, + ("trigger_method",) . toJSON <$> csjTriggerMethod, + ("status",) . toJSON <$> csjStatus, + ("error",) . toJSON <$> csjError, + ("worker_hostname",) . toJSON <$> csjWorkerHostname + ] + +------------------------------------------------------------------------------ +-- Envelope responses +------------------------------------------------------------------------------ + +-- | Response of the connector mutations that return @{"result": }@: +-- 'checkInConnector', every @updateConnector*@ and +-- 'cancelConnectorSyncJob'. The @result@ string is a short status token +-- (e.g. @"created"@, @"updated"@, @"cancelled"@, @"noop"@). +newtype ConnectorMutationResult = ConnectorMutationResult + { cmrResult :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ConnectorMutationResult where + parseJSON = withObject "ConnectorMutationResult" $ \o -> + ConnectorMutationResult <$> o .:? "result" + +instance ToJSON ConnectorMutationResult where + toJSON (ConnectorMutationResult r) = + omitNulls $ catMaybes [("result",) . toJSON <$> r] + +connectorMutationResultResultLens :: + Lens' ConnectorMutationResult (Maybe Text) +connectorMutationResultResultLens = + lens cmrResult (\x y -> x {cmrResult = y}) + +-- | Response of @POST /_connector@ and @PUT /_connector/{id}@ (create). +-- Carries the @result@ status token and the assigned @id@. +data ConnectorCreateResponse = ConnectorCreateResponse + { ccrResult :: Maybe Text, + ccrId :: Maybe ConnectorId + } + deriving stock (Eq, Show) + +instance FromJSON ConnectorCreateResponse where + parseJSON = withObject "ConnectorCreateResponse" $ \o -> + ConnectorCreateResponse + <$> o .:? "result" + <*> (fmap ConnectorId <$> o .:? "id") + +instance ToJSON ConnectorCreateResponse where + toJSON ConnectorCreateResponse {..} = + omitNulls $ + catMaybes + [ ("result",) . toJSON <$> ccrResult, + ("id",) . toJSON <$> ccrId + ] + +connectorCreateResponseResultLens :: + Lens' ConnectorCreateResponse (Maybe Text) +connectorCreateResponseResultLens = + lens ccrResult (\x y -> x {ccrResult = y}) + +connectorCreateResponseIdLens :: + Lens' ConnectorCreateResponse (Maybe ConnectorId) +connectorCreateResponseIdLens = + lens ccrId (\x y -> x {ccrId = y}) + +-- | Response of @POST /_connector/_sync_job@ (create sync job). Unlike +-- 'ConnectorCreateResponse' this is a bare @{"id": ...}@ with no +-- @result@ field — the envelope inconsistency is intentional and +-- documented in the module Haddock. +newtype ConnectorSyncJobCreateResponse = ConnectorSyncJobCreateResponse + { sjcrId :: Maybe ConnectorSyncJobId + } + deriving stock (Eq, Show) + +instance FromJSON ConnectorSyncJobCreateResponse where + parseJSON = withObject "ConnectorSyncJobCreateResponse" $ \o -> + ConnectorSyncJobCreateResponse + <$> (fmap ConnectorSyncJobId <$> o .:? "id") + +instance ToJSON ConnectorSyncJobCreateResponse where + toJSON (ConnectorSyncJobCreateResponse i) = + omitNulls $ catMaybes [("id",) . toJSON <$> i] + +connectorSyncJobCreateResponseIdLens :: + Lens' ConnectorSyncJobCreateResponse (Maybe ConnectorSyncJobId) +connectorSyncJobCreateResponseIdLens = + lens sjcrId (\x y -> x {sjcrId = y}) + +-- | Response of @GET /_connector@ (list all connectors). The server +-- returns a total @count@ and a @results@ array of 'Connector'. +data ConnectorListResponse = ConnectorListResponse + { clrCount :: Maybe Word, + clrResults :: [Connector] + } + deriving stock (Eq, Show) + +instance FromJSON ConnectorListResponse where + parseJSON = withObject "ConnectorListResponse" $ \o -> + ConnectorListResponse + <$> o .:? "count" + <*> o .:? "results" .!= [] + +instance ToJSON ConnectorListResponse where + toJSON ConnectorListResponse {..} = + omitNulls $ + catMaybes + [ ("count",) . toJSON <$> clrCount, + Just ("results" .= clrResults) + ] + +connectorListResponseCountLens :: Lens' ConnectorListResponse (Maybe Word) +connectorListResponseCountLens = + lens clrCount (\x y -> x {clrCount = y}) + +connectorListResponseResultsLens :: + Lens' ConnectorListResponse [Connector] +connectorListResponseResultsLens = + lens clrResults (\x y -> x {clrResults = y}) + +-- | Response of @GET /_connector/_sync_job@ (list all sync jobs). +data ConnectorSyncJobListResponse = ConnectorSyncJobListResponse + { csjlrCount :: Maybe Word, + csjlrResults :: [ConnectorSyncJob] + } + deriving stock (Eq, Show) + +instance FromJSON ConnectorSyncJobListResponse where + parseJSON = withObject "ConnectorSyncJobListResponse" $ \o -> + ConnectorSyncJobListResponse + <$> o .:? "count" + <*> o .:? "results" .!= [] + +instance ToJSON ConnectorSyncJobListResponse where + toJSON ConnectorSyncJobListResponse {..} = + omitNulls $ + catMaybes + [ ("count",) . toJSON <$> csjlrCount, + Just ("results" .= csjlrResults) + ] + +connectorSyncJobListResponseCountLens :: + Lens' ConnectorSyncJobListResponse (Maybe Word) +connectorSyncJobListResponseCountLens = + lens csjlrCount (\x y -> x {csjlrCount = y}) + +connectorSyncJobListResponseResultsLens :: + Lens' ConnectorSyncJobListResponse [ConnectorSyncJob] +connectorSyncJobListResponseResultsLens = + lens csjlrResults (\x y -> x {csjlrResults = y}) + +------------------------------------------------------------------------------ +-- List query parameters +------------------------------------------------------------------------------ + +-- | URI parameters accepted by @GET /_connector@. Every field is +-- 'Maybe'; 'defaultConnectorListOptions' emits no query string. +data ConnectorListOptions = ConnectorListOptions + { cloFrom :: Maybe Word, + cloSize :: Maybe Word, + cloIndexName :: Maybe Text, + cloConnectorName :: Maybe Text, + cloServiceType :: Maybe Text, + cloQuery :: Maybe Text + } + deriving stock (Eq, Show) + +defaultConnectorListOptions :: ConnectorListOptions +defaultConnectorListOptions = + ConnectorListOptions + { cloFrom = Nothing, + cloSize = Nothing, + cloIndexName = Nothing, + cloConnectorName = Nothing, + cloServiceType = Nothing, + cloQuery = Nothing + } + +connectorListOptionsParams :: ConnectorListOptions -> [(Text, Maybe Text)] +connectorListOptionsParams ConnectorListOptions {..} = + catMaybes + [ ("from",) . Just . showText <$> cloFrom, + ("size",) . Just . showText <$> cloSize, + ("index_name",) . Just <$> cloIndexName, + ("connector_name",) . Just <$> cloConnectorName, + ("service_type",) . Just <$> cloServiceType, + ("q",) . Just <$> cloQuery + ] + +-- | URI parameters accepted by @GET /_connector/_sync_job@. +data ConnectorSyncJobListOptions = ConnectorSyncJobListOptions + { csjloFrom :: Maybe Word, + csjloSize :: Maybe Word, + csjloStatus :: Maybe Text, + csjloConnectorId :: Maybe Text, + csjloJobType :: Maybe Text + } + deriving stock (Eq, Show) + +defaultConnectorSyncJobListOptions :: ConnectorSyncJobListOptions +defaultConnectorSyncJobListOptions = + ConnectorSyncJobListOptions + { csjloFrom = Nothing, + csjloSize = Nothing, + csjloStatus = Nothing, + csjloConnectorId = Nothing, + csjloJobType = Nothing + } + +connectorSyncJobListOptionsParams :: + ConnectorSyncJobListOptions -> [(Text, Maybe Text)] +connectorSyncJobListOptionsParams ConnectorSyncJobListOptions {..} = + catMaybes + [ ("from",) . Just . showText <$> csjloFrom, + ("size",) . Just . showText <$> csjloSize, + ("status",) . Just <$> csjloStatus, + ("connector_id",) . Just <$> csjloConnectorId, + ("job_type",) . Just <$> csjloJobType + ] + +------------------------------------------------------------------------------ +-- Create / update request bodies +------------------------------------------------------------------------------ + +-- | Request body of @POST /_connector@ and @PUT /_connector/{id}@ +-- (create or full replace). Every field is optional — the server mints +-- defaults — but a useful connector typically sets at least 'ccrName', +-- 'ccrIndexName' and 'ccrServiceType'. +data CreateConnectorRequest = CreateConnectorRequest + { ccrDescription :: Maybe Text, + ccrIndexName :: Maybe Text, + ccrIsNative :: Maybe Bool, + ccrLanguage :: Maybe Text, + ccrName :: Maybe Text, + ccrServiceType :: Maybe Text + } + deriving stock (Eq, Show) + +defaultCreateConnectorRequest :: CreateConnectorRequest +defaultCreateConnectorRequest = + CreateConnectorRequest + { ccrDescription = Nothing, + ccrIndexName = Nothing, + ccrIsNative = Nothing, + ccrLanguage = Nothing, + ccrName = Nothing, + ccrServiceType = Nothing + } + +instance ToJSON CreateConnectorRequest where + toJSON CreateConnectorRequest {..} = + omitNulls + [ "description" .= ccrDescription, + "index_name" .= ccrIndexName, + "is_native" .= ccrIsNative, + "language" .= ccrLanguage, + "name" .= ccrName, + "service_type" .= ccrServiceType + ] + +instance FromJSON CreateConnectorRequest where + parseJSON = withObject "CreateConnectorRequest" $ \o -> + CreateConnectorRequest + <$> o .:? "description" + <*> o .:? "index_name" + <*> o .:? "is_native" + <*> o .:? "language" + <*> o .:? "name" + <*> o .:? "service_type" + +-- | Body of @PUT /_connector/{id}/_api_key_id@. +data UpdateConnectorApiKeyRequest = UpdateConnectorApiKeyRequest + { uakrApiKeyId :: Maybe Text, + uakrApiKeySecretId :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorApiKeyRequest where + toJSON UpdateConnectorApiKeyRequest {..} = + omitNulls + [ "api_key_id" .= uakrApiKeyId, + "api_key_secret_id" .= uakrApiKeySecretId + ] + +instance FromJSON UpdateConnectorApiKeyRequest where + parseJSON = withObject "UpdateConnectorApiKeyRequest" $ \o -> + UpdateConnectorApiKeyRequest + <$> o .:? "api_key_id" + <*> o .:? "api_key_secret_id" + +-- | Body of @PUT /_connector/{id}/_configuration@. The +-- @configuration@ \/ @values@ sub-objects are connector-specific and +-- version-evolving, so they are carried as opaque 'Value'. +data UpdateConnectorConfigurationRequest = UpdateConnectorConfigurationRequest + { ucrConfiguration :: Maybe Value, + ucrValues :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorConfigurationRequest where + toJSON UpdateConnectorConfigurationRequest {..} = + omitNulls + [ "configuration" .= ucrConfiguration, + "values" .= ucrValues + ] + +instance FromJSON UpdateConnectorConfigurationRequest where + parseJSON = withObject "UpdateConnectorConfigurationRequest" $ \o -> + UpdateConnectorConfigurationRequest + <$> o .:? "configuration" + <*> o .:? "values" + +-- | Body of @PUT /_connector/{id}/_error@. A non-null 'uerError' flips +-- the connector status to @error@; 'Nothing' (encoded as JSON null on +-- the wire by the builder) clears it and flips the status to +-- @connected@. +newtype UpdateConnectorErrorRequest = UpdateConnectorErrorRequest + { uerError :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorErrorRequest where + toJSON (UpdateConnectorErrorRequest e) = object ["error" .= e] + +instance FromJSON UpdateConnectorErrorRequest where + parseJSON = withObject "UpdateConnectorErrorRequest" $ \o -> + UpdateConnectorErrorRequest <$> o .:? "error" + +-- | Body of @PUT /_connector/{id}/_features@. The @features@ object +-- (DLS, incremental, sync-rule overrides) is opaque 'Value'. +newtype UpdateConnectorFeaturesRequest = UpdateConnectorFeaturesRequest + { ufrFeatures :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorFeaturesRequest where + toJSON (UpdateConnectorFeaturesRequest f) = object ["features" .= f] + +instance FromJSON UpdateConnectorFeaturesRequest where + parseJSON = withObject "UpdateConnectorFeaturesRequest" $ \o -> + UpdateConnectorFeaturesRequest <$> o .:? "features" + +-- | Body of @PUT /_connector/{id}/_filtering@. The draft filtering +-- arrays (basic + advanced sync rules) are opaque 'Value'. +data UpdateConnectorFilteringRequest = UpdateConnectorFilteringRequest + { uflrFiltering :: Maybe Value, + uflrRules :: Maybe Value, + uflrAdvancedSnippet :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorFilteringRequest where + toJSON UpdateConnectorFilteringRequest {..} = + omitNulls + [ "filtering" .= uflrFiltering, + "rules" .= uflrRules, + "advanced_snippet" .= uflrAdvancedSnippet + ] + +instance FromJSON UpdateConnectorFilteringRequest where + parseJSON = withObject "UpdateConnectorFilteringRequest" $ \o -> + UpdateConnectorFilteringRequest + <$> o .:? "filtering" + <*> o .:? "rules" + <*> o .:? "advanced_snippet" + +-- | Body of @PUT /_connector/{id}/_filtering/_validation@. The draft +-- filtering validation object is opaque 'Value'. +newtype UpdateConnectorFilteringValidationRequest = UpdateConnectorFilteringValidationRequest + { ucvrValidation :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorFilteringValidationRequest where + toJSON (UpdateConnectorFilteringValidationRequest v) = + object ["validation" .= v] + +instance FromJSON UpdateConnectorFilteringValidationRequest where + parseJSON = withObject "UpdateConnectorFilteringValidationRequest" $ \o -> + UpdateConnectorFilteringValidationRequest <$> o .:? "validation" + +-- | Body of @PUT /_connector/{id}/_index_name@. 'Nothing' clears the +-- destination index. +newtype UpdateConnectorIndexNameRequest = UpdateConnectorIndexNameRequest + { uinrIndexName :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorIndexNameRequest where + toJSON (UpdateConnectorIndexNameRequest n) = object ["index_name" .= n] + +instance FromJSON UpdateConnectorIndexNameRequest where + parseJSON = withObject "UpdateConnectorIndexNameRequest" $ \o -> + UpdateConnectorIndexNameRequest <$> o .:? "index_name" + +-- | Body of @PUT /_connector/{id}/_name@. +data UpdateConnectorNameDescriptionRequest = UpdateConnectorNameDescriptionRequest + { undrName :: Maybe Text, + undrDescription :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorNameDescriptionRequest where + toJSON UpdateConnectorNameDescriptionRequest {..} = + omitNulls + [ "name" .= undrName, + "description" .= undrDescription + ] + +instance FromJSON UpdateConnectorNameDescriptionRequest where + parseJSON = withObject "UpdateConnectorNameDescriptionRequest" $ \o -> + UpdateConnectorNameDescriptionRequest + <$> o .:? "name" + <*> o .:? "description" + +-- | Body of @PUT /_connector/{id}/_native@. +newtype UpdateConnectorNativeRequest = UpdateConnectorNativeRequest + { unrIsNative :: Maybe Bool + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorNativeRequest where + toJSON (UpdateConnectorNativeRequest n) = object ["is_native" .= n] + +instance FromJSON UpdateConnectorNativeRequest where + parseJSON = withObject "UpdateConnectorNativeRequest" $ \o -> + UpdateConnectorNativeRequest <$> o .:? "is_native" + +-- | Body of @PUT /_connector/{id}/_pipeline@. The ingest pipeline +-- definition is opaque 'Value'. +newtype UpdateConnectorPipelineRequest = UpdateConnectorPipelineRequest + { uprPipeline :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorPipelineRequest where + toJSON (UpdateConnectorPipelineRequest p) = object ["pipeline" .= p] + +instance FromJSON UpdateConnectorPipelineRequest where + parseJSON = withObject "UpdateConnectorPipelineRequest" $ \o -> + UpdateConnectorPipelineRequest <$> o .:? "pipeline" + +-- | Body of @PUT /_connector/{id}/_scheduling@. The scheduling object +-- is opaque 'Value'. +newtype UpdateConnectorSchedulingRequest = UpdateConnectorSchedulingRequest + { usrScheduling :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorSchedulingRequest where + toJSON (UpdateConnectorSchedulingRequest s) = object ["scheduling" .= s] + +instance FromJSON UpdateConnectorSchedulingRequest where + parseJSON = withObject "UpdateConnectorSchedulingRequest" $ \o -> + UpdateConnectorSchedulingRequest <$> o .:? "scheduling" + +-- | Body of @PUT /_connector/{id}/_service_type@. +newtype UpdateConnectorServiceTypeRequest = UpdateConnectorServiceTypeRequest + { ustrServiceType :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorServiceTypeRequest where + toJSON (UpdateConnectorServiceTypeRequest s) = + object ["service_type" .= s] + +instance FromJSON UpdateConnectorServiceTypeRequest where + parseJSON = withObject "UpdateConnectorServiceTypeRequest" $ \o -> + UpdateConnectorServiceTypeRequest <$> o .:? "service_type" + +-- | Body of @PUT /_connector/{id}/_status@. +newtype UpdateConnectorStatusRequest = UpdateConnectorStatusRequest + { ustr2Status :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON UpdateConnectorStatusRequest where + toJSON (UpdateConnectorStatusRequest s) = object ["status" .= s] + +instance FromJSON UpdateConnectorStatusRequest where + parseJSON = withObject "UpdateConnectorStatusRequest" $ \o -> + UpdateConnectorStatusRequest <$> o .:? "status" + +-- | Body of @POST /_connector/_sync_job@ (create sync job). The +-- @id@ names the connector to run, @job_type@ selects @full@, +-- @incremental@ or @access_control@, and @trigger_method@ is +-- @scheduled@ or @on_demand@. +data CreateConnectorSyncJobRequest = CreateConnectorSyncJobRequest + { csjrId :: Maybe Text, + csjrJobType :: Maybe Text, + csjrTriggerMethod :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON CreateConnectorSyncJobRequest where + toJSON CreateConnectorSyncJobRequest {..} = + omitNulls + [ "id" .= csjrId, + "job_type" .= csjrJobType, + "trigger_method" .= csjrTriggerMethod + ] + +instance FromJSON CreateConnectorSyncJobRequest where + parseJSON = withObject "CreateConnectorSyncJobRequest" $ \o -> + CreateConnectorSyncJobRequest + <$> o .:? "id" + <*> o .:? "job_type" + <*> o .:? "trigger_method" + +-- | Body of @PUT /_connector/_sync_job/{id}/_claim@. +data ClaimConnectorSyncJobRequest = ClaimConnectorSyncJobRequest + { csrSyncCursor :: Maybe Value, + csrWorkerHostname :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON ClaimConnectorSyncJobRequest where + toJSON ClaimConnectorSyncJobRequest {..} = + omitNulls + [ "sync_cursor" .= csrSyncCursor, + "worker_hostname" .= csrWorkerHostname + ] + +instance FromJSON ClaimConnectorSyncJobRequest where + parseJSON = withObject "ClaimConnectorSyncJobRequest" $ \o -> + ClaimConnectorSyncJobRequest + <$> o .:? "sync_cursor" + <*> o .:? "worker_hostname" + +-- | Body of @PUT /_connector/_sync_job/{id}/_error@. +newtype SetConnectorSyncJobErrorRequest = SetConnectorSyncJobErrorRequest + { ssjerError :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON SetConnectorSyncJobErrorRequest where + toJSON (SetConnectorSyncJobErrorRequest e) = object ["error" .= e] + +instance FromJSON SetConnectorSyncJobErrorRequest where + parseJSON = withObject "SetConnectorSyncJobErrorRequest" $ \o -> + SetConnectorSyncJobErrorRequest <$> o .:? "error" + +-- | Body of @PUT /_connector/_sync_job/{id}/_stats@. Every field is +-- optional; the server updates only the supplied counters. The +-- @last_seen@ and @metadata@ fields are opaque 'Value' (their shape is +-- connector-specific). +data SetConnectorSyncJobStatsRequest = SetConnectorSyncJobStatsRequest + { ssjsrDeletedDocumentCount :: Maybe Word, + ssjsrIndexedDocumentCount :: Maybe Word, + ssjsrIndexedDocumentVolume :: Maybe Word, + ssjsrTotalDocumentCount :: Maybe Word, + ssjsrLastSeen :: Maybe Value, + ssjsrMetadata :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON SetConnectorSyncJobStatsRequest where + toJSON SetConnectorSyncJobStatsRequest {..} = + omitNulls + [ "deleted_document_count" .= ssjsrDeletedDocumentCount, + "indexed_document_count" .= ssjsrIndexedDocumentCount, + "indexed_document_volume" .= ssjsrIndexedDocumentVolume, + "total_document_count" .= ssjsrTotalDocumentCount, + "last_seen" .= ssjsrLastSeen, + "metadata" .= ssjsrMetadata + ] + +instance FromJSON SetConnectorSyncJobStatsRequest where + parseJSON = withObject "SetConnectorSyncJobStatsRequest" $ \o -> + SetConnectorSyncJobStatsRequest + <$> o .:? "deleted_document_count" + <*> o .:? "indexed_document_count" + <*> o .:? "indexed_document_volume" + <*> o .:? "total_document_count" + <*> o .:? "last_seen" + <*> o .:? "metadata" + +------------------------------------------------------------------------------ +-- Helpers (forward-compat catch-all, mirroring the Watcher module) +------------------------------------------------------------------------------ + +stripKeys :: [Text] -> KeyMap Value -> Maybe (KeyMap Value) +stripKeys keys km = + let stripped = foldr (KM.delete . fromText) km keys + in if KM.null stripped then Nothing else Just stripped + +mergeExtras :: Maybe (KeyMap Value) -> Value -> Value +mergeExtras Nothing base = base +mergeExtras (Just extras) (Object base) = + Object (KM.union base extras) +mergeExtras _ base = base diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/EsQueryLanguage.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/EsQueryLanguage.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/EsQueryLanguage.hs @@ -0,0 +1,996 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.EsQueryLanguage + ( ESQLRequest (..), + ESQLResult (..), + ESQLColumn (..), + AsyncESQLRequest (..), + mkAsyncESQLRequest, + AsyncESQLId (..), + AsyncESQLResult (..), + ESQLQueryOptions (..), + defaultESQLQueryOptions, + esqlOptionsParams, + GetAsyncESQLOptions (..), + defaultGetAsyncESQLOptions, + getAsyncESQLOptionsParams, + EsqlClusters (..), + EsqlClusterDetails (..), + EsqlClusterStatus (..), + esqlClusterStatusToText, + esqlClusterStatusFromText, + EsqlProfile (..), + EsqlProfileSection (..), + esqlQueryLens, + esqlLocaleLens, + esqlFilterLens, + esqlParamsLens, + esqlColumnarLens, + esqlProfileLens, + esqlTablesLens, + esqlIncludeCcsMetadataLens, + esqlIsPartialLens, + esqlAllColumnsLens, + esqlClustersLens, + esqlProfileValueLens, + esqlColumnsLens, + esqlValuesLens, + esqlTookLens, + esqlColumnNameLens, + esqlColumnTypeLens, + esqlClustersTotalLens, + esqlClustersSuccessfulLens, + esqlClustersRunningLens, + esqlClustersSkippedLens, + esqlClustersPartialLens, + esqlClustersFailedLens, + esqlClustersDetailsLens, + esqlClustersOtherLens, + esqlClusterDetailsStatusLens, + esqlClusterDetailsIndicesLens, + esqlClusterDetailsShardsLens, + esqlClusterDetailsFailuresLens, + esqlClusterDetailsOtherLens, + esqlProfileShardsLens, + esqlProfileProfilesLens, + esqlProfileOtherLens, + esqlProfileSectionPhaseLens, + esqlProfileSectionDescriptionLens, + esqlProfileSectionTimeLens, + esqlProfileSectionChildrenLens, + esqlProfileSectionOtherLens, + asyncESQLRequestBaseLens, + asyncESQLRequestWaitForCompletionTimeoutLens, + asyncESQLRequestKeepAliveLens, + asyncESQLRequestKeepOnCompletionLens, + esqloDelimiterLens, + esqloDropNullColumnsLens, + esqloAllowPartialResultsLens, + gaesqloWaitForCompletionTimeoutLens, + gaesqloKeepAliveLens, + gaesqloDropNullColumnsLens, + asyncESQLIdLens, + asyncESQLResultIdLens, + asyncESQLResultIsRunningLens, + asyncESQLResultIsPartialLens, + asyncESQLResultStartTimeInMillisLens, + asyncESQLResultExpirationTimeInMillisLens, + asyncESQLResultCompletionTimeInMillisLens, + asyncESQLResultTookLens, + asyncESQLResultDocumentsFoundLens, + asyncESQLResultValuesLoadedLens, + asyncESQLResultColumnsLens, + asyncESQLResultValuesLens, + asyncESQLResultClustersLens, + asyncESQLResultProfileLens, + ) +where + +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap (union) +import Data.Aeson.KeyMap qualified as KM +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes (ShardResult) +import Database.Bloodhound.Internal.Versions.Common.Types.Query (Filter) + +-- | Request body for the ES|QL @POST /_query@ API (Elasticsearch 8.11+). +-- +-- Only 'esqlQuery' is required; it holds the ES|QL pipe-language source +-- (e.g. @"FROM logs | LIMIT 10"@). Optional fields are forwarded verbatim +-- to the server and rendered as JSON @null@-dropped keys. +-- +-- The fields 'esqlColumnar', 'esqlProfile' and 'esqlIncludeCcsMetadata' +-- are also accepted by the async @POST /_query/async@ endpoint; they live +-- here (on the base request) rather than on 'AsyncESQLRequest' so the +-- async builder can simply forward them via 'asyncESQLRequestBase'. +-- +-- @field_multi_value_leniency@ was previously modelled here but is not +-- present in the current ES docs (deprecated\/removed); it has been +-- dropped. Callers that previously set it can simply omit it. +-- +-- The ES9-only body fields @time_zone@ (ES 9.4+) and +-- @include_execution_metadata@ are not modelled here; they live on the +-- ES9-specific request type in +-- "Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.EsQueryLanguage". +-- +-- For more information see +-- . +data ESQLRequest = ESQLRequest + { esqlQuery :: Text, + esqlLocale :: Maybe Text, + esqlFilter :: Maybe Filter, + esqlParams :: Maybe [Value], + -- | @columnar@ — request columnar rather than row-oriented @values@ + -- in the response. Also honoured by the async endpoint. + esqlColumnar :: Maybe Bool, + -- | @profile@ — when @'Just' 'True'@ the response carries a @profile@ + -- object (an opaque aeson 'Value' on the async result type). Also + -- honoured by the async endpoint. + esqlProfile :: Maybe Bool, + -- | @tables@ — LOOKUP join tables (ES 8.18+), an opaque JSON object + -- mapping table names to row arrays. Encoded verbatim. + esqlTables :: Maybe Value, + -- | @include_ccs_metadata@ — include cross-cluster search metadata in + -- the response when applicable. Also honoured by the async endpoint. + esqlIncludeCcsMetadata :: Maybe Bool + } + deriving stock (Eq, Show) + +instance ToJSON ESQLRequest where + toJSON ESQLRequest {..} = + omitNulls + [ "query" .= esqlQuery, + "locale" .= esqlLocale, + "filter" .= esqlFilter, + "params" .= esqlParams, + "columnar" .= esqlColumnar, + "profile" .= esqlProfile, + "tables" .= esqlTables, + "include_ccs_metadata" .= esqlIncludeCcsMetadata + ] + +instance FromJSON ESQLRequest where + parseJSON (Object o) = + ESQLRequest + <$> o .: "query" + <*> o .:? "locale" + <*> o .:? "filter" + <*> o .:? "params" + <*> o .:? "columnar" + <*> o .:? "profile" + <*> o .:? "tables" + <*> o .:? "include_ccs_metadata" + parseJSON x = typeMismatch "ESQLRequest" x + +esqlQueryLens :: Lens' ESQLRequest Text +esqlQueryLens = lens esqlQuery (\x y -> x {esqlQuery = y}) + +esqlLocaleLens :: Lens' ESQLRequest (Maybe Text) +esqlLocaleLens = lens esqlLocale (\x y -> x {esqlLocale = y}) + +esqlFilterLens :: Lens' ESQLRequest (Maybe Filter) +esqlFilterLens = lens esqlFilter (\x y -> x {esqlFilter = y}) + +esqlParamsLens :: Lens' ESQLRequest (Maybe [Value]) +esqlParamsLens = lens esqlParams (\x y -> x {esqlParams = y}) + +esqlColumnarLens :: Lens' ESQLRequest (Maybe Bool) +esqlColumnarLens = lens esqlColumnar (\x y -> x {esqlColumnar = y}) + +esqlProfileLens :: Lens' ESQLRequest (Maybe Bool) +esqlProfileLens = lens esqlProfile (\x y -> x {esqlProfile = y}) + +esqlTablesLens :: Lens' ESQLRequest (Maybe Value) +esqlTablesLens = lens esqlTables (\x y -> x {esqlTables = y}) + +esqlIncludeCcsMetadataLens :: Lens' ESQLRequest (Maybe Bool) +esqlIncludeCcsMetadataLens = + lens esqlIncludeCcsMetadata (\x y -> x {esqlIncludeCcsMetadata = y}) + +-- | Column descriptor in an 'ESQLResult'. The server emits a @type@ string +-- such as @"long"@, @"keyword"@, @"text"@, @"double"@, @"date"@, etc. +data ESQLColumn = ESQLColumn + { esqlColumnName :: Text, + esqlColumnType :: Text + } + deriving stock (Eq, Show) + +instance ToJSON ESQLColumn where + toJSON ESQLColumn {..} = + object + [ "name" .= esqlColumnName, + "type" .= esqlColumnType + ] + +instance FromJSON ESQLColumn where + parseJSON (Object o) = + ESQLColumn + <$> o .: "name" + <*> o .: "type" + parseJSON x = typeMismatch "ESQLColumn" x + +esqlColumnNameLens :: Lens' ESQLColumn Text +esqlColumnNameLens = lens esqlColumnName (\x y -> x {esqlColumnName = y}) + +esqlColumnTypeLens :: Lens' ESQLColumn Text +esqlColumnTypeLens = lens esqlColumnType (\x y -> x {esqlColumnType = y}) + +-- | Response body for the ES|QL @POST /_query@ API. +-- +-- Mirrors the Elasticsearch @esql._types.EsqlResult@ spec, whose required +-- keys are @columns@ and @values@; the remaining fields are present on +-- every observed synchronous response but are decoded leniently where the +-- spec allows absence. The phantom @total_rows@ and @is_running@ keys the +-- binding previously carried are gone: ES never emits @total_rows@ on this +-- endpoint, and @is_running@ is meaningful only on the async +-- 'AsyncESQLResult' shape (it is always @false@ on a completed synchronous +-- response, so modelling it just hid a constant). +-- +-- * @is_partial@ — @true@ when the query returned a partial result set +-- (e.g. a shard was unavailable and @allow_partial_results@ was set). +-- Strict: the server always emits it on the synchronous endpoint. +-- * @all_columns@ — @true@ when the @columns@ array reflects every column +-- the query produced (no @drop_null_columns@ pruning was applied). +-- * @_clusters@ — cross-cluster search summary. Typed as 'EsqlClusters' +-- (six counters plus a per-cluster @details@ map); any future keys ES +-- adds to the top-level object survive a round trip via +-- 'esqlClustersOther'. +-- * @profile@ — execution profile; present only when the request set +-- 'esqlProfile' to @'Just' 'True'@. Kept as the field name +-- @esqlProfileValue@ (and lens 'esqlProfileValueLens') to avoid clashing +-- with 'esqlProfile' / 'esqlProfileLens' (the request-side flag) in this module. +-- ES marks the inner shape as currently unstable; 'EsqlProfile' exposes the +-- documented Lucene-profile projections (@shards@, @profiles[]@) and +-- captures everything else verbatim in 'esqlProfileOther'. +data ESQLResult = ESQLResult + { esqlIsPartial :: Bool, + esqlAllColumns :: Maybe Bool, + esqlColumns :: [ESQLColumn], + esqlValues :: [[Value]], + esqlClusters :: Maybe EsqlClusters, + esqlProfileValue :: Maybe EsqlProfile, + esqlTook :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON ESQLResult where + toJSON ESQLResult {..} = + omitNulls + [ "is_partial" .= esqlIsPartial, + "all_columns" .= esqlAllColumns, + "columns" .= esqlColumns, + "values" .= esqlValues, + "_clusters" .= esqlClusters, + "profile" .= esqlProfileValue, + "took" .= esqlTook + ] + +instance FromJSON ESQLResult where + parseJSON (Object o) = + ESQLResult + <$> o .: "is_partial" + <*> o .:? "all_columns" + <*> o .: "columns" + <*> o .: "values" + <*> o .:? "_clusters" + <*> o .:? "profile" + <*> o .:? "took" + parseJSON x = typeMismatch "ESQLResult" x + +esqlIsPartialLens :: Lens' ESQLResult Bool +esqlIsPartialLens = lens esqlIsPartial (\x y -> x {esqlIsPartial = y}) + +esqlAllColumnsLens :: Lens' ESQLResult (Maybe Bool) +esqlAllColumnsLens = lens esqlAllColumns (\x y -> x {esqlAllColumns = y}) + +esqlColumnsLens :: Lens' ESQLResult [ESQLColumn] +esqlColumnsLens = lens esqlColumns (\x y -> x {esqlColumns = y}) + +esqlValuesLens :: Lens' ESQLResult [[Value]] +esqlValuesLens = lens esqlValues (\x y -> x {esqlValues = y}) + +esqlClustersLens :: Lens' ESQLResult (Maybe EsqlClusters) +esqlClustersLens = lens esqlClusters (\x y -> x {esqlClusters = y}) + +esqlProfileValueLens :: Lens' ESQLResult (Maybe EsqlProfile) +esqlProfileValueLens = lens esqlProfileValue (\x y -> x {esqlProfileValue = y}) + +esqlTookLens :: Lens' ESQLResult (Maybe Int) +esqlTookLens = lens esqlTook (\x y -> x {esqlTook = y}) + +-- | Request body for the async ES|QL @POST /_query/async@ API +-- (Elasticsearch 8.11+, identical wire format in ES9). +-- +-- Wraps a regular 'ESQLRequest' with the async-only body parameters ES +-- accepts on this endpoint. The synchronous @POST /_query@ endpoint +-- rejects these keys, which is why they live here rather than on +-- 'ESQLRequest' itself. +-- +-- * @wait_for_completion_timeout@ — duration string (e.g. @"5s"@) the +-- server waits before either returning the completed result or +-- deferring and returning only an 'AsyncESQLId' to poll. 'Nothing' +-- uses the server default (currently @1s@). +-- * @keep_alive@ — duration string (e.g. @"10d"@) controlling how long +-- the stored result remains retrievable after the query completes. +-- 'Nothing' uses the server default (currently 5 days). +-- * @keep_on_completion@ — when @'Just' 'True'@ the result is stored +-- even if the query finished synchronously within +-- @wait_for_completion_timeout@. +-- +-- The @columnar@, @profile@ and @include_ccs_metadata@ parameters are +-- accepted by /both/ endpoints and therefore live on the base +-- 'ESQLRequest'; set them there and they are forwarded automatically +-- when the async builder encodes the merged body. Note that the encoder +-- forwards /every/ base field verbatim, so fields not documented for the +-- async endpoint (e.g. 'esqlTables') are the caller's responsibility — +-- leave them 'Nothing' for async use. +-- +-- For more information see +-- . +data AsyncESQLRequest = AsyncESQLRequest + { asyncESQLRequestBase :: ESQLRequest, + asyncESQLRequestWaitForCompletionTimeout :: Maybe Text, + asyncESQLRequestKeepAlive :: Maybe Text, + asyncESQLRequestKeepOnCompletion :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | Smart constructor that promotes a plain 'ESQLRequest' to an +-- 'AsyncESQLRequest' with every async-only field defaulted to +-- 'Nothing' (use the record-update syntax or the @*@Lens setters to +-- populate them). +mkAsyncESQLRequest :: ESQLRequest -> AsyncESQLRequest +mkAsyncESQLRequest base = + AsyncESQLRequest + { asyncESQLRequestBase = base, + asyncESQLRequestWaitForCompletionTimeout = Nothing, + asyncESQLRequestKeepAlive = Nothing, + asyncESQLRequestKeepOnCompletion = Nothing + } + +instance ToJSON AsyncESQLRequest where + toJSON areq = + case toJSON (asyncESQLRequestBase areq) of + Object baseObj -> Object (baseObj `union` asyncFields) + other -> other + where + asyncFields = + omitNullsKeyMap + [ "wait_for_completion_timeout" .= asyncESQLRequestWaitForCompletionTimeout areq, + "keep_alive" .= asyncESQLRequestKeepAlive areq, + "keep_on_completion" .= asyncESQLRequestKeepOnCompletion areq + ] + +instance FromJSON AsyncESQLRequest where + parseJSON (Object o) = + AsyncESQLRequest + <$> parseJSON (Object o) + <*> o .:? "wait_for_completion_timeout" + <*> o .:? "keep_alive" + <*> o .:? "keep_on_completion" + parseJSON x = typeMismatch "AsyncESQLRequest" x + +asyncESQLRequestBaseLens :: Lens' AsyncESQLRequest ESQLRequest +asyncESQLRequestBaseLens = + lens asyncESQLRequestBase (\x y -> x {asyncESQLRequestBase = y}) + +asyncESQLRequestWaitForCompletionTimeoutLens :: Lens' AsyncESQLRequest (Maybe Text) +asyncESQLRequestWaitForCompletionTimeoutLens = + lens + asyncESQLRequestWaitForCompletionTimeout + (\x y -> x {asyncESQLRequestWaitForCompletionTimeout = y}) + +asyncESQLRequestKeepAliveLens :: Lens' AsyncESQLRequest (Maybe Text) +asyncESQLRequestKeepAliveLens = + lens asyncESQLRequestKeepAlive (\x y -> x {asyncESQLRequestKeepAlive = y}) + +asyncESQLRequestKeepOnCompletionLens :: Lens' AsyncESQLRequest (Maybe Bool) +asyncESQLRequestKeepOnCompletionLens = + lens asyncESQLRequestKeepOnCompletion (\x y -> x {asyncESQLRequestKeepOnCompletion = y}) + +-- | Identifies an async ES|QL query in the @\/_query\/async\/{id}@ URL +-- path. Wraps 'Text' so it round-trips through JSON as a bare string. +newtype AsyncESQLId = AsyncESQLId {unAsyncESQLId :: Text} + deriving newtype (Eq, Show, ToJSON, FromJSON) + +asyncESQLIdLens :: Lens' AsyncESQLId Text +asyncESQLIdLens = lens unAsyncESQLId (\x y -> x {unAsyncESQLId = y}) + +-- | Response shape for the async ES|QL API +-- (@POST \/_query\/async@ and @GET \/_query\/async\/{id}@). The same record +-- covers both the submission and the polling responses because ES uses a +-- single wire shape — only field presence differs. +-- +-- While the query is still running @asyncESQLResultIsRunning@ is @True@, +-- @asyncESQLResultColumns@\/@asyncESQLResultValues@ are empty (or absent), +-- and @asyncESQLResultCompletionTimeInMillis@ is absent. The +-- @asyncESQLResultId@ is present only when ES deferred the result (because +-- @wait_for_completion_timeout@ elapsed before completion); a synchronous +-- completion within the timeout omits it. +-- +-- Field set verified against an Elasticsearch 9.3 backend: @id@, +-- @is_running@, @is_partial@, @took@, @start_time_in_millis@, +-- @expiration_time_in_millis@, @completion_time_in_millis@, +-- @documents_found@, @values_loaded@, @columns@, @values@ and (when +-- requested) @profile@. The @_clusters@ object is also documented on the +-- async @GET /_query/async/{id}@ response when @include_ccs_metadata@ was +-- set on the submission and a cross-cluster search was performed; it is +-- modelled here as 'asyncESQLResultClusters' for parity with the +-- synchronous 'ESQLResult'. +-- +-- For more information see +-- . +data AsyncESQLResult = AsyncESQLResult + { asyncESQLResultId :: Maybe AsyncESQLId, + asyncESQLResultIsRunning :: Bool, + asyncESQLResultIsPartial :: Bool, + asyncESQLResultStartTimeInMillis :: Maybe Int, + asyncESQLResultExpirationTimeInMillis :: Maybe Int, + asyncESQLResultCompletionTimeInMillis :: Maybe Int, + asyncESQLResultTook :: Maybe Int, + asyncESQLResultDocumentsFound :: Maybe Int, + asyncESQLResultValuesLoaded :: Maybe Int, + asyncESQLResultColumns :: Maybe [ESQLColumn], + asyncESQLResultValues :: Maybe [[Value]], + asyncESQLResultClusters :: Maybe EsqlClusters, + asyncESQLResultProfile :: Maybe EsqlProfile + } + deriving stock (Eq, Show) + +instance FromJSON AsyncESQLResult where + parseJSON = withObject "AsyncESQLResult" $ \v -> + AsyncESQLResult + <$> v .:? "id" + <*> v .:? "is_running" .!= False + <*> v .:? "is_partial" .!= True + <*> v .:? "start_time_in_millis" + <*> v .:? "expiration_time_in_millis" + <*> v .:? "completion_time_in_millis" + <*> v .:? "took" + <*> v .:? "documents_found" + <*> v .:? "values_loaded" + <*> v .:? "columns" + <*> v .:? "values" + <*> v .:? "_clusters" + <*> v .:? "profile" + +-- Note: no 'ToJSON' instance, by precedent with 'AsyncSearchResult' — +-- response types are decode-only. 'AsyncESQLId' (a path-wrapping newtype) +-- does round-trip. + +asyncESQLResultIdLens :: Lens' AsyncESQLResult (Maybe AsyncESQLId) +asyncESQLResultIdLens = + lens asyncESQLResultId (\x y -> x {asyncESQLResultId = y}) + +asyncESQLResultIsRunningLens :: Lens' AsyncESQLResult Bool +asyncESQLResultIsRunningLens = + lens asyncESQLResultIsRunning (\x y -> x {asyncESQLResultIsRunning = y}) + +asyncESQLResultIsPartialLens :: Lens' AsyncESQLResult Bool +asyncESQLResultIsPartialLens = + lens asyncESQLResultIsPartial (\x y -> x {asyncESQLResultIsPartial = y}) + +asyncESQLResultStartTimeInMillisLens :: Lens' AsyncESQLResult (Maybe Int) +asyncESQLResultStartTimeInMillisLens = + lens asyncESQLResultStartTimeInMillis (\x y -> x {asyncESQLResultStartTimeInMillis = y}) + +asyncESQLResultExpirationTimeInMillisLens :: Lens' AsyncESQLResult (Maybe Int) +asyncESQLResultExpirationTimeInMillisLens = + lens asyncESQLResultExpirationTimeInMillis (\x y -> x {asyncESQLResultExpirationTimeInMillis = y}) + +asyncESQLResultCompletionTimeInMillisLens :: Lens' AsyncESQLResult (Maybe Int) +asyncESQLResultCompletionTimeInMillisLens = + lens asyncESQLResultCompletionTimeInMillis (\x y -> x {asyncESQLResultCompletionTimeInMillis = y}) + +asyncESQLResultTookLens :: Lens' AsyncESQLResult (Maybe Int) +asyncESQLResultTookLens = + lens asyncESQLResultTook (\x y -> x {asyncESQLResultTook = y}) + +asyncESQLResultDocumentsFoundLens :: Lens' AsyncESQLResult (Maybe Int) +asyncESQLResultDocumentsFoundLens = + lens asyncESQLResultDocumentsFound (\x y -> x {asyncESQLResultDocumentsFound = y}) + +asyncESQLResultValuesLoadedLens :: Lens' AsyncESQLResult (Maybe Int) +asyncESQLResultValuesLoadedLens = + lens asyncESQLResultValuesLoaded (\x y -> x {asyncESQLResultValuesLoaded = y}) + +asyncESQLResultColumnsLens :: Lens' AsyncESQLResult (Maybe [ESQLColumn]) +asyncESQLResultColumnsLens = + lens asyncESQLResultColumns (\x y -> x {asyncESQLResultColumns = y}) + +asyncESQLResultValuesLens :: Lens' AsyncESQLResult (Maybe [[Value]]) +asyncESQLResultValuesLens = + lens asyncESQLResultValues (\x y -> x {asyncESQLResultValues = y}) + +asyncESQLResultClustersLens :: Lens' AsyncESQLResult (Maybe EsqlClusters) +asyncESQLResultClustersLens = + lens asyncESQLResultClusters (\x y -> x {asyncESQLResultClusters = y}) + +asyncESQLResultProfileLens :: Lens' AsyncESQLResult (Maybe EsqlProfile) +asyncESQLResultProfileLens = + lens asyncESQLResultProfile (\x y -> x {asyncESQLResultProfile = y}) + +-- | URI query parameters accepted by the synchronous ES|QL +-- @POST /_query@ endpoint. Each field maps 1:1 to a query-string +-- parameter documented at +-- . +-- +-- The @format@ parameter is deliberately /not/ modelled here: every +-- non-JSON format (csv, tsv, txt, yaml, arrow, ...) would break the +-- typed 'ESQLResult' decoder. Exposing it requires a raw-response +-- variant and is tracked separately. +-- +-- 'Nothing' fields are omitted, so 'defaultESQLQueryOptions' produces +-- an empty query string and a call made with it is byte-identical to +-- the legacy parameterless 'esql' wire shape. The shape mirrors +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.PITOptions'. +data ESQLQueryOptions = ESQLQueryOptions + { -- | @delimiter@ — single character used as a field separator. Only + -- relevant when @format@ is a delimited text format (csv\/tsv); the + -- server ignores it otherwise. Kept as 'Text' so the caller can pass + -- any single character. + esqloDelimiter :: Maybe Text, + -- | @drop_null_columns@ — remove columns whose every value is @null@ + -- from the result. + esqloDropNullColumns :: Maybe Bool, + -- | @allow_partial_results@ — when @'Just' 'True'@, return partial + -- results if the query fails on a data node (e.g. due to a shard + -- being unavailable) rather than failing the whole request. + esqloAllowPartialResults :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'ESQLQueryOptions' with every parameter set to 'Nothing'. Produces +-- no query string, so a call made with this value is byte-identical to +-- a parameterless call. +defaultESQLQueryOptions :: ESQLQueryOptions +defaultESQLQueryOptions = + ESQLQueryOptions + { esqloDelimiter = Nothing, + esqloDropNullColumns = Nothing, + esqloAllowPartialResults = Nothing + } + +esqloDelimiterLens :: Lens' ESQLQueryOptions (Maybe Text) +esqloDelimiterLens = lens esqloDelimiter (\x y -> x {esqloDelimiter = y}) + +esqloDropNullColumnsLens :: Lens' ESQLQueryOptions (Maybe Bool) +esqloDropNullColumnsLens = + lens esqloDropNullColumns (\x y -> x {esqloDropNullColumns = y}) + +esqloAllowPartialResultsLens :: Lens' ESQLQueryOptions (Maybe Bool) +esqloAllowPartialResultsLens = + lens esqloAllowPartialResults (\x y -> x {esqloAllowPartialResults = y}) + +-- | Render 'ESQLQueryOptions' as a list of @(key, value)@ query +-- parameters suitable for 'withQueries'. 'Nothing' fields are omitted, +-- so 'defaultESQLQueryOptions' produces '[]'. Booleans render as the +-- strings @"true"@\/@"false"@. The order of the returned list is +-- stable but /unspecified/ — callers (including tests) should treat it +-- as a set. The underlying 'withQueries' is order-insensitive. +esqlOptionsParams :: ESQLQueryOptions -> [(Text, Maybe Text)] +esqlOptionsParams opts = + catMaybes + [ ("delimiter",) . Just <$> esqloDelimiter opts, + ("drop_null_columns",) . Just . boolQP <$> esqloDropNullColumns opts, + ("allow_partial_results",) . Just . boolQP <$> esqloAllowPartialResults opts + ] + where + boolQP True = "true" + boolQP False = "false" + +-- | URI query parameters accepted by the async ES|QL +-- @GET /_query\/async\/{id}@ polling endpoint. Each field maps 1:1 to a +-- query-string parameter documented at +-- . +-- +-- This is a distinct type from 'ESQLQueryOptions' because the GET polling +-- operation exposes a different parameter surface than the POST +-- submission: @wait_for_completion_timeout@ and @keep_alive@ (both +-- duration strings, modelled as 'Text') and @drop_null_columns@. The +-- @delimiter@\/@allow_partial_results@ parameters are not accepted by the +-- GET operation, and @format@ is deliberately omitted for the same +-- reason as in 'ESQLQueryOptions' (a non-JSON format would break the +-- typed 'AsyncESQLResult' decoder — see the note at 'ESQLQueryOptions'). +-- +-- 'Nothing' fields are omitted, so 'defaultGetAsyncESQLOptions' produces +-- an empty query string and a call made with it is byte-identical to the +-- legacy parameterless 'Database.Bloodhound.ElasticSearch8.Requests.getAsyncESQL' +-- wire shape (passing @'Nothing'@ for the timeout). +data GetAsyncESQLOptions = GetAsyncESQLOptions + { -- | @wait_for_completion_timeout@ — how long to wait for the query + -- to complete before returning the current state, as a duration + -- string such as @"5s"@. 'Nothing' returns immediately. + gaesqloWaitForCompletionTimeout :: Maybe Text, + -- | @keep_alive@ — how long to keep the async result available for + -- subsequent polling, as a duration string such as @"10d"@. Extends + -- the retention of a still-running or completed result. + gaesqloKeepAlive :: Maybe Text, + -- | @drop_null_columns@ — remove columns whose every value is @null@ + -- from the (partial or final) result. + gaesqloDropNullColumns :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'GetAsyncESQLOptions' with every parameter set to 'Nothing'. +-- Produces no query string, so a call made with this value is +-- byte-identical to a parameterless poll. +defaultGetAsyncESQLOptions :: GetAsyncESQLOptions +defaultGetAsyncESQLOptions = + GetAsyncESQLOptions + { gaesqloWaitForCompletionTimeout = Nothing, + gaesqloKeepAlive = Nothing, + gaesqloDropNullColumns = Nothing + } + +gaesqloWaitForCompletionTimeoutLens :: Lens' GetAsyncESQLOptions (Maybe Text) +gaesqloWaitForCompletionTimeoutLens = + lens gaesqloWaitForCompletionTimeout (\x y -> x {gaesqloWaitForCompletionTimeout = y}) + +gaesqloKeepAliveLens :: Lens' GetAsyncESQLOptions (Maybe Text) +gaesqloKeepAliveLens = + lens gaesqloKeepAlive (\x y -> x {gaesqloKeepAlive = y}) + +gaesqloDropNullColumnsLens :: Lens' GetAsyncESQLOptions (Maybe Bool) +gaesqloDropNullColumnsLens = + lens gaesqloDropNullColumns (\x y -> x {gaesqloDropNullColumns = y}) + +-- | Render 'GetAsyncESQLOptions' as a list of @(key, value)@ query +-- parameters suitable for 'withQueries'. 'Nothing' fields are omitted, +-- so 'defaultGetAsyncESQLOptions' produces @[]@. Booleans render as the +-- strings @"true"@\/@"false"@. The order is stable but /unspecified/ — +-- callers (including tests) should treat it as a set; 'withQueries' is +-- order-insensitive. +getAsyncESQLOptionsParams :: GetAsyncESQLOptions -> [(Text, Maybe Text)] +getAsyncESQLOptionsParams opts = + catMaybes + [ ("wait_for_completion_timeout",) . Just <$> gaesqloWaitForCompletionTimeout opts, + ("keep_alive",) . Just <$> gaesqloKeepAlive opts, + ("drop_null_columns",) . Just . boolQP <$> gaesqloDropNullColumns opts + ] + where + boolQP True = "true" + boolQP False = "false" + +-- | Build a 'KM.KeyMap' from a list of @(key, value)@ pairs, dropping +-- entries whose value encodes to JSON @null@. Mirrors the behaviour of +-- 'omitNulls' but returns a 'KM.KeyMap' so it can be 'union'ed with the +-- base 'ESQLRequest' object when encoding an 'AsyncESQLRequest'. +omitNullsKeyMap :: [(Key, Value)] -> KM.KeyMap Value +omitNullsKeyMap = foldr go mempty + where + go (_, Null) acc = acc + go (k, v) acc = KM.insert k v acc + +-- ------------------------------------------------------------------ -- +-- Cross-cluster search metadata (@_clusters@) -- +-- ------------------------------------------------------------------ -- + +-- | The @_clusters@ object emitted by @POST /_query@ and +-- @GET /_query/async/{id}@ when the request set @include_ccs_metadata@ +-- (ES8\/ES9) or @include_execution_metadata@ (ES9 only) to @true@ /and/ a +-- cross-cluster search was actually performed (or, for +-- @include_execution_metadata@, even when it was not). +-- +-- The Elasticsearch 9 OpenAPI spec marks the six counters and the +-- @details@ map as required; real-world responses occasionally omit +-- @details@ (and some counters) when no remote cluster participated, so +-- every counter defaults to @0@ and @details@ defaults to @[]@ on decode. +-- Any future top-level key ES introduces survives the round trip via +-- 'esqlClustersOther', mirroring the strategy used by +-- 'Database.Bloodhound.Internal.Versions.Common.Types.ClusterStats.ClusterStatsIndices'. +-- +-- Schema reference: +-- . +data EsqlClusters = EsqlClusters + { esqlClustersTotal :: Int, + esqlClustersSuccessful :: Int, + esqlClustersRunning :: Int, + esqlClustersSkipped :: Int, + esqlClustersPartial :: Int, + esqlClustersFailed :: Int, + esqlClustersDetails :: [(Text, EsqlClusterDetails)], + esqlClustersOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EsqlClusters where + parseJSON = withObject "EsqlClusters" $ \o -> do + total <- o .:? "total" .!= 0 + successful <- o .:? "successful" .!= 0 + running <- o .:? "running" .!= 0 + skipped <- o .:? "skipped" .!= 0 + partial <- o .:? "partial" .!= 0 + failed <- o .:? "failed" .!= 0 + details <- + case KM.lookup "details" o of + Just (Object d) -> traverse decodeClusterEntry (KM.toList d) + _ -> pure [] + pure $ + EsqlClusters + { esqlClustersTotal = total, + esqlClustersSuccessful = successful, + esqlClustersRunning = running, + esqlClustersSkipped = skipped, + esqlClustersPartial = partial, + esqlClustersFailed = failed, + esqlClustersDetails = details, + esqlClustersOther = Object o + } + where + decodeClusterEntry (k, v) = (K.toText k,) <$> parseJSON v + +instance ToJSON EsqlClusters where + toJSON clusters = + case esqlClustersOther clusters of + Object o -> Object (mergeIgnoringNulls typedFields o) + _ -> omitNulls typedFields + where + typedFields = + [ "total" .= esqlClustersTotal clusters, + "successful" .= esqlClustersSuccessful clusters, + "running" .= esqlClustersRunning clusters, + "skipped" .= esqlClustersSkipped clusters, + "partial" .= esqlClustersPartial clusters, + "failed" .= esqlClustersFailed clusters, + "details" .= KM.fromList (map (uncurry encodePair) (esqlClustersDetails clusters)) + ] + encodePair name d = (K.fromText name, toJSON d) + +esqlClustersTotalLens :: Lens' EsqlClusters Int +esqlClustersTotalLens = + lens esqlClustersTotal (\x y -> x {esqlClustersTotal = y}) + +esqlClustersSuccessfulLens :: Lens' EsqlClusters Int +esqlClustersSuccessfulLens = + lens esqlClustersSuccessful (\x y -> x {esqlClustersSuccessful = y}) + +esqlClustersRunningLens :: Lens' EsqlClusters Int +esqlClustersRunningLens = + lens esqlClustersRunning (\x y -> x {esqlClustersRunning = y}) + +esqlClustersSkippedLens :: Lens' EsqlClusters Int +esqlClustersSkippedLens = + lens esqlClustersSkipped (\x y -> x {esqlClustersSkipped = y}) + +esqlClustersPartialLens :: Lens' EsqlClusters Int +esqlClustersPartialLens = + lens esqlClustersPartial (\x y -> x {esqlClustersPartial = y}) + +esqlClustersFailedLens :: Lens' EsqlClusters Int +esqlClustersFailedLens = + lens esqlClustersFailed (\x y -> x {esqlClustersFailed = y}) + +esqlClustersDetailsLens :: Lens' EsqlClusters [(Text, EsqlClusterDetails)] +esqlClustersDetailsLens = + lens esqlClustersDetails (\x y -> x {esqlClustersDetails = y}) + +esqlClustersOtherLens :: Lens' EsqlClusters Value +esqlClustersOtherLens = + lens esqlClustersOther (\x y -> x {esqlClustersOther = y}) + +-- | The per-cluster entry under @_clusters.details.@. The +-- ES9 sync @/_query@ response documents @status@, @indices@, @_shards@ +-- and @failures@; the async @GET /_query/async/{id}@ response documents +-- only @indices@ and @failures@. Every field is therefore 'Maybe' and the +-- full original object is preserved in 'esqlClusterDetailsOther' so +-- callers can reach any not-yet-typed key (and so future ES additions +-- round-trip without a library release). +data EsqlClusterDetails = EsqlClusterDetails + { esqlClusterDetailsStatus :: Maybe EsqlClusterStatus, + esqlClusterDetailsIndices :: Maybe Text, + esqlClusterDetailsShards :: Maybe ShardResult, + esqlClusterDetailsFailures :: Maybe [Value], + esqlClusterDetailsOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EsqlClusterDetails where + parseJSON = withObject "EsqlClusterDetails" $ \o -> + EsqlClusterDetails + <$> o .:? "status" + <*> o .:? "indices" + <*> o .:? "_shards" + <*> o .:? "failures" + <*> pure (Object o) + +instance ToJSON EsqlClusterDetails where + toJSON d = + case esqlClusterDetailsOther d of + Object o -> Object (mergeIgnoringNulls typedFields o) + _ -> omitNulls typedFields + where + typedFields = + [ "status" .= esqlClusterDetailsStatus d, + "indices" .= esqlClusterDetailsIndices d, + "_shards" .= esqlClusterDetailsShards d, + "failures" .= esqlClusterDetailsFailures d + ] + +esqlClusterDetailsStatusLens :: Lens' EsqlClusterDetails (Maybe EsqlClusterStatus) +esqlClusterDetailsStatusLens = + lens esqlClusterDetailsStatus (\x y -> x {esqlClusterDetailsStatus = y}) + +esqlClusterDetailsIndicesLens :: Lens' EsqlClusterDetails (Maybe Text) +esqlClusterDetailsIndicesLens = + lens esqlClusterDetailsIndices (\x y -> x {esqlClusterDetailsIndices = y}) + +esqlClusterDetailsShardsLens :: Lens' EsqlClusterDetails (Maybe ShardResult) +esqlClusterDetailsShardsLens = + lens esqlClusterDetailsShards (\x y -> x {esqlClusterDetailsShards = y}) + +esqlClusterDetailsFailuresLens :: Lens' EsqlClusterDetails (Maybe [Value]) +esqlClusterDetailsFailuresLens = + lens esqlClusterDetailsFailures (\x y -> x {esqlClusterDetailsFailures = y}) + +esqlClusterDetailsOtherLens :: Lens' EsqlClusterDetails Value +esqlClusterDetailsOtherLens = + lens esqlClusterDetailsOther (\x y -> x {esqlClusterDetailsOther = y}) + +-- | The @status@ enum of a per-cluster 'EsqlClusterDetails' entry. The +-- ES9 spec enumerates @running@, @successful@, @partial@, @skipped@ and +-- @failed@; any other value round-trips through 'OtherEsqlClusterStatus' +-- so a future ES release adding a state does not require a library +-- release. Matches the forward-compatibility pattern of +-- 'Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.QueryRules.RuleType'. +data EsqlClusterStatus + = EsqlClusterStatusRunning + | EsqlClusterStatusSuccessful + | EsqlClusterStatusPartial + | EsqlClusterStatusSkipped + | EsqlClusterStatusFailed + | OtherEsqlClusterStatus Text + deriving stock (Eq, Show) + +esqlClusterStatusToText :: EsqlClusterStatus -> Text +esqlClusterStatusToText = \case + EsqlClusterStatusRunning -> "running" + EsqlClusterStatusSuccessful -> "successful" + EsqlClusterStatusPartial -> "partial" + EsqlClusterStatusSkipped -> "skipped" + EsqlClusterStatusFailed -> "failed" + OtherEsqlClusterStatus t -> t + +esqlClusterStatusFromText :: Text -> EsqlClusterStatus +esqlClusterStatusFromText t + | t == "running" = EsqlClusterStatusRunning + | t == "successful" = EsqlClusterStatusSuccessful + | t == "partial" = EsqlClusterStatusPartial + | t == "skipped" = EsqlClusterStatusSkipped + | t == "failed" = EsqlClusterStatusFailed + | otherwise = OtherEsqlClusterStatus t + +instance ToJSON EsqlClusterStatus where + toJSON = String . esqlClusterStatusToText + +instance FromJSON EsqlClusterStatus where + parseJSON = withText "EsqlClusterStatus" (pure . esqlClusterStatusFromText) + +-- ------------------------------------------------------------------ -- +-- Profile metadata (@profile@) -- +-- ------------------------------------------------------------------ -- + +-- | The @profile@ object emitted by both ES|QL endpoints when the request +-- set 'esqlProfile' to @'Just' 'True'@. +-- +-- The Elasticsearch 9 OpenAPI spec explicitly states that /"the contents +-- of this field are currently unstable"/. Rather than commit to a shape +-- the server refuses to document, 'EsqlProfile' exposes the projections +-- described by the Lucene profile tree (@shards@, @profiles[]@ — see +-- 'EsqlProfileSection') and captures /everything/ else verbatim in +-- 'esqlProfileOther'. Observed ES|QL responses (which key the payload by +-- @parsed@ or @query@) therefore round-trip losslessly through +-- 'esqlProfileOther' while any future stabilisation can be promoted into +-- typed fields without an API break. +data EsqlProfile = EsqlProfile + { esqlProfileShards :: Maybe [Value], + esqlProfileProfiles :: Maybe [EsqlProfileSection], + esqlProfileOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EsqlProfile where + parseJSON = withObject "EsqlProfile" $ \o -> + EsqlProfile + <$> o .:? "shards" + <*> o .:? "profiles" + <*> pure (Object o) + +instance ToJSON EsqlProfile where + toJSON p = + case esqlProfileOther p of + Object o -> Object (mergeIgnoringNulls typedFields o) + _ -> omitNulls typedFields + where + typedFields = + [ "shards" .= esqlProfileShards p, + "profiles" .= esqlProfileProfiles p + ] + +esqlProfileShardsLens :: Lens' EsqlProfile (Maybe [Value]) +esqlProfileShardsLens = + lens esqlProfileShards (\x y -> x {esqlProfileShards = y}) + +esqlProfileProfilesLens :: Lens' EsqlProfile (Maybe [EsqlProfileSection]) +esqlProfileProfilesLens = + lens esqlProfileProfiles (\x y -> x {esqlProfileProfiles = y}) + +esqlProfileOtherLens :: Lens' EsqlProfile Value +esqlProfileOtherLens = + lens esqlProfileOther (\x y -> x {esqlProfileOther = y}) + +-- | A single entry of the @profiles[]@ array on an 'EsqlProfile'. The +-- Lucene profile tree documents @phase@, @description@, @time@ and a +-- recursive @children@ array; every field is 'Maybe' (the shape is +-- unstable per the ES9 spec — see 'EsqlProfile') and the verbatim object +-- is preserved in 'esqlProfileSectionOther'. +data EsqlProfileSection = EsqlProfileSection + { esqlProfileSectionPhase :: Maybe Text, + esqlProfileSectionDescription :: Maybe Text, + esqlProfileSectionTime :: Maybe Value, + esqlProfileSectionChildren :: Maybe [EsqlProfileSection], + esqlProfileSectionOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EsqlProfileSection where + parseJSON = withObject "EsqlProfileSection" $ \o -> + EsqlProfileSection + <$> o .:? "phase" + <*> o .:? "description" + <*> o .:? "time" + <*> o .:? "children" + <*> pure (Object o) + +instance ToJSON EsqlProfileSection where + toJSON s = + case esqlProfileSectionOther s of + Object o -> Object (mergeIgnoringNulls typedFields o) + _ -> omitNulls typedFields + where + typedFields = + [ "phase" .= esqlProfileSectionPhase s, + "description" .= esqlProfileSectionDescription s, + "time" .= esqlProfileSectionTime s, + "children" .= esqlProfileSectionChildren s + ] + +esqlProfileSectionPhaseLens :: Lens' EsqlProfileSection (Maybe Text) +esqlProfileSectionPhaseLens = + lens esqlProfileSectionPhase (\x y -> x {esqlProfileSectionPhase = y}) + +esqlProfileSectionDescriptionLens :: Lens' EsqlProfileSection (Maybe Text) +esqlProfileSectionDescriptionLens = + lens esqlProfileSectionDescription (\x y -> x {esqlProfileSectionDescription = y}) + +esqlProfileSectionTimeLens :: Lens' EsqlProfileSection (Maybe Value) +esqlProfileSectionTimeLens = + lens esqlProfileSectionTime (\x y -> x {esqlProfileSectionTime = y}) + +esqlProfileSectionChildrenLens :: Lens' EsqlProfileSection (Maybe [EsqlProfileSection]) +esqlProfileSectionChildrenLens = + lens esqlProfileSectionChildren (\x y -> x {esqlProfileSectionChildren = y}) + +esqlProfileSectionOtherLens :: Lens' EsqlProfileSection Value +esqlProfileSectionOtherLens = + lens esqlProfileSectionOther (\x y -> x {esqlProfileSectionOther = y}) + +-- ------------------------------------------------------------------ -- +-- Internal helpers -- +-- ------------------------------------------------------------------ -- + +-- | Merge a list of @(key, value)@ pairs into a 'KM.KeyMap', dropping any +-- pair whose value is 'Null' (matching 'omitNulls' semantics). The typed +-- pairs take precedence over stale duplicates already present in the +-- @Other@ blob captured at decode time, ensuring round trips overwrite +-- verbatim entries with the typed projections rather than the other way +-- around. Mirrors the helper used by +-- "Database.Bloodhound.Internal.Versions.Common.Types.ClusterStats". +mergeIgnoringNulls :: [(Key, Value)] -> KM.KeyMap Value -> KM.KeyMap Value +mergeIgnoringNulls kvs o = KM.union (KM.fromList (filter notNull kvs)) o + where + notNull (_, Null) = False + notNull _ = True diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/EsQueryViews.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/EsQueryViews.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/EsQueryViews.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.EsQueryViews + ( -- * View identity + ESQLViewName (..), + + -- * View resource + ESQLView (..), + + -- * Running-query info + ESQLQueryInfo (..), + + -- * Running-query list response + ESQLQueryListResponse (..), + unESQLQueryListResponse, + + -- * Lenses + esqlViewNameLens, + esqlViewQueryLens, + esqlQueryInfoIdLens, + esqlQueryInfoNodeLens, + esqlQueryInfoStartTimeMillisLens, + esqlQueryInfoRunningTimeNanosLens, + esqlQueryInfoQueryLens, + esqlQueryInfoCoordinatingNodeLens, + esqlQueryInfoDataNodesLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.String (IsString) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.EsQueryLanguage (AsyncESQLId (..)) + +-- | The @{name}@ path segment of @\/_query\/view\/{name}@. Plain opaque +-- identifier (no validation rules), mirroring the shape of +-- 'Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.SearchApplications.SearchApplicationName'. +newtype ESQLViewName = ESQLViewName {unESQLViewName :: Text} + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +esqlViewNameLens :: Lens' ESQLViewName Text +esqlViewNameLens = + lens unESQLViewName (\_ y -> ESQLViewName y) + +-- | An ES|QL view resource — the body returned by +-- @GET \/_query\/view\/{name}@ and the resource shape referenced as +-- @esql._types.ESQLView@ in the Elasticsearch OpenAPI specification. +-- +-- The server requires both fields on the wire: @name@ echoes the path +-- segment, @query@ holds the stored ES|QL source. The PUT body for +-- @PUT \/_query\/view\/{name}@ carries only the @query@ field (the name +-- comes from the path); callers pass the query 'Text' directly to +-- 'Database.Bloodhound.ElasticSearch9.Requests.putESQLView' rather than +-- going through this type. +-- +-- ES|QL views are @Experimental; Added in 9.4.0@ per the OpenAPI spec. +data ESQLView = ESQLView + { esqlViewName :: Text, + esqlViewQuery :: Text + } + deriving stock (Eq, Show) + +instance ToJSON ESQLView where + toJSON ESQLView {..} = + object + [ "name" .= esqlViewName, + "query" .= esqlViewQuery + ] + +instance FromJSON ESQLView where + parseJSON = withObject "ESQLView" $ \o -> do + -- ES 9.4+ wraps the single view in a @views@ array envelope + -- (@\{"views\":[\{"name\":...,\"query\":...\}]\}@); earlier docs and + -- the symmetric PUT/POST request bodies use the bare object shape. + -- Accept both so the parser round-trips either wire form. The + -- recursion in the envelope branch is bounded by the input nesting + -- depth (a finite JSON byte stream produces a finite 'Value' tree), + -- so adversarial nesting terminates rather than looping. + mViews <- o .:? "views" + case mViews of + Just (firstView : _) -> + parseJSON firstView + Just [] -> + fail "ESQLView: empty \"views\" envelope" + Nothing -> + ESQLView + <$> o .: "name" + <*> o .: "query" + +esqlViewQueryLens :: Lens' ESQLView Text +esqlViewQueryLens = + lens esqlViewQuery (\x y -> x {esqlViewQuery = y}) + +-- | Body returned by @GET \/_query\/queries\/{id}@ — information about a +-- currently-running ES|QL query. +-- +-- Per the OpenAPI specification the endpoint emits @id@, @node@, +-- @start_time_millis@, @running_time_nanos@, @query@, +-- @coordinating_node@ and @data_nodes@. Real GA builds (e.g. an +-- Elasticsearch 9.3 single-node cluster) frequently omit +-- @id@\/@node@\/@coordinating_node@\/@data_nodes@, so every field +-- except @query@ is decoded as 'Maybe'; callers should consult +-- 'esqlQueryInfoQuery' for the query source and treat the rest as +-- best-effort telemetry. +-- +-- The phantom @documents_found@ and @values_loaded@ counters the +-- binding previously carried are gone: those keys are emitted only on +-- the 'AsyncESQLResult' shape (the async-stored result body), not on +-- the running-query introspection body, and the running-query endpoint +-- silently ignored them when present. +-- +-- ES|QL running-query introspection is @Experimental; Added in 9.1.0@ +-- per the OpenAPI spec. +data ESQLQueryInfo = ESQLQueryInfo + { esqlQueryInfoId :: Maybe Int, + esqlQueryInfoNode :: Maybe Text, + esqlQueryInfoStartTimeMillis :: Maybe Int, + esqlQueryInfoRunningTimeNanos :: Maybe Int, + esqlQueryInfoQuery :: Text, + esqlQueryInfoCoordinatingNode :: Maybe Text, + esqlQueryInfoDataNodes :: Maybe [Text] + } + deriving stock (Eq, Show) + +instance FromJSON ESQLQueryInfo where + parseJSON = withObject "ESQLQueryInfo" $ \o -> + ESQLQueryInfo + <$> o .:? "id" + <*> o .:? "node" + <*> o .:? "start_time_millis" + <*> o .:? "running_time_nanos" + <*> o .: "query" + <*> o .:? "coordinating_node" + <*> o .:? "data_nodes" + +-- Note: no 'ToJSON' instance, by precedent with 'AsyncESQLResult' — +-- response types are decode-only. + +esqlQueryInfoIdLens :: Lens' ESQLQueryInfo (Maybe Int) +esqlQueryInfoIdLens = + lens esqlQueryInfoId (\x y -> x {esqlQueryInfoId = y}) + +esqlQueryInfoNodeLens :: Lens' ESQLQueryInfo (Maybe Text) +esqlQueryInfoNodeLens = + lens esqlQueryInfoNode (\x y -> x {esqlQueryInfoNode = y}) + +esqlQueryInfoStartTimeMillisLens :: Lens' ESQLQueryInfo (Maybe Int) +esqlQueryInfoStartTimeMillisLens = + lens esqlQueryInfoStartTimeMillis (\x y -> x {esqlQueryInfoStartTimeMillis = y}) + +esqlQueryInfoRunningTimeNanosLens :: Lens' ESQLQueryInfo (Maybe Int) +esqlQueryInfoRunningTimeNanosLens = + lens esqlQueryInfoRunningTimeNanos (\x y -> x {esqlQueryInfoRunningTimeNanos = y}) + +esqlQueryInfoQueryLens :: Lens' ESQLQueryInfo Text +esqlQueryInfoQueryLens = + lens esqlQueryInfoQuery (\x y -> x {esqlQueryInfoQuery = y}) + +esqlQueryInfoCoordinatingNodeLens :: Lens' ESQLQueryInfo (Maybe Text) +esqlQueryInfoCoordinatingNodeLens = + lens esqlQueryInfoCoordinatingNode (\x y -> x {esqlQueryInfoCoordinatingNode = y}) + +esqlQueryInfoDataNodesLens :: Lens' ESQLQueryInfo (Maybe [Text]) +esqlQueryInfoDataNodesLens = + lens esqlQueryInfoDataNodes (\x y -> x {esqlQueryInfoDataNodes = y}) + +-- | Body returned by @GET \/_query\/queries@ — the list-all sibling of +-- 'getESQLQuery'. The endpoint returns information about every +-- currently-running ES|QL query, as a JSON object keyed by the encoded +-- async-id of each query (the same string 'AsyncESQLId' wraps on the +-- @\/_query\/queries\/{id}@ path), each value carrying the per-query +-- 'ESQLQueryInfo'. +-- +-- On the wire ES emits @{"queries": {\"\": {...}, ...}}@; the decoder +-- also tolerates a bare keyed object (no @queries@ wrapper) for +-- robustness. The result is flattened into @[(AsyncESQLId, +-- ESQLQueryInfo)]@ so callers retain the id they need to subsequently +-- 'getESQLQuery', 'stopAsyncESQL' or 'deleteAsyncESQL' a listed query — +-- mirroring how +-- 'Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Inference.InferenceEndpointsResponse' +-- preserves each entry's identity rather than discarding its key. +-- +-- A newtype wrapper (rather than aeson's generic @FromJSON [a]@) gives the +-- keyed-map decoder a dedicated home and avoids instance overlap. +-- +-- ES|QL running-query introspection is @Experimental; Added in 9.1.0@ +-- per the OpenAPI spec. +newtype ESQLQueryListResponse = ESQLQueryListResponse + { esqlQueryListResponse :: [(AsyncESQLId, ESQLQueryInfo)] + } + deriving stock (Eq, Show) + +unESQLQueryListResponse :: ESQLQueryListResponse -> [(AsyncESQLId, ESQLQueryInfo)] +unESQLQueryListResponse = esqlQueryListResponse + +instance FromJSON ESQLQueryListResponse where + parseJSON = withObject "ESQLQueryListResponse" $ \o -> do + queriesMap <- + case KM.lookup "queries" o of + Just (Object inner) -> pure inner + Just _ -> + -- "queries" present but not an object (e.g. an array) — the + -- keyed-id correlation would be lost, so reject explicitly. + fail "ESQLQueryListResponse: \"queries\" must be an object keyed by async query id" + Nothing -> + -- Bare keyed object, no "queries" wrapper. + pure o + ESQLQueryListResponse + <$> traverse parseEntry (KM.toList queriesMap) + where + parseEntry (k, v) = (AsyncESQLId (toText k),) <$> parseJSON v diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/Inference.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/Inference.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/Inference.hs @@ -0,0 +1,2900 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Inference + ( -- * Identity + TaskType (..), + taskTypeToText, + taskTypeFromText, + InferenceId (..), + unInferenceId, + + -- * Providers + InferenceProvider (..), + OpenAIServiceSettings (..), + OpenAITaskSettings (..), + CohereServiceSettings (..), + CohereTaskSettings (..), + ElserServiceSettings (..), + AdaptiveAllocations (..), + RateLimit (..), + Similarity (..), + CohereEmbeddingType (..), + CohereInputType (..), + CohereTruncate (..), + ChunkingSettings (..), + + -- ** Additional typed providers + NvidiaInputType (..), + JinaAiElementType (..), + JinaAiInputType (..), + AmazonSageMakerApi (..), + AmazonSageMakerElementType (..), + GoogleModelGardenProvider (..), + ThinkingConfig (..), + Ai21ServiceSettings (..), + MistralServiceSettings (..), + AnthropicServiceSettings (..), + AnthropicTaskSettings (..), + DeepSeekServiceSettings (..), + NvidiaServiceSettings (..), + NvidiaTaskSettings (..), + ContextualAiServiceSettings (..), + ContextualAiTaskSettings (..), + FireworksAiServiceSettings (..), + FireworksAiTaskSettings (..), + GoogleAiStudioServiceSettings (..), + GoogleVertexAiServiceSettings (..), + GoogleVertexAiTaskSettings (..), + GroqServiceSettings (..), + HuggingFaceServiceSettings (..), + HuggingFaceTaskSettings (..), + JinaAiServiceSettings (..), + JinaAiTaskSettings (..), + LlamaServiceSettings (..), + OpenShiftAiServiceSettings (..), + OpenShiftAiTaskSettings (..), + VoyageAiServiceSettings (..), + VoyageAiTaskSettings (..), + ElasticsearchServiceSettings (..), + ElasticsearchTaskSettings (..), + AlibabaCloudServiceSettings (..), + AlibabaCloudTaskSettings (..), + AmazonBedrockServiceSettings (..), + AmazonBedrockTaskSettings (..), + AmazonSageMakerServiceSettings (..), + AmazonSageMakerTaskSettings (..), + AzureAiStudioServiceSettings (..), + AzureAiStudioTaskSettings (..), + AzureOpenAiServiceSettings (..), + AzureOpenAiTaskSettings (..), + CustomServiceSettings (..), + CustomTaskSettings (..), + WatsonxServiceSettings (..), + + -- * Config (PUT body) + InferenceConfig (..), + + -- * PUT response + InferencePutResponse (..), + + -- * Run inference (POST body + response) + InferenceInput (..), + InferenceResult (..), + EmbeddingFormat (..), + DenseEmbeddingItem (..), + SparseEmbeddingItem (..), + CompletionItem (..), + RerankItem (..), + + -- * Streaming chat completion (POST body) + ChatMessage (..), + ChatCompletionRequest (..), + chatMessageRoleLens, + chatMessageContentLens, + chatMessageToolCallIdLens, + chatMessageToolCallsLens, + chatMessageReasoningLens, + chatMessageReasoningDetailsLens, + chatCompletionRequestMessagesLens, + chatCompletionRequestModelLens, + chatCompletionRequestMaxCompletionTokensLens, + chatCompletionRequestReasoningLens, + chatCompletionRequestStopLens, + chatCompletionRequestTemperatureLens, + chatCompletionRequestToolChoiceLens, + chatCompletionRequestToolsLens, + chatCompletionRequestTopPLens, + + -- * Get inference (GET response) + InferenceInfo (..), + InferenceEndpointsResponse (..), + + -- * Lenses + inferenceIdLens, + openAIServiceSettingsApiKeyLens, + openAIServiceSettingsModelIdLens, + openAIServiceSettingsOrganizationIdLens, + openAIServiceSettingsUrlLens, + openAIServiceSettingsDimensionsLens, + openAIServiceSettingsSimilarityLens, + openAIServiceSettingsRateLimitLens, + openAITaskSettingsUserLens, + openAITaskSettingsHeadersLens, + cohereServiceSettingsApiKeyLens, + cohereServiceSettingsModelIdLens, + cohereServiceSettingsEmbeddingTypeLens, + cohereServiceSettingsSimilarityLens, + cohereServiceSettingsRateLimitLens, + cohereTaskSettingsInputTypeLens, + cohereTaskSettingsReturnDocumentsLens, + cohereTaskSettingsTopNLens, + cohereTaskSettingsTruncateLens, + elserServiceSettingsNumAllocationsLens, + elserServiceSettingsNumThreadsLens, + elserServiceSettingsAdaptiveAllocationsLens, + adaptiveAllocationsEnabledLens, + adaptiveAllocationsMinNumberOfAllocationsLens, + adaptiveAllocationsMaxNumberOfAllocationsLens, + rateLimitRequestsPerMinuteLens, + chunkingSettingsMaxChunkSizeLens, + chunkingSettingsOverlapLens, + chunkingSettingsSentenceOverlapLens, + chunkingSettingsSeparatorGroupLens, + chunkingSettingsSeparatorsLens, + chunkingSettingsStrategyLens, + inferenceConfigProviderLens, + inferenceConfigChunkingSettingsLens, + inferencePutResponseInferenceIdLens, + inferencePutResponseTaskTypeLens, + inferencePutResponseServiceLens, + inferencePutResponseServiceSettingsLens, + inferencePutResponseTaskSettingsLens, + inferencePutResponseChunkingSettingsLens, + inferenceInputInputLens, + inferenceInputQueryLens, + inferenceInputInputTypeLens, + inferenceInputTaskSettingsLens, + denseEmbeddingItemEmbeddingLens, + sparseEmbeddingItemIsTruncatedLens, + sparseEmbeddingItemEmbeddingLens, + completionItemResultLens, + rerankItemIndexLens, + rerankItemRelevanceScoreLens, + rerankItemTextLens, + inferenceInfoTaskTypeLens, + inferenceInfoInferenceIdLens, + inferenceInfoServiceLens, + inferenceInfoServiceSettingsLens, + inferenceInfoTaskSettingsLens, + inferenceInfoChunkingSettingsLens, + + -- * Delete inference options (DELETE /_inference/{task_type}/{inference_id}) + DeleteInferenceOptions (..), + defaultDeleteInferenceOptions, + deleteInferenceOptionsParams, + dioDryRunLens, + dioForceLens, + + -- * PUT inference options (PUT /_inference/{task_type}/{inference_id}) + PutInferenceOptions (..), + defaultPutInferenceOptions, + putInferenceOptionsParams, + pioTimeoutLens, + + -- * Run inference options (POST /_inference/{task_type}/{inference_id}) + RunInferenceOptions (..), + defaultRunInferenceOptions, + runInferenceOptionsParams, + rnioTimeoutLens, + + -- * Stream completion options + + -- (POST /_inference/completion/{inference_id}/_stream) + StreamCompletionInferenceOptions (..), + defaultStreamCompletionInferenceOptions, + streamCompletionInferenceOptionsParams, + scioTimeoutLens, + + -- * Stream chat completion options + + -- (POST /_inference/chat_completion/{inference_id}/_stream) + StreamChatCompletionInferenceOptions (..), + defaultStreamChatCompletionInferenceOptions, + streamChatCompletionInferenceOptionsParams, + sccioTimeoutLens, + + -- * Secret-bearing field wrappers + SecretText (..), + SecretValue (..), + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as M +import Data.String (IsString) +import Data.Text qualified as T +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Utils.Secret (SecretText (..), SecretValue (..)) +import Database.Bloodhound.Internal.Versions.Common.Types.Units + ( TimeUnits, + timeUnitsSuffix, + ) + +-- | The @task_type@ segment of @\/_inference\/{task_type}\/{inference_id}@. +-- +-- The Elasticsearch inference API recognises six task types. Use +-- 'OtherTaskType' for forward compatibility with task types introduced after +-- this binding was written. +data TaskType + = SparseEmbeddingTaskType + | TextEmbeddingTaskType + | RerankTaskType + | CompletionTaskType + | ChatCompletionTaskType + | EmbeddingTaskType + deriving stock (Eq, Show, Ord, Bounded, Enum) + +-- | Render a 'TaskType' as the snake_case wire segment used in URLs and JSON. +taskTypeToText :: TaskType -> Text +taskTypeToText = \case + SparseEmbeddingTaskType -> "sparse_embedding" + TextEmbeddingTaskType -> "text_embedding" + RerankTaskType -> "rerank" + CompletionTaskType -> "completion" + ChatCompletionTaskType -> "chat_completion" + EmbeddingTaskType -> "embedding" + +-- | Parse a 'TaskType' from its wire representation. +taskTypeFromText :: Text -> Maybe TaskType +taskTypeFromText t = case t of + "sparse_embedding" -> Just SparseEmbeddingTaskType + "text_embedding" -> Just TextEmbeddingTaskType + "rerank" -> Just RerankTaskType + "completion" -> Just CompletionTaskType + "chat_completion" -> Just ChatCompletionTaskType + "embedding" -> Just EmbeddingTaskType + _ -> Nothing + +instance ToJSON TaskType where + toJSON = String . taskTypeToText + +instance FromJSON TaskType where + parseJSON = withText "TaskType" $ \t -> + case taskTypeFromText t of + Just tt -> pure tt + Nothing -> fail $ "Unknown TaskType: " <> T.unpack t + +-- | The @{inference_id}@ path segment. Unlike 'IndexName', this is a plain +-- opaque identifier with no validation rules. +newtype InferenceId = InferenceId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unInferenceId :: InferenceId -> Text +unInferenceId (InferenceId x) = x + +inferenceIdLens :: Lens' InferenceId Text +inferenceIdLens = lens unInferenceId (\_ y -> InferenceId y) + +-- | Shared vector-space metric used by OpenAI, Cohere, Nvidia, and other +-- inference providers. The Elasticsearch OpenAPI specification defines +-- per-provider similarity enums (e.g. @OpenAISimilarityType@, +-- @CohereSimilarityType@) that all accept exactly @cosine@, @dot_product@, +-- and @l2_norm@. @max_inner_product@ is /not/ valid for any inference +-- provider and is intentionally omitted. +data Similarity + = SimilarityCosine + | SimilarityDotProduct + | SimilarityL2Norm + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON Similarity where + toJSON = \case + SimilarityCosine -> "cosine" + SimilarityDotProduct -> "dot_product" + SimilarityL2Norm -> "l2_norm" + +instance FromJSON Similarity where + parseJSON = withText "Similarity" $ \case + "cosine" -> pure SimilarityCosine + "dot_product" -> pure SimilarityDotProduct + "l2_norm" -> pure SimilarityL2Norm + other -> fail $ "Unknown Similarity: " <> T.unpack other + +-- | @embedding_type@ accepted by the Cohere service. +data CohereEmbeddingType + = CohereEmbeddingBinary + | CohereEmbeddingBit + | CohereEmbeddingByte + | CohereEmbeddingFloat + | CohereEmbeddingInt8 + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON CohereEmbeddingType where + toJSON = \case + CohereEmbeddingBinary -> "binary" + CohereEmbeddingBit -> "bit" + CohereEmbeddingByte -> "byte" + CohereEmbeddingFloat -> "float" + CohereEmbeddingInt8 -> "int8" + +instance FromJSON CohereEmbeddingType where + parseJSON = withText "CohereEmbeddingType" $ \case + "binary" -> pure CohereEmbeddingBinary + "bit" -> pure CohereEmbeddingBit + "byte" -> pure CohereEmbeddingByte + "float" -> pure CohereEmbeddingFloat + "int8" -> pure CohereEmbeddingInt8 + other -> fail $ "Unknown CohereEmbeddingType: " <> T.unpack other + +-- | @input_type@ accepted by the Cohere service. +data CohereInputType + = CohereInputClassification + | CohereInputClustering + | CohereInputIngest + | CohereInputSearch + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON CohereInputType where + toJSON = \case + CohereInputClassification -> "classification" + CohereInputClustering -> "clustering" + CohereInputIngest -> "ingest" + CohereInputSearch -> "search" + +instance FromJSON CohereInputType where + parseJSON = withText "CohereInputType" $ \case + "classification" -> pure CohereInputClassification + "clustering" -> pure CohereInputClustering + "ingest" -> pure CohereInputIngest + "search" -> pure CohereInputSearch + other -> fail $ "Unknown CohereInputType: " <> T.unpack other + +-- | @truncate@ accepted by the Cohere service. The wire values are +-- upper-case per the Elasticsearch OpenAPI specification. +data CohereTruncate + = CohereTruncateEnd + | CohereTruncateNone + | CohereTruncateStart + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON CohereTruncate where + toJSON = \case + CohereTruncateEnd -> "END" + CohereTruncateNone -> "NONE" + CohereTruncateStart -> "START" + +instance FromJSON CohereTruncate where + parseJSON = withText "CohereTruncate" $ \case + "END" -> pure CohereTruncateEnd + "NONE" -> pure CohereTruncateNone + "START" -> pure CohereTruncateStart + other -> fail $ "Unknown CohereTruncate: " <> T.unpack other + +-- | @rate_limit@ sub-object shared by OpenAI and Cohere. +newtype RateLimit = RateLimit + { rlRequestsPerMinute :: Int + } + deriving stock (Eq, Show) + +instance ToJSON RateLimit where + toJSON RateLimit {..} = + object ["requests_per_minute" .= rlRequestsPerMinute] + +instance FromJSON RateLimit where + parseJSON = withObject "RateLimit" $ \o -> + RateLimit <$> o .: "requests_per_minute" + +rateLimitRequestsPerMinuteLens :: Lens' RateLimit Int +rateLimitRequestsPerMinuteLens = lens rlRequestsPerMinute (\x y -> x {rlRequestsPerMinute = y}) + +-- | @adaptive_allocations@ sub-object for the ELSER service. +data AdaptiveAllocations = AdaptiveAllocations + { aaEnabled :: Maybe Bool, + aaMinNumberOfAllocations :: Maybe Int, + aaMaxNumberOfAllocations :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON AdaptiveAllocations where + toJSON AdaptiveAllocations {..} = + omitNulls + [ "enabled" .= aaEnabled, + "min_number_of_allocations" .= aaMinNumberOfAllocations, + "max_number_of_allocations" .= aaMaxNumberOfAllocations + ] + +instance FromJSON AdaptiveAllocations where + parseJSON = withObject "AdaptiveAllocations" $ \o -> + AdaptiveAllocations + <$> o .:? "enabled" + <*> o .:? "min_number_of_allocations" + <*> o .:? "max_number_of_allocations" + +adaptiveAllocationsEnabledLens :: Lens' AdaptiveAllocations (Maybe Bool) +adaptiveAllocationsEnabledLens = lens aaEnabled (\x y -> x {aaEnabled = y}) + +adaptiveAllocationsMinNumberOfAllocationsLens :: Lens' AdaptiveAllocations (Maybe Int) +adaptiveAllocationsMinNumberOfAllocationsLens = + lens aaMinNumberOfAllocations (\x y -> x {aaMinNumberOfAllocations = y}) + +adaptiveAllocationsMaxNumberOfAllocationsLens :: Lens' AdaptiveAllocations (Maybe Int) +adaptiveAllocationsMaxNumberOfAllocationsLens = + lens aaMaxNumberOfAllocations (\x y -> x {aaMaxNumberOfAllocations = y}) + +-- | @service_settings@ for an OpenAI inference endpoint. The +-- @api_key@ is wrapped in 'SecretText' so 'show' never leaks it. +data OpenAIServiceSettings = OpenAIServiceSettings + { oassApiKey :: Maybe SecretText, + oassModelId :: Text, + oassOrganizationId :: Maybe Text, + oassUrl :: Maybe Text, + oassDimensions :: Maybe Int, + oassSimilarity :: Maybe Similarity, + oassRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON OpenAIServiceSettings where + toJSON OpenAIServiceSettings {..} = + omitNulls + [ "api_key" .= oassApiKey, + "model_id" .= oassModelId, + "organization_id" .= oassOrganizationId, + "url" .= oassUrl, + "dimensions" .= oassDimensions, + "similarity" .= oassSimilarity, + "rate_limit" .= oassRateLimit + ] + +instance FromJSON OpenAIServiceSettings where + parseJSON = withObject "OpenAIServiceSettings" $ \o -> + OpenAIServiceSettings + <$> o .:? "api_key" + <*> o .: "model_id" + <*> o .:? "organization_id" + <*> o .:? "url" + <*> o .:? "dimensions" + <*> o .:? "similarity" + <*> o .:? "rate_limit" + +openAIServiceSettingsApiKeyLens :: Lens' OpenAIServiceSettings (Maybe SecretText) +openAIServiceSettingsApiKeyLens = lens oassApiKey (\x y -> x {oassApiKey = y}) + +openAIServiceSettingsModelIdLens :: Lens' OpenAIServiceSettings Text +openAIServiceSettingsModelIdLens = lens oassModelId (\x y -> x {oassModelId = y}) + +openAIServiceSettingsOrganizationIdLens :: Lens' OpenAIServiceSettings (Maybe Text) +openAIServiceSettingsOrganizationIdLens = + lens oassOrganizationId (\x y -> x {oassOrganizationId = y}) + +openAIServiceSettingsUrlLens :: Lens' OpenAIServiceSettings (Maybe Text) +openAIServiceSettingsUrlLens = lens oassUrl (\x y -> x {oassUrl = y}) + +openAIServiceSettingsDimensionsLens :: Lens' OpenAIServiceSettings (Maybe Int) +openAIServiceSettingsDimensionsLens = + lens oassDimensions (\x y -> x {oassDimensions = y}) + +openAIServiceSettingsSimilarityLens :: Lens' OpenAIServiceSettings (Maybe Similarity) +openAIServiceSettingsSimilarityLens = + lens oassSimilarity (\x y -> x {oassSimilarity = y}) + +openAIServiceSettingsRateLimitLens :: Lens' OpenAIServiceSettings (Maybe RateLimit) +openAIServiceSettingsRateLimitLens = + lens oassRateLimit (\x y -> x {oassRateLimit = y}) + +-- | @task_settings@ for an OpenAI inference endpoint. +data OpenAITaskSettings = OpenAITaskSettings + { oatsUser :: Maybe Text, + oatsHeaders :: Maybe (M.Map Text Text) + } + deriving stock (Eq, Show) + +instance ToJSON OpenAITaskSettings where + toJSON OpenAITaskSettings {..} = + omitNulls + [ "user" .= oatsUser, + "headers" .= oatsHeaders + ] + +instance FromJSON OpenAITaskSettings where + parseJSON = withObject "OpenAITaskSettings" $ \o -> + OpenAITaskSettings + <$> o .:? "user" + <*> o .:? "headers" + +openAITaskSettingsUserLens :: Lens' OpenAITaskSettings (Maybe Text) +openAITaskSettingsUserLens = lens oatsUser (\x y -> x {oatsUser = y}) + +openAITaskSettingsHeadersLens :: Lens' OpenAITaskSettings (Maybe (M.Map Text Text)) +openAITaskSettingsHeadersLens = lens oatsHeaders (\x y -> x {oatsHeaders = y}) + +-- | @service_settings@ for a Cohere inference endpoint. The @api_key@ +-- is wrapped in 'SecretText' so 'show' never leaks it. +data CohereServiceSettings = CohereServiceSettings + { cssApiKey :: Maybe SecretText, + cssModelId :: Text, + cssEmbeddingType :: Maybe CohereEmbeddingType, + cssSimilarity :: Maybe Similarity, + cssRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON CohereServiceSettings where + toJSON CohereServiceSettings {..} = + omitNulls + [ "api_key" .= cssApiKey, + "model_id" .= cssModelId, + "embedding_type" .= cssEmbeddingType, + "similarity" .= cssSimilarity, + "rate_limit" .= cssRateLimit + ] + +instance FromJSON CohereServiceSettings where + parseJSON = withObject "CohereServiceSettings" $ \o -> + CohereServiceSettings + <$> o .:? "api_key" + <*> o .: "model_id" + <*> o .:? "embedding_type" + <*> o .:? "similarity" + <*> o .:? "rate_limit" + +cohereServiceSettingsApiKeyLens :: Lens' CohereServiceSettings (Maybe SecretText) +cohereServiceSettingsApiKeyLens = lens cssApiKey (\x y -> x {cssApiKey = y}) + +cohereServiceSettingsModelIdLens :: Lens' CohereServiceSettings Text +cohereServiceSettingsModelIdLens = lens cssModelId (\x y -> x {cssModelId = y}) + +cohereServiceSettingsEmbeddingTypeLens :: Lens' CohereServiceSettings (Maybe CohereEmbeddingType) +cohereServiceSettingsEmbeddingTypeLens = + lens cssEmbeddingType (\x y -> x {cssEmbeddingType = y}) + +cohereServiceSettingsSimilarityLens :: Lens' CohereServiceSettings (Maybe Similarity) +cohereServiceSettingsSimilarityLens = + lens cssSimilarity (\x y -> x {cssSimilarity = y}) + +cohereServiceSettingsRateLimitLens :: Lens' CohereServiceSettings (Maybe RateLimit) +cohereServiceSettingsRateLimitLens = + lens cssRateLimit (\x y -> x {cssRateLimit = y}) + +-- | @task_settings@ for a Cohere inference endpoint. Not every field applies +-- to every task type: @input_type@ \/ @truncate@ are embedding-task settings +-- while @top_n@ \/ @return_documents@ are rerank-task settings. Elasticsearch +-- validates the combination server-side per task type, so an over-populated +-- record will be rejected by the server rather than by this binding. +data CohereTaskSettings = CohereTaskSettings + { ctsInputType :: Maybe CohereInputType, + ctsReturnDocuments :: Maybe Bool, + ctsTopN :: Maybe Int, + ctsTruncate :: Maybe CohereTruncate + } + deriving stock (Eq, Show) + +instance ToJSON CohereTaskSettings where + toJSON CohereTaskSettings {..} = + omitNulls + [ "input_type" .= ctsInputType, + "return_documents" .= ctsReturnDocuments, + "top_n" .= ctsTopN, + "truncate" .= ctsTruncate + ] + +instance FromJSON CohereTaskSettings where + parseJSON = withObject "CohereTaskSettings" $ \o -> + CohereTaskSettings + <$> o .:? "input_type" + <*> o .:? "return_documents" + <*> o .:? "top_n" + <*> o .:? "truncate" + +cohereTaskSettingsInputTypeLens :: Lens' CohereTaskSettings (Maybe CohereInputType) +cohereTaskSettingsInputTypeLens = + lens ctsInputType (\x y -> x {ctsInputType = y}) + +cohereTaskSettingsReturnDocumentsLens :: Lens' CohereTaskSettings (Maybe Bool) +cohereTaskSettingsReturnDocumentsLens = + lens ctsReturnDocuments (\x y -> x {ctsReturnDocuments = y}) + +cohereTaskSettingsTopNLens :: Lens' CohereTaskSettings (Maybe Int) +cohereTaskSettingsTopNLens = lens ctsTopN (\x y -> x {ctsTopN = y}) + +cohereTaskSettingsTruncateLens :: Lens' CohereTaskSettings (Maybe CohereTruncate) +cohereTaskSettingsTruncateLens = + lens ctsTruncate (\x y -> x {ctsTruncate = y}) + +-- | @service_settings@ for an ELSER inference endpoint. Per the Elasticsearch +-- OpenAPI specification, both @num_allocations@ and @num_threads@ are +-- required when @adaptive_allocations@ is not used. +data ElserServiceSettings = ElserServiceSettings + { esserNumAllocations :: Int, + esserNumThreads :: Int, + esserAdaptiveAllocations :: Maybe AdaptiveAllocations + } + deriving stock (Eq, Show) + +instance ToJSON ElserServiceSettings where + toJSON ElserServiceSettings {..} = + omitNulls + [ "num_allocations" .= esserNumAllocations, + "num_threads" .= esserNumThreads, + "adaptive_allocations" .= esserAdaptiveAllocations + ] + +instance FromJSON ElserServiceSettings where + parseJSON = withObject "ElserServiceSettings" $ \o -> + ElserServiceSettings + <$> o .: "num_allocations" + <*> o .: "num_threads" + <*> o .:? "adaptive_allocations" + +elserServiceSettingsNumAllocationsLens :: Lens' ElserServiceSettings Int +elserServiceSettingsNumAllocationsLens = + lens esserNumAllocations (\x y -> x {esserNumAllocations = y}) + +elserServiceSettingsNumThreadsLens :: Lens' ElserServiceSettings Int +elserServiceSettingsNumThreadsLens = + lens esserNumThreads (\x y -> x {esserNumThreads = y}) + +elserServiceSettingsAdaptiveAllocationsLens :: Lens' ElserServiceSettings (Maybe AdaptiveAllocations) +elserServiceSettingsAdaptiveAllocationsLens = + lens esserAdaptiveAllocations (\x y -> x {esserAdaptiveAllocations = y}) + +-- $additional-providers +-- +-- The records below model the @service_settings@ (and, where the provider +-- defines them, @task_settings@) for the inference providers documented at +-- . +-- Every provider hits the same @PUT \/_inference\/{task_type}\/{inference_id}@ +-- path; only the shape of @service_settings@ differs. The shared 'RateLimit', +-- 'AdaptiveAllocations' and 'Similarity' types are reused where the +-- per-provider OpenAPI schemas delegate to them (they do, via @allOf@ $refs). + +-- | @input_type@ accepted by the Nvidia service. +data NvidiaInputType + = NvidiaInputIngest + | NvidiaInputSearch + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON NvidiaInputType where + toJSON = \case + NvidiaInputIngest -> "ingest" + NvidiaInputSearch -> "search" + +instance FromJSON NvidiaInputType where + parseJSON = withText "NvidiaInputType" $ \case + "ingest" -> pure NvidiaInputIngest + "search" -> pure NvidiaInputSearch + other -> fail $ "Unknown NvidiaInputType: " <> T.unpack other + +-- | @embedding_type@ accepted by the JinaAI service. +data JinaAiElementType + = JinaAiElementBinary + | JinaAiElementBit + | JinaAiElementFloat + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON JinaAiElementType where + toJSON = \case + JinaAiElementBinary -> "binary" + JinaAiElementBit -> "bit" + JinaAiElementFloat -> "float" + +instance FromJSON JinaAiElementType where + parseJSON = withText "JinaAiElementType" $ \case + "binary" -> pure JinaAiElementBinary + "bit" -> pure JinaAiElementBit + "float" -> pure JinaAiElementFloat + other -> fail $ "Unknown JinaAiElementType: " <> T.unpack other + +-- | @input_type@ accepted by the JinaAI service (same wire values as +-- 'CohereInputType', exposed under its own type for clarity). +data JinaAiInputType + = JinaAiInputClassification + | JinaAiInputClustering + | JinaAiInputIngest + | JinaAiInputSearch + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON JinaAiInputType where + toJSON = \case + JinaAiInputClassification -> "classification" + JinaAiInputClustering -> "clustering" + JinaAiInputIngest -> "ingest" + JinaAiInputSearch -> "search" + +instance FromJSON JinaAiInputType where + parseJSON = withText "JinaAiInputType" $ \case + "classification" -> pure JinaAiInputClassification + "clustering" -> pure JinaAiInputClustering + "ingest" -> pure JinaAiInputIngest + "search" -> pure JinaAiInputSearch + other -> fail $ "Unknown JinaAiInputType: " <> T.unpack other + +-- | @api@ format for the Amazon SageMaker service. +data AmazonSageMakerApi + = AmazonSageMakerApiOpenAI + | AmazonSageMakerApiElastic + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON AmazonSageMakerApi where + toJSON = \case + AmazonSageMakerApiOpenAI -> "openai" + AmazonSageMakerApiElastic -> "elastic" + +instance FromJSON AmazonSageMakerApi where + parseJSON = withText "AmazonSageMakerApi" $ \case + "openai" -> pure AmazonSageMakerApiOpenAI + "elastic" -> pure AmazonSageMakerApiElastic + other -> fail $ "Unknown AmazonSageMakerApi: " <> T.unpack other + +-- | @element_type@ for the Amazon SageMaker service. +data AmazonSageMakerElementType + = AmazonSageMakerElementByte + | AmazonSageMakerElementFloat + | AmazonSageMakerElementBit + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON AmazonSageMakerElementType where + toJSON = \case + AmazonSageMakerElementByte -> "byte" + AmazonSageMakerElementFloat -> "float" + AmazonSageMakerElementBit -> "bit" + +instance FromJSON AmazonSageMakerElementType where + parseJSON = withText "AmazonSageMakerElementType" $ \case + "byte" -> pure AmazonSageMakerElementByte + "float" -> pure AmazonSageMakerElementFloat + "bit" -> pure AmazonSageMakerElementBit + other -> fail $ "Unknown AmazonSageMakerElementType: " <> T.unpack other + +-- | @provider@ for the Google Vertex AI (Model Garden) service. +data GoogleModelGardenProvider + = GoogleModelGardenGoogle + | GoogleModelGardenAnthropic + | GoogleModelGardenMeta + | GoogleModelGardenHuggingFace + | GoogleModelGardenMistral + | GoogleModelGardenAi21 + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON GoogleModelGardenProvider where + toJSON = \case + GoogleModelGardenGoogle -> "google" + GoogleModelGardenAnthropic -> "anthropic" + GoogleModelGardenMeta -> "meta" + GoogleModelGardenHuggingFace -> "hugging_face" + GoogleModelGardenMistral -> "mistral" + GoogleModelGardenAi21 -> "ai21" + +instance FromJSON GoogleModelGardenProvider where + parseJSON = withText "GoogleModelGardenProvider" $ \case + "google" -> pure GoogleModelGardenGoogle + "anthropic" -> pure GoogleModelGardenAnthropic + "meta" -> pure GoogleModelGardenMeta + "hugging_face" -> pure GoogleModelGardenHuggingFace + "mistral" -> pure GoogleModelGardenMistral + "ai21" -> pure GoogleModelGardenAi21 + other -> fail $ "Unknown GoogleModelGardenProvider: " <> T.unpack other + +-- | @thinking_config@ for the Google Vertex AI service. Carries the +-- @thinking_budget@ numeric field. +newtype ThinkingConfig = ThinkingConfig + { tcThinkingBudget :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON ThinkingConfig where + toJSON ThinkingConfig {..} = + omitNulls ["thinking_budget" .= tcThinkingBudget] + +instance FromJSON ThinkingConfig where + parseJSON = withObject "ThinkingConfig" $ \o -> + ThinkingConfig <$> o .:? "thinking_budget" + +-- | @service_settings@ for an AI21 inference endpoint. The @api_key@ +-- is wrapped in 'SecretText' so 'show' never leaks it. +data Ai21ServiceSettings = Ai21ServiceSettings + { ai21ssModelId :: Text, + ai21ssApiKey :: Maybe SecretText, + ai21ssRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON Ai21ServiceSettings where + toJSON Ai21ServiceSettings {..} = + omitNulls + [ "model_id" .= ai21ssModelId, + "api_key" .= ai21ssApiKey, + "rate_limit" .= ai21ssRateLimit + ] + +instance FromJSON Ai21ServiceSettings where + parseJSON = withObject "Ai21ServiceSettings" $ \o -> + Ai21ServiceSettings + <$> o .: "model_id" + <*> o .:? "api_key" + <*> o .:? "rate_limit" + +-- | @service_settings@ for a Mistral inference endpoint. Note Mistral uses +-- @model@ (not @model_id@) as the model identifier field. The @api_key@ +-- is wrapped in 'SecretText' so 'show' never leaks it. +data MistralServiceSettings = MistralServiceSettings + { mistralssApiKey :: Maybe SecretText, + mistralssModel :: Text, + mistralssMaxInputTokens :: Maybe Int, + mistralssRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON MistralServiceSettings where + toJSON MistralServiceSettings {..} = + omitNulls + [ "api_key" .= mistralssApiKey, + "model" .= mistralssModel, + "max_input_tokens" .= mistralssMaxInputTokens, + "rate_limit" .= mistralssRateLimit + ] + +instance FromJSON MistralServiceSettings where + parseJSON = withObject "MistralServiceSettings" $ \o -> + MistralServiceSettings + <$> o .:? "api_key" + <*> o .: "model" + <*> o .:? "max_input_tokens" + <*> o .:? "rate_limit" + +-- | @service_settings@ for an Anthropic inference endpoint. The +-- @api_key@ is wrapped in 'SecretText' so 'show' never leaks it. +data AnthropicServiceSettings = AnthropicServiceSettings + { anthropicssApiKey :: Maybe SecretText, + anthropicssModelId :: Text, + anthropicssRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON AnthropicServiceSettings where + toJSON AnthropicServiceSettings {..} = + omitNulls + [ "api_key" .= anthropicssApiKey, + "model_id" .= anthropicssModelId, + "rate_limit" .= anthropicssRateLimit + ] + +instance FromJSON AnthropicServiceSettings where + parseJSON = withObject "AnthropicServiceSettings" $ \o -> + AnthropicServiceSettings + <$> o .:? "api_key" + <*> o .: "model_id" + <*> o .:? "rate_limit" + +-- | @task_settings@ for an Anthropic inference endpoint. +data AnthropicTaskSettings = AnthropicTaskSettings + { anthropicMaxTokens :: Int, + anthropicTemperature :: Maybe Double, + anthropicTopK :: Maybe Int, + anthropicTopP :: Maybe Double + } + deriving stock (Eq, Show) + +instance ToJSON AnthropicTaskSettings where + toJSON AnthropicTaskSettings {..} = + omitNulls + [ "max_tokens" .= anthropicMaxTokens, + "temperature" .= anthropicTemperature, + "top_k" .= anthropicTopK, + "top_p" .= anthropicTopP + ] + +instance FromJSON AnthropicTaskSettings where + parseJSON = withObject "AnthropicTaskSettings" $ \o -> + AnthropicTaskSettings + <$> o .: "max_tokens" + <*> o .:? "temperature" + <*> o .:? "top_k" + <*> o .:? "top_p" + +-- | @service_settings@ for a DeepSeek inference endpoint. The @api_key@ +-- is wrapped in 'SecretText' so 'show' never leaks it. +data DeepSeekServiceSettings = DeepSeekServiceSettings + { deepseekssApiKey :: Maybe SecretText, + deepseekssModelId :: Text, + deepseekssUrl :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON DeepSeekServiceSettings where + toJSON DeepSeekServiceSettings {..} = + omitNulls + [ "api_key" .= deepseekssApiKey, + "model_id" .= deepseekssModelId, + "url" .= deepseekssUrl + ] + +instance FromJSON DeepSeekServiceSettings where + parseJSON = withObject "DeepSeekServiceSettings" $ \o -> + DeepSeekServiceSettings + <$> o .:? "api_key" + <*> o .: "model_id" + <*> o .:? "url" + +-- | @service_settings@ for an Nvidia inference endpoint. The @api_key@ +-- is wrapped in 'SecretText' so 'show' never leaks it. +data NvidiaServiceSettings = NvidiaServiceSettings + { nvidiassApiKey :: Maybe SecretText, + nvidiassModelId :: Text, + nvidiassMaxInputTokens :: Maybe Int, + nvidiassRateLimit :: Maybe RateLimit, + nvidiassSimilarity :: Maybe Similarity, + nvidiassUrl :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON NvidiaServiceSettings where + toJSON NvidiaServiceSettings {..} = + omitNulls + [ "api_key" .= nvidiassApiKey, + "model_id" .= nvidiassModelId, + "max_input_tokens" .= nvidiassMaxInputTokens, + "rate_limit" .= nvidiassRateLimit, + "similarity" .= nvidiassSimilarity, + "url" .= nvidiassUrl + ] + +instance FromJSON NvidiaServiceSettings where + parseJSON = withObject "NvidiaServiceSettings" $ \o -> + NvidiaServiceSettings + <$> o .:? "api_key" + <*> o .: "model_id" + <*> o .:? "max_input_tokens" + <*> o .:? "rate_limit" + <*> o .:? "similarity" + <*> o .:? "url" + +-- | @task_settings@ for an Nvidia inference endpoint. Note @truncate@ +-- reuses the Cohere @truncate@ wire enum. +data NvidiaTaskSettings = NvidiaTaskSettings + { nvidiaTsInputType :: Maybe NvidiaInputType, + nvidiaTsTruncate :: Maybe CohereTruncate + } + deriving stock (Eq, Show) + +instance ToJSON NvidiaTaskSettings where + toJSON NvidiaTaskSettings {..} = + omitNulls + [ "input_type" .= nvidiaTsInputType, + "truncate" .= nvidiaTsTruncate + ] + +instance FromJSON NvidiaTaskSettings where + parseJSON = withObject "NvidiaTaskSettings" $ \o -> + NvidiaTaskSettings + <$> o .:? "input_type" + <*> o .:? "truncate" + +-- | @service_settings@ for a Contextual AI inference endpoint. The +-- @api_key@ is wrapped in 'SecretText' so 'show' never leaks it. +data ContextualAiServiceSettings = ContextualAiServiceSettings + { contextualaissApiKey :: Maybe SecretText, + contextualaissModelId :: Text, + contextualaissRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON ContextualAiServiceSettings where + toJSON ContextualAiServiceSettings {..} = + omitNulls + [ "api_key" .= contextualaissApiKey, + "model_id" .= contextualaissModelId, + "rate_limit" .= contextualaissRateLimit + ] + +instance FromJSON ContextualAiServiceSettings where + parseJSON = withObject "ContextualAiServiceSettings" $ \o -> + ContextualAiServiceSettings + <$> o .:? "api_key" + <*> o .: "model_id" + <*> o .:? "rate_limit" + +-- | @task_settings@ for a Contextual AI inference endpoint. +data ContextualAiTaskSettings = ContextualAiTaskSettings + { contextualaiTsInstruction :: Maybe Text, + contextualaiTsTopK :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON ContextualAiTaskSettings where + toJSON ContextualAiTaskSettings {..} = + omitNulls + [ "instruction" .= contextualaiTsInstruction, + "top_k" .= contextualaiTsTopK + ] + +instance FromJSON ContextualAiTaskSettings where + parseJSON = withObject "ContextualAiTaskSettings" $ \o -> + ContextualAiTaskSettings + <$> o .:? "instruction" + <*> o .:? "top_k" + +-- | @service_settings@ for a Fireworks AI inference endpoint. The +-- @api_key@ is wrapped in 'SecretText' so 'show' never leaks it. +data FireworksAiServiceSettings = FireworksAiServiceSettings + { fireworksaissApiKey :: Maybe SecretText, + fireworksaissModelId :: Text, + fireworksaissDimensions :: Maybe Int, + fireworksaissRateLimit :: Maybe RateLimit, + fireworksaissSimilarity :: Maybe Similarity, + fireworksaissUrl :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON FireworksAiServiceSettings where + toJSON FireworksAiServiceSettings {..} = + omitNulls + [ "api_key" .= fireworksaissApiKey, + "model_id" .= fireworksaissModelId, + "dimensions" .= fireworksaissDimensions, + "rate_limit" .= fireworksaissRateLimit, + "similarity" .= fireworksaissSimilarity, + "url" .= fireworksaissUrl + ] + +instance FromJSON FireworksAiServiceSettings where + parseJSON = withObject "FireworksAiServiceSettings" $ \o -> + FireworksAiServiceSettings + <$> o .:? "api_key" + <*> o .: "model_id" + <*> o .:? "dimensions" + <*> o .:? "rate_limit" + <*> o .:? "similarity" + <*> o .:? "url" + +-- | @task_settings@ for a Fireworks AI inference endpoint (OpenAI-style +-- @user@ \/ @headers@). +data FireworksAiTaskSettings = FireworksAiTaskSettings + { fireworksAiTsUser :: Maybe Text, + fireworksAiTsHeaders :: Maybe (M.Map Text Text) + } + deriving stock (Eq, Show) + +instance ToJSON FireworksAiTaskSettings where + toJSON FireworksAiTaskSettings {..} = + omitNulls + [ "user" .= fireworksAiTsUser, + "headers" .= fireworksAiTsHeaders + ] + +instance FromJSON FireworksAiTaskSettings where + parseJSON = withObject "FireworksAiTaskSettings" $ \o -> + FireworksAiTaskSettings + <$> o .:? "user" + <*> o .:? "headers" + +-- | @service_settings@ for a Google AI Studio inference endpoint. The +-- @api_key@ is wrapped in 'SecretText' so 'show' never leaks it. +data GoogleAiStudioServiceSettings = GoogleAiStudioServiceSettings + { googleaistudiossApiKey :: Maybe SecretText, + googleaistudiossModelId :: Text, + googleaistudiossRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON GoogleAiStudioServiceSettings where + toJSON GoogleAiStudioServiceSettings {..} = + omitNulls + [ "api_key" .= googleaistudiossApiKey, + "model_id" .= googleaistudiossModelId, + "rate_limit" .= googleaistudiossRateLimit + ] + +instance FromJSON GoogleAiStudioServiceSettings where + parseJSON = withObject "GoogleAiStudioServiceSettings" $ \o -> + GoogleAiStudioServiceSettings + <$> o .:? "api_key" + <*> o .: "model_id" + <*> o .:? "rate_limit" + +-- | @service_settings@ for a Google Vertex AI (Model Garden) inference +-- endpoint. @service_account_json@ is required (and is a credential — +-- wrapped in 'SecretText' so 'show' never leaks it); @provider@ +-- selects the underlying Model Garden backend. +data GoogleVertexAiServiceSettings = GoogleVertexAiServiceSettings + { googlevertexaissServiceAccountJson :: SecretText, + googlevertexaissProvider :: Maybe GoogleModelGardenProvider, + googlevertexaissUrl :: Maybe Text, + googlevertexaissStreamingUrl :: Maybe Text, + googlevertexaissLocation :: Maybe Text, + googlevertexaissModelId :: Maybe Text, + googlevertexaissProjectId :: Maybe Text, + googlevertexaissRateLimit :: Maybe RateLimit, + googlevertexaissDimensions :: Maybe Int, + googlevertexaissMaxBatchSize :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON GoogleVertexAiServiceSettings where + toJSON GoogleVertexAiServiceSettings {..} = + omitNulls + [ "service_account_json" .= googlevertexaissServiceAccountJson, + "provider" .= googlevertexaissProvider, + "url" .= googlevertexaissUrl, + "streaming_url" .= googlevertexaissStreamingUrl, + "location" .= googlevertexaissLocation, + "model_id" .= googlevertexaissModelId, + "project_id" .= googlevertexaissProjectId, + "rate_limit" .= googlevertexaissRateLimit, + "dimensions" .= googlevertexaissDimensions, + "max_batch_size" .= googlevertexaissMaxBatchSize + ] + +instance FromJSON GoogleVertexAiServiceSettings where + parseJSON = withObject "GoogleVertexAiServiceSettings" $ \o -> + GoogleVertexAiServiceSettings + <$> o .: "service_account_json" + <*> o .:? "provider" + <*> o .:? "url" + <*> o .:? "streaming_url" + <*> o .:? "location" + <*> o .:? "model_id" + <*> o .:? "project_id" + <*> o .:? "rate_limit" + <*> o .:? "dimensions" + <*> o .:? "max_batch_size" + +-- | @task_settings@ for a Google Vertex AI inference endpoint. +data GoogleVertexAiTaskSettings = GoogleVertexAiTaskSettings + { googlevertexaiTsAutoTruncate :: Maybe Bool, + googlevertexaiTsMaxTokens :: Maybe Int, + googlevertexaiTsThinkingConfig :: Maybe ThinkingConfig, + googlevertexaiTsTopN :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON GoogleVertexAiTaskSettings where + toJSON GoogleVertexAiTaskSettings {..} = + omitNulls + [ "auto_truncate" .= googlevertexaiTsAutoTruncate, + "max_tokens" .= googlevertexaiTsMaxTokens, + "thinking_config" .= googlevertexaiTsThinkingConfig, + "top_n" .= googlevertexaiTsTopN + ] + +instance FromJSON GoogleVertexAiTaskSettings where + parseJSON = withObject "GoogleVertexAiTaskSettings" $ \o -> + GoogleVertexAiTaskSettings + <$> o .:? "auto_truncate" + <*> o .:? "max_tokens" + <*> o .:? "thinking_config" + <*> o .:? "top_n" + +-- | @service_settings@ for a Groq inference endpoint. The @api_key@ +-- is wrapped in 'SecretText' so 'show' never leaks it. +data GroqServiceSettings = GroqServiceSettings + { groqssModelId :: Text, + groqssApiKey :: Maybe SecretText, + groqssRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON GroqServiceSettings where + toJSON GroqServiceSettings {..} = + omitNulls + [ "model_id" .= groqssModelId, + "api_key" .= groqssApiKey, + "rate_limit" .= groqssRateLimit + ] + +instance FromJSON GroqServiceSettings where + parseJSON = withObject "GroqServiceSettings" $ \o -> + GroqServiceSettings + <$> o .: "model_id" + <*> o .:? "api_key" + <*> o .:? "rate_limit" + +-- | @service_settings@ for a Hugging Face inference endpoint. The +-- @api_key@ is wrapped in 'SecretText' so 'show' never leaks it. +data HuggingFaceServiceSettings = HuggingFaceServiceSettings + { huggingfacessApiKey :: Maybe SecretText, + huggingfacessUrl :: Text, + huggingfacessModelId :: Maybe Text, + huggingfacessRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON HuggingFaceServiceSettings where + toJSON HuggingFaceServiceSettings {..} = + omitNulls + [ "api_key" .= huggingfacessApiKey, + "url" .= huggingfacessUrl, + "model_id" .= huggingfacessModelId, + "rate_limit" .= huggingfacessRateLimit + ] + +instance FromJSON HuggingFaceServiceSettings where + parseJSON = withObject "HuggingFaceServiceSettings" $ \o -> + HuggingFaceServiceSettings + <$> o .:? "api_key" + <*> o .: "url" + <*> o .:? "model_id" + <*> o .:? "rate_limit" + +-- | @task_settings@ for a Hugging Face inference endpoint. +data HuggingFaceTaskSettings = HuggingFaceTaskSettings + { huggingFaceTsReturnDocuments :: Maybe Bool, + huggingFaceTsTopN :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON HuggingFaceTaskSettings where + toJSON HuggingFaceTaskSettings {..} = + omitNulls + [ "return_documents" .= huggingFaceTsReturnDocuments, + "top_n" .= huggingFaceTsTopN + ] + +instance FromJSON HuggingFaceTaskSettings where + parseJSON = withObject "HuggingFaceTaskSettings" $ \o -> + HuggingFaceTaskSettings + <$> o .:? "return_documents" + <*> o .:? "top_n" + +-- | @service_settings@ for a JinaAI inference endpoint. The @api_key@ +-- is wrapped in 'SecretText' so 'show' never leaks it. +data JinaAiServiceSettings = JinaAiServiceSettings + { jinaaissApiKey :: Maybe SecretText, + jinaaissModelId :: Text, + jinaaissDimensions :: Maybe Int, + jinaaissEmbeddingType :: Maybe JinaAiElementType, + jinaaissMultimodalModel :: Maybe Bool, + jinaaissRateLimit :: Maybe RateLimit, + jinaaissSimilarity :: Maybe Similarity + } + deriving stock (Eq, Show) + +instance ToJSON JinaAiServiceSettings where + toJSON JinaAiServiceSettings {..} = + omitNulls + [ "api_key" .= jinaaissApiKey, + "model_id" .= jinaaissModelId, + "dimensions" .= jinaaissDimensions, + "embedding_type" .= jinaaissEmbeddingType, + "multimodal_model" .= jinaaissMultimodalModel, + "rate_limit" .= jinaaissRateLimit, + "similarity" .= jinaaissSimilarity + ] + +instance FromJSON JinaAiServiceSettings where + parseJSON = withObject "JinaAiServiceSettings" $ \o -> + JinaAiServiceSettings + <$> o .:? "api_key" + <*> o .: "model_id" + <*> o .:? "dimensions" + <*> o .:? "embedding_type" + <*> o .:? "multimodal_model" + <*> o .:? "rate_limit" + <*> o .:? "similarity" + +-- | @task_settings@ for a JinaAI inference endpoint. +data JinaAiTaskSettings = JinaAiTaskSettings + { jinaAiTsInputType :: Maybe JinaAiInputType, + jinaAiTsLateChunking :: Maybe Bool, + jinaAiTsReturnDocuments :: Maybe Bool, + jinaAiTsTopN :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON JinaAiTaskSettings where + toJSON JinaAiTaskSettings {..} = + omitNulls + [ "input_type" .= jinaAiTsInputType, + "late_chunking" .= jinaAiTsLateChunking, + "return_documents" .= jinaAiTsReturnDocuments, + "top_n" .= jinaAiTsTopN + ] + +instance FromJSON JinaAiTaskSettings where + parseJSON = withObject "JinaAiTaskSettings" $ \o -> + JinaAiTaskSettings + <$> o .:? "input_type" + <*> o .:? "late_chunking" + <*> o .:? "return_documents" + <*> o .:? "top_n" + +-- | @service_settings@ for a Llama inference endpoint. +data LlamaServiceSettings = LlamaServiceSettings + { llamassUrl :: Text, + llamassModelId :: Text, + llamassMaxInputTokens :: Maybe Int, + llamassRateLimit :: Maybe RateLimit, + llamassSimilarity :: Maybe Similarity + } + deriving stock (Eq, Show) + +instance ToJSON LlamaServiceSettings where + toJSON LlamaServiceSettings {..} = + omitNulls + [ "url" .= llamassUrl, + "model_id" .= llamassModelId, + "max_input_tokens" .= llamassMaxInputTokens, + "rate_limit" .= llamassRateLimit, + "similarity" .= llamassSimilarity + ] + +instance FromJSON LlamaServiceSettings where + parseJSON = withObject "LlamaServiceSettings" $ \o -> + LlamaServiceSettings + <$> o .: "url" + <*> o .: "model_id" + <*> o .:? "max_input_tokens" + <*> o .:? "rate_limit" + <*> o .:? "similarity" + +-- | @service_settings@ for an OpenShift AI inference endpoint. The +-- @api_key@ is wrapped in 'SecretText' so 'show' never leaks it. +data OpenShiftAiServiceSettings = OpenShiftAiServiceSettings + { openshiftaissApiKey :: Maybe SecretText, + openshiftaissUrl :: Text, + openshiftaissMaxInputTokens :: Maybe Int, + openshiftaissModelId :: Maybe Text, + openshiftaissRateLimit :: Maybe RateLimit, + openshiftaissSimilarity :: Maybe Similarity + } + deriving stock (Eq, Show) + +instance ToJSON OpenShiftAiServiceSettings where + toJSON OpenShiftAiServiceSettings {..} = + omitNulls + [ "api_key" .= openshiftaissApiKey, + "url" .= openshiftaissUrl, + "max_input_tokens" .= openshiftaissMaxInputTokens, + "model_id" .= openshiftaissModelId, + "rate_limit" .= openshiftaissRateLimit, + "similarity" .= openshiftaissSimilarity + ] + +instance FromJSON OpenShiftAiServiceSettings where + parseJSON = withObject "OpenShiftAiServiceSettings" $ \o -> + OpenShiftAiServiceSettings + <$> o .:? "api_key" + <*> o .: "url" + <*> o .:? "max_input_tokens" + <*> o .:? "model_id" + <*> o .:? "rate_limit" + <*> o .:? "similarity" + +-- | @task_settings@ for an OpenShift AI inference endpoint. +data OpenShiftAiTaskSettings = OpenShiftAiTaskSettings + { openshiftAiTsReturnDocuments :: Maybe Bool, + openshiftAiTsTopN :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON OpenShiftAiTaskSettings where + toJSON OpenShiftAiTaskSettings {..} = + omitNulls + [ "return_documents" .= openshiftAiTsReturnDocuments, + "top_n" .= openshiftAiTsTopN + ] + +instance FromJSON OpenShiftAiTaskSettings where + parseJSON = withObject "OpenShiftAiTaskSettings" $ \o -> + OpenShiftAiTaskSettings + <$> o .:? "return_documents" + <*> o .:? "top_n" + +-- | @service_settings@ for a VoyageAI inference endpoint. +data VoyageAiServiceSettings = VoyageAiServiceSettings + { voyageaissModelId :: Text, + voyageaissDimensions :: Maybe Int, + voyageaissEmbeddingType :: Maybe JinaAiElementType, + voyageaissRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON VoyageAiServiceSettings where + toJSON VoyageAiServiceSettings {..} = + omitNulls + [ "model_id" .= voyageaissModelId, + "dimensions" .= voyageaissDimensions, + "embedding_type" .= voyageaissEmbeddingType, + "rate_limit" .= voyageaissRateLimit + ] + +instance FromJSON VoyageAiServiceSettings where + parseJSON = withObject "VoyageAiServiceSettings" $ \o -> + VoyageAiServiceSettings + <$> o .: "model_id" + <*> o .:? "dimensions" + <*> o .:? "embedding_type" + <*> o .:? "rate_limit" + +-- | @task_settings@ for a VoyageAI inference endpoint. +data VoyageAiTaskSettings = VoyageAiTaskSettings + { voyageAiTsInputType :: Maybe Text, + voyageAiTsReturnDocuments :: Maybe Bool, + voyageAiTsTopK :: Maybe Int, + voyageAiTsTruncation :: Maybe Bool + } + deriving stock (Eq, Show) + +instance ToJSON VoyageAiTaskSettings where + toJSON VoyageAiTaskSettings {..} = + omitNulls + [ "input_type" .= voyageAiTsInputType, + "return_documents" .= voyageAiTsReturnDocuments, + "top_k" .= voyageAiTsTopK, + "truncation" .= voyageAiTsTruncation + ] + +instance FromJSON VoyageAiTaskSettings where + parseJSON = withObject "VoyageAiTaskSettings" $ \o -> + VoyageAiTaskSettings + <$> o .:? "input_type" + <*> o .:? "return_documents" + <*> o .:? "top_k" + <*> o .:? "truncation" + +-- | @service_settings@ for an Elasticsearch-native inference endpoint. +data ElasticsearchServiceSettings = ElasticsearchServiceSettings + { elasticsearchssModelId :: Text, + elasticsearchssNumThreads :: Int, + elasticsearchssAdaptiveAllocations :: Maybe AdaptiveAllocations, + elasticsearchssDeploymentId :: Maybe Text, + elasticsearchssNumAllocations :: Maybe Int, + elasticsearchssLongDocumentStrategy :: Maybe Text, + elasticsearchssMaxChunksPerDoc :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON ElasticsearchServiceSettings where + toJSON ElasticsearchServiceSettings {..} = + omitNulls + [ "model_id" .= elasticsearchssModelId, + "num_threads" .= elasticsearchssNumThreads, + "adaptive_allocations" .= elasticsearchssAdaptiveAllocations, + "deployment_id" .= elasticsearchssDeploymentId, + "num_allocations" .= elasticsearchssNumAllocations, + "long_document_strategy" .= elasticsearchssLongDocumentStrategy, + "max_chunks_per_doc" .= elasticsearchssMaxChunksPerDoc + ] + +instance FromJSON ElasticsearchServiceSettings where + parseJSON = withObject "ElasticsearchServiceSettings" $ \o -> + ElasticsearchServiceSettings + <$> o .: "model_id" + <*> o .: "num_threads" + <*> o .:? "adaptive_allocations" + <*> o .:? "deployment_id" + <*> o .:? "num_allocations" + <*> o .:? "long_document_strategy" + <*> o .:? "max_chunks_per_doc" + +-- | @task_settings@ for an Elasticsearch-native inference endpoint. +data ElasticsearchTaskSettings = ElasticsearchTaskSettings + { elasticsearchTsReturnDocuments :: Maybe Bool + } + deriving stock (Eq, Show) + +instance ToJSON ElasticsearchTaskSettings where + toJSON ElasticsearchTaskSettings {..} = + omitNulls ["return_documents" .= elasticsearchTsReturnDocuments] + +instance FromJSON ElasticsearchTaskSettings where + parseJSON = withObject "ElasticsearchTaskSettings" $ \o -> + ElasticsearchTaskSettings <$> o .:? "return_documents" + +-- | @service_settings@ for an AlibabaCloud AI Search inference endpoint. +-- The @api_key@ is wrapped in 'SecretText' so 'show' never leaks it. +data AlibabaCloudServiceSettings = AlibabaCloudServiceSettings + { alibabacloudssApiKey :: Maybe SecretText, + alibabacloudssHost :: Text, + alibabacloudssServiceId :: Text, + alibabacloudssWorkspace :: Text, + alibabacloudssRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON AlibabaCloudServiceSettings where + toJSON AlibabaCloudServiceSettings {..} = + omitNulls + [ "api_key" .= alibabacloudssApiKey, + "host" .= alibabacloudssHost, + "service_id" .= alibabacloudssServiceId, + "workspace" .= alibabacloudssWorkspace, + "rate_limit" .= alibabacloudssRateLimit + ] + +instance FromJSON AlibabaCloudServiceSettings where + parseJSON = withObject "AlibabaCloudServiceSettings" $ \o -> + AlibabaCloudServiceSettings + <$> o .:? "api_key" + <*> o .: "host" + <*> o .: "service_id" + <*> o .: "workspace" + <*> o .:? "rate_limit" + +-- | @task_settings@ for an AlibabaCloud AI Search inference endpoint. +data AlibabaCloudTaskSettings = AlibabaCloudTaskSettings + { alibabaCloudTsInputType :: Maybe Text, + alibabaCloudTsReturnToken :: Maybe Bool + } + deriving stock (Eq, Show) + +instance ToJSON AlibabaCloudTaskSettings where + toJSON AlibabaCloudTaskSettings {..} = + omitNulls + [ "input_type" .= alibabaCloudTsInputType, + "return_token" .= alibabaCloudTsReturnToken + ] + +instance FromJSON AlibabaCloudTaskSettings where + parseJSON = withObject "AlibabaCloudTaskSettings" $ \o -> + AlibabaCloudTaskSettings + <$> o .:? "input_type" + <*> o .:? "return_token" + +-- | @service_settings@ for an Amazon Bedrock inference endpoint. The +-- AWS @access_key@ and @secret_key@ are wrapped in 'SecretText' so +-- 'show' never leaks them. +data AmazonBedrockServiceSettings = AmazonBedrockServiceSettings + { amazonbedrockssAccessKey :: SecretText, + amazonbedrockssModel :: Text, + amazonbedrockssRegion :: Text, + amazonbedrockssSecretKey :: SecretText, + amazonbedrockssProvider :: Maybe Text, + amazonbedrockssRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON AmazonBedrockServiceSettings where + toJSON AmazonBedrockServiceSettings {..} = + omitNulls + [ "access_key" .= amazonbedrockssAccessKey, + "model" .= amazonbedrockssModel, + "region" .= amazonbedrockssRegion, + "secret_key" .= amazonbedrockssSecretKey, + "provider" .= amazonbedrockssProvider, + "rate_limit" .= amazonbedrockssRateLimit + ] + +instance FromJSON AmazonBedrockServiceSettings where + parseJSON = withObject "AmazonBedrockServiceSettings" $ \o -> + AmazonBedrockServiceSettings + <$> o .: "access_key" + <*> o .: "model" + <*> o .: "region" + <*> o .: "secret_key" + <*> o .:? "provider" + <*> o .:? "rate_limit" + +-- | @task_settings@ for an Amazon Bedrock inference endpoint. +data AmazonBedrockTaskSettings = AmazonBedrockTaskSettings + { amazonBedrockTsMaxNewTokens :: Maybe Int, + amazonBedrockTsTemperature :: Maybe Double, + amazonBedrockTsTopK :: Maybe Int, + amazonBedrockTsTopP :: Maybe Double + } + deriving stock (Eq, Show) + +instance ToJSON AmazonBedrockTaskSettings where + toJSON AmazonBedrockTaskSettings {..} = + omitNulls + [ "max_new_tokens" .= amazonBedrockTsMaxNewTokens, + "temperature" .= amazonBedrockTsTemperature, + "top_k" .= amazonBedrockTsTopK, + "top_p" .= amazonBedrockTsTopP + ] + +instance FromJSON AmazonBedrockTaskSettings where + parseJSON = withObject "AmazonBedrockTaskSettings" $ \o -> + AmazonBedrockTaskSettings + <$> o .:? "max_new_tokens" + <*> o .:? "temperature" + <*> o .:? "top_k" + <*> o .:? "top_p" + +-- | @service_settings@ for an Amazon SageMaker inference endpoint. +-- The AWS @access_key@ and @secret_key@ are wrapped in 'SecretText' +-- so 'show' never leaks them. +data AmazonSageMakerServiceSettings = AmazonSageMakerServiceSettings + { amazonsagemakerssAccessKey :: SecretText, + amazonsagemakerssEndpointName :: Text, + amazonsagemakerssApi :: AmazonSageMakerApi, + amazonsagemakerssRegion :: Text, + amazonsagemakerssSecretKey :: SecretText, + amazonsagemakerssSimilarity :: Maybe Similarity, + amazonsagemakerssElementType :: Maybe AmazonSageMakerElementType, + amazonsagemakerssTargetModel :: Maybe Text, + amazonsagemakerssTargetContainerHostname :: Maybe Text, + amazonsagemakerssInferenceComponentName :: Maybe Text, + amazonsagemakerssBatchSize :: Maybe Int, + amazonsagemakerssDimensions :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON AmazonSageMakerServiceSettings where + toJSON AmazonSageMakerServiceSettings {..} = + omitNulls + [ "access_key" .= amazonsagemakerssAccessKey, + "endpoint_name" .= amazonsagemakerssEndpointName, + "api" .= amazonsagemakerssApi, + "region" .= amazonsagemakerssRegion, + "secret_key" .= amazonsagemakerssSecretKey, + "similarity" .= amazonsagemakerssSimilarity, + "element_type" .= amazonsagemakerssElementType, + "target_model" .= amazonsagemakerssTargetModel, + "target_container_hostname" .= amazonsagemakerssTargetContainerHostname, + "inference_component_name" .= amazonsagemakerssInferenceComponentName, + "batch_size" .= amazonsagemakerssBatchSize, + "dimensions" .= amazonsagemakerssDimensions + ] + +instance FromJSON AmazonSageMakerServiceSettings where + parseJSON = withObject "AmazonSageMakerServiceSettings" $ \o -> + AmazonSageMakerServiceSettings + <$> o .: "access_key" + <*> o .: "endpoint_name" + <*> o .: "api" + <*> o .: "region" + <*> o .: "secret_key" + <*> o .:? "similarity" + <*> o .:? "element_type" + <*> o .:? "target_model" + <*> o .:? "target_container_hostname" + <*> o .:? "inference_component_name" + <*> o .:? "batch_size" + <*> o .:? "dimensions" + +-- | @task_settings@ for an Amazon SageMaker inference endpoint. +data AmazonSageMakerTaskSettings = AmazonSageMakerTaskSettings + { amazonSageMakerTsCustomAttributes :: Maybe Text, + amazonSageMakerTsEnableExplanations :: Maybe Text, + amazonSageMakerTsInferenceId :: Maybe Text, + amazonSageMakerTsSessionId :: Maybe Text, + amazonSageMakerTsTargetVariant :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON AmazonSageMakerTaskSettings where + toJSON AmazonSageMakerTaskSettings {..} = + omitNulls + [ "custom_attributes" .= amazonSageMakerTsCustomAttributes, + "enable_explanations" .= amazonSageMakerTsEnableExplanations, + "inference_id" .= amazonSageMakerTsInferenceId, + "session_id" .= amazonSageMakerTsSessionId, + "target_variant" .= amazonSageMakerTsTargetVariant + ] + +instance FromJSON AmazonSageMakerTaskSettings where + parseJSON = withObject "AmazonSageMakerTaskSettings" $ \o -> + AmazonSageMakerTaskSettings + <$> o .:? "custom_attributes" + <*> o .:? "enable_explanations" + <*> o .:? "inference_id" + <*> o .:? "session_id" + <*> o .:? "target_variant" + +-- | @service_settings@ for an Azure AI studio inference endpoint. The +-- @api_key@ is wrapped in 'SecretText' so 'show' never leaks it. +data AzureAiStudioServiceSettings = AzureAiStudioServiceSettings + { azureaistudiossApiKey :: Maybe SecretText, + azureaistudiossEndpointType :: Text, + azureaistudiossTarget :: Text, + azureaistudiossProvider :: Text, + azureaistudiossRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON AzureAiStudioServiceSettings where + toJSON AzureAiStudioServiceSettings {..} = + omitNulls + [ "api_key" .= azureaistudiossApiKey, + "endpoint_type" .= azureaistudiossEndpointType, + "target" .= azureaistudiossTarget, + "provider" .= azureaistudiossProvider, + "rate_limit" .= azureaistudiossRateLimit + ] + +instance FromJSON AzureAiStudioServiceSettings where + parseJSON = withObject "AzureAiStudioServiceSettings" $ \o -> + AzureAiStudioServiceSettings + <$> o .:? "api_key" + <*> o .: "endpoint_type" + <*> o .: "target" + <*> o .: "provider" + <*> o .:? "rate_limit" + +-- | @task_settings@ for an Azure AI studio inference endpoint. +data AzureAiStudioTaskSettings = AzureAiStudioTaskSettings + { azureAiStudioTsDoSample :: Maybe Double, + azureAiStudioTsMaxNewTokens :: Maybe Int, + azureAiStudioTsReturnDocuments :: Maybe Bool, + azureAiStudioTsTemperature :: Maybe Double, + azureAiStudioTsTopN :: Maybe Int, + azureAiStudioTsTopP :: Maybe Double, + azureAiStudioTsUser :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON AzureAiStudioTaskSettings where + toJSON AzureAiStudioTaskSettings {..} = + omitNulls + [ "do_sample" .= azureAiStudioTsDoSample, + "max_new_tokens" .= azureAiStudioTsMaxNewTokens, + "return_documents" .= azureAiStudioTsReturnDocuments, + "temperature" .= azureAiStudioTsTemperature, + "top_n" .= azureAiStudioTsTopN, + "top_p" .= azureAiStudioTsTopP, + "user" .= azureAiStudioTsUser + ] + +instance FromJSON AzureAiStudioTaskSettings where + parseJSON = withObject "AzureAiStudioTaskSettings" $ \o -> + AzureAiStudioTaskSettings + <$> o .:? "do_sample" + <*> o .:? "max_new_tokens" + <*> o .:? "return_documents" + <*> o .:? "temperature" + <*> o .:? "top_n" + <*> o .:? "top_p" + <*> o .:? "user" + +-- | @service_settings@ for an Azure OpenAI inference endpoint. The +-- @api_key@ and @client_secret@ are wrapped in 'SecretText' so 'show' +-- never leaks them. +data AzureOpenAiServiceSettings = AzureOpenAiServiceSettings + { azureopenaissApiVersion :: Text, + azureopenaissDeploymentId :: Text, + azureopenaissResourceName :: Text, + azureopenaissApiKey :: Maybe SecretText, + azureopenaissClientId :: Maybe Text, + azureopenaissClientSecret :: Maybe SecretText, + azureopenaissEntraId :: Maybe Text, + azureopenaissRateLimit :: Maybe RateLimit, + azureopenaissScopes :: Maybe [Text], + azureopenaissTenantId :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON AzureOpenAiServiceSettings where + toJSON AzureOpenAiServiceSettings {..} = + omitNulls + [ "api_version" .= azureopenaissApiVersion, + "deployment_id" .= azureopenaissDeploymentId, + "resource_name" .= azureopenaissResourceName, + "api_key" .= azureopenaissApiKey, + "client_id" .= azureopenaissClientId, + "client_secret" .= azureopenaissClientSecret, + "entra_id" .= azureopenaissEntraId, + "rate_limit" .= azureopenaissRateLimit, + "scopes" .= azureopenaissScopes, + "tenant_id" .= azureopenaissTenantId + ] + +instance FromJSON AzureOpenAiServiceSettings where + parseJSON = withObject "AzureOpenAiServiceSettings" $ \o -> + AzureOpenAiServiceSettings + <$> o .: "api_version" + <*> o .: "deployment_id" + <*> o .: "resource_name" + <*> o .:? "api_key" + <*> o .:? "client_id" + <*> o .:? "client_secret" + <*> o .:? "entra_id" + <*> o .:? "rate_limit" + <*> o .:? "scopes" + <*> o .:? "tenant_id" + +-- | @task_settings@ for an Azure OpenAI inference endpoint (OpenAI-style +-- @user@ \/ @headers@). +data AzureOpenAiTaskSettings = AzureOpenAiTaskSettings + { azureOpenAiTsUser :: Maybe Text, + azureOpenAiTsHeaders :: Maybe (M.Map Text Text) + } + deriving stock (Eq, Show) + +instance ToJSON AzureOpenAiTaskSettings where + toJSON AzureOpenAiTaskSettings {..} = + omitNulls + [ "user" .= azureOpenAiTsUser, + "headers" .= azureOpenAiTsHeaders + ] + +instance FromJSON AzureOpenAiTaskSettings where + parseJSON = withObject "AzureOpenAiTaskSettings" $ \o -> + AzureOpenAiTaskSettings + <$> o .:? "user" + <*> o .:? "headers" + +-- | @service_settings@ for a custom (user-defined) inference endpoint. The +-- @request@, @response@ and @secret_parameters@ sub-objects are deeply +-- nested adapter configurations (@CustomRequestParams@ / +-- @CustomResponseParams@ / a secret map in the OpenAPI spec); they are +-- modelled here as opaque JSON 'Value's so callers can supply any valid +-- adapter shape without a dedicated record per sub-field. The +-- @secret_parameters@ blob is wrapped in 'SecretValue' so 'show' never +-- leaks it (it carries arbitrary provider credentials). +data CustomServiceSettings = CustomServiceSettings + { customssRequest :: Value, + customssResponse :: Value, + customssSecretParameters :: SecretValue, + customssBatchSize :: Maybe Int, + customssHeaders :: Maybe Value, + customssInputType :: Maybe Value, + customssQueryParameters :: Maybe Value, + customssUrl :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON CustomServiceSettings where + toJSON CustomServiceSettings {..} = + omitNulls + [ "request" .= customssRequest, + "response" .= customssResponse, + "secret_parameters" .= customssSecretParameters, + "batch_size" .= customssBatchSize, + "headers" .= customssHeaders, + "input_type" .= customssInputType, + "query_parameters" .= customssQueryParameters, + "url" .= customssUrl + ] + +instance FromJSON CustomServiceSettings where + parseJSON = withObject "CustomServiceSettings" $ \o -> + CustomServiceSettings + <$> o .: "request" + <*> o .: "response" + <*> o .: "secret_parameters" + <*> o .:? "batch_size" + <*> o .:? "headers" + <*> o .:? "input_type" + <*> o .:? "query_parameters" + <*> o .:? "url" + +-- | @task_settings@ for a custom inference endpoint. +newtype CustomTaskSettings = CustomTaskSettings + { customTsParameters :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON CustomTaskSettings where + toJSON CustomTaskSettings {..} = + omitNulls ["parameters" .= customTsParameters] + +instance FromJSON CustomTaskSettings where + parseJSON = withObject "CustomTaskSettings" $ \o -> + CustomTaskSettings <$> o .:? "parameters" + +-- | @service_settings@ for a Watsonx inference endpoint. The @api_key@ +-- is wrapped in 'SecretText' so 'show' never leaks it. +data WatsonxServiceSettings = WatsonxServiceSettings + { watsonxssApiKey :: Maybe SecretText, + watsonxssApiVersion :: Text, + watsonxssModelId :: Text, + watsonxssProjectId :: Text, + watsonxssUrl :: Text, + watsonxssRateLimit :: Maybe RateLimit + } + deriving stock (Eq, Show) + +instance ToJSON WatsonxServiceSettings where + toJSON WatsonxServiceSettings {..} = + omitNulls + [ "api_key" .= watsonxssApiKey, + "api_version" .= watsonxssApiVersion, + "model_id" .= watsonxssModelId, + "project_id" .= watsonxssProjectId, + "url" .= watsonxssUrl, + "rate_limit" .= watsonxssRateLimit + ] + +instance FromJSON WatsonxServiceSettings where + parseJSON = withObject "WatsonxServiceSettings" $ \o -> + WatsonxServiceSettings + <$> o .:? "api_key" + <*> o .: "api_version" + <*> o .: "model_id" + <*> o .: "project_id" + <*> o .: "url" + <*> o .:? "rate_limit" + +-- | @chunking_settings@ shared by every inference endpoint. +data ChunkingSettings = ChunkingSettings + { csMaxChunkSize :: Maybe Int, + csOverlap :: Maybe Int, + csSentenceOverlap :: Maybe Int, + csSeparatorGroup :: Maybe Text, + csSeparators :: Maybe [Text], + csStrategy :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON ChunkingSettings where + toJSON ChunkingSettings {..} = + omitNulls + [ "max_chunk_size" .= csMaxChunkSize, + "overlap" .= csOverlap, + "sentence_overlap" .= csSentenceOverlap, + "separator_group" .= csSeparatorGroup, + "separators" .= csSeparators, + "strategy" .= csStrategy + ] + +instance FromJSON ChunkingSettings where + parseJSON = withObject "ChunkingSettings" $ \o -> + ChunkingSettings + <$> o .:? "max_chunk_size" + <*> o .:? "overlap" + <*> o .:? "sentence_overlap" + <*> o .:? "separator_group" + <*> o .:? "separators" + <*> o .:? "strategy" + +chunkingSettingsMaxChunkSizeLens :: Lens' ChunkingSettings (Maybe Int) +chunkingSettingsMaxChunkSizeLens = + lens csMaxChunkSize (\x y -> x {csMaxChunkSize = y}) + +chunkingSettingsOverlapLens :: Lens' ChunkingSettings (Maybe Int) +chunkingSettingsOverlapLens = lens csOverlap (\x y -> x {csOverlap = y}) + +chunkingSettingsSentenceOverlapLens :: Lens' ChunkingSettings (Maybe Int) +chunkingSettingsSentenceOverlapLens = + lens csSentenceOverlap (\x y -> x {csSentenceOverlap = y}) + +chunkingSettingsSeparatorGroupLens :: Lens' ChunkingSettings (Maybe Text) +chunkingSettingsSeparatorGroupLens = + lens csSeparatorGroup (\x y -> x {csSeparatorGroup = y}) + +chunkingSettingsSeparatorsLens :: Lens' ChunkingSettings (Maybe [Text]) +chunkingSettingsSeparatorsLens = + lens csSeparators (\x y -> x {csSeparators = y}) + +chunkingSettingsStrategyLens :: Lens' ChunkingSettings (Maybe Text) +chunkingSettingsStrategyLens = lens csStrategy (\x y -> x {csStrategy = y}) + +-- | Provider-specific configuration. Each constructor wraps the typed +-- @service_settings@ (and, where the provider defines one, @task_settings@) +-- for one of the inference services documented at +-- . +-- +-- The 'GenericProvider' constructor is an escape hatch for services not +-- individually typed (or for forward compatibility with providers +-- introduced after this binding was written): supply the raw @service@ +-- name and the @service_settings@ \/ @task_settings@ payloads as opaque +-- JSON. +data InferenceProvider + = OpenAIProvider OpenAIServiceSettings (Maybe OpenAITaskSettings) + | CohereProvider CohereServiceSettings (Maybe CohereTaskSettings) + | ElserProvider ElserServiceSettings + | Ai21Provider Ai21ServiceSettings + | MistralProvider MistralServiceSettings + | AnthropicProvider AnthropicServiceSettings (Maybe AnthropicTaskSettings) + | DeepSeekProvider DeepSeekServiceSettings + | NvidiaProvider NvidiaServiceSettings (Maybe NvidiaTaskSettings) + | ContextualAiProvider ContextualAiServiceSettings (Maybe ContextualAiTaskSettings) + | FireworksAiProvider FireworksAiServiceSettings (Maybe FireworksAiTaskSettings) + | GoogleAiStudioProvider GoogleAiStudioServiceSettings + | GoogleVertexAiProvider GoogleVertexAiServiceSettings (Maybe GoogleVertexAiTaskSettings) + | GroqProvider GroqServiceSettings + | HuggingFaceProvider HuggingFaceServiceSettings (Maybe HuggingFaceTaskSettings) + | JinaAiProvider JinaAiServiceSettings (Maybe JinaAiTaskSettings) + | LlamaProvider LlamaServiceSettings + | OpenShiftAiProvider OpenShiftAiServiceSettings (Maybe OpenShiftAiTaskSettings) + | VoyageAiProvider VoyageAiServiceSettings (Maybe VoyageAiTaskSettings) + | ElasticsearchProvider ElasticsearchServiceSettings (Maybe ElasticsearchTaskSettings) + | AlibabaCloudProvider AlibabaCloudServiceSettings (Maybe AlibabaCloudTaskSettings) + | AmazonBedrockProvider AmazonBedrockServiceSettings (Maybe AmazonBedrockTaskSettings) + | AmazonSageMakerProvider AmazonSageMakerServiceSettings (Maybe AmazonSageMakerTaskSettings) + | AzureAiStudioProvider AzureAiStudioServiceSettings (Maybe AzureAiStudioTaskSettings) + | AzureOpenAiProvider AzureOpenAiServiceSettings (Maybe AzureOpenAiTaskSettings) + | CustomProvider CustomServiceSettings (Maybe CustomTaskSettings) + | WatsonxProvider WatsonxServiceSettings + | GenericProvider Text Value (Maybe Value) + deriving stock (Eq, Show) + +-- | The wire value of the @service@ field for a provider. +providerService :: InferenceProvider -> Text +providerService = \case + OpenAIProvider _ _ -> "openai" + CohereProvider _ _ -> "cohere" + ElserProvider _ -> "elser" + Ai21Provider _ -> "ai21" + MistralProvider _ -> "mistral" + AnthropicProvider _ _ -> "anthropic" + DeepSeekProvider _ -> "deepseek" + NvidiaProvider _ _ -> "nvidia" + ContextualAiProvider _ _ -> "contextualai" + FireworksAiProvider _ _ -> "fireworksai" + GoogleAiStudioProvider _ -> "googleaistudio" + GoogleVertexAiProvider _ _ -> "googlevertexai" + GroqProvider _ -> "groq" + HuggingFaceProvider _ _ -> "hugging_face" + JinaAiProvider _ _ -> "jinaai" + LlamaProvider _ -> "llama" + OpenShiftAiProvider _ _ -> "openshift_ai" + VoyageAiProvider _ _ -> "voyageai" + ElasticsearchProvider _ _ -> "elasticsearch" + AlibabaCloudProvider _ _ -> "alibabacloud-ai-search" + AmazonBedrockProvider _ _ -> "amazonbedrock" + AmazonSageMakerProvider _ _ -> "amazon_sagemaker" + AzureAiStudioProvider _ _ -> "azureaistudio" + AzureOpenAiProvider _ _ -> "azureopenai" + CustomProvider _ _ -> "custom" + WatsonxProvider _ -> "watsonxai" + GenericProvider svc _ _ -> svc + +providerServiceSettings :: InferenceProvider -> Value +providerServiceSettings = \case + OpenAIProvider ss _ -> toJSON ss + CohereProvider ss _ -> toJSON ss + ElserProvider ss -> toJSON ss + Ai21Provider ss -> toJSON ss + MistralProvider ss -> toJSON ss + AnthropicProvider ss _ -> toJSON ss + DeepSeekProvider ss -> toJSON ss + NvidiaProvider ss _ -> toJSON ss + ContextualAiProvider ss _ -> toJSON ss + FireworksAiProvider ss _ -> toJSON ss + GoogleAiStudioProvider ss -> toJSON ss + GoogleVertexAiProvider ss _ -> toJSON ss + GroqProvider ss -> toJSON ss + HuggingFaceProvider ss _ -> toJSON ss + JinaAiProvider ss _ -> toJSON ss + LlamaProvider ss -> toJSON ss + OpenShiftAiProvider ss _ -> toJSON ss + VoyageAiProvider ss _ -> toJSON ss + ElasticsearchProvider ss _ -> toJSON ss + AlibabaCloudProvider ss _ -> toJSON ss + AmazonBedrockProvider ss _ -> toJSON ss + AmazonSageMakerProvider ss _ -> toJSON ss + AzureAiStudioProvider ss _ -> toJSON ss + AzureOpenAiProvider ss _ -> toJSON ss + CustomProvider ss _ -> toJSON ss + WatsonxProvider ss -> toJSON ss + GenericProvider _ ss _ -> ss + +providerTaskSettings :: InferenceProvider -> Maybe Value +providerTaskSettings = \case + OpenAIProvider _ ts -> toJSON <$> ts + CohereProvider _ ts -> toJSON <$> ts + ElserProvider _ -> Nothing + Ai21Provider _ -> Nothing + MistralProvider _ -> Nothing + AnthropicProvider _ ts -> toJSON <$> ts + DeepSeekProvider _ -> Nothing + NvidiaProvider _ ts -> toJSON <$> ts + ContextualAiProvider _ ts -> toJSON <$> ts + FireworksAiProvider _ ts -> toJSON <$> ts + GoogleAiStudioProvider _ -> Nothing + GoogleVertexAiProvider _ ts -> toJSON <$> ts + GroqProvider _ -> Nothing + HuggingFaceProvider _ ts -> toJSON <$> ts + JinaAiProvider _ ts -> toJSON <$> ts + LlamaProvider _ -> Nothing + OpenShiftAiProvider _ ts -> toJSON <$> ts + VoyageAiProvider _ ts -> toJSON <$> ts + ElasticsearchProvider _ ts -> toJSON <$> ts + AlibabaCloudProvider _ ts -> toJSON <$> ts + AmazonBedrockProvider _ ts -> toJSON <$> ts + AmazonSageMakerProvider _ ts -> toJSON <$> ts + AzureAiStudioProvider _ ts -> toJSON <$> ts + AzureOpenAiProvider _ ts -> toJSON <$> ts + CustomProvider _ ts -> toJSON <$> ts + WatsonxProvider _ -> Nothing + GenericProvider _ _ ts -> ts + +-- | Request body for @PUT \/_inference\/{task_type}\/{inference_id}@ +-- (Elasticsearch 8.12+). The 'InferenceProvider' selects the @service@, +-- @service_settings@ and @task_settings@ payloads. +data InferenceConfig = InferenceConfig + { inferenceProvider :: InferenceProvider, + inferenceChunkingSettings :: Maybe ChunkingSettings + } + deriving stock (Eq, Show) + +instance ToJSON InferenceConfig where + toJSON InferenceConfig {..} = + omitNulls + [ "service" .= providerService inferenceProvider, + "service_settings" .= providerServiceSettings inferenceProvider, + "task_settings" .= providerTaskSettings inferenceProvider, + "chunking_settings" .= inferenceChunkingSettings + ] + +instance FromJSON InferenceConfig where + parseJSON = withObject "InferenceConfig" $ \o -> do + svc <- o .: "service" + ssVal <- o .: "service_settings" + tsVal <- o .:? "task_settings" + chunking <- o .:? "chunking_settings" + provider <- case svc of + "openai" -> + OpenAIProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "cohere" -> + CohereProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "elser" -> ElserProvider <$> parseJSON ssVal + "ai21" -> Ai21Provider <$> parseJSON ssVal + "mistral" -> MistralProvider <$> parseJSON ssVal + "anthropic" -> + AnthropicProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "deepseek" -> DeepSeekProvider <$> parseJSON ssVal + "nvidia" -> + NvidiaProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "contextualai" -> + ContextualAiProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "fireworksai" -> + FireworksAiProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "googleaistudio" -> GoogleAiStudioProvider <$> parseJSON ssVal + "googlevertexai" -> + GoogleVertexAiProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "groq" -> GroqProvider <$> parseJSON ssVal + "hugging_face" -> + HuggingFaceProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "jinaai" -> + JinaAiProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "llama" -> LlamaProvider <$> parseJSON ssVal + "openshift_ai" -> + OpenShiftAiProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "voyageai" -> + VoyageAiProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "elasticsearch" -> + ElasticsearchProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "alibabacloud-ai-search" -> + AlibabaCloudProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "amazonbedrock" -> + AmazonBedrockProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "amazon_sagemaker" -> + AmazonSageMakerProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "azureaistudio" -> + AzureAiStudioProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "azureopenai" -> + AzureOpenAiProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "custom" -> + CustomProvider <$> parseJSON ssVal <*> traverse parseJSON tsVal + "watsonxai" -> WatsonxProvider <$> parseJSON ssVal + other -> pure (GenericProvider other ssVal tsVal) + pure $ + InferenceConfig + { inferenceProvider = provider, + inferenceChunkingSettings = chunking + } + +inferenceConfigProviderLens :: Lens' InferenceConfig InferenceProvider +inferenceConfigProviderLens = + lens inferenceProvider (\x y -> x {inferenceProvider = y}) + +inferenceConfigChunkingSettingsLens :: Lens' InferenceConfig (Maybe ChunkingSettings) +inferenceConfigChunkingSettingsLens = + lens inferenceChunkingSettings (\x y -> x {inferenceChunkingSettings = y}) + +-- | Response body for @PUT \/_inference\/{task_type}\/{inference_id}@. The +-- server echoes the request and adds @inference_id@ and @task_type@. +-- @service_settings@, @task_settings@ and @chunking_settings@ are decoded as +-- opaque values because their shape depends on the provider. +data InferencePutResponse = InferencePutResponse + { iprInferenceId :: Text, + iprTaskType :: TaskType, + iprService :: Text, + iprServiceSettings :: Maybe Value, + iprTaskSettings :: Maybe Value, + iprChunkingSettings :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON InferencePutResponse where + toJSON InferencePutResponse {..} = + omitNulls + [ "inference_id" .= iprInferenceId, + "task_type" .= iprTaskType, + "service" .= iprService, + "service_settings" .= iprServiceSettings, + "task_settings" .= iprTaskSettings, + "chunking_settings" .= iprChunkingSettings + ] + +instance FromJSON InferencePutResponse where + parseJSON = withObject "InferencePutResponse" $ \o -> + InferencePutResponse + <$> o .: "inference_id" + <*> o .: "task_type" + <*> o .: "service" + <*> o .:? "service_settings" + <*> o .:? "task_settings" + <*> o .:? "chunking_settings" + +inferencePutResponseInferenceIdLens :: Lens' InferencePutResponse Text +inferencePutResponseInferenceIdLens = + lens iprInferenceId (\x y -> x {iprInferenceId = y}) + +inferencePutResponseTaskTypeLens :: Lens' InferencePutResponse TaskType +inferencePutResponseTaskTypeLens = + lens iprTaskType (\x y -> x {iprTaskType = y}) + +inferencePutResponseServiceLens :: Lens' InferencePutResponse Text +inferencePutResponseServiceLens = + lens iprService (\x y -> x {iprService = y}) + +inferencePutResponseServiceSettingsLens :: Lens' InferencePutResponse (Maybe Value) +inferencePutResponseServiceSettingsLens = + lens iprServiceSettings (\x y -> x {iprServiceSettings = y}) + +inferencePutResponseTaskSettingsLens :: Lens' InferencePutResponse (Maybe Value) +inferencePutResponseTaskSettingsLens = + lens iprTaskSettings (\x y -> x {iprTaskSettings = y}) + +inferencePutResponseChunkingSettingsLens :: Lens' InferencePutResponse (Maybe Value) +inferencePutResponseChunkingSettingsLens = + lens iprChunkingSettings (\x y -> x {iprChunkingSettings = y}) + +-- | Request body for @POST \/_inference\/{task_type}\/{inference_id}@ +-- (run inference). @input@ is always rendered as a JSON array; for a single +-- input string the server accepts a one-element array for every task type. +data InferenceInput = InferenceInput + { iiInput :: [Text], + iiQuery :: Maybe Text, + iiInputType :: Maybe Text, + iiTaskSettings :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON InferenceInput where + toJSON InferenceInput {..} = + object $ + ("input" .= iiInput) + : catMaybes + [ ("query" .=) <$> iiQuery, + ("input_type" .=) <$> iiInputType, + ("task_settings" .=) <$> iiTaskSettings + ] + +instance FromJSON InferenceInput where + parseJSON = withObject "InferenceInput" $ \o -> + InferenceInput + <$> o .: "input" + <*> o .:? "query" + <*> o .:? "input_type" + <*> o .:? "task_settings" + +inferenceInputInputLens :: Lens' InferenceInput [Text] +inferenceInputInputLens = lens iiInput (\x y -> x {iiInput = y}) + +inferenceInputQueryLens :: Lens' InferenceInput (Maybe Text) +inferenceInputQueryLens = lens iiQuery (\x y -> x {iiQuery = y}) + +inferenceInputInputTypeLens :: Lens' InferenceInput (Maybe Text) +inferenceInputInputTypeLens = lens iiInputType (\x y -> x {iiInputType = y}) + +inferenceInputTaskSettingsLens :: Lens' InferenceInput (Maybe Value) +inferenceInputTaskSettingsLens = + lens iiTaskSettings (\x y -> x {iiTaskSettings = y}) + +-- | A single chat message in a 'ChatCompletionRequest'. @content@ is +-- deliberately opaque ('Value') because Elasticsearch accepts either a +-- plain string or an array of typed content objects +-- (e.g. @{"type":"text","text":"..."}@) depending on the model and task. +-- It is optional because assistant messages that carry @tool_calls@ may +-- omit it. +-- +-- The remaining optional fields (@tool_call_id@, @tool_calls@, +-- @reasoning@, @reasoning_details@) mirror the @Message@ OpenAPI schema. +data ChatMessage = ChatMessage + { cmRole :: Text, + cmContent :: Maybe Value, + cmToolCallId :: Maybe Text, + cmToolCalls :: Maybe Value, + cmReasoning :: Maybe Value, + cmReasoningDetails :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON ChatMessage where + toJSON ChatMessage {..} = + omitNulls + [ "role" .= cmRole, + "content" .= cmContent, + "tool_call_id" .= cmToolCallId, + "tool_calls" .= cmToolCalls, + "reasoning" .= cmReasoning, + "reasoning_details" .= cmReasoningDetails + ] + +instance FromJSON ChatMessage where + parseJSON = withObject "ChatMessage" $ \o -> + ChatMessage + <$> o .: "role" + <*> o .:? "content" + <*> o .:? "tool_call_id" + <*> o .:? "tool_calls" + <*> o .:? "reasoning" + <*> o .:? "reasoning_details" + +chatMessageRoleLens :: Lens' ChatMessage Text +chatMessageRoleLens = lens cmRole (\x y -> x {cmRole = y}) + +chatMessageContentLens :: Lens' ChatMessage (Maybe Value) +chatMessageContentLens = lens cmContent (\x y -> x {cmContent = y}) + +chatMessageToolCallIdLens :: Lens' ChatMessage (Maybe Text) +chatMessageToolCallIdLens = lens cmToolCallId (\x y -> x {cmToolCallId = y}) + +chatMessageToolCallsLens :: Lens' ChatMessage (Maybe Value) +chatMessageToolCallsLens = lens cmToolCalls (\x y -> x {cmToolCalls = y}) + +chatMessageReasoningLens :: Lens' ChatMessage (Maybe Value) +chatMessageReasoningLens = lens cmReasoning (\x y -> x {cmReasoning = y}) + +chatMessageReasoningDetailsLens :: Lens' ChatMessage (Maybe Value) +chatMessageReasoningDetailsLens = + lens cmReasoningDetails (\x y -> x {cmReasoningDetails = y}) + +-- | Request body for the streaming chat-completion endpoint +-- @POST \/_inference\/chat_completion\/{inference_id}\/_stream@. Mirrors +-- the @RequestChatCompletion@ OpenAPI schema: a non-empty list of +-- 'ChatMessage's and the top-level parameters the server accepts. +-- +-- The spec defines @messages@ as required and every other field as +-- optional. Fields with complex or provider-dependent shapes (@reasoning@, +-- @stop@, @tool_choice@, @tools@) are typed as opaque 'Value's so callers +-- can supply any valid JSON without a dedicated record per sub-shape. +data ChatCompletionRequest = ChatCompletionRequest + { ccrMessages :: [ChatMessage], + ccrModel :: Maybe Text, + ccrMaxCompletionTokens :: Maybe Int, + ccrReasoning :: Maybe Value, + ccrStop :: Maybe Value, + ccrTemperature :: Maybe Double, + ccrToolChoice :: Maybe Value, + ccrTools :: Maybe Value, + ccrTopP :: Maybe Double + } + deriving stock (Eq, Show) + +instance ToJSON ChatCompletionRequest where + toJSON ChatCompletionRequest {..} = + omitNulls + [ "messages" .= ccrMessages, + "model" .= ccrModel, + "max_completion_tokens" .= ccrMaxCompletionTokens, + "reasoning" .= ccrReasoning, + "stop" .= ccrStop, + "temperature" .= ccrTemperature, + "tool_choice" .= ccrToolChoice, + "tools" .= ccrTools, + "top_p" .= ccrTopP + ] + +instance FromJSON ChatCompletionRequest where + parseJSON = withObject "ChatCompletionRequest" $ \o -> + ChatCompletionRequest + <$> o .: "messages" + <*> o .:? "model" + <*> o .:? "max_completion_tokens" + <*> o .:? "reasoning" + <*> o .:? "stop" + <*> o .:? "temperature" + <*> o .:? "tool_choice" + <*> o .:? "tools" + <*> o .:? "top_p" + +chatCompletionRequestMessagesLens :: Lens' ChatCompletionRequest [ChatMessage] +chatCompletionRequestMessagesLens = + lens ccrMessages (\x y -> x {ccrMessages = y}) + +chatCompletionRequestModelLens :: Lens' ChatCompletionRequest (Maybe Text) +chatCompletionRequestModelLens = + lens ccrModel (\x y -> x {ccrModel = y}) + +chatCompletionRequestMaxCompletionTokensLens :: Lens' ChatCompletionRequest (Maybe Int) +chatCompletionRequestMaxCompletionTokensLens = + lens ccrMaxCompletionTokens (\x y -> x {ccrMaxCompletionTokens = y}) + +chatCompletionRequestReasoningLens :: Lens' ChatCompletionRequest (Maybe Value) +chatCompletionRequestReasoningLens = + lens ccrReasoning (\x y -> x {ccrReasoning = y}) + +chatCompletionRequestStopLens :: Lens' ChatCompletionRequest (Maybe Value) +chatCompletionRequestStopLens = + lens ccrStop (\x y -> x {ccrStop = y}) + +chatCompletionRequestTemperatureLens :: Lens' ChatCompletionRequest (Maybe Double) +chatCompletionRequestTemperatureLens = + lens ccrTemperature (\x y -> x {ccrTemperature = y}) + +chatCompletionRequestToolChoiceLens :: Lens' ChatCompletionRequest (Maybe Value) +chatCompletionRequestToolChoiceLens = + lens ccrToolChoice (\x y -> x {ccrToolChoice = y}) + +chatCompletionRequestToolsLens :: Lens' ChatCompletionRequest (Maybe Value) +chatCompletionRequestToolsLens = + lens ccrTools (\x y -> x {ccrTools = y}) + +chatCompletionRequestTopPLens :: Lens' ChatCompletionRequest (Maybe Double) +chatCompletionRequestTopPLens = + lens ccrTopP (\x y -> x {ccrTopP = y}) + +-- | Which wire key a dense embedding result arrived under. The Elasticsearch +-- inference response uses different top-level keys for the same logical +-- payload depending on the requested numeric representation +-- (@text_embedding@, @embeddings@, @*_bytes@, @*_bits@). +data EmbeddingFormat + = FloatEmbedding + | BytesEmbedding + | BitsEmbedding + deriving stock (Eq, Show, Ord, Bounded, Enum) + +-- | A single dense (float-family) embedding vector. +newtype DenseEmbeddingItem = DenseEmbeddingItem + { deiEmbedding :: [Double] + } + deriving stock (Eq, Show) + +instance ToJSON DenseEmbeddingItem where + toJSON DenseEmbeddingItem {..} = + object ["embedding" .= deiEmbedding] + +instance FromJSON DenseEmbeddingItem where + parseJSON = withObject "DenseEmbeddingItem" $ \o -> + DenseEmbeddingItem <$> o .: "embedding" + +denseEmbeddingItemEmbeddingLens :: Lens' DenseEmbeddingItem [Double] +denseEmbeddingItemEmbeddingLens = + lens deiEmbedding (\x y -> x {deiEmbedding = y}) + +-- | A single sparse embedding vector (ELSER-style token weights). +data SparseEmbeddingItem = SparseEmbeddingItem + { seiIsTruncated :: Bool, + seiEmbedding :: M.Map Text Double + } + deriving stock (Eq, Show) + +instance ToJSON SparseEmbeddingItem where + toJSON SparseEmbeddingItem {..} = + object + [ "is_truncated" .= seiIsTruncated, + "embedding" .= seiEmbedding + ] + +instance FromJSON SparseEmbeddingItem where + parseJSON = withObject "SparseEmbeddingItem" $ \o -> + SparseEmbeddingItem + <$> o .: "is_truncated" + <*> o .: "embedding" + +sparseEmbeddingItemIsTruncatedLens :: Lens' SparseEmbeddingItem Bool +sparseEmbeddingItemIsTruncatedLens = + lens seiIsTruncated (\x y -> x {seiIsTruncated = y}) + +sparseEmbeddingItemEmbeddingLens :: Lens' SparseEmbeddingItem (M.Map Text Double) +sparseEmbeddingItemEmbeddingLens = + lens seiEmbedding (\x y -> x {seiEmbedding = y}) + +-- | A single chat/completion result. +newtype CompletionItem = CompletionItem + { ciResult :: Text + } + deriving stock (Eq, Show) + +instance ToJSON CompletionItem where + toJSON CompletionItem {..} = + object ["result" .= ciResult] + +instance FromJSON CompletionItem where + parseJSON = withObject "CompletionItem" $ \o -> + CompletionItem <$> o .: "result" + +completionItemResultLens :: Lens' CompletionItem Text +completionItemResultLens = lens ciResult (\x y -> x {ciResult = y}) + +-- | A single rerank result. @text@ is present when @return_documents@ was set +-- on the request. +data RerankItem = RerankItem + { riIndex :: Int, + riRelevanceScore :: Double, + riText :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON RerankItem where + toJSON RerankItem {..} = + omitNulls + [ "index" .= riIndex, + "relevance_score" .= riRelevanceScore, + "text" .= riText + ] + +instance FromJSON RerankItem where + parseJSON = withObject "RerankItem" $ \o -> + RerankItem + <$> o .: "index" + <*> o .: "relevance_score" + <*> o .:? "text" + +rerankItemIndexLens :: Lens' RerankItem Int +rerankItemIndexLens = lens riIndex (\x y -> x {riIndex = y}) + +rerankItemRelevanceScoreLens :: Lens' RerankItem Double +rerankItemRelevanceScoreLens = + lens riRelevanceScore (\x y -> x {riRelevanceScore = y}) + +rerankItemTextLens :: Lens' RerankItem (Maybe Text) +rerankItemTextLens = lens riText (\x y -> x {riText = y}) + +-- | Response body for @POST \/_inference\/{task_type}\/{inference_id}@. The +-- Elasticsearch inference response is a single-key object whose key selects +-- the result variant (the OpenAPI schema enforces @maxProperties: 1@). +-- +-- 'FromJSON' accepts both the singular (@text_embedding@) and plural +-- (@embeddings@) keys, as well as the @*_bytes@ \/ @*_bits@ numeric variants, +-- collapsing them onto 'FloatEmbedding' \/ 'BytesEmbedding' \/ 'BitsEmbedding'. +-- 'ToJSON' (used for round-tripping) emits a canonical representative key per +-- format, so encode-after-decode may normalise the key name while preserving +-- the 'EmbeddingFormat'. +data InferenceResult + = DenseEmbeddingResult EmbeddingFormat [DenseEmbeddingItem] + | SparseEmbeddingResult [SparseEmbeddingItem] + | CompletionResult [CompletionItem] + | RerankResult [RerankItem] + deriving stock (Eq, Show) + +denseResultKey :: EmbeddingFormat -> Key +denseResultKey = \case + FloatEmbedding -> "text_embedding" + BytesEmbedding -> "embeddings_bytes" + BitsEmbedding -> "embeddings_bits" + +instance ToJSON InferenceResult where + toJSON = \case + DenseEmbeddingResult fmt xs -> object [denseResultKey fmt .= xs] + SparseEmbeddingResult xs -> object ["sparse_embedding" .= xs] + CompletionResult xs -> object ["completion" .= xs] + RerankResult xs -> object ["rerank" .= xs] + +instance FromJSON InferenceResult where + parseJSON = withObject "InferenceResult" $ \o -> case KM.toList o of + [(k, v)] -> dispatch k v + [] -> fail "InferenceResult: empty object (expected exactly one key)" + _ -> fail "InferenceResult: expected exactly one key" + where + dispatch k v = case toText k of + "text_embedding" -> + DenseEmbeddingResult FloatEmbedding <$> parseJSON v + "embeddings" -> + DenseEmbeddingResult FloatEmbedding <$> parseJSON v + "text_embedding_bytes" -> + DenseEmbeddingResult BytesEmbedding <$> parseJSON v + "embeddings_bytes" -> + DenseEmbeddingResult BytesEmbedding <$> parseJSON v + "text_embedding_bits" -> + DenseEmbeddingResult BitsEmbedding <$> parseJSON v + "embeddings_bits" -> + DenseEmbeddingResult BitsEmbedding <$> parseJSON v + "sparse_embedding" -> SparseEmbeddingResult <$> parseJSON v + "completion" -> CompletionResult <$> parseJSON v + "rerank" -> RerankResult <$> parseJSON v + other -> + fail $ "InferenceResult: unknown result key " <> T.unpack other + +-- | One entry in the response of @GET \/_inference@ +-- (and its @\/{task_type}@ \/ @\/{task_type}\/{inference_id}@ filter +-- variants). The Elasticsearch inference GET API returns a JSON object +-- keyed by @\/@; this type is the decoded form +-- of one such entry, with the key split back into its 'TaskType' and +-- 'InferenceId' components. +-- +-- @service_settings@, @task_settings@ and @chunking_settings@ are +-- decoded as opaque JSON values because their shape depends on the +-- backing provider (and @service_settings.api_key@ is returned as +-- @null@ by the server to avoid leaking the secret). +data InferenceInfo = InferenceInfo + { infTaskType :: TaskType, + infInferenceId :: InferenceId, + infService :: Text, + infServiceSettings :: Maybe Value, + infTaskSettings :: Maybe Value, + infChunkingSettings :: Maybe Value + } + deriving stock (Eq, Show) + +inferenceInfoTaskTypeLens :: Lens' InferenceInfo TaskType +inferenceInfoTaskTypeLens = + lens infTaskType (\x y -> x {infTaskType = y}) + +inferenceInfoInferenceIdLens :: Lens' InferenceInfo InferenceId +inferenceInfoInferenceIdLens = + lens infInferenceId (\x y -> x {infInferenceId = y}) + +inferenceInfoServiceLens :: Lens' InferenceInfo Text +inferenceInfoServiceLens = + lens infService (\x y -> x {infService = y}) + +inferenceInfoServiceSettingsLens :: Lens' InferenceInfo (Maybe Value) +inferenceInfoServiceSettingsLens = + lens infServiceSettings (\x y -> x {infServiceSettings = y}) + +inferenceInfoTaskSettingsLens :: Lens' InferenceInfo (Maybe Value) +inferenceInfoTaskSettingsLens = + lens infTaskSettings (\x y -> x {infTaskSettings = y}) + +inferenceInfoChunkingSettingsLens :: Lens' InferenceInfo (Maybe Value) +inferenceInfoChunkingSettingsLens = + lens infChunkingSettings (\x y -> x {infChunkingSettings = y}) + +-- | Direct 'ToJSON' for the bare-object form of 'InferenceInfo', as returned +-- by @PUT \/_inference\/{task_type}\/{inference_id}\/_update@ (and other +-- endpoints that return a single 'InferenceEndpointInfo' without a +-- @\/@ key wrapper). +instance ToJSON InferenceInfo where + toJSON InferenceInfo {..} = + omitNulls + [ "task_type" .= infTaskType, + "inference_id" .= infInferenceId, + "service" .= infService, + "service_settings" .= infServiceSettings, + "task_settings" .= infTaskSettings, + "chunking_settings" .= infChunkingSettings + ] + +-- | Direct 'FromJSON' for the bare-object form of 'InferenceInfo' +-- (@{task_type, inference_id, service, ...}@). This complements the +-- keyed-map decoding done by 'parseInferenceInfoEntry' / +-- 'InferenceEndpointsResponse'. +instance FromJSON InferenceInfo where + parseJSON = withObject "InferenceInfo" $ \o -> + InferenceInfo + <$> o .: "task_type" + <*> o .: "inference_id" + <*> o .: "service" + <*> o .:? "service_settings" + <*> o .:? "task_settings" + <*> o .:? "chunking_settings" + +-- | Internal decoder for a single @\/@ entry. +-- Splits the key on the first @\/@, parses the head with +-- 'taskTypeFromText' and treats the tail as the 'InferenceId'. +-- +-- The inner object is decoded for the 'InferenceEndpoint' body fields +-- (@service@, @service_settings@, @task_settings@, @chunking_settings@) +-- only — the list-envelope shape does NOT carry @task_type@ or +-- @inference_id@ in the body (they come from the key), so this intentionally +-- does /not/ reuse the direct 'FromJSON InferenceInfo' instance (whose +-- bare-object form requires those two fields). +parseInferenceInfoEntry :: Key -> Value -> Parser InferenceInfo +parseInferenceInfoEntry k v = do + case T.breakOn "/" (toText k) of + (_, "") -> + fail $ + "InferenceInfo: key without '/' separator: " <> T.unpack (toText k) + (taskTypeText, restWithSep) -> case taskTypeFromText taskTypeText of + Nothing -> + fail $ + "InferenceInfo: unknown task_type in key: " <> T.unpack taskTypeText + Just tt -> withObject "InferenceInfo" decodeInner v + where + decodeInner o = + InferenceInfo tt (InferenceId (T.drop 1 restWithSep)) + <$> o .: "service" + <*> o .:? "service_settings" + <*> o .:? "task_settings" + <*> o .:? "chunking_settings" + +-- | Wrapper around @[InferenceInfo]@ used as the response type of +-- 'getInferenceEndpoints'. The Elasticsearch @GET \/_inference@ API returns +-- a JSON object keyed by @\/@; this wrapper +-- flattens that map into a list. A newtype (rather than a bare +-- @FromJSON [InferenceInfo]@ instance) avoids overlapping with aeson's +-- generic @FromJSON [a]@, mirroring the 'GetDataStreamsResponse' +-- pattern. +-- +-- The per-id variant @GET \/_inference\/{task_type}\/{inference_id}@ returns +-- a different envelope — @{"endpoints": [InferenceEndpointInfo, ...]}@ — +-- which this decoder also accepts (dispatching on the presence of an +-- @endpoints@ key), so a single 'getInferenceEndpoints' call works for the +-- list-all, list-by-task-type and per-id path variants. +newtype InferenceEndpointsResponse = InferenceEndpointsResponse + { unInferenceEndpointsResponse :: [InferenceInfo] + } + deriving stock (Eq, Show) + +instance FromJSON InferenceEndpointsResponse where + parseJSON = withObject "InferenceEndpointsResponse" $ \o -> + case KM.lookup "endpoints" o of + Just endpointsValue -> + -- Per-id / updated-endpoint envelope: {"endpoints": [InferenceEndpointInfo]} + InferenceEndpointsResponse <$> parseJSON endpointsValue + Nothing -> + -- List envelope: object keyed by "/" + InferenceEndpointsResponse + <$> traverse (uncurry parseInferenceInfoEntry) (KM.toList o) + +-- | URI parameters accepted by @DELETE /_inference/{task_type}/{inference_id}@. +-- Both flags are optional on the server (omitted ≡ @false@); they are plain +-- 'Bool's rather than @Maybe Bool@ so the wire format is always explicit. +-- 'defaultDeleteInferenceOptions' sends @dry_run=false&force=false@, which is +-- semantically identical to the bare @DELETE@ that 'deleteInferenceEndpoint' +-- emits (that function stays hand-written with no query string for backward +-- wire compatibility; use 'deleteInferenceEndpointWith' to send the flags). +data DeleteInferenceOptions = DeleteInferenceOptions + { dioDryRun :: Bool, + dioForce :: Bool + } + deriving stock (Eq, Show) + +-- | Both flags @False@ — a plain @DELETE@ that will fail if the endpoint is +-- in use (referenced by other configurations). Flip 'dioForce' to @True@ to +-- delete it anyway; flip 'dioDryRun' to @True@ to preview the deletion +-- without performing it. +defaultDeleteInferenceOptions :: DeleteInferenceOptions +defaultDeleteInferenceOptions = + DeleteInferenceOptions + { dioDryRun = False, + dioForce = False + } + +dioDryRunLens :: Lens' DeleteInferenceOptions Bool +dioDryRunLens = + lens dioDryRun (\x y -> x {dioDryRun = y}) + +dioForceLens :: Lens' DeleteInferenceOptions Bool +dioForceLens = + lens dioForce (\x y -> x {dioForce = y}) + +-- | Render 'DeleteInferenceOptions' as URI parameters. Both flags are always +-- emitted (as @true@ or @false@), in the fixed order @dry_run@ then @force@. +deleteInferenceOptionsParams :: DeleteInferenceOptions -> [(Text, Maybe Text)] +deleteInferenceOptionsParams opts = + [ ("dry_run", Just (boolQP (dioDryRun opts))), + ("force", Just (boolQP (dioForce opts))) + ] + where + boolQP True = "true" + boolQP False = "false" + +-- /Inference timeout options/ (ES 8.12+, also in ES 9.x). The four +-- mutating inference operations — PUT (create\/update), POST (run), and the +-- two @_stream@ POSTs (completion \/ chat completion) — each accept a single +-- optional @timeout@ URI parameter. It is modelled as a +-- @'Maybe' ('TimeUnits', 'Word32')@ pair rendered via 'timeUnitsSuffix' +-- (e.g. @('TimeUnitSeconds', 30)@ → @"30s"@), matching the convention used by +-- "Database.Bloodhound.Internal.Versions.Common.Types.Reroute" and the +-- cluster\/index option records. +-- +-- Each operation gets its own record (mirroring the operation-scoped +-- 'DeleteInferenceOptions') so the public API can grow operation-specific +-- parameters later without a breaking rename. The four records are identical +-- in shape today; they differ only in name. 'default*Options' renders no +-- query string, so the @*With@ builder paired with it is byte-for-byte +-- identical to the parameterless variant. + +-- | URI parameters accepted by @PUT /_inference/{task_type}/{inference_id}@. +-- Currently carries only the @timeout@ query parameter documented at +-- : +-- an upper bound on the time the server spends on the create/update. +-- 'defaultPutInferenceOptions' renders no query string, so +-- 'putInferenceEndpointWith' with it is byte-for-byte identical to +-- 'putInferenceEndpoint'. +data PutInferenceOptions = PutInferenceOptions + { pioTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'PutInferenceOptions' with @timeout@ set to 'Nothing'. Renders no +-- query string. +defaultPutInferenceOptions :: PutInferenceOptions +defaultPutInferenceOptions = + PutInferenceOptions {pioTimeout = Nothing} + +pioTimeoutLens :: Lens' PutInferenceOptions (Maybe (TimeUnits, Word32)) +pioTimeoutLens = + lens pioTimeout (\x y -> x {pioTimeout = y}) + +-- | Render 'PutInferenceOptions' as URI parameters. 'Nothing' fields are +-- omitted, so 'defaultPutInferenceOptions' produces @[]@. +putInferenceOptionsParams :: PutInferenceOptions -> [(Text, Maybe Text)] +putInferenceOptionsParams opts = + catMaybes + [ ("timeout",) . Just . renderInferenceTimeout <$> pioTimeout opts + ] + +-- | URI parameters accepted by @POST /_inference/{task_type}/{inference_id}@. +-- Currently carries only the @timeout@ query parameter documented at +-- : +-- an upper bound on the time the server spends on the inference call (useful, +-- as inference can be slow). 'defaultRunInferenceOptions' renders no query +-- string, so 'runInferenceWith' with it is byte-for-byte identical to +-- 'runInference'. +data RunInferenceOptions = RunInferenceOptions + { rnioTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'RunInferenceOptions' with @timeout@ set to 'Nothing'. Renders no +-- query string. +defaultRunInferenceOptions :: RunInferenceOptions +defaultRunInferenceOptions = + RunInferenceOptions {rnioTimeout = Nothing} + +rnioTimeoutLens :: Lens' RunInferenceOptions (Maybe (TimeUnits, Word32)) +rnioTimeoutLens = + lens rnioTimeout (\x y -> x {rnioTimeout = y}) + +-- | Render 'RunInferenceOptions' as URI parameters. 'Nothing' fields are +-- omitted, so 'defaultRunInferenceOptions' produces @[]@. +runInferenceOptionsParams :: RunInferenceOptions -> [(Text, Maybe Text)] +runInferenceOptionsParams opts = + catMaybes + [ ("timeout",) . Just . renderInferenceTimeout <$> rnioTimeout opts + ] + +-- | URI parameters accepted by +-- @POST /_inference/completion/{inference_id}/_stream@ +-- (see +-- ). +-- Currently carries only the @timeout@ query parameter: an upper bound on the +-- time the server spends establishing the stream. 'defaultStreamCompletionInferenceOptions' +-- renders no query string, so 'streamCompletionInferenceWith' with it is +-- byte-for-byte identical to 'streamCompletionInference'. +data StreamCompletionInferenceOptions = StreamCompletionInferenceOptions + { scioTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'StreamCompletionInferenceOptions' with @timeout@ set to 'Nothing'. +-- Renders no query string. +defaultStreamCompletionInferenceOptions :: StreamCompletionInferenceOptions +defaultStreamCompletionInferenceOptions = + StreamCompletionInferenceOptions {scioTimeout = Nothing} + +scioTimeoutLens :: Lens' StreamCompletionInferenceOptions (Maybe (TimeUnits, Word32)) +scioTimeoutLens = + lens scioTimeout (\x y -> x {scioTimeout = y}) + +-- | Render 'StreamCompletionInferenceOptions' as URI parameters. 'Nothing' +-- fields are omitted, so 'defaultStreamCompletionInferenceOptions' produces @[]@. +streamCompletionInferenceOptionsParams :: StreamCompletionInferenceOptions -> [(Text, Maybe Text)] +streamCompletionInferenceOptionsParams opts = + catMaybes + [ ("timeout",) . Just . renderInferenceTimeout <$> scioTimeout opts + ] + +-- | URI parameters accepted by +-- @POST /_inference/chat_completion/{inference_id}/_stream@ +-- (see +-- ). +-- Currently carries only the @timeout@ query parameter: an upper bound on the +-- time the server spends establishing the stream. +-- 'defaultStreamChatCompletionInferenceOptions' renders no query string, so +-- 'streamChatCompletionInferenceWith' with it is byte-for-byte identical to +-- 'streamChatCompletionInference'. +data StreamChatCompletionInferenceOptions = StreamChatCompletionInferenceOptions + { sccioTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'StreamChatCompletionInferenceOptions' with @timeout@ set to 'Nothing'. +-- Renders no query string. +defaultStreamChatCompletionInferenceOptions :: StreamChatCompletionInferenceOptions +defaultStreamChatCompletionInferenceOptions = + StreamChatCompletionInferenceOptions {sccioTimeout = Nothing} + +sccioTimeoutLens :: Lens' StreamChatCompletionInferenceOptions (Maybe (TimeUnits, Word32)) +sccioTimeoutLens = + lens sccioTimeout (\x y -> x {sccioTimeout = y}) + +-- | Render 'StreamChatCompletionInferenceOptions' as URI parameters. +-- 'Nothing' fields are omitted, so +-- 'defaultStreamChatCompletionInferenceOptions' produces @[]@. +streamChatCompletionInferenceOptionsParams :: StreamChatCompletionInferenceOptions -> [(Text, Maybe Text)] +streamChatCompletionInferenceOptionsParams opts = + catMaybes + [ ("timeout",) . Just . renderInferenceTimeout <$> sccioTimeout opts + ] + +-- | Shared renderer for an @(units, amount)@ timeout pair, e.g. +-- @('TimeUnitSeconds', 30)@ → @"30s"@. Mirrors the local @renderDuration@ +-- helpers in the cluster\/index option modules. +renderInferenceTimeout :: (TimeUnits, Word32) -> Text +renderInferenceTimeout (u, n) = showText n <> timeUnitsSuffix u diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/MigrationReindex.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/MigrationReindex.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/MigrationReindex.hs @@ -0,0 +1,424 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- \$caveat +-- +-- The @index@ fields are typed as 'IndexName' to match the ES +-- @_types.IndexName@ schema. Note that 'IndexName' rejects names +-- containing a colon (@:@); data streams whose names contain a colon +-- (e.g. @logs:apache@) and their backing indices cannot therefore be +-- round-tripped through these bindings. This is a known limitation of +-- using the typed 'IndexName' over a raw 'Data.Text.Text'. +-- +-- See +-- . + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.MigrationReindex +-- Description : Types for the Elasticsearch migration reindex APIs +-- +-- Defines the request and response shapes for the four Elasticsearch +-- "migration reindex" endpoints (GA since ES 8.18.0, unchanged in 9.x), +-- used to upgrade the legacy backing indices of a data stream as part of +-- a major-version migration: +-- +-- * @POST /_migration/reindex@ — 'mkMigrateReindexRequest' body, returns +-- 'Acknowledged' (the reindex itself runs in a persistent task). +-- * @POST /_migration/reindex/{index}/_cancel@ — no body, returns +-- 'Acknowledged'. +-- * @GET /_migration/reindex/{index}/_status@ — no body, returns +-- 'MigrateReindexStatus'. +-- * @POST /_create_from/{source}/{dest}@ — optional 'CreateIndexFromBody', +-- returns 'CreateIndexFromResponse'. +-- +-- These are distinct from the deprecations \/ system_features types in +-- "Database.Bloodhound.Internal.Versions.Common.Types.Migration" (which +-- cover @GET /_migration/deprecations@ and @*\/_migration/system_features@). +-- +-- The wire shape is identical across ES 8.18+ and 9.x, so the types live +-- in the ES8 layer and are re-exported by the ES9 layer (the same +-- arrangement used for inference and the other 8.x-origin endpoints). +module Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.MigrationReindex + ( -- * Reindex (POST /_migration/reindex) + MigrateReindexMode (..), + MigrateReindexSource (..), + MigrateReindexRequest (..), + mkMigrateReindexRequest, + + -- * Status (GET /_migration/reindex/{index}/_status) + MigrateReindexInProgress (..), + MigrateReindexError (..), + MigrateReindexStatus (..), + + -- * Create from source (POST /_create_from/{source}/{dest}) + CreateIndexFromBody (..), + defaultCreateIndexFromBody, + CreateIndexFromResponse (..), + + -- * Optics + migrateReindexSourceIndexLens, + migrateReindexRequestSourceLens, + migrateReindexRequestModeLens, + migrateReindexInProgressIndexLens, + migrateReindexInProgressTotalDocCountLens, + migrateReindexInProgressReindexedDocCountLens, + migrateReindexErrorIndexLens, + migrateReindexErrorMessageLens, + migrateReindexStatusStartTimeLens, + migrateReindexStatusStartTimeMillisLens, + migrateReindexStatusCompleteLens, + migrateReindexStatusTotalIndicesInDataStreamLens, + migrateReindexStatusTotalIndicesRequiringUpgradeLens, + migrateReindexStatusSuccessesLens, + migrateReindexStatusInProgressLens, + migrateReindexStatusPendingLens, + migrateReindexStatusErrorsLens, + migrateReindexStatusExceptionLens, + createIndexFromBodyMappingsOverrideLens, + createIndexFromBodySettingsOverrideLens, + createIndexFromBodyRemoveIndexBlocksLens, + createIndexFromResponseAcknowledgedLens, + createIndexFromResponseIndexLens, + createIndexFromResponseShardsAcknowledgedLens, + ) +where + +import Data.Aeson +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( IndexName, + ) + +-- | The @mode@ field of 'MigrateReindexRequest'. Elasticsearch currently +-- exposes a single value, @upgrade@; it is modelled as a sum type so that +-- adding future modes is a non-breaking change. An unknown value fails to +-- decode (a deliberate signal that a new mode warrants a constructor +-- here). +data MigrateReindexMode + = MigrateReindexModeUpgrade + deriving stock (Eq, Show, Ord, Bounded, Enum) + +instance ToJSON MigrateReindexMode where + toJSON MigrateReindexModeUpgrade = String "upgrade" + +instance FromJSON MigrateReindexMode where + parseJSON = withText "MigrateReindexMode" $ \case + "upgrade" -> pure MigrateReindexModeUpgrade + other -> + fail ("unknown migrate reindex mode: " <> show other) + +-- | The @source@ object of 'MigrateReindexRequest', carrying the single +-- required @index@ field: the data stream (or index) whose legacy backing +-- indices should be reindexed. +data MigrateReindexSource = MigrateReindexSource + { migrateReindexSourceIndex :: IndexName + } + deriving stock (Eq, Show) + +instance FromJSON MigrateReindexSource where + parseJSON = withObject "MigrateReindexSource" $ \o -> do + migrateReindexSourceIndex <- o .: "index" + return MigrateReindexSource {..} + +instance ToJSON MigrateReindexSource where + toJSON MigrateReindexSource {..} = + object ["index" .= migrateReindexSourceIndex] + +-- | Request body of @POST /_migration/reindex@. The reindex runs in a +-- persistent task; the endpoint returns 'Acknowledged' immediately rather +-- than a 'Database.Bloodhound.Internal.Client.BHRequest.ReindexResponse'. +data MigrateReindexRequest = MigrateReindexRequest + { migrateReindexRequestSource :: MigrateReindexSource, + migrateReindexRequestMode :: MigrateReindexMode + } + deriving stock (Eq, Show) + +instance FromJSON MigrateReindexRequest where + parseJSON = withObject "MigrateReindexRequest" $ \o -> do + migrateReindexRequestSource <- o .: "source" + migrateReindexRequestMode <- o .: "mode" + return MigrateReindexRequest {..} + +instance ToJSON MigrateReindexRequest where + toJSON MigrateReindexRequest {..} = + object + [ "source" .= migrateReindexRequestSource, + "mode" .= migrateReindexRequestMode + ] + +-- | Smart constructor for 'MigrateReindexRequest': reindex the given data +-- stream \/ index in the only currently-supported @upgrade@ mode. +mkMigrateReindexRequest :: IndexName -> MigrateReindexRequest +mkMigrateReindexRequest index = + MigrateReindexRequest + { migrateReindexRequestSource = + MigrateReindexSource {migrateReindexSourceIndex = index}, + migrateReindexRequestMode = MigrateReindexModeUpgrade + } + +-- | One entry of 'MigrateReindexStatus'\'s @in_progress@ array: a backing +-- index currently being reindexed, with its document counters. +data MigrateReindexInProgress = MigrateReindexInProgress + { migrateReindexInProgressIndex :: IndexName, + migrateReindexInProgressTotalDocCount :: Int, + migrateReindexInProgressReindexedDocCount :: Int + } + deriving stock (Eq, Show) + +instance FromJSON MigrateReindexInProgress where + parseJSON = withObject "MigrateReindexInProgress" $ \o -> do + migrateReindexInProgressIndex <- o .: "index" + migrateReindexInProgressTotalDocCount <- o .: "total_doc_count" + migrateReindexInProgressReindexedDocCount <- o .: "reindexed_doc_count" + return MigrateReindexInProgress {..} + +instance ToJSON MigrateReindexInProgress where + toJSON MigrateReindexInProgress {..} = + object + [ "index" .= migrateReindexInProgressIndex, + "total_doc_count" .= migrateReindexInProgressTotalDocCount, + "reindexed_doc_count" .= migrateReindexInProgressReindexedDocCount + ] + +-- | One entry of 'MigrateReindexStatus'\'s @errors@ array: a backing +-- index whose reindex attempt failed, with the human-readable reason. +data MigrateReindexError = MigrateReindexError + { migrateReindexErrorIndex :: IndexName, + migrateReindexErrorMessage :: Text + } + deriving stock (Eq, Show) + +instance FromJSON MigrateReindexError where + parseJSON = withObject "MigrateReindexError" $ \o -> do + migrateReindexErrorIndex <- o .: "index" + migrateReindexErrorMessage <- o .: "message" + return MigrateReindexError {..} + +instance ToJSON MigrateReindexError where + toJSON MigrateReindexError {..} = + object + [ "index" .= migrateReindexErrorIndex, + "message" .= migrateReindexErrorMessage + ] + +-- | Response body of @GET /_migration/reindex/{index}/_status@. Reports +-- the progress of a migration reindex attempt for a data stream \/ index: +-- how many backing indices exist, how many needed upgrading, and how many +-- have succeeded \/ are in progress \/ pending \/ errored. +-- +-- @start_time@ is an ES @_types.DateTime@, which may be either an +-- ISO-8601 string or an epoch-millis number; it is surfaced as an opaque +-- 'Value' so both wire forms decode cleanly. The companion +-- @start_time_millis@ is always a number. @exception@ is present only +-- when the overall attempt errored. +-- +-- The @in_progress@ and @errors@ arrays are tolerated as absent +-- (defaulting to @[]@) so the decoder survives older responses that omit +-- them. +data MigrateReindexStatus = MigrateReindexStatus + { migrateReindexStatusStartTime :: Maybe Value, + migrateReindexStatusStartTimeMillis :: Int, + migrateReindexStatusComplete :: Bool, + migrateReindexStatusTotalIndicesInDataStream :: Int, + migrateReindexStatusTotalIndicesRequiringUpgrade :: Int, + migrateReindexStatusSuccesses :: Int, + migrateReindexStatusInProgress :: [MigrateReindexInProgress], + migrateReindexStatusPending :: Int, + migrateReindexStatusErrors :: [MigrateReindexError], + migrateReindexStatusException :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON MigrateReindexStatus where + parseJSON = withObject "MigrateReindexStatus" $ \o -> do + migrateReindexStatusStartTime <- o .:? "start_time" + migrateReindexStatusStartTimeMillis <- o .: "start_time_millis" + migrateReindexStatusComplete <- o .: "complete" + migrateReindexStatusTotalIndicesInDataStream <- o .: "total_indices_in_data_stream" + migrateReindexStatusTotalIndicesRequiringUpgrade <- o .: "total_indices_requiring_upgrade" + migrateReindexStatusSuccesses <- o .: "successes" + migrateReindexStatusInProgress <- o .:? "in_progress" .!= [] + migrateReindexStatusPending <- o .: "pending" + migrateReindexStatusErrors <- o .:? "errors" .!= [] + migrateReindexStatusException <- o .:? "exception" + return MigrateReindexStatus {..} + +instance ToJSON MigrateReindexStatus where + toJSON MigrateReindexStatus {..} = + omitNulls $ + catMaybes + [ fmap ("start_time" .=) migrateReindexStatusStartTime, + Just ("start_time_millis" .= migrateReindexStatusStartTimeMillis), + Just ("complete" .= migrateReindexStatusComplete), + Just ("total_indices_in_data_stream" .= migrateReindexStatusTotalIndicesInDataStream), + Just ("total_indices_requiring_upgrade" .= migrateReindexStatusTotalIndicesRequiringUpgrade), + Just ("successes" .= migrateReindexStatusSuccesses), + Just ("in_progress" .= migrateReindexStatusInProgress), + Just ("pending" .= migrateReindexStatusPending), + Just ("errors" .= migrateReindexStatusErrors), + fmap ("exception" .=) migrateReindexStatusException + ] + +-- | Optional request body of @POST /_create_from/{source}/{dest}@. All +-- three fields are optional: @mappings_override@ and @settings_override@ +-- are free-form JSON objects (ES @_types.mapping.TypeMapping@ and index +-- settings) surfaced as 'Value' for the caller to assemble, and +-- @remove_index_blocks@ defaults to @true@ on the server when omitted. +data CreateIndexFromBody = CreateIndexFromBody + { createIndexFromBodyMappingsOverride :: Maybe Value, + createIndexFromBodySettingsOverride :: Maybe Value, + createIndexFromBodyRemoveIndexBlocks :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON CreateIndexFromBody where + parseJSON = withObject "CreateIndexFromBody" $ \o -> do + createIndexFromBodyMappingsOverride <- o .:? "mappings_override" + createIndexFromBodySettingsOverride <- o .:? "settings_override" + createIndexFromBodyRemoveIndexBlocks <- o .:? "remove_index_blocks" + return CreateIndexFromBody {..} + +instance ToJSON CreateIndexFromBody where + toJSON CreateIndexFromBody {..} = + omitNulls $ + catMaybes + [ fmap ("mappings_override" .=) createIndexFromBodyMappingsOverride, + fmap ("settings_override" .=) createIndexFromBodySettingsOverride, + fmap ("remove_index_blocks" .=) createIndexFromBodyRemoveIndexBlocks + ] + +-- | 'CreateIndexFromBody' with every override set to 'Nothing'. Sending +-- it is equivalent to omitting the body entirely (the server applies its +-- own defaults, including @remove_index_blocks = true@). +defaultCreateIndexFromBody :: CreateIndexFromBody +defaultCreateIndexFromBody = + CreateIndexFromBody + { createIndexFromBodyMappingsOverride = Nothing, + createIndexFromBodySettingsOverride = Nothing, + createIndexFromBodyRemoveIndexBlocks = Nothing + } + +-- | Response body of @POST /_create_from/{source}/{dest}@. Mirrors the +-- standard index-creation acknowledgement: @acknowledged@ that the +-- request was received, @shards_acknowledged@ that the requisite shards +-- responded, and @index@ echoing the destination name. +data CreateIndexFromResponse = CreateIndexFromResponse + { createIndexFromResponseAcknowledged :: Bool, + createIndexFromResponseIndex :: IndexName, + createIndexFromResponseShardsAcknowledged :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON CreateIndexFromResponse where + parseJSON = withObject "CreateIndexFromResponse" $ \o -> do + createIndexFromResponseAcknowledged <- o .: "acknowledged" + createIndexFromResponseIndex <- o .: "index" + createIndexFromResponseShardsAcknowledged <- o .: "shards_acknowledged" + return CreateIndexFromResponse {..} + +instance ToJSON CreateIndexFromResponse where + toJSON CreateIndexFromResponse {..} = + object + [ "acknowledged" .= createIndexFromResponseAcknowledged, + "index" .= createIndexFromResponseIndex, + "shards_acknowledged" .= createIndexFromResponseShardsAcknowledged + ] + +-- Lenses + +migrateReindexSourceIndexLens :: Lens' MigrateReindexSource IndexName +migrateReindexSourceIndexLens = + lens migrateReindexSourceIndex (\x y -> x {migrateReindexSourceIndex = y}) + +migrateReindexRequestSourceLens :: Lens' MigrateReindexRequest MigrateReindexSource +migrateReindexRequestSourceLens = + lens migrateReindexRequestSource (\x y -> x {migrateReindexRequestSource = y}) + +migrateReindexRequestModeLens :: Lens' MigrateReindexRequest MigrateReindexMode +migrateReindexRequestModeLens = + lens migrateReindexRequestMode (\x y -> x {migrateReindexRequestMode = y}) + +migrateReindexInProgressIndexLens :: Lens' MigrateReindexInProgress IndexName +migrateReindexInProgressIndexLens = + lens migrateReindexInProgressIndex (\x y -> x {migrateReindexInProgressIndex = y}) + +migrateReindexInProgressTotalDocCountLens :: Lens' MigrateReindexInProgress Int +migrateReindexInProgressTotalDocCountLens = + lens migrateReindexInProgressTotalDocCount (\x y -> x {migrateReindexInProgressTotalDocCount = y}) + +migrateReindexInProgressReindexedDocCountLens :: Lens' MigrateReindexInProgress Int +migrateReindexInProgressReindexedDocCountLens = + lens migrateReindexInProgressReindexedDocCount (\x y -> x {migrateReindexInProgressReindexedDocCount = y}) + +migrateReindexErrorIndexLens :: Lens' MigrateReindexError IndexName +migrateReindexErrorIndexLens = + lens migrateReindexErrorIndex (\x y -> x {migrateReindexErrorIndex = y}) + +migrateReindexErrorMessageLens :: Lens' MigrateReindexError Text +migrateReindexErrorMessageLens = + lens migrateReindexErrorMessage (\x y -> x {migrateReindexErrorMessage = y}) + +migrateReindexStatusStartTimeLens :: Lens' MigrateReindexStatus (Maybe Value) +migrateReindexStatusStartTimeLens = + lens migrateReindexStatusStartTime (\x y -> x {migrateReindexStatusStartTime = y}) + +migrateReindexStatusStartTimeMillisLens :: Lens' MigrateReindexStatus Int +migrateReindexStatusStartTimeMillisLens = + lens migrateReindexStatusStartTimeMillis (\x y -> x {migrateReindexStatusStartTimeMillis = y}) + +migrateReindexStatusCompleteLens :: Lens' MigrateReindexStatus Bool +migrateReindexStatusCompleteLens = + lens migrateReindexStatusComplete (\x y -> x {migrateReindexStatusComplete = y}) + +migrateReindexStatusTotalIndicesInDataStreamLens :: Lens' MigrateReindexStatus Int +migrateReindexStatusTotalIndicesInDataStreamLens = + lens migrateReindexStatusTotalIndicesInDataStream (\x y -> x {migrateReindexStatusTotalIndicesInDataStream = y}) + +migrateReindexStatusTotalIndicesRequiringUpgradeLens :: Lens' MigrateReindexStatus Int +migrateReindexStatusTotalIndicesRequiringUpgradeLens = + lens migrateReindexStatusTotalIndicesRequiringUpgrade (\x y -> x {migrateReindexStatusTotalIndicesRequiringUpgrade = y}) + +migrateReindexStatusSuccessesLens :: Lens' MigrateReindexStatus Int +migrateReindexStatusSuccessesLens = + lens migrateReindexStatusSuccesses (\x y -> x {migrateReindexStatusSuccesses = y}) + +migrateReindexStatusInProgressLens :: Lens' MigrateReindexStatus [MigrateReindexInProgress] +migrateReindexStatusInProgressLens = + lens migrateReindexStatusInProgress (\x y -> x {migrateReindexStatusInProgress = y}) + +migrateReindexStatusPendingLens :: Lens' MigrateReindexStatus Int +migrateReindexStatusPendingLens = + lens migrateReindexStatusPending (\x y -> x {migrateReindexStatusPending = y}) + +migrateReindexStatusErrorsLens :: Lens' MigrateReindexStatus [MigrateReindexError] +migrateReindexStatusErrorsLens = + lens migrateReindexStatusErrors (\x y -> x {migrateReindexStatusErrors = y}) + +migrateReindexStatusExceptionLens :: Lens' MigrateReindexStatus (Maybe Text) +migrateReindexStatusExceptionLens = + lens migrateReindexStatusException (\x y -> x {migrateReindexStatusException = y}) + +createIndexFromBodyMappingsOverrideLens :: Lens' CreateIndexFromBody (Maybe Value) +createIndexFromBodyMappingsOverrideLens = + lens createIndexFromBodyMappingsOverride (\x y -> x {createIndexFromBodyMappingsOverride = y}) + +createIndexFromBodySettingsOverrideLens :: Lens' CreateIndexFromBody (Maybe Value) +createIndexFromBodySettingsOverrideLens = + lens createIndexFromBodySettingsOverride (\x y -> x {createIndexFromBodySettingsOverride = y}) + +createIndexFromBodyRemoveIndexBlocksLens :: Lens' CreateIndexFromBody (Maybe Bool) +createIndexFromBodyRemoveIndexBlocksLens = + lens createIndexFromBodyRemoveIndexBlocks (\x y -> x {createIndexFromBodyRemoveIndexBlocks = y}) + +createIndexFromResponseAcknowledgedLens :: Lens' CreateIndexFromResponse Bool +createIndexFromResponseAcknowledgedLens = + lens createIndexFromResponseAcknowledged (\x y -> x {createIndexFromResponseAcknowledged = y}) + +createIndexFromResponseIndexLens :: Lens' CreateIndexFromResponse IndexName +createIndexFromResponseIndexLens = + lens createIndexFromResponseIndex (\x y -> x {createIndexFromResponseIndex = y}) + +createIndexFromResponseShardsAcknowledgedLens :: Lens' CreateIndexFromResponse Bool +createIndexFromResponseShardsAcknowledgedLens = + lens createIndexFromResponseShardsAcknowledged (\x y -> x {createIndexFromResponseShardsAcknowledged = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/QueryRules.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/QueryRules.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/QueryRules.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.QueryRules + ( -- * Identity + RulesetId (..), + unRulesetId, + RuleId (..), + unRuleId, + + -- * Ruleset body + QueryRuleset (..), + Rule (..), + RuleType (..), + ruleTypeToText, + ruleTypeFromText, + Criterion (..), + PinnedDoc (..), + PinnedActions (..), + + -- * GET response + QueryRulesetInfo (..), + + -- * PUT response + QueryRulesetPutResponse (..), + queryRulesetPutResponseResultLens, + + -- * Test request body + QueryRulesetTest (..), + + -- * Test response + QueryRulesetTestResponse (..), + QueryRulesetTestMatchedRule (..), + + -- * Lenses + rulesetIdLens, + ruleIdLens, + queryRulesetRulesLens, + ruleRuleIdLens, + ruleTypeLens, + ruleCriteriaLens, + ruleActionsLens, + rulePriorityLens, + pinnedDocIndexLens, + pinnedDocIdLens, + pinnedActionsDocsLens, + pinnedActionsIdsLens, + queryRulesetInfoIdLens, + queryRulesetInfoRulesLens, + queryRulesetTestMatchCriteriaLens, + queryRulesetTestResponseTotalLens, + queryRulesetTestResponseMatchedLens, + queryRulesetTestMatchedRuleRulesetIdLens, + queryRulesetTestMatchedRuleRuleIdLens, + ) +where + +import Data.Aeson +import Data.Map.Strict (Map) +import Data.String (IsString) +import Database.Bloodhound.Internal.Utils.Imports + +-- | The @{ruleset_id}@ path segment of +-- @\/_query_rules\/{ruleset_id}@ and the matching top-level key of the +-- @GET@ response. Unlike 'IndexName', this is a plain opaque +-- identifier with no validation rules. +newtype RulesetId = RulesetId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unRulesetId :: RulesetId -> Text +unRulesetId (RulesetId x) = x + +rulesetIdLens :: Lens' RulesetId Text +rulesetIdLens = lens unRulesetId (\_ y -> RulesetId y) + +-- | The @rule_id@ of an individual rule within a 'QueryRuleset'. Plain +-- opaque identifier. +newtype RuleId = RuleId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unRuleId :: RuleId -> Text +unRuleId (RuleId x) = x + +ruleIdLens :: Lens' RuleId Text +ruleIdLens = lens unRuleId (\_ y -> RuleId y) + +-- | The top-level request body of @PUT \/_query_rules\/{ruleset_id}@ +-- and the @rules@ sub-array of the @GET@ response. A ruleset is an +-- ordered list of 'Rule's; Elasticsearch evaluates them top-down and +-- applies the actions of the first matching rule. +newtype QueryRuleset = QueryRuleset + { qrRules :: [Rule] + } + deriving stock (Eq, Show) + +instance ToJSON QueryRuleset where + toJSON QueryRuleset {..} = + object ["rules" .= qrRules] + +instance FromJSON QueryRuleset where + parseJSON = withObject "QueryRuleset" $ \o -> + QueryRuleset <$> o .: "rules" + +queryRulesetRulesLens :: Lens' QueryRuleset [Rule] +queryRulesetRulesLens = lens qrRules (\x y -> x {qrRules = y}) + +-- | The @type@ discriminant of a rule. +-- +-- @pinned@: promote documents to the top of the result list (the +-- @docs@ and @ids@ actions). +-- +-- @exclude@: exclude documents from the result list entirely +-- (Elasticsearch 8.10+). +-- +-- 'OtherRuleType' is the forward-compatibility escape hatch. +data RuleType + = PinnedRuleType + | ExcludeRuleType + | OtherRuleType Text + deriving stock (Eq, Show) + +ruleTypeToText :: RuleType -> Text +ruleTypeToText = \case + PinnedRuleType -> "pinned" + ExcludeRuleType -> "exclude" + OtherRuleType t -> t + +ruleTypeFromText :: Text -> RuleType +ruleTypeFromText t + | t == "pinned" = PinnedRuleType + | t == "exclude" = ExcludeRuleType + | otherwise = OtherRuleType t + +instance ToJSON RuleType where + toJSON = String . ruleTypeToText + +instance FromJSON RuleType where + parseJSON = withText "RuleType" (pure . ruleTypeFromText) + +-- | A single rule within a 'QueryRuleset'. +-- +-- 'rPriority' is the optional @priority@ field: when two rules both +-- match, the lower-priority rule wins. It is omitted from the wire when +-- 'Nothing' and decodes to 'Nothing' when the server omits it (older +-- ES versions). +data Rule = Rule + { rRuleId :: RuleId, + rType :: RuleType, + rCriteria :: [Criterion], + rActions :: PinnedActions, + rPriority :: Maybe Int + } + deriving stock (Eq, Show) + +instance ToJSON Rule where + toJSON Rule {..} = + object $ + [ "rule_id" .= rRuleId, + "type" .= rType, + "criteria" .= rCriteria, + "actions" .= rActions + ] + ++ [ "priority" .= p + | Just p <- [rPriority] + ] + +instance FromJSON Rule where + parseJSON = withObject "Rule" $ \o -> + Rule + <$> o .: "rule_id" + <*> o .: "type" + <*> o .: "criteria" + <*> o .: "actions" + <*> o .:? "priority" + +ruleRuleIdLens :: Lens' Rule RuleId +ruleRuleIdLens = lens rRuleId (\x y -> x {rRuleId = y}) + +ruleTypeLens :: Lens' Rule RuleType +ruleTypeLens = lens rType (\x y -> x {rType = y}) + +ruleCriteriaLens :: Lens' Rule [Criterion] +ruleCriteriaLens = lens rCriteria (\x y -> x {rCriteria = y}) + +ruleActionsLens :: Lens' Rule PinnedActions +ruleActionsLens = lens rActions (\x y -> x {rActions = y}) + +rulePriorityLens :: Lens' Rule (Maybe Int) +rulePriorityLens = lens rPriority (\x y -> x {rPriority = y}) + +-- | One entry in a rule's @criteria@ list. A rule matches when /all/ +-- of its criteria match the search request context. +-- +-- The Elasticsearch wire shape is +-- @{"type": , "metadata": , "values": [...]}@, with +-- @always@ and @global@ as the only variants that omit @metadata@ and +-- @values@. (@global@ is the GA name for @always@; it is kept as a +-- distinct constructor so that round-tripping preserves the exact tag +-- the server sent.) Each typed variant below maps directly to one +-- @type@ tag; the 'GenericCriterion' escape hatch preserves any future +-- criterion shape this binding does not yet model. +data Criterion + = AlwaysCriterion + | GlobalCriterion + | ExactCriterion Text (NonEmpty Value) + | FuzzyCriterion Text (NonEmpty Value) + | ContainsCriterion Text (NonEmpty Value) + | PrefixCriterion Text (NonEmpty Value) + | SuffixCriterion Text (NonEmpty Value) + | GreaterThanCriterion Text Value + | GreaterThanEqualCriterion Text Value + | LessThanCriterion Text Value + | LessThanEqualCriterion Text Value + | GenericCriterion Value + deriving stock (Eq, Show) + +instance ToJSON Criterion where + toJSON = \case + AlwaysCriterion -> + object ["type" .= ("always" :: Text)] + GlobalCriterion -> + object ["type" .= ("global" :: Text)] + ExactCriterion md vals -> + criterionObject "exact" md (toList vals) + FuzzyCriterion md vals -> + criterionObject "fuzzy" md (toList vals) + ContainsCriterion md vals -> + criterionObject "contains" md (toList vals) + PrefixCriterion md vals -> + criterionObject "prefix" md (toList vals) + SuffixCriterion md vals -> + criterionObject "suffix" md (toList vals) + GreaterThanCriterion md v -> + criterionObject "gt" md [v] + GreaterThanEqualCriterion md v -> + criterionObject "gte" md [v] + LessThanCriterion md v -> + criterionObject "lt" md [v] + LessThanEqualCriterion md v -> + criterionObject "lte" md [v] + GenericCriterion v -> v + +criterionObject :: Text -> Text -> [Value] -> Value +criterionObject ty metadata values = + object + [ "type" .= ty, + "metadata" .= metadata, + "values" .= values + ] + +instance FromJSON Criterion where + parseJSON = withObject "Criterion" $ \o -> do + ty <- typeName o + case ty of + "always" -> pure AlwaysCriterion + "global" -> pure GlobalCriterion + "exact" -> ExactCriterion <$> o .: "metadata" <*> valuesNE o + "fuzzy" -> FuzzyCriterion <$> o .: "metadata" <*> valuesNE o + "contains" -> ContainsCriterion <$> o .: "metadata" <*> valuesNE o + "prefix" -> PrefixCriterion <$> o .: "metadata" <*> valuesNE o + "suffix" -> SuffixCriterion <$> o .: "metadata" <*> valuesNE o + "gt" -> GreaterThanCriterion <$> o .: "metadata" <*> singleValue o + "gte" -> GreaterThanEqualCriterion <$> o .: "metadata" <*> singleValue o + "lt" -> LessThanCriterion <$> o .: "metadata" <*> singleValue o + "lte" -> LessThanEqualCriterion <$> o .: "metadata" <*> singleValue o + _ -> pure (GenericCriterion (Object o)) + where + typeName obj = (obj .: "type") :: Parser Text + valuesNE obj = do + vs <- (obj .: "values") :: Parser [Value] + case vs of + [] -> fail "Criterion: \"values\" array is empty" + (x : xs) -> pure (x :| xs) + singleValue obj = do + vs <- (obj .: "values") :: Parser [Value] + case vs of + [v] -> pure v + [] -> fail "Criterion: \"values\" array is empty (expected exactly one)" + _ -> fail "Criterion: \"values\" array has multiple entries (expected exactly one)" + +-- | A pinned-doc reference: either @{"_index": ..., "_id": ...}@ or +-- the bare @{"_id": ...}@ form. The @_index@ is optional because ES +-- accepts a bare @_id@ when the rule's caller knows the index from +-- the search context. +data PinnedDoc = PinnedDoc + { pdIndex :: Maybe Text, + pdId :: Text + } + deriving stock (Eq, Show) + +instance ToJSON PinnedDoc where + toJSON PinnedDoc {..} = + omitNulls + [ "_index" .= pdIndex, + "_id" .= pdId + ] + +instance FromJSON PinnedDoc where + parseJSON = withObject "PinnedDoc" $ \o -> + PinnedDoc + <$> o .:? "_index" + <*> o .: "_id" + +pinnedDocIndexLens :: Lens' PinnedDoc (Maybe Text) +pinnedDocIndexLens = lens pdIndex (\x y -> x {pdIndex = y}) + +pinnedDocIdLens :: Lens' PinnedDoc Text +pinnedDocIdLens = lens pdId (\x y -> x {pdId = y}) + +-- | @actions@ payload of a rule. Exactly one of @docs@ or @ids@ +-- should be non-empty for a valid rule (Elasticsearch validates this +-- server-side). +data PinnedActions = PinnedActions + { paDocs :: [PinnedDoc], + paIds :: [Text] + } + deriving stock (Eq, Show) + +instance ToJSON PinnedActions where + toJSON PinnedActions {..} = + omitNulls + [ "docs" .= paDocs, + "ids" .= paIds + ] + +instance FromJSON PinnedActions where + parseJSON = withObject "PinnedActions" $ \o -> + PinnedActions + <$> o .:? "docs" .!= [] + <*> o .:? "ids" .!= [] + +pinnedActionsDocsLens :: Lens' PinnedActions [PinnedDoc] +pinnedActionsDocsLens = lens paDocs (\x y -> x {paDocs = y}) + +pinnedActionsIdsLens :: Lens' PinnedActions [Text] +pinnedActionsIdsLens = lens paIds (\x y -> x {paIds = y}) + +-- | Wrapper returned by @GET \/_query_rules\/{ruleset_id}@. The +-- Elasticsearch response shape is the flat object +-- @{"ruleset_id": "...", "rules": [...]}@ — the same shape as the +-- PUT body plus the path-echoed @ruleset_id@. +data QueryRulesetInfo = QueryRulesetInfo + { qriId :: RulesetId, + qriRules :: [Rule] + } + deriving stock (Eq, Show) + +instance ToJSON QueryRulesetInfo where + toJSON QueryRulesetInfo {..} = + object + [ "ruleset_id" .= qriId, + "rules" .= qriRules + ] + +instance FromJSON QueryRulesetInfo where + parseJSON = withObject "QueryRulesetInfo" $ \o -> + QueryRulesetInfo + <$> o .: "ruleset_id" + <*> o .: "rules" + +queryRulesetInfoIdLens :: Lens' QueryRulesetInfo RulesetId +queryRulesetInfoIdLens = lens qriId (\x y -> x {qriId = y}) + +queryRulesetInfoRulesLens :: Lens' QueryRulesetInfo [Rule] +queryRulesetInfoRulesLens = lens qriRules (\x y -> x {qriRules = y}) + +-- | Response body of @PUT \/_query_rules\/{ruleset_id}@. The server +-- echoes @{"result": "created"}@ or @{"result": "updated"}@ depending +-- on whether the ruleset was newly created or overwrote an existing +-- one. Unlike many other PUT endpoints in Elasticsearch, this one +-- does /not/ return an @acknowledged@ flag. +newtype QueryRulesetPutResponse = QueryRulesetPutResponse + { qrprResult :: Text + } + deriving stock (Eq, Show) + +instance ToJSON QueryRulesetPutResponse where + toJSON QueryRulesetPutResponse {..} = + object ["result" .= qrprResult] + +instance FromJSON QueryRulesetPutResponse where + parseJSON = withObject "QueryRulesetPutResponse" $ \o -> + QueryRulesetPutResponse <$> o .: "result" + +queryRulesetPutResponseResultLens :: Lens' QueryRulesetPutResponse Text +queryRulesetPutResponseResultLens = + lens qrprResult (\x y -> x {qrprResult = y}) + +-- | Request body of @POST \/_query_rules\/{ruleset_id}\/_test@ +-- (Elasticsearch 8.10+). The @match_criteria@ map carries the +-- hypothetical search-request metadata that the ruleset's +-- @criteria.metadata@ keys are evaluated against. Keys are arbitrary +-- metadata field names (e.g. @"user_query"@, @"user_country"@); values +-- are any JSON the corresponding 'Criterion' variant expects (most +-- often strings, but the wire schema is intentionally free-form). +newtype QueryRulesetTest = QueryRulesetTest + { qrtMatchCriteria :: Map Text Value + } + deriving stock (Eq, Show) + +instance ToJSON QueryRulesetTest where + toJSON QueryRulesetTest {..} = + object ["match_criteria" .= qrtMatchCriteria] + +instance FromJSON QueryRulesetTest where + parseJSON = withObject "QueryRulesetTest" $ \o -> + QueryRulesetTest <$> o .: "match_criteria" + +queryRulesetTestMatchCriteriaLens :: Lens' QueryRulesetTest (Map Text Value) +queryRulesetTestMatchCriteriaLens = + lens qrtMatchCriteria (\x y -> x {qrtMatchCriteria = y}) + +-- | One entry in the @matched_rules@ array of a +-- 'QueryRulesetTestResponse'. Elasticsearch echoes back the +-- @ruleset_id@ (the path-echoed ruleset that owned the match) and the +-- @rule_id@ of the individual rule that fired. The response does /not/ +-- include the rule's @actions@, @ids@, or @docs@ — only the +-- identifiers. +data QueryRulesetTestMatchedRule = QueryRulesetTestMatchedRule + { qrtmrRulesetId :: RulesetId, + qrtmrRuleId :: RuleId + } + deriving stock (Eq, Show) + +instance ToJSON QueryRulesetTestMatchedRule where + toJSON QueryRulesetTestMatchedRule {..} = + object + [ "ruleset_id" .= qrtmrRulesetId, + "rule_id" .= qrtmrRuleId + ] + +instance FromJSON QueryRulesetTestMatchedRule where + parseJSON = withObject "QueryRulesetTestMatchedRule" $ \o -> + QueryRulesetTestMatchedRule + <$> o .: "ruleset_id" + <*> o .: "rule_id" + +queryRulesetTestMatchedRuleRulesetIdLens :: + Lens' QueryRulesetTestMatchedRule RulesetId +queryRulesetTestMatchedRuleRulesetIdLens = + lens qrtmrRulesetId (\x y -> x {qrtmrRulesetId = y}) + +queryRulesetTestMatchedRuleRuleIdLens :: + Lens' QueryRulesetTestMatchedRule RuleId +queryRulesetTestMatchedRuleRuleIdLens = + lens qrtmrRuleId (\x y -> x {qrtmrRuleId = y}) + +-- | Response body of @POST \/_query_rules\/{ruleset_id}\/_test@ +-- (Elasticsearch 8.10+). The server evaluates the supplied +-- 'QueryRulesetTest' match criteria against every rule in the stored +-- ruleset and returns how many matched ('qrtTotal') plus the +-- identifying pair of each match ('qrtMatched'). +data QueryRulesetTestResponse = QueryRulesetTestResponse + { qrtTotal :: Int, + qrtMatched :: [QueryRulesetTestMatchedRule] + } + deriving stock (Eq, Show) + +instance ToJSON QueryRulesetTestResponse where + toJSON QueryRulesetTestResponse {..} = + object + [ "total_matched_rules" .= qrtTotal, + "matched_rules" .= qrtMatched + ] + +instance FromJSON QueryRulesetTestResponse where + parseJSON = withObject "QueryRulesetTestResponse" $ \o -> + QueryRulesetTestResponse + <$> o .: "total_matched_rules" + <*> o .: "matched_rules" + +queryRulesetTestResponseTotalLens :: Lens' QueryRulesetTestResponse Int +queryRulesetTestResponseTotalLens = + lens qrtTotal (\x y -> x {qrtTotal = y}) + +queryRulesetTestResponseMatchedLens :: + Lens' QueryRulesetTestResponse [QueryRulesetTestMatchedRule] +queryRulesetTestResponseMatchedLens = + lens qrtMatched (\x y -> x {qrtMatched = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/SearchApplications.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/SearchApplications.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/SearchApplications.hs @@ -0,0 +1,511 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.SearchApplications + ( -- * Identity + SearchApplicationName (..), + unSearchApplicationName, + + -- * Template script + SearchApplicationScriptBody (..), + SearchApplicationTemplateScript (..), + + -- * Template + SearchApplicationTemplate (..), + + -- * Request body + SearchApplication (..), + + -- * GET response + SearchApplicationInfo (..), + + -- * PUT response + SearchApplicationPutResponse (..), + searchApplicationPutResponseResultLens, + + -- * PUT query parameters + SearchApplicationPutOptions (..), + defaultSearchApplicationPutOptions, + searchApplicationPutOptionsCreateLens, + + -- * POST /_search query parameters + SearchApplicationOptions (..), + defaultSearchApplicationOptions, + searchApplicationOptionsParams, + searchApplicationOptionsTypedKeysLens, + + -- * POST /_search request body + SearchApplicationSearchParams (..), + + -- * GET (list) query parameters + SearchApplicationListOptions (..), + defaultSearchApplicationListOptions, + searchApplicationListOptionsParams, + searchApplicationListOptionsQLens, + searchApplicationListOptionsFromLens, + searchApplicationListOptionsSizeLens, + + -- * GET (list) response + SearchApplicationListResponse (..), + searchApplicationListResponseCountLens, + searchApplicationListResponseResultsLens, + + -- * Lenses + searchApplicationNameLens, + searchApplicationTemplateScriptBodyLens, + searchApplicationTemplateScriptParamsLens, + searchApplicationTemplateScriptLangLens, + searchApplicationTemplateScriptOptionsLens, + searchApplicationTemplateScriptLens, + searchApplicationIndicesLens, + searchApplicationAnalyticsCollectionNameLens, + searchApplicationTemplateLens, + searchApplicationInfoNameLens, + searchApplicationInfoIndicesLens, + searchApplicationInfoAnalyticsCollectionNameLens, + searchApplicationInfoTemplateLens, + searchApplicationInfoUpdatedAtMillisLens, + searchApplicationSearchParamsParamsLens, + ) +where + +import Data.Aeson +import Data.String (IsString) +import Data.Word (Word64) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes (IndexName) +import Database.Bloodhound.Internal.Versions.Common.Types.Script (ScriptLanguage) + +-- | The @{name}@ path segment of @\/_application\/search_application\/{name}@. Plain opaque +-- identifier with no validation rules. +newtype SearchApplicationName = SearchApplicationName Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unSearchApplicationName :: SearchApplicationName -> Text +unSearchApplicationName (SearchApplicationName x) = x + +searchApplicationNameLens :: Lens' SearchApplicationName Text +searchApplicationNameLens = + lens unSearchApplicationName (\_ y -> SearchApplicationName y) + +-- | The polymorphic @source@ \/ @id@ field of a +-- 'SearchApplicationTemplateScript'. Elasticsearch accepts one of three +-- shapes for the body of a search-application template script: +-- +-- [@InlineStringSource@] @\{"source": ""\}@ — a +-- mustache template rendered with the per-request params. +-- [@InlineObjectSource@] @\{"source": \{...\}\}@ — an inline +-- 'SearchRequestBody' object. Kept as raw 'Value' so this binding +-- does not have to model every field the search body accepts. +-- [@StoredScriptId@] @\{"id": ""\}@ — a reference to +-- a stored script (created via @POST \/_scripts\/{id}@). +-- +-- The three arms are mutually exclusive on the wire. +data SearchApplicationScriptBody + = InlineStringSource Text + | InlineObjectSource Value + | StoredScriptId Text + deriving stock (Eq, Show) + +instance ToJSON SearchApplicationScriptBody where + toJSON = \case + InlineStringSource src -> object ["source" .= src] + InlineObjectSource src -> object ["source" .= src] + StoredScriptId sid -> object ["id" .= sid] + +instance FromJSON SearchApplicationScriptBody where + parseJSON = withObject "SearchApplicationScriptBody" $ \o -> do + mSource <- o .:? "source" + mId <- o .:? "id" + case (mSource, mId) of + (Just (String s), Nothing) -> pure (InlineStringSource s) + (Just v@(Object _), Nothing) -> pure (InlineObjectSource v) + (Just other, Nothing) -> + fail $ + "SearchApplicationScriptBody: \"source\" must be a String or Object, got: " + <> show other + (Nothing, Just sid) -> pure (StoredScriptId sid) + (Just _, Just _) -> + fail "SearchApplicationScriptBody: both \"source\" and \"id\" present" + (Nothing, Nothing) -> + fail "SearchApplicationScriptBody: missing both \"source\" and \"id\"" + +-- | The @script@ object of a 'SearchApplicationTemplate'. The body of a +-- search application template is an Elasticsearch "script" in the sense +-- of the stored / inline script APIs: it carries a 'SearchApplicationScriptBody' +-- (inline source, inline object, or stored id) alongside optional +-- default @params@, @lang@ and @options@. +-- +-- 'ScriptLanguage' is reused from +-- "Database.Bloodhound.Internal.Versions.Common.Types.Script" to keep +-- the script-language type unified across the binding. +data SearchApplicationTemplateScript = SearchApplicationTemplateScript + { satsScriptBody :: SearchApplicationScriptBody, + satsParams :: Maybe Object, + satsLang :: Maybe ScriptLanguage, + satsOptions :: Maybe Object + } + deriving stock (Eq, Show) + +instance ToJSON SearchApplicationTemplateScript where + toJSON SearchApplicationTemplateScript {..} = + case satsScriptBody of + InlineStringSource src -> + omitNulls + [ "source" .= src, + "params" .= satsParams, + "lang" .= satsLang, + "options" .= satsOptions + ] + InlineObjectSource src -> + omitNulls + [ "source" .= src, + "params" .= satsParams, + "lang" .= satsLang, + "options" .= satsOptions + ] + StoredScriptId sid -> + omitNulls + [ "id" .= sid, + "params" .= satsParams, + "lang" .= satsLang, + "options" .= satsOptions + ] + +instance FromJSON SearchApplicationTemplateScript where + parseJSON = withObject "SearchApplicationTemplateScript" $ \o -> do + body <- parseJSON (Object o) + SearchApplicationTemplateScript body + <$> o .:? "params" + <*> o .:? "lang" + <*> o .:? "options" + +searchApplicationTemplateScriptBodyLens :: Lens' SearchApplicationTemplateScript SearchApplicationScriptBody +searchApplicationTemplateScriptBodyLens = + lens satsScriptBody (\x y -> x {satsScriptBody = y}) + +searchApplicationTemplateScriptParamsLens :: Lens' SearchApplicationTemplateScript (Maybe Object) +searchApplicationTemplateScriptParamsLens = + lens satsParams (\x y -> x {satsParams = y}) + +searchApplicationTemplateScriptLangLens :: Lens' SearchApplicationTemplateScript (Maybe ScriptLanguage) +searchApplicationTemplateScriptLangLens = + lens satsLang (\x y -> x {satsLang = y}) + +searchApplicationTemplateScriptOptionsLens :: Lens' SearchApplicationTemplateScript (Maybe Object) +searchApplicationTemplateScriptOptionsLens = + lens satsOptions (\x y -> x {satsOptions = y}) + +-- | The @template@ object of a 'SearchApplication'. Wraps the required +-- 'SearchApplicationTemplateScript'. The Elasticsearch +-- @search_application._types.SearchApplicationTemplate@ spec carries +-- only the @script@ key on the wire; the phantom @dictionary@ field the +-- binding previously modelled is gone — the server rejects any +-- non-empty value there. +newtype SearchApplicationTemplate = SearchApplicationTemplate + { satScript :: SearchApplicationTemplateScript + } + deriving newtype (Eq, Show) + +instance ToJSON SearchApplicationTemplate where + toJSON (SearchApplicationTemplate script) = + object ["script" .= script] + +instance FromJSON SearchApplicationTemplate where + parseJSON = withObject "SearchApplicationTemplate" $ \o -> + SearchApplicationTemplate <$> o .: "script" + +searchApplicationTemplateScriptLens :: Lens' SearchApplicationTemplate SearchApplicationTemplateScript +searchApplicationTemplateScriptLens = + lens satScript (\_ y -> SearchApplicationTemplate y) + +-- | The request body of @PUT \/_application\/search_application\/{name}@. @indices@ is +-- required by Elasticsearch (the search application targets one or more +-- indices); the analytics collection name and template are optional. +data SearchApplication = SearchApplication + { saIndices :: NonEmpty IndexName, + saAnalyticsCollectionName :: Maybe Text, + saTemplate :: Maybe SearchApplicationTemplate + } + deriving stock (Eq, Show) + +instance ToJSON SearchApplication where + toJSON SearchApplication {..} = + omitNulls + [ "indices" .= toList saIndices, + "analytics_collection_name" .= saAnalyticsCollectionName, + "template" .= saTemplate + ] + +instance FromJSON SearchApplication where + parseJSON = withObject "SearchApplication" $ \o -> do + indices <- o .: "indices" + case indices of + [] -> fail "SearchApplication: \"indices\" array is empty" + (x : xs) -> + SearchApplication (x :| xs) + <$> o .:? "analytics_collection_name" + <*> o .:? "template" + +searchApplicationIndicesLens :: Lens' SearchApplication (NonEmpty IndexName) +searchApplicationIndicesLens = + lens saIndices (\x y -> x {saIndices = y}) + +searchApplicationAnalyticsCollectionNameLens :: Lens' SearchApplication (Maybe Text) +searchApplicationAnalyticsCollectionNameLens = + lens saAnalyticsCollectionName (\x y -> x {saAnalyticsCollectionName = y}) + +searchApplicationTemplateLens :: Lens' SearchApplication (Maybe SearchApplicationTemplate) +searchApplicationTemplateLens = + lens saTemplate (\x y -> x {saTemplate = y}) + +-- | Wrapper returned by @GET \/_application\/search_application\/{name}@. The shape mirrors +-- 'SearchApplication' plus the path-echoed @name@ and an optional +-- @updated_at_millis@ timestamp. +data SearchApplicationInfo = SearchApplicationInfo + { saiName :: SearchApplicationName, + saiIndices :: [IndexName], + saiAnalyticsCollectionName :: Maybe Text, + saiTemplate :: Maybe SearchApplicationTemplate, + saiUpdatedAtMillis :: Maybe Word64 + } + deriving stock (Eq, Show) + +instance ToJSON SearchApplicationInfo where + toJSON SearchApplicationInfo {..} = + omitNulls + [ "name" .= saiName, + "indices" .= saiIndices, + "analytics_collection_name" .= saiAnalyticsCollectionName, + "template" .= saiTemplate, + "updated_at_millis" .= saiUpdatedAtMillis + ] + +instance FromJSON SearchApplicationInfo where + parseJSON = withObject "SearchApplicationInfo" $ \o -> + SearchApplicationInfo + <$> o .: "name" + <*> o .:? "indices" .!= [] + <*> o .:? "analytics_collection_name" + <*> o .:? "template" + <*> o .:? "updated_at_millis" + +searchApplicationInfoNameLens :: Lens' SearchApplicationInfo SearchApplicationName +searchApplicationInfoNameLens = + lens saiName (\x y -> x {saiName = y}) + +searchApplicationInfoIndicesLens :: Lens' SearchApplicationInfo [IndexName] +searchApplicationInfoIndicesLens = + lens saiIndices (\x y -> x {saiIndices = y}) + +searchApplicationInfoAnalyticsCollectionNameLens :: Lens' SearchApplicationInfo (Maybe Text) +searchApplicationInfoAnalyticsCollectionNameLens = + lens saiAnalyticsCollectionName (\x y -> x {saiAnalyticsCollectionName = y}) + +searchApplicationInfoTemplateLens :: Lens' SearchApplicationInfo (Maybe SearchApplicationTemplate) +searchApplicationInfoTemplateLens = + lens saiTemplate (\x y -> x {saiTemplate = y}) + +searchApplicationInfoUpdatedAtMillisLens :: Lens' SearchApplicationInfo (Maybe Word64) +searchApplicationInfoUpdatedAtMillisLens = + lens saiUpdatedAtMillis (\x y -> x {saiUpdatedAtMillis = y}) + +-- | Response body of @PUT \/_application\/search_application\/{name}@. Mirrors the +-- 'Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.QueryRules.QueryRulesetPutResponse' +-- shape: the server echoes @{\"result\": \"created\"}@ or +-- @{\"result\": \"updated\"}@ depending on whether the search +-- application was newly created or overwrote an existing one. The +-- Elasticsearch enum also lists @deleted@, @not_found@ and @noop@ for +-- other endpoints in the family, so we keep the field as an opaque +-- 'Text'. +newtype SearchApplicationPutResponse = SearchApplicationPutResponse + { saprResult :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SearchApplicationPutResponse where + toJSON SearchApplicationPutResponse {..} = + object ["result" .= saprResult] + +instance FromJSON SearchApplicationPutResponse where + parseJSON = withObject "SearchApplicationPutResponse" $ \o -> + SearchApplicationPutResponse <$> o .: "result" + +searchApplicationPutResponseResultLens :: Lens' SearchApplicationPutResponse Text +searchApplicationPutResponseResultLens = + lens saprResult (\x y -> x {saprResult = y}) + +-- | Optional URI query parameters for +-- @PUT \/_application\/search_application\/{name}@. +-- Currently carries only the @create@ flag documented at +-- : +-- when @'Just' 'True'@ the request is rejected if the search application +-- already exists (i.e. it can only create, not replace or update). +-- 'defaultSearchApplicationPutOptions' renders no query string, so +-- 'putSearchApplicationWith' with it is byte-for-byte identical to +-- 'putSearchApplication'. +data SearchApplicationPutOptions = SearchApplicationPutOptions + { sapoCreate :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'SearchApplicationPutOptions' with every field set to 'Nothing'. +-- Renders no query parameters. +defaultSearchApplicationPutOptions :: SearchApplicationPutOptions +defaultSearchApplicationPutOptions = + SearchApplicationPutOptions {sapoCreate = Nothing} + +searchApplicationPutOptionsCreateLens :: Lens' SearchApplicationPutOptions (Maybe Bool) +searchApplicationPutOptionsCreateLens = + lens sapoCreate (\x y -> x {sapoCreate = y}) + +-- | Optional URI query parameters for +-- @POST \/_application\/search_application\/{name}\/_search@. +-- Currently carries only the @typed_keys@ parameter documented at +-- : +-- when @'Just' 'True'@ the response returns aggregation names prefixed with +-- their type (e.g. @aggregations#terms@). 'defaultSearchApplicationOptions' +-- renders no query string, so 'searchApplicationWith' with it is byte-for-byte +-- identical to 'searchApplication'. +data SearchApplicationOptions = SearchApplicationOptions + { saoTypedKeys :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'SearchApplicationOptions' with every field set to 'Nothing'. +-- Renders no query parameters. +defaultSearchApplicationOptions :: SearchApplicationOptions +defaultSearchApplicationOptions = + SearchApplicationOptions {saoTypedKeys = Nothing} + +searchApplicationOptionsTypedKeysLens :: Lens' SearchApplicationOptions (Maybe Bool) +searchApplicationOptionsTypedKeysLens = + lens saoTypedKeys (\x y -> x {saoTypedKeys = y}) + +-- | Render 'SearchApplicationOptions' as a list of @(key, value)@ query +-- parameters suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultSearchApplicationOptions' produces @[]@. Booleans render as the +-- strings @"true"@\/@"false"@. +searchApplicationOptionsParams :: SearchApplicationOptions -> [(Text, Maybe Text)] +searchApplicationOptionsParams opts = + catMaybes + [ ("typed_keys",) . Just . boolQP <$> saoTypedKeys opts + ] + where + boolQP True = "true" + boolQP False = "false" + +-- | Request body of @POST \/_application\/search_application\/{name}\/_search@. The body is +-- optional (an empty POST runs the search application's template with +-- its default params); when present, it carries a single @params@ +-- object whose keys override the template's defaults for this request. +newtype SearchApplicationSearchParams = SearchApplicationSearchParams + { saspParams :: Maybe Object + } + deriving stock (Eq, Show) + +instance ToJSON SearchApplicationSearchParams where + toJSON SearchApplicationSearchParams {..} = + omitNulls ["params" .= saspParams] + +instance FromJSON SearchApplicationSearchParams where + parseJSON = withObject "SearchApplicationSearchParams" $ \o -> + SearchApplicationSearchParams <$> o .:? "params" + +searchApplicationSearchParamsParamsLens :: Lens' SearchApplicationSearchParams (Maybe Object) +searchApplicationSearchParamsParamsLens = + lens saspParams (\x y -> x {saspParams = y}) + +-- | Optional URI query parameters for +-- @GET \/_application\/search_application@ (the list endpoint). +-- Carries the three parameters documented at +-- : +-- +-- [@saloQ@] @q@ — a Lucene query-string filter on the search-application +-- names (e.g. @"app*"@). +-- [@saloFrom@] @from@ — the starting offset of the first result. +-- [@saloSize@] @size@ — the maximum number of results to return. +-- +-- 'defaultSearchApplicationListOptions' renders no query string, so +-- 'listSearchApplicationsWith' with it is byte-for-byte identical to +-- 'listSearchApplications'. +data SearchApplicationListOptions = SearchApplicationListOptions + { saloQ :: Maybe Text, + saloFrom :: Maybe Word, + saloSize :: Maybe Word + } + deriving stock (Eq, Show) + +-- | 'SearchApplicationListOptions' with every field set to 'Nothing'. +-- Renders no query parameters. +defaultSearchApplicationListOptions :: SearchApplicationListOptions +defaultSearchApplicationListOptions = + SearchApplicationListOptions + { saloQ = Nothing, + saloFrom = Nothing, + saloSize = Nothing + } + +searchApplicationListOptionsQLens :: Lens' SearchApplicationListOptions (Maybe Text) +searchApplicationListOptionsQLens = + lens saloQ (\x y -> x {saloQ = y}) + +searchApplicationListOptionsFromLens :: Lens' SearchApplicationListOptions (Maybe Word) +searchApplicationListOptionsFromLens = + lens saloFrom (\x y -> x {saloFrom = y}) + +searchApplicationListOptionsSizeLens :: Lens' SearchApplicationListOptions (Maybe Word) +searchApplicationListOptionsSizeLens = + lens saloSize (\x y -> x {saloSize = y}) + +-- | Render 'SearchApplicationListOptions' as a list of @(key, value)@ +-- query parameters suitable for 'withQueries'. 'Nothing' fields are +-- omitted, so 'defaultSearchApplicationListOptions' produces @[]@. +-- Numeric fields render as their decimal representation (without a +-- trailing @.0@, since they are 'Word'). +searchApplicationListOptionsParams :: SearchApplicationListOptions -> [(Text, Maybe Text)] +searchApplicationListOptionsParams opts = + catMaybes + [ ("q",) . Just <$> saloQ opts, + ("from",) . Just . showText <$> saloFrom opts, + ("size",) . Just . showText <$> saloSize opts + ] + +-- | Response body of @GET \/_application\/search_application@ (the list +-- endpoint). The server returns a @count@ of matching search +-- applications plus a @results@ array. Each 'SearchApplicationInfo' +-- element reuses the 'getSearchApplication' single-get shape: the list +-- endpoint typically emits only @name@ and @updated_at_millis@ per item, +-- but the OpenAPI schema permits the full 'SearchApplicationInfo' field +-- set, and 'SearchApplicationInfo''s 'FromJSON' defaults the absent +-- optional fields — so a single type covers both the per-item and +-- single-get responses. +data SearchApplicationListResponse = SearchApplicationListResponse + { salrCount :: Word, + salrResults :: [SearchApplicationInfo] + } + deriving stock (Eq, Show) + +instance ToJSON SearchApplicationListResponse where + toJSON SearchApplicationListResponse {..} = + object + [ "count" .= salrCount, + "results" .= salrResults + ] + +instance FromJSON SearchApplicationListResponse where + parseJSON = withObject "SearchApplicationListResponse" $ \o -> + SearchApplicationListResponse + <$> o .:? "count" .!= 0 + <*> o .:? "results" .!= [] + +searchApplicationListResponseCountLens :: Lens' SearchApplicationListResponse Word +searchApplicationListResponseCountLens = + lens salrCount (\x y -> x {salrCount = y}) + +searchApplicationListResponseResultsLens :: Lens' SearchApplicationListResponse [SearchApplicationInfo] +searchApplicationListResponseResultsLens = + lens salrResults (\x y -> x {salrResults = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/Synonyms.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/Synonyms.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch8/Types/Synonyms.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.Synonyms + ( -- * Identity + SynonymsSetId (..), + unSynonymsSetId, + + -- * Rule + SynonymRule (..), + + -- * PUT request body + SynonymsSet (..), + + -- * GET response + SynonymsSetInfo (..), + + -- * PUT response + SynonymsSetPutResponse (..), + synonymsSetPutResponseAcknowledgedLens, + synonymsSetPutResponseResultLens, + + -- * GET query parameters + SynonymsGetOptions (..), + defaultSynonymsGetOptions, + synonymsGetOptionsParams, + synonymsGetOptionsFromLens, + synonymsGetOptionsSizeLens, + + -- * Lenses + synonymsSetIdLens, + synonymRuleIdLens, + synonymRuleSynonymsLens, + synonymsSetRulesLens, + synonymsSetInfoCountLens, + synonymsSetInfoRulesLens, + ) +where + +import Data.Aeson +import Data.String (IsString) +import Database.Bloodhound.Internal.Utils.Imports + +-- | The @@ path segment of +-- @\/_synonyms\/@. Unlike 'IndexName', this is a plain +-- opaque identifier with no validation rules; it is used both as the +-- URL path component and (unlike query rules) is /not/ echoed verbatim +-- in the GET response body, which instead returns the rule list. +newtype SynonymsSetId = SynonymsSetId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unSynonymsSetId :: SynonymsSetId -> Text +unSynonymsSetId (SynonymsSetId x) = x + +synonymsSetIdLens :: Lens' SynonymsSetId Text +synonymsSetIdLens = lens unSynonymsSetId (\_ y -> SynonymsSetId y) + +-- | A single synonym rule, used both inside the 'SynonymsSet' PUT body +-- and the 'SynonymsSetInfo' GET response. The wire shape is +-- @{"id": "...", "synonyms": "..."}@. +-- +-- 'srId' is 'Maybe' because it is /optional/ on the PUT request body +-- (Elasticsearch assigns an identifier automatically when omitted) but +-- /always/ present on the GET response (the server fills in the +-- assigned id). Encoding omits @id@ when 'Nothing' so a caller can let +-- the server mint ids; decoding tolerates its absence. +data SynonymRule = SynonymRule + { srId :: Maybe Text, + srSynonyms :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SynonymRule where + toJSON SynonymRule {..} = + omitNulls + [ "id" .= srId, + "synonyms" .= srSynonyms + ] + +instance FromJSON SynonymRule where + parseJSON = withObject "SynonymRule" $ \o -> + SynonymRule + <$> o .:? "id" + <*> o .: "synonyms" + +synonymRuleIdLens :: Lens' SynonymRule (Maybe Text) +synonymRuleIdLens = lens srId (\x y -> x {srId = y}) + +synonymRuleSynonymsLens :: Lens' SynonymRule Text +synonymRuleSynonymsLens = lens srSynonyms (\x y -> x {srSynonyms = y}) + +-- | The top-level request body of +-- @PUT \/_synonyms\/@ (Elasticsearch 8.10+). The body +-- is a single object with a @synonyms_set@ key whose value is the +-- ordered list of 'SynonymRule's. (Note the wire key is the same +-- spelling as the path-identifier concept but is an /array/ here.) +-- +-- For the exact shape see +-- . +newtype SynonymsSet = SynonymsSet + { ssRules :: [SynonymRule] + } + deriving stock (Eq, Show) + +instance ToJSON SynonymsSet where + toJSON SynonymsSet {..} = + object ["synonyms_set" .= ssRules] + +instance FromJSON SynonymsSet where + parseJSON = withObject "SynonymsSet" $ \o -> + SynonymsSet <$> o .:? "synonyms_set" .!= [] + +synonymsSetRulesLens :: Lens' SynonymsSet [SynonymRule] +synonymsSetRulesLens = lens ssRules (\x y -> x {ssRules = y}) + +-- | Response body of @GET \/_synonyms\/@ +-- (Elasticsearch 8.10+). The server returns the total @count@ of +-- synonym rules in the set plus the @synonyms_set@ array of +-- 'SynonymRule's, paginated by the GET 'SynonymsGetOptions' +-- (@from@ \/ @size@, which default to @0@ and @10@ server-side). +-- +-- Both fields are parsed with a default (@0@ and @[]@ respectively) so +-- that a server response omitting either key does not fail the decode. +-- +-- For the exact shape see +-- . +data SynonymsSetInfo = SynonymsSetInfo + { ssiCount :: Word, + ssiRules :: [SynonymRule] + } + deriving stock (Eq, Show) + +instance ToJSON SynonymsSetInfo where + toJSON SynonymsSetInfo {..} = + object + [ "count" .= ssiCount, + "synonyms_set" .= ssiRules + ] + +instance FromJSON SynonymsSetInfo where + parseJSON = withObject "SynonymsSetInfo" $ \o -> + SynonymsSetInfo + <$> o .:? "count" .!= 0 + <*> o .:? "synonyms_set" .!= [] + +synonymsSetInfoCountLens :: Lens' SynonymsSetInfo Word +synonymsSetInfoCountLens = lens ssiCount (\x y -> x {ssiCount = y}) + +synonymsSetInfoRulesLens :: Lens' SynonymsSetInfo [SynonymRule] +synonymsSetInfoRulesLens = lens ssiRules (\x y -> x {ssiRules = y}) + +-- | Response body of @PUT \/_synonyms\/@ +-- (Elasticsearch 8.10+). Both fields are optional and modelled as +-- 'Maybe' because the server's response shape varies: a plain create +-- returns @{"acknowledged": true}@, while an update that triggers +-- analyzer reloading returns @{"result": "updated", +-- "reload_analyzers_details": {...}}@ (the reload details are not +-- modelled here). Treating both as 'Maybe' lets one type decode every +-- variant the server emits. +data SynonymsSetPutResponse = SynonymsSetPutResponse + { ssprAcknowledged :: Maybe Bool, + ssprResult :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON SynonymsSetPutResponse where + toJSON SynonymsSetPutResponse {..} = + omitNulls + [ "acknowledged" .= ssprAcknowledged, + "result" .= ssprResult + ] + +instance FromJSON SynonymsSetPutResponse where + parseJSON = withObject "SynonymsSetPutResponse" $ \o -> + SynonymsSetPutResponse + <$> o .:? "acknowledged" + <*> o .:? "result" + +synonymsSetPutResponseAcknowledgedLens :: Lens' SynonymsSetPutResponse (Maybe Bool) +synonymsSetPutResponseAcknowledgedLens = + lens ssprAcknowledged (\x y -> x {ssprAcknowledged = y}) + +synonymsSetPutResponseResultLens :: Lens' SynonymsSetPutResponse (Maybe Text) +synonymsSetPutResponseResultLens = + lens ssprResult (\x y -> x {ssprResult = y}) + +-- | Optional URI query parameters for +-- @GET \/_synonyms\/@, matching the two parameters +-- documented at +-- : +-- +-- [@sgoFrom@] @from@ — the starting offset of synonym rules to +-- retrieve (defaults to @0@ server-side). +-- [@sgoSize@] @size@ — the maximum number of synonym rules to +-- retrieve (defaults to @10@ server-side). +-- +-- 'defaultSynonymsGetOptions' renders no query string, so a GET made +-- with it relies on the server-side defaults. +data SynonymsGetOptions = SynonymsGetOptions + { sgoFrom :: Maybe Word, + sgoSize :: Maybe Word + } + deriving stock (Eq, Show) + +-- | 'SynonymsGetOptions' with both fields set to 'Nothing'. Renders no +-- query parameters. +defaultSynonymsGetOptions :: SynonymsGetOptions +defaultSynonymsGetOptions = + SynonymsGetOptions + { sgoFrom = Nothing, + sgoSize = Nothing + } + +synonymsGetOptionsFromLens :: Lens' SynonymsGetOptions (Maybe Word) +synonymsGetOptionsFromLens = + lens sgoFrom (\x y -> x {sgoFrom = y}) + +synonymsGetOptionsSizeLens :: Lens' SynonymsGetOptions (Maybe Word) +synonymsGetOptionsSizeLens = + lens sgoSize (\x y -> x {sgoSize = y}) + +-- | Render 'SynonymsGetOptions' as a list of @(key, value)@ query +-- parameters suitable for 'withQueries'. 'Nothing' fields are omitted, +-- so 'defaultSynonymsGetOptions' produces @[]@. Numeric fields render +-- as their decimal representation (without a trailing @.0@, since they +-- are 'Word'). +synonymsGetOptionsParams :: SynonymsGetOptions -> [(Text, Maybe Text)] +synonymsGetOptionsParams opts = + catMaybes + [ ("from",) . Just . showText <$> sgoFrom opts, + ("size",) . Just . showText <$> sgoSize opts + ] diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/Downsample.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/Downsample.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/Downsample.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.Downsample +-- Description : Types for the Elasticsearch 9 downsample index API +-- +-- Defines the request and response shapes for the Elasticsearch 9 +-- downsample index endpoint +-- (@POST \/{index}\\/_downsample\\/\\{target_index\\}@, operation-indices-downsample), +-- which rolls up an existing time-series index into a new, coarser-grained +-- target index: +-- +-- * Request body @{"fixed_interval": ..., "sampling_method": ...?}@ — +-- 'DownsampleRequest'. +-- * Response @{"acknowledged": , "shards_acknowledged": }@ — +-- 'DownsampleResponse'. +-- +-- The @fixed_interval@ is modelled with the shared 'FixedInterval' type +-- (rendered as e.g. @\"1h\"@). The optional @sampling_method@ selects +-- the rollup strategy via the shared 'SamplingMethod' enum (@aggregate@ +-- is the documented default; when 'Nothing' the field is omitted so the +-- server applies its default). The optional @wait_for_active_shards@, +-- @master_timeout@ and @timeout@ parameters are documented query-string +-- parameters and live in 'DownsampleOptions', not the body. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.Downsample + ( -- * Request + DownsampleRequest (..), + downsampleRequestFixedIntervalLens, + downsampleRequestSamplingMethodLens, + + -- * Rollup strategy (shared enum) + SamplingMethod, + + -- * Response + DownsampleResponse (..), + downsampleResponseAcknowledgedLens, + downsampleResponseShardsAcknowledgedLens, + + -- * URI options + DownsampleOptions (..), + defaultDownsampleOptions, + downsampleOptionsParams, + downsampleOptionsWaitForActiveShardsLens, + downsampleOptionsMasterTimeoutLens, + downsampleOptionsTimeoutLens, + ) +where + +import Data.Aeson +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Indices + ( ActiveShardCount, + SamplingMethod, + renderActiveShardCount, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Units + ( FixedInterval, + ) + +-- | Request body of @POST \/\\/_downsample\/\@. The @fixed_interval@ +-- is the rollup granularity (a 'FixedInterval', e.g. one hour). The +-- optional @sampling_method@ selects the rollup strategy via the shared +-- 'SamplingMethod' enum; when 'Nothing' the field is omitted and the +-- server applies its documented default of @aggregate@. +data DownsampleRequest = DownsampleRequest + { downsampleRequestFixedInterval :: FixedInterval, + downsampleRequestSamplingMethod :: Maybe SamplingMethod + } + deriving stock (Eq, Show) + +instance ToJSON DownsampleRequest where + toJSON DownsampleRequest {..} = + omitNulls + [ "fixed_interval" .= downsampleRequestFixedInterval, + "sampling_method" .= downsampleRequestSamplingMethod + ] + +instance FromJSON DownsampleRequest where + parseJSON = withObject "DownsampleRequest" $ \o -> + DownsampleRequest + <$> o .: "fixed_interval" + <*> o .:? "sampling_method" + +downsampleRequestFixedIntervalLens :: Lens' DownsampleRequest FixedInterval +downsampleRequestFixedIntervalLens = + lens downsampleRequestFixedInterval (\x y -> x {downsampleRequestFixedInterval = y}) + +downsampleRequestSamplingMethodLens :: Lens' DownsampleRequest (Maybe SamplingMethod) +downsampleRequestSamplingMethodLens = + lens downsampleRequestSamplingMethod (\x y -> x {downsampleRequestSamplingMethod = y}) + +-- | Response body of @POST \/\\/_downsample\/\@, mirroring the shape +-- returned by other index-mutating endpoints (e.g. create-index, +-- rollover): @acknowledged@ reports that the request was received by the +-- cluster, @shards_acknowledged@ that the requisite shard copies were +-- active before the timeout. Both default to @False@ when the server +-- omits them, matching the lenient 'RolloverResponse' parser. +data DownsampleResponse = DownsampleResponse + { downsampleResponseAcknowledged :: Bool, + downsampleResponseShardsAcknowledged :: Bool + } + deriving stock (Eq, Show) + +instance ToJSON DownsampleResponse where + toJSON DownsampleResponse {..} = + omitNulls + [ "acknowledged" .= downsampleResponseAcknowledged, + "shards_acknowledged" .= downsampleResponseShardsAcknowledged + ] + +instance FromJSON DownsampleResponse where + parseJSON = withObject "DownsampleResponse" $ \v -> do + downsampleResponseAcknowledged <- v .:? "acknowledged" .!= False + downsampleResponseShardsAcknowledged <- v .:? "shards_acknowledged" .!= False + return DownsampleResponse {..} + +downsampleResponseAcknowledgedLens :: Lens' DownsampleResponse Bool +downsampleResponseAcknowledgedLens = + lens downsampleResponseAcknowledged (\x y -> x {downsampleResponseAcknowledged = y}) + +downsampleResponseShardsAcknowledgedLens :: Lens' DownsampleResponse Bool +downsampleResponseShardsAcknowledgedLens = + lens downsampleResponseShardsAcknowledged (\x y -> x {downsampleResponseShardsAcknowledged = y}) + +-- | Optional URI query parameters for @POST \/\\/_downsample\/\@: +-- @wait_for_active_shards@ (the number of shard copies that must be +-- active before the operation returns, rendered via +-- 'renderActiveShardCount'), plus @master_timeout@ and @timeout@ (both +-- time-value strings, e.g. @30s@). All are optional and modelled as +-- 'Maybe'; 'defaultDownsampleOptions' renders no query string. +data DownsampleOptions = DownsampleOptions + { downsampleOptionsWaitForActiveShards :: Maybe ActiveShardCount, + downsampleOptionsMasterTimeout :: Maybe Text, + downsampleOptionsTimeout :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'DownsampleOptions' with all fields set to 'Nothing'. Renders no +-- query parameters. +defaultDownsampleOptions :: DownsampleOptions +defaultDownsampleOptions = + DownsampleOptions + { downsampleOptionsWaitForActiveShards = Nothing, + downsampleOptionsMasterTimeout = Nothing, + downsampleOptionsTimeout = Nothing + } + +downsampleOptionsWaitForActiveShardsLens :: Lens' DownsampleOptions (Maybe ActiveShardCount) +downsampleOptionsWaitForActiveShardsLens = + lens downsampleOptionsWaitForActiveShards (\x y -> x {downsampleOptionsWaitForActiveShards = y}) + +downsampleOptionsMasterTimeoutLens :: Lens' DownsampleOptions (Maybe Text) +downsampleOptionsMasterTimeoutLens = + lens downsampleOptionsMasterTimeout (\x y -> x {downsampleOptionsMasterTimeout = y}) + +downsampleOptionsTimeoutLens :: Lens' DownsampleOptions (Maybe Text) +downsampleOptionsTimeoutLens = + lens downsampleOptionsTimeout (\x y -> x {downsampleOptionsTimeout = y}) + +-- | Render 'DownsampleOptions' as a list of @(key, value)@ query +-- parameters suitable for 'withQueries'. 'Nothing' fields are omitted, +-- so 'defaultDownsampleOptions' produces @[]@. @wait_for_active_shards@ +-- is rendered via 'renderActiveShardCount' (@\"all\"@ or a bare number). +downsampleOptionsParams :: DownsampleOptions -> [(Text, Maybe Text)] +downsampleOptionsParams DownsampleOptions {..} = + catMaybes + [ ("wait_for_active_shards",) . Just . renderActiveShardCount <$> downsampleOptionsWaitForActiveShards, + ("master_timeout",) . Just <$> downsampleOptionsMasterTimeout, + ("timeout",) . Just <$> downsampleOptionsTimeout + ] diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/EsQueryLanguage.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/EsQueryLanguage.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/EsQueryLanguage.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | ES | QL request types for the Elasticsearch 9.x @POST /_query@ and +-- @POST /_query/async@ endpoints. +-- +-- The ES9 request body is a strict superset of the ES8 one: it adds +-- @time_zone@ (generally available since ES 9.4.0) and +-- @include_execution_metadata@ (ES 9.x). Neither field is documented for the +-- ES8 @/_query@ endpoint (see the v8 OpenAPI spec), so they live here on a +-- dedicated ES9 'ESQLRequest' rather than on the shared ES8 type — callers +-- targeting ES8 cannot accidentally emit undocumented body keys, while ES9 +-- callers retain typed access to both fields. +-- +-- Every type that is identical between ES8 and ES9 (response shapes, query +-- options, the @AsyncESQLId@ path wrapper, the @_clusters@ \/ @profile@ +-- fragments and all of their lenses) is re-exported verbatim from +-- "Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.EsQueryLanguage". +-- +-- For the authoritative ES9 wire shape see +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.EsQueryLanguage + ( -- * Request types (ES9) + ESQLRequest (..), + AsyncESQLRequest (..), + mkAsyncESQLRequest, + + -- * Request lenses (ES9) + esqlQueryLens, + esqlLocaleLens, + esqlTimeZoneLens, + esqlFilterLens, + esqlParamsLens, + esqlColumnarLens, + esqlProfileLens, + esqlTablesLens, + esqlIncludeCcsMetadataLens, + esqlIncludeExecutionMetadataLens, + asyncESQLRequestBaseLens, + asyncESQLRequestWaitForCompletionTimeoutLens, + asyncESQLRequestKeepAliveLens, + asyncESQLRequestKeepOnCompletionLens, + + -- * Shared (re-exported from the ES8 module) + module Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.EsQueryLanguage, + ) +where + +import Data.Aeson.KeyMap (union) +import Data.Aeson.KeyMap qualified as KM +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Query (Filter) +import Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.EsQueryLanguage hiding + ( AsyncESQLRequest (..), + ESQLRequest (..), + asyncESQLRequestBaseLens, + asyncESQLRequestKeepAliveLens, + asyncESQLRequestKeepOnCompletionLens, + asyncESQLRequestWaitForCompletionTimeoutLens, + esqlColumnarLens, + esqlFilterLens, + esqlIncludeCcsMetadataLens, + esqlLocaleLens, + esqlParamsLens, + esqlProfileLens, + esqlQueryLens, + esqlTablesLens, + mkAsyncESQLRequest, + ) + +-- | Request body for the ES | QL @POST /_query@ API on Elasticsearch 9.x. +-- +-- This is the ES8 'Database.Bloodhound.Internal.Versions.ElasticSearch8.Types.EsQueryLanguage.ESQLRequest' +-- wire shape plus the two ES9-only body fields: +-- +-- * @time_zone@ ('esqlTimeZone') — sets the default timezone of the query. +-- Marked @Generally available; Added in 9.4.0@ in the v9 OpenAPI spec, so it +-- is ignored\/rejected by ES 8.x clusters; leave it 'Nothing' when targeting +-- ES 8.x. +-- * @include_execution_metadata@ ('esqlIncludeExecutionMetadata') — when +-- @'Just' 'True'@ the response carries an @_clusters@ object with execution +-- metadata even when the query is /not/ a cross-cluster search. ES9-only +-- (absent from the v8 spec; default @false@). It is the non-CCS counterpart +-- of @include_ccs_metadata@, which exists on both versions. +-- +-- Every field is 'Maybe' and rendered as a JSON @null@-dropped key via +-- 'omitNulls', so a request built entirely from 'Nothing' optionals produces a +-- body containing only @\"query\"@ — byte-identical to the documented minimal +-- wire shape on both ES8 and ES9. +-- +-- For more information see +-- . +data ESQLRequest = ESQLRequest + { esqlQuery :: Text, + esqlLocale :: Maybe Text, + -- | @time_zone@ — ES 9.4+. Sets the default timezone of the query. + esqlTimeZone :: Maybe Text, + esqlFilter :: Maybe Filter, + esqlParams :: Maybe [Value], + -- | @columnar@ — request columnar rather than row-oriented @values@ + -- in the response. Also honoured by the async endpoint. + esqlColumnar :: Maybe Bool, + -- | @profile@ — when @'Just' 'True'@ the response carries a @profile@ + -- object. Also honoured by the async endpoint. + esqlProfile :: Maybe Bool, + -- | @tables@ — LOOKUP join tables (ES 8.18+), an opaque JSON object + -- mapping table names to row arrays. Encoded verbatim. + esqlTables :: Maybe Value, + -- | @include_ccs_metadata@ — include cross-cluster search metadata in + -- the response when applicable. Also honoured by the async endpoint. + esqlIncludeCcsMetadata :: Maybe Bool, + -- | @include_execution_metadata@ — ES9 only. Attaches execution + -- metadata (an @_clusters@ object) to the response even for + -- non-cross-cluster queries. + esqlIncludeExecutionMetadata :: Maybe Bool + } + deriving stock (Eq, Show) + +instance ToJSON ESQLRequest where + toJSON ESQLRequest {..} = + omitNulls + [ "query" .= esqlQuery, + "locale" .= esqlLocale, + "time_zone" .= esqlTimeZone, + "filter" .= esqlFilter, + "params" .= esqlParams, + "columnar" .= esqlColumnar, + "profile" .= esqlProfile, + "tables" .= esqlTables, + "include_ccs_metadata" .= esqlIncludeCcsMetadata, + "include_execution_metadata" .= esqlIncludeExecutionMetadata + ] + +instance FromJSON ESQLRequest where + parseJSON (Object o) = + ESQLRequest + <$> o .: "query" + <*> o .:? "locale" + <*> o .:? "time_zone" + <*> o .:? "filter" + <*> o .:? "params" + <*> o .:? "columnar" + <*> o .:? "profile" + <*> o .:? "tables" + <*> o .:? "include_ccs_metadata" + <*> o .:? "include_execution_metadata" + parseJSON x = typeMismatch "ESQLRequest" x + +esqlQueryLens :: Lens' ESQLRequest Text +esqlQueryLens = lens esqlQuery (\x y -> x {esqlQuery = y}) + +esqlLocaleLens :: Lens' ESQLRequest (Maybe Text) +esqlLocaleLens = lens esqlLocale (\x y -> x {esqlLocale = y}) + +esqlTimeZoneLens :: Lens' ESQLRequest (Maybe Text) +esqlTimeZoneLens = lens esqlTimeZone (\x y -> x {esqlTimeZone = y}) + +esqlFilterLens :: Lens' ESQLRequest (Maybe Filter) +esqlFilterLens = lens esqlFilter (\x y -> x {esqlFilter = y}) + +esqlParamsLens :: Lens' ESQLRequest (Maybe [Value]) +esqlParamsLens = lens esqlParams (\x y -> x {esqlParams = y}) + +esqlColumnarLens :: Lens' ESQLRequest (Maybe Bool) +esqlColumnarLens = lens esqlColumnar (\x y -> x {esqlColumnar = y}) + +esqlProfileLens :: Lens' ESQLRequest (Maybe Bool) +esqlProfileLens = lens esqlProfile (\x y -> x {esqlProfile = y}) + +esqlTablesLens :: Lens' ESQLRequest (Maybe Value) +esqlTablesLens = lens esqlTables (\x y -> x {esqlTables = y}) + +esqlIncludeCcsMetadataLens :: Lens' ESQLRequest (Maybe Bool) +esqlIncludeCcsMetadataLens = + lens esqlIncludeCcsMetadata (\x y -> x {esqlIncludeCcsMetadata = y}) + +esqlIncludeExecutionMetadataLens :: Lens' ESQLRequest (Maybe Bool) +esqlIncludeExecutionMetadataLens = + lens esqlIncludeExecutionMetadata (\x y -> x {esqlIncludeExecutionMetadata = y}) + +-- | Request body for the async ES | QL @POST /_query/async@ API on +-- Elasticsearch 9.x. Wraps an ES9 'ESQLRequest' with the async-only body +-- parameters (@wait_for_completion_timeout@, @keep_alive@, +-- @keep_on_completion@). +-- +-- The @columnar@, @profile@, @include_ccs_metadata@, @time_zone@ and +-- @include_execution_metadata@ parameters are accepted by both the sync and +-- async endpoints and therefore live on the base 'ESQLRequest'; set them +-- there and they are forwarded automatically when this record is encoded. +-- +-- For more information see +-- . +data AsyncESQLRequest = AsyncESQLRequest + { asyncESQLRequestBase :: ESQLRequest, + asyncESQLRequestWaitForCompletionTimeout :: Maybe Text, + asyncESQLRequestKeepAlive :: Maybe Text, + asyncESQLRequestKeepOnCompletion :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | Smart constructor that promotes a plain 'ESQLRequest' to an +-- 'AsyncESQLRequest' with every async-only field defaulted to 'Nothing'. +mkAsyncESQLRequest :: ESQLRequest -> AsyncESQLRequest +mkAsyncESQLRequest base = + AsyncESQLRequest + { asyncESQLRequestBase = base, + asyncESQLRequestWaitForCompletionTimeout = Nothing, + asyncESQLRequestKeepAlive = Nothing, + asyncESQLRequestKeepOnCompletion = Nothing + } + +instance ToJSON AsyncESQLRequest where + toJSON areq = + case toJSON (asyncESQLRequestBase areq) of + Object baseObj -> Object (baseObj `union` asyncFields) + other -> other + where + asyncFields = + omitNullsKeyMap + [ "wait_for_completion_timeout" .= asyncESQLRequestWaitForCompletionTimeout areq, + "keep_alive" .= asyncESQLRequestKeepAlive areq, + "keep_on_completion" .= asyncESQLRequestKeepOnCompletion areq + ] + +instance FromJSON AsyncESQLRequest where + parseJSON (Object o) = + AsyncESQLRequest + <$> parseJSON (Object o) + <*> o .:? "wait_for_completion_timeout" + <*> o .:? "keep_alive" + <*> o .:? "keep_on_completion" + parseJSON x = typeMismatch "AsyncESQLRequest" x + +asyncESQLRequestBaseLens :: Lens' AsyncESQLRequest ESQLRequest +asyncESQLRequestBaseLens = + lens asyncESQLRequestBase (\x y -> x {asyncESQLRequestBase = y}) + +asyncESQLRequestWaitForCompletionTimeoutLens :: Lens' AsyncESQLRequest (Maybe Text) +asyncESQLRequestWaitForCompletionTimeoutLens = + lens + asyncESQLRequestWaitForCompletionTimeout + (\x y -> x {asyncESQLRequestWaitForCompletionTimeout = y}) + +asyncESQLRequestKeepAliveLens :: Lens' AsyncESQLRequest (Maybe Text) +asyncESQLRequestKeepAliveLens = + lens asyncESQLRequestKeepAlive (\x y -> x {asyncESQLRequestKeepAlive = y}) + +asyncESQLRequestKeepOnCompletionLens :: Lens' AsyncESQLRequest (Maybe Bool) +asyncESQLRequestKeepOnCompletionLens = + lens asyncESQLRequestKeepOnCompletion (\x y -> x {asyncESQLRequestKeepOnCompletion = y}) + +-- | Build a 'KM.KeyMap' from a list of @(key, value)@ pairs, dropping entries +-- whose value encodes to JSON @null@. Mirrors 'omitNulls' but returns a +-- 'KM.KeyMap' so it can be 'union'ed with the base 'ESQLRequest' object when +-- encoding an 'AsyncESQLRequest'. +omitNullsKeyMap :: [(Key, Value)] -> KM.KeyMap Value +omitNullsKeyMap = foldr go mempty + where + go (_, Null) acc = acc + go (k, v) acc = KM.insert k v acc diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/Features.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/Features.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/Features.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.Features +-- Description : Types for the ES9 @/_features@ endpoints +-- +-- Request option and response shapes for the Elasticsearch +-- @/_features@ endpoints: +-- +-- * @GET /_features@ (features-get-features) — 'FeaturesResponse' with a +-- list of installed features (@name@ + @description@). +-- * @POST /_features/_reset@ (features-reset-features) — +-- 'ResetFeaturesResponse' with the per-feature reset outcome. +-- +-- The @GET@ response is unambiguously an array of +-- @{"name", "description"}@ objects. The @POST@ response is shape-ambiguous: +-- the OpenAPI schema reuses the same @{"name", "description"}@ item, but the +-- documented response example returns @{"feature_name", "status"}@ objects. +-- 'ResetFeaturesItem' therefore decodes /both/ shapes, populating whichever +-- fields the server sends. +-- +-- Both endpoints are documented as experimental and intended for +-- development\/testing rather than production clusters. +-- +-- See +-- +-- and +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.Features + ( -- * GET /_features + Feature (..), + FeaturesResponse (..), + + -- * POST /_features/_reset + ResetFeaturesItem (..), + ResetFeaturesResponse (..), + + -- * Options + FeaturesOptions (..), + defaultFeaturesOptions, + featuresOptionsParams, + + -- * Optics + featureNameLens, + featureDescriptionLens, + featuresResponseFeaturesLens, + rfiFeatureNameLens, + rfiStatusLens, + rfiNameLens, + rfiDescriptionLens, + resetFeaturesResponseFeaturesLens, + foMasterTimeoutLens, + ) +where + +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Units + +-- | A single feature as returned by @GET /_features@. Both fields are +-- required by the schema. +data Feature = Feature + { featureName :: Text, + featureDescription :: Text + } + deriving stock (Eq, Show) + +instance ToJSON Feature where + toJSON Feature {..} = + object + [ "name" .= featureName, + "description" .= featureDescription + ] + +instance FromJSON Feature where + parseJSON (Object o) = + Feature + <$> o .: "name" + <*> o .: "description" + parseJSON x = typeMismatch "Feature" x + +featureNameLens :: Lens' Feature Text +featureNameLens = lens featureName (\x y -> x {featureName = y}) + +featureDescriptionLens :: Lens' Feature Text +featureDescriptionLens = lens featureDescription (\x y -> x {featureDescription = y}) + +-- | Top-level response of @GET /_features@. +newtype FeaturesResponse = FeaturesResponse + { featuresResponseFeatures :: [Feature] + } + deriving stock (Eq, Show) + +instance ToJSON FeaturesResponse where + toJSON FeaturesResponse {..} = + object ["features" .= featuresResponseFeatures] + +instance FromJSON FeaturesResponse where + parseJSON (Object o) = + FeaturesResponse <$> o .: "features" + parseJSON x = typeMismatch "FeaturesResponse" x + +featuresResponseFeaturesLens :: Lens' FeaturesResponse [Feature] +featuresResponseFeaturesLens = + lens featuresResponseFeatures (\x y -> x {featuresResponseFeatures = y}) + +-- | A single item in the @POST /_features/_reset@ response. The schema +-- declares @name@\/@description@ (shared with 'Feature'), but the +-- documented example returns @feature_name@\/@status@; every field is +-- optional so either shape decodes. +data ResetFeaturesItem = ResetFeaturesItem + { rfiFeatureName :: Maybe Text, + rfiStatus :: Maybe Text, + rfiName :: Maybe Text, + rfiDescription :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON ResetFeaturesItem where + toJSON ResetFeaturesItem {..} = + omitNulls + [ "feature_name" .= rfiFeatureName, + "status" .= rfiStatus, + "name" .= rfiName, + "description" .= rfiDescription + ] + +instance FromJSON ResetFeaturesItem where + parseJSON (Object o) = + ResetFeaturesItem + <$> o .:? "feature_name" + <*> o .:? "status" + <*> o .:? "name" + <*> o .:? "description" + parseJSON x = typeMismatch "ResetFeaturesItem" x + +rfiFeatureNameLens :: Lens' ResetFeaturesItem (Maybe Text) +rfiFeatureNameLens = lens rfiFeatureName (\x y -> x {rfiFeatureName = y}) + +rfiStatusLens :: Lens' ResetFeaturesItem (Maybe Text) +rfiStatusLens = lens rfiStatus (\x y -> x {rfiStatus = y}) + +rfiNameLens :: Lens' ResetFeaturesItem (Maybe Text) +rfiNameLens = lens rfiName (\x y -> x {rfiName = y}) + +rfiDescriptionLens :: Lens' ResetFeaturesItem (Maybe Text) +rfiDescriptionLens = lens rfiDescription (\x y -> x {rfiDescription = y}) + +-- | Top-level response of @POST /_features/_reset@. +newtype ResetFeaturesResponse = ResetFeaturesResponse + { resetFeaturesResponseFeatures :: [ResetFeaturesItem] + } + deriving stock (Eq, Show) + +instance ToJSON ResetFeaturesResponse where + toJSON ResetFeaturesResponse {..} = + object ["features" .= resetFeaturesResponseFeatures] + +instance FromJSON ResetFeaturesResponse where + parseJSON (Object o) = + ResetFeaturesResponse <$> o .: "features" + parseJSON x = typeMismatch "ResetFeaturesResponse" x + +resetFeaturesResponseFeaturesLens :: Lens' ResetFeaturesResponse [ResetFeaturesItem] +resetFeaturesResponseFeaturesLens = + lens resetFeaturesResponseFeatures (\x y -> x {resetFeaturesResponseFeatures = y}) + +-- | URI parameters accepted by both @/_features@ endpoints: only +-- @master_timeout@ (the period to wait for a connection to the master +-- node). Optional, so 'defaultFeaturesOptions' renders to no query string. +-- +-- The @POST /_features/_reset@ operation additionally documents a +-- @timeout@ query parameter (operation timeout, default @30s@). It is +-- intentionally /not/ modelled here, because 'FeaturesOptions' is shared +-- with @GET /_features@ — which does not accept @timeout@ — and emitting +-- it on a GET would be invalid. This mirrors the selective-param +-- modelling precedent elsewhere in the codebase. +newtype FeaturesOptions = FeaturesOptions + { foMasterTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'FeaturesOptions' with @master_timeout@ set to 'Nothing'. Produces no +-- query string. +defaultFeaturesOptions :: FeaturesOptions +defaultFeaturesOptions = + FeaturesOptions {foMasterTimeout = Nothing} + +-- | Render 'FeaturesOptions' as a list of @(key, value)@ pairs suitable for +-- 'withQueries'. 'Nothing' is omitted. +featuresOptionsParams :: FeaturesOptions -> [(Text, Maybe Text)] +featuresOptionsParams opts = + catMaybes + [ ("master_timeout",) . Just . renderDuration <$> foMasterTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +foMasterTimeoutLens :: Lens' FeaturesOptions (Maybe (TimeUnits, Word32)) +foMasterTimeoutLens = lens foMasterTimeout (\x y -> x {foMasterTimeout = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/HealthReport.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/HealthReport.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/HealthReport.hs @@ -0,0 +1,380 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.HealthReport +-- Description : Types for the ES9 @GET /_health_report@ endpoint +-- +-- Request option and response shapes for the Elasticsearch +-- @GET /_health_report[\/{feature}]@ endpoint (health-report), which +-- returns a high-level health summary of the cluster broken down by +-- /indicator/ (@master_is_stable@, @shards_availability@, @disk@, +-- @ilm@, ...). Each indicator carries a 'HealthReportStatus' colour, a +-- human-readable @symptom@, and optional @impacts@\/@diagnosis@ arrays +-- describing what is wrong and how to fix it. +-- +-- The indicator subtypes each add their own @details@ object; because +-- those are subtype-specific and evolve between ES releases, the +-- 'HealthIndicator' record captures the fields common to every subtype +-- and funnels everything else into an 'hiOther' catch-all, so the same +-- parser tolerates new indicator types without failing. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.HealthReport + ( -- * Response + HealthReport (..), + HealthReportStatus (..), + healthReportStatusToText, + healthReportStatusFromText, + HealthIndicator (..), + HealthImpact (..), + HealthDiagnosis (..), + DiagnosisAffectedResources (..), + + -- * Options + HealthReportOptions (..), + defaultHealthReportOptions, + healthReportOptionsParams, + + -- * Optics + hrClusterNameLens, + hrStatusLens, + hrIndicatorsLens, + hiStatusLens, + hiSymptomLens, + hiImpactsLens, + hiDiagnosisLens, + hiOtherLens, + himpDescriptionLens, + himpIdLens, + himpImpactAreasLens, + himpSeverityLens, + hdiagIdLens, + hdiagActionLens, + hdiagCauseLens, + hdiagHelpUrlLens, + hdiagAffectedResourcesLens, + darIndicesLens, + darNodesLens, + darSlmPoliciesLens, + darFeatureStatesLens, + darSnapshotRepositoriesLens, + hroVerboseLens, + hroSizeLens, + hroTimeoutLens, + ) +where + +import Data.Aeson.KeyMap qualified as X +import Data.Map.Strict qualified as M +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Units + +-- | Health colour used both at the top level ('hrStatus') and per +-- indicator ('hiStatus'). @unavailable@ means the indicator could not be +-- computed; @unknown@ means it has not yet been determined. +data HealthReportStatus + = HealthReportStatusGreen + | HealthReportStatusYellow + | HealthReportStatusRed + | HealthReportStatusUnknown + | HealthReportStatusUnavailable + deriving stock (Eq, Show, Bounded, Enum) + +-- | Wire rendering of a 'HealthReportStatus'. +healthReportStatusToText :: HealthReportStatus -> Text +healthReportStatusToText HealthReportStatusGreen = "green" +healthReportStatusToText HealthReportStatusYellow = "yellow" +healthReportStatusToText HealthReportStatusRed = "red" +healthReportStatusToText HealthReportStatusUnknown = "unknown" +healthReportStatusToText HealthReportStatusUnavailable = "unavailable" + +-- | Inverse of 'healthReportStatusToText'. +healthReportStatusFromText :: Text -> Maybe HealthReportStatus +healthReportStatusFromText "green" = Just HealthReportStatusGreen +healthReportStatusFromText "yellow" = Just HealthReportStatusYellow +healthReportStatusFromText "red" = Just HealthReportStatusRed +healthReportStatusFromText "unknown" = Just HealthReportStatusUnknown +healthReportStatusFromText "unavailable" = Just HealthReportStatusUnavailable +healthReportStatusFromText _ = Nothing + +instance ToJSON HealthReportStatus where + toJSON = String . healthReportStatusToText + +instance FromJSON HealthReportStatus where + parseJSON (String t) = maybe (fail "invalid HealthReportStatus") pure (healthReportStatusFromText t) + parseJSON x = typeMismatch "HealthReportStatus" x + +-- | Top-level response of @GET /_health_report@. @cluster_name@ and the +-- @indicators@ map are always present; the top-level @status@ (the +-- cluster-wide rollup) is optional. +data HealthReport = HealthReport + { hrClusterName :: Text, + hrStatus :: Maybe HealthReportStatus, + hrIndicators :: M.Map Text HealthIndicator + } + deriving stock (Eq, Show) + +instance ToJSON HealthReport where + toJSON HealthReport {..} = + omitNulls + [ "cluster_name" .= hrClusterName, + "status" .= hrStatus, + "indicators" .= hrIndicators + ] + +instance FromJSON HealthReport where + parseJSON (Object o) = + HealthReport + <$> o .: "cluster_name" + <*> o .:? "status" + <*> o .: "indicators" + parseJSON x = typeMismatch "HealthReport" x + +hrClusterNameLens :: Lens' HealthReport Text +hrClusterNameLens = lens hrClusterName (\x y -> x {hrClusterName = y}) + +hrStatusLens :: Lens' HealthReport (Maybe HealthReportStatus) +hrStatusLens = lens hrStatus (\x y -> x {hrStatus = y}) + +hrIndicatorsLens :: Lens' HealthReport (M.Map Text HealthIndicator) +hrIndicatorsLens = lens hrIndicators (\x y -> x {hrIndicators = y}) + +-- | A single health indicator. @status@ and @symptom@ are common to every +-- indicator subtype; @impacts@ and @diagnosis@ are present when the +-- indicator is not green. 'hiOther' captures every additional field the +-- server attaches (notably the subtype-specific @details@ object), so new +-- or indicator-specific fields survive a round trip. +data HealthIndicator = HealthIndicator + { hiStatus :: HealthReportStatus, + hiSymptom :: Text, + hiImpacts :: Maybe [HealthImpact], + hiDiagnosis :: Maybe [HealthDiagnosis], + hiOther :: Maybe Object + } + deriving stock (Eq, Show) + +indicatorKeys :: [Key] +indicatorKeys = ["status", "symptom", "impacts", "diagnosis"] + +instance ToJSON HealthIndicator where + toJSON HealthIndicator {..} = + Object (X.union known other') + where + known = + X.fromList $ + catMaybes + [ Just ("status" .= hiStatus), + Just ("symptom" .= hiSymptom), + ("impacts" .=) <$> hiImpacts, + ("diagnosis" .=) <$> hiDiagnosis + ] + other' = maybe mempty id hiOther + +instance FromJSON HealthIndicator where + parseJSON (Object o) = do + hiStatus <- o .: "status" + hiSymptom <- o .: "symptom" + hiImpacts <- o .:? "impacts" + hiDiagnosis <- o .:? "diagnosis" + let remainder = deleteSeveral indicatorKeys o + hiOther = if X.null remainder then Nothing else Just remainder + pure HealthIndicator {..} + parseJSON x = typeMismatch "HealthIndicator" x + +hiStatusLens :: Lens' HealthIndicator HealthReportStatus +hiStatusLens = lens hiStatus (\x y -> x {hiStatus = y}) + +hiSymptomLens :: Lens' HealthIndicator Text +hiSymptomLens = lens hiSymptom (\x y -> x {hiSymptom = y}) + +hiImpactsLens :: Lens' HealthIndicator (Maybe [HealthImpact]) +hiImpactsLens = lens hiImpacts (\x y -> x {hiImpacts = y}) + +hiDiagnosisLens :: Lens' HealthIndicator (Maybe [HealthDiagnosis]) +hiDiagnosisLens = lens hiDiagnosis (\x y -> x {hiDiagnosis = y}) + +hiOtherLens :: Lens' HealthIndicator (Maybe Object) +hiOtherLens = lens hiOther (\x y -> x {hiOther = y}) + +-- | One consequence of an unhealthy indicator. @severity@ is a numeric +-- scale; @impact_areas@ are free-form strings drawn from a documented +-- enum (@search@, @ingest@, @backup@, @deployment_management@). +data HealthImpact = HealthImpact + { himpDescription :: Text, + himpId :: Text, + himpImpactAreas :: [Text], + himpSeverity :: Int + } + deriving stock (Eq, Show) + +instance ToJSON HealthImpact where + toJSON HealthImpact {..} = + object + [ "description" .= himpDescription, + "id" .= himpId, + "impact_areas" .= himpImpactAreas, + "severity" .= himpSeverity + ] + +instance FromJSON HealthImpact where + parseJSON (Object o) = + HealthImpact + <$> o .: "description" + <*> o .: "id" + <*> o .:? "impact_areas" .!= [] + <*> o .: "severity" + parseJSON x = typeMismatch "HealthImpact" x + +himpDescriptionLens :: Lens' HealthImpact Text +himpDescriptionLens = lens himpDescription (\x y -> x {himpDescription = y}) + +himpIdLens :: Lens' HealthImpact Text +himpIdLens = lens himpId (\x y -> x {himpId = y}) + +himpImpactAreasLens :: Lens' HealthImpact [Text] +himpImpactAreasLens = lens himpImpactAreas (\x y -> x {himpImpactAreas = y}) + +himpSeverityLens :: Lens' HealthImpact Int +himpSeverityLens = lens himpSeverity (\x y -> x {himpSeverity = y}) + +-- | One root-cause analysis for an indicator, with suggested remediation. +data HealthDiagnosis = HealthDiagnosis + { hdiagId :: Text, + hdiagAction :: Text, + hdiagCause :: Text, + hdiagHelpUrl :: Text, + hdiagAffectedResources :: Maybe DiagnosisAffectedResources + } + deriving stock (Eq, Show) + +instance ToJSON HealthDiagnosis where + toJSON HealthDiagnosis {..} = + omitNulls + [ "id" .= hdiagId, + "action" .= hdiagAction, + "cause" .= hdiagCause, + "help_url" .= hdiagHelpUrl, + "affected_resources" .= hdiagAffectedResources + ] + +instance FromJSON HealthDiagnosis where + parseJSON (Object o) = + HealthDiagnosis + <$> o .: "id" + <*> o .: "action" + <*> o .: "cause" + <*> o .: "help_url" + <*> o .:? "affected_resources" + parseJSON x = typeMismatch "HealthDiagnosis" x + +hdiagIdLens :: Lens' HealthDiagnosis Text +hdiagIdLens = lens hdiagId (\x y -> x {hdiagId = y}) + +hdiagActionLens :: Lens' HealthDiagnosis Text +hdiagActionLens = lens hdiagAction (\x y -> x {hdiagAction = y}) + +hdiagCauseLens :: Lens' HealthDiagnosis Text +hdiagCauseLens = lens hdiagCause (\x y -> x {hdiagCause = y}) + +hdiagHelpUrlLens :: Lens' HealthDiagnosis Text +hdiagHelpUrlLens = lens hdiagHelpUrl (\x y -> x {hdiagHelpUrl = y}) + +hdiagAffectedResourcesLens :: Lens' HealthDiagnosis (Maybe DiagnosisAffectedResources) +hdiagAffectedResourcesLens = + lens hdiagAffectedResources (\x y -> x {hdiagAffectedResources = y}) + +-- | Resources named by a 'HealthDiagnosis'. Every field is optional; the +-- server only populates the ones relevant to the diagnosis. +data DiagnosisAffectedResources = DiagnosisAffectedResources + { darIndices :: Maybe [Text], + darNodes :: Maybe [Value], + darSlmPolicies :: Maybe [Text], + darFeatureStates :: Maybe [Text], + darSnapshotRepositories :: Maybe [Text] + } + deriving stock (Eq, Show) + +instance ToJSON DiagnosisAffectedResources where + toJSON DiagnosisAffectedResources {..} = + omitNulls + [ "indices" .= darIndices, + "nodes" .= darNodes, + "slm_policies" .= darSlmPolicies, + "feature_states" .= darFeatureStates, + "snapshot_repositories" .= darSnapshotRepositories + ] + +instance FromJSON DiagnosisAffectedResources where + parseJSON (Object o) = + DiagnosisAffectedResources + <$> o .:? "indices" + <*> o .:? "nodes" + <*> o .:? "slm_policies" + <*> o .:? "feature_states" + <*> o .:? "snapshot_repositories" + parseJSON x = typeMismatch "DiagnosisAffectedResources" x + +darIndicesLens :: Lens' DiagnosisAffectedResources (Maybe [Text]) +darIndicesLens = lens darIndices (\x y -> x {darIndices = y}) + +darNodesLens :: Lens' DiagnosisAffectedResources (Maybe [Value]) +darNodesLens = lens darNodes (\x y -> x {darNodes = y}) + +darSlmPoliciesLens :: Lens' DiagnosisAffectedResources (Maybe [Text]) +darSlmPoliciesLens = lens darSlmPolicies (\x y -> x {darSlmPolicies = y}) + +darFeatureStatesLens :: Lens' DiagnosisAffectedResources (Maybe [Text]) +darFeatureStatesLens = lens darFeatureStates (\x y -> x {darFeatureStates = y}) + +darSnapshotRepositoriesLens :: Lens' DiagnosisAffectedResources (Maybe [Text]) +darSnapshotRepositoriesLens = + lens darSnapshotRepositories (\x y -> x {darSnapshotRepositories = y}) + +-- | URI parameters accepted by @GET /_health_report[\/{feature}]@. @verbose@ +-- enables more expensive root-cause analysis (set @False@ when polling); +-- @size@ caps the number of affected resources returned; @timeout@ bounds +-- the operation. Every field is optional so +-- 'defaultHealthReportOptions' renders to no query string. +data HealthReportOptions = HealthReportOptions + { hroVerbose :: Maybe Bool, + hroSize :: Maybe Int, + hroTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'HealthReportOptions' with every parameter set to 'Nothing'. Produces +-- no query string. +defaultHealthReportOptions :: HealthReportOptions +defaultHealthReportOptions = + HealthReportOptions + { hroVerbose = Nothing, + hroSize = Nothing, + hroTimeout = Nothing + } + +-- | Render 'HealthReportOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted. +healthReportOptionsParams :: HealthReportOptions -> [(Text, Maybe Text)] +healthReportOptionsParams opts = + catMaybes + [ ("verbose",) . Just . renderBool <$> hroVerbose opts, + ("size",) . Just . showText <$> hroSize opts, + ("timeout",) . Just . renderDuration <$> hroTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" + +hroVerboseLens :: Lens' HealthReportOptions (Maybe Bool) +hroVerboseLens = lens hroVerbose (\x y -> x {hroVerbose = y}) + +hroSizeLens :: Lens' HealthReportOptions (Maybe Int) +hroSizeLens = lens hroSize (\x y -> x {hroSize = y}) + +hroTimeoutLens :: Lens' HealthReportOptions (Maybe (TimeUnits, Word32)) +hroTimeoutLens = lens hroTimeout (\x y -> x {hroTimeout = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/IngestGeoIp.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/IngestGeoIp.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/IngestGeoIp.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.IngestGeoIp +-- Description : Types for the Elasticsearch GeoIP / IP-location database APIs +-- +-- Defines the request and response shapes for the ingest GeoIP and +-- IP-location database configuration endpoints (GA since 8.15, shared +-- verbatim by ES 8.x and 9.x), plus the GeoIP downloader statistics +-- endpoint: +-- +-- * @GET /_ingest/geoip/stats@ — 'GeoIpStatsResponse'. +-- * @GET /_ingest/geoip/database[/{id}]@ — 'GeoIpDatabasesResponse'. +-- * @PUT /_ingest/geoip/database/{id}@ — body 'GeoIpDatabasePutBody'. +-- * @DELETE /_ingest/geoip/database/{id}@ — returns 'Acknowledged'. +-- * @GET /_ingest/ip_location/database[/{id}]@ — 'GeoIpDatabasesResponse'. +-- * @PUT /_ingest/ip_location/database/{id}@ — body 'IpLocationDatabasePutBody'. +-- * @DELETE /_ingest/ip_location/database/{id}@ — returns 'Acknowledged'. +-- +-- The GET response's @database@ object is the stored configuration; like +-- the ingest pipeline body it is carried here as an opaque 'Value' until +-- a typed schema lands. The @id@ path segment accepts a single id, a +-- comma-separated list, or @*@ (wildcard) — all represented by the plain +-- 'GeoIpDatabaseId' newtype. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.IngestGeoIp + ( -- * Identity + GeoIpDatabaseId (..), + unGeoIpDatabaseId, + + -- * PUT request body + GeoIpMaxmindConfig (..), + geoIpMaxmindConfigAccountIdLens, + GeoIpDatabasePutBody (..), + geoIpDatabasePutBodyNameLens, + geoIpDatabasePutBodyMaxmindLens, + IpLocationDatabasePutBody (..), + ipLocationDatabasePutBodyNameLens, + ipLocationDatabasePutBodyMaxmindLens, + ipLocationDatabasePutBodyIpInfoLens, + + -- * GET response + GeoIpDatabaseInfo (..), + geoIpDatabaseInfoIdLens, + geoIpDatabaseInfoVersionLens, + geoIpDatabaseInfoModifiedDateMillisLens, + geoIpDatabaseInfoDatabaseLens, + GeoIpDatabasesResponse (..), + geoIpDatabasesResponseDatabasesLens, + + -- * Stats response + GeoIpStats (..), + geoIpStatsSuccessfulDownloadsLens, + geoIpStatsFailedDownloadsLens, + geoIpStatsTotalDownloadTimeLens, + geoIpStatsDatabasesCountLens, + geoIpStatsSkippedUpdatesLens, + geoIpStatsExpiredDatabasesLens, + GeoIpNodeDatabase (..), + geoIpNodeDatabaseNameLens, + GeoIpNodeStats (..), + geoIpNodeStatsDatabasesLens, + geoIpNodeStatsFilesInTempLens, + GeoIpStatsResponse (..), + geoIpStatsResponseStatsLens, + geoIpStatsResponseNodesLens, + ) +where + +import Data.Aeson +import Data.Map.Strict qualified as M +import Data.String (IsString) +import Database.Bloodhound.Internal.Utils.Imports + +-- | The @@ path segment of +-- @\/_ingest\/(geoip|ip_location)\/database\/@. Accepts a single id, +-- a comma-separated list (e.g. @"mydb,other"@) or a wildcard @"*"@; the +-- value is forwarded verbatim as the final URL component. +newtype GeoIpDatabaseId = GeoIpDatabaseId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unGeoIpDatabaseId :: GeoIpDatabaseId -> Text +unGeoIpDatabaseId (GeoIpDatabaseId x) = x + +-- | The @maxmind@ provider configuration nested inside the PUT body. The +-- wire shape is @{"account_id": "..."}@; @account_id@ is the MaxMind +-- license key used to download databases directly from MaxMind. +data GeoIpMaxmindConfig = GeoIpMaxmindConfig + { gimcAccountId :: Text + } + deriving stock (Eq, Show) + +instance ToJSON GeoIpMaxmindConfig where + toJSON GeoIpMaxmindConfig {..} = + object ["account_id" .= gimcAccountId] + +instance FromJSON GeoIpMaxmindConfig where + parseJSON = withObject "GeoIpMaxmindConfig" $ \o -> + GeoIpMaxmindConfig <$> o .: "account_id" + +geoIpMaxmindConfigAccountIdLens :: Lens' GeoIpMaxmindConfig Text +geoIpMaxmindConfigAccountIdLens = + lens gimcAccountId (\x y -> x {gimcAccountId = y}) + +-- | The PUT request body for +-- @PUT \/_ingest\/geoip\/database\/{id}@. The @name@ field is the +-- database file name (e.g. @"GeoLite2-City.mmdb"@); the @maxmind@ +-- provider is required for GeoIP databases — a request without it is +-- rejected by the server, so it is carried as a plain (non-'Maybe') +-- 'GeoIpMaxmindConfig' to make the invalid state unrepresentable. +data GeoIpDatabasePutBody = GeoIpDatabasePutBody + { gipbName :: Text, + gipbMaxmind :: GeoIpMaxmindConfig + } + deriving stock (Eq, Show) + +instance ToJSON GeoIpDatabasePutBody where + toJSON GeoIpDatabasePutBody {..} = + object + [ "name" .= gipbName, + "maxmind" .= gipbMaxmind + ] + +instance FromJSON GeoIpDatabasePutBody where + parseJSON = withObject "GeoIpDatabasePutBody" $ \o -> + GeoIpDatabasePutBody + <$> o .: "name" + <*> o .: "maxmind" + +geoIpDatabasePutBodyNameLens :: Lens' GeoIpDatabasePutBody Text +geoIpDatabasePutBodyNameLens = + lens gipbName (\x y -> x {gipbName = y}) + +geoIpDatabasePutBodyMaxmindLens :: Lens' GeoIpDatabasePutBody GeoIpMaxmindConfig +geoIpDatabasePutBodyMaxmindLens = + lens gipbMaxmind (\x y -> x {gipbMaxmind = y}) + +-- | The PUT request body for +-- @PUT \/_ingest\/ip_location\/database\/{id}@. The @name@ field is the +-- database file name (e.g. @"GeoLite2-City.mmdb"@). Exactly one provider +-- is required: either @maxmind@ or @ipinfo@. Since the two are +-- interchangeable at the type level, both are 'Maybe' and encoding omits +-- a 'Nothing' provider so the caller selects which to send. Note: the +-- type cannot enforce single-selection; setting both to 'Just' or both +-- to 'Nothing' will produce a body the server rejects — the caller is +-- responsible for setting exactly one. +data IpLocationDatabasePutBody = IpLocationDatabasePutBody + { ilpbName :: Text, + ilpbMaxmind :: Maybe GeoIpMaxmindConfig, + ilpbIpInfo :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON IpLocationDatabasePutBody where + toJSON IpLocationDatabasePutBody {..} = + omitNulls + [ "name" .= ilpbName, + "maxmind" .= ilpbMaxmind, + "ipinfo" .= ilpbIpInfo + ] + +instance FromJSON IpLocationDatabasePutBody where + parseJSON = withObject "IpLocationDatabasePutBody" $ \o -> + IpLocationDatabasePutBody + <$> o .: "name" + <*> o .:? "maxmind" + <*> o .:? "ipinfo" + +ipLocationDatabasePutBodyNameLens :: Lens' IpLocationDatabasePutBody Text +ipLocationDatabasePutBodyNameLens = + lens ilpbName (\x y -> x {ilpbName = y}) + +ipLocationDatabasePutBodyMaxmindLens :: Lens' IpLocationDatabasePutBody (Maybe GeoIpMaxmindConfig) +ipLocationDatabasePutBodyMaxmindLens = + lens ilpbMaxmind (\x y -> x {ilpbMaxmind = y}) + +ipLocationDatabasePutBodyIpInfoLens :: Lens' IpLocationDatabasePutBody (Maybe Value) +ipLocationDatabasePutBodyIpInfoLens = + lens ilpbIpInfo (\x y -> x {ilpbIpInfo = y}) + +-- | A single entry in the @databases@ array of the GET +-- @\/_ingest\/(geoip|ip_location)\/database[\/{id}]@ response. The +-- @database@ field is the stored configuration object, carried as an +-- opaque 'Value'. All four fields are documented as Required for both +-- GeoIP and IP-location database responses, so the 'FromJSON' parser +-- demands them strictly. +data GeoIpDatabaseInfo = GeoIpDatabaseInfo + { gidiId :: Text, + gidiVersion :: Scientific, + gidiModifiedDateMillis :: Scientific, + gidiDatabase :: Value + } + deriving stock (Eq, Show) + +instance ToJSON GeoIpDatabaseInfo where + toJSON GeoIpDatabaseInfo {..} = + object + [ "id" .= gidiId, + "version" .= gidiVersion, + "modified_date_millis" .= gidiModifiedDateMillis, + "database" .= gidiDatabase + ] + +instance FromJSON GeoIpDatabaseInfo where + parseJSON = withObject "GeoIpDatabaseInfo" $ \o -> + GeoIpDatabaseInfo + <$> o .: "id" + <*> o .: "version" + <*> o .: "modified_date_millis" + <*> o .: "database" + +geoIpDatabaseInfoIdLens :: Lens' GeoIpDatabaseInfo Text +geoIpDatabaseInfoIdLens = + lens gidiId (\x y -> x {gidiId = y}) + +geoIpDatabaseInfoVersionLens :: Lens' GeoIpDatabaseInfo Scientific +geoIpDatabaseInfoVersionLens = + lens gidiVersion (\x y -> x {gidiVersion = y}) + +geoIpDatabaseInfoModifiedDateMillisLens :: Lens' GeoIpDatabaseInfo Scientific +geoIpDatabaseInfoModifiedDateMillisLens = + lens gidiModifiedDateMillis (\x y -> x {gidiModifiedDateMillis = y}) + +geoIpDatabaseInfoDatabaseLens :: Lens' GeoIpDatabaseInfo Value +geoIpDatabaseInfoDatabaseLens = + lens gidiDatabase (\x y -> x {gidiDatabase = y}) + +-- | Response body of the GET database-configuration endpoints. The +-- server returns a @databases@ array of 'GeoIpDatabaseInfo'; an empty or +-- missing array decodes to @[]@. +newtype GeoIpDatabasesResponse = GeoIpDatabasesResponse + { gdrDatabases :: [GeoIpDatabaseInfo] + } + deriving stock (Eq, Show) + deriving newtype (Semigroup, Monoid) + +instance ToJSON GeoIpDatabasesResponse where + toJSON GeoIpDatabasesResponse {..} = + object ["databases" .= gdrDatabases] + +instance FromJSON GeoIpDatabasesResponse where + parseJSON = withObject "GeoIpDatabasesResponse" $ \o -> + GeoIpDatabasesResponse <$> o .:? "databases" .!= [] + +geoIpDatabasesResponseDatabasesLens :: Lens' GeoIpDatabasesResponse [GeoIpDatabaseInfo] +geoIpDatabasesResponseDatabasesLens = + lens gdrDatabases (\x y -> x {gdrDatabases = y}) + +-- | Aggregate downloader statistics returned by +-- @GET /_ingest/geoip/stats@. All six numeric fields are documented as +-- Required and parsed strictly with @.:@. The numeric fields are +-- 'Scientific' to tolerate both integer and fractional JSON encodings. +data GeoIpStats = GeoIpStats + { gisSuccessfulDownloads :: Scientific, + gisFailedDownloads :: Scientific, + gisTotalDownloadTime :: Scientific, + gisDatabasesCount :: Scientific, + gisSkippedUpdates :: Scientific, + gisExpiredDatabases :: Scientific + } + deriving stock (Eq, Show) + +instance ToJSON GeoIpStats where + toJSON GeoIpStats {..} = + object + [ "successful_downloads" .= gisSuccessfulDownloads, + "failed_downloads" .= gisFailedDownloads, + "total_download_time" .= gisTotalDownloadTime, + "databases_count" .= gisDatabasesCount, + "skipped_updates" .= gisSkippedUpdates, + "expired_databases" .= gisExpiredDatabases + ] + +instance FromJSON GeoIpStats where + parseJSON = withObject "GeoIpStats" $ \o -> do + gisSuccessfulDownloads <- o .: "successful_downloads" + gisFailedDownloads <- o .: "failed_downloads" + gisTotalDownloadTime <- o .: "total_download_time" + gisDatabasesCount <- o .: "databases_count" + gisSkippedUpdates <- o .: "skipped_updates" + gisExpiredDatabases <- o .: "expired_databases" + pure GeoIpStats {..} + +geoIpStatsSuccessfulDownloadsLens :: Lens' GeoIpStats Scientific +geoIpStatsSuccessfulDownloadsLens = + lens gisSuccessfulDownloads (\x y -> x {gisSuccessfulDownloads = y}) + +geoIpStatsFailedDownloadsLens :: Lens' GeoIpStats Scientific +geoIpStatsFailedDownloadsLens = + lens gisFailedDownloads (\x y -> x {gisFailedDownloads = y}) + +geoIpStatsTotalDownloadTimeLens :: Lens' GeoIpStats Scientific +geoIpStatsTotalDownloadTimeLens = + lens gisTotalDownloadTime (\x y -> x {gisTotalDownloadTime = y}) + +geoIpStatsDatabasesCountLens :: Lens' GeoIpStats Scientific +geoIpStatsDatabasesCountLens = + lens gisDatabasesCount (\x y -> x {gisDatabasesCount = y}) + +geoIpStatsSkippedUpdatesLens :: Lens' GeoIpStats Scientific +geoIpStatsSkippedUpdatesLens = + lens gisSkippedUpdates (\x y -> x {gisSkippedUpdates = y}) + +geoIpStatsExpiredDatabasesLens :: Lens' GeoIpStats Scientific +geoIpStatsExpiredDatabasesLens = + lens gisExpiredDatabases (\x y -> x {gisExpiredDatabases = y}) + +-- | A single database name reported under a node's @databases@ list in +-- the GeoIP stats response. The wire shape is @{"name": "..."}@. +data GeoIpNodeDatabase = GeoIpNodeDatabase + { gindName :: Text + } + deriving stock (Eq, Show) + +instance ToJSON GeoIpNodeDatabase where + toJSON GeoIpNodeDatabase {..} = + object ["name" .= gindName] + +instance FromJSON GeoIpNodeDatabase where + parseJSON = withObject "GeoIpNodeDatabase" $ \o -> + GeoIpNodeDatabase <$> o .: "name" + +geoIpNodeDatabaseNameLens :: Lens' GeoIpNodeDatabase Text +geoIpNodeDatabaseNameLens = + lens gindName (\x y -> x {gindName = y}) + +-- | Per-node GeoIP statistics. @databases@ is the list of locally cached +-- database files; @files_in_temp@ lists transient files in the node's +-- temporary directory. Both default to @[]@ when the server omits them. +data GeoIpNodeStats = GeoIpNodeStats + { ginsDatabases :: [GeoIpNodeDatabase], + ginsFilesInTemp :: [Text] + } + deriving stock (Eq, Show) + +instance ToJSON GeoIpNodeStats where + toJSON GeoIpNodeStats {..} = + object + [ "databases" .= ginsDatabases, + "files_in_temp" .= ginsFilesInTemp + ] + +instance FromJSON GeoIpNodeStats where + parseJSON = withObject "GeoIpNodeStats" $ \o -> + GeoIpNodeStats + <$> o .:? "databases" .!= [] + <*> o .:? "files_in_temp" .!= [] + +geoIpNodeStatsDatabasesLens :: Lens' GeoIpNodeStats [GeoIpNodeDatabase] +geoIpNodeStatsDatabasesLens = + lens ginsDatabases (\x y -> x {ginsDatabases = y}) + +geoIpNodeStatsFilesInTempLens :: Lens' GeoIpNodeStats [Text] +geoIpNodeStatsFilesInTempLens = + lens ginsFilesInTemp (\x y -> x {ginsFilesInTemp = y}) + +-- | Response body of @GET /_ingest/geoip/stats@. The @stats@ field +-- carries the aggregate 'GeoIpStats'; the @nodes@ field is a 'Map' keyed +-- by node id whose values are per-node 'GeoIpNodeStats'. Both fields are +-- documented as Required and parsed strictly with @.:@. +data GeoIpStatsResponse = GeoIpStatsResponse + { gisrStats :: GeoIpStats, + gisrNodes :: M.Map Text GeoIpNodeStats + } + deriving stock (Eq, Show) + +instance ToJSON GeoIpStatsResponse where + toJSON GeoIpStatsResponse {..} = + object + [ "stats" .= gisrStats, + "nodes" .= gisrNodes + ] + +instance FromJSON GeoIpStatsResponse where + parseJSON = withObject "GeoIpStatsResponse" $ \o -> + GeoIpStatsResponse + <$> o .: "stats" + <*> o .: "nodes" + +geoIpStatsResponseStatsLens :: Lens' GeoIpStatsResponse GeoIpStats +geoIpStatsResponseStatsLens = + lens gisrStats (\x y -> x {gisrStats = y}) + +geoIpStatsResponseNodesLens :: Lens' GeoIpStatsResponse (M.Map Text GeoIpNodeStats) +geoIpStatsResponseNodesLens = + lens gisrNodes (\x y -> x {gisrNodes = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlAnomalyJobs.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlAnomalyJobs.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlAnomalyJobs.hs @@ -0,0 +1,868 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlAnomalyJobs +-- Description : Types for the Elasticsearch ML anomaly detector job APIs +-- +-- Defines the request and response shapes for the Elasticsearch X-Pack ML +-- anomaly detector job endpoints (under @\/_ml\/anomaly_detectors/*@). An +-- anomaly detection job consumes a data feed and scores records for +-- abnormality. +-- +-- * @PUT /_ml/anomaly_detectors/{job_id}@ — create ('MlAnomalyJob'). +-- * @GET /_ml/anomaly_detectors[/{job_id}]@ — 'MlAnomalyJobsResponse'. +-- * @POST /_ml/anomaly_detectors/{job_id}/_update@ — update ('MlAnomalyJobUpdate'). +-- * @DELETE /_ml/anomaly_detectors/{job_id}@ — returns 'Acknowledged'. +-- * @POST /_ml/anomaly_detectors/{job_id}/_open@ — returns 'Acknowledged'. +-- * @POST /_ml/anomaly_detectors/{job_id}/_close@ — returns 'Acknowledged'. +-- * @POST /_ml/anomaly_detectors/{job_id}/_forecast@ — 'MlForecastResponse'. +-- * @POST /_ml/anomaly_detectors/{job_id}/_flush@ — 'MlFlushResponse'. +-- * @POST /_ml/anomaly_detectors/{job_id}/_validate@ — 'MlValidateResponse'. +-- * @GET /_ml/anomaly_detectors/{job_id}/_stats@ — 'MlAnomalyJobStatsResponse'. +-- * @GET /_ml/anomaly_detectors/{job_id}/_results/{buckets,records,categories,influencers,overall_buckets}@ — 'MlAnomalyJobResults'. +-- * @GET /_ml/anomaly_detectors/{job_id}/_model_snapshots[/{snapshot_id}]@ — 'MlModelSnapshotsResponse'. +-- * @PUT /_ml/anomaly_detectors/{job_id}/_model_snapshots/{snapshot_id}@ — 'Acknowledged'. +-- * @DELETE /_ml/anomaly_detectors/{job_id}/_model_snapshots/{snapshot_id}@ — 'Acknowledged'. +-- * @POST /_ml/anomaly_detectors/{job_id}/_model_snapshots/{snapshot_id}/_revert@ — 'MlRevertSnapshotResponse'. +-- +-- The analysis configuration (@analysis_config@, @data_description@, +-- @analysis_limits@, @model_plot_config@, @custom_settings@) and the +-- read-only results bodies are large and fast-moving; they are carried as +-- opaque 'Value's. Only the stable envelope and the response arrays are +-- typed, with unknown sibling fields preserved in the @*Extras@ +-- 'KeyMap' catch-alls. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlAnomalyJobs + ( -- * Identity + MlJobId (..), + unMlJobId, + MlModelSnapshotId (..), + unMlModelSnapshotId, + + -- * Enums + MlJobState (..), + mlJobStateText, + MlAnomalyResultType (..), + mlAnomalyResultTypeSegment, + + -- * Request bodies + MlAnomalyJob (..), + defaultMlAnomalyJob, + mlAnomalyJobAnalysisConfigLens, + mlAnomalyJobDataDescriptionLens, + mlAnomalyJobAnalysisLimitsLens, + mlAnomalyJobBackgroundPersistenceLens, + mlAnomalyJobDescriptionLens, + mlAnomalyJobGroupsLens, + mlAnomalyJobModelPlotConfigLens, + mlAnomalyJobResultsIndexNameLens, + mlAnomalyJobCustomSettingsLens, + MlAnomalyJobUpdate (..), + defaultMlAnomalyJobUpdate, + mlAnomalyJobUpdateDescriptionLens, + mlAnomalyJobUpdateAnalysisLimitsLens, + mlAnomalyJobUpdateAnalysisConfigLens, + mlAnomalyJobUpdateGroupsLens, + mlAnomalyJobUpdateModelPlotConfigLens, + mlAnomalyJobUpdateCustomSettingsLens, + MlForecastOptions (..), + defaultMlForecastOptions, + MlFlushOptions (..), + defaultMlFlushOptions, + + -- * Query options + MlAnomalyJobOptions (..), + defaultMlAnomalyJobOptions, + mlAnomalyJobOptionsParams, + + -- * Responses + MlAnomalyJobDocument (..), + mlAnomalyJobDocumentIdLens, + mlAnomalyJobDocumentStateLens, + mlAnomalyJobDocumentJobTypeLens, + mlAnomalyJobDocumentCreateTimeLens, + mlAnomalyJobDocumentExtrasLens, + MlAnomalyJobsResponse (..), + mlAnomalyJobsResponseCountLens, + mlAnomalyJobsResponseJobsLens, + MlAnomalyJobStats (..), + mlAnomalyJobStatsJobIdLens, + mlAnomalyJobStatsStateLens, + mlAnomalyJobStatsExtrasLens, + MlAnomalyJobStatsResponse (..), + mlAnomalyJobStatsResponseCountLens, + mlAnomalyJobStatsResponseStatsLens, + MlForecastResponse (..), + mlForecastResponseAcknowledgedLens, + mlForecastResponseForecastIdLens, + MlFlushResponse (..), + mlFlushResponseAcknowledgedLens, + mlFlushResponseLastFinalizedBucketEndLens, + MlValidateResponse (..), + mlValidateResponseBodyLens, + MlAnomalyJobResults (..), + mlAnomalyJobResultsCountLens, + mlAnomalyJobResultsBodyLens, + MlModelSnapshotDocument (..), + mlModelSnapshotDocumentIdLens, + mlModelSnapshotDocumentExtrasLens, + MlModelSnapshotsResponse (..), + mlModelSnapshotsResponseCountLens, + mlModelSnapshotsResponseSnapshotsLens, + MlRevertSnapshotResponse (..), + mlRevertSnapshotResponseModelLens, + mlRevertSnapshotResponseModelSnapshotIdLens, + mlRevertSnapshotResponseExtrasLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.String (IsString) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- | The @@ path segment of +-- @\/_ml\/anomaly_detectors\/@. Forwarded verbatim. +newtype MlJobId = MlJobId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unMlJobId :: MlJobId -> Text +unMlJobId (MlJobId x) = x + +-- | The @@ path segment of the model-snapshot endpoints. +newtype MlModelSnapshotId = MlModelSnapshotId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unMlModelSnapshotId :: MlModelSnapshotId -> Text +unMlModelSnapshotId (MlModelSnapshotId x) = x + +-- | The @state@ of an anomaly job. Documented values: @opening@, @open@, +-- @closing@, @closed@, @deleting@, @deleted@, @failed@; the custom branch +-- absorbs anything newer. +data MlJobState + = MlJobStateOpening + | MlJobStateOpened + | MlJobStateClosing + | MlJobStateClosed + | MlJobStateDeleting + | MlJobStateDeleted + | MlJobStateFailed + | MlJobStateCustom Text + deriving stock (Eq, Show) + +mlJobStateText :: MlJobState -> Text +mlJobStateText = \case + MlJobStateOpening -> "opening" + MlJobStateOpened -> "open" + MlJobStateClosing -> "closing" + MlJobStateClosed -> "closed" + MlJobStateDeleting -> "deleting" + MlJobStateDeleted -> "deleted" + MlJobStateFailed -> "failed" + MlJobStateCustom t -> t + +instance ToJSON MlJobState where + toJSON = toJSON . mlJobStateText + +instance FromJSON MlJobState where + parseJSON = withText "MlJobState" $ \t -> + pure $ case t of + "opening" -> MlJobStateOpening + "open" -> MlJobStateOpened + "closing" -> MlJobStateClosing + "closed" -> MlJobStateClosed + "deleting" -> MlJobStateDeleting + "deleted" -> MlJobStateDeleted + "failed" -> MlJobStateFailed + other -> MlJobStateCustom other + +-- | Selects the results sub-resource of +-- @\/_ml\/anomaly_detectors\/{job_id}/_results\/@. Maps to the +-- documented path segment via 'mlAnomalyResultTypeSegment'. +data MlAnomalyResultType + = MlAnomalyResultBuckets + | MlAnomalyResultRecords + | MlAnomalyResultCategories + | MlAnomalyResultInfluencers + | MlAnomalyResultOverallBuckets + deriving stock (Eq, Show) + +-- | The path segment for each 'MlAnomalyResultType'. +mlAnomalyResultTypeSegment :: MlAnomalyResultType -> Text +mlAnomalyResultTypeSegment = \case + MlAnomalyResultBuckets -> "buckets" + MlAnomalyResultRecords -> "records" + MlAnomalyResultCategories -> "categories" + MlAnomalyResultInfluencers -> "influencers" + MlAnomalyResultOverallBuckets -> "overall_buckets" + +-- | The PUT request body for +-- @PUT \/_ml\/anomaly_detectors\/{job_id}@ (ml-put-job). The +-- @analysis_config@ and @data_description@ are required; both are carried +-- as opaque 'Value's because their nested shape (detectors, influencers, +-- categorization, summary_count_field_name, time_field, …) is large and +-- evolves across releases. +data MlAnomalyJob = MlAnomalyJob + { mlajAnalysisConfig :: Value, + mlajDataDescription :: Value, + mlajAnalysisLimits :: Maybe Value, + mlajBackgroundPersistence :: Maybe Bool, + mlajDescription :: Maybe Text, + mlajGroups :: Maybe [Text], + mlajModelPlotConfig :: Maybe Value, + mlajResultsIndexName :: Maybe Text, + mlajCustomSettings :: Maybe Value + } + deriving stock (Eq, Show) + +-- | A job body with empty @analysis_config@ \/ @data_description@ and +-- every optional field 'Nothing'. +defaultMlAnomalyJob :: MlAnomalyJob +defaultMlAnomalyJob = + MlAnomalyJob + { mlajAnalysisConfig = object [], + mlajDataDescription = object [], + mlajAnalysisLimits = Nothing, + mlajBackgroundPersistence = Nothing, + mlajDescription = Nothing, + mlajGroups = Nothing, + mlajModelPlotConfig = Nothing, + mlajResultsIndexName = Nothing, + mlajCustomSettings = Nothing + } + +instance ToJSON MlAnomalyJob where + toJSON MlAnomalyJob {..} = + omitNulls + [ "analysis_config" .= mlajAnalysisConfig, + "data_description" .= mlajDataDescription, + "analysis_limits" .= mlajAnalysisLimits, + "background_persistence" .= mlajBackgroundPersistence, + "description" .= mlajDescription, + "groups" .= mlajGroups, + "model_plot_config" .= mlajModelPlotConfig, + "results_index_name" .= mlajResultsIndexName, + "custom_settings" .= mlajCustomSettings + ] + +instance FromJSON MlAnomalyJob where + parseJSON = withObject "MlAnomalyJob" $ \o -> do + analysisConfig <- o .:? "analysis_config" + dataDescription <- o .:? "data_description" + let mlajAnalysisConfig = maybe (object []) id analysisConfig + mlajDataDescription = maybe (object []) id dataDescription + mlajAnalysisLimits <- o .:? "analysis_limits" + mlajBackgroundPersistence <- o .:? "background_persistence" + mlajDescription <- o .:? "description" + mlajGroups <- o .:? "groups" + mlajModelPlotConfig <- o .:? "model_plot_config" + mlajResultsIndexName <- o .:? "results_index_name" + mlajCustomSettings <- o .:? "custom_settings" + pure MlAnomalyJob {..} + +mlAnomalyJobAnalysisConfigLens :: Lens' MlAnomalyJob Value +mlAnomalyJobAnalysisConfigLens = + lens mlajAnalysisConfig (\x y -> x {mlajAnalysisConfig = y}) + +mlAnomalyJobDataDescriptionLens :: Lens' MlAnomalyJob Value +mlAnomalyJobDataDescriptionLens = + lens mlajDataDescription (\x y -> x {mlajDataDescription = y}) + +mlAnomalyJobAnalysisLimitsLens :: Lens' MlAnomalyJob (Maybe Value) +mlAnomalyJobAnalysisLimitsLens = + lens mlajAnalysisLimits (\x y -> x {mlajAnalysisLimits = y}) + +mlAnomalyJobBackgroundPersistenceLens :: Lens' MlAnomalyJob (Maybe Bool) +mlAnomalyJobBackgroundPersistenceLens = + lens mlajBackgroundPersistence (\x y -> x {mlajBackgroundPersistence = y}) + +mlAnomalyJobDescriptionLens :: Lens' MlAnomalyJob (Maybe Text) +mlAnomalyJobDescriptionLens = + lens mlajDescription (\x y -> x {mlajDescription = y}) + +mlAnomalyJobGroupsLens :: Lens' MlAnomalyJob (Maybe [Text]) +mlAnomalyJobGroupsLens = + lens mlajGroups (\x y -> x {mlajGroups = y}) + +mlAnomalyJobModelPlotConfigLens :: Lens' MlAnomalyJob (Maybe Value) +mlAnomalyJobModelPlotConfigLens = + lens mlajModelPlotConfig (\x y -> x {mlajModelPlotConfig = y}) + +mlAnomalyJobResultsIndexNameLens :: Lens' MlAnomalyJob (Maybe Text) +mlAnomalyJobResultsIndexNameLens = + lens mlajResultsIndexName (\x y -> x {mlajResultsIndexName = y}) + +mlAnomalyJobCustomSettingsLens :: Lens' MlAnomalyJob (Maybe Value) +mlAnomalyJobCustomSettingsLens = + lens mlajCustomSettings (\x y -> x {mlajCustomSettings = y}) + +-- | The POST body for +-- @POST \/_ml\/anomaly_detectors\/{job_id}/_update@ (ml-update-job). Every +-- field is optional. +data MlAnomalyJobUpdate = MlAnomalyJobUpdate + { mlajuDescription :: Maybe Text, + mlajuAnalysisLimits :: Maybe Value, + mlajuAnalysisConfig :: Maybe Value, + mlajuGroups :: Maybe [Text], + mlajuModelPlotConfig :: Maybe Value, + mlajuCustomSettings :: Maybe Value + } + deriving stock (Eq, Show) + +-- | An empty update body — encodes to @{}@. +defaultMlAnomalyJobUpdate :: MlAnomalyJobUpdate +defaultMlAnomalyJobUpdate = + MlAnomalyJobUpdate + { mlajuDescription = Nothing, + mlajuAnalysisLimits = Nothing, + mlajuAnalysisConfig = Nothing, + mlajuGroups = Nothing, + mlajuModelPlotConfig = Nothing, + mlajuCustomSettings = Nothing + } + +instance ToJSON MlAnomalyJobUpdate where + toJSON MlAnomalyJobUpdate {..} = + omitNulls + [ "description" .= mlajuDescription, + "analysis_limits" .= mlajuAnalysisLimits, + "analysis_config" .= mlajuAnalysisConfig, + "groups" .= mlajuGroups, + "model_plot_config" .= mlajuModelPlotConfig, + "custom_settings" .= mlajuCustomSettings + ] + +instance FromJSON MlAnomalyJobUpdate where + parseJSON = withObject "MlAnomalyJobUpdate" $ \o -> + MlAnomalyJobUpdate + <$> o .:? "description" + <*> o .:? "analysis_limits" + <*> o .:? "analysis_config" + <*> o .:? "groups" + <*> o .:? "model_plot_config" + <*> o .:? "custom_settings" + +mlAnomalyJobUpdateDescriptionLens :: Lens' MlAnomalyJobUpdate (Maybe Text) +mlAnomalyJobUpdateDescriptionLens = + lens mlajuDescription (\x y -> x {mlajuDescription = y}) + +mlAnomalyJobUpdateAnalysisLimitsLens :: Lens' MlAnomalyJobUpdate (Maybe Value) +mlAnomalyJobUpdateAnalysisLimitsLens = + lens mlajuAnalysisLimits (\x y -> x {mlajuAnalysisLimits = y}) + +mlAnomalyJobUpdateAnalysisConfigLens :: Lens' MlAnomalyJobUpdate (Maybe Value) +mlAnomalyJobUpdateAnalysisConfigLens = + lens mlajuAnalysisConfig (\x y -> x {mlajuAnalysisConfig = y}) + +mlAnomalyJobUpdateGroupsLens :: Lens' MlAnomalyJobUpdate (Maybe [Text]) +mlAnomalyJobUpdateGroupsLens = + lens mlajuGroups (\x y -> x {mlajuGroups = y}) + +mlAnomalyJobUpdateModelPlotConfigLens :: Lens' MlAnomalyJobUpdate (Maybe Value) +mlAnomalyJobUpdateModelPlotConfigLens = + lens mlajuModelPlotConfig (\x y -> x {mlajuModelPlotConfig = y}) + +mlAnomalyJobUpdateCustomSettingsLens :: Lens' MlAnomalyJobUpdate (Maybe Value) +mlAnomalyJobUpdateCustomSettingsLens = + lens mlajuCustomSettings (\x y -> x {mlajuCustomSettings = y}) + +-- | Optional URI query parameters and POST body for the forecast endpoint. +-- Documented fields: @max_active_notifications@, @duration@, @expires_in@. +-- All optional; 'defaultMlForecastOptions' encodes @{}@. +data MlForecastOptions = MlForecastOptions + { mlfoMaxActiveNotifications :: Maybe Int, + mlfoDuration :: Maybe Text, + mlfoExpiresIn :: Maybe Text + } + deriving stock (Eq, Show) + +defaultMlForecastOptions :: MlForecastOptions +defaultMlForecastOptions = + MlForecastOptions + { mlfoMaxActiveNotifications = Nothing, + mlfoDuration = Nothing, + mlfoExpiresIn = Nothing + } + +instance ToJSON MlForecastOptions where + toJSON MlForecastOptions {..} = + omitNulls + [ "max_active_notifications" .= mlfoMaxActiveNotifications, + "duration" .= mlfoDuration, + "expires_in" .= mlfoExpiresIn + ] + +instance FromJSON MlForecastOptions where + parseJSON = withObject "MlForecastOptions" $ \o -> + MlForecastOptions + <$> o .:? "max_active_notifications" + <*> o .:? "duration" + <*> o .:? "expires_in" + +-- | Optional POST body for the flush endpoint. Documented fields: +-- @calc_interim@, @start@, @end@, @advance_time@, @skip_time@. All +-- optional; 'defaultMlFlushOptions' encodes @{}@. +data MlFlushOptions = MlFlushOptions + { mlfloCalcInterim :: Maybe Bool, + mlfloStart :: Maybe Text, + mlfloEnd :: Maybe Text, + mlfloAdvanceTime :: Maybe Text, + mlfloSkipTime :: Maybe Text + } + deriving stock (Eq, Show) + +defaultMlFlushOptions :: MlFlushOptions +defaultMlFlushOptions = + MlFlushOptions + { mlfloCalcInterim = Nothing, + mlfloStart = Nothing, + mlfloEnd = Nothing, + mlfloAdvanceTime = Nothing, + mlfloSkipTime = Nothing + } + +instance ToJSON MlFlushOptions where + toJSON MlFlushOptions {..} = + omitNulls + [ "calc_interim" .= mlfloCalcInterim, + "start" .= mlfloStart, + "end" .= mlfloEnd, + "advance_time" .= mlfloAdvanceTime, + "skip_time" .= mlfloSkipTime + ] + +instance FromJSON MlFlushOptions where + parseJSON = withObject "MlFlushOptions" $ \o -> + MlFlushOptions + <$> o .:? "calc_interim" + <*> o .:? "start" + <*> o .:? "end" + <*> o .:? "advance_time" + <*> o .:? "skip_time" + +-- | Optional URI query parameters shared across the anomaly job endpoints: +-- @from@ \/ @size@ (list pagination), @exclude_generated@ (GET), +-- @advanced_stats@ (stats), @force@ (delete\/close), +-- @timeout@ (open\/close), @delete_intervening_results@ (revert). All +-- optional; 'defaultMlAnomalyJobOptions' renders no query string. +data MlAnomalyJobOptions = MlAnomalyJobOptions + { mlajoFrom :: Maybe Int, + mlajoSize :: Maybe Int, + mlajoExcludeGenerated :: Maybe Bool, + mlajoAdvancedStats :: Maybe Bool, + mlajoForce :: Maybe Bool, + mlajoTimeout :: Maybe Text, + mlajoDeleteInterveningResults :: Maybe Bool + } + deriving stock (Eq, Show) + +defaultMlAnomalyJobOptions :: MlAnomalyJobOptions +defaultMlAnomalyJobOptions = + MlAnomalyJobOptions + { mlajoFrom = Nothing, + mlajoSize = Nothing, + mlajoExcludeGenerated = Nothing, + mlajoAdvancedStats = Nothing, + mlajoForce = Nothing, + mlajoTimeout = Nothing, + mlajoDeleteInterveningResults = Nothing + } + +-- | Render 'MlAnomalyJobOptions' as a list of @(key, value)@ query +-- parameters suitable for 'withQueries'. 'Nothing' fields are omitted. +mlAnomalyJobOptionsParams :: MlAnomalyJobOptions -> [(Text, Maybe Text)] +mlAnomalyJobOptionsParams MlAnomalyJobOptions {..} = + catMaybes + [ (("from",) . Just . intText) <$> mlajoFrom, + (("size",) . Just . intText) <$> mlajoSize, + (("exclude_generated",) . Just . boolText) <$> mlajoExcludeGenerated, + (("advanced_stats",) . Just . boolText) <$> mlajoAdvancedStats, + (("force",) . Just . boolText) <$> mlajoForce, + (("timeout",) . Just) <$> mlajoTimeout, + (("delete_intervening_results",) . Just . boolText) <$> mlajoDeleteInterveningResults + ] + where + boolText b = if b then "true" else "false" + intText = T.pack . show + +-- | The stored configuration of a single anomaly job, as returned by +-- @GET \/_ml\/anomaly_detectors[\/{job_id}]@ (the @jobs@ array entry). The +-- envelope is typed; everything else (@analysis_config@, +-- @data_description@, @create_time@, @model_snapshot_id@, ...) is folded +-- into 'mlajdExtras'. +data MlAnomalyJobDocument = MlAnomalyJobDocument + { mlajdId :: Maybe Text, + mlajdState :: Maybe MlJobState, + mlajdJobType :: Maybe Text, + mlajdCreateTime :: Maybe Scientific, + mlajdExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +knownJobDocumentKeys :: [Key] +knownJobDocumentKeys = ["job_id", "state", "job_type", "create_time"] + +instance ToJSON MlAnomalyJobDocument where + toJSON MlAnomalyJobDocument {..} = + omitNulls $ + [ "job_id" .= mlajdId, + "state" .= mlajdState, + "job_type" .= mlajdJobType, + "create_time" .= mlajdCreateTime + ] + ++ maybe [] KeyMap.toList mlajdExtras + +instance FromJSON MlAnomalyJobDocument where + parseJSON = withObject "MlAnomalyJobDocument" $ \o -> do + mlajdId <- o .:? "job_id" + mlajdState <- o .:? "state" + mlajdJobType <- o .:? "job_type" + mlajdCreateTime <- o .:? "create_time" + let extras = deleteSeveral knownJobDocumentKeys o + mlajdExtras = if null extras then Nothing else Just extras + pure MlAnomalyJobDocument {..} + +mlAnomalyJobDocumentIdLens :: Lens' MlAnomalyJobDocument (Maybe Text) +mlAnomalyJobDocumentIdLens = + lens mlajdId (\x y -> x {mlajdId = y}) + +mlAnomalyJobDocumentStateLens :: Lens' MlAnomalyJobDocument (Maybe MlJobState) +mlAnomalyJobDocumentStateLens = + lens mlajdState (\x y -> x {mlajdState = y}) + +mlAnomalyJobDocumentJobTypeLens :: Lens' MlAnomalyJobDocument (Maybe Text) +mlAnomalyJobDocumentJobTypeLens = + lens mlajdJobType (\x y -> x {mlajdJobType = y}) + +mlAnomalyJobDocumentCreateTimeLens :: Lens' MlAnomalyJobDocument (Maybe Scientific) +mlAnomalyJobDocumentCreateTimeLens = + lens mlajdCreateTime (\x y -> x {mlajdCreateTime = y}) + +mlAnomalyJobDocumentExtrasLens :: Lens' MlAnomalyJobDocument (Maybe (KeyMap.KeyMap Value)) +mlAnomalyJobDocumentExtrasLens = + lens mlajdExtras (\x y -> x {mlajdExtras = y}) + +-- | Response body of @GET \/_ml\/anomaly_detectors[\/{job_id}]@. The +-- @count@ defaults to the length of @jobs@ when the server omits it; the +-- array defaults to @[]@. +data MlAnomalyJobsResponse = MlAnomalyJobsResponse + { mlajsrCount :: Maybe Int, + mlajsrJobs :: [MlAnomalyJobDocument] + } + deriving stock (Eq, Show) + +instance ToJSON MlAnomalyJobsResponse where + toJSON MlAnomalyJobsResponse {..} = + omitNulls + [ "count" .= mlajsrCount, + "jobs" .= mlajsrJobs + ] + +instance FromJSON MlAnomalyJobsResponse where + parseJSON = withObject "MlAnomalyJobsResponse" $ \o -> do + mlajsrJobs <- o .:? "jobs" .!= [] + mCount <- o .:? "count" + let mlajsrCount = mCount <|> Just (length mlajsrJobs) + pure MlAnomalyJobsResponse {..} + +mlAnomalyJobsResponseCountLens :: Lens' MlAnomalyJobsResponse (Maybe Int) +mlAnomalyJobsResponseCountLens = + lens mlajsrCount (\x y -> x {mlajsrCount = y}) + +mlAnomalyJobsResponseJobsLens :: Lens' MlAnomalyJobsResponse [MlAnomalyJobDocument] +mlAnomalyJobsResponseJobsLens = + lens mlajsrJobs (\x y -> x {mlajsrJobs = y}) + +-- | The per-job entry in the @jobs@ array of a stats response. Only +-- @job_id@ and @state@ are typed; the large, volatile statistics +-- (@data_counts@, @model_size_stats@, @forecasts_stats@, @node@, ...) are +-- folded into 'mlajssExtras'. +data MlAnomalyJobStats = MlAnomalyJobStats + { mlajssJobId :: Maybe Text, + mlajssState :: Maybe MlJobState, + mlajssExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +knownJobStatsKeys :: [Key] +knownJobStatsKeys = ["job_id", "state"] + +instance ToJSON MlAnomalyJobStats where + toJSON MlAnomalyJobStats {..} = + omitNulls $ + [ "job_id" .= mlajssJobId, + "state" .= mlajssState + ] + ++ maybe [] KeyMap.toList mlajssExtras + +instance FromJSON MlAnomalyJobStats where + parseJSON = withObject "MlAnomalyJobStats" $ \o -> do + mlajssJobId <- o .:? "job_id" + mlajssState <- o .:? "state" + let extras = deleteSeveral knownJobStatsKeys o + mlajssExtras = if null extras then Nothing else Just extras + pure MlAnomalyJobStats {..} + +mlAnomalyJobStatsJobIdLens :: Lens' MlAnomalyJobStats (Maybe Text) +mlAnomalyJobStatsJobIdLens = + lens mlajssJobId (\x y -> x {mlajssJobId = y}) + +mlAnomalyJobStatsStateLens :: Lens' MlAnomalyJobStats (Maybe MlJobState) +mlAnomalyJobStatsStateLens = + lens mlajssState (\x y -> x {mlajssState = y}) + +mlAnomalyJobStatsExtrasLens :: Lens' MlAnomalyJobStats (Maybe (KeyMap.KeyMap Value)) +mlAnomalyJobStatsExtrasLens = + lens mlajssExtras (\x y -> x {mlajssExtras = y}) + +-- | Response body of @GET \/_ml\/anomaly_detectors\/{job_id}/_stats@. The +-- @count@ defaults to the length of @jobs@ when absent. +data MlAnomalyJobStatsResponse = MlAnomalyJobStatsResponse + { mlajsrrCount :: Maybe Int, + mlajsrrStats :: [MlAnomalyJobStats] + } + deriving stock (Eq, Show) + +instance ToJSON MlAnomalyJobStatsResponse where + toJSON MlAnomalyJobStatsResponse {..} = + omitNulls + [ "count" .= mlajsrrCount, + "jobs" .= mlajsrrStats + ] + +instance FromJSON MlAnomalyJobStatsResponse where + parseJSON = withObject "MlAnomalyJobStatsResponse" $ \o -> do + mlajsrrStats <- o .:? "jobs" .!= [] + mCount <- o .:? "count" + let mlajsrrCount = mCount <|> Just (length mlajsrrStats) + pure MlAnomalyJobStatsResponse {..} + +mlAnomalyJobStatsResponseCountLens :: Lens' MlAnomalyJobStatsResponse (Maybe Int) +mlAnomalyJobStatsResponseCountLens = + lens mlajsrrCount (\x y -> x {mlajsrrCount = y}) + +mlAnomalyJobStatsResponseStatsLens :: Lens' MlAnomalyJobStatsResponse [MlAnomalyJobStats] +mlAnomalyJobStatsResponseStatsLens = + lens mlajsrrStats (\x y -> x {mlajsrrStats = y}) + +-- | Response body of @POST \/_ml\/anomaly_detectors\/{job_id}/_forecast@. +-- @acknowledged@ defaults to @True@ when the server omits it. +data MlForecastResponse = MlForecastResponse + { mlfrAcknowledged :: Maybe Bool, + mlfrForecastId :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON MlForecastResponse where + toJSON MlForecastResponse {..} = + omitNulls + [ "acknowledged" .= mlfrAcknowledged, + "forecast_id" .= mlfrForecastId + ] + +instance FromJSON MlForecastResponse where + parseJSON = withObject "MlForecastResponse" $ \o -> do + mAck <- o .:? "acknowledged" + let mlfrAcknowledged = mAck <|> Just True + mlfrForecastId <- o .:? "forecast_id" + pure MlForecastResponse {..} + +mlForecastResponseAcknowledgedLens :: Lens' MlForecastResponse (Maybe Bool) +mlForecastResponseAcknowledgedLens = + lens mlfrAcknowledged (\x y -> x {mlfrAcknowledged = y}) + +mlForecastResponseForecastIdLens :: Lens' MlForecastResponse (Maybe Text) +mlForecastResponseForecastIdLens = + lens mlfrForecastId (\x y -> x {mlfrForecastId = y}) + +-- | Response body of @POST \/_ml\/anomaly_detectors\/{job_id}/_flush@. +-- Both fields are optional. +data MlFlushResponse = MlFlushResponse + { mlflrAcknowledged :: Maybe Bool, + mlflrLastFinalizedBucketEnd :: Maybe Scientific + } + deriving stock (Eq, Show) + +instance ToJSON MlFlushResponse where + toJSON MlFlushResponse {..} = + omitNulls + [ "acknowledged" .= mlflrAcknowledged, + "last_finalized_bucket_end" .= mlflrLastFinalizedBucketEnd + ] + +instance FromJSON MlFlushResponse where + parseJSON = withObject "MlFlushResponse" $ \o -> + MlFlushResponse + <$> o .:? "acknowledged" + <*> o .:? "last_finalized_bucket_end" + +mlFlushResponseAcknowledgedLens :: Lens' MlFlushResponse (Maybe Bool) +mlFlushResponseAcknowledgedLens = + lens mlflrAcknowledged (\x y -> x {mlflrAcknowledged = y}) + +mlFlushResponseLastFinalizedBucketEndLens :: Lens' MlFlushResponse (Maybe Scientific) +mlFlushResponseLastFinalizedBucketEndLens = + lens mlflrLastFinalizedBucketEnd (\x y -> x {mlflrLastFinalizedBucketEnd = y}) + +-- | Response body of @POST \/_ml\/anomaly_detectors\/{job_id}/_validate@, +-- carried verbatim as an opaque 'Value' (the validation report shape +-- varies by analyzer kind). +data MlValidateResponse = MlValidateResponse + { mlvrBody :: Value + } + deriving stock (Eq, Show) + +instance ToJSON MlValidateResponse where + toJSON MlValidateResponse {..} = mlvrBody + +instance FromJSON MlValidateResponse where + parseJSON v = pure $ MlValidateResponse v + +mlValidateResponseBodyLens :: Lens' MlValidateResponse Value +mlValidateResponseBodyLens = + lens mlvrBody (\x y -> x {mlvrBody = y}) + +-- | Response body of the read-only results endpoints +-- (@\/_ml\/anomaly_detectors\/{job_id}/_results\/*@). The @count@ is typed +-- when present; the whole results array (buckets, records, categories or +-- influencers) is carried verbatim as an opaque 'Value'. +data MlAnomalyJobResults = MlAnomalyJobResults + { mlrCount :: Maybe Int, + mlrBody :: Value + } + deriving stock (Eq, Show) + +instance ToJSON MlAnomalyJobResults where + toJSON MlAnomalyJobResults {..} = + case mlrBody of + Object o -> + Object (maybe o (\n -> KeyMap.insert "count" (toJSON n) o) mlrCount) + other -> other + +instance FromJSON MlAnomalyJobResults where + parseJSON = withObject "MlAnomalyJobResults" $ \o -> do + mlrCount <- o .:? "count" + pure MlAnomalyJobResults {mlrBody = Object o, mlrCount = mlrCount} + +mlAnomalyJobResultsCountLens :: Lens' MlAnomalyJobResults (Maybe Int) +mlAnomalyJobResultsCountLens = + lens mlrCount (\x y -> x {mlrCount = y}) + +mlAnomalyJobResultsBodyLens :: Lens' MlAnomalyJobResults Value +mlAnomalyJobResultsBodyLens = + lens mlrBody (\x y -> x {mlrBody = y}) + +-- | The stored configuration of a single model snapshot, as returned by +-- @GET \/_ml\/anomaly_detectors\/{job_id}/_model_snapshots[/{snapshot_id}]@. +-- Only @id@ is typed; everything else is folded into 'mlmsdExtras'. +data MlModelSnapshotDocument = MlModelSnapshotDocument + { mlmsdId :: Maybe Text, + mlmsdExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +knownSnapshotKeys :: [Key] +knownSnapshotKeys = ["id"] + +instance ToJSON MlModelSnapshotDocument where + toJSON MlModelSnapshotDocument {..} = + omitNulls $ + [ "id" .= mlmsdId + ] + ++ maybe [] KeyMap.toList mlmsdExtras + +instance FromJSON MlModelSnapshotDocument where + parseJSON = withObject "MlModelSnapshotDocument" $ \o -> do + mlmsdId <- o .:? "id" + let extras = deleteSeveral knownSnapshotKeys o + mlmsdExtras = if null extras then Nothing else Just extras + pure MlModelSnapshotDocument {..} + +mlModelSnapshotDocumentIdLens :: Lens' MlModelSnapshotDocument (Maybe Text) +mlModelSnapshotDocumentIdLens = + lens mlmsdId (\x y -> x {mlmsdId = y}) + +mlModelSnapshotDocumentExtrasLens :: Lens' MlModelSnapshotDocument (Maybe (KeyMap.KeyMap Value)) +mlModelSnapshotDocumentExtrasLens = + lens mlmsdExtras (\x y -> x {mlmsdExtras = y}) + +-- | Response body of +-- @GET \/_ml\/anomaly_detectors\/{job_id}/_model_snapshots[/{snapshot_id}]@. +-- The @count@ defaults to the length of @model_snapshots@ when absent. +data MlModelSnapshotsResponse = MlModelSnapshotsResponse + { mlmsrCount :: Maybe Int, + mlmsrSnapshots :: [MlModelSnapshotDocument] + } + deriving stock (Eq, Show) + +instance ToJSON MlModelSnapshotsResponse where + toJSON MlModelSnapshotsResponse {..} = + omitNulls + [ "count" .= mlmsrCount, + "model_snapshots" .= mlmsrSnapshots + ] + +instance FromJSON MlModelSnapshotsResponse where + parseJSON = withObject "MlModelSnapshotsResponse" $ \o -> do + mlmsrSnapshots <- o .:? "model_snapshots" .!= [] + mCount <- o .:? "count" + let mlmsrCount = mCount <|> Just (length mlmsrSnapshots) + pure MlModelSnapshotsResponse {..} + +mlModelSnapshotsResponseCountLens :: Lens' MlModelSnapshotsResponse (Maybe Int) +mlModelSnapshotsResponseCountLens = + lens mlmsrCount (\x y -> x {mlmsrCount = y}) + +mlModelSnapshotsResponseSnapshotsLens :: Lens' MlModelSnapshotsResponse [MlModelSnapshotDocument] +mlModelSnapshotsResponseSnapshotsLens = + lens mlmsrSnapshots (\x y -> x {mlmsrSnapshots = y}) + +-- | Response body of +-- @POST \/_ml\/anomaly_detectors\/{job_id}/_model_snapshots/{snapshot_id}/_revert@. +-- @model@ and @model_snapshot_id@ are typed when present; the rest of the +-- report (e.g. @records_deleted@) is folded into 'mlrsrExtras'. +data MlRevertSnapshotResponse = MlRevertSnapshotResponse + { mlrsrModel :: Maybe Value, + mlrsrModelSnapshotId :: Maybe Text, + mlrsrExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +knownRevertKeys :: [Key] +knownRevertKeys = ["model", "model_snapshot_id"] + +instance ToJSON MlRevertSnapshotResponse where + toJSON MlRevertSnapshotResponse {..} = + omitNulls $ + [ "model" .= mlrsrModel, + "model_snapshot_id" .= mlrsrModelSnapshotId + ] + ++ maybe [] KeyMap.toList mlrsrExtras + +instance FromJSON MlRevertSnapshotResponse where + parseJSON = withObject "MlRevertSnapshotResponse" $ \o -> do + mlrsrModel <- o .:? "model" + mlrsrModelSnapshotId <- o .:? "model_snapshot_id" + let extras = deleteSeveral knownRevertKeys o + mlrsrExtras = if null extras then Nothing else Just extras + pure MlRevertSnapshotResponse {..} + +mlRevertSnapshotResponseModelLens :: Lens' MlRevertSnapshotResponse (Maybe Value) +mlRevertSnapshotResponseModelLens = + lens mlrsrModel (\x y -> x {mlrsrModel = y}) + +mlRevertSnapshotResponseModelSnapshotIdLens :: Lens' MlRevertSnapshotResponse (Maybe Text) +mlRevertSnapshotResponseModelSnapshotIdLens = + lens mlrsrModelSnapshotId (\x y -> x {mlrsrModelSnapshotId = y}) + +mlRevertSnapshotResponseExtrasLens :: Lens' MlRevertSnapshotResponse (Maybe (KeyMap.KeyMap Value)) +mlRevertSnapshotResponseExtrasLens = + lens mlrsrExtras (\x y -> x {mlrsrExtras = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlDataFrameAnalytics.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlDataFrameAnalytics.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlDataFrameAnalytics.hs @@ -0,0 +1,830 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlDataFrameAnalytics +-- Description : Types for the Elasticsearch ML data frame analytics APIs +-- +-- Defines the request and response shapes for the Elasticsearch X-Pack ML +-- data frame analytics endpoints (under @\/_ml\/data_frame\/analytics/*@), +-- which run supervised (classification, regression) and unsupervised +-- (outlier detection) analysis on a data frame (index) and persist the +-- results to a destination index. +-- +-- * @PUT /_ml/data_frame/analytics/{id}@ — create ('MlDataFrameAnalyticsPutBody'). +-- * @GET /_ml/data_frame/analytics[/{id}]@ — 'MlDataFrameAnalyticsGetResponse' (list or one). +-- * @POST /_ml/data_frame/analytics/{id}/_update@ — update ('MlDataFrameAnalyticsUpdateBody'). +-- * @DELETE /_ml/data_frame/analytics/{id}@ — returns 'Acknowledged'. +-- * @POST /_ml/data_frame/analytics/{id}/_start@ — returns 'Acknowledged'. +-- * @POST /_ml/data_frame/analytics/{id}/_stop@ — returns 'Acknowledged'. +-- * @GET /_ml/data_frame/analytics/{id}/_stats@ — 'MlDataFrameAnalyticsStatsResponse'. +-- * @POST /_ml/data_frame/analytics/_preview@ — 'MlDataFrameAnalyticsPreviewResponse'. +-- +-- The large, fast-moving analysis configuration objects +-- (@classification@, @regression@, @outlier_detection@, @dependent_variable@, +-- training percent, randomize_seed, etc.) are carried as an opaque +-- 'Value' via 'MlDataFrameAnalyticsAnalysis'; only the stable envelope +-- (source\/dest\/analyzed_fields\/model_memory_limit\/description) is typed. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlDataFrameAnalytics + ( -- * Identity + MlDataFrameAnalyticsId (..), + unMlDataFrameAnalyticsId, + + -- * Enums + MlDataFrameAnalysisType (..), + mlDataFrameAnalysisTypeText, + MlDataFrameAnalyticsState (..), + mlDataFrameAnalyticsStateText, + + -- * Shared sub-objects + MlDataFrameAnalyticsSource (..), + defaultMlDataFrameAnalyticsSource, + mlDataFrameAnalyticsSourceIndexLens, + mlDataFrameAnalyticsSourceQueryLens, + mlDataFrameAnalyticsSourceSourceLens, + MlDataFrameAnalyticsDest (..), + defaultMlDataFrameAnalyticsDest, + mlDataFrameAnalyticsDestIndexLens, + mlDataFrameAnalyticsDestResultsFieldLens, + MlDataFrameAnalyticsAnalyzedFields (..), + mlDataFrameAnalyticsAnalyzedFieldsIncludesLens, + mlDataFrameAnalyticsAnalyzedFieldsExcludesLens, + MlDataFrameAnalyticsAnalysis (..), + mlDataFrameAnalyticsAnalysisConfigLens, + + -- * Request bodies + MlDataFrameAnalyticsPutBody (..), + defaultMlDataFrameAnalyticsPutBody, + mlDataFrameAnalyticsPutBodySourceLens, + mlDataFrameAnalyticsPutBodyDestLens, + mlDataFrameAnalyticsPutBodyAnalysisLens, + mlDataFrameAnalyticsPutBodyAnalyzedFieldsLens, + mlDataFrameAnalyticsPutBodyDescriptionLens, + mlDataFrameAnalyticsPutBodyModelMemoryLimitLens, + mlDataFrameAnalyticsPutBodyAllowLazyStartLens, + mlDataFrameAnalyticsPutBodyFrequencyLens, + MlDataFrameAnalyticsUpdateBody (..), + defaultMlDataFrameAnalyticsUpdateBody, + mlDataFrameAnalyticsUpdateBodyDescriptionLens, + mlDataFrameAnalyticsUpdateBodyModelMemoryLimitLens, + mlDataFrameAnalyticsUpdateBodyAnalysisLens, + mlDataFrameAnalyticsUpdateBodySourceLens, + mlDataFrameAnalyticsUpdateBodyDestLens, + mlDataFrameAnalyticsUpdateBodyAnalyzedFieldsLens, + MlDataFrameAnalyticsPreviewRequest (..), + mlDataFrameAnalyticsPreviewRequestConfigLens, + + -- * Query options + MlDataFrameAnalyticsOptions (..), + defaultMlDataFrameAnalyticsOptions, + mlDataFrameAnalyticsOptionsParams, + mlDataFrameAnalyticsOptionsForceLens, + mlDataFrameAnalyticsOptionsFromLens, + mlDataFrameAnalyticsOptionsSizeLens, + mlDataFrameAnalyticsOptionsAllowLazyStartLens, + mlDataFrameAnalyticsOptionsVerboseLens, + mlDataFrameAnalyticsOptionsTimeoutLens, + + -- * Responses + MlDataFrameAnalyticsDocument (..), + mlDataFrameAnalyticsDocumentIdLens, + mlDataFrameAnalyticsDocumentStateLens, + mlDataFrameAnalyticsDocumentAnalysisTypeLens, + mlDataFrameAnalyticsDocumentCreateTimeLens, + mlDataFrameAnalyticsDocumentVersionLens, + mlDataFrameAnalyticsDocumentSourceLens, + mlDataFrameAnalyticsDocumentDestLens, + mlDataFrameAnalyticsDocumentAnalysisLens, + mlDataFrameAnalyticsDocumentExtrasLens, + MlDataFrameAnalyticsGetResponse (..), + mlDataFrameAnalyticsGetResponseCountLens, + mlDataFrameAnalyticsGetResponseAnalyticsLens, + MlDataFrameAnalyticsStats (..), + mlDataFrameAnalyticsStatsIdLens, + mlDataFrameAnalyticsStatsStateLens, + mlDataFrameAnalyticsStatsAnalysisTypeLens, + mlDataFrameAnalyticsStatsExtrasLens, + MlDataFrameAnalyticsStatsResponse (..), + mlDataFrameAnalyticsStatsResponseCountLens, + mlDataFrameAnalyticsStatsResponseStatsLens, + MlDataFrameAnalyticsPreviewRow (..), + MlDataFrameAnalyticsPreviewResponse (..), + mlDataFrameAnalyticsPreviewResponseRowsLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.String (IsString) +import Data.Text qualified as T +import Data.Vector qualified as V +import Database.Bloodhound.Internal.Utils.Imports + +-- | The @@ path segment of +-- @\/_ml\/data_frame\/analytics\/@. Accepts a single id, a +-- comma-separated list, or a wildcard @"*"@; the value is forwarded +-- verbatim as the final URL component. +newtype MlDataFrameAnalyticsId = MlDataFrameAnalyticsId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unMlDataFrameAnalyticsId :: MlDataFrameAnalyticsId -> Text +unMlDataFrameAnalyticsId (MlDataFrameAnalyticsId x) = x + +-- | The @analysis_type@ discriminator reported by the server. The +-- documented values are @classification@, @regression@ and +-- @outlier_detection@; 'MlDataFrameAnalysisTypeCustom' is the +-- forward-compat escape hatch for anything newer. +data MlDataFrameAnalysisType + = MlDataFrameAnalysisTypeClassification + | MlDataFrameAnalysisTypeRegression + | MlDataFrameAnalysisTypeOutlierDetection + | MlDataFrameAnalysisTypeCustom Text + deriving stock (Eq, Show) + +mlDataFrameAnalysisTypeText :: MlDataFrameAnalysisType -> Text +mlDataFrameAnalysisTypeText = \case + MlDataFrameAnalysisTypeClassification -> "classification" + MlDataFrameAnalysisTypeRegression -> "regression" + MlDataFrameAnalysisTypeOutlierDetection -> "outlier_detection" + MlDataFrameAnalysisTypeCustom t -> t + +instance ToJSON MlDataFrameAnalysisType where + toJSON = toJSON . mlDataFrameAnalysisTypeText + +instance FromJSON MlDataFrameAnalysisType where + parseJSON = withText "MlDataFrameAnalysisType" $ \t -> + pure $ case t of + "classification" -> MlDataFrameAnalysisTypeClassification + "regression" -> MlDataFrameAnalysisTypeRegression + "outlier_detection" -> MlDataFrameAnalysisTypeOutlierDetection + other -> MlDataFrameAnalysisTypeCustom other + +-- | The @state@ of an analytics job. Documented values: @stopped@, +-- @starting@, @started@, @stopping@, @reverting@, @failed@; the custom +-- branch absorbs anything the server adds later. +data MlDataFrameAnalyticsState + = MlDataFrameAnalyticsStateStopped + | MlDataFrameAnalyticsStateStarting + | MlDataFrameAnalyticsStateStarted + | MlDataFrameAnalyticsStateStopping + | MlDataFrameAnalyticsStateReverting + | MlDataFrameAnalyticsStateFailed + | MlDataFrameAnalyticsStateCustom Text + deriving stock (Eq, Show) + +mlDataFrameAnalyticsStateText :: MlDataFrameAnalyticsState -> Text +mlDataFrameAnalyticsStateText = \case + MlDataFrameAnalyticsStateStopped -> "stopped" + MlDataFrameAnalyticsStateStarting -> "starting" + MlDataFrameAnalyticsStateStarted -> "started" + MlDataFrameAnalyticsStateStopping -> "stopping" + MlDataFrameAnalyticsStateReverting -> "reverting" + MlDataFrameAnalyticsStateFailed -> "failed" + MlDataFrameAnalyticsStateCustom t -> t + +instance ToJSON MlDataFrameAnalyticsState where + toJSON = toJSON . mlDataFrameAnalyticsStateText + +instance FromJSON MlDataFrameAnalyticsState where + parseJSON = withText "MlDataFrameAnalyticsState" $ \t -> + pure $ case t of + "stopped" -> MlDataFrameAnalyticsStateStopped + "starting" -> MlDataFrameAnalyticsStateStarting + "started" -> MlDataFrameAnalyticsStateStarted + "stopping" -> MlDataFrameAnalyticsStateStopping + "reverting" -> MlDataFrameAnalyticsStateReverting + "failed" -> MlDataFrameAnalyticsStateFailed + other -> MlDataFrameAnalyticsStateCustom other + +-- | The @source@ sub-object: which indices to read, an optional query +-- and the list of fields to include from @_source@. The @query@ field is +-- an opaque 'Value' so any analysis query can be round-tripped without +-- modelling the full search DSL here. +data MlDataFrameAnalyticsSource = MlDataFrameAnalyticsSource + { mldasIndex :: [Text], + mldasQuery :: Maybe Value, + mldasSource :: Maybe [Text] + } + deriving stock (Eq, Show) + +-- | A 'MlDataFrameAnalyticsSource' with @index = []@ and every optional +-- field 'Nothing'. +defaultMlDataFrameAnalyticsSource :: MlDataFrameAnalyticsSource +defaultMlDataFrameAnalyticsSource = + MlDataFrameAnalyticsSource + { mldasIndex = [], + mldasQuery = Nothing, + mldasSource = Nothing + } + +instance ToJSON MlDataFrameAnalyticsSource where + toJSON MlDataFrameAnalyticsSource {..} = + omitNulls + [ "index" .= mldasIndex, + "query" .= mldasQuery, + "_source" .= mldasSource + ] + +instance FromJSON MlDataFrameAnalyticsSource where + parseJSON = withObject "MlDataFrameAnalyticsSource" $ \o -> + MlDataFrameAnalyticsSource + <$> o .:? "index" .!= [] + <*> o .:? "query" + <*> o .:? "_source" + +mlDataFrameAnalyticsSourceIndexLens :: Lens' MlDataFrameAnalyticsSource [Text] +mlDataFrameAnalyticsSourceIndexLens = + lens mldasIndex (\x y -> x {mldasIndex = y}) + +mlDataFrameAnalyticsSourceQueryLens :: Lens' MlDataFrameAnalyticsSource (Maybe Value) +mlDataFrameAnalyticsSourceQueryLens = + lens mldasQuery (\x y -> x {mldasQuery = y}) + +mlDataFrameAnalyticsSourceSourceLens :: Lens' MlDataFrameAnalyticsSource (Maybe [Text]) +mlDataFrameAnalyticsSourceSourceLens = + lens mldasSource (\x y -> x {mldasSource = y}) + +-- | The @dest@ sub-object: the destination index name and the field +-- under which results are written (defaults to @ml@ server-side). +data MlDataFrameAnalyticsDest = MlDataFrameAnalyticsDest + { mldadIndex :: Maybe Text, + mldadResultsField :: Maybe Text + } + deriving stock (Eq, Show) + +-- | A 'MlDataFrameAnalyticsDest' with both fields 'Nothing' — the server +-- fills sensible defaults. +defaultMlDataFrameAnalyticsDest :: MlDataFrameAnalyticsDest +defaultMlDataFrameAnalyticsDest = + MlDataFrameAnalyticsDest + { mldadIndex = Nothing, + mldadResultsField = Nothing + } + +instance ToJSON MlDataFrameAnalyticsDest where + toJSON MlDataFrameAnalyticsDest {..} = + omitNulls + [ "index" .= mldadIndex, + "results_field" .= mldadResultsField + ] + +instance FromJSON MlDataFrameAnalyticsDest where + parseJSON = withObject "MlDataFrameAnalyticsDest" $ \o -> + MlDataFrameAnalyticsDest + <$> o .:? "index" + <*> o .:? "results_field" + +mlDataFrameAnalyticsDestIndexLens :: Lens' MlDataFrameAnalyticsDest (Maybe Text) +mlDataFrameAnalyticsDestIndexLens = + lens mldadIndex (\x y -> x {mldadIndex = y}) + +mlDataFrameAnalyticsDestResultsFieldLens :: Lens' MlDataFrameAnalyticsDest (Maybe Text) +mlDataFrameAnalyticsDestResultsFieldLens = + lens mldadResultsField (\x y -> x {mldadResultsField = y}) + +-- | The @analyzed_fields@ selector: explicit includes\/excludes. Both +-- default to @[]@ when the server omits them. +data MlDataFrameAnalyticsAnalyzedFields = MlDataFrameAnalyticsAnalyzedFields + { mldaaIncludes :: [Text], + mldaaExcludes :: [Text] + } + deriving stock (Eq, Show) + +instance ToJSON MlDataFrameAnalyticsAnalyzedFields where + toJSON MlDataFrameAnalyticsAnalyzedFields {..} = + omitNulls + [ "includes" .= mldaaIncludes, + "excludes" .= mldaaExcludes + ] + +instance FromJSON MlDataFrameAnalyticsAnalyzedFields where + parseJSON = withObject "MlDataFrameAnalyticsAnalyzedFields" $ \o -> + MlDataFrameAnalyticsAnalyzedFields + <$> o .:? "includes" .!= [] + <*> o .:? "excludes" .!= [] + +mlDataFrameAnalyticsAnalyzedFieldsIncludesLens :: Lens' MlDataFrameAnalyticsAnalyzedFields [Text] +mlDataFrameAnalyticsAnalyzedFieldsIncludesLens = + lens mldaaIncludes (\x y -> x {mldaaIncludes = y}) + +mlDataFrameAnalyticsAnalyzedFieldsExcludesLens :: Lens' MlDataFrameAnalyticsAnalyzedFields [Text] +mlDataFrameAnalyticsAnalyzedFieldsExcludesLens = + lens mldaaExcludes (\x y -> x {mldaaExcludes = y}) + +-- | The @analysis@ sub-object. Exactly one of @classification@, +-- @regression@ or @outlier_detection@ should be present; the whole +-- nested config is carried as an opaque 'Value' because it is large and +-- evolves across releases. +data MlDataFrameAnalyticsAnalysis = MlDataFrameAnalyticsAnalysis + { mldaanConfig :: Value + } + deriving stock (Eq, Show) + +instance ToJSON MlDataFrameAnalyticsAnalysis where + toJSON MlDataFrameAnalyticsAnalysis {..} = mldaanConfig + +instance FromJSON MlDataFrameAnalyticsAnalysis where + parseJSON v = pure $ MlDataFrameAnalyticsAnalysis v + +mlDataFrameAnalyticsAnalysisConfigLens :: Lens' MlDataFrameAnalyticsAnalysis Value +mlDataFrameAnalyticsAnalysisConfigLens = + lens mldaanConfig (\x y -> x {mldaanConfig = y}) + +-- | The PUT request body for +-- @PUT \/_ml\/data_frame\/analytics\/{id}@. Only @source@, @dest@ and +-- @analysis@ are required by the server; the rest are optional and +-- omitted from the wire when 'Nothing'. +data MlDataFrameAnalyticsPutBody = MlDataFrameAnalyticsPutBody + { mldapbSource :: MlDataFrameAnalyticsSource, + mldapbDest :: MlDataFrameAnalyticsDest, + mldapbAnalysis :: Maybe MlDataFrameAnalyticsAnalysis, + mldapbAnalyzedFields :: Maybe MlDataFrameAnalyticsAnalyzedFields, + mldapbDescription :: Maybe Text, + mldapbModelMemoryLimit :: Maybe Text, + mldapbAllowLazyStart :: Maybe Bool, + mldapbFrequency :: Maybe Text + } + deriving stock (Eq, Show) + +-- | A PUT body with empty 'defaultMlDataFrameAnalyticsSource' and +-- 'defaultMlDataFrameAnalyticsDest' and every optional field 'Nothing'. +defaultMlDataFrameAnalyticsPutBody :: MlDataFrameAnalyticsPutBody +defaultMlDataFrameAnalyticsPutBody = + MlDataFrameAnalyticsPutBody + { mldapbSource = defaultMlDataFrameAnalyticsSource, + mldapbDest = defaultMlDataFrameAnalyticsDest, + mldapbAnalysis = Nothing, + mldapbAnalyzedFields = Nothing, + mldapbDescription = Nothing, + mldapbModelMemoryLimit = Nothing, + mldapbAllowLazyStart = Nothing, + mldapbFrequency = Nothing + } + +instance ToJSON MlDataFrameAnalyticsPutBody where + toJSON MlDataFrameAnalyticsPutBody {..} = + omitNulls + [ "source" .= mldapbSource, + "dest" .= mldapbDest, + "analysis" .= mldapbAnalysis, + "analyzed_fields" .= mldapbAnalyzedFields, + "description" .= mldapbDescription, + "model_memory_limit" .= mldapbModelMemoryLimit, + "allow_lazy_start" .= mldapbAllowLazyStart, + "frequency" .= mldapbFrequency + ] + +instance FromJSON MlDataFrameAnalyticsPutBody where + parseJSON = withObject "MlDataFrameAnalyticsPutBody" $ \o -> + MlDataFrameAnalyticsPutBody + <$> o .:? "source" .!= defaultMlDataFrameAnalyticsSource + <*> o .:? "dest" .!= defaultMlDataFrameAnalyticsDest + <*> o .:? "analysis" + <*> o .:? "analyzed_fields" + <*> o .:? "description" + <*> o .:? "model_memory_limit" + <*> o .:? "allow_lazy_start" + <*> o .:? "frequency" + +mlDataFrameAnalyticsPutBodySourceLens :: Lens' MlDataFrameAnalyticsPutBody MlDataFrameAnalyticsSource +mlDataFrameAnalyticsPutBodySourceLens = + lens mldapbSource (\x y -> x {mldapbSource = y}) + +mlDataFrameAnalyticsPutBodyDestLens :: Lens' MlDataFrameAnalyticsPutBody MlDataFrameAnalyticsDest +mlDataFrameAnalyticsPutBodyDestLens = + lens mldapbDest (\x y -> x {mldapbDest = y}) + +mlDataFrameAnalyticsPutBodyAnalysisLens :: Lens' MlDataFrameAnalyticsPutBody (Maybe MlDataFrameAnalyticsAnalysis) +mlDataFrameAnalyticsPutBodyAnalysisLens = + lens mldapbAnalysis (\x y -> x {mldapbAnalysis = y}) + +mlDataFrameAnalyticsPutBodyAnalyzedFieldsLens :: Lens' MlDataFrameAnalyticsPutBody (Maybe MlDataFrameAnalyticsAnalyzedFields) +mlDataFrameAnalyticsPutBodyAnalyzedFieldsLens = + lens mldapbAnalyzedFields (\x y -> x {mldapbAnalyzedFields = y}) + +mlDataFrameAnalyticsPutBodyDescriptionLens :: Lens' MlDataFrameAnalyticsPutBody (Maybe Text) +mlDataFrameAnalyticsPutBodyDescriptionLens = + lens mldapbDescription (\x y -> x {mldapbDescription = y}) + +mlDataFrameAnalyticsPutBodyModelMemoryLimitLens :: Lens' MlDataFrameAnalyticsPutBody (Maybe Text) +mlDataFrameAnalyticsPutBodyModelMemoryLimitLens = + lens mldapbModelMemoryLimit (\x y -> x {mldapbModelMemoryLimit = y}) + +mlDataFrameAnalyticsPutBodyAllowLazyStartLens :: Lens' MlDataFrameAnalyticsPutBody (Maybe Bool) +mlDataFrameAnalyticsPutBodyAllowLazyStartLens = + lens mldapbAllowLazyStart (\x y -> x {mldapbAllowLazyStart = y}) + +mlDataFrameAnalyticsPutBodyFrequencyLens :: Lens' MlDataFrameAnalyticsPutBody (Maybe Text) +mlDataFrameAnalyticsPutBodyFrequencyLens = + lens mldapbFrequency (\x y -> x {mldapbFrequency = y}) + +-- | The POST body for +-- @POST \/_ml\/data_frame\/analytics\/{id}/_update@. Every field is +-- optional; an empty body is valid. +data MlDataFrameAnalyticsUpdateBody = MlDataFrameAnalyticsUpdateBody + { mldaubDescription :: Maybe Text, + mldaubModelMemoryLimit :: Maybe Text, + mldaubAnalysis :: Maybe MlDataFrameAnalyticsAnalysis, + mldaubSource :: Maybe MlDataFrameAnalyticsSource, + mldaubDest :: Maybe MlDataFrameAnalyticsDest, + mldaubAnalyzedFields :: Maybe MlDataFrameAnalyticsAnalyzedFields + } + deriving stock (Eq, Show) + +-- | An empty update body — encodes to @{}@. +defaultMlDataFrameAnalyticsUpdateBody :: MlDataFrameAnalyticsUpdateBody +defaultMlDataFrameAnalyticsUpdateBody = + MlDataFrameAnalyticsUpdateBody + { mldaubDescription = Nothing, + mldaubModelMemoryLimit = Nothing, + mldaubAnalysis = Nothing, + mldaubSource = Nothing, + mldaubDest = Nothing, + mldaubAnalyzedFields = Nothing + } + +instance ToJSON MlDataFrameAnalyticsUpdateBody where + toJSON MlDataFrameAnalyticsUpdateBody {..} = + omitNulls + [ "description" .= mldaubDescription, + "model_memory_limit" .= mldaubModelMemoryLimit, + "analysis" .= mldaubAnalysis, + "source" .= mldaubSource, + "dest" .= mldaubDest, + "analyzed_fields" .= mldaubAnalyzedFields + ] + +instance FromJSON MlDataFrameAnalyticsUpdateBody where + parseJSON = withObject "MlDataFrameAnalyticsUpdateBody" $ \o -> + MlDataFrameAnalyticsUpdateBody + <$> o .:? "description" + <*> o .:? "model_memory_limit" + <*> o .:? "analysis" + <*> o .:? "source" + <*> o .:? "dest" + <*> o .:? "analyzed_fields" + +mlDataFrameAnalyticsUpdateBodyDescriptionLens :: Lens' MlDataFrameAnalyticsUpdateBody (Maybe Text) +mlDataFrameAnalyticsUpdateBodyDescriptionLens = + lens mldaubDescription (\x y -> x {mldaubDescription = y}) + +mlDataFrameAnalyticsUpdateBodyModelMemoryLimitLens :: Lens' MlDataFrameAnalyticsUpdateBody (Maybe Text) +mlDataFrameAnalyticsUpdateBodyModelMemoryLimitLens = + lens mldaubModelMemoryLimit (\x y -> x {mldaubModelMemoryLimit = y}) + +mlDataFrameAnalyticsUpdateBodyAnalysisLens :: Lens' MlDataFrameAnalyticsUpdateBody (Maybe MlDataFrameAnalyticsAnalysis) +mlDataFrameAnalyticsUpdateBodyAnalysisLens = + lens mldaubAnalysis (\x y -> x {mldaubAnalysis = y}) + +mlDataFrameAnalyticsUpdateBodySourceLens :: Lens' MlDataFrameAnalyticsUpdateBody (Maybe MlDataFrameAnalyticsSource) +mlDataFrameAnalyticsUpdateBodySourceLens = + lens mldaubSource (\x y -> x {mldaubSource = y}) + +mlDataFrameAnalyticsUpdateBodyDestLens :: Lens' MlDataFrameAnalyticsUpdateBody (Maybe MlDataFrameAnalyticsDest) +mlDataFrameAnalyticsUpdateBodyDestLens = + lens mldaubDest (\x y -> x {mldaubDest = y}) + +mlDataFrameAnalyticsUpdateBodyAnalyzedFieldsLens :: Lens' MlDataFrameAnalyticsUpdateBody (Maybe MlDataFrameAnalyticsAnalyzedFields) +mlDataFrameAnalyticsUpdateBodyAnalyzedFieldsLens = + lens mldaubAnalyzedFields (\x y -> x {mldaubAnalyzedFields = y}) + +-- | The POST body for @POST \/_ml\/data_frame\/analytics\/_preview@. +-- The server accepts either a full config object (with @source@, +-- @dest@, @analysis@) or a reference to an existing analytics id; both +-- shapes are forwarded verbatim via the opaque 'Value'. +data MlDataFrameAnalyticsPreviewRequest = MlDataFrameAnalyticsPreviewRequest + { mldaprConfig :: Value + } + deriving stock (Eq, Show) + +instance ToJSON MlDataFrameAnalyticsPreviewRequest where + toJSON MlDataFrameAnalyticsPreviewRequest {..} = mldaprConfig + +instance FromJSON MlDataFrameAnalyticsPreviewRequest where + parseJSON v = pure $ MlDataFrameAnalyticsPreviewRequest v + +mlDataFrameAnalyticsPreviewRequestConfigLens :: Lens' MlDataFrameAnalyticsPreviewRequest Value +mlDataFrameAnalyticsPreviewRequestConfigLens = + lens mldaprConfig (\x y -> x {mldaprConfig = y}) + +-- | Optional URI query parameters shared across the data frame analytics +-- endpoints: @force@ (delete\/stop a non-stopped job), @from@ \/ @size@ +-- (pagination of the list), @allow_lazy_start@, @verbose@ (stats) and +-- @timeout@. 'defaultMlDataFrameAnalyticsOptions' renders no query +-- string; endpoints silently ignore parameters that do not apply to +-- them. +data MlDataFrameAnalyticsOptions = MlDataFrameAnalyticsOptions + { mldaoForce :: Maybe Bool, + mldaoFrom :: Maybe Int, + mldaoSize :: Maybe Int, + mldaoAllowLazyStart :: Maybe Bool, + mldaoVerbose :: Maybe Bool, + mldaoTimeout :: Maybe Text + } + deriving stock (Eq, Show) + +defaultMlDataFrameAnalyticsOptions :: MlDataFrameAnalyticsOptions +defaultMlDataFrameAnalyticsOptions = + MlDataFrameAnalyticsOptions + { mldaoForce = Nothing, + mldaoFrom = Nothing, + mldaoSize = Nothing, + mldaoAllowLazyStart = Nothing, + mldaoVerbose = Nothing, + mldaoTimeout = Nothing + } + +mlDataFrameAnalyticsOptionsForceLens :: Lens' MlDataFrameAnalyticsOptions (Maybe Bool) +mlDataFrameAnalyticsOptionsForceLens = + lens mldaoForce (\x y -> x {mldaoForce = y}) + +mlDataFrameAnalyticsOptionsFromLens :: Lens' MlDataFrameAnalyticsOptions (Maybe Int) +mlDataFrameAnalyticsOptionsFromLens = + lens mldaoFrom (\x y -> x {mldaoFrom = y}) + +mlDataFrameAnalyticsOptionsSizeLens :: Lens' MlDataFrameAnalyticsOptions (Maybe Int) +mlDataFrameAnalyticsOptionsSizeLens = + lens mldaoSize (\x y -> x {mldaoSize = y}) + +mlDataFrameAnalyticsOptionsAllowLazyStartLens :: Lens' MlDataFrameAnalyticsOptions (Maybe Bool) +mlDataFrameAnalyticsOptionsAllowLazyStartLens = + lens mldaoAllowLazyStart (\x y -> x {mldaoAllowLazyStart = y}) + +mlDataFrameAnalyticsOptionsVerboseLens :: Lens' MlDataFrameAnalyticsOptions (Maybe Bool) +mlDataFrameAnalyticsOptionsVerboseLens = + lens mldaoVerbose (\x y -> x {mldaoVerbose = y}) + +mlDataFrameAnalyticsOptionsTimeoutLens :: Lens' MlDataFrameAnalyticsOptions (Maybe Text) +mlDataFrameAnalyticsOptionsTimeoutLens = + lens mldaoTimeout (\x y -> x {mldaoTimeout = y}) + +-- | Render 'MlDataFrameAnalyticsOptions' as a list of @(key, value)@ +-- query parameters suitable for 'withQueries'. 'Nothing' fields are +-- omitted, so 'defaultMlDataFrameAnalyticsOptions' produces @[]@. +mlDataFrameAnalyticsOptionsParams :: MlDataFrameAnalyticsOptions -> [(Text, Maybe Text)] +mlDataFrameAnalyticsOptionsParams MlDataFrameAnalyticsOptions {..} = + catMaybes + [ (("force",) . Just . boolText) <$> mldaoForce, + (("from",) . Just . intText) <$> mldaoFrom, + (("size",) . Just . intText) <$> mldaoSize, + (("allow_lazy_start",) . Just . boolText) <$> mldaoAllowLazyStart, + (("verbose",) . Just . boolText) <$> mldaoVerbose, + (("timeout",) . Just) <$> mldaoTimeout + ] + where + boolText b = if b then "true" else "false" + intText = T.pack . show + +-- | The stored configuration of a single analytics job, as returned by +-- @GET \/_ml\/data_frame\/analytics[\/{id}]@. The envelope is typed +-- (@id@, @state@, @analysis_type@, @create_time@, @version@, @source@, +-- @dest@, @analysis@); everything else the server reports is folded into +-- the opaque 'mldadExtras' map so unknown forward-compat fields survive +-- a round trip. +data MlDataFrameAnalyticsDocument = MlDataFrameAnalyticsDocument + { mldadId :: Maybe Text, + mldadState :: Maybe MlDataFrameAnalyticsState, + mldadAnalysisType :: Maybe MlDataFrameAnalysisType, + mldadCreateTime :: Maybe Scientific, + mldadVersion :: Maybe Text, + mldadSource :: Maybe MlDataFrameAnalyticsSource, + mldadDest :: Maybe MlDataFrameAnalyticsDest, + mldadAnalysis :: Maybe MlDataFrameAnalyticsAnalysis, + mldadExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +knownDocumentKeys :: [Key] +knownDocumentKeys = + [ "id", + "state", + "analysis_type", + "create_time", + "version", + "source", + "dest", + "analysis" + ] + +instance ToJSON MlDataFrameAnalyticsDocument where + toJSON MlDataFrameAnalyticsDocument {..} = + omitNulls $ + [ "id" .= mldadId, + "state" .= mldadState, + "analysis_type" .= mldadAnalysisType, + "create_time" .= mldadCreateTime, + "version" .= mldadVersion, + "source" .= mldadSource, + "dest" .= mldadDest, + "analysis" .= mldadAnalysis + ] + ++ maybe [] KeyMap.toList mldadExtras + +instance FromJSON MlDataFrameAnalyticsDocument where + parseJSON = withObject "MlDataFrameAnalyticsDocument" $ \o -> do + mldadId <- o .:? "id" + mldadState <- o .:? "state" + mldadAnalysisType <- o .:? "analysis_type" + mldadCreateTime <- o .:? "create_time" + mldadVersion <- o .:? "version" + mldadSource <- o .:? "source" + mldadDest <- o .:? "dest" + mldadAnalysis <- o .:? "analysis" + let extras = deleteSeveral knownDocumentKeys o + mldadExtras = if null extras then Nothing else Just extras + pure MlDataFrameAnalyticsDocument {..} + +mlDataFrameAnalyticsDocumentIdLens :: Lens' MlDataFrameAnalyticsDocument (Maybe Text) +mlDataFrameAnalyticsDocumentIdLens = + lens mldadId (\x y -> x {mldadId = y}) + +mlDataFrameAnalyticsDocumentStateLens :: Lens' MlDataFrameAnalyticsDocument (Maybe MlDataFrameAnalyticsState) +mlDataFrameAnalyticsDocumentStateLens = + lens mldadState (\x y -> x {mldadState = y}) + +mlDataFrameAnalyticsDocumentAnalysisTypeLens :: Lens' MlDataFrameAnalyticsDocument (Maybe MlDataFrameAnalysisType) +mlDataFrameAnalyticsDocumentAnalysisTypeLens = + lens mldadAnalysisType (\x y -> x {mldadAnalysisType = y}) + +mlDataFrameAnalyticsDocumentCreateTimeLens :: Lens' MlDataFrameAnalyticsDocument (Maybe Scientific) +mlDataFrameAnalyticsDocumentCreateTimeLens = + lens mldadCreateTime (\x y -> x {mldadCreateTime = y}) + +mlDataFrameAnalyticsDocumentVersionLens :: Lens' MlDataFrameAnalyticsDocument (Maybe Text) +mlDataFrameAnalyticsDocumentVersionLens = + lens mldadVersion (\x y -> x {mldadVersion = y}) + +mlDataFrameAnalyticsDocumentSourceLens :: Lens' MlDataFrameAnalyticsDocument (Maybe MlDataFrameAnalyticsSource) +mlDataFrameAnalyticsDocumentSourceLens = + lens mldadSource (\x y -> x {mldadSource = y}) + +mlDataFrameAnalyticsDocumentDestLens :: Lens' MlDataFrameAnalyticsDocument (Maybe MlDataFrameAnalyticsDest) +mlDataFrameAnalyticsDocumentDestLens = + lens mldadDest (\x y -> x {mldadDest = y}) + +mlDataFrameAnalyticsDocumentAnalysisLens :: Lens' MlDataFrameAnalyticsDocument (Maybe MlDataFrameAnalyticsAnalysis) +mlDataFrameAnalyticsDocumentAnalysisLens = + lens mldadAnalysis (\x y -> x {mldadAnalysis = y}) + +mlDataFrameAnalyticsDocumentExtrasLens :: Lens' MlDataFrameAnalyticsDocument (Maybe (KeyMap.KeyMap Value)) +mlDataFrameAnalyticsDocumentExtrasLens = + lens mldadExtras (\x y -> x {mldadExtras = y}) + +-- | Response body of @GET \/_ml\/data_frame\/analytics[\/{id}]@. The +-- @count@ defaults to the length of @analytics@ when the server omits +-- it; @analytics@ defaults to @[]@. +data MlDataFrameAnalyticsGetResponse = MlDataFrameAnalyticsGetResponse + { mldagrCount :: Maybe Int, + mldagrAnalytics :: [MlDataFrameAnalyticsDocument] + } + deriving stock (Eq, Show) + +instance ToJSON MlDataFrameAnalyticsGetResponse where + toJSON MlDataFrameAnalyticsGetResponse {..} = + omitNulls + [ "count" .= mldagrCount, + "data_frame_analytics" .= mldagrAnalytics + ] + +instance FromJSON MlDataFrameAnalyticsGetResponse where + parseJSON = withObject "MlDataFrameAnalyticsGetResponse" $ \o -> do + mldagrAnalytics <- o .:? "data_frame_analytics" .!= [] + mCount <- o .:? "count" + let mldagrCount = mCount <|> Just (length mldagrAnalytics) + pure MlDataFrameAnalyticsGetResponse {..} + +mlDataFrameAnalyticsGetResponseCountLens :: Lens' MlDataFrameAnalyticsGetResponse (Maybe Int) +mlDataFrameAnalyticsGetResponseCountLens = + lens mldagrCount (\x y -> x {mldagrCount = y}) + +mlDataFrameAnalyticsGetResponseAnalyticsLens :: Lens' MlDataFrameAnalyticsGetResponse [MlDataFrameAnalyticsDocument] +mlDataFrameAnalyticsGetResponseAnalyticsLens = + lens mldagrAnalytics (\x y -> x {mldagrAnalytics = y}) + +-- | The per-job entry in the @data_frame_analytics@ array of a stats +-- response. The stable fields (@id@, @state@, @analysis_type@) are +-- typed; the large, volatile sub-objects (@data_counts@, +-- @memory_usage@, @progress@, @node@, @assignment@, ...) are folded +-- into 'mldasExtras' so the response survives forward-compat growth. +data MlDataFrameAnalyticsStats = MlDataFrameAnalyticsStats + { mldasId :: Maybe Text, + mldasState :: Maybe MlDataFrameAnalyticsState, + mldasAnalysisType :: Maybe MlDataFrameAnalysisType, + mldasExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +knownStatsKeys :: [Key] +knownStatsKeys = ["id", "state", "analysis_type"] + +instance ToJSON MlDataFrameAnalyticsStats where + toJSON MlDataFrameAnalyticsStats {..} = + omitNulls $ + [ "id" .= mldasId, + "state" .= mldasState, + "analysis_type" .= mldasAnalysisType + ] + ++ maybe [] KeyMap.toList mldasExtras + +instance FromJSON MlDataFrameAnalyticsStats where + parseJSON = withObject "MlDataFrameAnalyticsStats" $ \o -> do + mldasId <- o .:? "id" + mldasState <- o .:? "state" + mldasAnalysisType <- o .:? "analysis_type" + let extras = deleteSeveral knownStatsKeys o + mldasExtras = if null extras then Nothing else Just extras + pure MlDataFrameAnalyticsStats {..} + +mlDataFrameAnalyticsStatsIdLens :: Lens' MlDataFrameAnalyticsStats (Maybe Text) +mlDataFrameAnalyticsStatsIdLens = + lens mldasId (\x y -> x {mldasId = y}) + +mlDataFrameAnalyticsStatsStateLens :: Lens' MlDataFrameAnalyticsStats (Maybe MlDataFrameAnalyticsState) +mlDataFrameAnalyticsStatsStateLens = + lens mldasState (\x y -> x {mldasState = y}) + +mlDataFrameAnalyticsStatsAnalysisTypeLens :: Lens' MlDataFrameAnalyticsStats (Maybe MlDataFrameAnalysisType) +mlDataFrameAnalyticsStatsAnalysisTypeLens = + lens mldasAnalysisType (\x y -> x {mldasAnalysisType = y}) + +mlDataFrameAnalyticsStatsExtrasLens :: Lens' MlDataFrameAnalyticsStats (Maybe (KeyMap.KeyMap Value)) +mlDataFrameAnalyticsStatsExtrasLens = + lens mldasExtras (\x y -> x {mldasExtras = y}) + +-- | Response body of @GET \/_ml\/data_frame\/analytics\/{id}\/_stats@. +-- The @count@ defaults to the length of @stats@ when absent. +data MlDataFrameAnalyticsStatsResponse = MlDataFrameAnalyticsStatsResponse + { mldasrCount :: Maybe Int, + mldasrStats :: [MlDataFrameAnalyticsStats] + } + deriving stock (Eq, Show) + +instance ToJSON MlDataFrameAnalyticsStatsResponse where + toJSON MlDataFrameAnalyticsStatsResponse {..} = + omitNulls + [ "count" .= mldasrCount, + "data_frame_analytics" .= mldasrStats + ] + +instance FromJSON MlDataFrameAnalyticsStatsResponse where + parseJSON = withObject "MlDataFrameAnalyticsStatsResponse" $ \o -> do + mldasrStats <- o .:? "data_frame_analytics" .!= [] + mCount <- o .:? "count" + let mldasrCount = mCount <|> Just (length mldasrStats) + pure MlDataFrameAnalyticsStatsResponse {..} + +mlDataFrameAnalyticsStatsResponseCountLens :: Lens' MlDataFrameAnalyticsStatsResponse (Maybe Int) +mlDataFrameAnalyticsStatsResponseCountLens = + lens mldasrCount (\x y -> x {mldasrCount = y}) + +mlDataFrameAnalyticsStatsResponseStatsLens :: Lens' MlDataFrameAnalyticsStatsResponse [MlDataFrameAnalyticsStats] +mlDataFrameAnalyticsStatsResponseStatsLens = + lens mldasrStats (\x y -> x {mldasrStats = y}) + +-- | A single previewed row. The server emits one JSON object per input +-- row; the contents are analysis-dependent, so the row carries the raw +-- JSON object verbatim. +newtype MlDataFrameAnalyticsPreviewRow = MlDataFrameAnalyticsPreviewRow + { mldaprFields :: KeyMap.KeyMap Value + } + deriving stock (Eq, Show) + +instance ToJSON MlDataFrameAnalyticsPreviewRow where + toJSON MlDataFrameAnalyticsPreviewRow {..} = Object mldaprFields + +instance FromJSON MlDataFrameAnalyticsPreviewRow where + parseJSON = withObject "MlDataFrameAnalyticsPreviewRow" $ \o -> + pure $ MlDataFrameAnalyticsPreviewRow o + +-- | Response body of @POST \/_ml\/data_frame\/analytics\/_preview@ — a +-- JSON array of previewed rows. Missing or non-array bodies decode to +-- @[]@. +newtype MlDataFrameAnalyticsPreviewResponse = MlDataFrameAnalyticsPreviewResponse + { mldaprrRows :: [MlDataFrameAnalyticsPreviewRow] + } + deriving stock (Eq, Show) + deriving newtype (Semigroup, Monoid) + +instance ToJSON MlDataFrameAnalyticsPreviewResponse where + toJSON MlDataFrameAnalyticsPreviewResponse {..} = toJSON mldaprrRows + +instance FromJSON MlDataFrameAnalyticsPreviewResponse where + parseJSON v = + pure $ + MlDataFrameAnalyticsPreviewResponse $ + case v of + Array a -> [MlDataFrameAnalyticsPreviewRow (asObject x) | x <- V.toList a] + _ -> [] + where + asObject (Object o) = o + asObject _ = KeyMap.empty + +mlDataFrameAnalyticsPreviewResponseRowsLens :: Lens' MlDataFrameAnalyticsPreviewResponse [MlDataFrameAnalyticsPreviewRow] +mlDataFrameAnalyticsPreviewResponseRowsLens = + lens mldaprrRows (\x y -> x {mldaprrRows = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlDatafeeds.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlDatafeeds.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlDatafeeds.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlDatafeeds +-- Description : Types for the Elasticsearch ML datafeed APIs +-- +-- Defines the request and response shapes for the Elasticsearch X-Pack ML +-- datafeed endpoints (under @\/_ml\/datafeeds/*@). A datafeed retrieves +-- data from Elasticsearch and forwards it to an anomaly detection job. +-- +-- * @PUT /_ml/datafeeds/{feed_id}@ — create ('MlDatafeed'). +-- * @GET /_ml/datafeeds[/{feed_id}]@ — 'MlDatafeedsResponse'. +-- * @POST /_ml/datafeeds/{feed_id}/_update@ — update ('MlDatafeedUpdate'). +-- * @DELETE /_ml/datafeeds/{feed_id}@ — returns 'Acknowledged'. +-- * @POST /_ml/datafeeds/{feed_id}/_start@ — returns 'Acknowledged'. +-- * @POST /_ml/datafeeds/{feed_id}/_stop@ — returns 'Acknowledged'. +-- * @GET /_ml/datafeeds/{feed_id}/_preview@ — 'MlDatafeedPreviewResponse'. +-- +-- The query and aggregation sub-objects are carried as opaque 'Value's; +-- only the stable envelope (@indices@, @job_id@, @frequency@, …) is +-- typed. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlDatafeeds + ( -- * Identity + MlDatafeedId (..), + unMlDatafeedId, + + -- * Request bodies + MlDatafeed (..), + defaultMlDatafeed, + mlDatafeedJobIdLens, + mlDatafeedIndicesLens, + mlDatafeedQueryLens, + mlDatafeedAggregationsLens, + mlDatafeedChunkingConfigLens, + mlDatafeedFrequencyLens, + mlDatafeedDelayedDataCheckConfigLens, + mlDatafeedIndicesOptionsLens, + mlDatafeedScrollSizeLens, + mlDatafeedRuntimeMappingsLens, + MlDatafeedUpdate (..), + defaultMlDatafeedUpdate, + mlDatafeedUpdateIndicesLens, + mlDatafeedUpdateQueryLens, + mlDatafeedUpdateAggregationsLens, + mlDatafeedUpdateChunkingConfigLens, + mlDatafeedUpdateFrequencyLens, + mlDatafeedUpdateDelayedDataCheckConfigLens, + mlDatafeedUpdateIndicesOptionsLens, + mlDatafeedUpdateScrollSizeLens, + mlDatafeedUpdateRuntimeMappingsLens, + + -- * Query options + MlDatafeedOptions (..), + defaultMlDatafeedOptions, + mlDatafeedOptionsParams, + + -- * Responses + MlDatafeedDocument (..), + mlDatafeedDocumentIdLens, + mlDatafeedDocumentJobIdLens, + mlDatafeedDocumentExtrasLens, + MlDatafeedsResponse (..), + mlDatafeedsResponseCountLens, + mlDatafeedsResponseDatafeedsLens, + MlDatafeedPreviewResponse (..), + mlDatafeedPreviewResponseBodyLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.String (IsString) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- | The @@ path segment of @\/_ml\/datafeeds\/@. +-- Forwarded verbatim. +newtype MlDatafeedId = MlDatafeedId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unMlDatafeedId :: MlDatafeedId -> Text +unMlDatafeedId (MlDatafeedId x) = x + +-- | The PUT request body for @PUT \/_ml\/datafeeds\/{feed_id}@. @job_id@ +-- is required (the anomaly job this feed serves); the search sub-objects +-- (@query@, @aggregations@, @chunking_config@, +-- @delayed_data_check_config@, @indices_options@, @runtime_mappings@) are +-- carried as opaque 'Value's. +data MlDatafeed = MlDatafeed + { mldfJobId :: Text, + mldfIndices :: Maybe [Text], + mldfQuery :: Maybe Value, + mldfAggregations :: Maybe Value, + mldfChunkingConfig :: Maybe Value, + mldfFrequency :: Maybe Int, + mldfDelayedDataCheckConfig :: Maybe Value, + mldfIndicesOptions :: Maybe Value, + mldfScrollSize :: Maybe Int, + mldfRuntimeMappings :: Maybe Value + } + deriving stock (Eq, Show) + +-- | A datafeed body with only the required @job_id@ set and every +-- optional field 'Nothing'. +defaultMlDatafeed :: MlDatafeed +defaultMlDatafeed = + MlDatafeed + { mldfJobId = "", + mldfIndices = Nothing, + mldfQuery = Nothing, + mldfAggregations = Nothing, + mldfChunkingConfig = Nothing, + mldfFrequency = Nothing, + mldfDelayedDataCheckConfig = Nothing, + mldfIndicesOptions = Nothing, + mldfScrollSize = Nothing, + mldfRuntimeMappings = Nothing + } + +instance ToJSON MlDatafeed where + toJSON MlDatafeed {..} = + omitNulls + [ "job_id" .= mldfJobId, + "indices" .= mldfIndices, + "query" .= mldfQuery, + "aggregations" .= mldfAggregations, + "chunking_config" .= mldfChunkingConfig, + "frequency" .= mldfFrequency, + "delayed_data_check_config" .= mldfDelayedDataCheckConfig, + "indices_options" .= mldfIndicesOptions, + "scroll_size" .= mldfScrollSize, + "runtime_mappings" .= mldfRuntimeMappings + ] + +instance FromJSON MlDatafeed where + parseJSON = withObject "MlDatafeed" $ \o -> + MlDatafeed + <$> o .:? "job_id" .!= "" + <*> o .:? "indices" + <*> o .:? "query" + <*> o .:? "aggregations" + <*> o .:? "chunking_config" + <*> o .:? "frequency" + <*> o .:? "delayed_data_check_config" + <*> o .:? "indices_options" + <*> o .:? "scroll_size" + <*> o .:? "runtime_mappings" + +mlDatafeedJobIdLens :: Lens' MlDatafeed Text +mlDatafeedJobIdLens = + lens mldfJobId (\x y -> x {mldfJobId = y}) + +mlDatafeedIndicesLens :: Lens' MlDatafeed (Maybe [Text]) +mlDatafeedIndicesLens = + lens mldfIndices (\x y -> x {mldfIndices = y}) + +mlDatafeedQueryLens :: Lens' MlDatafeed (Maybe Value) +mlDatafeedQueryLens = + lens mldfQuery (\x y -> x {mldfQuery = y}) + +mlDatafeedAggregationsLens :: Lens' MlDatafeed (Maybe Value) +mlDatafeedAggregationsLens = + lens mldfAggregations (\x y -> x {mldfAggregations = y}) + +mlDatafeedChunkingConfigLens :: Lens' MlDatafeed (Maybe Value) +mlDatafeedChunkingConfigLens = + lens mldfChunkingConfig (\x y -> x {mldfChunkingConfig = y}) + +mlDatafeedFrequencyLens :: Lens' MlDatafeed (Maybe Int) +mlDatafeedFrequencyLens = + lens mldfFrequency (\x y -> x {mldfFrequency = y}) + +mlDatafeedDelayedDataCheckConfigLens :: Lens' MlDatafeed (Maybe Value) +mlDatafeedDelayedDataCheckConfigLens = + lens mldfDelayedDataCheckConfig (\x y -> x {mldfDelayedDataCheckConfig = y}) + +mlDatafeedIndicesOptionsLens :: Lens' MlDatafeed (Maybe Value) +mlDatafeedIndicesOptionsLens = + lens mldfIndicesOptions (\x y -> x {mldfIndicesOptions = y}) + +mlDatafeedScrollSizeLens :: Lens' MlDatafeed (Maybe Int) +mlDatafeedScrollSizeLens = + lens mldfScrollSize (\x y -> x {mldfScrollSize = y}) + +mlDatafeedRuntimeMappingsLens :: Lens' MlDatafeed (Maybe Value) +mlDatafeedRuntimeMappingsLens = + lens mldfRuntimeMappings (\x y -> x {mldfRuntimeMappings = y}) + +-- | The POST body for +-- @POST \/_ml\/datafeeds\/{feed_id}/_update@. Every field is optional. +data MlDatafeedUpdate = MlDatafeedUpdate + { mldfuIndices :: Maybe [Text], + mldfuQuery :: Maybe Value, + mldfuAggregations :: Maybe Value, + mldfuChunkingConfig :: Maybe Value, + mldfuFrequency :: Maybe Int, + mldfuDelayedDataCheckConfig :: Maybe Value, + mldfuIndicesOptions :: Maybe Value, + mldfuScrollSize :: Maybe Int, + mldfuRuntimeMappings :: Maybe Value + } + deriving stock (Eq, Show) + +-- | An empty update body — encodes to @{}@. +defaultMlDatafeedUpdate :: MlDatafeedUpdate +defaultMlDatafeedUpdate = + MlDatafeedUpdate + { mldfuIndices = Nothing, + mldfuQuery = Nothing, + mldfuAggregations = Nothing, + mldfuChunkingConfig = Nothing, + mldfuFrequency = Nothing, + mldfuDelayedDataCheckConfig = Nothing, + mldfuIndicesOptions = Nothing, + mldfuScrollSize = Nothing, + mldfuRuntimeMappings = Nothing + } + +instance ToJSON MlDatafeedUpdate where + toJSON MlDatafeedUpdate {..} = + omitNulls + [ "indices" .= mldfuIndices, + "query" .= mldfuQuery, + "aggregations" .= mldfuAggregations, + "chunking_config" .= mldfuChunkingConfig, + "frequency" .= mldfuFrequency, + "delayed_data_check_config" .= mldfuDelayedDataCheckConfig, + "indices_options" .= mldfuIndicesOptions, + "scroll_size" .= mldfuScrollSize, + "runtime_mappings" .= mldfuRuntimeMappings + ] + +instance FromJSON MlDatafeedUpdate where + parseJSON = withObject "MlDatafeedUpdate" $ \o -> + MlDatafeedUpdate + <$> o .:? "indices" + <*> o .:? "query" + <*> o .:? "aggregations" + <*> o .:? "chunking_config" + <*> o .:? "frequency" + <*> o .:? "delayed_data_check_config" + <*> o .:? "indices_options" + <*> o .:? "scroll_size" + <*> o .:? "runtime_mappings" + +mlDatafeedUpdateIndicesLens :: Lens' MlDatafeedUpdate (Maybe [Text]) +mlDatafeedUpdateIndicesLens = + lens mldfuIndices (\x y -> x {mldfuIndices = y}) + +mlDatafeedUpdateQueryLens :: Lens' MlDatafeedUpdate (Maybe Value) +mlDatafeedUpdateQueryLens = + lens mldfuQuery (\x y -> x {mldfuQuery = y}) + +mlDatafeedUpdateAggregationsLens :: Lens' MlDatafeedUpdate (Maybe Value) +mlDatafeedUpdateAggregationsLens = + lens mldfuAggregations (\x y -> x {mldfuAggregations = y}) + +mlDatafeedUpdateChunkingConfigLens :: Lens' MlDatafeedUpdate (Maybe Value) +mlDatafeedUpdateChunkingConfigLens = + lens mldfuChunkingConfig (\x y -> x {mldfuChunkingConfig = y}) + +mlDatafeedUpdateFrequencyLens :: Lens' MlDatafeedUpdate (Maybe Int) +mlDatafeedUpdateFrequencyLens = + lens mldfuFrequency (\x y -> x {mldfuFrequency = y}) + +mlDatafeedUpdateDelayedDataCheckConfigLens :: Lens' MlDatafeedUpdate (Maybe Value) +mlDatafeedUpdateDelayedDataCheckConfigLens = + lens mldfuDelayedDataCheckConfig (\x y -> x {mldfuDelayedDataCheckConfig = y}) + +mlDatafeedUpdateIndicesOptionsLens :: Lens' MlDatafeedUpdate (Maybe Value) +mlDatafeedUpdateIndicesOptionsLens = + lens mldfuIndicesOptions (\x y -> x {mldfuIndicesOptions = y}) + +mlDatafeedUpdateScrollSizeLens :: Lens' MlDatafeedUpdate (Maybe Int) +mlDatafeedUpdateScrollSizeLens = + lens mldfuScrollSize (\x y -> x {mldfuScrollSize = y}) + +mlDatafeedUpdateRuntimeMappingsLens :: Lens' MlDatafeedUpdate (Maybe Value) +mlDatafeedUpdateRuntimeMappingsLens = + lens mldfuRuntimeMappings (\x y -> x {mldfuRuntimeMappings = y}) + +-- | Optional URI query parameters shared across the datafeed endpoints: +-- @from@ \/ @size@ (list pagination). 'defaultMlDatafeedOptions' renders +-- no query string. +data MlDatafeedOptions = MlDatafeedOptions + { mldoFrom :: Maybe Int, + mldoSize :: Maybe Int + } + deriving stock (Eq, Show) + +defaultMlDatafeedOptions :: MlDatafeedOptions +defaultMlDatafeedOptions = + MlDatafeedOptions + { mldoFrom = Nothing, + mldoSize = Nothing + } + +mlDatafeedOptionsParams :: MlDatafeedOptions -> [(Text, Maybe Text)] +mlDatafeedOptionsParams MlDatafeedOptions {..} = + catMaybes + [ (("from",) . Just . intText) <$> mldoFrom, + (("size",) . Just . intText) <$> mldoSize + ] + where + intText = T.pack . show + +-- | The stored configuration of a single datafeed, as returned by +-- @GET \/_ml\/datafeeds[\/{feed_id}]@. @datafeed_id@ and @job_id@ are +-- typed; everything else is folded into 'mldfdExtras'. +data MlDatafeedDocument = MlDatafeedDocument + { mldfdId :: Maybe Text, + mldfdJobId :: Maybe Text, + mldfdExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +knownDatafeedKeys :: [Key] +knownDatafeedKeys = ["datafeed_id", "job_id"] + +instance ToJSON MlDatafeedDocument where + toJSON MlDatafeedDocument {..} = + omitNulls $ + [ "datafeed_id" .= mldfdId, + "job_id" .= mldfdJobId + ] + ++ maybe [] KeyMap.toList mldfdExtras + +instance FromJSON MlDatafeedDocument where + parseJSON = withObject "MlDatafeedDocument" $ \o -> do + mldfdId <- o .:? "datafeed_id" + mldfdJobId <- o .:? "job_id" + let extras = deleteSeveral knownDatafeedKeys o + mldfdExtras = if null extras then Nothing else Just extras + pure MlDatafeedDocument {..} + +mlDatafeedDocumentIdLens :: Lens' MlDatafeedDocument (Maybe Text) +mlDatafeedDocumentIdLens = + lens mldfdId (\x y -> x {mldfdId = y}) + +mlDatafeedDocumentJobIdLens :: Lens' MlDatafeedDocument (Maybe Text) +mlDatafeedDocumentJobIdLens = + lens mldfdJobId (\x y -> x {mldfdJobId = y}) + +mlDatafeedDocumentExtrasLens :: Lens' MlDatafeedDocument (Maybe (KeyMap.KeyMap Value)) +mlDatafeedDocumentExtrasLens = + lens mldfdExtras (\x y -> x {mldfdExtras = y}) + +-- | Response body of @GET \/_ml\/datafeeds[\/{feed_id}]@. The @count@ +-- defaults to the length of @datafeeds@ when absent. +data MlDatafeedsResponse = MlDatafeedsResponse + { mldfrCount :: Maybe Int, + mldfrDatafeeds :: [MlDatafeedDocument] + } + deriving stock (Eq, Show) + +instance ToJSON MlDatafeedsResponse where + toJSON MlDatafeedsResponse {..} = + omitNulls + [ "count" .= mldfrCount, + "datafeeds" .= mldfrDatafeeds + ] + +instance FromJSON MlDatafeedsResponse where + parseJSON = withObject "MlDatafeedsResponse" $ \o -> do + mldfrDatafeeds <- o .:? "datafeeds" .!= [] + mCount <- o .:? "count" + let mldfrCount = mCount <|> Just (length mldfrDatafeeds) + pure MlDatafeedsResponse {..} + +mlDatafeedsResponseCountLens :: Lens' MlDatafeedsResponse (Maybe Int) +mlDatafeedsResponseCountLens = + lens mldfrCount (\x y -> x {mldfrCount = y}) + +mlDatafeedsResponseDatafeedsLens :: Lens' MlDatafeedsResponse [MlDatafeedDocument] +mlDatafeedsResponseDatafeedsLens = + lens mldfrDatafeeds (\x y -> x {mldfrDatafeeds = y}) + +-- | Response body of @GET \/_ml\/datafeeds\/{feed_id}/_preview@ — the +-- documents the datafeed would send to the job. Carried verbatim as an +-- opaque 'Value'. +data MlDatafeedPreviewResponse = MlDatafeedPreviewResponse + { mldprBody :: Value + } + deriving stock (Eq, Show) + +instance ToJSON MlDatafeedPreviewResponse where + toJSON MlDatafeedPreviewResponse {..} = mldprBody + +instance FromJSON MlDatafeedPreviewResponse where + parseJSON v = pure $ MlDatafeedPreviewResponse v + +mlDatafeedPreviewResponseBodyLens :: Lens' MlDatafeedPreviewResponse Value +mlDatafeedPreviewResponseBodyLens = + lens mldprBody (\x y -> x {mldprBody = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlFiltersCalendars.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlFiltersCalendars.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlFiltersCalendars.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlFiltersCalendars +-- Description : Types for the Elasticsearch ML filter and calendar APIs +-- +-- Defines the request and response shapes for the Elasticsearch X-Pack ML +-- filter and scheduled-event calendar endpoints. +-- +-- Filters (@\/_ml\/filters/*@) are named lists of items (typically +-- @"skip_over "@ rules) referenced by anomaly detector +-- configurations: +-- +-- * @PUT /_ml/filters/{filter_id}@ — create\/update ('MlFilter'). +-- * @GET /_ml/filters[/{filter_id}]@ — 'MlFiltersResponse'. +-- * @DELETE /_ml/filters/{filter_id}@ — returns 'Acknowledged'. +-- +-- Calendars (@\/_ml\/calendars/*@) group 'MlScheduledEvent's that suppress +-- or otherwise annotate anomaly results during known downtime windows: +-- +-- * @PUT /_ml/calendars/{calendar_id}@ — create\/update ('MlCalendar'). +-- * @GET /_ml/calendars[/{calendar_id}]@ — 'MlCalendarsResponse'. +-- * @DELETE /_ml/calendars/{calendar_id}@ — returns 'Acknowledged'. +-- * @POST /_ml/calendars/{calendar_id}/events@ — set events ('MlScheduledEvents'). +-- * @GET /_ml/calendars/{calendar_id}/events@ — 'MlScheduledEventsResponse'. +-- +-- The scheduled-event shape (@calendar_id@, @event_id@, @description@, +-- @start_time@, @end_time@, @alarm@, ...) is carried as an opaque 'Value' +-- because it is large and only needed for display. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlFiltersCalendars + ( -- * Filter identity + MlFilterId (..), + unMlFilterId, + + -- * Filter request body + MlFilter (..), + defaultMlFilter, + mlFilterDescriptionLens, + mlFilterItemsLens, + + -- * Filter response + MlFilterDocument (..), + mlFilterDocumentIdLens, + mlFilterDocumentDescriptionLens, + mlFilterDocumentItemsLens, + mlFilterDocumentExtrasLens, + MlFiltersResponse (..), + mlFiltersResponseCountLens, + mlFiltersResponseFiltersLens, + + -- * Calendar identity + MlCalendarId (..), + unMlCalendarId, + + -- * Calendar request body + MlCalendar (..), + defaultMlCalendar, + mlCalendarDescriptionLens, + + -- * Calendar response + MlCalendarDocument (..), + mlCalendarDocumentIdLens, + mlCalendarDocumentDescriptionLens, + mlCalendarDocumentExtrasLens, + MlCalendarsResponse (..), + mlCalendarsResponseCountLens, + mlCalendarsResponseCalendarsLens, + + -- * Scheduled events + MlScheduledEvents (..), + mlScheduledEventsEventsLens, + MlScheduledEventsResponse (..), + mlScheduledEventsResponseBodyLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.String (IsString) +import Database.Bloodhound.Internal.Utils.Imports + +-- | The @@ path segment of @\/_ml\/filters\/@. +newtype MlFilterId = MlFilterId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unMlFilterId :: MlFilterId -> Text +unMlFilterId (MlFilterId x) = x + +-- | The PUT request body for +-- @PUT \/_ml\/filters\/{filter_id}@ (ml-put-filter). Both fields are +-- optional; an empty body creates an empty filter. +data MlFilter = MlFilter + { mlfDescription :: Maybe Text, + mlfItems :: Maybe [Text] + } + deriving stock (Eq, Show) + +-- | An empty filter body — encodes to @{}@. +defaultMlFilter :: MlFilter +defaultMlFilter = + MlFilter + { mlfDescription = Nothing, + mlfItems = Nothing + } + +instance ToJSON MlFilter where + toJSON MlFilter {..} = + omitNulls + [ "description" .= mlfDescription, + "items" .= mlfItems + ] + +instance FromJSON MlFilter where + parseJSON = withObject "MlFilter" $ \o -> + MlFilter + <$> o .:? "description" + <*> o .:? "items" + +mlFilterDescriptionLens :: Lens' MlFilter (Maybe Text) +mlFilterDescriptionLens = + lens mlfDescription (\x y -> x {mlfDescription = y}) + +mlFilterItemsLens :: Lens' MlFilter (Maybe [Text]) +mlFilterItemsLens = + lens mlfItems (\x y -> x {mlfItems = y}) + +-- | The stored configuration of a single filter, as returned by +-- @GET \/_ml\/filters[\/{filter_id}]@. @id@, @description@ and @items@ are +-- typed; everything else is folded into 'mlfdExtras'. +data MlFilterDocument = MlFilterDocument + { mlfdId :: Maybe Text, + mlfdDescription :: Maybe Text, + mlfdItems :: Maybe [Text], + mlfdExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +knownFilterKeys :: [Key] +knownFilterKeys = ["id", "description", "items"] + +instance ToJSON MlFilterDocument where + toJSON MlFilterDocument {..} = + omitNulls $ + [ "id" .= mlfdId, + "description" .= mlfdDescription, + "items" .= mlfdItems + ] + ++ maybe [] KeyMap.toList mlfdExtras + +instance FromJSON MlFilterDocument where + parseJSON = withObject "MlFilterDocument" $ \o -> do + mlfdId <- o .:? "id" + mlfdDescription <- o .:? "description" + mlfdItems <- o .:? "items" + let extras = deleteSeveral knownFilterKeys o + mlfdExtras = if null extras then Nothing else Just extras + pure MlFilterDocument {..} + +mlFilterDocumentIdLens :: Lens' MlFilterDocument (Maybe Text) +mlFilterDocumentIdLens = + lens mlfdId (\x y -> x {mlfdId = y}) + +mlFilterDocumentDescriptionLens :: Lens' MlFilterDocument (Maybe Text) +mlFilterDocumentDescriptionLens = + lens mlfdDescription (\x y -> x {mlfdDescription = y}) + +mlFilterDocumentItemsLens :: Lens' MlFilterDocument (Maybe [Text]) +mlFilterDocumentItemsLens = + lens mlfdItems (\x y -> x {mlfdItems = y}) + +mlFilterDocumentExtrasLens :: Lens' MlFilterDocument (Maybe (KeyMap.KeyMap Value)) +mlFilterDocumentExtrasLens = + lens mlfdExtras (\x y -> x {mlfdExtras = y}) + +-- | Response body of @GET \/_ml\/filters[\/{filter_id}]@. The @count@ +-- defaults to the length of @filters@ when absent. +data MlFiltersResponse = MlFiltersResponse + { mlfsrCount :: Maybe Int, + mlfsrFilters :: [MlFilterDocument] + } + deriving stock (Eq, Show) + +instance ToJSON MlFiltersResponse where + toJSON MlFiltersResponse {..} = + omitNulls + [ "count" .= mlfsrCount, + "filters" .= mlfsrFilters + ] + +instance FromJSON MlFiltersResponse where + parseJSON = withObject "MlFiltersResponse" $ \o -> do + mlfsrFilters <- o .:? "filters" .!= [] + mCount <- o .:? "count" + let mlfsrCount = mCount <|> Just (length mlfsrFilters) + pure MlFiltersResponse {..} + +mlFiltersResponseCountLens :: Lens' MlFiltersResponse (Maybe Int) +mlFiltersResponseCountLens = + lens mlfsrCount (\x y -> x {mlfsrCount = y}) + +mlFiltersResponseFiltersLens :: Lens' MlFiltersResponse [MlFilterDocument] +mlFiltersResponseFiltersLens = + lens mlfsrFilters (\x y -> x {mlfsrFilters = y}) + +-- | The @@ path segment of @\/_ml\/calendars\/@. +newtype MlCalendarId = MlCalendarId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unMlCalendarId :: MlCalendarId -> Text +unMlCalendarId (MlCalendarId x) = x + +-- | The PUT request body for +-- @PUT \/_ml\/calendars\/{calendar_id}@ (ml-put-calendar). +data MlCalendar = MlCalendar + { mlcalDescription :: Maybe Text + } + deriving stock (Eq, Show) + +-- | An empty calendar body — encodes to @{}@. +defaultMlCalendar :: MlCalendar +defaultMlCalendar = + MlCalendar {mlcalDescription = Nothing} + +instance ToJSON MlCalendar where + toJSON MlCalendar {..} = + omitNulls ["description" .= mlcalDescription] + +instance FromJSON MlCalendar where + parseJSON = withObject "MlCalendar" $ \o -> + MlCalendar <$> o .:? "description" + +mlCalendarDescriptionLens :: Lens' MlCalendar (Maybe Text) +mlCalendarDescriptionLens = + lens mlcalDescription (\x y -> x {mlcalDescription = y}) + +-- | The stored configuration of a single calendar, as returned by +-- @GET \/_ml\/calendars[\/{calendar_id}]@. @calendar_id@ and @description@ +-- are typed; everything else is folded into 'mlcdExtras'. +data MlCalendarDocument = MlCalendarDocument + { mlcdId :: Maybe Text, + mlcdDescription :: Maybe Text, + mlcdExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +knownCalendarKeys :: [Key] +knownCalendarKeys = ["calendar_id", "description"] + +instance ToJSON MlCalendarDocument where + toJSON MlCalendarDocument {..} = + omitNulls $ + [ "calendar_id" .= mlcdId, + "description" .= mlcdDescription + ] + ++ maybe [] KeyMap.toList mlcdExtras + +instance FromJSON MlCalendarDocument where + parseJSON = withObject "MlCalendarDocument" $ \o -> do + mlcdId <- o .:? "calendar_id" + mlcdDescription <- o .:? "description" + let extras = deleteSeveral knownCalendarKeys o + mlcdExtras = if null extras then Nothing else Just extras + pure MlCalendarDocument {..} + +mlCalendarDocumentIdLens :: Lens' MlCalendarDocument (Maybe Text) +mlCalendarDocumentIdLens = + lens mlcdId (\x y -> x {mlcdId = y}) + +mlCalendarDocumentDescriptionLens :: Lens' MlCalendarDocument (Maybe Text) +mlCalendarDocumentDescriptionLens = + lens mlcdDescription (\x y -> x {mlcdDescription = y}) + +mlCalendarDocumentExtrasLens :: Lens' MlCalendarDocument (Maybe (KeyMap.KeyMap Value)) +mlCalendarDocumentExtrasLens = + lens mlcdExtras (\x y -> x {mlcdExtras = y}) + +-- | Response body of @GET \/_ml\/calendars[\/{calendar_id}]@. The @count@ +-- defaults to the length of @calendars@ when absent. +data MlCalendarsResponse = MlCalendarsResponse + { mlcsrCount :: Maybe Int, + mlcsrCalendars :: [MlCalendarDocument] + } + deriving stock (Eq, Show) + +instance ToJSON MlCalendarsResponse where + toJSON MlCalendarsResponse {..} = + omitNulls + [ "count" .= mlcsrCount, + "calendars" .= mlcsrCalendars + ] + +instance FromJSON MlCalendarsResponse where + parseJSON = withObject "MlCalendarsResponse" $ \o -> do + mlcsrCalendars <- o .:? "calendars" .!= [] + mCount <- o .:? "count" + let mlcsrCount = mCount <|> Just (length mlcsrCalendars) + pure MlCalendarsResponse {..} + +mlCalendarsResponseCountLens :: Lens' MlCalendarsResponse (Maybe Int) +mlCalendarsResponseCountLens = + lens mlcsrCount (\x y -> x {mlcsrCount = y}) + +mlCalendarsResponseCalendarsLens :: Lens' MlCalendarsResponse [MlCalendarDocument] +mlCalendarsResponseCalendarsLens = + lens mlcsrCalendars (\x y -> x {mlcsrCalendars = y}) + +-- | The POST body for +-- @POST \/_ml\/calendars\/{calendar_id}/events@ (ml-post-calendar-events). +-- The @events@ array entries are carried as opaque 'Value's (their shape +-- varies by event kind — alarm, scheduled, …). +data MlScheduledEvents = MlScheduledEvents + { mlseEvents :: [Value] + } + deriving stock (Eq, Show) + +instance ToJSON MlScheduledEvents where + toJSON MlScheduledEvents {..} = + object ["events" .= mlseEvents] + +instance FromJSON MlScheduledEvents where + parseJSON = withObject "MlScheduledEvents" $ \o -> + MlScheduledEvents <$> o .:? "events" .!= [] + +mlScheduledEventsEventsLens :: Lens' MlScheduledEvents [Value] +mlScheduledEventsEventsLens = + lens mlseEvents (\x y -> x {mlseEvents = y}) + +-- | Response body of @GET \/_ml\/calendars\/{calendar_id}/events@ — +-- carried verbatim as an opaque 'Value'. +data MlScheduledEventsResponse = MlScheduledEventsResponse + { mlserBody :: Value + } + deriving stock (Eq, Show) + +instance ToJSON MlScheduledEventsResponse where + toJSON MlScheduledEventsResponse {..} = mlserBody + +instance FromJSON MlScheduledEventsResponse where + parseJSON v = pure $ MlScheduledEventsResponse v + +mlScheduledEventsResponseBodyLens :: Lens' MlScheduledEventsResponse Value +mlScheduledEventsResponseBodyLens = + lens mlserBody (\x y -> x {mlserBody = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlTrainedModels.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlTrainedModels.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/MlTrainedModels.hs @@ -0,0 +1,587 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlTrainedModels +-- Description : Types for the Elasticsearch ML trained model APIs +-- +-- Defines the request and response shapes for the Elasticsearch X-Pack ML +-- trained model endpoints (under @\/_ml\/trained_models/*@), which manage +-- pre-trained language models and their inference / deployment lifecycle. +-- +-- * @PUT /_ml/trained_models/{model_id}@ — create ('MlTrainedModelPutBody'). +-- * @GET /_ml/trained_models[/{model_id}]@ — 'MlTrainedModelsResponse'. +-- * @GET /_ml/trained_models/{model_id}/definition@ — 'MlTrainedModelDefinition'. +-- * @POST /_ml/trained_models/{model_id}/_update@ — update ('MlTrainedModelUpdateBody'). +-- * @DELETE /_ml/trained_models/{model_id}@ — returns 'Acknowledged'. +-- * @POST /_ml/trained_models/{model_id}/deployment/_deploy@ — returns 'Acknowledged'. +-- * @POST /_ml/trained_models/{model_id}/deployment/_undeploy@ — returns 'Acknowledged'. +-- * @POST /_ml/trained_models/{model_id}/deployment/_start@ — returns 'Acknowledged'. +-- * @POST /_ml/trained_models/{model_id}/deployment/_stop@ — returns 'Acknowledged'. +-- * @GET /_ml/trained_models/{model_id}/_stats@ — 'MlTrainedModelStatsResponse'. +-- * @POST /_ml/trained_models/{model_id}/_infer@ — 'MlTrainedModelInferResponse'. +-- +-- The model definition and inference config are large and fast-moving; they +-- are carried as opaque 'Value's. Only the stable envelope and the response +-- arrays are typed, with unknown sibling fields preserved in the +-- @*Extras@ 'KeyMap' catch-alls. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.MlTrainedModels + ( -- * Identity + MlTrainedModelId (..), + unMlTrainedModelId, + + -- * Request bodies + MlTrainedModelPutBody (..), + defaultMlTrainedModelPutBody, + mlTrainedModelPutBodyInferenceConfigLens, + mlTrainedModelPutBodyCompressedDefinitionLens, + mlTrainedModelPutBodyDefinitionLens, + mlTrainedModelPutBodyDescriptionLens, + mlTrainedModelPutBodyTagsLens, + mlTrainedModelPutBodyMetadataLens, + MlTrainedModelUpdateBody (..), + defaultMlTrainedModelUpdateBody, + mlTrainedModelUpdateBodyDescriptionLens, + mlTrainedModelUpdateBodyDeprecatedLens, + mlTrainedModelUpdateBodyMetadataLens, + MlTrainedModelInferRequest (..), + mlTrainedModelInferRequestDocsLens, + + -- * Query options + MlTrainedModelOptions (..), + defaultMlTrainedModelOptions, + mlTrainedModelOptionsParams, + mlTrainedModelOptionsFromLens, + mlTrainedModelOptionsSizeLens, + mlTrainedModelOptionsDecompressDefinitionLens, + mlTrainedModelOptionsIncludeDefinitionLens, + mlTrainedModelOptionsWaitForCompletionLens, + mlTrainedModelOptionsPriorityLens, + mlTrainedModelOptionsTimeoutLens, + mlTrainedModelOptionsForceLens, + mlTrainedModelOptionsThreadsLens, + + -- * Responses + MlTrainedModelConfig (..), + mlTrainedModelConfigModelIdLens, + mlTrainedModelConfigCreatedByLens, + mlTrainedModelConfigVersionLens, + mlTrainedModelConfigDescriptionLens, + mlTrainedModelConfigDeprecatedLens, + mlTrainedModelConfigInferenceConfigLens, + mlTrainedModelConfigExtrasLens, + MlTrainedModelsResponse (..), + mlTrainedModelsResponseCountLens, + mlTrainedModelsResponseConfigsLens, + MlTrainedModelStats (..), + mlTrainedModelStatsModelIdLens, + mlTrainedModelStatsExtrasLens, + MlTrainedModelStatsResponse (..), + mlTrainedModelStatsResponseCountLens, + mlTrainedModelStatsResponseStatsLens, + MlTrainedModelDefinition (..), + mlTrainedModelDefinitionModelIdLens, + mlTrainedModelDefinitionTotalDefinitionLengthLens, + mlTrainedModelDefinitionDefinitionLens, + mlTrainedModelDefinitionExtrasLens, + MlTrainedModelInferResponse (..), + mlTrainedModelInferResponseBodyLens, + ) +where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.String (IsString) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- | The @@ path segment of +-- @\/_ml\/trained_models\/@. Accepts a single id, a +-- comma-separated list, or a wildcard @"*"@; forwarded verbatim. +newtype MlTrainedModelId = MlTrainedModelId Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unMlTrainedModelId :: MlTrainedModelId -> Text +unMlTrainedModelId (MlTrainedModelId x) = x + +-- | The PUT request body for +-- @PUT \/_ml\/trained_models\/{model_id}@ (ml-put-trained-model). Exactly +-- one model source is required: @compressed_definition@ (a deflated, +-- base64-encoded string) or @definition@ (the full structured +-- @model_definition@). @inference_config@ is always required and carried +-- as an opaque 'Value'. +data MlTrainedModelPutBody = MlTrainedModelPutBody + { mltmpInferenceConfig :: Value, + mltmpCompressedDefinition :: Maybe Text, + mltmpDefinition :: Maybe Value, + mltmpDescription :: Maybe Text, + mltmpTags :: Maybe [Text], + mltmpMetadata :: Maybe Value + } + deriving stock (Eq, Show) + +-- | A PUT body carrying only the mandatory @inference_config@ and every +-- optional field 'Nothing'. +defaultMlTrainedModelPutBody :: MlTrainedModelPutBody +defaultMlTrainedModelPutBody = + MlTrainedModelPutBody + { mltmpInferenceConfig = object [], + mltmpCompressedDefinition = Nothing, + mltmpDefinition = Nothing, + mltmpDescription = Nothing, + mltmpTags = Nothing, + mltmpMetadata = Nothing + } + +instance ToJSON MlTrainedModelPutBody where + toJSON MlTrainedModelPutBody {..} = + omitNulls + [ "inference_config" .= mltmpInferenceConfig, + "compressed_definition" .= mltmpCompressedDefinition, + "definition" .= mltmpDefinition, + "description" .= mltmpDescription, + "tags" .= mltmpTags, + "metadata" .= mltmpMetadata + ] + +instance FromJSON MlTrainedModelPutBody where + parseJSON = withObject "MlTrainedModelPutBody" $ \o -> do + cfg <- o .:? "inference_config" + let mltmpInferenceConfig = maybe (object []) id cfg + mltmpCompressedDefinition <- o .:? "compressed_definition" + mltmpDefinition <- o .:? "definition" + mltmpDescription <- o .:? "description" + mltmpTags <- o .:? "tags" + mltmpMetadata <- o .:? "metadata" + pure MlTrainedModelPutBody {..} + +mlTrainedModelPutBodyInferenceConfigLens :: Lens' MlTrainedModelPutBody Value +mlTrainedModelPutBodyInferenceConfigLens = + lens mltmpInferenceConfig (\x y -> x {mltmpInferenceConfig = y}) + +mlTrainedModelPutBodyCompressedDefinitionLens :: Lens' MlTrainedModelPutBody (Maybe Text) +mlTrainedModelPutBodyCompressedDefinitionLens = + lens mltmpCompressedDefinition (\x y -> x {mltmpCompressedDefinition = y}) + +mlTrainedModelPutBodyDefinitionLens :: Lens' MlTrainedModelPutBody (Maybe Value) +mlTrainedModelPutBodyDefinitionLens = + lens mltmpDefinition (\x y -> x {mltmpDefinition = y}) + +mlTrainedModelPutBodyDescriptionLens :: Lens' MlTrainedModelPutBody (Maybe Text) +mlTrainedModelPutBodyDescriptionLens = + lens mltmpDescription (\x y -> x {mltmpDescription = y}) + +mlTrainedModelPutBodyTagsLens :: Lens' MlTrainedModelPutBody (Maybe [Text]) +mlTrainedModelPutBodyTagsLens = + lens mltmpTags (\x y -> x {mltmpTags = y}) + +mlTrainedModelPutBodyMetadataLens :: Lens' MlTrainedModelPutBody (Maybe Value) +mlTrainedModelPutBodyMetadataLens = + lens mltmpMetadata (\x y -> x {mltmpMetadata = y}) + +-- | The POST body for +-- @POST \/_ml\/trained_models\/{model_id}/_update@ (ml-update-trained-model). +-- Every field is optional. +data MlTrainedModelUpdateBody = MlTrainedModelUpdateBody + { mltmubDescription :: Maybe Text, + mltmubDeprecated :: Maybe Bool, + mltmubMetadata :: Maybe Value + } + deriving stock (Eq, Show) + +-- | An empty update body — encodes to @{}@. +defaultMlTrainedModelUpdateBody :: MlTrainedModelUpdateBody +defaultMlTrainedModelUpdateBody = + MlTrainedModelUpdateBody + { mltmubDescription = Nothing, + mltmubDeprecated = Nothing, + mltmubMetadata = Nothing + } + +instance ToJSON MlTrainedModelUpdateBody where + toJSON MlTrainedModelUpdateBody {..} = + omitNulls + [ "description" .= mltmubDescription, + "deprecated" .= mltmubDeprecated, + "metadata" .= mltmubMetadata + ] + +instance FromJSON MlTrainedModelUpdateBody where + parseJSON = withObject "MlTrainedModelUpdateBody" $ \o -> + MlTrainedModelUpdateBody + <$> o .:? "description" + <*> o .:? "deprecated" + <*> o .:? "metadata" + +mlTrainedModelUpdateBodyDescriptionLens :: Lens' MlTrainedModelUpdateBody (Maybe Text) +mlTrainedModelUpdateBodyDescriptionLens = + lens mltmubDescription (\x y -> x {mltmubDescription = y}) + +mlTrainedModelUpdateBodyDeprecatedLens :: Lens' MlTrainedModelUpdateBody (Maybe Bool) +mlTrainedModelUpdateBodyDeprecatedLens = + lens mltmubDeprecated (\x y -> x {mltmubDeprecated = y}) + +mlTrainedModelUpdateBodyMetadataLens :: Lens' MlTrainedModelUpdateBody (Maybe Value) +mlTrainedModelUpdateBodyMetadataLens = + lens mltmubMetadata (\x y -> x {mltmubMetadata = y}) + +-- | The POST body for +-- @POST \/_ml\/trained_models\/{model_id}/_infer@ (ml-infer-trained-model). +-- The server accepts either a @docs@ array of objects or, for text +-- expansion models, a @text@ string; both are forwarded verbatim via the +-- opaque 'Value'. +data MlTrainedModelInferRequest = MlTrainedModelInferRequest + { mltmirDocs :: Value + } + deriving stock (Eq, Show) + +instance ToJSON MlTrainedModelInferRequest where + toJSON MlTrainedModelInferRequest {..} = mltmirDocs + +instance FromJSON MlTrainedModelInferRequest where + parseJSON v = pure $ MlTrainedModelInferRequest v + +mlTrainedModelInferRequestDocsLens :: Lens' MlTrainedModelInferRequest Value +mlTrainedModelInferRequestDocsLens = + lens mltmirDocs (\x y -> x {mltmirDocs = y}) + +-- | Optional URI query parameters shared across the trained model +-- endpoints: @from@ \/ @size@ (list pagination), +-- @decompress_definition@ \/ @include_definition@ (GET), +-- @wait_for_completion@ \/ @priority@ \/ @timeout@ (deploy\/start), +-- @force@ (undeploy\/stop) and @threads@ (deploy). Endpoints silently +-- ignore parameters that do not apply to them; +-- 'defaultMlTrainedModelOptions' renders no query string. +data MlTrainedModelOptions = MlTrainedModelOptions + { mltooFrom :: Maybe Int, + mltooSize :: Maybe Int, + mltooDecompressDefinition :: Maybe Bool, + mltooIncludeDefinition :: Maybe Bool, + mltooWaitForCompletion :: Maybe Bool, + mltooPriority :: Maybe Text, + mltooTimeout :: Maybe Text, + mltooForce :: Maybe Bool, + mltooThreads :: Maybe Int + } + deriving stock (Eq, Show) + +defaultMlTrainedModelOptions :: MlTrainedModelOptions +defaultMlTrainedModelOptions = + MlTrainedModelOptions + { mltooFrom = Nothing, + mltooSize = Nothing, + mltooDecompressDefinition = Nothing, + mltooIncludeDefinition = Nothing, + mltooWaitForCompletion = Nothing, + mltooPriority = Nothing, + mltooTimeout = Nothing, + mltooForce = Nothing, + mltooThreads = Nothing + } + +mlTrainedModelOptionsFromLens :: Lens' MlTrainedModelOptions (Maybe Int) +mlTrainedModelOptionsFromLens = + lens mltooFrom (\x y -> x {mltooFrom = y}) + +mlTrainedModelOptionsSizeLens :: Lens' MlTrainedModelOptions (Maybe Int) +mlTrainedModelOptionsSizeLens = + lens mltooSize (\x y -> x {mltooSize = y}) + +mlTrainedModelOptionsDecompressDefinitionLens :: Lens' MlTrainedModelOptions (Maybe Bool) +mlTrainedModelOptionsDecompressDefinitionLens = + lens mltooDecompressDefinition (\x y -> x {mltooDecompressDefinition = y}) + +mlTrainedModelOptionsIncludeDefinitionLens :: Lens' MlTrainedModelOptions (Maybe Bool) +mlTrainedModelOptionsIncludeDefinitionLens = + lens mltooIncludeDefinition (\x y -> x {mltooIncludeDefinition = y}) + +mlTrainedModelOptionsWaitForCompletionLens :: Lens' MlTrainedModelOptions (Maybe Bool) +mlTrainedModelOptionsWaitForCompletionLens = + lens mltooWaitForCompletion (\x y -> x {mltooWaitForCompletion = y}) + +mlTrainedModelOptionsPriorityLens :: Lens' MlTrainedModelOptions (Maybe Text) +mlTrainedModelOptionsPriorityLens = + lens mltooPriority (\x y -> x {mltooPriority = y}) + +mlTrainedModelOptionsTimeoutLens :: Lens' MlTrainedModelOptions (Maybe Text) +mlTrainedModelOptionsTimeoutLens = + lens mltooTimeout (\x y -> x {mltooTimeout = y}) + +mlTrainedModelOptionsForceLens :: Lens' MlTrainedModelOptions (Maybe Bool) +mlTrainedModelOptionsForceLens = + lens mltooForce (\x y -> x {mltooForce = y}) + +mlTrainedModelOptionsThreadsLens :: Lens' MlTrainedModelOptions (Maybe Int) +mlTrainedModelOptionsThreadsLens = + lens mltooThreads (\x y -> x {mltooThreads = y}) + +-- | Render 'MlTrainedModelOptions' as a list of @(key, value)@ query +-- parameters suitable for 'withQueries'. 'Nothing' fields are omitted. +mlTrainedModelOptionsParams :: MlTrainedModelOptions -> [(Text, Maybe Text)] +mlTrainedModelOptionsParams MlTrainedModelOptions {..} = + catMaybes + [ (("from",) . Just . intText) <$> mltooFrom, + (("size",) . Just . intText) <$> mltooSize, + (("decompress_definition",) . Just . boolText) <$> mltooDecompressDefinition, + (("include_definition",) . Just . boolText) <$> mltooIncludeDefinition, + (("wait_for_completion",) . Just . boolText) <$> mltooWaitForCompletion, + (("priority",) . Just) <$> mltooPriority, + (("timeout",) . Just) <$> mltooTimeout, + (("force",) . Just . boolText) <$> mltooForce, + (("threads",) . Just . intText) <$> mltooThreads + ] + where + boolText b = if b then "true" else "false" + intText = T.pack . show + +-- | The stored configuration of a single trained model, as returned by +-- @GET \/_ml\/trained_models[\/{model_id}]@ (the @trained_model_configs@ +-- array entry). The envelope is typed; @inference_config@ is the opaque +-- 'Value' (its shape varies by model kind — regression, classification, +-- text_expansion, …) and everything else lands in 'mltmcExtras'. +data MlTrainedModelConfig = MlTrainedModelConfig + { mltmcModelId :: Maybe Text, + mltmcCreatedBy :: Maybe Text, + mltmcVersion :: Maybe Text, + mltmcDescription :: Maybe Text, + mltmcDeprecated :: Maybe Bool, + mltmcInferenceConfig :: Maybe Value, + mltmcExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +knownConfigKeys :: [Key] +knownConfigKeys = + [ "model_id", + "created_by", + "version", + "description", + "deprecated", + "inference_config" + ] + +instance ToJSON MlTrainedModelConfig where + toJSON MlTrainedModelConfig {..} = + omitNulls $ + [ "model_id" .= mltmcModelId, + "created_by" .= mltmcCreatedBy, + "version" .= mltmcVersion, + "description" .= mltmcDescription, + "deprecated" .= mltmcDeprecated, + "inference_config" .= mltmcInferenceConfig + ] + ++ maybe [] KeyMap.toList mltmcExtras + +instance FromJSON MlTrainedModelConfig where + parseJSON = withObject "MlTrainedModelConfig" $ \o -> do + mltmcModelId <- o .:? "model_id" + mltmcCreatedBy <- o .:? "created_by" + mltmcVersion <- o .:? "version" + mltmcDescription <- o .:? "description" + mltmcDeprecated <- o .:? "deprecated" + mltmcInferenceConfig <- o .:? "inference_config" + let extras = deleteSeveral knownConfigKeys o + mltmcExtras = if null extras then Nothing else Just extras + pure MlTrainedModelConfig {..} + +mlTrainedModelConfigModelIdLens :: Lens' MlTrainedModelConfig (Maybe Text) +mlTrainedModelConfigModelIdLens = + lens mltmcModelId (\x y -> x {mltmcModelId = y}) + +mlTrainedModelConfigCreatedByLens :: Lens' MlTrainedModelConfig (Maybe Text) +mlTrainedModelConfigCreatedByLens = + lens mltmcCreatedBy (\x y -> x {mltmcCreatedBy = y}) + +mlTrainedModelConfigVersionLens :: Lens' MlTrainedModelConfig (Maybe Text) +mlTrainedModelConfigVersionLens = + lens mltmcVersion (\x y -> x {mltmcVersion = y}) + +mlTrainedModelConfigDescriptionLens :: Lens' MlTrainedModelConfig (Maybe Text) +mlTrainedModelConfigDescriptionLens = + lens mltmcDescription (\x y -> x {mltmcDescription = y}) + +mlTrainedModelConfigDeprecatedLens :: Lens' MlTrainedModelConfig (Maybe Bool) +mlTrainedModelConfigDeprecatedLens = + lens mltmcDeprecated (\x y -> x {mltmcDeprecated = y}) + +mlTrainedModelConfigInferenceConfigLens :: Lens' MlTrainedModelConfig (Maybe Value) +mlTrainedModelConfigInferenceConfigLens = + lens mltmcInferenceConfig (\x y -> x {mltmcInferenceConfig = y}) + +mlTrainedModelConfigExtrasLens :: Lens' MlTrainedModelConfig (Maybe (KeyMap.KeyMap Value)) +mlTrainedModelConfigExtrasLens = + lens mltmcExtras (\x y -> x {mltmcExtras = y}) + +-- | Response body of @GET \/_ml\/trained_models[\/{model_id}]@. The +-- @count@ defaults to the length of @trained_model_configs@ when the +-- server omits it; the array defaults to @[]@. +data MlTrainedModelsResponse = MlTrainedModelsResponse + { mltrCount :: Maybe Int, + mltrConfigs :: [MlTrainedModelConfig] + } + deriving stock (Eq, Show) + +instance ToJSON MlTrainedModelsResponse where + toJSON MlTrainedModelsResponse {..} = + omitNulls + [ "count" .= mltrCount, + "trained_model_configs" .= mltrConfigs + ] + +instance FromJSON MlTrainedModelsResponse where + parseJSON = withObject "MlTrainedModelsResponse" $ \o -> do + mltrConfigs <- o .:? "trained_model_configs" .!= [] + mCount <- o .:? "count" + let mltrCount = mCount <|> Just (length mltrConfigs) + pure MlTrainedModelsResponse {..} + +mlTrainedModelsResponseCountLens :: Lens' MlTrainedModelsResponse (Maybe Int) +mlTrainedModelsResponseCountLens = + lens mltrCount (\x y -> x {mltrCount = y}) + +mlTrainedModelsResponseConfigsLens :: Lens' MlTrainedModelsResponse [MlTrainedModelConfig] +mlTrainedModelsResponseConfigsLens = + lens mltrConfigs (\x y -> x {mltrConfigs = y}) + +-- | The per-model entry in the @trained_model_stats@ array of a stats +-- response. Only @model_id@ is typed; the large, volatile deployment +-- statistics (@deployment_stats@, @model_size_bytes@, @node_count@, ...) +-- are folded into 'mltmsExtras'. +data MlTrainedModelStats = MlTrainedModelStats + { mltmsModelId :: Maybe Text, + mltmsExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +knownStatsKeys :: [Key] +knownStatsKeys = ["model_id"] + +instance ToJSON MlTrainedModelStats where + toJSON MlTrainedModelStats {..} = + omitNulls $ + [ "model_id" .= mltmsModelId + ] + ++ maybe [] KeyMap.toList mltmsExtras + +instance FromJSON MlTrainedModelStats where + parseJSON = withObject "MlTrainedModelStats" $ \o -> do + mltmsModelId <- o .:? "model_id" + let extras = deleteSeveral knownStatsKeys o + mltmsExtras = if null extras then Nothing else Just extras + pure MlTrainedModelStats {..} + +mlTrainedModelStatsModelIdLens :: Lens' MlTrainedModelStats (Maybe Text) +mlTrainedModelStatsModelIdLens = + lens mltmsModelId (\x y -> x {mltmsModelId = y}) + +mlTrainedModelStatsExtrasLens :: Lens' MlTrainedModelStats (Maybe (KeyMap.KeyMap Value)) +mlTrainedModelStatsExtrasLens = + lens mltmsExtras (\x y -> x {mltmsExtras = y}) + +-- | Response body of @GET \/_ml\/trained_models\/{model_id}/_stats@. The +-- @count@ defaults to the length of @trained_model_stats@ when absent. +data MlTrainedModelStatsResponse = MlTrainedModelStatsResponse + { mltsrCount :: Maybe Int, + mltsrStats :: [MlTrainedModelStats] + } + deriving stock (Eq, Show) + +instance ToJSON MlTrainedModelStatsResponse where + toJSON MlTrainedModelStatsResponse {..} = + omitNulls + [ "count" .= mltsrCount, + "trained_model_stats" .= mltsrStats + ] + +instance FromJSON MlTrainedModelStatsResponse where + parseJSON = withObject "MlTrainedModelStatsResponse" $ \o -> do + mltsrStats <- o .:? "trained_model_stats" .!= [] + mCount <- o .:? "count" + let mltsrCount = mCount <|> Just (length mltsrStats) + pure MlTrainedModelStatsResponse {..} + +mlTrainedModelStatsResponseCountLens :: Lens' MlTrainedModelStatsResponse (Maybe Int) +mlTrainedModelStatsResponseCountLens = + lens mltsrCount (\x y -> x {mltsrCount = y}) + +mlTrainedModelStatsResponseStatsLens :: Lens' MlTrainedModelStatsResponse [MlTrainedModelStats] +mlTrainedModelStatsResponseStatsLens = + lens mltsrStats (\x y -> x {mltsrStats = y}) + +-- | Response body of @GET \/_ml\/trained_models\/{model_id}/definition@ +-- (ml-get-trained-model-definition). The @model_definition@ payload is +-- large and streamed in parts; it is carried here as an opaque 'Value'. +data MlTrainedModelDefinition = MlTrainedModelDefinition + { mltmdModelId :: Maybe Text, + mltmdTotalDefinitionLength :: Maybe Scientific, + mltmdDefinition :: Maybe Value, + mltmdExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +knownDefinitionKeys :: [Key] +knownDefinitionKeys = + [ "model_id", + "total_definition_length", + "model_definition" + ] + +instance ToJSON MlTrainedModelDefinition where + toJSON MlTrainedModelDefinition {..} = + omitNulls $ + [ "model_id" .= mltmdModelId, + "total_definition_length" .= mltmdTotalDefinitionLength, + "model_definition" .= mltmdDefinition + ] + ++ maybe [] KeyMap.toList mltmdExtras + +instance FromJSON MlTrainedModelDefinition where + parseJSON = withObject "MlTrainedModelDefinition" $ \o -> do + mltmdModelId <- o .:? "model_id" + mltmdTotalDefinitionLength <- o .:? "total_definition_length" + mltmdDefinition <- o .:? "model_definition" + let extras = deleteSeveral knownDefinitionKeys o + mltmdExtras = if null extras then Nothing else Just extras + pure MlTrainedModelDefinition {..} + +mlTrainedModelDefinitionModelIdLens :: Lens' MlTrainedModelDefinition (Maybe Text) +mlTrainedModelDefinitionModelIdLens = + lens mltmdModelId (\x y -> x {mltmdModelId = y}) + +mlTrainedModelDefinitionTotalDefinitionLengthLens :: Lens' MlTrainedModelDefinition (Maybe Scientific) +mlTrainedModelDefinitionTotalDefinitionLengthLens = + lens mltmdTotalDefinitionLength (\x y -> x {mltmdTotalDefinitionLength = y}) + +mlTrainedModelDefinitionDefinitionLens :: Lens' MlTrainedModelDefinition (Maybe Value) +mlTrainedModelDefinitionDefinitionLens = + lens mltmdDefinition (\x y -> x {mltmdDefinition = y}) + +mlTrainedModelDefinitionExtrasLens :: Lens' MlTrainedModelDefinition (Maybe (KeyMap.KeyMap Value)) +mlTrainedModelDefinitionExtrasLens = + lens mltmdExtras (\x y -> x {mltmdExtras = y}) + +-- | Response body of @POST \/_ml\/trained_models\/{model_id}/_infer@. The +-- predicted payload is model-kind-dependent (a @predicted_value@ number +-- for regression, a @results@ array for classification, a +-- @predicted_value@ token-weight map for text expansion, …), so the whole +-- response body is carried verbatim as an opaque 'Value'. +data MlTrainedModelInferResponse = MlTrainedModelInferResponse + { mltmirBody :: Value + } + deriving stock (Eq, Show) + +instance ToJSON MlTrainedModelInferResponse where + toJSON MlTrainedModelInferResponse {..} = mltmirBody + +instance FromJSON MlTrainedModelInferResponse where + parseJSON v = pure $ MlTrainedModelInferResponse v + +mlTrainedModelInferResponseBodyLens :: Lens' MlTrainedModelInferResponse Value +mlTrainedModelInferResponseBodyLens = + lens mltmirBody (\x y -> x {mltmirBody = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/PointInTime.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/PointInTime.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/PointInTime.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.PointInTime +-- +-- Request and response types for the Elasticsearch 9 point-in-time +-- endpoints: @POST \/{index}\/_pit@ (open) and @DELETE \/_pit@ (close). +-- The wire shapes match the ES7 variants +-- (see "Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.PointInTime"), +-- except that the ES9 open response additionally surfaces an @_shards@ +-- summary, which the ES9 docs mark as Required and which is therefore +-- parsed strictly here (matching the OpenSearch 2\/3 variants). +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.PointInTime where + +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes (ShardResult) + +-- | Response body for @POST /{index}/_pit@ (open point in time) on +-- Elasticsearch 9. Per the ES9 docs the @_shards@ summary is a Required +-- field and is parsed strictly (a payload omitting it is rejected, +-- matching the OpenSearch 2\/3 variants). Callers that need the shard +-- breakdown can read 'oes9Shards'; those that only need the id keep +-- using 'oes9PitId'. +data OpenPointInTimeResponse = OpenPointInTimeResponse + { oes9PitId :: Text, + oes9Shards :: ShardResult + } + deriving stock (Eq, Show) + +openPointInTimeIdLens :: Lens' OpenPointInTimeResponse Text +openPointInTimeIdLens = lens oes9PitId (\x y -> x {oes9PitId = y}) + +openPointInTimeShardsLens :: Lens' OpenPointInTimeResponse ShardResult +openPointInTimeShardsLens = lens oes9Shards (\x y -> x {oes9Shards = y}) + +instance ToJSON OpenPointInTimeResponse where + toJSON OpenPointInTimeResponse {..} = + object ["id" .= oes9PitId, "_shards" .= oes9Shards] + +instance FromJSON OpenPointInTimeResponse where + parseJSON (Object o) = + OpenPointInTimeResponse <$> o .: "id" <*> o .: "_shards" + parseJSON x = typeMismatch "OpenPointInTimeResponse" x + +-- | Request body for @DELETE /_pit@ (close point in time) on +-- Elasticsearch 9. The wire shape is identical to the ES7 variant (see +-- "Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.PointInTime"): +-- +-- @ +-- { "id": "" } +-- @ +-- +-- The value is a /single/ @id@ string. 'cPitId' is the value previously +-- obtained from 'OpenPointInTimeResponse'. +data ClosePointInTime = ClosePointInTime + { cPitId :: Text + } + deriving stock (Eq, Show) + +instance ToJSON ClosePointInTime where + toJSON ClosePointInTime {..} = + object ["id" .= cPitId] + +instance FromJSON ClosePointInTime where + parseJSON (Object o) = ClosePointInTime <$> o .: "id" + parseJSON x = typeMismatch "ClosePointInTime" x + +closePointInTimeIdLens :: Lens' ClosePointInTime Text +closePointInTimeIdLens = lens cPitId (\x y -> x {cPitId = y}) + +-- | Response body for @DELETE /_pit@ (close point in time) on +-- Elasticsearch 9. The wire shape is identical to the ES7 variant (see +-- "Database.Bloodhound.Internal.Versions.ElasticSearch7.Types.PointInTime"): +-- +-- @ +-- { "succeeded": \, "num_freed": \ } +-- @ +-- +-- 'succeeded' is whether the close completed for every requested pit; +-- 'numFreed' (wire @num_freed@) is the number of search contexts +-- released. +data ClosePointInTimeResponse = ClosePointInTimeResponse + { succeeded :: Bool, + numFreed :: Int + } + deriving stock (Eq, Show) + +instance ToJSON ClosePointInTimeResponse where + toJSON ClosePointInTimeResponse {..} = + object + [ "succeeded" .= succeeded, + "num_freed" .= numFreed + ] + +instance FromJSON ClosePointInTimeResponse where + parseJSON (Object o) = do + succeeded' <- o .: "succeeded" + numFreed' <- o .: "num_freed" + return $ ClosePointInTimeResponse succeeded' numFreed' + parseJSON x = typeMismatch "ClosePointInTimeResponse" x + +closePointInTimeSucceededLens :: Lens' ClosePointInTimeResponse Bool +closePointInTimeSucceededLens = lens succeeded (\x y -> x {succeeded = y}) + +closePointInTimeNumFreedLens :: Lens' ClosePointInTimeResponse Int +closePointInTimeNumFreedLens = lens numFreed (\x y -> x {numFreed = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/ResolveCluster.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/ResolveCluster.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/ResolveCluster.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.ResolveCluster +-- Description : Types for the ES9 @GET /_resolve/cluster@ endpoint +-- +-- Request option and response shapes for the Elasticsearch 9 +-- @GET /_resolve/cluster[\/{name}]@ endpoint +-- (indices-resolve-cluster), which resolves the cluster alias component +-- of index expressions (including @\:\@ remote-cluster +-- references) into the connected remote clusters the caller can search. +-- +-- The bare @GET /_resolve/cluster@ form (no index expression) returns +-- information about every configured remote cluster without doing any +-- index matching; in that shape the server omits the @matching_indices@, +-- @error@ and @version@ fields, which are modelled as 'Maybe' so the same +-- parser handles both responses. The querying cluster is keyed under the +-- literal string @"(local)"@. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.ResolveCluster + ( -- * Response + ResolveClusterResponse (..), + ResolveClusterInfo (..), + ResolveClusterVersion (..), + + -- * Options + ResolveClusterOptions (..), + defaultResolveClusterOptions, + resolveClusterOptionsParams, + + -- * Optics + resolveClusterResponseEntriesLens, + rciConnectedLens, + rciSkipUnavailableLens, + rciMatchingIndicesLens, + rciErrorLens, + rciVersionLens, + rcvBuildFlavorLens, + rcvMinimumIndexCompatibilityVersionLens, + rcvMinimumWireCompatibilityVersionLens, + rcvNumberLens, + rcoExpandWildcardsLens, + rcoIgnoreUnavailableLens, + rcoAllowNoIndicesLens, + rcoIgnoreThrottledLens, + rcoTimeoutLens, + ) +where + +import Data.Map.Strict qualified as M +import Data.Text qualified as T +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards +import Database.Bloodhound.Internal.Versions.Common.Types.Units + +-- | Top-level envelope of @GET /_resolve/cluster@: a map keyed by cluster +-- alias (with @"(local)"@ for the querying cluster). Each value carries +-- the connection state of that cluster. +newtype ResolveClusterResponse = ResolveClusterResponse + { resolveClusterResponseEntries :: M.Map Text ResolveClusterInfo + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +resolveClusterResponseEntriesLens :: Lens' ResolveClusterResponse (M.Map Text ResolveClusterInfo) +resolveClusterResponseEntriesLens = + lens resolveClusterResponseEntries (\x y -> x {resolveClusterResponseEntries = y}) + +-- | Per-cluster entry in a 'ResolveClusterResponse'. @connected@ and +-- @skip_unavailable@ are always present; the remaining fields are only +-- sent when an index expression was supplied (or, for @version@, when the +-- remote cluster is recent enough to report one). +data ResolveClusterInfo = ResolveClusterInfo + { rciConnected :: Bool, + rciSkipUnavailable :: Bool, + rciMatchingIndices :: Maybe Bool, + rciError :: Maybe Text, + rciVersion :: Maybe ResolveClusterVersion + } + deriving stock (Eq, Show) + +instance ToJSON ResolveClusterInfo where + toJSON ResolveClusterInfo {..} = + omitNulls + [ "connected" .= rciConnected, + "skip_unavailable" .= rciSkipUnavailable, + "matching_indices" .= rciMatchingIndices, + "error" .= rciError, + "version" .= rciVersion + ] + +instance FromJSON ResolveClusterInfo where + parseJSON (Object o) = + ResolveClusterInfo + <$> o .: "connected" + <*> o .: "skip_unavailable" + <*> o .:? "matching_indices" + <*> o .:? "error" + <*> o .:? "version" + parseJSON x = typeMismatch "ResolveClusterInfo" x + +rciConnectedLens :: Lens' ResolveClusterInfo Bool +rciConnectedLens = lens rciConnected (\x y -> x {rciConnected = y}) + +rciSkipUnavailableLens :: Lens' ResolveClusterInfo Bool +rciSkipUnavailableLens = lens rciSkipUnavailable (\x y -> x {rciSkipUnavailable = y}) + +rciMatchingIndicesLens :: Lens' ResolveClusterInfo (Maybe Bool) +rciMatchingIndicesLens = lens rciMatchingIndices (\x y -> x {rciMatchingIndices = y}) + +rciErrorLens :: Lens' ResolveClusterInfo (Maybe Text) +rciErrorLens = lens rciError (\x y -> x {rciError = y}) + +rciVersionLens :: Lens' ResolveClusterInfo (Maybe ResolveClusterVersion) +rciVersionLens = lens rciVersion (\x y -> x {rciVersion = y}) + +-- | @ElasticsearchVersionMinInfo@ object nested under @version@. All four +-- fields are required when the object is present, but the object itself is +-- optional (see 'rciVersion'). +data ResolveClusterVersion = ResolveClusterVersion + { rcvBuildFlavor :: Text, + rcvMinimumIndexCompatibilityVersion :: Text, + rcvMinimumWireCompatibilityVersion :: Text, + rcvNumber :: Text + } + deriving stock (Eq, Show) + +instance ToJSON ResolveClusterVersion where + toJSON ResolveClusterVersion {..} = + object + [ "build_flavor" .= rcvBuildFlavor, + "minimum_index_compatibility_version" .= rcvMinimumIndexCompatibilityVersion, + "minimum_wire_compatibility_version" .= rcvMinimumWireCompatibilityVersion, + "number" .= rcvNumber + ] + +instance FromJSON ResolveClusterVersion where + parseJSON (Object o) = + ResolveClusterVersion + <$> o .: "build_flavor" + <*> o .: "minimum_index_compatibility_version" + <*> o .: "minimum_wire_compatibility_version" + <*> o .: "number" + parseJSON x = typeMismatch "ResolveClusterVersion" x + +rcvBuildFlavorLens :: Lens' ResolveClusterVersion Text +rcvBuildFlavorLens = lens rcvBuildFlavor (\x y -> x {rcvBuildFlavor = y}) + +rcvMinimumIndexCompatibilityVersionLens :: Lens' ResolveClusterVersion Text +rcvMinimumIndexCompatibilityVersionLens = + lens rcvMinimumIndexCompatibilityVersion (\x y -> x {rcvMinimumIndexCompatibilityVersion = y}) + +rcvMinimumWireCompatibilityVersionLens :: Lens' ResolveClusterVersion Text +rcvMinimumWireCompatibilityVersionLens = + lens rcvMinimumWireCompatibilityVersion (\x y -> x {rcvMinimumWireCompatibilityVersion = y}) + +rcvNumberLens :: Lens' ResolveClusterVersion Text +rcvNumberLens = lens rcvNumber (\x y -> x {rcvNumber = y}) + +-- | URI parameters accepted by @GET /_resolve/cluster[\/{name}]@. The +-- index-filtering parameters (@expand_wildcards@, @ignore_unavailable@, +-- @allow_no_indices@) are documented as valid only when an index +-- expression is supplied; @timeout@ applies to both forms. Every field is +-- optional so 'defaultResolveClusterOptions' renders to no query string. +-- +-- @ignore_throttled@ is included for completeness but is marked +-- /deprecated/ in the Elasticsearch 9 docs +-- (); +-- both the field and its lens carry a 'DEPRECATED' pragma. Avoid it in +-- new code. +data ResolveClusterOptions = ResolveClusterOptions + { rcoExpandWildcards :: Maybe (NonEmpty ExpandWildcards), + rcoIgnoreUnavailable :: Maybe Bool, + rcoAllowNoIndices :: Maybe Bool, + rcoIgnoreThrottled :: Maybe Bool, + rcoTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +{-# DEPRECATED + rcoIgnoreThrottled, + rcoIgnoreThrottledLens + "ignore_throttled is marked deprecated in the ES9 /_resolve/cluster docs; avoid it in new requests. See https://www.elastic.co/docs/reference/elasticsearch/apis/get-resolve-cluster" + #-} + +-- | 'ResolveClusterOptions' with every parameter set to 'Nothing'. Produces +-- no query string. +defaultResolveClusterOptions :: ResolveClusterOptions +defaultResolveClusterOptions = + ResolveClusterOptions + { rcoExpandWildcards = Nothing, + rcoIgnoreUnavailable = Nothing, + rcoAllowNoIndices = Nothing, + rcoIgnoreThrottled = Nothing, + rcoTimeout = Nothing + } + +rcoExpandWildcardsLens :: Lens' ResolveClusterOptions (Maybe (NonEmpty ExpandWildcards)) +rcoExpandWildcardsLens = lens rcoExpandWildcards (\x y -> x {rcoExpandWildcards = y}) + +rcoIgnoreUnavailableLens :: Lens' ResolveClusterOptions (Maybe Bool) +rcoIgnoreUnavailableLens = lens rcoIgnoreUnavailable (\x y -> x {rcoIgnoreUnavailable = y}) + +rcoAllowNoIndicesLens :: Lens' ResolveClusterOptions (Maybe Bool) +rcoAllowNoIndicesLens = lens rcoAllowNoIndices (\x y -> x {rcoAllowNoIndices = y}) + +rcoIgnoreThrottledLens :: Lens' ResolveClusterOptions (Maybe Bool) +rcoIgnoreThrottledLens = lens rcoIgnoreThrottled (\x y -> x {rcoIgnoreThrottled = y}) + +rcoTimeoutLens :: Lens' ResolveClusterOptions (Maybe (TimeUnits, Word32)) +rcoTimeoutLens = lens rcoTimeout (\x y -> x {rcoTimeout = y}) + +-- | Render 'ResolveClusterOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' fields are omitted, so +-- 'defaultResolveClusterOptions' produces an empty list. +resolveClusterOptionsParams :: ResolveClusterOptions -> [(Text, Maybe Text)] +resolveClusterOptionsParams opts = + catMaybes + [ ("expand_wildcards",) . Just . renderExpandWildcards <$> rcoExpandWildcards opts, + ("ignore_unavailable",) . Just . renderBool <$> rcoIgnoreUnavailable opts, + ("allow_no_indices",) . Just . renderBool <$> rcoAllowNoIndices opts, + ("ignore_throttled",) . Just . renderBool <$> rcoIgnoreThrottled opts, + ("timeout",) . Just . renderDuration <$> rcoTimeout opts + ] + where + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + renderDuration (u, n) = showText n <> timeUnitsSuffix u + renderBool True = "true" + renderBool False = "false" diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/SimulateIngest.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/SimulateIngest.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/SimulateIngest.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.SimulateIngest +-- Description : Types for the Elasticsearch simulate-ingest v2 API +-- +-- Defines the request and response shapes for the simulate-ingest v2 +-- endpoint (experimental since 8.12), distinct from the older +-- @POST /_ingest/pipeline/{id}/_simulate@ pipeline-simulation API: +-- +-- * @POST /_ingest/_simulate@ +-- * @POST /_ingest/{index}/_simulate@ (query params: @pipeline@, +-- @merge_type=index|template@) +-- +-- Unlike the pipeline simulate API, simulate-ingest v2 resolves index +-- templates, component templates and mappings against the supplied +-- documents, returning the @executed_pipelines@ and the +-- @effective_mapping@ for each document. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.SimulateIngest + ( -- * Query options + SimulateIngestMergeType (..), + simulateIngestMergeTypeToText, + simulateIngestMergeTypeFromText, + SimulateIngestOptions (..), + defaultSimulateIngestOptions, + simulateIngestOptionsParams, + simulateIngestOptionsPipelineLens, + simulateIngestOptionsMergeTypeLens, + + -- * Request body + SimulateIngestDoc (..), + simulateIngestDocIdLens, + simulateIngestDocIndexLens, + simulateIngestDocSourceLens, + SimulateIngestRequest (..), + simulateIngestRequestDocsLens, + simulateIngestRequestComponentTemplateSubstitutionsLens, + simulateIngestRequestIndexTemplateSubstitutionsLens, + simulateIngestRequestMappingAdditionLens, + + -- * Response body + SimulateIngestResponseInner (..), + simulateIngestResponseInnerIdLens, + simulateIngestResponseInnerIndexLens, + simulateIngestResponseInnerSourceLens, + simulateIngestResponseInnerExecutedPipelinesLens, + simulateIngestResponseInnerIgnoredFieldsLens, + simulateIngestResponseInnerErrorLens, + simulateIngestResponseInnerEffectiveMappingLens, + SimulateIngestResponseDoc (..), + simulateIngestResponseDocDocLens, + SimulateIngestResponse (..), + simulateIngestResponseDocsLens, + ) +where + +import Data.Aeson +import Database.Bloodhound.Internal.Utils.Imports + +-- | The @merge_type@ query parameter of the simulate-ingest endpoints, +-- controlling how the supplied and existing templates are merged. +data SimulateIngestMergeType + = SimulateIngestMergeIndex + | SimulateIngestMergeTemplate + deriving stock (Eq, Show, Bounded, Enum) + +simulateIngestMergeTypeToText :: SimulateIngestMergeType -> Text +simulateIngestMergeTypeToText SimulateIngestMergeIndex = "index" +simulateIngestMergeTypeToText SimulateIngestMergeTemplate = "template" + +simulateIngestMergeTypeFromText :: Text -> Maybe SimulateIngestMergeType +simulateIngestMergeTypeFromText "index" = Just SimulateIngestMergeIndex +simulateIngestMergeTypeFromText "template" = Just SimulateIngestMergeTemplate +simulateIngestMergeTypeFromText _ = Nothing + +-- | Optional URI query parameters for the simulate-ingest endpoints: +-- @pipeline@ (an explicit pipeline id to run) and @merge_type@. +data SimulateIngestOptions = SimulateIngestOptions + { sioPipeline :: Maybe Text, + sioMergeType :: Maybe SimulateIngestMergeType + } + deriving stock (Eq, Show) + +-- | 'SimulateIngestOptions' with both fields set to 'Nothing'. Renders no +-- query parameters. +defaultSimulateIngestOptions :: SimulateIngestOptions +defaultSimulateIngestOptions = + SimulateIngestOptions + { sioPipeline = Nothing, + sioMergeType = Nothing + } + +simulateIngestOptionsPipelineLens :: Lens' SimulateIngestOptions (Maybe Text) +simulateIngestOptionsPipelineLens = + lens sioPipeline (\x y -> x {sioPipeline = y}) + +simulateIngestOptionsMergeTypeLens :: Lens' SimulateIngestOptions (Maybe SimulateIngestMergeType) +simulateIngestOptionsMergeTypeLens = + lens sioMergeType (\x y -> x {sioMergeType = y}) + +-- | Render 'SimulateIngestOptions' as a list of @(key, value)@ query +-- parameters suitable for 'withQueries'. 'Nothing' fields are omitted, +-- so 'defaultSimulateIngestOptions' produces @[]@. +simulateIngestOptionsParams :: SimulateIngestOptions -> [(Text, Maybe Text)] +simulateIngestOptionsParams SimulateIngestOptions {..} = + catMaybes + [ ("pipeline",) . Just <$> sioPipeline, + ("merge_type",) . Just . simulateIngestMergeTypeToText <$> sioMergeType + ] + +-- | A single input document in the simulate-ingest request body. The +-- wire shape is @{"_id": "...", "_index": "...", "_source": {...}}@; +-- only @_source@ is required, @_id@ and @_index@ are optional. +data SimulateIngestDoc = SimulateIngestDoc + { sidId :: Maybe Text, + sidIndex :: Maybe Text, + sidSource :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SimulateIngestDoc where + toJSON SimulateIngestDoc {..} = + omitNulls + [ "_id" .= sidId, + "_index" .= sidIndex, + "_source" .= sidSource + ] + +instance FromJSON SimulateIngestDoc where + parseJSON = withObject "SimulateIngestDoc" $ \o -> + SimulateIngestDoc + <$> o .:? "_id" + <*> o .:? "_index" + <*> o .: "_source" + +simulateIngestDocIdLens :: Lens' SimulateIngestDoc (Maybe Text) +simulateIngestDocIdLens = + lens sidId (\x y -> x {sidId = y}) + +simulateIngestDocIndexLens :: Lens' SimulateIngestDoc (Maybe Text) +simulateIngestDocIndexLens = + lens sidIndex (\x y -> x {sidIndex = y}) + +simulateIngestDocSourceLens :: Lens' SimulateIngestDoc Value +simulateIngestDocSourceLens = + lens sidSource (\x y -> x {sidSource = y}) + +-- | The top-level simulate-ingest request body. @docs@ is the mandatory +-- list of 'SimulateIngestDoc's; the three substitution\/addition objects +-- are optional template/mapping overrides carried as opaque 'Value's. +data SimulateIngestRequest = SimulateIngestRequest + { sirDocs :: [SimulateIngestDoc], + sirComponentTemplateSubstitutions :: Maybe Value, + sirIndexTemplateSubstitutions :: Maybe Value, + sirMappingAddition :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON SimulateIngestRequest where + toJSON SimulateIngestRequest {..} = + object $ + "docs" .= sirDocs + : [ pair + | pair <- + [ "component_template_substitutions" .= sirComponentTemplateSubstitutions, + "index_template_substitutions" .= sirIndexTemplateSubstitutions, + "mapping_addition" .= sirMappingAddition + ], + keep pair + ] + where + -- The @docs@ array is a required key, so it is emitted unconditionally + -- (even when empty); only the optional substitution objects are dropped + -- when 'Nothing'. Note that 'omitNulls' cannot be used here because it + -- also strips empty arrays, which would silently drop an empty @docs@. + keep (_, Null) = False + keep _ = True + +instance FromJSON SimulateIngestRequest where + parseJSON = withObject "SimulateIngestRequest" $ \o -> + SimulateIngestRequest + <$> o .:? "docs" .!= [] + <*> o .:? "component_template_substitutions" + <*> o .:? "index_template_substitutions" + <*> o .:? "mapping_addition" + +simulateIngestRequestDocsLens :: Lens' SimulateIngestRequest [SimulateIngestDoc] +simulateIngestRequestDocsLens = + lens sirDocs (\x y -> x {sirDocs = y}) + +simulateIngestRequestComponentTemplateSubstitutionsLens :: Lens' SimulateIngestRequest (Maybe Value) +simulateIngestRequestComponentTemplateSubstitutionsLens = + lens sirComponentTemplateSubstitutions (\x y -> x {sirComponentTemplateSubstitutions = y}) + +simulateIngestRequestIndexTemplateSubstitutionsLens :: Lens' SimulateIngestRequest (Maybe Value) +simulateIngestRequestIndexTemplateSubstitutionsLens = + lens sirIndexTemplateSubstitutions (\x y -> x {sirIndexTemplateSubstitutions = y}) + +simulateIngestRequestMappingAdditionLens :: Lens' SimulateIngestRequest (Maybe Value) +simulateIngestRequestMappingAdditionLens = + lens sirMappingAddition (\x y -> x {sirMappingAddition = y}) + +-- | The inner @doc@ object of a simulate-ingest response entry. The +-- server typically emits @_id@, @_index@, @_source@ and +-- @executed_pipelines@; @ignored_fields@, @error@ and +-- @effective_mapping@ are optional. All fields are decoded leniently +-- (the identity fields are 'Maybe' to tolerate entries that omit them), +-- and the optional objects are carried as opaque 'Value's. +data SimulateIngestResponseInner = SimulateIngestResponseInner + { siriId :: Maybe Text, + siriIndex :: Maybe Text, + siriSource :: Maybe Value, + siriExecutedPipelines :: [Text], + siriIgnoredFields :: Maybe Value, + siriError :: Maybe Value, + siriEffectiveMapping :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON SimulateIngestResponseInner where + toJSON SimulateIngestResponseInner {..} = + object $ + "executed_pipelines" .= siriExecutedPipelines + : [ pair + | pair <- + [ "_id" .= siriId, + "_index" .= siriIndex, + "_source" .= siriSource, + "ignored_fields" .= siriIgnoredFields, + "error" .= siriError, + "effective_mapping" .= siriEffectiveMapping + ], + keep pair + ] + where + -- @executed_pipelines@ is emitted unconditionally (even when empty) + -- because 'omitNulls' would otherwise strip an empty array. The + -- identity fields ('Maybe') and optional objects are dropped when + -- 'Nothing'. + keep (_, Null) = False + keep _ = True + +instance FromJSON SimulateIngestResponseInner where + parseJSON = withObject "SimulateIngestResponseInner" $ \o -> + SimulateIngestResponseInner + <$> o .:? "_id" + <*> o .:? "_index" + <*> o .:? "_source" + <*> o .:? "executed_pipelines" .!= [] + <*> o .:? "ignored_fields" + <*> o .:? "error" + <*> o .:? "effective_mapping" + +simulateIngestResponseInnerIdLens :: Lens' SimulateIngestResponseInner (Maybe Text) +simulateIngestResponseInnerIdLens = + lens siriId (\x y -> x {siriId = y}) + +simulateIngestResponseInnerIndexLens :: Lens' SimulateIngestResponseInner (Maybe Text) +simulateIngestResponseInnerIndexLens = + lens siriIndex (\x y -> x {siriIndex = y}) + +simulateIngestResponseInnerSourceLens :: Lens' SimulateIngestResponseInner (Maybe Value) +simulateIngestResponseInnerSourceLens = + lens siriSource (\x y -> x {siriSource = y}) + +simulateIngestResponseInnerExecutedPipelinesLens :: Lens' SimulateIngestResponseInner [Text] +simulateIngestResponseInnerExecutedPipelinesLens = + lens siriExecutedPipelines (\x y -> x {siriExecutedPipelines = y}) + +simulateIngestResponseInnerIgnoredFieldsLens :: Lens' SimulateIngestResponseInner (Maybe Value) +simulateIngestResponseInnerIgnoredFieldsLens = + lens siriIgnoredFields (\x y -> x {siriIgnoredFields = y}) + +simulateIngestResponseInnerErrorLens :: Lens' SimulateIngestResponseInner (Maybe Value) +simulateIngestResponseInnerErrorLens = + lens siriError (\x y -> x {siriError = y}) + +simulateIngestResponseInnerEffectiveMappingLens :: Lens' SimulateIngestResponseInner (Maybe Value) +simulateIngestResponseInnerEffectiveMappingLens = + lens siriEffectiveMapping (\x y -> x {siriEffectiveMapping = y}) + +-- | A single entry of the simulate-ingest @docs@ response array; the +-- server wraps each result in a @doc@ key. +newtype SimulateIngestResponseDoc = SimulateIngestResponseDoc + { srdDoc :: SimulateIngestResponseInner + } + deriving stock (Eq, Show) + +instance ToJSON SimulateIngestResponseDoc where + toJSON SimulateIngestResponseDoc {..} = + object ["doc" .= srdDoc] + +instance FromJSON SimulateIngestResponseDoc where + parseJSON = withObject "SimulateIngestResponseDoc" $ \o -> + SimulateIngestResponseDoc <$> o .: "doc" + +simulateIngestResponseDocDocLens :: Lens' SimulateIngestResponseDoc SimulateIngestResponseInner +simulateIngestResponseDocDocLens = + lens srdDoc (\x y -> x {srdDoc = y}) + +-- | Response body of the simulate-ingest endpoints: a @docs@ array of +-- 'SimulateIngestResponseDoc'. An empty or missing array decodes to @[]@. +newtype SimulateIngestResponse = SimulateIngestResponse + { sirResponseDocs :: [SimulateIngestResponseDoc] + } + deriving stock (Eq, Show) + deriving newtype (Semigroup, Monoid) + +instance ToJSON SimulateIngestResponse where + toJSON SimulateIngestResponse {..} = + object ["docs" .= sirResponseDocs] + +instance FromJSON SimulateIngestResponse where + parseJSON = withObject "SimulateIngestResponse" $ \o -> + SimulateIngestResponse <$> o .:? "docs" .!= [] + +simulateIngestResponseDocsLens :: Lens' SimulateIngestResponse [SimulateIngestResponseDoc] +simulateIngestResponseDocsLens = + lens sirResponseDocs (\x y -> x {sirResponseDocs = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/Streams.hs b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/Streams.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/ElasticSearch9/Types/Streams.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.Streams +-- Description : Types for the Elasticsearch 9 Streams API +-- +-- Defines the request and response shapes for the Elasticsearch 9 Streams +-- API (experimental, added in 9.1), used to manage the built-in named +-- streams (@logs@, @logs.otel@, @logs.ecs@): +-- +-- * @GET /_streams/status@ — 'StreamsStatusResponse' (a map from stream +-- name to its 'StreamStatus'). +-- * @POST /_streams/{name}/_enable@ — returns 'Acknowledged'. +-- * @POST /_streams/{name}/_disable@ — returns 'Acknowledged'. +-- +-- The status response is a JSON object whose /keys/ are the stream names +-- (e.g. @logs@, @logs.otel@) and whose /values/ carry the per-stream +-- @enabled@ flag. Because the names contain dots and may grow over time, +-- the response is modelled as a 'Map' from 'Text' to 'StreamStatus' +-- rather than a fixed record. +-- +-- See +-- . +module Database.Bloodhound.Internal.Versions.ElasticSearch9.Types.Streams + ( -- * Identity + StreamName (..), + unStreamName, + + -- * Status response + StreamStatus (..), + streamStatusEnabledLens, + StreamsStatusResponse (..), + streamsStatusResponseLens, + streamStatusFor, + + -- * Status options + GetStreamsStatusOptions (..), + defaultGetStreamsStatusOptions, + getStreamsStatusOptionsParams, + getStreamsStatusOptionsMasterTimeoutLens, + + -- * Enable/disable options + StreamsActionOptions (..), + defaultStreamsActionOptions, + streamsActionOptionsParams, + streamsActionOptionsMasterTimeoutLens, + streamsActionOptionsTimeoutLens, + ) +where + +import Data.Aeson +import Data.Map.Strict qualified as M +import Data.String (IsString) +import Data.Word (Word32) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Units + +-- | The @@ path segment of @\/_streams\/\/_enable@ (or +-- @_disable@). Elasticsearch 9 ships three built-in streams — @logs@, +-- @logs.otel@ and @logs.ecs@ — but the identifier is a plain opaque +-- string (it contains dots, so it is /not/ an 'IndexName'), hence this +-- dedicated newtype. +newtype StreamName = StreamName Text + deriving stock (Eq, Show, Ord) + deriving newtype (Hashable, IsString, ToJSON, FromJSON) + +unStreamName :: StreamName -> Text +unStreamName (StreamName x) = x + +-- | Per-stream status entry, the value associated with each stream name +-- in the 'StreamsStatusResponse' map. The wire shape is +-- @{"enabled": }@. +data StreamStatus = StreamStatus + { ssEnabled :: Bool + } + deriving stock (Eq, Show) + +instance ToJSON StreamStatus where + toJSON StreamStatus {..} = + object ["enabled" .= ssEnabled] + +instance FromJSON StreamStatus where + parseJSON = withObject "StreamStatus" $ \o -> + StreamStatus <$> o .: "enabled" + +streamStatusEnabledLens :: Lens' StreamStatus Bool +streamStatusEnabledLens = lens ssEnabled (\x y -> x {ssEnabled = y}) + +-- | Response body of @GET /_streams/status@. The whole JSON object is a +-- map from stream name (e.g. @logs@, @logs.otel@, @logs.ecs@) to its +-- 'StreamStatus'. aeson decodes a JSON object directly into a +-- 'Map' 'Text' 'StreamStatus', so the newtype derives the instances. +newtype StreamsStatusResponse = StreamsStatusResponse + { ssrStreams :: M.Map Text StreamStatus + } + deriving stock (Eq, Show) + deriving newtype (Semigroup, Monoid, FromJSON, ToJSON) + +streamsStatusResponseLens :: Lens' StreamsStatusResponse (M.Map Text StreamStatus) +streamsStatusResponseLens = lens ssrStreams (\x y -> x {ssrStreams = y}) + +-- | Look up the status of a named stream in a 'StreamsStatusResponse'. +-- Returns 'Nothing' when the stream is absent (e.g. not yet created). +streamStatusFor :: StreamName -> StreamsStatusResponse -> Maybe StreamStatus +streamStatusFor (StreamName name) (StreamsStatusResponse m) = + M.lookup name m + +-- | URI parameters accepted by @GET /_streams/status@: only +-- @master_timeout@ (the period to wait for a connection to the master +-- node). Optional, so 'defaultGetStreamsStatusOptions' renders to no +-- query string. +-- +-- This is deliberately a separate type from 'StreamsActionOptions' +-- (which also carries @timeout@): @GET /_streams/status@ does not +-- accept @timeout@, and emitting it would be invalid. This mirrors the +-- selective-param modelling precedent elsewhere in the codebase. +newtype GetStreamsStatusOptions = GetStreamsStatusOptions + { gssoMasterTimeout :: Maybe (TimeUnits, Word32) + } + deriving stock (Eq, Show) + +-- | 'GetStreamsStatusOptions' with @master_timeout@ set to 'Nothing'. +-- Produces no query string. +defaultGetStreamsStatusOptions :: GetStreamsStatusOptions +defaultGetStreamsStatusOptions = + GetStreamsStatusOptions {gssoMasterTimeout = Nothing} + +-- | Render 'GetStreamsStatusOptions' as a list of @(key, value)@ pairs +-- suitable for 'withQueries'. 'Nothing' is omitted. +getStreamsStatusOptionsParams :: GetStreamsStatusOptions -> [(Text, Maybe Text)] +getStreamsStatusOptionsParams opts = + catMaybes + [ ("master_timeout",) . Just . renderDuration <$> gssoMasterTimeout opts + ] + where + renderDuration (u, n) = showText n <> timeUnitsSuffix u + +getStreamsStatusOptionsMasterTimeoutLens :: Lens' GetStreamsStatusOptions (Maybe (TimeUnits, Word32)) +getStreamsStatusOptionsMasterTimeoutLens = + lens gssoMasterTimeout (\x y -> x {gssoMasterTimeout = y}) + +-- | Optional URI query parameters for the @\/_streams\/\/_enable@ +-- and @_disable@ endpoints: @master_timeout@ and @timeout@ (both +-- time-value strings, e.g. @30s@). Both are optional and modelled as +-- 'Maybe' 'Text'; 'defaultStreamsActionOptions' renders no query string. +data StreamsActionOptions = StreamsActionOptions + { saoMasterTimeout :: Maybe Text, + saoTimeout :: Maybe Text + } + deriving stock (Eq, Show) + +-- | 'StreamsActionOptions' with both fields set to 'Nothing'. Renders no +-- query parameters. +defaultStreamsActionOptions :: StreamsActionOptions +defaultStreamsActionOptions = + StreamsActionOptions + { saoMasterTimeout = Nothing, + saoTimeout = Nothing + } + +streamsActionOptionsMasterTimeoutLens :: Lens' StreamsActionOptions (Maybe Text) +streamsActionOptionsMasterTimeoutLens = + lens saoMasterTimeout (\x y -> x {saoMasterTimeout = y}) + +streamsActionOptionsTimeoutLens :: Lens' StreamsActionOptions (Maybe Text) +streamsActionOptionsTimeoutLens = + lens saoTimeout (\x y -> x {saoTimeout = y}) + +-- | Render 'StreamsActionOptions' as a list of @(key, value)@ query +-- parameters suitable for 'withQueries'. 'Nothing' fields are omitted, +-- so 'defaultStreamsActionOptions' produces @[]@. +streamsActionOptionsParams :: StreamsActionOptions -> [(Text, Maybe Text)] +streamsActionOptionsParams StreamsActionOptions {..} = + catMaybes + [ ("master_timeout",) . Just <$> saoMasterTimeout, + ("timeout",) . Just <$> saoTimeout + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types.hs @@ -0,0 +1,44 @@ +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types + ( module Reexport, + ISMPolicyRequest (..), + ISMPolicyResponse (..), + ISMPolicyBody (..), + PolicyId (..), + PutISMPolicyResponse (..), + MLTaskId (..), + MLTaskType (..), + MLTaskState (..), + MLTaskInfo (..), + SQLRequest (..), + PPLRequest (..), + SQLParameter (..), + SQLCursor (..), + SQLCursorRequest (..), + SQLColumn (..), + SQLResult (..), + SQLCloseResult (..), + SQLPluginStats (..), + ) +where + +-- Hide the Common Security 'User' so it does not collide with the +-- OpenSearch anomaly-detection 'User' re-exported below, and the ES +-- X-Pack Transform types (Common.Types.Transform) that collide with the +-- OpenSearch Index Transforms plugin (IndexTransforms). +import Database.Bloodhound.Common.Types as Reexport hiding + ( PreviewTransformResponse, + TransformId, + TransformStats, + User, + unTransformId, + ) +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.AnomalyDetection as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.ISM as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.KnnModel as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.KnnStats as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.KnnTrain as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.MLModel as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.MLStats as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.MLTask as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.SQLPPL as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.SQLStats as Reexport diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/Alerting.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/Alerting.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/Alerting.hs @@ -0,0 +1,2153 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.Alerting + ( -- * Identifiers + MonitorId (..), + DestinationId (..), + + -- * Discriminators + AlertType (..), + alertTypeText, + MonitorType (..), + monitorTypeText, + + -- * Schedule + Schedule (..), + SchedulePeriod (..), + ScheduleCron (..), + + -- * Inputs, triggers, actions + MonitorInput (..), + Trigger (..), + Action (..), + MessageTemplate (..), + Throttle (..), + AlertingShards (..), + + -- * Monitor and response wrappers + Monitor (..), + MonitorResponse (..), + DeleteMonitorResponse (..), + + -- * Monitor search (POST /_plugins/_alerting/monitors/_search) + MonitorsSearchQuery (..), + defaultMonitorsSearchQuery, + MonitorHit (..), + MonitorsTotal (..), + MonitorsTotalRelation (..), + monitorsTotalRelationText, + SearchMonitorsResponse (..), + searchMonitorsResponseMonitors, + + -- * Execute monitor (POST /_plugins/_alerting/monitors/{id}/_execute) + ExecuteMonitorRequest (..), + defaultExecuteMonitorRequest, + ExecuteMonitorResponse (..), + + -- * Destinations (GET /_plugins/_alerting/destinations) + DestinationType (..), + destinationTypeText, + Destination (..), + DestinationSortOrder (..), + destinationSortOrderText, + DestinationListOptions (..), + defaultDestinationListOptions, + destinationListOptionsParams, + GetDestinationsResponse (..), + + -- * Destination lifecycle (POST/PUT/DELETE /_plugins/_alerting/destinations[/{id}]) + DestinationResponse (..), + DeleteDestinationResponse (..), + + -- * Get alerts (GET /_plugins/_alerting/monitors/alerts) + AlertSortOrder (..), + alertSortOrderText, + AlertState (..), + alertStateText, + GetAlertsOptions (..), + defaultGetAlertsOptions, + getAlertsOptionsParams, + Alert (..), + GetAlertsResponse (..), + + -- * Acknowledge alert (POST /_plugins/_alerting/monitors/{id}/_acknowledge/alerts) + AcknowledgeAlertRequest (..), + defaultAcknowledgeAlertRequest, + AcknowledgeAlertResponse (..), + + -- * Monitor stats (GET /_plugins/_alerting/stats[/...]) + MonitorStats (..), + MonitorStatsNodesCount (..), + + -- * Email account lifecycle (POST/PUT/GET/DELETE /_plugins/_alerting/destinations/email_accounts[/{id}]) + EmailAccountId (..), + EmailAccount (..), + EmailAccountResponse (..), + DeleteEmailAccountResponse (..), + + -- * Email group lifecycle (POST/PUT/GET/DELETE /_plugins/_alerting/destinations/email_groups[/{id}]) + EmailGroupId (..), + EmailGroupRecipient (..), + EmailGroup (..), + EmailGroupResponse (..), + DeleteEmailGroupResponse (..), + + -- * Email account search (POST /_plugins/_alerting/destinations/email_accounts/_search) + EmailAccountSearchQuery (..), + defaultEmailAccountSearchQuery, + EmailAccountSearchHit (..), + SearchEmailAccountsResponse (..), + + -- * Email group search (POST /_plugins/_alerting/destinations/email_groups/_search) + EmailGroupSearchQuery (..), + defaultEmailGroupSearchQuery, + EmailGroupSearchHit (..), + SearchEmailGroupsResponse (..), + + -- * Internal helpers (re-exported for the test suite) + alertingTriggerWrapperKeys, + ) +where + +import Data.Aeson +import Data.Aeson.Key qualified as K (fromText) +import Data.Aeson.KeyMap qualified as KM +import Data.Int (Int64) +import Database.Bloodhound.Internal.Utils.Imports +import Numeric.Natural (Natural) + +-- $schema +-- +-- The Alerting plugin (see +-- ) +-- runs scheduled monitors over cluster data and dispatches actions +-- (notifications) to destinations when trigger conditions fire. This +-- module covers the monitor lifecycle endpoints +-- (@POST \/\/_plugins\/_alerting\/monitors@ etc.) for OpenSearch 1.x. +-- +-- The wire shape of a 'Monitor' is a discriminated object: the +-- @monitor_type@ field selects one of several execution models +-- (query-level, bucket-level, document-level, cluster-metrics, remote), +-- and the @inputs@ and @triggers@ arrays carry per-kind payloads whose +-- exact shape varies widely. Following the pragmatic precedent set by +-- the ML Commons @predict@ endpoint, this module types the /shell/ — +-- the stable fields common to every monitor (name, enabled, schedule, +-- trigger names\/severities, action destination ids) — and models the +-- per-kind payloads as opaque aeson 'Value's. This keeps the public +-- surface small and stable while letting callers construct and inspect +-- any monitor kind, including ones the docs page does not enumerate. +-- Unknown top-level keys are preserved verbatim in 'monitorOther' so +-- future plugin additions and the @ui_metadata@\/@metadata@ fields +-- round-trip cleanly. +-- +-- The three response wrappers are modelled distinctly because they are +-- distinct on the wire: +-- +-- * 'MonitorResponse' wraps the create\/update response +-- (@{_id,_version,_seq_no,_primary_term, monitor:{...}}@). +-- * A bare 'Monitor' is the get-monitor response body (the @monitor@ +-- field is unwrapped by the 'FromJSON' instance of the endpoint +-- wrapper — see 'getMonitor'). +-- * 'DeleteMonitorResponse' mirrors the standard Elasticsearch +-- delete-document response. It deliberately deviates from the bead's +-- @m 'Acknowledged'@ acceptance (the endpoint returns @_shards@, not +-- @acknowledged@ — see the Haddock on 'DeleteMonitorResponse' and the +-- changelog entry for bloodhound-04f.6.7.4). +-- +-- Doc-level monitors were introduced in OpenSearch 2.0, so OS 1.x +-- callers must not construct 'MonitorTypeDocLevel'; the type still +-- carries the constructor because the wire grammar is identical. + +-- | The server-assigned identifier of a monitor. Wraps 'Text' so it +-- round-trips as a bare JSON string but stays distinct from +-- 'Database.Bloodhound.Common.Types.IndexName' and friends at the type +-- level. +newtype MonitorId = MonitorId {unMonitorId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The server-assigned identifier of an alerting destination. Wraps +-- 'Text' so it round-trips as a bare JSON string but stays distinct +-- from 'MonitorId' and 'Database.Bloodhound.Common.Types.IndexName' at +-- the type level. Used by the update\/delete destination endpoints +-- (@PUT@\/@DELETE /_plugins/_alerting/destinations/{id}@). +newtype DestinationId = DestinationId {unDestinationId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The top-level @type@ field of a monitor document. Documented as the +-- constant @"monitor"@ for non-composite monitors (composite monitors +-- use @"workflow"@ and live behind a separate API not covered here). +-- Unknown values fall through to 'AlertTypeOther' rather than +-- parse-failing, because the field is informational on requests and the +-- server is the authority. +data AlertType + = AlertTypeMonitor + | AlertTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for an 'AlertType'. +alertTypeText :: AlertType -> Text +alertTypeText AlertTypeMonitor = "monitor" +alertTypeText (AlertTypeOther t) = t + +instance ToJSON AlertType where + toJSON = toJSON . alertTypeText + +instance FromJSON AlertType where + parseJSON = withText "AlertType" $ \case + "monitor" -> pure AlertTypeMonitor + other -> pure (AlertTypeOther other) + +-- | The @monitor_type@ discriminator selecting the monitor's execution +-- model. The three documented on the API page are given dedicated +-- constructors; @cluster_metrics@, @remote@, and any future kind fall +-- through to 'MonitorTypeOther'. 'monitorTypeText' round-trips every +-- constructor. +data MonitorType + = MonitorTypeQueryLevel + | MonitorTypeBucketLevel + | MonitorTypeDocLevel + | MonitorTypeClusterMetrics + | MonitorTypeRemote + | MonitorTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'MonitorType'. Values are the lower-snake forms +-- documented at +-- . +monitorTypeText :: MonitorType -> Text +monitorTypeText = \case + MonitorTypeQueryLevel -> "query_level_monitor" + MonitorTypeBucketLevel -> "bucket_level_monitor" + MonitorTypeDocLevel -> "doc_level_monitor" + MonitorTypeClusterMetrics -> "cluster_metrics_monitor" + MonitorTypeRemote -> "remote_monitor" + MonitorTypeOther t -> t + +instance ToJSON MonitorType where + toJSON = toJSON . monitorTypeText + +instance FromJSON MonitorType where + parseJSON = + withText "MonitorType" $ \t -> + pure $ + case t of + "query_level_monitor" -> MonitorTypeQueryLevel + "bucket_level_monitor" -> MonitorTypeBucketLevel + "doc_level_monitor" -> MonitorTypeDocLevel + "cluster_metrics_monitor" -> MonitorTypeClusterMetrics + "remote_monitor" -> MonitorTypeRemote + other -> MonitorTypeOther other + +-- | The @schedule@ sub-object. The API documents two variants +-- (@period {interval, unit}@ and @cron {expression, timezone}@); any +-- other shape (e.g. a future schedule kind) is preserved verbatim via +-- 'ScheduleOther' so a decode never drops user data. +data Schedule + = PeriodSchedule SchedulePeriod + | CronSchedule ScheduleCron + | OtherSchedule Value + deriving stock (Eq, Show) + +instance ToJSON Schedule where + toJSON = \case + PeriodSchedule p -> object ["period" .= p] + CronSchedule c -> object ["cron" .= c] + OtherSchedule v -> v + +instance FromJSON Schedule where + parseJSON = withObject "Schedule" $ \o -> + (PeriodSchedule <$> o .: "period") + <|> (CronSchedule <$> o .: "cron") + <|> pure (OtherSchedule (Object o)) + +-- | The @period@ schedule variant. @unit@ is an upper-case string such +-- as @"MINUTES"@; the docs only enumerate @MINUTES@ in examples, so the +-- field is typed as 'Text' (not a closed enum) to avoid a library +-- release when OpenSearch advertises another unit. +data SchedulePeriod = SchedulePeriod + { schedulePeriodInterval :: Int, + schedulePeriodUnit :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SchedulePeriod where + toJSON SchedulePeriod {..} = + object + [ "interval" .= schedulePeriodInterval, + "unit" .= schedulePeriodUnit + ] + +instance FromJSON SchedulePeriod where + parseJSON = withObject "SchedulePeriod" $ \o -> + SchedulePeriod + <$> o .: "interval" + <*> o .: "unit" + +-- | The @cron@ schedule variant. @expression@ is a cron expression, +-- @timezone@ is a Java @ZoneId@ (e.g. @"America/Los_Angeles"@). +data ScheduleCron = ScheduleCron + { scheduleCronExpression :: Text, + scheduleCronTimezone :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON ScheduleCron where + toJSON ScheduleCron {..} = + omitNulls + [ "expression" .= scheduleCronExpression, + "timezone" .= scheduleCronTimezone + ] + +instance FromJSON ScheduleCron where + parseJSON = withObject "ScheduleCron" $ \o -> + ScheduleCron + <$> o .: "expression" + <*> o .:? "timezone" + +-- | A single element of the @inputs@ array. The shape varies by monitor +-- kind (@search@ for query\/bucket-level, @doc_level_input@ for +-- document-level, @clusters@ for cluster-metrics, ...), so the payload +-- is kept as an opaque 'Value' and callers decode it with their own +-- kind-specific parser. This mirrors the ML Commons @predict@ precedent. +newtype MonitorInput = MonitorInput {unMonitorInput :: Value} + deriving stock (Eq, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A @message_template@ \/ @subject_template@ sub-object. The server +-- injects @"lang": "mustache"@ on responses even when the request omits +-- it; both directions round-trip here. +data MessageTemplate = MessageTemplate + { messageTemplateSource :: Text, + messageTemplateLang :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON MessageTemplate where + toJSON MessageTemplate {..} = + omitNulls + [ "source" .= messageTemplateSource, + "lang" .= messageTemplateLang + ] + +instance FromJSON MessageTemplate where + parseJSON = withObject "MessageTemplate" $ \o -> + MessageTemplate + <$> o .: "source" + <*> o .:? "lang" + +-- | A @throttle@ sub-object (@{value, unit}@). Present on every action +-- response regardless of the @throttle_enabled@ flag. +data Throttle = Throttle + { throttleValue :: Int, + throttleUnit :: Text + } + deriving stock (Eq, Show) + +instance ToJSON Throttle where + toJSON Throttle {..} = + object + [ "value" .= throttleValue, + "unit" .= throttleUnit + ] + +instance FromJSON Throttle where + parseJSON = withObject "Throttle" $ \o -> + Throttle + <$> o .: "value" + <*> o .: "unit" + +-- | A single action within a trigger. The typed fields are those +-- documented across every action shape; the @action_execution_policy@ +-- sub-object (whose @action_execution_scope@ varies between +-- @per_alert@\/@per_action@ and carries @actionable_alerts@ enums) is +-- kept as an opaque 'Value', as is any forward-compat key in +-- 'actionOther'. +data Action = Action + { actionName :: Text, + actionDestinationId :: Text, + actionMessageTemplate :: MessageTemplate, + actionSubjectTemplate :: Maybe MessageTemplate, + actionThrottleEnabled :: Maybe Bool, + actionThrottle :: Maybe Throttle, + actionExecutionPolicy :: Maybe Value, + actionOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON Action where + toJSON a = + case actionOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= actionName a, + "destination_id" .= actionDestinationId a, + "message_template" .= actionMessageTemplate a, + "subject_template" .= actionSubjectTemplate a, + "throttle_enabled" .= actionThrottleEnabled a, + "throttle" .= actionThrottle a, + "action_execution_policy" .= actionExecutionPolicy a + ] + +instance FromJSON Action where + parseJSON = withObject "Action" $ \o -> do + Action + <$> o .: "name" + <*> o .: "destination_id" + <*> o .: "message_template" + <*> o .:? "subject_template" + <*> o .:? "throttle_enabled" + <*> o .:? "throttle" + <*> o .:? "action_execution_policy" + <*> pure (Object o) + +-- | The set of wrapper keys the Alerting plugin uses to discriminate +-- non-query-level triggers inside the @triggers@ array. Query-level +-- triggers carry their fields directly on the element; bucket-level and +-- document-level triggers wrap them under exactly one of these keys. +-- Re-exported so the test suite can pin the set. +alertingTriggerWrapperKeys :: [Text] +alertingTriggerWrapperKeys = ["bucket_level_trigger", "document_level_trigger"] + +-- | A single trigger. The wire shape differs by monitor kind: query-level +-- triggers put the fields directly on the element, while bucket-level +-- and document-level triggers wrap them under a discriminator key (see +-- 'alertingTriggerWrapperKeys'). The 'FromJSON' instance transparently +-- descends into the wrapper when present, so the typed fields are +-- readable uniformly; the full original element (wrapper and all) is +-- preserved in 'triggerOther' so a round-trip encode is lossless. +-- +-- @triggerSeverity@ is a 'Text' rather than an 'Int' because the wire +-- emits a string-encoded integer (e.g. @"1"@); parsing it as a number +-- would silently drop real monitor documents. +-- +-- @triggerCondition@ is an opaque 'Value' because the condition body +-- varies by trigger kind (@script {source, lang}@ for query-level; +-- @buckets_path@ + @parent_bucket_path@ + @script@ for bucket-level). +data Trigger = Trigger + { triggerName :: Text, + triggerSeverity :: Text, + triggerCondition :: Value, + triggerActions :: [Action], + triggerOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON Trigger where + toJSON t = + case triggerOther t of + Object o + | (wrapperKey, Object body) : _ <- wrappedBodies o -> + -- Captured element carried a discriminator wrapper key + -- (bucket-level / document-level). Re-inject the typed fields + -- into the wrapper body so caller modifications survive a + -- round-trip, and keep the wrapper as the sole top-level key + -- (matching the wire shape). + Object (KM.insert wrapperKey (Object (mergeIgnoringNulls typed body)) (deleteSeveral [wrapperKey] o)) + | otherwise -> + -- Query-level trigger: fields live directly on the element. + -- Overlay the typed fields on the captured object. + Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= triggerName t, + "severity" .= triggerSeverity t, + "condition" .= triggerCondition t, + "actions" .= triggerActions t + ] + wrappedBodies o = + [ (wk, v) + | k <- alertingTriggerWrapperKeys, + let wk = K.fromText k, + Just v <- [KM.lookup wk o] + ] + +instance FromJSON Trigger where + parseJSON = withObject "Trigger" $ \o' -> do + let body = unwrapTrigger o' + Trigger + <$> body .: "name" + <*> body .: "severity" + <*> body .: "condition" + <*> body .:? "actions" .!= [] + <*> pure (Object o') + where + unwrapTrigger o = + case catMaybes (mapMaybeWrapper o) of + (inner : _) -> inner + [] -> o + mapMaybeWrapper o = + [ KM.lookup (K.fromText k) o >>= (\case Object ob -> Just ob; _ -> Nothing) + | k <- alertingTriggerWrapperKeys + ] + +-- | The top-level 'Monitor' document. Typed fields cover every key the +-- API documents on requests and responses; 'monitorOther' captures the +-- whole original object so @ui_metadata@, @metadata@, future plugin +-- keys, and any field this type does not yet model round-trip +-- losslessly (mirrors the 'PendingTask' precedent). +data Monitor = Monitor + { monitorName :: Text, + monitorType :: Maybe AlertType, + monitorMonitorType :: Maybe MonitorType, + monitorEnabled :: Maybe Bool, + monitorEnabledTime :: Maybe Int64, + monitorLastUpdateTime :: Maybe Int64, + monitorSchemaVersion :: Maybe Int, + monitorSchedule :: Schedule, + monitorInputs :: [MonitorInput], + monitorTriggers :: [Trigger], + monitorUser :: Maybe Value, + monitorRbacRoles :: Maybe [Text], + monitorOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON Monitor where + toJSON m = + case monitorOther m of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= monitorName m, + "type" .= monitorType m, + "monitor_type" .= monitorMonitorType m, + "enabled" .= monitorEnabled m, + "enabled_time" .= monitorEnabledTime m, + "last_update_time" .= monitorLastUpdateTime m, + "schema_version" .= monitorSchemaVersion m, + "schedule" .= monitorSchedule m, + "inputs" .= monitorInputs m, + "triggers" .= monitorTriggers m, + "user" .= monitorUser m, + "rbac_roles" .= monitorRbacRoles m + ] + +instance FromJSON Monitor where + parseJSON = withObject "Monitor" $ \o -> + Monitor + <$> o .: "name" + <*> o .:? "type" + <*> o .:? "monitor_type" + <*> o .:? "enabled" + <*> o .:? "enabled_time" + <*> o .:? "last_update_time" + <*> o .:? "schema_version" + <*> o .: "schedule" + <*> o .:? "inputs" .!= [] + <*> o .:? "triggers" .!= [] + <*> o .:? "user" + <*> o .:? "rbac_roles" + <*> pure (Object o) + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/monitors[\/{id}]@. Carries the indexing metadata +-- alongside the persisted monitor document. +data MonitorResponse = MonitorResponse + { monitorResponseId :: Text, + monitorResponseVersion :: Int64, + monitorResponseSeqNo :: Int64, + monitorResponsePrimaryTerm :: Int64, + monitorResponseMonitor :: Monitor + } + deriving stock (Eq, Show) + +instance FromJSON MonitorResponse where + parseJSON = withObject "MonitorResponse" $ \o -> + MonitorResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "monitor" + +instance ToJSON MonitorResponse where + toJSON MonitorResponse {..} = + object + [ "_id" .= monitorResponseId, + "_version" .= monitorResponseVersion, + "_seq_no" .= monitorResponseSeqNo, + "_primary_term" .= monitorResponsePrimaryTerm, + "monitor" .= monitorResponseMonitor + ] + +-- | The @_shards@ sub-object of 'DeleteMonitorResponse'. Modelled +-- locally rather than reusing +-- "Database.Bloodhound.Internal.Versions.Common.Types.Nodes".'ShardsResult' +-- because that type wraps the outer @{"_shards": {...}}@ envelope (one +-- level too high for inline use here), and keeping the local shape +-- avoids widening the export surface of the Common types for this +-- single-purpose borrow. +data AlertingShards = AlertingShards + { alertingShardsTotal :: Int, + alertingShardsSuccessful :: Int, + alertingShardsSkipped :: Int, + alertingShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON AlertingShards where + parseJSON = withObject "AlertingShards" $ \o -> + AlertingShards + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "skipped" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON AlertingShards where + toJSON AlertingShards {..} = + object + [ "total" .= alertingShardsTotal, + "successful" .= alertingShardsSuccessful, + "skipped" .= alertingShardsSkipped, + "failed" .= alertingShardsFailed + ] + +-- | Response shape for @DELETE /_plugins/_alerting/monitors/{id}@. +-- +-- Deviates from the bead's @m 'Acknowledged'@ acceptance: the body +-- never carries an @acknowledged@ key, so an 'Acknowledged' decoder +-- would raise 'EsProtocolException' at runtime (same deviation pattern +-- as bloodhound-04f.3.13 rethrottle). +-- +-- The exact shape is version-dependent (live-verified in bead +-- bloodhound-z5j on OS 1.3.19, 2.19.5 and 3.7.0): +-- +-- * OS 1.3.x returns the full bare Elasticsearch delete-document +-- response — @_index@, @_type@, @_id@, @_version@, @result@, +-- @forced_refresh@, @_shards@, @_seq_no@, @_primary_term@. +-- * OS 2.x and 3.x return a minimal @_id@ + @_version@ envelope; the +-- indexing-metadata fields (@_index@, @result@, @_shards@, +-- @_seq_no@, ...) are omitted entirely. +-- +-- Only @_id@ and @_version@ are present on every version, so they are +-- the sole required fields; the rest are 'Maybe' and decode as +-- 'Nothing' on OS 2.x\/3.x. +data DeleteMonitorResponse = DeleteMonitorResponse + { deleteMonitorResponseId :: Text, + deleteMonitorResponseVersion :: Int64, + deleteMonitorResponseIndex :: Maybe Text, + deleteMonitorResponseResult :: Maybe Text, + deleteMonitorResponseForcedRefresh :: Maybe Bool, + deleteMonitorResponseShards :: Maybe AlertingShards, + deleteMonitorResponseSeqNo :: Maybe Int64, + deleteMonitorResponsePrimaryTerm :: Maybe Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteMonitorResponse where + parseJSON = withObject "DeleteMonitorResponse" $ \o -> + DeleteMonitorResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .:? "_index" + <*> o .:? "result" + <*> o .:? "forced_refresh" + <*> o .:? "_shards" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + +instance ToJSON DeleteMonitorResponse where + toJSON DeleteMonitorResponse {..} = + omitNulls + [ "_id" .= deleteMonitorResponseId, + "_version" .= deleteMonitorResponseVersion, + "_index" .= deleteMonitorResponseIndex, + "result" .= deleteMonitorResponseResult, + "forced_refresh" .= deleteMonitorResponseForcedRefresh, + "_shards" .= deleteMonitorResponseShards, + "_seq_no" .= deleteMonitorResponseSeqNo, + "_primary_term" .= deleteMonitorResponsePrimaryTerm + ] + +-- ========================================================================= +-- Destinations: GET /_plugins/_alerting/destinations +-- ========================================================================= +-- +-- The Alerting plugin's destinations API is the legacy notification +-- surface that pre-dates the Notifications plugin (covered separately +-- in "OpenSearchN.Types.Notifications"). A destination is a typed +-- notification target: a Slack incoming webhook, a Chime webhook, a +-- custom webhook, or an email account. Monitors reference destinations +-- by id via the @destination_id@ field on each 'Action'. The +-- @GET /_plugins/_alerting/destinations@ endpoint lists configured +-- destinations; the OpenSearch docs +-- () +-- document the wire shape. +-- +-- The destination record follows the same pragmatic pattern used by +-- 'Monitor' in this module: typed shell for the stable, common fields +-- (@id@, @type@, @name@, @schema_version@, @seq_no@, @primary_term@, +-- @last_update_time@, optional @user@) plus an opaque aeson 'Value' for +-- the per-type sub-object (the @slack@ \/ @chime@ \/ @custom_webhook@ +-- \/ @email@ key whose name matches the @type@ discriminator). The +-- shape of that sub-object varies by type and the docs do not fully +-- enumerate every variant, so it is kept opaque; callers decode it +-- with their own type-specific parser. The full original object is +-- captured in 'destinationOther' so unknown top-level keys round-trip +-- losslessly (same approach as 'monitorOther'). + +-- | The @type@ discriminator of a destination. The five values +-- enumerated by the @DestinationType@ enum in the plugin source are +-- given dedicated constructors; any future value falls through to +-- 'DestinationTypeOther' rather than parse-failing, because the field +-- is informational on requests and the server is the authority. +data DestinationType + = DestinationTypeSlack + | DestinationTypeChime + | DestinationTypeCustomWebhook + | DestinationTypeEmail + | DestinationTypeTestAction + | DestinationTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'DestinationType'. +destinationTypeText :: DestinationType -> Text +destinationTypeText = \case + DestinationTypeSlack -> "slack" + DestinationTypeChime -> "chime" + DestinationTypeCustomWebhook -> "custom_webhook" + DestinationTypeEmail -> "email" + DestinationTypeTestAction -> "test_action" + DestinationTypeOther t -> t + +instance ToJSON DestinationType where + toJSON = toJSON . destinationTypeText + +instance FromJSON DestinationType where + parseJSON = withText "DestinationType" $ \t -> + pure $ + case t of + "slack" -> DestinationTypeSlack + "chime" -> DestinationTypeChime + "custom_webhook" -> DestinationTypeCustomWebhook + "email" -> DestinationTypeEmail + "test_action" -> DestinationTypeTestAction + other -> DestinationTypeOther other + +-- | A single destination record returned by +-- @GET /_plugins/_alerting/destinations@. The typed fields cover every +-- key the API documents on responses; 'destinationBody' carries the +-- per-type sub-object keyed by 'destinationTypeText' (so +-- 'DestinationTypeSlack' implies a @slack@ sub-object, +-- 'DestinationTypeEmail' implies an @email@ sub-object, etc.). The +-- @test_action@ type carries no sub-object; its 'destinationBody' is +-- 'Null' on decode and omitted on encode. 'destinationOther' captures +-- the whole original object so any forward-compat top-level key +-- round-trips losslessly (mirrors the 'monitorOther' precedent). +data Destination = Destination + { destinationId :: Text, + destinationType :: DestinationType, + destinationName :: Text, + destinationSchemaVersion :: Int, + destinationSeqNo :: Int64, + destinationPrimaryTerm :: Int64, + destinationLastUpdateTime :: Maybe Int64, + destinationUser :: Maybe Value, + destinationBody :: Value, + destinationOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON Destination where + parseJSON = withObject "Destination" $ \o -> do + destinationId <- o .: "id" + destinationType <- o .: "type" + destinationName <- o .: "name" + destinationSchemaVersion <- o .:? "schema_version" .!= 0 + destinationSeqNo <- o .:? "seq_no" .!= 0 + destinationPrimaryTerm <- o .:? "primary_term" .!= 0 + destinationLastUpdateTime <- o .:? "last_update_time" + destinationUser <- o .:? "user" + let typeKey = K.fromText (destinationTypeText destinationType) + destinationBody = maybe Null id (KM.lookup typeKey o) + pure Destination {destinationOther = Object o, ..} + +instance ToJSON Destination where + toJSON d = + case destinationOther d of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= destinationId d, + "type" .= destinationType d, + "name" .= destinationName d, + "schema_version" .= destinationSchemaVersion d, + "seq_no" .= destinationSeqNo d, + "primary_term" .= destinationPrimaryTerm d, + "last_update_time" .= destinationLastUpdateTime d, + "user" .= destinationUser d, + K.fromText (destinationTypeText (destinationType d)) .= destinationBody d + ] + +-- | Sort direction for @GET /_plugins/_alerting/destinations@. The +-- plugin docs only document @"asc"@ and @"desc"@. +data DestinationSortOrder + = DestinationSortOrderAsc + | DestinationSortOrderDesc + deriving stock (Eq, Show) + +-- | Wire string for a 'DestinationSortOrder'. +destinationSortOrderText :: DestinationSortOrder -> Text +destinationSortOrderText = \case + DestinationSortOrderAsc -> "asc" + DestinationSortOrderDesc -> "desc" + +-- | Query-string parameters accepted by +-- @GET /_plugins/_alerting/destinations@. Every field is optional; +-- 'defaultDestinationListOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. The server-side defaults when the +-- parameter is omitted are: @size=20@, @start_index=0@, +-- @sortString=destination.name.keyword@, @sortOrder=asc@, +-- @missing=null@, @searchString=""@, @destinationType=ALL@. +data DestinationListOptions = DestinationListOptions + { destinationListOptionsSize :: Maybe Natural, + destinationListOptionsStartIndex :: Maybe Natural, + destinationListOptionsSortString :: Maybe Text, + destinationListOptionsSortOrder :: Maybe DestinationSortOrder, + destinationListOptionsMissing :: Maybe Text, + destinationListOptionsSearchString :: Maybe Text, + destinationListOptionsDestinationType :: Maybe DestinationType + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the +-- plain @GET /_plugins/_alerting/destinations@ (server defaults apply) +-- when passed to 'getDestinationsWith'. +defaultDestinationListOptions :: DestinationListOptions +defaultDestinationListOptions = + DestinationListOptions + { destinationListOptionsSize = Nothing, + destinationListOptionsStartIndex = Nothing, + destinationListOptionsSortString = Nothing, + destinationListOptionsSortOrder = Nothing, + destinationListOptionsMissing = Nothing, + destinationListOptionsSearchString = Nothing, + destinationListOptionsDestinationType = Nothing + } + +-- | Render a 'DestinationListOptions' to the query-string pairs +-- accepted by the GET endpoint. Fields set to 'Nothing' are omitted +-- (not rendered with an empty value). The parameter names are +-- camelCase, matching the alerting plugin's @RestGetDestinationsAction@ +-- (note: the Notifications plugin uses snake_case for its sibling +-- parameters — these are distinct plugin surfaces and the casings +-- genuinely differ on the wire). +destinationListOptionsParams :: DestinationListOptions -> [(Text, Maybe Text)] +destinationListOptionsParams DestinationListOptions {..} = + catMaybes + [ (("size",) . Just . tshow) <$> destinationListOptionsSize, + (("start_index",) . Just . tshow) <$> destinationListOptionsStartIndex, + (("sortString",) . Just) <$> destinationListOptionsSortString, + (("sortOrder",) . Just . destinationSortOrderText) <$> destinationListOptionsSortOrder, + (("missing",) . Just) <$> destinationListOptionsMissing, + (("searchString",) . Just) <$> destinationListOptionsSearchString, + (("destinationType",) . Just . destinationTypeText) <$> destinationListOptionsDestinationType + ] + +-- | Envelope returned by @GET /_plugins/_alerting/destinations@. +-- @totalDestinations@ is the total hit count matching the query (not +-- the size of @destinations@, which is the current page constrained by +-- the @size@ \/ @start_index@ parameters); @destinations@ is the +-- current page of records. The paging metadata is decoded for +-- completeness but discarded by the public 'getDestinations' wrapper, +-- which returns only the @destinations@ list. +data GetDestinationsResponse = GetDestinationsResponse + { getDestinationsResponseTotalDestinations :: Int, + getDestinationsResponseDestinations :: [Destination] + } + deriving stock (Eq, Show) + +instance FromJSON GetDestinationsResponse where + parseJSON = withObject "GetDestinationsResponse" $ \o -> do + getDestinationsResponseTotalDestinations <- o .:? "totalDestinations" .!= 0 + getDestinationsResponseDestinations <- o .:? "destinations" .!= [] + pure GetDestinationsResponse {..} + +instance ToJSON GetDestinationsResponse where + toJSON GetDestinationsResponse {..} = + object + [ "totalDestinations" .= getDestinationsResponseTotalDestinations, + "destinations" .= getDestinationsResponseDestinations + ] + +-- ========================================================================= +-- Monitor search: POST /_plugins/_alerting/monitors/_search +-- ========================================================================= +-- +-- The Alerting plugin exposes the monitor store as a regular +-- OpenSearch index (@.opendistro-allocator-config@ \/ +-- @.opensearch-scheduled-jobs@, depending on version), so the search +-- endpoint takes the standard OpenSearch query DSL and returns the +-- standard search envelope. The 'MonitorsSearchQuery' body mirrors the +-- 'SARulesQuery' shape (opaque @query@ DSL plus @from@ \/ @size@ +-- pagination); the 'SearchMonitorsResponse' envelope mirrors +-- 'SARulesSearchResponse'. Each hit's @_source@ is a bare 'Monitor' +-- (the indexed document source — no @monitor@ wrapper, unlike the +-- create\/update response). + +-- | Optional query body for 'searchMonitors'. The @from@ \/ @size@ +-- pair is the standard OpenSearch pagination cursor; @query@ is the +-- standard OpenSearch query DSL, kept opaque because its shape varies +-- by use case (term match on @monitor.name@, range on +-- @enabled_time@, ...). Pass 'Nothing' to 'searchMonitors' (or +-- 'defaultMonitorsSearchQuery' to the body renderer) for the plain +-- empty-body @{}@ POST that returns the first page of all monitors. +data MonitorsSearchQuery = MonitorsSearchQuery + { monitorsSearchQueryFrom :: Maybe Int, + monitorsSearchQuerySize :: Maybe Int, + monitorsSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultMonitorsSearchQuery :: MonitorsSearchQuery +defaultMonitorsSearchQuery = MonitorsSearchQuery Nothing Nothing Nothing + +instance ToJSON MonitorsSearchQuery where + toJSON MonitorsSearchQuery {..} = + omitNulls + [ "from" .= monitorsSearchQueryFrom, + "size" .= monitorsSearchQuerySize, + "query" .= monitorsSearchQueryQuery + ] + +instance FromJSON MonitorsSearchQuery where + parseJSON = withObject "MonitorsSearchQuery" $ \o -> + MonitorsSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "query" + +-- | The @hits.total.relation@ discriminator on a monitor search +-- response. OpenSearch documents @"eq"@ (exact count) and @"ge"@ +-- (lower bound, when @track_total_hits@ is false); any future value +-- falls through to 'MonitorsTotalRelationOther' rather than +-- parse-failing. +data MonitorsTotalRelation + = MonitorsTotalRelationEq + | MonitorsTotalRelationGe + | MonitorsTotalRelationOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'MonitorsTotalRelation'. +monitorsTotalRelationText :: MonitorsTotalRelation -> Text +monitorsTotalRelationText = \case + MonitorsTotalRelationEq -> "eq" + MonitorsTotalRelationGe -> "ge" + MonitorsTotalRelationOther t -> t + +instance ToJSON MonitorsTotalRelation where + toJSON = toJSON . monitorsTotalRelationText + +instance FromJSON MonitorsTotalRelation where + parseJSON = withText "MonitorsTotalRelation" $ \t -> + pure $ + case t of + "eq" -> MonitorsTotalRelationEq + "ge" -> MonitorsTotalRelationGe + other -> MonitorsTotalRelationOther other + +-- | The @hits.total@ sub-object on a monitor search response +-- (@{value, relation}@). +data MonitorsTotal = MonitorsTotal + { monitorsTotalValue :: Int64, + monitorsTotalRelation :: MonitorsTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON MonitorsTotal where + parseJSON = withObject "MonitorsTotal" $ \o -> + MonitorsTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON MonitorsTotal where + toJSON MonitorsTotal {..} = + object + [ "value" .= monitorsTotalValue, + "relation" .= monitorsTotalRelation + ] + +-- | A single hit in @hits.hits[]@ on a monitor search response. The +-- typed fields mirror the standard search-hit envelope; the @_source@ +-- is decoded as a bare 'Monitor' (the indexed document source). +data MonitorHit = MonitorHit + { monitorHitIndex :: Maybe Text, + monitorHitId :: Text, + monitorHitVersion :: Maybe Int64, + monitorHitSeqNo :: Maybe Int64, + monitorHitPrimaryTerm :: Maybe Int64, + monitorHitScore :: Maybe Double, + monitorHitSource :: Monitor + } + deriving stock (Eq, Show) + +instance FromJSON MonitorHit where + parseJSON = withObject "MonitorHit" $ \o -> + MonitorHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON MonitorHit where + toJSON MonitorHit {..} = + omitNulls + [ "_index" .= monitorHitIndex, + "_id" .= monitorHitId, + "_version" .= monitorHitVersion, + "_seq_no" .= monitorHitSeqNo, + "_primary_term" .= monitorHitPrimaryTerm, + "_score" .= monitorHitScore, + "_source" .= monitorHitSource + ] + +-- | Response envelope for 'searchMonitors'. Decoded verbatim from the +-- standard OpenSearch search-response shape; the paging metadata +-- (@took@, @timed_out@, @_shards@, @hits.total@, @hits.max_score@) is +-- preserved alongside the monitor list so callers can drive pagination +-- and observe shard health. The @_shards@ sub-object reuses the local +-- 'AlertingShards' (the standard @{total,successful,skipped,failed}@ +-- shape already modelled for 'DeleteMonitorResponse'). +data SearchMonitorsResponse = SearchMonitorsResponse + { searchMonitorsResponseTook :: Int64, + searchMonitorsResponseTimedOut :: Bool, + searchMonitorsResponseShards :: AlertingShards, + searchMonitorsResponseTotal :: MonitorsTotal, + searchMonitorsResponseMaxScore :: Maybe Double, + searchMonitorsResponseHits :: [MonitorHit] + } + deriving stock (Eq, Show) + +instance FromJSON SearchMonitorsResponse where + parseJSON = withObject "SearchMonitorsResponse" $ \o -> do + hits <- o .: "hits" + SearchMonitorsResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SearchMonitorsResponse where + toJSON SearchMonitorsResponse {..} = + object + [ "took" .= searchMonitorsResponseTook, + "timed_out" .= searchMonitorsResponseTimedOut, + "_shards" .= searchMonitorsResponseShards, + "hits" + .= object + [ "total" .= searchMonitorsResponseTotal, + "max_score" .= searchMonitorsResponseMaxScore, + "hits" .= searchMonitorsResponseHits + ] + ] + +-- | Project the decoded 'Monitor' list out of a 'SearchMonitorsResponse' +-- (convenience for callers who only want the monitors and not the +-- paging envelope). +searchMonitorsResponseMonitors :: SearchMonitorsResponse -> [Monitor] +searchMonitorsResponseMonitors = map monitorHitSource . searchMonitorsResponseHits + +-- ========================================================================= +-- Execute monitor: POST /_plugins/_alerting/monitors/{id}/_execute +-- ========================================================================= +-- +-- The execute endpoint runs a monitor's inputs and triggers immediately +-- (out of schedule) and returns the per-trigger execution result. The +-- response shape varies widely by monitor kind (@trigger_results@ is a +-- map keyed by trigger name whose value differs for query-level, +-- bucket-level, and document-level triggers; @input_results@ carries +-- the search response the monitor ran against). Following the ML +-- Commons @predict@ precedent, the stable shell fields +-- (@monitor_name@, @period_start@, @period_end@, @dry_run@) are typed +-- and the variable result sub-objects are kept as opaque aeson +-- 'Value's so any monitor kind round-trips losslessly. + +-- | Optional request parameters for 'executeMonitor'. @dryrun@ (default +-- 'False' on the server) skips dispatching actions to destinations; it +-- is sent as the @?dryrun=true@ query parameter (the @_execute@ +-- endpoint takes no request body). Pass 'Nothing' to 'executeMonitor' +-- (or 'defaultExecuteMonitorRequest') for a real execution with action +-- dispatch. +data ExecuteMonitorRequest = ExecuteMonitorRequest + { executeMonitorRequestDryrun :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | The empty request: a real execution with action dispatch (no +-- @?dryrun@ query parameter). +defaultExecuteMonitorRequest :: ExecuteMonitorRequest +defaultExecuteMonitorRequest = ExecuteMonitorRequest Nothing + +instance ToJSON ExecuteMonitorRequest where + toJSON ExecuteMonitorRequest {..} = + omitNulls ["dryrun" .= executeMonitorRequestDryrun] + +instance FromJSON ExecuteMonitorRequest where + parseJSON = withObject "ExecuteMonitorRequest" $ \o -> + ExecuteMonitorRequest <$> o .:? "dryrun" + +-- | Response shape for @POST /_plugins/_alerting/monitors/{id}/_execute@. +-- The typed shell carries the stable fields every execution result +-- shares; @trigger_results@, @input_results@, and @script_actions@ are +-- kept as opaque aeson 'Value's because their shape varies by monitor +-- kind and trigger type (mirrors the ML Commons @predict@ precedent). +-- The full original object is captured in 'executeMonitorResponseOther' +-- so any forward-compat key round-trips losslessly. +data ExecuteMonitorResponse = ExecuteMonitorResponse + { executeMonitorResponseMonitorName :: Maybe Text, + executeMonitorResponsePeriodStart :: Maybe Int64, + executeMonitorResponsePeriodEnd :: Maybe Int64, + executeMonitorResponseDryRun :: Maybe Bool, + executeMonitorResponseTriggerResults :: Maybe Value, + executeMonitorResponseInputResults :: Maybe Value, + executeMonitorResponseScriptActions :: Maybe Value, + executeMonitorResponseOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON ExecuteMonitorResponse where + parseJSON = withObject "ExecuteMonitorResponse" $ \o -> + ExecuteMonitorResponse + <$> o .:? "monitor_name" + <*> o .:? "period_start" + <*> o .:? "period_end" + <*> o .:? "dry_run" + <*> o .:? "trigger_results" + <*> o .:? "input_results" + <*> o .:? "script_actions" + <*> pure (Object o) + +instance ToJSON ExecuteMonitorResponse where + toJSON r = + case executeMonitorResponseOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "monitor_name" .= executeMonitorResponseMonitorName r, + "period_start" .= executeMonitorResponsePeriodStart r, + "period_end" .= executeMonitorResponsePeriodEnd r, + "dry_run" .= executeMonitorResponseDryRun r, + "trigger_results" .= executeMonitorResponseTriggerResults r, + "input_results" .= executeMonitorResponseInputResults r, + "script_actions" .= executeMonitorResponseScriptActions r + ] + +-- ========================================================================= +-- Destination lifecycle: POST/PUT/DELETE /_plugins/_alerting/destinations[/{id}] +-- ========================================================================= +-- +-- The create and update destination endpoints take a 'Destination' as +-- the request body (the server assigns @id@, @schema_version@, +-- @seq_no@, @primary_term@ on write) and return the +-- 'DestinationResponse' wrapper (@{_id,_version,_seq_no,_primary_term, +-- destination:{...}}@) — the destination analogue of 'MonitorResponse'. +-- The delete endpoint returns the standard Elasticsearch +-- delete-document response (bare, no @acknowledged@ key, with a +-- @_shards@ report), modelled distinctly as 'DeleteDestinationResponse' +-- for the same reason as 'DeleteMonitorResponse' (an 'Acknowledged' +-- decoder would raise 'EsProtocolException' at runtime). + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/destinations[/{id}]@. Carries the indexing +-- metadata alongside the persisted destination document. Mirrors +-- 'MonitorResponse'. +data DestinationResponse = DestinationResponse + { destinationResponseId :: Text, + destinationResponseVersion :: Int64, + destinationResponseSeqNo :: Int64, + destinationResponsePrimaryTerm :: Int64, + destinationResponseDestination :: Destination + } + deriving stock (Eq, Show) + +instance FromJSON DestinationResponse where + parseJSON = withObject "DestinationResponse" $ \o -> + DestinationResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "destination" + +instance ToJSON DestinationResponse where + toJSON DestinationResponse {..} = + object + [ "_id" .= destinationResponseId, + "_version" .= destinationResponseVersion, + "_seq_no" .= destinationResponseSeqNo, + "_primary_term" .= destinationResponsePrimaryTerm, + "destination" .= destinationResponseDestination + ] + +-- | Response shape for @DELETE /_plugins/_alerting/destinations/{id}@. +-- Wire-identical to 'DeleteMonitorResponse' (the standard Elasticsearch +-- delete-document response — bare, no destination echo, no +-- @acknowledged@ key, with a @_shards@ report) but modelled as a +-- distinct type so the public API reads correctly at call sites. +-- 'AlertingShards' is reused for the @_shards@ sub-object. +data DeleteDestinationResponse = DeleteDestinationResponse + { deleteDestinationResponseIndex :: Text, + deleteDestinationResponseId :: Text, + deleteDestinationResponseVersion :: Int64, + deleteDestinationResponseResult :: Text, + deleteDestinationResponseForcedRefresh :: Bool, + deleteDestinationResponseShards :: AlertingShards, + deleteDestinationResponseSeqNo :: Int64, + deleteDestinationResponsePrimaryTerm :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteDestinationResponse where + parseJSON = withObject "DeleteDestinationResponse" $ \o -> + DeleteDestinationResponse + <$> o .: "_index" + <*> o .: "_id" + <*> o .: "_version" + <*> o .: "result" + <*> o .:? "forced_refresh" .!= False + <*> o .: "_shards" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + +instance ToJSON DeleteDestinationResponse where + toJSON DeleteDestinationResponse {..} = + object + [ "_index" .= deleteDestinationResponseIndex, + "_id" .= deleteDestinationResponseId, + "_version" .= deleteDestinationResponseVersion, + "result" .= deleteDestinationResponseResult, + "forced_refresh" .= deleteDestinationResponseForcedRefresh, + "_shards" .= deleteDestinationResponseShards, + "_seq_no" .= deleteDestinationResponseSeqNo, + "_primary_term" .= deleteDestinationResponsePrimaryTerm + ] + +-- ========================================================================= +-- Get alerts: GET /_plugins/_alerting/monitors/alerts +-- ========================================================================= +-- +-- The get-alerts endpoint returns the active alert documents for the +-- whole cluster (optionally filtered by a rich set of query-string +-- parameters). An alert document carries a large, partly variable body +-- (@monitor_user@, @alert_history@, @action_execution_results@ sub-objects +-- whose shape tracks the monitor kind and action type). Following the +-- pragmatic precedent used by 'Monitor' and 'ExecuteMonitorResponse', +-- the stable shell fields are typed and the variable sub-objects are +-- kept as opaque aeson 'Value's (captured together in 'alertOther') so +-- any alert round-trips losslessly. The OpenSearch docs +-- () +-- document the wire shape. + +-- | Sort direction for @GET /_plugins/_alerting/monitors/alerts@. The +-- plugin documents only @"asc"@ and @"desc"@. Modelled as a distinct +-- type from 'DestinationSortOrder' so the call site reads correctly, +-- even though the wire values coincide. +data AlertSortOrder + = AlertSortOrderAsc + | AlertSortOrderDesc + deriving stock (Eq, Show) + +-- | Wire string for an 'AlertSortOrder'. +alertSortOrderText :: AlertSortOrder -> Text +alertSortOrderText = \case + AlertSortOrderAsc -> "asc" + AlertSortOrderDesc -> "desc" + +instance ToJSON AlertSortOrder where + toJSON = toJSON . alertSortOrderText + +-- | The @state@ field of an alert document, and the @alertState@ query +-- parameter. The four documented states are given dedicated +-- constructors; any future value falls through to 'AlertStateOther' +-- rather than parse-failing, because the server is the authority. +data AlertState + = AlertStateActive + | AlertStateCompleted + | AlertStateError + | AlertStateAcknowledged + | AlertStateOther Text + deriving stock (Eq, Show) + +-- | Wire string for an 'AlertState'. +alertStateText :: AlertState -> Text +alertStateText = \case + AlertStateActive -> "ACTIVE" + AlertStateCompleted -> "COMPLETED" + AlertStateError -> "ERROR" + AlertStateAcknowledged -> "ACKNOWLEDGED" + AlertStateOther t -> t + +instance ToJSON AlertState where + toJSON = toJSON . alertStateText + +instance FromJSON AlertState where + parseJSON = withText "AlertState" $ \t -> + pure $ + case t of + "ACTIVE" -> AlertStateActive + "COMPLETED" -> AlertStateCompleted + "ERROR" -> AlertStateError + "ACKNOWLEDGED" -> AlertStateAcknowledged + other -> AlertStateOther other + +-- | Query-string parameters accepted by +-- @GET /_plugins/_alerting/monitors/alerts@. Every field is optional; +-- 'defaultGetAlertsOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. The server-side defaults when a +-- parameter is omitted are: @size=20@, @startIndex=0@, +-- @sortString=monitor_name.keyword@, @sortOrder=asc@, +-- @searchString=""@, @severityLevel=ALL@, @alertState=ALL@. The +-- @severityLevel@ is kept as 'Text' because the wire values are +-- string-encoded severities (@\"1\"@..@\"4\"@) plus the literal +-- @\"ALL\"@, which is awkward to model as a closed enum. The +-- @workflowIds@ parameter is documented for OpenSearch 2.9+ (comma- +-- separated workflow ids for chained-alert dashboards); it is harmlessly +-- ignored by older servers, so it is exposed uniformly across OS1\/2\/3. +data GetAlertsOptions = GetAlertsOptions + { getAlertsOptionsSortString :: Maybe Text, + getAlertsOptionsSortOrder :: Maybe AlertSortOrder, + getAlertsOptionsMissing :: Maybe Text, + getAlertsOptionsSize :: Maybe Natural, + getAlertsOptionsStartIndex :: Maybe Natural, + getAlertsOptionsSearchString :: Maybe Text, + getAlertsOptionsSeverityLevel :: Maybe Text, + getAlertsOptionsAlertState :: Maybe AlertState, + getAlertsOptionsMonitorId :: Maybe Text, + getAlertsOptionsWorkflowIds :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the plain +-- @GET /_plugins/_alerting/monitors/alerts@ (server defaults apply) when +-- passed to 'getAlertsWith'. +defaultGetAlertsOptions :: GetAlertsOptions +defaultGetAlertsOptions = + GetAlertsOptions + { getAlertsOptionsSortString = Nothing, + getAlertsOptionsSortOrder = Nothing, + getAlertsOptionsMissing = Nothing, + getAlertsOptionsSize = Nothing, + getAlertsOptionsStartIndex = Nothing, + getAlertsOptionsSearchString = Nothing, + getAlertsOptionsSeverityLevel = Nothing, + getAlertsOptionsAlertState = Nothing, + getAlertsOptionsMonitorId = Nothing, + getAlertsOptionsWorkflowIds = Nothing + } + +-- | Render a 'GetAlertsOptions' to the query-string pairs accepted by +-- the get-alerts endpoint. Fields set to 'Nothing' are omitted (not +-- rendered with an empty value). The parameter names are camelCase, +-- matching the alerting plugin's @RestGetAlertsAction@ (note: +-- @startIndex@ is camelCase here, whereas the destinations GET uses +-- snake_case @start_index@ — these are distinct plugin routes and the +-- casings genuinely differ on the wire). +getAlertsOptionsParams :: GetAlertsOptions -> [(Text, Maybe Text)] +getAlertsOptionsParams GetAlertsOptions {..} = + catMaybes + [ ("sortString",) . Just <$> getAlertsOptionsSortString, + ("sortOrder",) . Just . alertSortOrderText <$> getAlertsOptionsSortOrder, + ("missing",) . Just <$> getAlertsOptionsMissing, + ("size",) . Just . tshow <$> getAlertsOptionsSize, + ("startIndex",) . Just . tshow <$> getAlertsOptionsStartIndex, + ("searchString",) . Just <$> getAlertsOptionsSearchString, + ("severityLevel",) . Just <$> getAlertsOptionsSeverityLevel, + ("alertState",) . Just . alertStateText <$> getAlertsOptionsAlertState, + ("monitorId",) . Just <$> getAlertsOptionsMonitorId, + ("workflowIds",) . Just <$> getAlertsOptionsWorkflowIds + ] + +-- | A single alert document returned by +-- @GET /_plugins/_alerting/monitors/alerts@. The typed shell covers the +-- stable fields every alert shares; @monitor_user@, @alert_history@, and +-- @action_execution_results@ are kept as opaque aeson 'Value's (captured +-- in 'alertOther') because their shape varies by monitor kind and action +-- type. @alertSeverity@ is a 'Text' rather than an 'Int' because the +-- wire emits a string-encoded integer (e.g. @\"1\"@) — the same +-- deviation from the docs as 'triggerSeverity'. The full original +-- object is captured in 'alertOther' so any forward-compat key +-- round-trips losslessly (mirrors the 'monitorOther' precedent). +data Alert = Alert + { alertId :: Text, + alertVersion :: Int64, + alertMonitorId :: Text, + alertSchemaVersion :: Maybe Int, + alertMonitorVersion :: Maybe Int64, + alertMonitorName :: Text, + alertTriggerId :: Text, + alertTriggerName :: Text, + alertState :: AlertState, + alertSeverity :: Text, + alertErrorMessage :: Maybe Text, + alertStartTime :: Maybe Int64, + alertLastNotificationTime :: Maybe Int64, + alertEndTime :: Maybe Int64, + alertAcknowledgedTime :: Maybe Int64, + alertOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON Alert where + parseJSON = withObject "Alert" $ \o -> + Alert + <$> o .: "id" + <*> o .:? "version" .!= 0 + <*> o .: "monitor_id" + <*> o .:? "schema_version" + <*> o .:? "monitor_version" + <*> o .: "monitor_name" + <*> o .: "trigger_id" + <*> o .: "trigger_name" + <*> o .:? "state" .!= AlertStateOther "" + <*> o .:? "severity" .!= "" + <*> o .:? "error_message" + <*> o .:? "start_time" + <*> o .:? "last_notification_time" + <*> o .:? "end_time" + <*> o .:? "acknowledged_time" + <*> pure (Object o) + +instance ToJSON Alert where + toJSON a = + case alertOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= alertId a, + "version" .= alertVersion a, + "monitor_id" .= alertMonitorId a, + "schema_version" .= alertSchemaVersion a, + "monitor_version" .= alertMonitorVersion a, + "monitor_name" .= alertMonitorName a, + "trigger_id" .= alertTriggerId a, + "trigger_name" .= alertTriggerName a, + "state" .= alertState a, + "severity" .= alertSeverity a, + "error_message" .= alertErrorMessage a, + "start_time" .= alertStartTime a, + "last_notification_time" .= alertLastNotificationTime a, + "end_time" .= alertEndTime a, + "acknowledged_time" .= alertAcknowledgedTime a + ] + +-- | Envelope returned by @GET /_plugins/_alerting/monitors/alerts@. +-- @totalAlerts@ is the total hit count matching the query (not the size +-- of @alerts@, which is the current page constrained by the @size@ \/ +-- @startIndex@ parameters); @alerts@ is the current page of records. +data GetAlertsResponse = GetAlertsResponse + { getAlertsResponseAlerts :: [Alert], + getAlertsResponseTotalAlerts :: Int + } + deriving stock (Eq, Show) + +instance FromJSON GetAlertsResponse where + parseJSON = withObject "GetAlertsResponse" $ \o -> do + getAlertsResponseAlerts <- o .:? "alerts" .!= [] + getAlertsResponseTotalAlerts <- o .:? "totalAlerts" .!= 0 + pure GetAlertsResponse {..} + +instance ToJSON GetAlertsResponse where + toJSON GetAlertsResponse {..} = + object + [ "alerts" .= getAlertsResponseAlerts, + "totalAlerts" .= getAlertsResponseTotalAlerts + ] + +-- ========================================================================= +-- Acknowledge alert: POST /_plugins/_alerting/monitors/{id}/_acknowledge/alerts +-- ========================================================================= +-- +-- The acknowledge endpoint takes a list of alert ids (belonging to the +-- monitor in the path) and flips each to the @ACKNOWLEDGED@ state. Alerts +-- already in an @ERROR@, @COMPLETED@, or @ACKNOWLEDGED@ state are not +-- transitioned and are echoed back in the @failed@ array. See +-- . + +-- | Request body for 'acknowledgeAlert'. @alerts@ is the list of alert +-- ids to acknowledge. 'defaultAcknowledgeAlertRequest' renders to the +-- empty-list body @{"alerts":[]}@. +newtype AcknowledgeAlertRequest = AcknowledgeAlertRequest + { acknowledgeAlertRequestAlerts :: [Text] + } + deriving stock (Eq, Show) + +defaultAcknowledgeAlertRequest :: AcknowledgeAlertRequest +defaultAcknowledgeAlertRequest = AcknowledgeAlertRequest [] + +instance ToJSON AcknowledgeAlertRequest where + toJSON AcknowledgeAlertRequest {..} = + object ["alerts" .= acknowledgeAlertRequestAlerts] + +instance FromJSON AcknowledgeAlertRequest where + parseJSON = withObject "AcknowledgeAlertRequest" $ \o -> + AcknowledgeAlertRequest + <$> o .:? "alerts" .!= [] + +-- | Response shape for +-- @POST /_plugins/_alerting/monitors/{id}/_acknowledge/alerts@. @success@ +-- lists the alert ids that were transitioned to @ACKNOWLEDGED@; @failed@ +-- lists the alert ids that were not (already in a terminal state). +data AcknowledgeAlertResponse = AcknowledgeAlertResponse + { acknowledgeAlertResponseSuccess :: [Text], + acknowledgeAlertResponseFailed :: [Text] + } + deriving stock (Eq, Show) + +instance FromJSON AcknowledgeAlertResponse where + parseJSON = withObject "AcknowledgeAlertResponse" $ \o -> do + acknowledgeAlertResponseSuccess <- o .:? "success" .!= [] + acknowledgeAlertResponseFailed <- o .:? "failed" .!= [] + pure AcknowledgeAlertResponse {..} + +instance ToJSON AcknowledgeAlertResponse where + toJSON AcknowledgeAlertResponse {..} = + object + [ "success" .= acknowledgeAlertResponseSuccess, + "failed" .= acknowledgeAlertResponseFailed + ] + +-- ========================================================================= +-- Monitor stats: GET /_plugins/_alerting/stats[/...] +-- ========================================================================= +-- +-- The stats endpoint returns node-level alerting scheduler metrics. The +-- response is a large, deeply-nested object: a stable shell +-- (@_nodes@ count, @cluster_name@, scheduled-job index health booleans, +-- @nodes_on_schedule@ \/ @nodes_not_on_schedule@ counts) wrapping a +-- @nodes@ map keyed by node id whose value carries per-node roles, +-- schedule status, job-scheduling metrics, and a per-job @jobs_info@ +-- map. The @nodes@ sub-object's shape grows across OpenSearch releases, +-- so following the pragmatic precedent used by +-- 'ExecuteMonitorResponse', the stable shell is typed and the variable +-- @nodes@ map (plus any forward-compat key) is kept as an opaque aeson +-- 'Value' in 'monitorStatsOther'. See +-- . + +-- | The @_nodes@ sub-object of 'MonitorStats' +-- (@{total, successful, failed}@). Modelled locally (rather than reusing +-- 'AlertingShards') because the stats @_nodes@ object carries no +-- @skipped@ field and the names describe cluster-node bookkeeping, not +-- shard execution. +data MonitorStatsNodesCount = MonitorStatsNodesCount + { monitorStatsNodesCountTotal :: Int, + monitorStatsNodesCountSuccessful :: Int, + monitorStatsNodesCountFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON MonitorStatsNodesCount where + parseJSON = withObject "MonitorStatsNodesCount" $ \o -> + MonitorStatsNodesCount + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON MonitorStatsNodesCount where + toJSON MonitorStatsNodesCount {..} = + object + [ "total" .= monitorStatsNodesCountTotal, + "successful" .= monitorStatsNodesCountSuccessful, + "failed" .= monitorStatsNodesCountFailed + ] + +-- | Response shape for @GET /_plugins/_alerting/stats[/...]@. The typed +-- shell carries the stable, cluster-level fields every stats response +-- shares; the deeply-nested @nodes@ map (and any forward-compat key) is +-- captured in 'monitorStatsOther' as an opaque aeson 'Value'. Note the +-- literal dotted key @plugins.scheduled_jobs.enabled@ on the wire. +data MonitorStats = MonitorStats + { monitorStatsNodes :: Maybe MonitorStatsNodesCount, + monitorStatsClusterName :: Maybe Text, + monitorStatsScheduledJobsEnabled :: Maybe Bool, + monitorStatsScheduledJobIndexExists :: Maybe Bool, + monitorStatsScheduledJobIndexStatus :: Maybe Text, + monitorStatsNodesOnSchedule :: Maybe Int, + monitorStatsNodesNotOnSchedule :: Maybe Int, + monitorStatsOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON MonitorStats where + parseJSON = withObject "MonitorStats" $ \o -> + MonitorStats + <$> o .:? "_nodes" + <*> o .:? "cluster_name" + <*> o .:? "plugins.scheduled_jobs.enabled" + <*> o .:? "scheduled_job_index_exists" + <*> o .:? "scheduled_job_index_status" + <*> o .:? "nodes_on_schedule" + <*> o .:? "nodes_not_on_schedule" + <*> pure (Object o) + +instance ToJSON MonitorStats where + toJSON s = + case monitorStatsOther s of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "_nodes" .= monitorStatsNodes s, + "cluster_name" .= monitorStatsClusterName s, + "plugins.scheduled_jobs.enabled" .= monitorStatsScheduledJobsEnabled s, + "scheduled_job_index_exists" .= monitorStatsScheduledJobIndexExists s, + "scheduled_job_index_status" .= monitorStatsScheduledJobIndexStatus s, + "nodes_on_schedule" .= monitorStatsNodesOnSchedule s, + "nodes_not_on_schedule" .= monitorStatsNodesNotOnSchedule s + ] + +-- ========================================================================= +-- Email account lifecycle: POST/PUT/GET/DELETE /_plugins/_alerting/destinations/email_accounts[/{id}] +-- ========================================================================= +-- +-- The legacy alerting email surface (predating the Notifications +-- plugin). An email account is an SMTP sender (host, port, method, +-- credentials) referenced by id from an email 'Destination'. The +-- create\/update endpoints take an 'EmailAccount' body and return the +-- 'EmailAccountResponse' wrapper +-- (@{_id,_version,_seq_no,_primary_term, email_account:{...}}@) — the +-- email-account analogue of 'MonitorResponse'. The delete endpoint +-- returns the standard Elasticsearch delete-document response (bare, no +-- @acknowledged@ key, with a @_shards@ report), modelled distinctly as +-- 'DeleteEmailAccountResponse'. See +-- . + +-- | The server-assigned identifier of an alerting email account. Wraps +-- 'Text' so it round-trips as a bare JSON string but stays distinct from +-- 'MonitorId' and 'DestinationId' at the type level. +newtype EmailAccountId = EmailAccountId {unEmailAccountId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | An SMTP sender account. @method@ is typed as 'Text' (the docs +-- enumerate @ssl@ \/ @none@ \/ @start_tls@ \/ @ssl_tls@ but the set is +-- not pinned in the plugin schema, so a closed enum would risk a +-- library release on the next addition — same reasoning as +-- 'schedulePeriodUnit'). The full original object is captured in +-- 'emailAccountOther' so any forward-compat key round-trips losslessly. +data EmailAccount = EmailAccount + { emailAccountName :: Text, + emailAccountEmail :: Text, + emailAccountHost :: Text, + emailAccountPort :: Int, + emailAccountMethod :: Text, + emailAccountSchemaVersion :: Maybe Int, + emailAccountOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailAccount where + parseJSON = withObject "EmailAccount" $ \o -> do + emailAccountName <- o .: "name" + emailAccountEmail <- o .: "email" + emailAccountHost <- o .: "host" + emailAccountPort <- o .:? "port" .!= 0 + emailAccountMethod <- o .:? "method" .!= "" + emailAccountSchemaVersion <- o .:? "schema_version" + pure EmailAccount {emailAccountOther = Object o, ..} + +instance ToJSON EmailAccount where + toJSON a = + case emailAccountOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= emailAccountName a, + "email" .= emailAccountEmail a, + "host" .= emailAccountHost a, + "port" .= emailAccountPort a, + "method" .= emailAccountMethod a, + "schema_version" .= emailAccountSchemaVersion a + ] + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/destinations/email_accounts[/{id}]@. Carries the +-- indexing metadata alongside the persisted email account. Mirrors +-- 'MonitorResponse' \/ 'DestinationResponse'. +data EmailAccountResponse = EmailAccountResponse + { emailAccountResponseId :: Text, + emailAccountResponseVersion :: Int64, + emailAccountResponseSeqNo :: Int64, + emailAccountResponsePrimaryTerm :: Int64, + emailAccountResponseEmailAccount :: EmailAccount + } + deriving stock (Eq, Show) + +instance FromJSON EmailAccountResponse where + parseJSON = withObject "EmailAccountResponse" $ \o -> + EmailAccountResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "email_account" + +instance ToJSON EmailAccountResponse where + toJSON EmailAccountResponse {..} = + object + [ "_id" .= emailAccountResponseId, + "_version" .= emailAccountResponseVersion, + "_seq_no" .= emailAccountResponseSeqNo, + "_primary_term" .= emailAccountResponsePrimaryTerm, + "email_account" .= emailAccountResponseEmailAccount + ] + +-- | Response shape for +-- @DELETE /_plugins/_alerting/destinations/email_accounts/{id}@. +-- Wire-identical to 'DeleteDestinationResponse' (the standard +-- Elasticsearch delete-document response) but modelled as a distinct +-- type so the public API reads correctly at call sites. 'AlertingShards' +-- is reused for the @_shards@ sub-object. +data DeleteEmailAccountResponse = DeleteEmailAccountResponse + { deleteEmailAccountResponseIndex :: Text, + deleteEmailAccountResponseId :: Text, + deleteEmailAccountResponseVersion :: Int64, + deleteEmailAccountResponseResult :: Text, + deleteEmailAccountResponseForcedRefresh :: Bool, + deleteEmailAccountResponseShards :: AlertingShards, + deleteEmailAccountResponseSeqNo :: Int64, + deleteEmailAccountResponsePrimaryTerm :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteEmailAccountResponse where + parseJSON = withObject "DeleteEmailAccountResponse" $ \o -> + DeleteEmailAccountResponse + <$> o .: "_index" + <*> o .: "_id" + <*> o .: "_version" + <*> o .: "result" + <*> o .:? "forced_refresh" .!= False + <*> o .: "_shards" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + +instance ToJSON DeleteEmailAccountResponse where + toJSON DeleteEmailAccountResponse {..} = + object + [ "_index" .= deleteEmailAccountResponseIndex, + "_id" .= deleteEmailAccountResponseId, + "_version" .= deleteEmailAccountResponseVersion, + "result" .= deleteEmailAccountResponseResult, + "forced_refresh" .= deleteEmailAccountResponseForcedRefresh, + "_shards" .= deleteEmailAccountResponseShards, + "_seq_no" .= deleteEmailAccountResponseSeqNo, + "_primary_term" .= deleteEmailAccountResponsePrimaryTerm + ] + +-- ========================================================================= +-- Email group lifecycle: POST/PUT/GET/DELETE /_plugins/_alerting/destinations/email_groups[/{id}] +-- ========================================================================= +-- +-- An email group is a named list of recipients (@emails@) referenced by +-- id from an email 'Destination'. The create\/update endpoints take an +-- 'EmailGroup' body and return the 'EmailGroupResponse' wrapper +-- (@{_id,_version,_seq_no,_primary_term, email_group:{...}}@); the delete +-- endpoint returns the standard Elasticsearch delete-document response, +-- modelled as 'DeleteEmailGroupResponse'. See +-- . + +-- | The server-assigned identifier of an alerting email group. Wraps +-- 'Text' so it round-trips as a bare JSON string but stays distinct from +-- the other alerting ids at the type level. +newtype EmailGroupId = EmailGroupId {unEmailGroupId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A single recipient within an 'EmailGroup'. The wire object is +-- @{"email": "..."}@; any forward-compat key is captured in +-- 'emailGroupRecipientOther'. +data EmailGroupRecipient = EmailGroupRecipient + { emailGroupRecipientEmail :: Text, + emailGroupRecipientOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroupRecipient where + parseJSON = withObject "EmailGroupRecipient" $ \o -> do + emailGroupRecipientEmail <- o .: "email" + pure EmailGroupRecipient {emailGroupRecipientOther = Object o, ..} + +instance ToJSON EmailGroupRecipient where + toJSON r = + case emailGroupRecipientOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = ["email" .= emailGroupRecipientEmail r] + +-- | An email group document. The full original object is captured in +-- 'emailGroupOther' so any forward-compat key round-trips losslessly. +data EmailGroup = EmailGroup + { emailGroupName :: Text, + emailGroupEmails :: [EmailGroupRecipient], + emailGroupSchemaVersion :: Maybe Int, + emailGroupOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroup where + parseJSON = withObject "EmailGroup" $ \o -> do + emailGroupName <- o .: "name" + emailGroupEmails <- o .:? "emails" .!= [] + emailGroupSchemaVersion <- o .:? "schema_version" + pure EmailGroup {emailGroupOther = Object o, ..} + +instance ToJSON EmailGroup where + toJSON g = + case emailGroupOther g of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= emailGroupName g, + "emails" .= emailGroupEmails g, + "schema_version" .= emailGroupSchemaVersion g + ] + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/destinations/email_groups[/{id}]@. Carries the +-- indexing metadata alongside the persisted email group. Mirrors +-- 'MonitorResponse' \/ 'DestinationResponse' \/ 'EmailAccountResponse'. +data EmailGroupResponse = EmailGroupResponse + { emailGroupResponseId :: Text, + emailGroupResponseVersion :: Int64, + emailGroupResponseSeqNo :: Int64, + emailGroupResponsePrimaryTerm :: Int64, + emailGroupResponseEmailGroup :: EmailGroup + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroupResponse where + parseJSON = withObject "EmailGroupResponse" $ \o -> + EmailGroupResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "email_group" + +instance ToJSON EmailGroupResponse where + toJSON EmailGroupResponse {..} = + object + [ "_id" .= emailGroupResponseId, + "_version" .= emailGroupResponseVersion, + "_seq_no" .= emailGroupResponseSeqNo, + "_primary_term" .= emailGroupResponsePrimaryTerm, + "email_group" .= emailGroupResponseEmailGroup + ] + +-- | Response shape for +-- @DELETE /_plugins/_alerting/destinations/email_groups/{id}@. +-- Wire-identical to 'DeleteDestinationResponse' (the standard +-- Elasticsearch delete-document response) but modelled as a distinct +-- type so the public API reads correctly at call sites. 'AlertingShards' +-- is reused for the @_shards@ sub-object. +data DeleteEmailGroupResponse = DeleteEmailGroupResponse + { deleteEmailGroupResponseIndex :: Text, + deleteEmailGroupResponseId :: Text, + deleteEmailGroupResponseVersion :: Int64, + deleteEmailGroupResponseResult :: Text, + deleteEmailGroupResponseForcedRefresh :: Bool, + deleteEmailGroupResponseShards :: AlertingShards, + deleteEmailGroupResponseSeqNo :: Int64, + deleteEmailGroupResponsePrimaryTerm :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteEmailGroupResponse where + parseJSON = withObject "DeleteEmailGroupResponse" $ \o -> + DeleteEmailGroupResponse + <$> o .: "_index" + <*> o .: "_id" + <*> o .: "_version" + <*> o .: "result" + <*> o .:? "forced_refresh" .!= False + <*> o .: "_shards" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + +instance ToJSON DeleteEmailGroupResponse where + toJSON DeleteEmailGroupResponse {..} = + object + [ "_index" .= deleteEmailGroupResponseIndex, + "_id" .= deleteEmailGroupResponseId, + "_version" .= deleteEmailGroupResponseVersion, + "result" .= deleteEmailGroupResponseResult, + "forced_refresh" .= deleteEmailGroupResponseForcedRefresh, + "_shards" .= deleteEmailGroupResponseShards, + "_seq_no" .= deleteEmailGroupResponseSeqNo, + "_primary_term" .= deleteEmailGroupResponsePrimaryTerm + ] + +-- ========================================================================= +-- Email account search: POST /_plugins/_alerting/destinations/email_accounts/_search +-- ========================================================================= +-- +-- The email account search endpoint exposes the email-account store as a +-- standard OpenSearch index, so the search body takes the standard query +-- DSL plus @from@ \/ @size@ \/ @sort@ and returns the standard search +-- envelope. Each hit's @_source@ is a bare 'EmailAccount' (the indexed +-- document source). Mirrors the 'MonitorsSearchQuery' / +-- 'SearchMonitorsResponse' pattern but with 'EmailAccount' sources. + +-- | Optional query body for 'searchEmailAccounts'. The @from@ \/ @size@ +-- pair is the standard OpenSearch pagination cursor; @sort@ is an opaque +-- 'Value' (the docs show @{"field.keyword": "desc"}@); @query@ is the +-- standard OpenSearch query DSL. Pass 'Nothing' to 'searchEmailAccounts' +-- (or 'defaultEmailAccountSearchQuery' to the body renderer) for the plain +-- empty-body @{}@ POST that returns the first page of all email accounts. +data EmailAccountSearchQuery = EmailAccountSearchQuery + { emailAccountSearchQueryFrom :: Maybe Int, + emailAccountSearchQuerySize :: Maybe Int, + emailAccountSearchQuerySort :: Maybe Value, + emailAccountSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultEmailAccountSearchQuery :: EmailAccountSearchQuery +defaultEmailAccountSearchQuery = EmailAccountSearchQuery Nothing Nothing Nothing Nothing + +instance ToJSON EmailAccountSearchQuery where + toJSON EmailAccountSearchQuery {..} = + omitNulls + [ "from" .= emailAccountSearchQueryFrom, + "size" .= emailAccountSearchQuerySize, + "sort" .= emailAccountSearchQuerySort, + "query" .= emailAccountSearchQueryQuery + ] + +instance FromJSON EmailAccountSearchQuery where + parseJSON = withObject "EmailAccountSearchQuery" $ \o -> + EmailAccountSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "sort" + <*> o .:? "query" + +-- | A single hit in @hits.hits[]@ on an email account search response. +-- The typed fields mirror the standard search-hit envelope; the @_source@ +-- is decoded as a bare 'EmailAccount'. The @sort@ field (present when a +-- sort is supplied in the query) is preserved as an opaque 'Value' in +-- 'emailAccountSearchHitSort' so callers can drive cursor-based +-- pagination. +data EmailAccountSearchHit = EmailAccountSearchHit + { emailAccountSearchHitIndex :: Maybe Text, + emailAccountSearchHitId :: Text, + emailAccountSearchHitVersion :: Maybe Int64, + emailAccountSearchHitSeqNo :: Maybe Int64, + emailAccountSearchHitPrimaryTerm :: Maybe Int64, + emailAccountSearchHitScore :: Maybe Double, + emailAccountSearchHitSource :: EmailAccount, + emailAccountSearchHitSort :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailAccountSearchHit where + parseJSON = withObject "EmailAccountSearchHit" $ \o -> + EmailAccountSearchHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + <*> o .:? "sort" + +instance ToJSON EmailAccountSearchHit where + toJSON EmailAccountSearchHit {..} = + omitNulls + [ "_index" .= emailAccountSearchHitIndex, + "_id" .= emailAccountSearchHitId, + "_version" .= emailAccountSearchHitVersion, + "_seq_no" .= emailAccountSearchHitSeqNo, + "_primary_term" .= emailAccountSearchHitPrimaryTerm, + "_score" .= emailAccountSearchHitScore, + "_source" .= emailAccountSearchHitSource, + "sort" .= emailAccountSearchHitSort + ] + +-- | Response envelope for 'searchEmailAccounts'. Reuses 'MonitorsTotal' +-- and 'MonitorsTotalRelation' for the @hits.total@ sub-object and +-- 'AlertingShards' for the @_shards@ sub-object (same wire shapes). +data SearchEmailAccountsResponse = SearchEmailAccountsResponse + { searchEmailAccountsResponseTook :: Int64, + searchEmailAccountsResponseTimedOut :: Bool, + searchEmailAccountsResponseShards :: AlertingShards, + searchEmailAccountsResponseTotal :: MonitorsTotal, + searchEmailAccountsResponseMaxScore :: Maybe Double, + searchEmailAccountsResponseHits :: [EmailAccountSearchHit] + } + deriving stock (Eq, Show) + +instance FromJSON SearchEmailAccountsResponse where + parseJSON = withObject "SearchEmailAccountsResponse" $ \o -> do + hits <- o .: "hits" + SearchEmailAccountsResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SearchEmailAccountsResponse where + toJSON SearchEmailAccountsResponse {..} = + object + [ "took" .= searchEmailAccountsResponseTook, + "timed_out" .= searchEmailAccountsResponseTimedOut, + "_shards" .= searchEmailAccountsResponseShards, + "hits" + .= object + [ "total" .= searchEmailAccountsResponseTotal, + "max_score" .= searchEmailAccountsResponseMaxScore, + "hits" .= searchEmailAccountsResponseHits + ] + ] + +-- ========================================================================= +-- Email group search: POST /_plugins/_alerting/destinations/email_groups/_search +-- ========================================================================= +-- +-- Wire-identical in shape to the email account search; the @_source@ of +-- each hit is a bare 'EmailGroup' instead. + +-- | Optional query body for 'searchEmailGroups'. Same shape as +-- 'EmailAccountSearchQuery'. Pass 'Nothing' or +-- 'defaultEmailGroupSearchQuery' for the plain empty-body @{}@ POST. +data EmailGroupSearchQuery = EmailGroupSearchQuery + { emailGroupSearchQueryFrom :: Maybe Int, + emailGroupSearchQuerySize :: Maybe Int, + emailGroupSearchQuerySort :: Maybe Value, + emailGroupSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultEmailGroupSearchQuery :: EmailGroupSearchQuery +defaultEmailGroupSearchQuery = EmailGroupSearchQuery Nothing Nothing Nothing Nothing + +instance ToJSON EmailGroupSearchQuery where + toJSON EmailGroupSearchQuery {..} = + omitNulls + [ "from" .= emailGroupSearchQueryFrom, + "size" .= emailGroupSearchQuerySize, + "sort" .= emailGroupSearchQuerySort, + "query" .= emailGroupSearchQueryQuery + ] + +instance FromJSON EmailGroupSearchQuery where + parseJSON = withObject "EmailGroupSearchQuery" $ \o -> + EmailGroupSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "sort" + <*> o .:? "query" + +-- | A single hit in @hits.hits[]@ on an email group search response. +-- Mirrors 'EmailAccountSearchHit' but with 'EmailGroup' source. +data EmailGroupSearchHit = EmailGroupSearchHit + { emailGroupSearchHitIndex :: Maybe Text, + emailGroupSearchHitId :: Text, + emailGroupSearchHitVersion :: Maybe Int64, + emailGroupSearchHitSeqNo :: Maybe Int64, + emailGroupSearchHitPrimaryTerm :: Maybe Int64, + emailGroupSearchHitScore :: Maybe Double, + emailGroupSearchHitSource :: EmailGroup, + emailGroupSearchHitSort :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroupSearchHit where + parseJSON = withObject "EmailGroupSearchHit" $ \o -> + EmailGroupSearchHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + <*> o .:? "sort" + +instance ToJSON EmailGroupSearchHit where + toJSON EmailGroupSearchHit {..} = + omitNulls + [ "_index" .= emailGroupSearchHitIndex, + "_id" .= emailGroupSearchHitId, + "_version" .= emailGroupSearchHitVersion, + "_seq_no" .= emailGroupSearchHitSeqNo, + "_primary_term" .= emailGroupSearchHitPrimaryTerm, + "_score" .= emailGroupSearchHitScore, + "_source" .= emailGroupSearchHitSource, + "sort" .= emailGroupSearchHitSort + ] + +-- | Response envelope for 'searchEmailGroups'. Reuses 'MonitorsTotal' +-- and 'AlertingShards'. +data SearchEmailGroupsResponse = SearchEmailGroupsResponse + { searchEmailGroupsResponseTook :: Int64, + searchEmailGroupsResponseTimedOut :: Bool, + searchEmailGroupsResponseShards :: AlertingShards, + searchEmailGroupsResponseTotal :: MonitorsTotal, + searchEmailGroupsResponseMaxScore :: Maybe Double, + searchEmailGroupsResponseHits :: [EmailGroupSearchHit] + } + deriving stock (Eq, Show) + +instance FromJSON SearchEmailGroupsResponse where + parseJSON = withObject "SearchEmailGroupsResponse" $ \o -> do + hits <- o .: "hits" + SearchEmailGroupsResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SearchEmailGroupsResponse where + toJSON SearchEmailGroupsResponse {..} = + object + [ "took" .= searchEmailGroupsResponseTook, + "timed_out" .= searchEmailGroupsResponseTimedOut, + "_shards" .= searchEmailGroupsResponseShards, + "hits" + .= object + [ "total" .= searchEmailGroupsResponseTotal, + "max_score" .= searchEmailGroupsResponseMaxScore, + "hits" .= searchEmailGroupsResponseHits + ] + ] + +-- | Overlay the typed key-value pairs on top of a captured object, +-- dropping typed pairs whose value is @null@ (so optional fields left +-- 'Nothing' do not clobber a non-null value captured from the wire). +-- Mirrors the helper in +-- "Database.Bloodhound.Internal.Versions.Common.Types.PendingTask". +mergeIgnoringNulls :: [(Key, Value)] -> KM.KeyMap Value -> KM.KeyMap Value +mergeIgnoringNulls kvs o = KM.union (KM.fromList (filter notNull kvs)) o + where + notNull (_, Null) = False + notNull _ = True diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/AnomalyDetection.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/AnomalyDetection.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/AnomalyDetection.hs @@ -0,0 +1,1426 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.AnomalyDetection + ( DetectorId (..), + PeriodUnit (..), + periodUnitText, + Period (..), + WindowPeriod (..), + FeatureAttribute (..), + DetectorType (..), + detectorTypeText, + User (..), + Detector (..), + DetectorResponse (..), + CreateDetectorResponse (..), + GetDetectorResponse (..), + GetDetectorParams (..), + defaultGetDetectorParams, + DetectorJob (..), + DetectorJobSchedule (..), + DetectorJobScheduleInterval (..), + DetectionTask (..), + DetectionDateRange (..), + DetectionTaskType (..), + detectionTaskTypeText, + PreviewRequest (..), + FeatureData (..), + Entity (..), + AnomalyResult (..), + PreviewResponse (..), + StartDetectorJobRequest (..), + DetectorJobAcknowledgment (..), + -- | Update / Delete detector + AnomalyShards (..), + DeleteDetectorResponse (..), + -- | Validate detector + ValidateDetectorMode (..), + validateDetectorModeSegments, + ValidateDetectorResponse (..), + -- | Search envelope (detectors / results / tasks) + AnomalySearchTotalRelation (..), + AnomalySearchTotal (..), + AnomalySearchHit (..), + AnomalySearchResponse (..), + anomalySearchResponseSources, + SearchDetectorsResponse, + SearchDetectorResultsResponse, + DeleteDetectorResultsResponse, + SearchDetectorTasksResponse, + -- | Profile / Stats + DetectorProfileResponse (..), + DetectorStatsResponse (..), + -- | Top anomalies + TopAnomaliesOrder (..), + topAnomaliesOrderText, + TopAnomaliesRequest (..), + defaultTopAnomaliesRequest, + TopAnomalyBucket (..), + TopAnomaliesResponse (..), + ) +where + +import Data.Text qualified as T +import Database.Bloodhound.Internal.Client.Doc (DocVersion) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes (DeletedDocuments) + +-- $schema +-- +-- The OpenSearch Anomaly Detection (AD) plugin +-- () +-- detects anomalies in time-series data using Random Cut Forest (RCF). A +-- 'Detector' binds a name and a target index to one or more +-- 'FeatureAttribute's (aggregations the plugin evaluates each +-- 'detectionInterval'); the server persists it under +-- @.opendistro-anomaly-detection-state@ and returns a +-- 'CreateDetectorResponse' wrapping the persisted 'DetectorResponse' with +-- server-injected bookkeeping fields (@_id@, @_version@, @_seq_no@, +-- @_primary_term@, @shingle_size@, @schema_version@, @last_update_time@, +-- @user@, @detector_type@, @rules@, @recency_emphasis@, @history@). +-- +-- We split the request shape ('Detector') from the response shape +-- ('DetectorResponse') so the request cannot accidentally carry +-- server-only fields, while the response still round-trips the full +-- server payload. This mirrors the 'ISMPolicyRequest' / +-- 'ISMPolicyResponse' split used for the ISM plugin. +-- +-- The plugin is shipped with OpenSearch 1.0+; it is present (and +-- wire-compatible) on OS1, OS2 and OS3, hence this module is duplicated +-- across all three versions. +-- +-- Doc ambiguities handled here deliberately: +-- +-- * The @period.unit@ field is documented with only @"Minutes"@ in +-- examples. The plugin source also accepts @Hours@, @Seconds@, @Days@, +-- @Weeks@ and @Months@; we type 'PeriodUnit' as a closed enum with a +-- 'PeriodUnitCustom' escape hatch so future additions surface as a +-- parsed value rather than a decode failure. +-- * The @detector_type@ field is server-derived from the presence of +-- @category_field@. The docs enumerate @"SINGLE_ENTITY"@ and +-- @"MULTI_ENTITY"@; we add 'DetectorTypeCustom' for forward +-- compatibility. +-- * The @rules@ array is server-injected as a default +-- @IGNORE_ANOMALY@ rule (observed in live responses) but is not +-- documented in the field table. We carry it as an opaque 'Value' +-- until the typed schema lands (tracked separately). +-- * The @_start@ endpoint serves double duty: with no body it starts the +-- real-time detector job, and with a 'StartDetectorJobRequest' body it +-- kicks off a one-shot historical backfill (the documented successor to +-- the legacy @_run@). The two forms share one URL and one +-- 'DetectorJobAcknowledgment' response shape but return different +-- @_id@ values (detector id vs historical batch task id). + +-- | Identifies an anomaly detector in the +-- @\/_plugins\/_anomaly_detection\/detectors\/{id}@ URL path. Wraps +-- 'Text' so it round-trips through JSON as a bare string but is distinct +-- at the Haskell type level. +-- See +newtype DetectorId = DetectorId {unDetectorId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @period.unit@ enum documented at +-- . +-- The docs only show @"Minutes"@ in examples; the plugin source accepts +-- a handful of additional values, all enumerated here. Unknown values +-- (forward compatibility) parse as 'PeriodUnitCustom'. +data PeriodUnit + = PeriodUnitMinutes + | PeriodUnitHours + | PeriodUnitSeconds + | PeriodUnitDays + | PeriodUnitWeeks + | PeriodUnitMonths + | PeriodUnitCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'PeriodUnit' — the same mapping the 'ToJSON' +-- \/ 'FromJSON' instances use, exposed as plain 'Text' for callers that +-- need the wire string without going through a 'Data.Aeson.Value'. +periodUnitText :: PeriodUnit -> Text +periodUnitText = \case + PeriodUnitMinutes -> "Minutes" + PeriodUnitHours -> "Hours" + PeriodUnitSeconds -> "Seconds" + PeriodUnitDays -> "Days" + PeriodUnitWeeks -> "Weeks" + PeriodUnitMonths -> "Months" + PeriodUnitCustom t -> t + +instance ToJSON PeriodUnit where + toJSON = toJSON . periodUnitText + +instance FromJSON PeriodUnit where + parseJSON = withText "PeriodUnit" $ \case + "Minutes" -> pure PeriodUnitMinutes + "Hours" -> pure PeriodUnitHours + "Seconds" -> pure PeriodUnitSeconds + "Days" -> pure PeriodUnitDays + "Weeks" -> pure PeriodUnitWeeks + "Months" -> pure PeriodUnitMonths + other -> pure (PeriodUnitCustom other) + +-- | The inner @{interval, unit}@ object shared by 'WindowPeriod'. The +-- @interval@ is a positive integer; @unit@ names the time unit. +-- See +data Period = Period + { periodInterval :: Int, + periodUnit :: PeriodUnit + } + deriving stock (Eq, Show) + +instance FromJSON Period where + parseJSON = withObject "Period" $ \v -> do + periodInterval <- v .: "interval" + periodUnit <- v .: "unit" + pure Period {..} + +instance ToJSON Period where + toJSON Period {..} = + object + [ "interval" .= periodInterval, + "unit" .= periodUnit + ] + +-- | The wrapper @{period: {interval, unit}}@ used by both +-- @detection_interval@ and @window_delay@. Distinct from 'Period' so the +-- two levels cannot be confused at the call site. +-- See +newtype WindowPeriod = WindowPeriod {windowPeriodPeriod :: Period} + deriving stock (Eq, Show) + +instance FromJSON WindowPeriod where + parseJSON = withObject "WindowPeriod" $ \v -> + WindowPeriod <$> v .: "period" + +instance ToJSON WindowPeriod where + toJSON WindowPeriod {..} = + object ["period" .= windowPeriodPeriod] + +-- | A feature attribute: a named aggregation the plugin evaluates each +-- detection interval. The request shape omits @feature_id@ (the server +-- generates one); the response shape fills it in via 'featureAttributeId'. +-- @aggregation_query@ is an arbitrary OpenSearch aggregations DSL body, +-- so it is carried as an opaque 'Value' (the same approach the ISM +-- module takes for untyped DSL fragments). +-- See +data FeatureAttribute = FeatureAttribute + { featureAttributeId :: Maybe Text, + featureAttributeName :: Text, + featureAttributeEnabled :: Bool, + featureAttributeAggregationQuery :: Value + } + deriving stock (Eq, Show) + +instance FromJSON FeatureAttribute where + parseJSON = withObject "FeatureAttribute" $ \v -> do + featureAttributeId <- v .:? "feature_id" + featureAttributeName <- v .: "feature_name" + featureAttributeEnabled <- v .:? "feature_enabled" .!= True + featureAttributeAggregationQuery <- v .: "aggregation_query" + pure FeatureAttribute {..} + +instance ToJSON FeatureAttribute where + toJSON FeatureAttribute {..} = + omitNulls + [ "feature_id" .= featureAttributeId, + "feature_name" .= featureAttributeName, + "feature_enabled" .= featureAttributeEnabled, + "aggregation_query" .= featureAttributeAggregationQuery + ] + +-- | The @detector_type@ enum. The docs enumerate @"SINGLE_ENTITY"@ (no +-- @category_field@ set) and @"MULTI_ENTITY"@ (@category_field@ set); +-- unknown values parse as 'DetectorTypeCustom' so future plugin +-- releases surface as a parsed value rather than a decode failure. +-- The field is server-derived; callers never need to construct it. +data DetectorType + = DetectorTypeSingleEntity + | DetectorTypeMultiEntity + | DetectorTypeCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'DetectorType' — the same mapping the +-- 'ToJSON' \/ 'FromJSON' instances use. +detectorTypeText :: DetectorType -> Text +detectorTypeText = \case + DetectorTypeSingleEntity -> "SINGLE_ENTITY" + DetectorTypeMultiEntity -> "MULTI_ENTITY" + DetectorTypeCustom t -> t + +instance ToJSON DetectorType where + toJSON = toJSON . detectorTypeText + +instance FromJSON DetectorType where + parseJSON = withText "DetectorType" $ \case + "SINGLE_ENTITY" -> pure DetectorTypeSingleEntity + "MULTI_ENTITY" -> pure DetectorTypeMultiEntity + other -> pure (DetectorTypeCustom other) + +-- | The server-injected @user@ object carried on every detector +-- response. The plugin populates it from the authenticated caller; the +-- request never supplies it. All fields are 'Maybe' because the plugin +-- docs do not enumerate which subsets may be absent for non-admin +-- callers or internal users. +-- See +data User = User + { userName :: Maybe Text, + userBackendRoles :: Maybe [Text], + userRoles :: Maybe [Text], + userCustomAttributeNames :: Maybe [Value], + userUserRequestedTenant :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON User where + parseJSON = withObject "User" $ \v -> do + userName <- v .:? "name" + userBackendRoles <- v .:? "backend_roles" + userRoles <- v .:? "roles" + userCustomAttributeNames <- v .:? "custom_attribute_names" + userUserRequestedTenant <- v .:? "user_requested_tenant" + pure User {..} + +instance ToJSON User where + toJSON User {..} = + omitNulls + [ "name" .= userName, + "backend_roles" .= userBackendRoles, + "roles" .= userRoles, + "custom_attribute_names" .= userCustomAttributeNames, + "user_requested_tenant" .= userUserRequestedTenant + ] + +-- $detectorSchema +-- +-- The 'Detector' request body carries the user-supplied fields the +-- server needs to create or update an anomaly detector. Server-only +-- fields (@shingle_size@, @schema_version@, @last_update_time@, @user@, +-- @detector_type@, @rules@, @recency_emphasis@, @history@) are +-- deliberately absent — including them would invite callers to send +-- values the server ignores or rejects. They appear on the +-- 'DetectorResponse' round-trip shape. + +-- | The request body for @POST /_plugins/_anomaly_detection/detectors@. +-- Required fields: @name@, @time_field@, @indices@, +-- @feature_attributes@, @detection_interval@. Everything else is +-- optional and omitted on the wire when 'Nothing'. +-- See +data Detector = Detector + { detectorName :: Text, + detectorDescription :: Maybe Text, + detectorTimeField :: Text, + detectorIndices :: [Text], + detectorFeatureAttributes :: [FeatureAttribute], + detectorFilterQuery :: Maybe Value, + detectorDetectionInterval :: WindowPeriod, + detectorWindowDelay :: Maybe WindowPeriod, + detectorCategoryField :: Maybe [Text], + detectorResultIndex :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON Detector where + parseJSON = withObject "Detector" $ \v -> do + detectorName <- v .: "name" + detectorDescription <- v .:? "description" + detectorTimeField <- v .: "time_field" + detectorIndices <- v .:? "indices" .!= [] + detectorFeatureAttributes <- v .:? "feature_attributes" .!= [] + detectorFilterQuery <- v .:? "filter_query" + detectorDetectionInterval <- v .: "detection_interval" + detectorWindowDelay <- v .:? "window_delay" + detectorCategoryField <- v .:? "category_field" + detectorResultIndex <- v .:? "result_index" + pure Detector {..} + +instance ToJSON Detector where + toJSON Detector {..} = + omitNulls + [ "name" .= detectorName, + "description" .= detectorDescription, + "time_field" .= detectorTimeField, + "indices" .= detectorIndices, + "feature_attributes" .= detectorFeatureAttributes, + "filter_query" .= detectorFilterQuery, + "detection_interval" .= detectorDetectionInterval, + "window_delay" .= detectorWindowDelay, + "category_field" .= detectorCategoryField, + "result_index" .= detectorResultIndex + ] + +-- | The persisted detector shape returned in responses (the inner +-- @anomaly_detector@ object of a 'CreateDetectorResponse' / +-- 'GetDetectorResponse' / 'PreviewResponse'). Carries the full +-- 'Detector' body alongside server-injected bookkeeping fields. The +-- round-trip preserves everything the server sent, so a Get → Update +-- cycle does not lose data the caller never set. +-- See +data DetectorResponse = DetectorResponse + { detectorResponseName :: Text, + detectorResponseDescription :: Maybe Text, + detectorResponseTimeField :: Text, + detectorResponseIndices :: [Text], + detectorResponseFilterQuery :: Maybe Value, + detectorResponseDetectionInterval :: WindowPeriod, + detectorResponseWindowDelay :: Maybe WindowPeriod, + detectorResponseShingleSize :: Maybe Int, + detectorResponseSchemaVersion :: Maybe Int, + detectorResponseFeatureAttributes :: [FeatureAttribute], + detectorResponseLastUpdateTime :: Maybe Integer, + detectorResponseUser :: Maybe User, + detectorResponseDetectorType :: Maybe DetectorType, + detectorResponseCategoryField :: Maybe [Text], + detectorResponseResultIndex :: Maybe Text, + -- Server-injected bookkeeping the docs do not enumerate but live + -- responses carry. Typed as 'Value' / 'Int' until a follow-up + -- promotes them (see module docs). + detectorResponseRecencyEmphasis :: Maybe Int, + detectorResponseHistory :: Maybe Int, + detectorResponseRules :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON DetectorResponse where + parseJSON = withObject "DetectorResponse" $ \v -> do + detectorResponseName <- v .: "name" + detectorResponseDescription <- v .:? "description" + detectorResponseTimeField <- v .: "time_field" + detectorResponseIndices <- v .:? "indices" .!= [] + detectorResponseFilterQuery <- v .:? "filter_query" + detectorResponseDetectionInterval <- v .: "detection_interval" + detectorResponseWindowDelay <- v .:? "window_delay" + detectorResponseShingleSize <- v .:? "shingle_size" + detectorResponseSchemaVersion <- v .:? "schema_version" + detectorResponseFeatureAttributes <- v .:? "feature_attributes" .!= [] + detectorResponseLastUpdateTime <- v .:? "last_update_time" + detectorResponseUser <- v .:? "user" + detectorResponseDetectorType <- v .:? "detector_type" + detectorResponseCategoryField <- v .:? "category_field" + detectorResponseResultIndex <- v .:? "result_index" + detectorResponseRecencyEmphasis <- v .:? "recency_emphasis" + detectorResponseHistory <- v .:? "history" + detectorResponseRules <- v .:? "rules" + pure DetectorResponse {..} + +instance ToJSON DetectorResponse where + toJSON DetectorResponse {..} = + omitNulls + [ "name" .= detectorResponseName, + "description" .= detectorResponseDescription, + "time_field" .= detectorResponseTimeField, + "indices" .= detectorResponseIndices, + "filter_query" .= detectorResponseFilterQuery, + "detection_interval" .= detectorResponseDetectionInterval, + "window_delay" .= detectorResponseWindowDelay, + "shingle_size" .= detectorResponseShingleSize, + "schema_version" .= detectorResponseSchemaVersion, + "feature_attributes" .= detectorResponseFeatureAttributes, + "last_update_time" .= detectorResponseLastUpdateTime, + "user" .= detectorResponseUser, + "detector_type" .= detectorResponseDetectorType, + "category_field" .= detectorResponseCategoryField, + "result_index" .= detectorResponseResultIndex, + "recency_emphasis" .= detectorResponseRecencyEmphasis, + "history" .= detectorResponseHistory, + "rules" .= detectorResponseRules + ] + +-- | Response body of @POST /_plugins/_anomaly_detection/detectors@. The +-- server wraps the persisted 'DetectorResponse' in a document-write +-- envelope (@_id@, @_version@, @_primary_term@, @_seq_no@) — the same +-- shape OpenSearch uses for any persisted document. +-- See +data CreateDetectorResponse = CreateDetectorResponse + { createDetectorResponseId :: Text, + createDetectorResponseVersion :: DocVersion, + createDetectorResponsePrimaryTerm :: Int, + createDetectorResponseSeqNo :: Int, + createDetectorResponseDetector :: DetectorResponse + } + deriving stock (Eq, Show) + +instance FromJSON CreateDetectorResponse where + parseJSON = withObject "CreateDetectorResponse" $ \v -> do + createDetectorResponseId <- v .: "_id" + createDetectorResponseVersion <- v .: "_version" + createDetectorResponsePrimaryTerm <- v .: "_primary_term" + createDetectorResponseSeqNo <- v .: "_seq_no" + createDetectorResponseDetector <- v .: "anomaly_detector" + pure CreateDetectorResponse {..} + +instance ToJSON CreateDetectorResponse where + toJSON CreateDetectorResponse {..} = + object + [ "_id" .= createDetectorResponseId, + "_version" .= createDetectorResponseVersion, + "_primary_term" .= createDetectorResponsePrimaryTerm, + "_seq_no" .= createDetectorResponseSeqNo, + "anomaly_detector" .= createDetectorResponseDetector + ] + +-- | Response body of @GET /_plugins/_anomaly_detection/detectors/{id}@. +-- Structurally a superset of 'CreateDetectorResponse': the same +-- document-write envelope (@_id@, @_version@, @_primary_term@, @_seq_no@) +-- around the same inner 'DetectorResponse', plus up to three optional +-- sibling objects that the server only embeds when the corresponding +-- query flag is set on the request ('GetDetectorParams'): +-- +-- * @?job=true@ adds 'getDetectorResponseJob' (@anomaly_detector_job@); +-- * @?task=true@ adds 'getDetectorResponseRealtimeTask' +-- (@realtime_detection_task@) and 'getDetectorResponseHistoricalTask' +-- (@historical_analysis_task@). +-- +-- Without either flag the three 'Maybe' fields decode as 'Nothing', so a +-- plain GET round-trips exactly like the old 'CreateDetectorResponse'. +-- See +data GetDetectorResponse = GetDetectorResponse + { getDetectorResponseId :: Text, + getDetectorResponseVersion :: DocVersion, + getDetectorResponsePrimaryTerm :: Int, + getDetectorResponseSeqNo :: Int, + getDetectorResponseDetector :: DetectorResponse, + getDetectorResponseJob :: Maybe DetectorJob, + getDetectorResponseRealtimeTask :: Maybe DetectionTask, + getDetectorResponseHistoricalTask :: Maybe DetectionTask + } + deriving stock (Eq, Show) + +instance FromJSON GetDetectorResponse where + parseJSON = withObject "GetDetectorResponse" $ \v -> do + getDetectorResponseId <- v .: "_id" + getDetectorResponseVersion <- v .: "_version" + getDetectorResponsePrimaryTerm <- v .: "_primary_term" + getDetectorResponseSeqNo <- v .: "_seq_no" + getDetectorResponseDetector <- v .: "anomaly_detector" + getDetectorResponseJob <- v .:? "anomaly_detector_job" + getDetectorResponseRealtimeTask <- v .:? "realtime_detection_task" + getDetectorResponseHistoricalTask <- v .:? "historical_analysis_task" + pure GetDetectorResponse {..} + +instance ToJSON GetDetectorResponse where + toJSON GetDetectorResponse {..} = + omitNulls + [ "_id" .= getDetectorResponseId, + "_version" .= getDetectorResponseVersion, + "_primary_term" .= getDetectorResponsePrimaryTerm, + "_seq_no" .= getDetectorResponseSeqNo, + "anomaly_detector" .= getDetectorResponseDetector, + "anomaly_detector_job" .= getDetectorResponseJob, + "realtime_detection_task" .= getDetectorResponseRealtimeTask, + "historical_analysis_task" .= getDetectorResponseHistoricalTask + ] + +-- | Optional flags for 'getDetector' that select which extra sibling +-- objects the server embeds in the 'GetDetectorResponse'. Both default +-- to 'False' via 'defaultGetDetectorParams', reproducing the bare GET. +-- See +data GetDetectorParams = GetDetectorParams + { -- | @?job=true@ — embed 'getDetectorResponseJob' (real-time job + -- schedule / state). + getDetectorParamsJob :: Bool, + -- | @?task=true@ — embed 'getDetectorResponseRealtimeTask' and + -- 'getDetectorResponseHistoricalTask' (running task records). + getDetectorParamsTask :: Bool + } + deriving stock (Eq, Show) + +-- | The all-false 'GetDetectorParams', equivalent to a bare GET. +defaultGetDetectorParams :: GetDetectorParams +defaultGetDetectorParams = GetDetectorParams {getDetectorParamsJob = False, getDetectorParamsTask = False} + +-- ========================================================================= +-- Detector job (anomaly_detector_job, returned with ?job=true) +-- ========================================================================= + +-- | The @anomaly_detector_job@ object the server embeds in a +-- 'GetDetectorResponse' when the request carries @?job=true@. The job +-- binds the real-time detector's schedule and runtime bookkeeping. +-- All fields are 'Maybe' because the docs describe the shape only by +-- example; some may be absent for internal or disabled detectors. +-- See +data DetectorJob = DetectorJob + { detectorJobName :: Maybe Text, + detectorJobSchedule :: Maybe DetectorJobSchedule, + detectorJobWindowDelay :: Maybe WindowPeriod, + detectorJobEnabled :: Maybe Bool, + detectorJobEnabledTime :: Maybe Integer, + detectorJobLastUpdateTime :: Maybe Integer, + detectorJobLockDurationSeconds :: Maybe Int, + detectorJobUser :: Maybe User + } + deriving stock (Eq, Show) + +instance FromJSON DetectorJob where + parseJSON = withObject "DetectorJob" $ \v -> do + detectorJobName <- v .:? "name" + detectorJobSchedule <- v .:? "schedule" + detectorJobWindowDelay <- v .:? "window_delay" + detectorJobEnabled <- v .:? "enabled" + detectorJobEnabledTime <- v .:? "enabled_time" + detectorJobLastUpdateTime <- v .:? "last_update_time" + detectorJobLockDurationSeconds <- v .:? "lock_duration_seconds" + detectorJobUser <- v .:? "user" + pure DetectorJob {..} + +instance ToJSON DetectorJob where + toJSON DetectorJob {..} = + omitNulls + [ "name" .= detectorJobName, + "schedule" .= detectorJobSchedule, + "window_delay" .= detectorJobWindowDelay, + "enabled" .= detectorJobEnabled, + "enabled_time" .= detectorJobEnabledTime, + "last_update_time" .= detectorJobLastUpdateTime, + "lock_duration_seconds" .= detectorJobLockDurationSeconds, + "user" .= detectorJobUser + ] + +-- | The @schedule@ object of a 'DetectorJob'. The docs only show the +-- 'DetectorJobScheduleInterval' (@{interval: {...}}@) form; other +-- schedule variants (e.g. cron) are not documented and would need a +-- follow-up to type. They surface as a decode failure today. +-- See +data DetectorJobSchedule = DetectorJobSchedule + { detectorJobScheduleInterval :: DetectorJobScheduleInterval + } + deriving stock (Eq, Show) + +instance FromJSON DetectorJobSchedule where + parseJSON = withObject "DetectorJobSchedule" $ \v -> do + detectorJobScheduleInterval <- v .: "interval" + pure DetectorJobSchedule {..} + +instance ToJSON DetectorJobSchedule where + toJSON DetectorJobSchedule {..} = + object ["interval" .= detectorJobScheduleInterval] + +-- | The @interval@ object inside a 'DetectorJobSchedule'. Mirrors the +-- 'WindowPeriod' @{interval, unit}@ pair but adds an optional +-- @start_time@ (epoch ms) the scheduler uses to stagger the first run. +-- See +data DetectorJobScheduleInterval = DetectorJobScheduleInterval + { detectorJobScheduleIntervalStartTime :: Maybe Integer, + detectorJobScheduleIntervalPeriod :: Int, + detectorJobScheduleIntervalUnit :: PeriodUnit + } + deriving stock (Eq, Show) + +instance FromJSON DetectorJobScheduleInterval where + parseJSON = withObject "DetectorJobScheduleInterval" $ \v -> do + detectorJobScheduleIntervalStartTime <- v .:? "start_time" + detectorJobScheduleIntervalPeriod <- v .: "period" + detectorJobScheduleIntervalUnit <- v .: "unit" + pure DetectorJobScheduleInterval {..} + +instance ToJSON DetectorJobScheduleInterval where + toJSON DetectorJobScheduleInterval {..} = + omitNulls + [ "start_time" .= detectorJobScheduleIntervalStartTime, + "period" .= detectorJobScheduleIntervalPeriod, + "unit" .= detectorJobScheduleIntervalUnit + ] + +-- ========================================================================= +-- Detection tasks (realtime_detection_task / historical_analysis_task, +-- returned with ?task=true) +-- ========================================================================= + +-- | The @task_type@ enum carried by a 'DetectionTask'. The docs +-- enumerate the two single-entity values (@REALTIME_SINGLE_ENTITY@, +-- @HISTORICAL_SINGLE_ENTITY@); the two multi-entity values +-- (@REALTIME_MULTI_ENTITY@, @HISTORICAL_MULTI_ENTITY@) are inferred from +-- the naming convention. Unknown values parse as +-- 'DetectionTaskTypeCustom' so future plugin releases surface as a +-- parsed value rather than a decode failure. +data DetectionTaskType + = DetectionTaskTypeRealtimeSingleEntity + | DetectionTaskTypeHistoricalSingleEntity + | DetectionTaskTypeRealtimeMultiEntity + | DetectionTaskTypeHistoricalMultiEntity + | DetectionTaskTypeCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'DetectionTaskType' — the same mapping the +-- 'ToJSON' \/ 'FromJSON' instances use. +detectionTaskTypeText :: DetectionTaskType -> Text +detectionTaskTypeText = \case + DetectionTaskTypeRealtimeSingleEntity -> "REALTIME_SINGLE_ENTITY" + DetectionTaskTypeHistoricalSingleEntity -> "HISTORICAL_SINGLE_ENTITY" + DetectionTaskTypeRealtimeMultiEntity -> "REALTIME_MULTI_ENTITY" + DetectionTaskTypeHistoricalMultiEntity -> "HISTORICAL_MULTI_ENTITY" + DetectionTaskTypeCustom t -> t + +instance ToJSON DetectionTaskType where + toJSON = toJSON . detectionTaskTypeText + +instance FromJSON DetectionTaskType where + parseJSON = withText "DetectionTaskType" $ \case + "REALTIME_SINGLE_ENTITY" -> pure DetectionTaskTypeRealtimeSingleEntity + "HISTORICAL_SINGLE_ENTITY" -> pure DetectionTaskTypeHistoricalSingleEntity + "REALTIME_MULTI_ENTITY" -> pure DetectionTaskTypeRealtimeMultiEntity + "HISTORICAL_MULTI_ENTITY" -> pure DetectionTaskTypeHistoricalMultiEntity + other -> pure (DetectionTaskTypeCustom other) + +-- | A detection task record. The server embeds one of these under +-- @realtime_detection_task@ (the running real-time job) and/or +-- @historical_analysis_task@ (a historical backfill batch) in a +-- 'GetDetectorResponse' when the request carries @?task=true@. +-- +-- The shape is the union of the two documented examples: some fields +-- appear only on the real-time variant (@estimated_minutes_left@) and +-- some only on the historical variant (@current_piece@, @worker_node@, +-- 'detectionTaskDetectionDateRange'), so every field except @task_id@ +-- is 'Maybe'. Progress fractions are 'Scientific' because the plugin +-- emits them as either an integer (@0@) or a fraction (@0.89285713@); +-- 'Scientific' round-trips both losslessly. +-- See +data DetectionTask = DetectionTask + { detectionTaskTaskId :: Text, + detectionTaskType :: Maybe DetectionTaskType, + detectionTaskState :: Maybe Text, + detectionTaskDetectorId :: Maybe DetectorId, + detectionTaskDetector :: Maybe DetectorResponse, + detectionTaskTaskProgress :: Maybe Scientific, + detectionTaskInitProgress :: Maybe Scientific, + detectionTaskIsLatest :: Maybe Bool, + detectionTaskExecutionStartTime :: Maybe Integer, + detectionTaskLastUpdateTime :: Maybe Integer, + detectionTaskCurrentPiece :: Maybe Integer, + detectionTaskDetectionDateRange :: Maybe DetectionDateRange, + detectionTaskEstimatedMinutesLeft :: Maybe Int, + detectionTaskCoordinatingNode :: Maybe Text, + detectionTaskWorkerNode :: Maybe Text, + detectionTaskStartedBy :: Maybe Text, + detectionTaskError :: Maybe Text, + detectionTaskUser :: Maybe User + } + deriving stock (Eq, Show) + +instance FromJSON DetectionTask where + parseJSON = withObject "DetectionTask" $ \v -> do + detectionTaskTaskId <- v .: "task_id" + detectionTaskType <- v .:? "task_type" + detectionTaskState <- v .:? "state" + detectionTaskDetectorId <- v .:? "detector_id" + detectionTaskDetector <- v .:? "detector" + detectionTaskTaskProgress <- v .:? "task_progress" + detectionTaskInitProgress <- v .:? "init_progress" + detectionTaskIsLatest <- v .:? "is_latest" + detectionTaskExecutionStartTime <- v .:? "execution_start_time" + detectionTaskLastUpdateTime <- v .:? "last_update_time" + detectionTaskCurrentPiece <- v .:? "current_piece" + detectionTaskDetectionDateRange <- v .:? "detection_date_range" + detectionTaskEstimatedMinutesLeft <- v .:? "estimated_minutes_left" + detectionTaskCoordinatingNode <- v .:? "coordinating_node" + detectionTaskWorkerNode <- v .:? "worker_node" + detectionTaskStartedBy <- v .:? "started_by" + detectionTaskError <- v .:? "error" + detectionTaskUser <- v .:? "user" + pure DetectionTask {..} + +instance ToJSON DetectionTask where + toJSON DetectionTask {..} = + omitNulls + [ "task_id" .= detectionTaskTaskId, + "task_type" .= detectionTaskType, + "state" .= detectionTaskState, + "detector_id" .= detectionTaskDetectorId, + "detector" .= detectionTaskDetector, + "task_progress" .= detectionTaskTaskProgress, + "init_progress" .= detectionTaskInitProgress, + "is_latest" .= detectionTaskIsLatest, + "execution_start_time" .= detectionTaskExecutionStartTime, + "last_update_time" .= detectionTaskLastUpdateTime, + "current_piece" .= detectionTaskCurrentPiece, + "detection_date_range" .= detectionTaskDetectionDateRange, + "estimated_minutes_left" .= detectionTaskEstimatedMinutesLeft, + "coordinating_node" .= detectionTaskCoordinatingNode, + "worker_node" .= detectionTaskWorkerNode, + "started_by" .= detectionTaskStartedBy, + "error" .= detectionTaskError, + "user" .= detectionTaskUser + ] + +-- | The @detection_date_range@ object carried by a historical +-- 'DetectionTask'. Bounds the historical window the batch is +-- backfilling, as epoch-ms timestamps. Absent on real-time tasks. +-- See +data DetectionDateRange = DetectionDateRange + { detectionDateRangeStartTime :: Maybe Integer, + detectionDateRangeEndTime :: Maybe Integer + } + deriving stock (Eq, Show) + +instance FromJSON DetectionDateRange where + parseJSON = withObject "DetectionDateRange" $ \v -> do + detectionDateRangeStartTime <- v .:? "start_time" + detectionDateRangeEndTime <- v .:? "end_time" + pure DetectionDateRange {..} + +instance ToJSON DetectionDateRange where + toJSON DetectionDateRange {..} = + omitNulls + [ "start_time" .= detectionDateRangeStartTime, + "end_time" .= detectionDateRangeEndTime + ] + +-- ========================================================================= +-- Preview endpoint: POST /_plugins/_anomaly_detection/detectors/_preview +-- ========================================================================= + +-- | Request body for the Anomaly Detection plugin Preview Detector API +-- (@POST /_plugins/_anomaly_detection/detectors/_preview@). The two +-- fields @period_start@ and @period_end@ are epoch-ms timestamps +-- bracketing the historical window the plugin should re-analyze. The +-- plugin requires both (a missing value yields HTTP 400 with +-- @Must set both period start and end date with epoch of milliseconds@). +-- +-- The optional 'previewRequestDetectorId' names the detector to preview +-- (set by 'previewDetector' from its path argument, or directly by the +-- caller of 'previewDetectorInline'); 'previewRequestDetector' carries a +-- full unpersisted 'Detector' config for the inline form. Both are +-- omitted from the wire payload when 'Nothing', so a periods-only body +-- round-trips as just the two timestamps. +-- See +data PreviewRequest = PreviewRequest + { previewRequestPeriodStart :: Integer, + previewRequestPeriodEnd :: Integer, + previewRequestDetector :: Maybe Detector, + previewRequestDetectorId :: Maybe DetectorId + } + deriving stock (Eq, Show) + +instance FromJSON PreviewRequest where + parseJSON = withObject "PreviewRequest" $ \v -> do + previewRequestPeriodStart <- v .: "period_start" + previewRequestPeriodEnd <- v .: "period_end" + previewRequestDetector <- v .:? "detector" + previewRequestDetectorId <- v .:? "detector_id" + pure PreviewRequest {..} + +instance ToJSON PreviewRequest where + toJSON PreviewRequest {..} = + omitNulls + [ "period_start" .= previewRequestPeriodStart, + "period_end" .= previewRequestPeriodEnd, + "detector" .= previewRequestDetector, + "detector_id" .= previewRequestDetectorId + ] + +-- | One entry in the @feature_data@ array of an 'AnomalyResult'. The +-- @feature_id@ echoes the corresponding 'FeatureAttribute' identifier; +-- @data@ is the observed feature value for the window. Both come back +-- as @0@ in fresh / sparse fixtures, so they are 'Maybe' for safety. +data FeatureData = FeatureData + { featureDataFeatureId :: Maybe Text, + featureDataFeatureName :: Text, + featureDataData :: Maybe Double + } + deriving stock (Eq, Show) + +instance FromJSON FeatureData where + parseJSON = withObject "FeatureData" $ \v -> do + featureDataFeatureId <- v .:? "feature_id" + featureDataFeatureName <- v .: "feature_name" + featureDataData <- v .:? "data" + pure FeatureData {..} + +instance ToJSON FeatureData where + toJSON FeatureData {..} = + omitNulls + [ "feature_id" .= featureDataFeatureId, + "feature_name" .= featureDataFeatureName, + "data" .= featureDataData + ] + +-- | One entry in the @entity@ array of a multi-entity 'AnomalyResult'. +-- The plugin emits @entity@ only when the detector was created with a +-- @category_field@; each entry names the categorical dimension +-- (@name@) and the value the anomaly was graded against (@value@). +-- See +data Entity = Entity + { entityName :: Text, + entityValue :: Text + } + deriving stock (Eq, Show) + +instance FromJSON Entity where + parseJSON = withObject "Entity" $ \v -> do + entityName <- v .: "name" + entityValue <- v .: "value" + pure Entity {..} + +instance ToJSON Entity where + toJSON Entity {..} = + object + [ "name" .= entityName, + "value" .= entityValue + ] + +-- | One entry in the @anomaly_result@ array of a 'PreviewResponse'. +-- Every field is 'Maybe' or has a sensible empty default because the +-- plugin emits a sparse shape early in training (zero @anomaly_grade@, +-- zero @confidence@, empty @feature_data@) and a fuller shape once the +-- model has converged. +-- See +data AnomalyResult = AnomalyResult + { anomalyResultDetectorId :: Maybe Text, + anomalyResultDataStartTime :: Integer, + anomalyResultDataEndTime :: Integer, + anomalyResultSchemaVersion :: Maybe Int, + anomalyResultFeatureData :: [FeatureData], + anomalyResultAnomalyGrade :: Maybe Double, + anomalyResultConfidence :: Maybe Double, + anomalyResultEntity :: Maybe [Entity], + anomalyResultUser :: Maybe User + } + deriving stock (Eq, Show) + +instance FromJSON AnomalyResult where + parseJSON = withObject "AnomalyResult" $ \v -> do + anomalyResultDetectorId <- v .:? "detector_id" + anomalyResultDataStartTime <- v .: "data_start_time" + anomalyResultDataEndTime <- v .: "data_end_time" + anomalyResultSchemaVersion <- v .:? "schema_version" + anomalyResultFeatureData <- v .:? "feature_data" .!= [] + anomalyResultAnomalyGrade <- v .:? "anomaly_grade" + anomalyResultConfidence <- v .:? "confidence" + anomalyResultEntity <- v .:? "entity" + anomalyResultUser <- v .:? "user" + pure AnomalyResult {..} + +instance ToJSON AnomalyResult where + toJSON AnomalyResult {..} = + omitNulls + [ "detector_id" .= anomalyResultDetectorId, + "data_start_time" .= anomalyResultDataStartTime, + "data_end_time" .= anomalyResultDataEndTime, + "schema_version" .= anomalyResultSchemaVersion, + "feature_data" .= anomalyResultFeatureData, + "anomaly_grade" .= anomalyResultAnomalyGrade, + "confidence" .= anomalyResultConfidence, + "entity" .= anomalyResultEntity, + "user" .= anomalyResultUser + ] + +-- | Response body of @_preview@: an @anomaly_result@ array plus the +-- detector snapshot the plugin graded against (the same +-- 'DetectorResponse' shape returned by create / get). +-- See +data PreviewResponse = PreviewResponse + { previewResponseAnomalyResult :: [AnomalyResult], + previewResponseAnomalyDetector :: DetectorResponse + } + deriving stock (Eq, Show) + +instance FromJSON PreviewResponse where + parseJSON = withObject "PreviewResponse" $ \v -> do + previewResponseAnomalyResult <- v .:? "anomaly_result" .!= [] + previewResponseAnomalyDetector <- v .: "anomaly_detector" + pure PreviewResponse {..} + +instance ToJSON PreviewResponse where + toJSON PreviewResponse {..} = + object + [ "anomaly_result" .= previewResponseAnomalyResult, + "anomaly_detector" .= previewResponseAnomalyDetector + ] + +-- ========================================================================= +-- Update / Delete detector +-- ========================================================================= + +-- | The standard @{total, successful, skipped, failed}@ shard-report +-- sub-object carried by AD delete and search responses. Defined locally +-- (mirroring the 'AlertingShards' pattern) rather than borrowing a +-- Common type, to keep the AD module self-contained. +data AnomalyShards = AnomalyShards + { anomalyShardsTotal :: Int, + anomalyShardsSuccessful :: Int, + anomalyShardsSkipped :: Int, + anomalyShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON AnomalyShards where + parseJSON = withObject "AnomalyShards" $ \v -> + AnomalyShards + <$> v .:? "total" .!= 0 + <*> v .:? "successful" .!= 0 + <*> v .:? "skipped" .!= 0 + <*> v .:? "failed" .!= 0 + +instance ToJSON AnomalyShards where + toJSON AnomalyShards {..} = + object + [ "total" .= anomalyShardsTotal, + "successful" .= anomalyShardsSuccessful, + "skipped" .= anomalyShardsSkipped, + "failed" .= anomalyShardsFailed + ] + +-- | Response body of @DELETE /_plugins/_anomaly_detection/detectors/{id}@. +-- The AD delete endpoint returns the bare Elasticsearch delete-document +-- envelope (@_index@, @_id@, @_version@, @result@, @forced_refresh@, +-- @_shards@, @_seq_no@, @_primary_term@) — NOT an @{acknowledged: true}@ +-- ack, so an 'Acknowledged' decoder would raise 'EsProtocolException' at +-- runtime. Modelled verbatim, mirroring the Alerting 'DeleteMonitorResponse' +-- and Security Analytics 'DeleteSADetectorResponse' precedent. +-- See +data DeleteDetectorResponse = DeleteDetectorResponse + { deleteDetectorResponseIndex :: Text, + deleteDetectorResponseId :: Text, + deleteDetectorResponseVersion :: Int, + deleteDetectorResponseResult :: Text, + deleteDetectorResponseForcedRefresh :: Bool, + deleteDetectorResponseShards :: AnomalyShards, + deleteDetectorResponseSeqNo :: Int, + deleteDetectorResponsePrimaryTerm :: Int + } + deriving stock (Eq, Show) + +instance FromJSON DeleteDetectorResponse where + parseJSON = withObject "DeleteDetectorResponse" $ \v -> + DeleteDetectorResponse + <$> v .: "_index" + <*> v .: "_id" + <*> v .: "_version" + <*> v .: "result" + <*> v .:? "forced_refresh" .!= False + <*> v .: "_shards" + <*> v .: "_seq_no" + <*> v .: "_primary_term" + +instance ToJSON DeleteDetectorResponse where + toJSON DeleteDetectorResponse {..} = + object + [ "_index" .= deleteDetectorResponseIndex, + "_id" .= deleteDetectorResponseId, + "_version" .= deleteDetectorResponseVersion, + "result" .= deleteDetectorResponseResult, + "forced_refresh" .= deleteDetectorResponseForcedRefresh, + "_shards" .= deleteDetectorResponseShards, + "_seq_no" .= deleteDetectorResponseSeqNo, + "_primary_term" .= deleteDetectorResponsePrimaryTerm + ] + +-- ========================================================================= +-- Start / Stop detector job +-- ========================================================================= + +-- | Request body for the historical-analysis form of +-- @POST /_plugins/_anomaly_detection/detectors/{id}/_start@. +-- +-- The @_start@ endpoint serves two roles: with no body it starts the +-- real-time detector job, and with a body it kicks off a one-shot +-- historical backfill over the window bounded by +-- 'startDetectorJobRequestStartTime' / 'startDetectorJobRequestEndTime' +-- (epoch milliseconds). Both @start_time@ and @end_time@ are required +-- when a body is sent; the server returns a 'DetectorJobAcknowledgment' +-- whose @_id@ is the historical batch task id (a UUID), distinct from +-- the detector id returned by the real-time form. +-- See +data StartDetectorJobRequest = StartDetectorJobRequest + { startDetectorJobRequestStartTime :: Integer, + startDetectorJobRequestEndTime :: Integer + } + deriving stock (Eq, Show) + +instance FromJSON StartDetectorJobRequest where + parseJSON = withObject "StartDetectorJobRequest" $ \v -> do + startDetectorJobRequestStartTime <- v .: "start_time" + startDetectorJobRequestEndTime <- v .: "end_time" + pure StartDetectorJobRequest {..} + +instance ToJSON StartDetectorJobRequest where + toJSON StartDetectorJobRequest {..} = + object + [ "start_time" .= startDetectorJobRequestStartTime, + "end_time" .= startDetectorJobRequestEndTime + ] + +-- | Response body of @_start@ and @_stop@. Both endpoints return the +-- same small write-acknowledgment envelope (@_id@, @_version@, +-- @_seq_no@, @_primary_term@). For @_start@, @_id@ is the real-time job +-- id (= the detector id) when no body is sent, or the historical batch +-- task id (a UUID) when a 'StartDetectorJobRequest' body is sent. For +-- @_stop@, @_version@, @_seq_no@ and @_primary_term@ are zeroed on +-- success. Note @_version@ is a plain 'Int' (not 'DocVersion') because +-- the @_stop@ response legitimately carries @0@, which is below +-- 'DocVersion'\'s @minBound@ of @1@. +-- See +-- and +data DetectorJobAcknowledgment = DetectorJobAcknowledgment + { detectorJobAcknowledgmentId :: Text, + detectorJobAcknowledgmentVersion :: Int, + detectorJobAcknowledgmentSeqNo :: Int, + detectorJobAcknowledgmentPrimaryTerm :: Int + } + deriving stock (Eq, Show) + +instance FromJSON DetectorJobAcknowledgment where + parseJSON = withObject "DetectorJobAcknowledgment" $ \v -> do + detectorJobAcknowledgmentId <- v .: "_id" + -- OS 1.x only returns @_id@ for start/stop acknowledgments; the + -- @_version@, @_seq_no@, @_primary_term@ fields are absent (older + -- docs and some patch levels emit them zeroed). Default to 0 when + -- missing so the parser tolerates both wire shapes. + detectorJobAcknowledgmentVersion <- v .:? "_version" .!= 0 + detectorJobAcknowledgmentSeqNo <- v .:? "_seq_no" .!= 0 + detectorJobAcknowledgmentPrimaryTerm <- v .:? "_primary_term" .!= 0 + pure DetectorJobAcknowledgment {..} + +instance ToJSON DetectorJobAcknowledgment where + toJSON DetectorJobAcknowledgment {..} = + object + [ "_id" .= detectorJobAcknowledgmentId, + "_version" .= detectorJobAcknowledgmentVersion, + "_seq_no" .= detectorJobAcknowledgmentSeqNo, + "_primary_term" .= detectorJobAcknowledgmentPrimaryTerm + ] + +-- ========================================================================= +-- Validate detector: POST /_plugins/_anomaly_detection/detectors/_validate[/mode] +-- ========================================================================= + +-- | Selects the validation mode (the trailing path segment). The bare +-- @\/_validate@ form is a server-side alias for @\/_validate\/detector@; +-- 'ValidateDetector' covers both. @\/_validate\/model@ validates against +-- source data and is advisory only. +-- See +data ValidateDetectorMode = ValidateDetector | ValidateModel + deriving stock (Eq, Show) + +-- | The trailing path segment(s) for 'ValidateDetectorMode' — empty for +-- the detector default (bare @\/_validate@), @["model"]@ for the model +-- advisory check. +validateDetectorModeSegments :: ValidateDetectorMode -> [Text] +validateDetectorModeSegments = \case + ValidateDetector -> [] + ValidateModel -> ["model"] + +-- | Response body of the validate endpoint. Variable by outcome: an empty +-- object @{}@ when no issues are found; @{"detector": {...}}@ for blocking +-- issues from @\/_validate\/detector@; @{"model": {...}}@ for advisory +-- issues from @\/_validate\/model@. Carried as an opaque aeson 'Value' so +-- every shape round-trips losslessly (the pragmatic-typing precedent used +-- for ML Commons @predict@). +newtype ValidateDetectorResponse = ValidateDetectorResponse + { getValidateDetectorResponse :: Value + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- ========================================================================= +-- Search envelope: detectors / results / tasks +-- ========================================================================= + +-- | The @hits.total.relation@ discriminator on an AD search response. +data AnomalySearchTotalRelation + = AnomalySearchTotalRelationEq + | AnomalySearchTotalRelationGe + | AnomalySearchTotalRelationOther Text + deriving stock (Eq, Show) + +instance FromJSON AnomalySearchTotalRelation where + parseJSON = withText "AnomalySearchTotalRelation" $ \case + "eq" -> pure AnomalySearchTotalRelationEq + "ge" -> pure AnomalySearchTotalRelationGe + other -> pure (AnomalySearchTotalRelationOther other) + +instance ToJSON AnomalySearchTotalRelation where + toJSON = \case + AnomalySearchTotalRelationEq -> "eq" + AnomalySearchTotalRelationGe -> "ge" + AnomalySearchTotalRelationOther t -> toJSON t + +-- | The @hits.total@ sub-object on an AD search response +-- (@{value, relation}@). +data AnomalySearchTotal = AnomalySearchTotal + { anomalySearchTotalValue :: Int, + anomalySearchTotalRelation :: AnomalySearchTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON AnomalySearchTotal where + parseJSON = withObject "AnomalySearchTotal" $ \v -> + AnomalySearchTotal + <$> v .: "value" + <*> v .: "relation" + +instance ToJSON AnomalySearchTotal where + toJSON AnomalySearchTotal {..} = + object + [ "value" .= anomalySearchTotalValue, + "relation" .= anomalySearchTotalRelation + ] + +-- | A single hit in @hits.hits[]@ on an AD search response. The @_source@ +-- is decoded as the @source@ type parameter: 'DetectorResponse' for the +-- detector-config index, 'Value' for the variable anomaly-result and task +-- records (pragmatic typing — the full schema lives in the separate AD +-- result-mapping doc page). +data AnomalySearchHit source = AnomalySearchHit + { anomalySearchHitIndex :: Maybe Text, + anomalySearchHitId :: Text, + anomalySearchHitVersion :: Maybe Int, + anomalySearchHitSeqNo :: Maybe Int, + anomalySearchHitPrimaryTerm :: Maybe Int, + anomalySearchHitScore :: Maybe Double, + anomalySearchHitSource :: source + } + deriving stock (Eq, Show) + +instance (FromJSON source) => FromJSON (AnomalySearchHit source) where + parseJSON = withObject "AnomalySearchHit" $ \v -> + AnomalySearchHit + <$> v .:? "_index" + <*> v .: "_id" + <*> v .:? "_version" + <*> v .:? "_seq_no" + <*> v .:? "_primary_term" + <*> v .:? "_score" + <*> v .: "_source" + +instance (ToJSON source) => ToJSON (AnomalySearchHit source) where + toJSON AnomalySearchHit {..} = + omitNulls + [ "_index" .= anomalySearchHitIndex, + "_id" .= anomalySearchHitId, + "_version" .= anomalySearchHitVersion, + "_seq_no" .= anomalySearchHitSeqNo, + "_primary_term" .= anomalySearchHitPrimaryTerm, + "_score" .= anomalySearchHitScore, + "_source" .= anomalySearchHitSource + ] + +-- | The standard OpenSearch search-response envelope +-- (@took@, @timed_out@, @_shards@, @hits.total@, @hits.max_score@, +-- @hits.hits@) parametrised by the @_source@ type. Specialised by the AD +-- search endpoints: +-- +-- * 'SearchDetectorsResponse' — @_source@ is a typed 'DetectorResponse'. +-- * 'SearchDetectorResultsResponse' / 'SearchDetectorTasksResponse' — +-- @_source@ is an opaque 'Value' (the anomaly-result and task records +-- carry many optional fields; the full mapping lives in a separate doc +-- page). +data AnomalySearchResponse source = AnomalySearchResponse + { anomalySearchResponseTook :: Int, + anomalySearchResponseTimedOut :: Bool, + anomalySearchResponseShards :: AnomalyShards, + anomalySearchResponseTotal :: AnomalySearchTotal, + anomalySearchResponseMaxScore :: Maybe Double, + anomalySearchResponseHits :: [AnomalySearchHit source] + } + deriving stock (Eq, Show) + +instance (FromJSON source) => FromJSON (AnomalySearchResponse source) where + parseJSON = withObject "AnomalySearchResponse" $ \v -> do + hits <- v .: "hits" + AnomalySearchResponse + <$> v .: "took" + <*> v .: "timed_out" + <*> v .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance (ToJSON source) => ToJSON (AnomalySearchResponse source) where + toJSON AnomalySearchResponse {..} = + object + [ "took" .= anomalySearchResponseTook, + "timed_out" .= anomalySearchResponseTimedOut, + "_shards" .= anomalySearchResponseShards, + "hits" + .= object + [ "total" .= anomalySearchResponseTotal, + "max_score" .= anomalySearchResponseMaxScore, + "hits" .= anomalySearchResponseHits + ] + ] + +-- | Project the @source@ values out of an 'AnomalySearchResponse' +-- (convenience for callers who only want the hits). +anomalySearchResponseSources :: AnomalySearchResponse source -> [source] +anomalySearchResponseSources = map anomalySearchHitSource . anomalySearchResponseHits + +-- | Response of @POST /_plugins/_anomaly_detection/detectors/_search@ — +-- a search over the detector-config index. @_source@ is a typed +-- 'DetectorResponse'. +type SearchDetectorsResponse = AnomalySearchResponse DetectorResponse + +-- | Response of @POST /_plugins/_anomaly_detection/detectors/results/_search@. +-- @_source@ is an opaque 'Value' (the anomaly-result record). +type SearchDetectorResultsResponse = AnomalySearchResponse Value + +-- | Response of @DELETE /_plugins/_anomaly_detection/detectors/results@. +-- The plugin returns the bare @_delete_by_query@ envelope, which is +-- structurally identical to the document-API 'DeletedDocuments' — we +-- alias to it rather than duplicate the type. Fork here (make a +-- dedicated AD type) if the plugin ever diverges from the document +-- envelope. +type DeleteDetectorResultsResponse = DeletedDocuments + +-- | Response of @POST /_plugins/_anomaly_detection/detectors/tasks/_search@. +-- @_source@ is an opaque 'Value' (the task record). +type SearchDetectorTasksResponse = AnomalySearchResponse Value + +-- ========================================================================= +-- Profile detector: GET /_plugins/_anomaly_detection/detectors/{id}/_profile[/types|?_all=true] +-- ========================================================================= + +-- | Response body of the profile endpoint. The shape varies widely by +-- requested profile kind (@_profile@, @_profile\/{type}@, @?_all=true@, +-- entity-filtered) and by detector kind (single-entity vs +-- high-cardinality); the docs enumerate many distinct sub-shapes. +-- Carried as an opaque aeson 'Value' so every variant round-trips +-- losslessly (pragmatic-typing precedent). +-- See +newtype DetectorProfileResponse = DetectorProfileResponse + { getDetectorProfileResponse :: Value + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- ========================================================================= +-- Detector stats: GET /_plugins/_anomaly_detection/stats[/{stat}] etc. +-- ========================================================================= + +-- | Response body of the stats endpoint. The full form returns several +-- top-level index-status keys plus a @nodes@ map; the filtered forms +-- (@\/stats\/{stat}@, @\/{node_id}\/stats@) return only a subset. +-- Carried as an opaque aeson 'Value' (pragmatic-typing precedent) so the +-- variable top-level surface round-trips losslessly. +-- See +newtype DetectorStatsResponse = DetectorStatsResponse + { getDetectorStatsResponse :: Value + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- ========================================================================= +-- Top anomalies: GET /_plugins/_anomaly_detection/detectors/{id}/results/_topAnomalies +-- ========================================================================= + +-- | The @order@ enum for 'TopAnomaliesRequest' — @severity@ (default) or +-- @occurrence@. +data TopAnomaliesOrder + = TopAnomaliesOrderSeverity + | TopAnomaliesOrderOccurrence + deriving stock (Eq, Show) + +-- | Wire string for a 'TopAnomaliesOrder'. +topAnomaliesOrderText :: TopAnomaliesOrder -> Text +topAnomaliesOrderText = \case + TopAnomaliesOrderSeverity -> "severity" + TopAnomaliesOrderOccurrence -> "occurrence" + +instance ToJSON TopAnomaliesOrder where + toJSON = toJSON . topAnomaliesOrderText + +instance FromJSON TopAnomaliesOrder where + parseJSON = withText "TopAnomaliesOrder" $ \case + "severity" -> pure TopAnomaliesOrderSeverity + "occurrence" -> pure TopAnomaliesOrderOccurrence + other -> + fail ("unknown TopAnomaliesOrder: " <> T.unpack other) + +-- | Request body for the top-anomalies endpoint (sent with the GET). +-- @start_time_ms@ and @end_time_ms@ are required epoch-ms; the rest are +-- optional. 'Nothing' for @size@ leaves the server default (10, max +-- 10000); 'Nothing' for @category_field@ defaults to all detector +-- category fields; 'Nothing' for @task_id@ is only meaningful when the +-- request is historical (ignored otherwise). +-- See +data TopAnomaliesRequest = TopAnomaliesRequest + { topAnomaliesRequestSize :: Maybe Int, + topAnomaliesRequestCategoryField :: Maybe [Text], + topAnomaliesRequestOrder :: Maybe TopAnomaliesOrder, + topAnomaliesRequestTaskId :: Maybe Text, + topAnomaliesRequestStartTimeMs :: Integer, + topAnomaliesRequestEndTimeMs :: Integer + } + deriving stock (Eq, Show) + +-- | The minimal 'TopAnomaliesRequest' carrying only the two required +-- epoch-ms timestamps; every optional field is 'Nothing' (server +-- defaults). +defaultTopAnomaliesRequest :: Integer -> Integer -> TopAnomaliesRequest +defaultTopAnomaliesRequest start end = + TopAnomaliesRequest + { topAnomaliesRequestSize = Nothing, + topAnomaliesRequestCategoryField = Nothing, + topAnomaliesRequestOrder = Nothing, + topAnomaliesRequestTaskId = Nothing, + topAnomaliesRequestStartTimeMs = start, + topAnomaliesRequestEndTimeMs = end + } + +instance ToJSON TopAnomaliesRequest where + toJSON TopAnomaliesRequest {..} = + omitNulls + [ "size" .= topAnomaliesRequestSize, + "category_field" .= topAnomaliesRequestCategoryField, + "order" .= topAnomaliesRequestOrder, + "task_id" .= topAnomaliesRequestTaskId, + "start_time_ms" .= topAnomaliesRequestStartTimeMs, + "end_time_ms" .= topAnomaliesRequestEndTimeMs + ] + +instance FromJSON TopAnomaliesRequest where + parseJSON = withObject "TopAnomaliesRequest" $ \v -> + TopAnomaliesRequest + <$> v .:? "size" + <*> v .:? "category_field" + <*> v .:? "order" + <*> v .:? "task_id" + <*> v .: "start_time_ms" + <*> v .: "end_time_ms" + +-- | One bucket in the top-anomalies response: a categorical @key@ (a map +-- from category-field name to value), the @doc_count@ of anomalies in +-- that bucket, and the @max_anomaly_grade@ observed. +data TopAnomalyBucket = TopAnomalyBucket + { topAnomalyBucketKey :: Value, + topAnomalyBucketDocCount :: Int, + topAnomalyBucketMaxAnomalyGrade :: Double + } + deriving stock (Eq, Show) + +instance FromJSON TopAnomalyBucket where + parseJSON = withObject "TopAnomalyBucket" $ \v -> + TopAnomalyBucket + <$> v .: "key" + <*> v .: "doc_count" + <*> v .: "max_anomaly_grade" + +instance ToJSON TopAnomalyBucket where + toJSON TopAnomalyBucket {..} = + object + [ "key" .= topAnomalyBucketKey, + "doc_count" .= topAnomalyBucketDocCount, + "max_anomaly_grade" .= topAnomalyBucketMaxAnomalyGrade + ] + +-- | Response body of the top-anomalies endpoint: a @buckets@ array of +-- 'TopAnomalyBucket'. +-- See +data TopAnomaliesResponse = TopAnomaliesResponse + { topAnomaliesResponseBuckets :: [TopAnomalyBucket] + } + deriving stock (Eq, Show) + +instance FromJSON TopAnomaliesResponse where + parseJSON = withObject "TopAnomaliesResponse" $ \v -> + TopAnomaliesResponse + <$> v .:? "buckets" .!= [] + +instance ToJSON TopAnomaliesResponse where + toJSON TopAnomaliesResponse {..} = + object ["buckets" .= topAnomaliesResponseBuckets] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/CCR.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/CCR.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/CCR.hs @@ -0,0 +1,573 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.CCR + ( -- * Requests + ReplicationUseRoles (..), + StartReplicationRequest (..), + UpdateReplicationSettingsRequest (..), + CreateAutoFollowPatternRequest (..), + DeleteAutoFollowPatternRequest (..), + + -- * Status + ReplicationStatus (..), + replicationStatusText, + SyncingDetails (..), + ReplicationStatusResponse (..), + ReplicationStatusOptions (..), + defaultReplicationStatusOptions, + replicationStatusOptionsParams, + + -- * Leader stats + LeaderIndexStats (..), + LeaderStatsResponse (..), + + -- * Follower stats + FollowerIndexStats (..), + FollowerStatsResponse (..), + + -- * Auto-follow stats + AutoFollowRuleStats (..), + AutoFollowStatsResponse (..), + ) +where + +import Data.Map.Strict (Map) +import Database.Bloodhound.Internal.Utils.Imports + +-- $ccrSchema +-- +-- The Cross-Cluster Replication (CCR) plugin (see +-- ) +-- replicates indexes from a /leader/ cluster to a /follower/ cluster in +-- near real-time. The follower cluster pulls changes from the leader's +-- translog; the follower index stays read-only while replication is +-- active. The plugin has shipped with OpenSearch since 1.1, hence this +-- module exists for OS1, OS2 and OS3. +-- +-- The REST surface lives under @\/_plugins\/_replication\/*@ on both +-- clusters. Follower-lifecycle operations (start\/stop\/pause\/resume\/ +-- update) and the per-index @\/_status@ are sent to the /follower/ +-- cluster; the leader cluster only serves @leader_stats@. The +-- @follower_stats@ and @autofollow_stats@ endpoints, plus the +-- auto-follow pattern create\/delete, are sent to the follower cluster. +-- +-- Most mutation endpoints return the trivial +-- @{\"acknowledged\":true}@ envelope, modelled by the shared +-- 'Database.Bloodhound.Internal.Client.BHRequest.Acknowledged' type +-- (re-exported via "Database.Bloodhound.Common.Types"). The interesting +-- wire shapes are the status and the three stats responses, modelled +-- below as dedicated records. + +-- | The @use_roles@ object embedded in 'StartReplicationRequest' and +-- 'CreateAutoFollowPatternRequest'. Required when the Security plugin is +-- enabled (the common case); the plugin uses these roles to authorize +-- cross-cluster reads on the leader and writes on the follower. +data ReplicationUseRoles = ReplicationUseRoles + { replicationUseRolesLeaderClusterRole :: Text, + replicationUseRolesFollowerClusterRole :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ReplicationUseRoles where + parseJSON = withObject "ReplicationUseRoles" $ \v -> do + replicationUseRolesLeaderClusterRole <- v .: "leader_cluster_role" + replicationUseRolesFollowerClusterRole <- v .: "follower_cluster_role" + pure ReplicationUseRoles {..} + +instance ToJSON ReplicationUseRoles where + toJSON ReplicationUseRoles {..} = + object + [ "leader_cluster_role" .= replicationUseRolesLeaderClusterRole, + "follower_cluster_role" .= replicationUseRolesFollowerClusterRole + ] + +-- | The request body for @PUT \/_plugins\/_replication\/{follower-index}\/_start@. +-- @leader_alias@ names the cross-cluster connection (configured via the +-- cluster settings @cluster.remote..seeds@), and @leader_index@ is +-- the source index on the leader cluster. +data StartReplicationRequest = StartReplicationRequest + { startReplicationRequestLeaderAlias :: Text, + startReplicationRequestLeaderIndex :: Text, + startReplicationRequestUseRoles :: Maybe ReplicationUseRoles + } + deriving stock (Eq, Show) + +instance FromJSON StartReplicationRequest where + parseJSON = withObject "StartReplicationRequest" $ \v -> do + startReplicationRequestLeaderAlias <- v .: "leader_alias" + startReplicationRequestLeaderIndex <- v .: "leader_index" + startReplicationRequestUseRoles <- v .:? "use_roles" + pure StartReplicationRequest {..} + +instance ToJSON StartReplicationRequest where + toJSON StartReplicationRequest {..} = + omitNulls + [ "leader_alias" .= startReplicationRequestLeaderAlias, + "leader_index" .= startReplicationRequestLeaderIndex, + "use_roles" .= startReplicationRequestUseRoles + ] + +-- | The request body for +-- @PUT \/_plugins\/_replication\/{follower-index}\/_update@. Carries an +-- arbitrary map of index-level settings (e.g. +-- @index.number_of_replicas@) to apply to the follower index. Values are +-- kept as aeson 'Value's because settings may be numbers, strings, or +-- booleans and the plugin forwards them verbatim. +newtype UpdateReplicationSettingsRequest = UpdateReplicationSettingsRequest + { updateReplicationSettingsRequestSettings :: Map Text Value + } + deriving stock (Eq, Show) + +instance FromJSON UpdateReplicationSettingsRequest where + parseJSON = withObject "UpdateReplicationSettingsRequest" $ \v -> do + updateReplicationSettingsRequestSettings <- v .: "settings" + pure UpdateReplicationSettingsRequest {..} + +instance ToJSON UpdateReplicationSettingsRequest where + toJSON UpdateReplicationSettingsRequest {..} = + object ["settings" .= updateReplicationSettingsRequestSettings] + +-- | The request body for @POST \/_plugins\/_replication\/_autofollow@. +-- Creates (or, re-POSTed with the same @name@, updates) an auto-follow +-- rule that automatically starts replication on any existing /and/ +-- future leader indexes whose names match @pattern@. +data CreateAutoFollowPatternRequest = CreateAutoFollowPatternRequest + { createAutoFollowPatternRequestLeaderAlias :: Text, + createAutoFollowPatternRequestName :: Text, + createAutoFollowPatternRequestPattern :: Text, + createAutoFollowPatternRequestUseRoles :: Maybe ReplicationUseRoles + } + deriving stock (Eq, Show) + +instance FromJSON CreateAutoFollowPatternRequest where + parseJSON = withObject "CreateAutoFollowPatternRequest" $ \v -> do + createAutoFollowPatternRequestLeaderAlias <- v .: "leader_alias" + createAutoFollowPatternRequestName <- v .: "name" + createAutoFollowPatternRequestPattern <- v .: "pattern" + createAutoFollowPatternRequestUseRoles <- v .:? "use_roles" + pure CreateAutoFollowPatternRequest {..} + +instance ToJSON CreateAutoFollowPatternRequest where + toJSON CreateAutoFollowPatternRequest {..} = + omitNulls + [ "leader_alias" .= createAutoFollowPatternRequestLeaderAlias, + "name" .= createAutoFollowPatternRequestName, + "pattern" .= createAutoFollowPatternRequestPattern, + "use_roles" .= createAutoFollowPatternRequestUseRoles + ] + +-- | The request body for @DELETE \/_plugins\/_replication\/_autofollow@. +-- Deletes an auto-follow rule. This prevents /new/ indexes from being +-- replicated but does /not/ stop replication already initiated by the +-- rule (stop those individually with 'stopReplication'). +data DeleteAutoFollowPatternRequest = DeleteAutoFollowPatternRequest + { deleteAutoFollowPatternRequestLeaderAlias :: Text, + deleteAutoFollowPatternRequestName :: Text + } + deriving stock (Eq, Show) + +instance FromJSON DeleteAutoFollowPatternRequest where + parseJSON = withObject "DeleteAutoFollowPatternRequest" $ \v -> do + deleteAutoFollowPatternRequestLeaderAlias <- v .: "leader_alias" + deleteAutoFollowPatternRequestName <- v .: "name" + pure DeleteAutoFollowPatternRequest {..} + +instance ToJSON DeleteAutoFollowPatternRequest where + toJSON DeleteAutoFollowPatternRequest {..} = + object + [ "leader_alias" .= deleteAutoFollowPatternRequestLeaderAlias, + "name" .= deleteAutoFollowPatternRequestName + ] + +-- | The @status@ enum reported by +-- @GET \/_plugins\/_replication\/{follower-index}\/_status@. Modelled as +-- an /open/ enum: the four documented values map to dedicated +-- constructors, and any unknown status string round-trips through +-- 'ReplicationStatusOther'. This guards against plugin releases adding a +-- fifth state (or undocumented intermediate states) surfacing as a +-- silent parse failure. Note the documented @REPLICATION NOT IN +-- PROGRESS@ value contains spaces. +data ReplicationStatus + = ReplicationStatusSyncing + | ReplicationStatusBootstrapping + | ReplicationStatusPaused + | ReplicationStatusNotInProgress + | ReplicationStatusOther Text + deriving stock (Eq, Show) + +instance FromJSON ReplicationStatus where + parseJSON = withText "ReplicationStatus" $ \t -> + pure $ case t of + "SYNCING" -> ReplicationStatusSyncing + "BOOTSTRAPPING" -> ReplicationStatusBootstrapping + "PAUSED" -> ReplicationStatusPaused + "REPLICATION NOT IN PROGRESS" -> ReplicationStatusNotInProgress + other -> ReplicationStatusOther other + +instance ToJSON ReplicationStatus where + toJSON = toJSON . replicationStatusText + +-- | The wire string for a 'ReplicationStatus', exposed as plain 'Text' +-- for callers that need the wire value without going through a +-- 'Data.Aeson.Value'. 'ReplicationStatusOther' round-trips its payload. +replicationStatusText :: ReplicationStatus -> Text +replicationStatusText = \case + ReplicationStatusSyncing -> "SYNCING" + ReplicationStatusBootstrapping -> "BOOTSTRAPPING" + ReplicationStatusPaused -> "PAUSED" + ReplicationStatusNotInProgress -> "REPLICATION NOT IN PROGRESS" + ReplicationStatusOther t -> t + +-- | The @syncing_details@ object embedded in 'ReplicationStatusResponse' +-- when the status is @SYNCING@. Checkpoints start negative (-1 per +-- shard) and increment with each change; equal leader\/follower +-- checkpoints mean the indexes are fully synced. +data SyncingDetails = SyncingDetails + { syncingDetailsLeaderCheckpoint :: Int, + syncingDetailsFollowerCheckpoint :: Int, + syncingDetailsSeqNo :: Int + } + deriving stock (Eq, Show) + +instance FromJSON SyncingDetails where + parseJSON = withObject "SyncingDetails" $ \v -> do + syncingDetailsLeaderCheckpoint <- v .: "leader_checkpoint" + syncingDetailsFollowerCheckpoint <- v .: "follower_checkpoint" + syncingDetailsSeqNo <- v .: "seq_no" + pure SyncingDetails {..} + +instance ToJSON SyncingDetails where + toJSON SyncingDetails {..} = + object + [ "leader_checkpoint" .= syncingDetailsLeaderCheckpoint, + "follower_checkpoint" .= syncingDetailsFollowerCheckpoint, + "seq_no" .= syncingDetailsSeqNo + ] + +-- | The response of +-- @GET \/_plugins\/_replication\/{follower-index}\/_status@. The +-- @syncing_details@ object is only present when @status@ is @SYNCING@; +-- it is 'Nothing' for the other states. +data ReplicationStatusResponse = ReplicationStatusResponse + { replicationStatusResponseStatus :: ReplicationStatus, + replicationStatusResponseReason :: Text, + replicationStatusResponseLeaderAlias :: Text, + replicationStatusResponseLeaderIndex :: Text, + replicationStatusResponseFollowerIndex :: Text, + replicationStatusResponseSyncingDetails :: Maybe SyncingDetails + } + deriving stock (Eq, Show) + +instance FromJSON ReplicationStatusResponse where + parseJSON = withObject "ReplicationStatusResponse" $ \v -> do + replicationStatusResponseStatus <- v .: "status" + replicationStatusResponseReason <- v .: "reason" + replicationStatusResponseLeaderAlias <- v .: "leader_alias" + replicationStatusResponseLeaderIndex <- v .: "leader_index" + replicationStatusResponseFollowerIndex <- v .: "follower_index" + replicationStatusResponseSyncingDetails <- v .:? "syncing_details" + pure ReplicationStatusResponse {..} + +instance ToJSON ReplicationStatusResponse where + toJSON ReplicationStatusResponse {..} = + omitNulls + [ "status" .= replicationStatusResponseStatus, + "reason" .= replicationStatusResponseReason, + "leader_alias" .= replicationStatusResponseLeaderAlias, + "leader_index" .= replicationStatusResponseLeaderIndex, + "follower_index" .= replicationStatusResponseFollowerIndex, + "syncing_details" .= replicationStatusResponseSyncingDetails + ] + +-- | Query-string options for +-- 'Database.Bloodhound.OpenSearch1.Requests.getReplicationStatus'. The +-- plugin documents only @verbose@: when @true@, the response includes +-- shard-level @syncing_details@; when omitted or @false@, the details +-- are absent. +data ReplicationStatusOptions = ReplicationStatusOptions + { replicationStatusOptionsVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | No query-string parameters — the plain @GET ...\/_status@. +defaultReplicationStatusOptions :: ReplicationStatusOptions +defaultReplicationStatusOptions = + ReplicationStatusOptions + { replicationStatusOptionsVerbose = Nothing + } + +-- | Render 'ReplicationStatusOptions' as query-string pairs for +-- 'withQueries'. +replicationStatusOptionsParams :: ReplicationStatusOptions -> [(Text, Maybe Text)] +replicationStatusOptionsParams ReplicationStatusOptions {..} = + catMaybes + [ (("verbose",) . Just . \case True -> "true"; False -> "false") <$> replicationStatusOptionsVerbose + ] + +-- | Per-index leader statistics, the value entries of the +-- @index_stats@ map in 'LeaderStatsResponse'. These are the read-side +-- counters the leader cluster reports for a single replicated index. +data LeaderIndexStats = LeaderIndexStats + { leaderIndexStatsOperationsRead :: Int, + leaderIndexStatsTranslogSizeBytes :: Int, + leaderIndexStatsOperationsReadLucene :: Int, + leaderIndexStatsOperationsReadTranslog :: Int, + leaderIndexStatsTotalReadTimeLuceneMillis :: Int, + leaderIndexStatsTotalReadTimeTranslogMillis :: Int, + leaderIndexStatsBytesRead :: Int + } + deriving stock (Eq, Show) + +instance FromJSON LeaderIndexStats where + parseJSON = withObject "LeaderIndexStats" $ \v -> do + leaderIndexStatsOperationsRead <- v .: "operations_read" + leaderIndexStatsTranslogSizeBytes <- v .: "translog_size_bytes" + leaderIndexStatsOperationsReadLucene <- v .: "operations_read_lucene" + leaderIndexStatsOperationsReadTranslog <- v .: "operations_read_translog" + leaderIndexStatsTotalReadTimeLuceneMillis <- v .: "total_read_time_lucene_millis" + leaderIndexStatsTotalReadTimeTranslogMillis <- v .: "total_read_time_translog_millis" + leaderIndexStatsBytesRead <- v .: "bytes_read" + pure LeaderIndexStats {..} + +instance ToJSON LeaderIndexStats where + toJSON LeaderIndexStats {..} = + object + [ "operations_read" .= leaderIndexStatsOperationsRead, + "translog_size_bytes" .= leaderIndexStatsTranslogSizeBytes, + "operations_read_lucene" .= leaderIndexStatsOperationsReadLucene, + "operations_read_translog" .= leaderIndexStatsOperationsReadTranslog, + "total_read_time_lucene_millis" .= leaderIndexStatsTotalReadTimeLuceneMillis, + "total_read_time_translog_millis" .= leaderIndexStatsTotalReadTimeTranslogMillis, + "bytes_read" .= leaderIndexStatsBytesRead + ] + +-- | The response of @GET \/_plugins\/_replication\/leader_stats@ (sent +-- to the /leader/ cluster). Aggregates read-side counters across all +-- replicated indexes, plus a per-index breakdown under @index_stats@. +-- The per-index values reuse 'LeaderIndexStats'. The @index_stats@ map +-- defaults to empty when the plugin omits it (e.g. no replication +-- configured). +data LeaderStatsResponse = LeaderStatsResponse + { leaderStatsResponseNumReplicatedIndices :: Int, + leaderStatsResponseOperationsRead :: Int, + leaderStatsResponseTranslogSizeBytes :: Int, + leaderStatsResponseOperationsReadLucene :: Int, + leaderStatsResponseOperationsReadTranslog :: Int, + leaderStatsResponseTotalReadTimeLuceneMillis :: Int, + leaderStatsResponseTotalReadTimeTranslogMillis :: Int, + leaderStatsResponseBytesRead :: Int, + leaderStatsResponseIndexStats :: Map Text LeaderIndexStats + } + deriving stock (Eq, Show) + +instance FromJSON LeaderStatsResponse where + parseJSON = withObject "LeaderStatsResponse" $ \v -> do + leaderStatsResponseNumReplicatedIndices <- v .: "num_replicated_indices" + leaderStatsResponseOperationsRead <- v .: "operations_read" + leaderStatsResponseTranslogSizeBytes <- v .: "translog_size_bytes" + leaderStatsResponseOperationsReadLucene <- v .: "operations_read_lucene" + leaderStatsResponseOperationsReadTranslog <- v .: "operations_read_translog" + leaderStatsResponseTotalReadTimeLuceneMillis <- v .: "total_read_time_lucene_millis" + leaderStatsResponseTotalReadTimeTranslogMillis <- v .: "total_read_time_translog_millis" + leaderStatsResponseBytesRead <- v .: "bytes_read" + leaderStatsResponseIndexStats <- v .:? "index_stats" .!= mempty + pure LeaderStatsResponse {..} + +instance ToJSON LeaderStatsResponse where + toJSON LeaderStatsResponse {..} = + object + [ "num_replicated_indices" .= leaderStatsResponseNumReplicatedIndices, + "operations_read" .= leaderStatsResponseOperationsRead, + "translog_size_bytes" .= leaderStatsResponseTranslogSizeBytes, + "operations_read_lucene" .= leaderStatsResponseOperationsReadLucene, + "operations_read_translog" .= leaderStatsResponseOperationsReadTranslog, + "total_read_time_lucene_millis" .= leaderStatsResponseTotalReadTimeLuceneMillis, + "total_read_time_translog_millis" .= leaderStatsResponseTotalReadTimeTranslogMillis, + "bytes_read" .= leaderStatsResponseBytesRead, + "index_stats" .= leaderStatsResponseIndexStats + ] + +-- | Per-index follower statistics, the value entries of the +-- @index_stats@ map in 'FollowerStatsResponse'. These are the write-side +-- counters the follower cluster reports for a single syncing index. +data FollowerIndexStats = FollowerIndexStats + { followerIndexStatsOperationsWritten :: Int, + followerIndexStatsOperationsRead :: Int, + followerIndexStatsFailedReadRequests :: Int, + followerIndexStatsThrottledReadRequests :: Int, + followerIndexStatsFailedWriteRequests :: Int, + followerIndexStatsThrottledWriteRequests :: Int, + followerIndexStatsFollowerCheckpoint :: Int, + followerIndexStatsLeaderCheckpoint :: Int, + followerIndexStatsTotalWriteTimeMillis :: Int + } + deriving stock (Eq, Show) + +instance FromJSON FollowerIndexStats where + parseJSON = withObject "FollowerIndexStats" $ \v -> do + followerIndexStatsOperationsWritten <- v .: "operations_written" + followerIndexStatsOperationsRead <- v .: "operations_read" + followerIndexStatsFailedReadRequests <- v .: "failed_read_requests" + followerIndexStatsThrottledReadRequests <- v .: "throttled_read_requests" + followerIndexStatsFailedWriteRequests <- v .: "failed_write_requests" + followerIndexStatsThrottledWriteRequests <- v .: "throttled_write_requests" + followerIndexStatsFollowerCheckpoint <- v .: "follower_checkpoint" + followerIndexStatsLeaderCheckpoint <- v .: "leader_checkpoint" + followerIndexStatsTotalWriteTimeMillis <- v .: "total_write_time_millis" + pure FollowerIndexStats {..} + +instance ToJSON FollowerIndexStats where + toJSON FollowerIndexStats {..} = + object + [ "operations_written" .= followerIndexStatsOperationsWritten, + "operations_read" .= followerIndexStatsOperationsRead, + "failed_read_requests" .= followerIndexStatsFailedReadRequests, + "throttled_read_requests" .= followerIndexStatsThrottledReadRequests, + "failed_write_requests" .= followerIndexStatsFailedWriteRequests, + "throttled_write_requests" .= followerIndexStatsThrottledWriteRequests, + "follower_checkpoint" .= followerIndexStatsFollowerCheckpoint, + "leader_checkpoint" .= followerIndexStatsLeaderCheckpoint, + "total_write_time_millis" .= followerIndexStatsTotalWriteTimeMillis + ] + +-- | The response of @GET \/_plugins\/_replication\/follower_stats@ (sent +-- to the /follower/ cluster). Reports counts of follower indexes by +-- state (syncing\/bootstrapping\/paused\/failed), shard- and index-level +-- task counts, and aggregate write-side throughput, plus a per-index +-- breakdown under @index_stats@. The @index_stats@ map defaults to +-- empty when the plugin omits it. +data FollowerStatsResponse = FollowerStatsResponse + { followerStatsResponseNumSyncingIndices :: Int, + followerStatsResponseNumBootstrappingIndices :: Int, + followerStatsResponseNumPausedIndices :: Int, + followerStatsResponseNumFailedIndices :: Int, + followerStatsResponseNumShardTasks :: Int, + followerStatsResponseNumIndexTasks :: Int, + followerStatsResponseOperationsWritten :: Int, + followerStatsResponseOperationsRead :: Int, + followerStatsResponseFailedReadRequests :: Int, + followerStatsResponseThrottledReadRequests :: Int, + followerStatsResponseFailedWriteRequests :: Int, + followerStatsResponseThrottledWriteRequests :: Int, + followerStatsResponseFollowerCheckpoint :: Int, + followerStatsResponseLeaderCheckpoint :: Int, + followerStatsResponseTotalWriteTimeMillis :: Int, + followerStatsResponseIndexStats :: Map Text FollowerIndexStats + } + deriving stock (Eq, Show) + +instance FromJSON FollowerStatsResponse where + parseJSON = withObject "FollowerStatsResponse" $ \v -> do + followerStatsResponseNumSyncingIndices <- v .: "num_syncing_indices" + followerStatsResponseNumBootstrappingIndices <- v .: "num_bootstrapping_indices" + followerStatsResponseNumPausedIndices <- v .: "num_paused_indices" + followerStatsResponseNumFailedIndices <- v .: "num_failed_indices" + followerStatsResponseNumShardTasks <- v .: "num_shard_tasks" + followerStatsResponseNumIndexTasks <- v .: "num_index_tasks" + followerStatsResponseOperationsWritten <- v .: "operations_written" + followerStatsResponseOperationsRead <- v .: "operations_read" + followerStatsResponseFailedReadRequests <- v .: "failed_read_requests" + followerStatsResponseThrottledReadRequests <- v .: "throttled_read_requests" + followerStatsResponseFailedWriteRequests <- v .: "failed_write_requests" + followerStatsResponseThrottledWriteRequests <- v .: "throttled_write_requests" + followerStatsResponseFollowerCheckpoint <- v .: "follower_checkpoint" + followerStatsResponseLeaderCheckpoint <- v .: "leader_checkpoint" + followerStatsResponseTotalWriteTimeMillis <- v .: "total_write_time_millis" + followerStatsResponseIndexStats <- v .:? "index_stats" .!= mempty + pure FollowerStatsResponse {..} + +instance ToJSON FollowerStatsResponse where + toJSON FollowerStatsResponse {..} = + object + [ "num_syncing_indices" .= followerStatsResponseNumSyncingIndices, + "num_bootstrapping_indices" .= followerStatsResponseNumBootstrappingIndices, + "num_paused_indices" .= followerStatsResponseNumPausedIndices, + "num_failed_indices" .= followerStatsResponseNumFailedIndices, + "num_shard_tasks" .= followerStatsResponseNumShardTasks, + "num_index_tasks" .= followerStatsResponseNumIndexTasks, + "operations_written" .= followerStatsResponseOperationsWritten, + "operations_read" .= followerStatsResponseOperationsRead, + "failed_read_requests" .= followerStatsResponseFailedReadRequests, + "throttled_read_requests" .= followerStatsResponseThrottledReadRequests, + "failed_write_requests" .= followerStatsResponseFailedWriteRequests, + "throttled_write_requests" .= followerStatsResponseThrottledWriteRequests, + "follower_checkpoint" .= followerStatsResponseFollowerCheckpoint, + "leader_checkpoint" .= followerStatsResponseLeaderCheckpoint, + "total_write_time_millis" .= followerStatsResponseTotalWriteTimeMillis, + "index_stats" .= followerStatsResponseIndexStats + ] + +-- | Per-rule auto-follow statistics, the list entries of the +-- @autofollow_stats@ array in 'AutoFollowStatsResponse'. Each entry +-- describes one auto-follow rule (its name and match pattern) and its +-- success\/failure counters. The @failed_indices@ array lists the +-- leader index names that failed to start replicating under this rule. +data AutoFollowRuleStats = AutoFollowRuleStats + { autoFollowRuleStatsName :: Text, + autoFollowRuleStatsPattern :: Text, + autoFollowRuleStatsNumSuccessStartReplication :: Int, + autoFollowRuleStatsNumFailedStartReplication :: Int, + autoFollowRuleStatsNumFailedLeaderCalls :: Int, + autoFollowRuleStatsFailedIndices :: [Text] + } + deriving stock (Eq, Show) + +instance FromJSON AutoFollowRuleStats where + parseJSON = withObject "AutoFollowRuleStats" $ \v -> do + autoFollowRuleStatsName <- v .: "name" + autoFollowRuleStatsPattern <- v .: "pattern" + autoFollowRuleStatsNumSuccessStartReplication <- v .: "num_success_start_replication" + autoFollowRuleStatsNumFailedStartReplication <- v .: "num_failed_start_replication" + autoFollowRuleStatsNumFailedLeaderCalls <- v .: "num_failed_leader_calls" + autoFollowRuleStatsFailedIndices <- v .:? "failed_indices" .!= [] + pure AutoFollowRuleStats {..} + +instance ToJSON AutoFollowRuleStats where + toJSON AutoFollowRuleStats {..} = + object + [ "name" .= autoFollowRuleStatsName, + "pattern" .= autoFollowRuleStatsPattern, + "num_success_start_replication" .= autoFollowRuleStatsNumSuccessStartReplication, + "num_failed_start_replication" .= autoFollowRuleStatsNumFailedStartReplication, + "num_failed_leader_calls" .= autoFollowRuleStatsNumFailedLeaderCalls, + "failed_indices" .= autoFollowRuleStatsFailedIndices + ] + +-- | The response of @GET \/_plugins\/_replication\/autofollow_stats@ +-- (sent to the /follower/ cluster). Aggregates auto-follow activity +-- across all rules, plus a per-rule breakdown under @autofollow_stats@. +-- The docs note there is no dedicated \"list patterns\" endpoint — this +-- stats response is the only way to discover existing auto-follow rules, +-- hence each rule carries its @name@ and @pattern@. Both @failed_indices@ +-- and @autofollow_stats@ default to empty when the plugin omits them. +data AutoFollowStatsResponse = AutoFollowStatsResponse + { autoFollowStatsResponseNumSuccessStartReplication :: Int, + autoFollowStatsResponseNumFailedStartReplication :: Int, + autoFollowStatsResponseNumFailedLeaderCalls :: Int, + autoFollowStatsResponseFailedIndices :: [Text], + autoFollowStatsResponseAutoFollowStats :: [AutoFollowRuleStats] + } + deriving stock (Eq, Show) + +instance FromJSON AutoFollowStatsResponse where + parseJSON = withObject "AutoFollowStatsResponse" $ \v -> do + autoFollowStatsResponseNumSuccessStartReplication <- v .: "num_success_start_replication" + autoFollowStatsResponseNumFailedStartReplication <- v .: "num_failed_start_replication" + autoFollowStatsResponseNumFailedLeaderCalls <- v .: "num_failed_leader_calls" + autoFollowStatsResponseFailedIndices <- v .:? "failed_indices" .!= [] + autoFollowStatsResponseAutoFollowStats <- v .:? "autofollow_stats" .!= [] + pure AutoFollowStatsResponse {..} + +instance ToJSON AutoFollowStatsResponse where + toJSON AutoFollowStatsResponse {..} = + object + [ "num_success_start_replication" .= autoFollowStatsResponseNumSuccessStartReplication, + "num_failed_start_replication" .= autoFollowStatsResponseNumFailedStartReplication, + "num_failed_leader_calls" .= autoFollowStatsResponseNumFailedLeaderCalls, + "failed_indices" .= autoFollowStatsResponseFailedIndices, + "autofollow_stats" .= autoFollowStatsResponseAutoFollowStats + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/ISM.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/ISM.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/ISM.hs @@ -0,0 +1,1407 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.ISM where + +import Data.Aeson.Key qualified as AKey +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Database.Bloodhound.Internal.Client.Doc (DocVersion) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) + +-- $policySchema +-- +-- The OpenSearch ISM policy body has two faces: +-- +-- 1. The @PUT /_plugins/_ism/policies/{id}@ request carries the user-supplied +-- policy definition (no @policy_id@, no @schema_version@, no +-- @last_updated_time@ — the server injects those). +-- 2. The @GET /_plugins/_ism/policies\/{_id}@ response (and the inner @policy@ +-- object of the @PUT@ response) carries the same body with server-injected +-- metadata mixed in. +-- +-- We split these into 'ISMPolicyRequest' and 'ISMPolicyResponse' so the +-- request shape cannot accidentally carry server-only fields and the +-- response shape can still round-trip the full server payload. +-- +-- See + +-- | The shared user-supplied policy body, used by both 'ISMPolicyRequest' and +-- 'ISMPolicyResponse'. Carries only the fields the client supplies: +-- @description@, @default_state@, @states@, optional @ism_template@, +-- optional @error_notification@, optional @user_vars@. +data ISMPolicyBody = ISMPolicyBody + { ismPolicyBodyDescription :: Maybe Text, + ismPolicyBodyDefaultState :: Text, + ismPolicyBodyStates :: [ISMState], + ismPolicyBodyIsmTemplate :: [ISMTemplate], + ismPolicyBodyErrorNotification :: Maybe ISMErrorNotification, + ismPolicyBodyUserVariables :: Maybe ISMUserVariables + } + deriving stock (Eq, Show) + +instance FromJSON ISMPolicyBody where + parseJSON = withObject "ISMPolicyBody" $ \v -> do + ismPolicyBodyDescription <- v .:? "description" + ismPolicyBodyDefaultState <- v .: "default_state" + -- 'states' is required by OpenSearch and must be non-empty; we read it + -- strictly so malformed bodies missing the key fail-fast instead of + -- silently producing a policy whose 'default_state' points at nothing. + ismPolicyBodyStates <- v .: "states" + -- The spec allows @ism_template@ as a single object, @null@, or an array + -- of objects; a policy may carry one or more templates. Normalise all + -- three forms into a list: missing/null -> [], a bare object -> [obj], + -- an array -> its elements. + rawTemplate <- v .:? "ism_template" + ismPolicyBodyIsmTemplate <- case rawTemplate of + Nothing -> pure [] + Just Null -> pure [] + Just arr@(Array _) -> parseJSON arr + Just other -> (: []) <$> parseJSON other + ismPolicyBodyErrorNotification <- v .:? "error_notification" + ismPolicyBodyUserVariables <- v .:? "user_vars" + return ISMPolicyBody {..} + +instance ToJSON ISMPolicyBody where + toJSON ISMPolicyBody {..} = + omitNulls + [ "description" .= ismPolicyBodyDescription, + "default_state" .= ismPolicyBodyDefaultState, + "states" .= ismPolicyBodyStates, + "ism_template" .= ismPolicyBodyIsmTemplate, + "error_notification" .= ismPolicyBodyErrorNotification, + "user_vars" .= ismPolicyBodyUserVariables + ] + +-- | The request body for @PUT /_plugins/_ism/policies/{id}@. OpenSearch +-- requires the user-supplied policy body to be wrapped in a top-level +-- @policy@ key, so 'ISMPolicyRequest' encodes as +-- @{"policy": {…body…}}@. The wrapper is invisible at the type level: callers +-- build an 'ISMPolicyBody', wrap it in 'ISMPolicyRequest', and the +-- 'ToJSON' instance handles the wire-level wrapping. +-- See +newtype ISMPolicyRequest = ISMPolicyRequest {unISMPolicyRequest :: ISMPolicyBody} + deriving stock (Eq, Show) + +instance FromJSON ISMPolicyRequest where + parseJSON original@(Object o) = + -- Prefer the wrapped shape @{"policy": {…}}@; fall back to a bare body + -- so hand-built fixtures that skip the wrapper still decode cleanly. + (ISMPolicyRequest <$> o .: "policy") + <|> (ISMPolicyRequest <$> parseJSON original) + parseJSON v = ISMPolicyRequest <$> parseJSON v + +instance ToJSON ISMPolicyRequest where + toJSON req = object ["policy" .= unISMPolicyRequest req] + +-- | The policy shape returned in responses (@GET /_plugins/_ism/policies@, the +-- inner @policy@ object of a @PUT@ response). Adds the three server-injected +-- fields (@policy_id@, @schema_version@, @last_updated_time@) alongside the +-- shared body fields. OpenSearch populates them inside the inner policy body +-- on @GET /_plugins/_ism/policies\/{_id}@; @PUT@ responses historically put +-- them on the outer @policy@ wrapper. 'PutISMPolicyResponse' reconciles both +-- placements by reading the inner body verbatim and falling back to the outer +-- wrapper fields when the inner doesn't carry them. +data ISMPolicyResponse = ISMPolicyResponse + { ismPolicyResponsePolicyId :: Maybe Text, + ismPolicyResponseSchemaVersion :: Maybe Int, + ismPolicyResponseLastUpdatedTime :: Maybe Int, + ismPolicyResponseBody :: ISMPolicyBody + } + deriving stock (Eq, Show) + +instance FromJSON ISMPolicyResponse where + parseJSON v = do + body <- parseJSON v + withObject + "ISMPolicyResponse" + ( \o -> do + ismPolicyResponsePolicyId <- o .:? "policy_id" + ismPolicyResponseSchemaVersion <- o .:? "schema_version" + ismPolicyResponseLastUpdatedTime <- o .:? "last_updated_time" + return ISMPolicyResponse {ismPolicyResponseBody = body, ..} + ) + v + +instance ToJSON ISMPolicyResponse where + toJSON ISMPolicyResponse {..} = + omitNulls $ + catMaybes + [ fmap ("policy_id" .=) ismPolicyResponsePolicyId, + fmap ("schema_version" .=) ismPolicyResponseSchemaVersion, + fmap ("last_updated_time" .=) ismPolicyResponseLastUpdatedTime + ] + <> bodyPairs + where + bodyPairs = + case toJSON ismPolicyResponseBody of + Object o -> KM.toList o + _ -> [] + +-- | 'PolicyId' identifies an ISM policy in the +-- @\/_plugins\/_ism\/policies\/{id}@ URL path. Wraps 'Text' so it round-trips +-- through JSON as a bare string but is distinct at the Haskell type level. +-- See +newtype PolicyId = PolicyId {unPolicyId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Response of @PUT /_plugins/_ism/policies/{id}@. The server returns the +-- standard document-write envelope (@_id@, @_version@, @_seq_no@, +-- @_primary_term@) wrapping a single @policy@ key. That @policy@ object +-- itself contains @schema_version@, @last_updated_time@ and an inner +-- @policy@ body. Different OpenSearch versions disagree on whether +-- @schema_version@ / @last_updated_time@ live on the outer wrapper or inside +-- the inner body, so the decoder merges both sources into the inner +-- 'ISMPolicyResponse'. Callers should read those fields from +-- 'putISMPolicyResponsePolicy' rather than expecting them at the outer level. +data PutISMPolicyResponse = PutISMPolicyResponse + { putISMPolicyResponseId :: Text, + putISMPolicyResponseVersion :: DocVersion, + putISMPolicyResponsePrimaryTerm :: Int, + putISMPolicyResponseSeqNo :: Int, + putISMPolicyResponsePolicy :: ISMPolicyResponse + } + deriving stock (Eq, Show) + +instance FromJSON PutISMPolicyResponse where + parseJSON = withObject "PutISMPolicyResponse" $ \v -> do + putISMPolicyResponseId <- v .: "_id" + putISMPolicyResponseVersion <- v .: "_version" + putISMPolicyResponsePrimaryTerm <- v .: "_primary_term" + putISMPolicyResponseSeqNo <- v .: "_seq_no" + envelope <- v .: "policy" + -- OpenSearch's documented shape nests the user body inside + -- policy.policy and carries schema_version/last_updated_time there + -- (and sometimes also on the outer policy wrapper). Read the inner + -- body verbatim into ISMPolicyResponse (which already picks up + -- schema_version/last_updated_time when present) and merge the outer + -- envelope fields in when the inner doesn't carry them. + innerBody <- envelope .: "policy" + outerSchemaVersion <- envelope .:? "schema_version" + outerLastUpdated <- envelope .:? "last_updated_time" + parsedInner <- parseJSON innerBody + let merged = + parsedInner + { ismPolicyResponseSchemaVersion = + ismPolicyResponseSchemaVersion parsedInner <|> outerSchemaVersion, + ismPolicyResponseLastUpdatedTime = + ismPolicyResponseLastUpdatedTime parsedInner <|> outerLastUpdated + } + return PutISMPolicyResponse {putISMPolicyResponsePolicy = merged, ..} + +instance ToJSON PutISMPolicyResponse where + toJSON PutISMPolicyResponse {..} = + omitNulls + [ "_id" .= putISMPolicyResponseId, + "_version" .= putISMPolicyResponseVersion, + "_primary_term" .= putISMPolicyResponsePrimaryTerm, + "_seq_no" .= putISMPolicyResponseSeqNo, + "policy" .= object ["policy" .= putISMPolicyResponsePolicy] + ] + +-- | A named state in the policy state machine. The managed index transitions +-- from @name@ to the next state when any of @transitions@ matches; on entry it +-- runs every @actions@ entry. Both lists default to empty so a minimal +-- @{\"name\": \"hot\"}@ state decodes cleanly. +-- See +data ISMState = ISMState + { ismStateName :: Text, + ismStateActions :: [ISMActionEntry], + ismStateTransitions :: [ISMTransition] + } + deriving stock (Eq, Show) + +instance FromJSON ISMState where + parseJSON = withObject "ISMState" $ \v -> do + ismStateName <- v .: "name" + ismStateActions <- v .:? "actions" .!= [] + ismStateTransitions <- v .:? "transitions" .!= [] + return ISMState {..} + +instance ToJSON ISMState where + toJSON ISMState {..} = + omitNulls + [ "name" .= ismStateName, + "actions" .= ismStateActions, + "transitions" .= ismStateTransitions + ] + +-- | A state transition. @stateName@ names the destination state; @conditions@ +-- is the optional guard. When @conditions@ is 'Nothing' the transition is +-- unconditional. +-- See +data ISMTransition = ISMTransition + { ismTransitionStateName :: Text, + ismTransitionConditions :: Maybe ISMCondition + } + deriving stock (Eq, Show) + +instance FromJSON ISMTransition where + parseJSON = withObject "ISMTransition" $ \v -> do + ismTransitionStateName <- v .: "state_name" + ismTransitionConditions <- v .:? "conditions" + return ISMTransition {..} + +instance ToJSON ISMTransition where + toJSON ISMTransition {..} = + omitNulls + [ "state_name" .= ismTransitionStateName, + "conditions" .= ismTransitionConditions + ] + +-- | The guard on a transition. OpenSearch accepts any subset of these +-- thresholds; all are 'Maybe' so callers can express just the ones they need. +-- See +data ISMCondition = ISMCondition + { ismConditionMinSize :: Maybe Text, + ismConditionMinDocCount :: Maybe Int, + ismConditionMinIndexAge :: Maybe Text, + ismConditionMinRolloverAge :: Maybe Text, + ismConditionCron :: Maybe ISMCron, + ismConditionDsl :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMCondition where + parseJSON = withObject "ISMCondition" $ \v -> do + ismConditionMinSize <- v .:? "min_size" + ismConditionMinDocCount <- v .:? "min_doc_count" + ismConditionMinIndexAge <- v .:? "min_index_age" + ismConditionMinRolloverAge <- v .:? "min_rollover_age" + ismConditionCron <- v .:? "cron" + ismConditionDsl <- v .:? "dsl" + return ISMCondition {..} + +instance ToJSON ISMCondition where + toJSON ISMCondition {..} = + omitNulls + [ "min_size" .= ismConditionMinSize, + "min_doc_count" .= ismConditionMinDocCount, + "min_index_age" .= ismConditionMinIndexAge, + "min_rollover_age" .= ismConditionMinRolloverAge, + "cron" .= ismConditionCron, + "dsl" .= ismConditionDsl + ] + +-- | Inner payload of a cron transition condition: the cron expression and an +-- optional timezone. See 'ISMCron' for the outer wrapper OpenSearch expects. +-- See +data ISMCronCondition = ISMCronCondition + { ismCronConditionExpression :: Text, + ismCronConditionTimezone :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMCronCondition where + parseJSON = withObject "ISMCronCondition" $ \v -> do + ismCronConditionExpression <- v .: "expression" + ismCronConditionTimezone <- v .:? "timezone" + return ISMCronCondition {..} + +instance ToJSON ISMCronCondition where + toJSON ISMCronCondition {..} = + omitNulls + [ "expression" .= ismCronConditionExpression, + "timezone" .= ismCronConditionTimezone + ] + +-- | Outer wrapper OpenSearch requires around an 'ISMCronCondition'. The +-- documented @conditions.cron@ value is an object containing a nested @cron@ +-- key: @{\"cron\":{\"cron\":{\"expression\":...,\"timezone\":...}}}@. The +-- outer 'ISMCron' models the middle layer so 'ISMCondition''s parser can +-- decode the documented shape directly. +-- See +newtype ISMCron = ISMCron {ismCronInner :: ISMCronCondition} + deriving stock (Eq, Show) + +instance FromJSON ISMCron where + parseJSON = withObject "ISMCron" $ \v -> do + inner <- v .: "cron" + return (ISMCron inner) + +instance ToJSON ISMCron where + toJSON (ISMCron inner) = + omitNulls ["cron" .= inner] + +-- | The auto-apply template that attaches this policy to newly-created indices +-- whose name matches one of @indexPatterns@. @priority@ breaks ties when +-- multiple templates match. +-- See +data ISMTemplate = ISMTemplate + { ismTemplateIndexPatterns :: [Text], + ismTemplatePriority :: Maybe Scientific + } + deriving stock (Eq, Show) + +instance FromJSON ISMTemplate where + parseJSON = withObject "ISMTemplate" $ \v -> do + ismTemplateIndexPatterns <- v .:? "index_patterns" .!= [] + ismTemplatePriority <- v .:? "priority" + return ISMTemplate {..} + +instance ToJSON ISMTemplate where + toJSON ISMTemplate {..} = + omitNulls + [ "index_patterns" .= ismTemplateIndexPatterns, + "priority" .= ismTemplatePriority + ] + +-- | The destination of an 'ISMErrorNotification'. OpenSearch's Policies doc +-- () +-- lists three destination kinds: @chime@, @custom_webhook@ and @slack@. +-- Unknown destination types fall through to 'ISMErrorNotificationDestinationCustom'. +data ISMErrorNotificationDestination + = ISMErrorNotificationDestinationChime (Maybe Value) + | ISMErrorNotificationDestinationCustomWebhook (Maybe Value) + | ISMErrorNotificationDestinationSlack (Maybe Value) + | ISMErrorNotificationDestinationCustom Text (Maybe Value) + deriving stock (Eq, Show) + +destinationTag :: ISMErrorNotificationDestination -> Text +destinationTag = \case + ISMErrorNotificationDestinationChime _ -> "chime" + ISMErrorNotificationDestinationCustomWebhook _ -> "custom_webhook" + ISMErrorNotificationDestinationSlack _ -> "slack" + ISMErrorNotificationDestinationCustom tag _ -> tag + +destinationConfig :: ISMErrorNotificationDestination -> Maybe Value +destinationConfig = \case + ISMErrorNotificationDestinationChime cfg -> cfg + ISMErrorNotificationDestinationCustomWebhook cfg -> cfg + ISMErrorNotificationDestinationSlack cfg -> cfg + ISMErrorNotificationDestinationCustom _ cfg -> cfg + +instance FromJSON ISMErrorNotificationDestination where + parseJSON = withObject "ISMErrorNotificationDestination" $ \o -> case KM.toList o of + [] -> fail "ISMErrorNotificationDestination: empty object" + ((k, v) : _) -> case AKey.toText k of + "chime" -> ISMErrorNotificationDestinationChime <$> parseJSON v + "custom_webhook" -> ISMErrorNotificationDestinationCustomWebhook <$> parseJSON v + "slack" -> ISMErrorNotificationDestinationSlack <$> parseJSON v + other -> ISMErrorNotificationDestinationCustom other <$> parseJSON v + +instance ToJSON ISMErrorNotificationDestination where + toJSON d = + object + [ AKey.fromText (destinationTag d) + .= maybe (object []) id (destinationConfig d) + ] + +-- | The Mustache template used to render an 'ISMErrorNotification' message. +-- OpenSearch documents only the @source@ field, but the server injects @lang@ +-- (typically @"mustache"@) on responses; we carry it as 'Maybe' so a GET → PUT +-- round-trip is lossless (mirrors the Alerting plugin's @MessageTemplate@). See +-- the @message_template@ parameter at +-- . +data ISMMessageTemplate = ISMMessageTemplate + { ismMessageTemplateSource :: Text, + ismMessageTemplateLang :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMMessageTemplate where + parseJSON = withObject "ISMMessageTemplate" $ \v -> do + ismMessageTemplateSource <- v .: "source" + ismMessageTemplateLang <- v .:? "lang" + pure ISMMessageTemplate {..} + +instance ToJSON ISMMessageTemplate where + toJSON ISMMessageTemplate {..} = + omitNulls + [ "source" .= ismMessageTemplateSource, + "lang" .= ismMessageTemplateLang + ] + +-- | Error-notification block attached to a policy: when an action fails, OS +-- notifies either a @destination@ (Slack/Chime/webhook URL) or a Notifications +-- plugin @channel@. Per the policies doc, exactly one of 'destination' / +-- 'channel' must be present (they are mutually exclusive); the parser enforces +-- that invariant. +-- See +data ISMErrorNotification = ISMErrorNotification + { ismErrorNotificationDestination :: Maybe ISMErrorNotificationDestination, + ismErrorNotificationChannelId :: Maybe Text, + ismErrorNotificationMessageTemplate :: ISMMessageTemplate + } + deriving stock (Eq, Show) + +instance FromJSON ISMErrorNotification where + parseJSON = withObject "ISMErrorNotification" $ \v -> do + ismErrorNotificationDestination <- v .:? "destination" + mChannel <- v .:? "channel" + case (ismErrorNotificationDestination, mChannel) of + (Nothing, Nothing) -> + fail "ISMErrorNotification requires either 'destination' or 'channel'" + (Just _, Just _) -> + fail "ISMErrorNotification: 'destination' and 'channel' are mutually exclusive" + _ -> pure () + ismErrorNotificationChannelId <- case mChannel of + Nothing -> pure Nothing + Just ch -> Just <$> withObject "ISMErrorNotification channel" (.: "id") ch + ismErrorNotificationMessageTemplate <- v .: "message_template" + return ISMErrorNotification {..} + +instance ToJSON ISMErrorNotification where + toJSON ISMErrorNotification {..} = + omitNulls + [ "destination" .= ismErrorNotificationDestination, + "channel" .= channelValue ismErrorNotificationChannelId, + "message_template" .= ismErrorNotificationMessageTemplate + ] + where + channelValue = \case + Nothing -> Null + Just cid -> object ["id" .= cid] + +-- | User-supplied variable substitutions, used inside Mustache templates +-- (@{{{ctx.user_vars.}}}@). OS allows arbitrary JSON here; we expose the +-- common @Map Text Text@ shape and lose anything more exotic. +-- See +newtype ISMUserVariables = ISMUserVariables {unISMUserVariables :: Map.Map Text Text} + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- $actions +-- +-- OpenSearch encodes a state @actions@ entry as a JSON object whose keys +-- are the action name plus optional @timeout@ \/ @retry@ siblings. The +-- action-name key carries that action's config (or @{}@ when there is +-- none). For example: +-- +-- @{"rollover": {"min_size": "1gb"}}@, @{"delete": {}}@, and (with meta) +-- @{"rollover": {"min_size": "1gb"}, "timeout": "1d"}@. +-- +-- 'ISMAction' models the action half (one constructor per known action +-- plus an 'ISMActionCustom' escape hatch that preserves unknown action +-- types losslessly); 'ISMActionEntry' pairs it with the optional +-- per-action meta. Only the three most common actions ('ISMActionRollover', +-- 'ISMActionForceMerge', 'ISMActionAllocation') carry typed configs today; the +-- remaining constructors carry their config as an opaque 'Value' (typing them +-- is tracked as follow-up work). + +data ISMAction + = ISMActionRollover (Maybe ISMRolloverConfig) + | ISMActionDelete + | ISMActionForceMerge (Maybe ISMForceMergeConfig) + | ISMActionAllocation (Maybe ISMAllocationConfig) + | ISMActionNotification (Maybe Value) + | ISMActionSnapshot (Maybe Value) + | ISMActionReadWrite (Maybe Value) + | ISMActionReadOnly + | ISMActionShrink (Maybe Value) + | ISMActionOpen + | ISMActionClose + | ISMActionRollup (Maybe Value) + | ISMActionIndexPriority (Maybe Value) + | ISMActionFreeze + | ISMActionUnfreeze + | ISMActionWaitFor (Maybe Value) + | ISMActionReplicaCount (Maybe ISMReplicaCountConfig) + | ISMActionAlias (Maybe ISMAliasConfig) + | ISMActionCustom Text (Maybe Value) + deriving stock (Eq, Show) + +-- | Name of the single JSON key that encodes this action (matches what OS +-- sends on the wire). +actionTagName :: ISMAction -> Text +actionTagName = \case + ISMActionRollover _ -> "rollover" + ISMActionDelete -> "delete" + ISMActionForceMerge _ -> "force_merge" + ISMActionAllocation _ -> "allocation" + ISMActionNotification _ -> "notification" + ISMActionSnapshot _ -> "snapshot" + ISMActionReadWrite _ -> "read_write" + ISMActionReadOnly -> "read_only" + ISMActionShrink _ -> "shrink" + ISMActionOpen -> "open" + ISMActionClose -> "close" + ISMActionRollup _ -> "rollup" + ISMActionIndexPriority _ -> "index_priority" + ISMActionFreeze -> "freeze" + ISMActionUnfreeze -> "unfreeze" + ISMActionWaitFor _ -> "wait_for" + ISMActionReplicaCount _ -> "replica_count" + ISMActionAlias _ -> "alias" + ISMActionCustom tag _ -> tag + +-- | Render the action's config as a 'Value'. For actions without a config this +-- is an empty object @{}@; for opaque actions it is whatever the caller put in +-- (or @{}@ if 'Nothing'). +actionConfigValue :: ISMAction -> Value +actionConfigValue = \case + ISMActionRollover cfg -> maybe (object []) toJSON cfg + ISMActionDelete -> object [] + ISMActionForceMerge cfg -> maybe (object []) toJSON cfg + ISMActionAllocation cfg -> maybe (object []) toJSON cfg + ISMActionNotification cfg -> maybe (object []) toJSON cfg + ISMActionSnapshot cfg -> maybe (object []) toJSON cfg + ISMActionReadWrite cfg -> maybe (object []) toJSON cfg + ISMActionReadOnly -> object [] + ISMActionShrink cfg -> maybe (object []) toJSON cfg + ISMActionOpen -> object [] + ISMActionClose -> object [] + ISMActionRollup cfg -> maybe (object []) toJSON cfg + ISMActionIndexPriority cfg -> maybe (object []) toJSON cfg + ISMActionFreeze -> object [] + ISMActionUnfreeze -> object [] + ISMActionWaitFor cfg -> maybe (object []) toJSON cfg + ISMActionReplicaCount cfg -> maybe (object []) toJSON cfg + ISMActionAlias cfg -> maybe (object []) toJSON cfg + ISMActionCustom _ cfg -> maybe (object []) toJSON cfg + +instance FromJSON ISMAction where + parseJSON = withObject "ISMAction" $ \o -> case KM.toList o of + [] -> fail "ISMAction: empty object" + ((k, v) : _) -> case AKey.toText k of + "rollover" -> ISMActionRollover <$> parseJSON v + "delete" -> pure ISMActionDelete + "force_merge" -> ISMActionForceMerge <$> parseJSON v + "allocation" -> ISMActionAllocation <$> parseJSON v + "notification" -> ISMActionNotification <$> parseJSON v + "snapshot" -> ISMActionSnapshot <$> parseJSON v + "read_write" -> ISMActionReadWrite <$> parseJSON v + "read_only" -> pure ISMActionReadOnly + "shrink" -> ISMActionShrink <$> parseJSON v + "open" -> pure ISMActionOpen + "close" -> pure ISMActionClose + "rollup" -> ISMActionRollup <$> parseJSON v + "index_priority" -> ISMActionIndexPriority <$> parseJSON v + "freeze" -> pure ISMActionFreeze + "unfreeze" -> pure ISMActionUnfreeze + "wait_for" -> ISMActionWaitFor <$> parseJSON v + "replica_count" -> ISMActionReplicaCount <$> parseJSON v + "alias" -> ISMActionAlias <$> parseJSON v + other -> ISMActionCustom other <$> parseJSON v + +instance ToJSON ISMAction where + toJSON a = object [AKey.fromText (actionTagName a) .= actionConfigValue a] + +-- $actionMeta +-- +-- Beyond the action-specific config, OS accepts two orthogonal parameters +-- on every action entry: @timeout@ and @retry@ +-- (). +-- These sit alongside the action key as siblings in the same JSON object, +-- e.g.: +-- +-- @ +-- { "rollover": {"min_size": "50gb"}, +-- , "timeout": "1d" +-- , "retry": {"count": 3, "backoff": "exponential", "delay": "1m"} +-- } +-- @ +-- +-- 'ISMActionEntry' pairs an 'ISMAction' with its optional meta so the +-- per-action configuration stays orthogonal to the action type itself. +-- 'mkISMActionEntry' produces an entry whose wire shape is byte-for-byte +-- identical to the legacy bare 'ISMAction' for any *known* action (no +-- @timeout@\/@retry@ keys emitted), preserving backwards compatibility +-- with existing callers. The names @"timeout"@ and @"retry"@ are +-- reserved: an 'ISMActionCustom' that reuses either as its tag would be +-- shadowed by the meta merge — see the note on 'ISMActionEntry's +-- 'ToJSON' instance. +-- +-- /Maintainer note:/ 'ISMActionEntry's codecs strip exactly +-- @["timeout", "retry"]@ before delegating to 'ISMAction'. If OS grows +-- additional per-action meta siblings in a future release, extend that +-- strip list in both 'FromJSON' and 'ToJSON' to keep the action parser +-- from mis-reading the new sibling as an 'ISMActionCustom'. + +-- | Backoff strategy used by 'ISMRetryConfig'. OS accepts exactly these +-- three values; the 'FromJSON' instance rejects anything else so a typo +-- surfaces at decode time rather than being silently dropped. +data ISMRetryBackoff + = ISMRetryBackoffExponential + | ISMRetryBackoffConstant + | ISMRetryBackoffLinear + deriving stock (Eq, Show) + +ismRetryBackoffText :: ISMRetryBackoff -> Text +ismRetryBackoffText ISMRetryBackoffExponential = "exponential" +ismRetryBackoffText ISMRetryBackoffConstant = "constant" +ismRetryBackoffText ISMRetryBackoffLinear = "linear" + +instance FromJSON ISMRetryBackoff where + parseJSON = withText "ISMRetryBackoff" $ \case + "exponential" -> pure ISMRetryBackoffExponential + "constant" -> pure ISMRetryBackoffConstant + "linear" -> pure ISMRetryBackoffLinear + other -> fail ("unknown ISM retry backoff: " <> T.unpack other) + +instance ToJSON ISMRetryBackoff where + toJSON = String . ismRetryBackoffText + +-- | Per-action retry configuration. Every field is optional; OS fills in +-- sensible defaults when omitted. +-- See +data ISMRetryConfig = ISMRetryConfig + { ismRetryConfigCount :: Maybe Int, + ismRetryConfigBackoff :: Maybe ISMRetryBackoff, + ismRetryConfigDelay :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMRetryConfig where + parseJSON = withObject "ISMRetryConfig" $ \v -> do + ismRetryConfigCount <- v .:? "count" + ismRetryConfigBackoff <- v .:? "backoff" + ismRetryConfigDelay <- v .:? "delay" + return ISMRetryConfig {..} + +instance ToJSON ISMRetryConfig where + toJSON ISMRetryConfig {..} = + omitNulls + [ "count" .= ismRetryConfigCount, + "backoff" .= ismRetryConfigBackoff, + "delay" .= ismRetryConfigDelay + ] + +-- | One entry in 'ismStateActions'. Pairs the action-specific config +-- ('ISMAction') with the orthogonal per-action meta (@timeout@, @retry@). +-- Use 'mkISMActionEntry' to construct an entry that decodes byte-for-byte +-- like the legacy bare 'ISMAction'. +data ISMActionEntry = ISMActionEntry + { ismActionEntryAction :: ISMAction, + -- | @timeout@ sibling. OS accepts time units for minutes, hours and + -- days (e.g. @"1d"@, @"60m"@). Kept as plain 'Text' so callers can + -- build any valid OS literal without the library having to model the + -- restricted grammar. + ismActionEntryTimeout :: Maybe Text, + ismActionEntryRetry :: Maybe ISMRetryConfig + } + deriving stock (Eq, Show) + +-- | Smart constructor that produces an entry with no meta. The resulting +-- wire shape is byte-for-byte identical to the bare 'ISMAction', so +-- callers migrating from the legacy @[ISMAction]@ shape can wrap each +-- element mechanically. +mkISMActionEntry :: ISMAction -> ISMActionEntry +mkISMActionEntry a = ISMActionEntry a Nothing Nothing + +instance FromJSON ISMActionEntry where + parseJSON = withObject "ISMActionEntry" $ \o -> do + -- Strip the meta keys so the remaining single-key object parses as + -- the underlying 'ISMAction' via its existing instance. + let body = Object (deleteSeveral ["timeout", "retry"] o) + ismActionEntryAction <- parseJSON body + ismActionEntryTimeout <- o .:? "timeout" + ismActionEntryRetry <- o .:? "retry" + return ISMActionEntry {..} + +instance ToJSON ISMActionEntry where + toJSON ISMActionEntry {..} = + case toJSON ismActionEntryAction of + Object inner -> + Object (deleteSeveral ["timeout", "retry"] inner <> meta) + where + meta = + KM.fromList $ + [ ("timeout", toJSON t) | Just t <- [ismActionEntryTimeout] + ] + <> [ ("retry", toJSON r) | Just r <- [ismActionEntryRetry] + ] + -- Defensive: 'ISMAction' always renders to a single-key 'Object', + -- so this branch is unreachable in practice but keeps the instance + -- total. + other -> other + +ismActionEntryActionLens :: Lens' ISMActionEntry ISMAction +ismActionEntryActionLens = lens ismActionEntryAction (\x y -> x {ismActionEntryAction = y}) + +ismActionEntryTimeoutLens :: Lens' ISMActionEntry (Maybe Text) +ismActionEntryTimeoutLens = lens ismActionEntryTimeout (\x y -> x {ismActionEntryTimeout = y}) + +ismActionEntryRetryLens :: Lens' ISMActionEntry (Maybe ISMRetryConfig) +ismActionEntryRetryLens = lens ismActionEntryRetry (\x y -> x {ismActionEntryRetry = y}) + +-- | Config for 'ISMActionRollover'. OS requires at least one threshold; we keep +-- all four 'Maybe' so callers can express any subset. Sizes/ages carry units +-- (e.g. @"1gb"@, @"1d"@) so they are 'Text', not numbers. +-- See +data ISMRolloverConfig = ISMRolloverConfig + { ismRolloverConfigMinSize :: Maybe Text, + ismRolloverConfigMinDocCount :: Maybe Int, + ismRolloverConfigMinIndexAge :: Maybe Text, + ismRolloverConfigMinPrimaryShardSize :: Maybe Text, + ismRolloverConfigCopyAlias :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON ISMRolloverConfig where + parseJSON = withObject "ISMRolloverConfig" $ \v -> do + ismRolloverConfigMinSize <- v .:? "min_size" + ismRolloverConfigMinDocCount <- v .:? "min_doc_count" + ismRolloverConfigMinIndexAge <- v .:? "min_index_age" + ismRolloverConfigMinPrimaryShardSize <- v .:? "min_primary_shard_size" + ismRolloverConfigCopyAlias <- v .:? "copy_alias" + return ISMRolloverConfig {..} + +instance ToJSON ISMRolloverConfig where + toJSON ISMRolloverConfig {..} = + omitNulls + [ "min_size" .= ismRolloverConfigMinSize, + "min_doc_count" .= ismRolloverConfigMinDocCount, + "min_index_age" .= ismRolloverConfigMinIndexAge, + "min_primary_shard_size" .= ismRolloverConfigMinPrimaryShardSize, + "copy_alias" .= ismRolloverConfigCopyAlias + ] + +-- | Config for 'ISMActionForceMerge'. Of the three fields, only +-- @max_num_segments@ appears in the official OpenSearch ISM @force_merge@ +-- documentation; @wait_for_completion@ and @task_execution_timeout@ are +-- accepted by the server but undocumented on the policies page. +-- @wait_for_completion@ (default @true@) is a 'Bool' gating whether the +-- action blocks until the merge finishes; @task_execution_timeout@ (default +-- @1h@, only meaningful when @wait_for_completion@ is @false@) is a duration +-- string (e.g. @"1h"@), hence 'Text'. All three are 'Maybe' so minimal +-- payloads round-trip byte-stable. +-- See +data ISMForceMergeConfig = ISMForceMergeConfig + { ismForceMergeConfigMaxNumSegments :: Maybe Int, + ismForceMergeConfigWaitForCompletion :: Maybe Bool, + ismForceMergeConfigTaskExecutionTimeout :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMForceMergeConfig where + parseJSON = withObject "ISMForceMergeConfig" $ \v -> do + ismForceMergeConfigMaxNumSegments <- v .:? "max_num_segments" + ismForceMergeConfigWaitForCompletion <- v .:? "wait_for_completion" + ismForceMergeConfigTaskExecutionTimeout <- v .:? "task_execution_timeout" + return ISMForceMergeConfig {..} + +instance ToJSON ISMForceMergeConfig where + toJSON ISMForceMergeConfig {..} = + omitNulls + [ "max_num_segments" .= ismForceMergeConfigMaxNumSegments, + "wait_for_completion" .= ismForceMergeConfigWaitForCompletion, + "task_execution_timeout" .= ismForceMergeConfigTaskExecutionTimeout + ] + +-- | Config for 'ISMActionAllocation'. Each of @require@, @include@, @exclude@ +-- maps allocation attribute names to (comma-separated) values. @wait_for@ +-- gates whether the policy blocks until the reallocation completes +-- (: +-- @val waitFor: Boolean = false@). +-- See +data ISMAllocationConfig = ISMAllocationConfig + { ismAllocationConfigRequire :: Maybe (Map.Map Text Text), + ismAllocationConfigInclude :: Maybe (Map.Map Text Text), + ismAllocationConfigExclude :: Maybe (Map.Map Text Text), + ismAllocationConfigWaitFor :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON ISMAllocationConfig where + parseJSON = withObject "ISMAllocationConfig" $ \v -> do + ismAllocationConfigRequire <- v .:? "require" + ismAllocationConfigInclude <- v .:? "include" + ismAllocationConfigExclude <- v .:? "exclude" + ismAllocationConfigWaitFor <- v .:? "wait_for" + return ISMAllocationConfig {..} + +instance ToJSON ISMAllocationConfig where + toJSON ISMAllocationConfig {..} = + omitNulls + [ "require" .= ismAllocationConfigRequire, + "include" .= ismAllocationConfigInclude, + "exclude" .= ismAllocationConfigExclude, + "wait_for" .= ismAllocationConfigWaitFor + ] + +-- | Config for 'ISMActionReplicaCount'. OS requires @number_of_replicas@ to be +-- present (it has no sensible default), so the field is a strict 'Int' rather +-- than 'Maybe'. A caller who builds 'ISMActionReplicaCount' 'Nothing' encodes +-- as @{"replica_count":{}}@ which the server will reject — that path is +-- intended only for round-tripping malformed payloads. +-- See +data ISMReplicaCountConfig = ISMReplicaCountConfig + { ismReplicaCountConfigNumberOfReplicas :: Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMReplicaCountConfig where + parseJSON = withObject "ISMReplicaCountConfig" $ \v -> do + ismReplicaCountConfigNumberOfReplicas <- v .: "number_of_replicas" + return ISMReplicaCountConfig {..} + +instance ToJSON ISMReplicaCountConfig where + toJSON ISMReplicaCountConfig {..} = + object ["number_of_replicas" .= ismReplicaCountConfigNumberOfReplicas] + +-- | One sub-action inside an 'ISMAliasConfig' @actions@ array. OS supports +-- @add@ and @remove@; both carry at least the alias name. @add@ additionally +-- accepts @index@ (which index to attach) and @is_write_index@. This is the +-- minimal typed surface covering the documented example +-- (); any +-- more exotic sub-action can still be carried losslessly via +-- 'ISMActionCustom' on the outer 'ISMAction'. +data ISMAliasAction + = ISMAliasActionAdd + { ismAliasActionAddAlias :: Text, + ismAliasActionAddIndex :: Maybe Text, + ismAliasActionAddIsWriteIndex :: Maybe Bool + } + | ISMAliasActionRemove + { ismAliasActionRemoveAlias :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMAliasAction where + parseJSON = withObject "ISMAliasAction" $ \o -> case KM.toList o of + [] -> fail "ISMAliasAction: empty object" + ((k, v) : _) -> case AKey.toText k of + "add" -> + withObject + "ISMAliasActionAdd" + ( \cfg -> do + ismAliasActionAddAlias <- cfg .: "alias" + ismAliasActionAddIndex <- cfg .:? "index" + ismAliasActionAddIsWriteIndex <- cfg .:? "is_write_index" + return ISMAliasActionAdd {..} + ) + v + "remove" -> + withObject + "ISMAliasActionRemove" + ( \cfg -> do + ismAliasActionRemoveAlias <- cfg .: "alias" + return ISMAliasActionRemove {..} + ) + v + other -> fail ("ISMAliasAction: unexpected key " <> T.unpack other) + +instance ToJSON ISMAliasAction where + toJSON = \case + ISMAliasActionAdd {..} -> + object + [ AKey.fromText "add" + .= omitNulls + [ "alias" .= ismAliasActionAddAlias, + "index" .= ismAliasActionAddIndex, + "is_write_index" .= ismAliasActionAddIsWriteIndex + ] + ] + ISMAliasActionRemove {..} -> + object + [ AKey.fromText "remove" + .= object ["alias" .= ismAliasActionRemoveAlias] + ] + +-- | Config for 'ISMActionAlias'. Wraps the @actions@ array of @add@ \/ @remove@ +-- sub-actions (see 'ISMAliasAction'). +-- See +newtype ISMAliasConfig = ISMAliasConfig + { ismAliasConfigActions :: [ISMAliasAction] + } + deriving stock (Eq, Show) + +instance FromJSON ISMAliasConfig where + parseJSON = withObject "ISMAliasConfig" $ \v -> do + ismAliasConfigActions <- v .:? "actions" .!= [] + return ISMAliasConfig {..} + +instance ToJSON ISMAliasConfig where + toJSON ISMAliasConfig {..} = + object ["actions" .= ismAliasConfigActions] + +-- | One entry in the @failed_indices@ array of an 'ISMUpdatedIndicesResponse'. +-- Carries the index that rejected an ISM policy operation along with the +-- reason. @index_uuid@ is @null@ when the index does not exist. +-- See +data ISMFailedIndex = ISMFailedIndex + { ismFailedIndexName :: Text, + ismFailedIndexUuid :: Maybe Text, + ismFailedIndexReason :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMFailedIndex where + parseJSON = withObject "ISMFailedIndex" $ \v -> do + ismFailedIndexName <- v .: "index_name" + ismFailedIndexUuid <- v .:? "index_uuid" + ismFailedIndexReason <- v .: "reason" + return ISMFailedIndex {..} + +instance ToJSON ISMFailedIndex where + toJSON ISMFailedIndex {..} = + object + [ "index_name" .= ismFailedIndexName, + "index_uuid" .= ismFailedIndexUuid, + "reason" .= ismFailedIndexReason + ] + +-- | Response body shared by the ISM index-mutation endpoints +-- @POST /_plugins/_ism/add\/remove\/change_policy\/retry\/{index}@. +-- OpenSearch reports @updated_indices@, whether any @failures@ occurred, and a +-- @failed_indices@ list describing each index that rejected the operation. +-- See +data ISMUpdatedIndicesResponse = ISMUpdatedIndicesResponse + { ismUpdatedIndicesResponseUpdatedIndices :: Int, + ismUpdatedIndicesResponseFailures :: Bool, + ismUpdatedIndicesResponseFailedIndices :: [ISMFailedIndex] + } + deriving stock (Eq, Show) + +-- | Backwards-compatible alias. The @add@, @remove@, @change_policy@ and +-- @retry@ ISM endpoints all share this response shape; the type was originally +-- introduced as @AddISMPolicyResponse@ before the shared shape was recognised. +type AddISMPolicyResponse = ISMUpdatedIndicesResponse + +instance FromJSON ISMUpdatedIndicesResponse where + parseJSON = withObject "ISMUpdatedIndicesResponse" $ \v -> do + ismUpdatedIndicesResponseUpdatedIndices <- v .: "updated_indices" + ismUpdatedIndicesResponseFailures <- v .: "failures" + ismUpdatedIndicesResponseFailedIndices <- v .:? "failed_indices" .!= [] + return ISMUpdatedIndicesResponse {..} + +instance ToJSON ISMUpdatedIndicesResponse where + toJSON ISMUpdatedIndicesResponse {..} = + object + [ "updated_indices" .= ismUpdatedIndicesResponseUpdatedIndices, + "failures" .= ismUpdatedIndicesResponseFailures, + "failed_indices" .= ismUpdatedIndicesResponseFailedIndices + ] + +-- | Optional filter inside a 'ChangePolicyRequest'. Restricts the policy change +-- to managed indices currently in the given @state@. +-- See +data ISMChangePolicyInclude = ISMChangePolicyInclude + { ismChangePolicyIncludeState :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMChangePolicyInclude where + parseJSON = withObject "ISMChangePolicyInclude" $ \v -> do + ismChangePolicyIncludeState <- v .: "state" + return ISMChangePolicyInclude {..} + +instance ToJSON ISMChangePolicyInclude where + toJSON ISMChangePolicyInclude {..} = + object ["state" .= ismChangePolicyIncludeState] + +-- | Request body for @POST /_plugins/_ism/change_policy\/{index}@. +-- @policy_id@ selects the new policy; @state@ optionally names the state the +-- managed index transitions to after the change takes effect; @include@ +-- optionally filters which currently-managed indices the change applies to. +-- See +data ChangePolicyRequest = ChangePolicyRequest + { changePolicyRequestId :: PolicyId, + changePolicyRequestState :: Maybe Text, + changePolicyRequestInclude :: [ISMChangePolicyInclude] + } + deriving stock (Eq, Show) + +instance FromJSON ChangePolicyRequest where + parseJSON = withObject "ChangePolicyRequest" $ \v -> do + changePolicyRequestId <- v .: "policy_id" + changePolicyRequestState <- v .:? "state" + changePolicyRequestInclude <- v .:? "include" .!= [] + return ChangePolicyRequest {..} + +instance ToJSON ChangePolicyRequest where + toJSON ChangePolicyRequest {..} = + omitNulls + [ "policy_id" .= unPolicyId changePolicyRequestId, + "state" .= changePolicyRequestState, + "include" .= changePolicyRequestInclude + ] + +-- $explainSubshapes +-- +-- The @GET /_plugins/_ism/explain/{index}@ response is a JSON object keyed by +-- index name. Each value mixes (a) arbitrary index settings whose keys contain +-- dots (e.g. @index.plugins.index_state_management.policy_id@) with (b) a +-- fixed set of managed-index fields (@index@, @state@, @action@, ...). To stay +-- lossless for the unmanaged case, the dotted @policy_id@ settings are +-- captured explicitly; every managed-index field is 'Maybe' so the minimal +-- unmanaged body @{"index.plugins...policy_id": "p"}@ decodes cleanly. +-- +-- The full @policy@ sub-object is carried as an opaque 'Value' until the typed +-- ISM policy schema lands (tracked separately). +-- +-- See + +-- | A named ISM runtime entity (a @state@ or an @action@) with the epoch-ms +-- instant at which it became active. +data ISMExplanationNamed = ISMExplanationNamed + { ismExplanationNamedName :: Text, + ismExplanationNamedStartTime :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationNamed where + parseJSON = withObject "ISMExplanationNamed" $ \v -> do + ismExplanationNamedName <- v .: "name" + ismExplanationNamedStartTime <- v .:? "start_time" + return ISMExplanationNamed {..} + +instance ToJSON ISMExplanationNamed where + toJSON ISMExplanationNamed {..} = + omitNulls + [ "name" .= ismExplanationNamedName, + "start_time" .= ismExplanationNamedStartTime + ] + +-- | The @action@ object in an explain entry. +data ISMExplanationAction = ISMExplanationAction + { ismExplanationActionName :: Text, + ismExplanationActionStartTime :: Maybe Int, + ismExplanationActionIndex :: Maybe Int, + ismExplanationActionFailed :: Maybe Bool, + ismExplanationActionConsumedRetries :: Maybe Int, + ismExplanationActionLastRetryTime :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationAction where + parseJSON = withObject "ISMExplanationAction" $ \v -> do + ismExplanationActionName <- v .: "name" + ismExplanationActionStartTime <- v .:? "start_time" + ismExplanationActionIndex <- v .:? "index" + ismExplanationActionFailed <- v .:? "failed" + ismExplanationActionConsumedRetries <- v .:? "consumed_retries" + ismExplanationActionLastRetryTime <- v .:? "last_retry_time" + return ISMExplanationAction {..} + +instance ToJSON ISMExplanationAction where + toJSON ISMExplanationAction {..} = + omitNulls + [ "name" .= ismExplanationActionName, + "start_time" .= ismExplanationActionStartTime, + "index" .= ismExplanationActionIndex, + "failed" .= ismExplanationActionFailed, + "consumed_retries" .= ismExplanationActionConsumedRetries, + "last_retry_time" .= ismExplanationActionLastRetryTime + ] + +-- | The @step@ object in an explain entry. +data ISMExplanationStep = ISMExplanationStep + { ismExplanationStepName :: Text, + ismExplanationStepStartTime :: Maybe Int, + ismExplanationStepStepStatus :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationStep where + parseJSON = withObject "ISMExplanationStep" $ \v -> do + ismExplanationStepName <- v .: "name" + ismExplanationStepStartTime <- v .:? "start_time" + ismExplanationStepStepStatus <- v .:? "step_status" + return ISMExplanationStep {..} + +instance ToJSON ISMExplanationStep where + toJSON ISMExplanationStep {..} = + omitNulls + [ "name" .= ismExplanationStepName, + "start_time" .= ismExplanationStepStartTime, + "step_status" .= ismExplanationStepStepStatus + ] + +-- | The @retry_info@ object in an explain entry. +data ISMExplanationRetryInfo = ISMExplanationRetryInfo + { ismExplanationRetryInfoFailed :: Bool, + ismExplanationRetryInfoConsumedRetries :: Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationRetryInfo where + parseJSON = withObject "ISMExplanationRetryInfo" $ \v -> do + ismExplanationRetryInfoFailed <- v .: "failed" + ismExplanationRetryInfoConsumedRetries <- v .: "consumed_retries" + return ISMExplanationRetryInfo {..} + +instance ToJSON ISMExplanationRetryInfo where + toJSON ISMExplanationRetryInfo {..} = + object + [ "failed" .= ismExplanationRetryInfoFailed, + "consumed_retries" .= ismExplanationRetryInfoConsumedRetries + ] + +-- | The @info@ object in an explain entry. +data ISMExplanationInfo = ISMExplanationInfo + { ismExplanationInfoMessage :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationInfo where + parseJSON = withObject "ISMExplanationInfo" $ \v -> do + ismExplanationInfoMessage <- v .: "message" + return ISMExplanationInfo {..} + +instance ToJSON ISMExplanationInfo where + toJSON ISMExplanationInfo {..} = + object ["message" .= ismExplanationInfoMessage] + +-- | The @validate@ object returned when explain is called with +-- @validate_action=true@. +data ISMExplanationValidate = ISMExplanationValidate + { ismExplanationValidateValidationMessage :: Text, + ismExplanationValidateValidationStatus :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationValidate where + parseJSON = withObject "ISMExplanationValidate" $ \v -> do + ismExplanationValidateValidationMessage <- v .: "validation_message" + ismExplanationValidateValidationStatus <- v .: "validation_status" + return ISMExplanationValidate {..} + +instance ToJSON ISMExplanationValidate where + toJSON ISMExplanationValidate {..} = + object + [ "validation_message" .= ismExplanationValidateValidationMessage, + "validation_status" .= ismExplanationValidateValidationStatus + ] + +-- | Per-index value in an 'ISMExplanation'. Every field is 'Maybe' because the +-- explain response ranges from a bare settings-only object (unmanaged index) +-- to the full managed-index status. The dotted @policy_id@ settings are +-- captured explicitly so the unmanaged case is not lossy. +data ISMExplanationEntry = ISMExplanationEntry + { ismExplanationEntryIndex :: Maybe Text, + ismExplanationEntryIndexUuid :: Maybe Text, + ismExplanationEntryPolicyId :: Maybe Text, + ismExplanationEntryEnabled :: Maybe Bool, + ismExplanationEntryEnabledTime :: Maybe Int, + ismExplanationEntryPolicySeqNo :: Maybe Int, + ismExplanationEntryPolicyPrimaryTerm :: Maybe Int, + ismExplanationEntryRolledOver :: Maybe Bool, + ismExplanationEntryIndexCreationDate :: Maybe Int, + ismExplanationEntryState :: Maybe ISMExplanationNamed, + ismExplanationEntryAction :: Maybe ISMExplanationAction, + ismExplanationEntryStep :: Maybe ISMExplanationStep, + ismExplanationEntryRetryInfo :: Maybe ISMExplanationRetryInfo, + ismExplanationEntryInfo :: Maybe ISMExplanationInfo, + ismExplanationEntryPolicy :: Maybe Value, + ismExplanationEntryValidate :: Maybe ISMExplanationValidate, + ismExplanationEntryPolicyIdSetting :: Maybe Text, + ismExplanationEntryOpendistroPolicyIdSetting :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationEntry where + parseJSON = withObject "ISMExplanationEntry" $ \v -> do + ismExplanationEntryIndex <- v .:? "index" + ismExplanationEntryIndexUuid <- v .:? "index_uuid" + ismExplanationEntryPolicyId <- v .:? "policy_id" + ismExplanationEntryEnabled <- v .:? "enabled" + ismExplanationEntryEnabledTime <- v .:? "enabled_time" + ismExplanationEntryPolicySeqNo <- v .:? "policy_seq_no" + ismExplanationEntryPolicyPrimaryTerm <- v .:? "policy_primary_term" + ismExplanationEntryRolledOver <- v .:? "rolled_over" + ismExplanationEntryIndexCreationDate <- v .:? "index_creation_date" + ismExplanationEntryState <- v .:? "state" + ismExplanationEntryAction <- v .:? "action" + ismExplanationEntryStep <- v .:? "step" + ismExplanationEntryRetryInfo <- v .:? "retry_info" + ismExplanationEntryInfo <- v .:? "info" + ismExplanationEntryPolicy <- v .:? "policy" + ismExplanationEntryValidate <- v .:? "validate" + ismExplanationEntryPolicyIdSetting <- + v .:? "index.plugins.index_state_management.policy_id" + ismExplanationEntryOpendistroPolicyIdSetting <- + v .:? "index.opendistro.index_state_management.policy_id" + return ISMExplanationEntry {..} + +instance ToJSON ISMExplanationEntry where + toJSON ISMExplanationEntry {..} = + omitNulls + [ "index" .= ismExplanationEntryIndex, + "index_uuid" .= ismExplanationEntryIndexUuid, + "policy_id" .= ismExplanationEntryPolicyId, + "enabled" .= ismExplanationEntryEnabled, + "enabled_time" .= ismExplanationEntryEnabledTime, + "policy_seq_no" .= ismExplanationEntryPolicySeqNo, + "policy_primary_term" .= ismExplanationEntryPolicyPrimaryTerm, + "rolled_over" .= ismExplanationEntryRolledOver, + "index_creation_date" .= ismExplanationEntryIndexCreationDate, + "state" .= ismExplanationEntryState, + "action" .= ismExplanationEntryAction, + "step" .= ismExplanationEntryStep, + "retry_info" .= ismExplanationEntryRetryInfo, + "info" .= ismExplanationEntryInfo, + "policy" .= ismExplanationEntryPolicy, + "validate" .= ismExplanationEntryValidate, + "index.plugins.index_state_management.policy_id" .= ismExplanationEntryPolicyIdSetting, + "index.opendistro.index_state_management.policy_id" .= ismExplanationEntryOpendistroPolicyIdSetting + ] + +-- | Response of @GET /_plugins/_ism/explain/{index}@: a map keyed by index +-- name plus an optional @total_managed_indices@ count (present when at least +-- one queried index is managed). Unknown per-index keys are ignored; the +-- dotted @policy_id@ settings are captured by 'ISMExplanationEntry'. +-- See +data ISMExplanation = ISMExplanation + { ismExplanationEntries :: Map.Map Text ISMExplanationEntry, + ismExplanationTotalManagedIndices :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanation where + parseJSON = withObject "ISMExplanation" $ \v -> do + ismExplanationTotalManagedIndices <- v .:? "total_managed_indices" + let entryPairs = + [ (AKey.toText k, val) + | (k, val) <- KM.toList v, + k /= "total_managed_indices" + ] + ismExplanationEntries <- + Map.fromList + <$> traverse + (\(k, val) -> fmap ((,) k) (parseJSON val)) + entryPairs + return ISMExplanation {..} + +instance ToJSON ISMExplanation where + toJSON ISMExplanation {..} = + Object $ + KM.fromList $ + [ (AKey.fromText k, toJSON e) + | (k, e) <- Map.toList ismExplanationEntries + ] + <> [ (AKey.fromText "total_managed_indices", toJSON n) + | Just n <- [ismExplanationTotalManagedIndices] + ] + +-- | A single policy entry as returned by @GET /_plugins/_ism/policies[\/{id}]@. +-- The @policy@ sub-object is the full managed-policy wrapper (with +-- @policy_id@, @schema_version@, @states@, ...) and is carried as an opaque +-- 'Value' until the typed ISM policy schema lands (tracked separately). +-- See +data ISMPolicyInfo = ISMPolicyInfo + { ismPolicyInfoId :: Text, + ismPolicyInfoVersion :: Maybe DocVersion, + ismPolicyInfoSeqNo :: Int, + ismPolicyInfoPrimaryTerm :: Int, + ismPolicyInfoPolicy :: Value + } + deriving stock (Eq, Show) + +instance FromJSON ISMPolicyInfo where + parseJSON = withObject "ISMPolicyInfo" $ \v -> do + ismPolicyInfoId <- v .: "_id" + ismPolicyInfoVersion <- v .:? "_version" + ismPolicyInfoSeqNo <- v .: "_seq_no" + ismPolicyInfoPrimaryTerm <- v .: "_primary_term" + ismPolicyInfoPolicy <- v .: "policy" + return ISMPolicyInfo {..} + +instance ToJSON ISMPolicyInfo where + toJSON ISMPolicyInfo {..} = + omitNulls + [ "_id" .= ismPolicyInfoId, + "_version" .= ismPolicyInfoVersion, + "_seq_no" .= ismPolicyInfoSeqNo, + "_primary_term" .= ismPolicyInfoPrimaryTerm, + "policy" .= ismPolicyInfoPolicy + ] + +-- | Response of @GET /_plugins/_ism/policies@ (the list variant). +-- See +data GetISMPoliciesResponse = GetISMPoliciesResponse + { getISMPoliciesResponsePolicies :: [ISMPolicyInfo] + } + deriving stock (Eq, Show) + +instance FromJSON GetISMPoliciesResponse where + parseJSON = withObject "GetISMPoliciesResponse" $ \v -> do + getISMPoliciesResponsePolicies <- v .: "policies" + return GetISMPoliciesResponse {..} + +instance ToJSON GetISMPoliciesResponse where + toJSON GetISMPoliciesResponse {..} = + object ["policies" .= getISMPoliciesResponsePolicies] + +-- | Optional filtering / pagination parameters for 'getISMPolicies'. +-- All fields are optional; see the @Get policies@ query parameters table. +data ISMPoliciesQuery = ISMPoliciesQuery + { ismPoliciesQuerySize :: Maybe Int, + ismPoliciesQueryFrom :: Maybe Int, + ismPoliciesQuerySortField :: Maybe Text, + ismPoliciesQuerySortOrder :: Maybe Text, + ismPoliciesQueryQueryString :: Maybe Text + } + deriving stock (Eq, Show) + +-- | Render an 'ISMPoliciesQuery' as the query-string pairs accepted by the +-- @GET /_plugins/_ism/policies@ endpoint. 'Nothing' fields are omitted so the +-- request only carries the parameters the caller set. +ismPoliciesQueryToPairs :: ISMPoliciesQuery -> [(Text, Maybe Text)] +ismPoliciesQueryToPairs ISMPoliciesQuery {..} = + catMaybes + [ fmap (\n -> ("size", Just (showText n))) ismPoliciesQuerySize, + fmap (\n -> ("from", Just (showText n))) ismPoliciesQueryFrom, + fmap (\t -> ("sortField", Just t)) ismPoliciesQuerySortField, + fmap (\t -> ("sortOrder", Just t)) ismPoliciesQuerySortOrder, + fmap (\t -> ("queryString", Just t)) ismPoliciesQueryQueryString + ] + +-- | Optional parameters for 'explainISMIndexWith' +-- (@GET /_plugins/_ism/explain/{index}@). All four documented query +-- parameters are modelled: +-- +-- * @show_policy@ — returns the full managed-index policy in the response. +-- * @validate_action@ — validates the cached actions in the managed index +-- metadata. +-- * @local@ — /OpenSearch only/. Whether to return local information such +-- as the managed index metadata. Default is @false@. +-- * @expand_wildcards@ — controls wildcard index expansion (@open@, +-- @closed@, @hidden@, @all@, @none@). Reuses the 'ExpandWildcards' sum +-- type shared with the search and count endpoints; the server accepts a +-- comma-separated list so we model it as a 'NonEmpty' to encode "at +-- least one". +-- +-- See +data ISMExplainOptions = ISMExplainOptions + { ismExplainOptionsShowPolicy :: Bool, + ismExplainOptionsValidateAction :: Bool, + ismExplainOptionsLocal :: Maybe Bool, + ismExplainOptionsExpandWildcards :: Maybe (NonEmpty ExpandWildcards) + } + deriving stock (Eq, Show) + +-- | 'ISMExplainOptions' with every parameter set to its no-op value +-- (@show_policy = False@, @validate_action = False@, @local = Nothing@, +-- @expand_wildcards = Nothing@). Produces no query string, so a call made +-- with this value is byte-identical to the legacy @explainISMIndex@ wire +-- shape. +defaultISMExplainOptions :: ISMExplainOptions +defaultISMExplainOptions = + ISMExplainOptions + { ismExplainOptionsShowPolicy = False, + ismExplainOptionsValidateAction = False, + ismExplainOptionsLocal = Nothing, + ismExplainOptionsExpandWildcards = Nothing + } + +-- | Render an 'ISMExplainOptions' as the query-string pairs accepted by the +-- @GET /_plugins/_ism/explain/{index}@ endpoint. 'False' bool flags and +-- 'Nothing' fields are omitted, so 'defaultISMExplainOptions' produces an +-- empty list. The order of the returned list is stable but /unspecified/ — +-- callers (including tests) should treat it as a set and not pattern-match +-- on the head. The underlying 'withQueries' is order-insensitive. +ismExplainOptionsParams :: ISMExplainOptions -> [(Text, Maybe Text)] +ismExplainOptionsParams ISMExplainOptions {..} = + catMaybes + [ if ismExplainOptionsShowPolicy + then Just ("show_policy", Just "true") + else Nothing, + if ismExplainOptionsValidateAction + then Just ("validate_action", Just "true") + else Nothing, + fmap (\b -> ("local", Just (if b then "true" else "false"))) ismExplainOptionsLocal, + fmap (\xs -> ("expand_wildcards", Just (renderExpandWildcards xs))) ismExplainOptionsExpandWildcards + ] + where + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/IndexTransforms.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/IndexTransforms.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/IndexTransforms.hs @@ -0,0 +1,837 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.IndexTransforms + ( TransformId (..), + TransformPeriodUnit (..), + transformPeriodUnitText, + TransformInterval (..), + TransformSchedule (..), + TransformGroup (..), + TermsGroup (..), + HistogramGroup (..), + DateHistogramGroup (..), + Transform (..), + TransformResponse (..), + TransformRequest (..), + TransformDocumentResponse (..), + TransformSortDirection (..), + transformSortDirectionText, + TransformsListOptions (..), + defaultTransformsListOptions, + transformsListOptionsParams, + GetTransformsResponse (..), + GetTransformsListEntry (..), + TransformExplain (..), + TransformMetadata (..), + TransformStats (..), + TransformContinuousStats (..), + PreviewTransformResponse (..), + ) +where + +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict (Map) +import Data.Vector qualified as V +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The OpenSearch Index Transforms plugin +-- () +-- materialises a target index from aggregations over a source index on a +-- schedule. A 'Transform' binds a 'transformSourceIndex' to a +-- 'transformTargetIndex' via either 'transformGroups' (terms \/ histogram +-- \/ date_histogram buckets) or 'transformAggregations' (sum \/ avg \/ +-- \/ max \/ min \/ value_count \/ scripted_metric \/ percentiles), +-- evaluated under 'transformDataSelectionQuery' (a query DSL filter on +-- the source). The plugin persists the transform under the +-- @.opensearch-ism-config@ system index (transforms are stored alongside +-- ISM policies) and returns the document-write envelope +-- (@_id@, @_version@, @_seq_no@, @_primary_term@) wrapping the +-- 'TransformResponse' under the @transform@ key. +-- +-- We split the request shape ('Transform') from the response shape +-- ('TransformResponse') so the request cannot accidentally carry +-- server-only fields, while the response still round-trips the full +-- server payload. This mirrors the 'ISMPolicyRequest' / +-- 'ISMPolicyResponse' split used for the ISM plugin and the +-- 'Detector' / 'DetectorResponse' split used by Anomaly Detection. +-- +-- The plugin is shipped with OpenSearch 1.0+; it is present (and +-- wire-compatible) on OS1, OS2 and OS3, hence this module is duplicated +-- across all three versions. +-- +-- Doc ambiguities handled here deliberately: +-- +-- * The @schedule.interval.unit@ field is documented with only +-- @"Minutes"@, @"Hours"@, and @"Days"@ in the examples. The plugin +-- source (the underlying job-scheduler) accepts more (e.g. @Seconds@, +-- @Weeks@, @Months@); we type 'TransformPeriodUnit' as a closed enum +-- with a 'TransformPeriodUnitCustom' escape hatch so future additions +-- surface as a parsed value rather than a decode failure. +-- * Only the @interval@ schedule variant is documented on the Transforms +-- page; the job-scheduler plugin also supports @cron@ and other +-- variants. 'TransformSchedule' is a sum type with a +-- 'TransformScheduleOther' escape hatch so unknown schedule variants +-- round-trip losslessly instead of failing decode. +-- * The @groups@ array entries are wrapped under a per-type key +-- (@terms@ \/ @histogram@ \/ @date_histogram@); we model this as a +-- 'TransformGroup' sum type so an entry cannot be constructed with an +-- inconsistent (wrapper, body) pair. The wrapped objects are +-- intentionally light (the documented fields plus an opaque 'Value' +-- catch-all) — future bucket options surface as the catch-all rather +-- than a parse failure. +-- * The @data_selection_query@ and @aggregations@ fields are arbitrary +-- OpenSearch query \/ aggregation DSL bodies, so both are carried as +-- opaque 'Value's (the same approach Anomaly Detection's +-- 'featureAttributeAggregationQuery' takes). +-- * The @_explain@ response is keyed by transform_id at the top level; +-- we decode it as @'Map' 'Text' 'TransformExplain'@. The whole +-- @transform_metadata@ sub-object is 'Maybe' because the plugin omits +-- it on a freshly-created transform that has not yet run. The +-- @continuous_stats@ sub-object only appears on continuous transforms, +-- so it is itself 'Maybe' inside 'TransformMetadata'. +-- * The @delete@ endpoint returns a bulk-response envelope (the +-- transform is stored as a doc in @.opensearch-ism-config@, so DELETE +-- surfaces through the bulk handler). The shared +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Bulk.BulkResponse' +-- matches that envelope byte-for-byte, so the request builder reuses +-- it rather than introducing a per-plugin wrapper. + +-- | Identifies a transform job in the +-- @\/_plugins\/_transform\/{transform_id}@ URL path. Wraps 'Text' so it +-- round-trips through JSON as a bare string but is distinct at the +-- Haskell type level. +-- See +newtype TransformId = TransformId {unTransformId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @schedule.interval.unit@ enum documented at +-- . +-- The Transforms docs enumerate @"Minutes"@, @"Hours"@, and @"Days"@ in +-- the examples; the underlying job-scheduler plugin accepts more values +-- (a 'TransformPeriodUnitCustom' escape hatch preserves them). +data TransformPeriodUnit + = TransformPeriodUnitMinutes + | TransformPeriodUnitHours + | TransformPeriodUnitDays + | TransformPeriodUnitSeconds + | TransformPeriodUnitWeeks + | TransformPeriodUnitMonths + | TransformPeriodUnitCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'TransformPeriodUnit' — the same mapping the +-- 'ToJSON' \/ 'FromJSON' instances use, exposed as plain 'Text' for +-- callers that need the wire string without going through a +-- 'Data.Aeson.Value'. +transformPeriodUnitText :: TransformPeriodUnit -> Text +transformPeriodUnitText = \case + TransformPeriodUnitMinutes -> "Minutes" + TransformPeriodUnitHours -> "Hours" + TransformPeriodUnitDays -> "Days" + TransformPeriodUnitSeconds -> "Seconds" + TransformPeriodUnitWeeks -> "Weeks" + TransformPeriodUnitMonths -> "Months" + TransformPeriodUnitCustom t -> t + +instance ToJSON TransformPeriodUnit where + toJSON = toJSON . transformPeriodUnitText + +instance FromJSON TransformPeriodUnit where + parseJSON = withText "TransformPeriodUnit" $ \case + "Minutes" -> pure TransformPeriodUnitMinutes + "Hours" -> pure TransformPeriodUnitHours + "Days" -> pure TransformPeriodUnitDays + "Seconds" -> pure TransformPeriodUnitSeconds + "Weeks" -> pure TransformPeriodUnitWeeks + "Months" -> pure TransformPeriodUnitMonths + other -> pure (TransformPeriodUnitCustom other) + +-- | The inner @{period, unit, start_time}@ object carried inside a +-- 'TransformSchedule'. @start_time@ is documented as a Unix epoch +-- (seconds); the docs page puts it under @interval.start_time@, which +-- is the only placement the encoder emits. +-- See +data TransformInterval = TransformInterval + { transformIntervalPeriod :: Int, + transformIntervalUnit :: TransformPeriodUnit, + transformIntervalStartTime :: Maybe Integer + } + deriving stock (Eq, Show) + +instance FromJSON TransformInterval where + parseJSON = withObject "TransformInterval" $ \v -> do + transformIntervalPeriod <- v .: "period" + transformIntervalUnit <- v .: "unit" + transformIntervalStartTime <- v .:? "start_time" + pure TransformInterval {..} + +instance ToJSON TransformInterval where + toJSON TransformInterval {..} = + omitNulls + [ "period" .= transformIntervalPeriod, + "unit" .= transformIntervalUnit, + "start_time" .= transformIntervalStartTime + ] + +-- | The @schedule@ object. The Transforms docs only document the +-- @interval@ variant; the underlying job-scheduler plugin also supports +-- @cron@ and others, so unknown schedule shapes parse as +-- 'TransformScheduleOther' and round-trip losslessly. +-- See +data TransformSchedule + = TransformScheduleInterval TransformInterval + | TransformScheduleOther Value + deriving stock (Eq, Show) + +instance FromJSON TransformSchedule where + parseJSON = withObject "TransformSchedule" $ \v -> + case KM.lookup "interval" v of + Just _ -> TransformScheduleInterval <$> v .: "interval" + Nothing -> pure (TransformScheduleOther (Object v)) + +instance ToJSON TransformSchedule where + toJSON = \case + TransformScheduleInterval i -> object ["interval" .= i] + TransformScheduleOther val -> val + +-- | A @terms@ group entry of the @groups@ array. +-- See +data TermsGroup = TermsGroup + { termsGroupSourceField :: Text, + termsGroupTargetField :: Maybe Text, + termsGroupOther :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON TermsGroup where + parseJSON = withObject "TermsGroup" $ \v -> do + termsGroupSourceField <- v .: "source_field" + termsGroupTargetField <- v .:? "target_field" + let deleted = deleteSeveral ["source_field", "target_field"] v + termsGroupOther = + if null deleted + then Nothing + else Just (Object deleted) + pure TermsGroup {..} + +instance ToJSON TermsGroup where + toJSON TermsGroup {..} = + mergeOther + termsGroupOther + [ "source_field" .= termsGroupSourceField, + "target_field" .= termsGroupTargetField + ] + +-- | A @histogram@ group entry of the @groups@ array. +-- See +data HistogramGroup = HistogramGroup + { histogramGroupSourceField :: Text, + histogramGroupTargetField :: Maybe Text, + histogramGroupInterval :: Maybe Scientific, + histogramGroupOther :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON HistogramGroup where + parseJSON = withObject "HistogramGroup" $ \v -> do + histogramGroupSourceField <- v .: "source_field" + histogramGroupTargetField <- v .:? "target_field" + histogramGroupInterval <- v .:? "interval" + let deleted = deleteSeveral ["source_field", "target_field", "interval"] v + histogramGroupOther = + if null deleted + then Nothing + else Just (Object deleted) + pure HistogramGroup {..} + +instance ToJSON HistogramGroup where + toJSON HistogramGroup {..} = + mergeOther + histogramGroupOther + [ "source_field" .= histogramGroupSourceField, + "target_field" .= histogramGroupTargetField, + "interval" .= histogramGroupInterval + ] + +-- | A @date_histogram@ group entry of the @groups@ array. +-- See +data DateHistogramGroup = DateHistogramGroup + { dateHistogramGroupSourceField :: Text, + dateHistogramGroupTargetField :: Maybe Text, + dateHistogramGroupInterval :: Maybe Text, + dateHistogramGroupFormat :: Maybe Text, + dateHistogramGroupTimeZone :: Maybe Text, + dateHistogramGroupOther :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON DateHistogramGroup where + parseJSON = withObject "DateHistogramGroup" $ \v -> do + dateHistogramGroupSourceField <- v .: "source_field" + dateHistogramGroupTargetField <- v .:? "target_field" + dateHistogramGroupInterval <- v .:? "interval" + dateHistogramGroupFormat <- v .:? "format" + dateHistogramGroupTimeZone <- v .:? "time_zone" + let deleted = + deleteSeveral + ["source_field", "target_field", "interval", "format", "time_zone"] + v + dateHistogramGroupOther = + if null deleted + then Nothing + else Just (Object deleted) + pure DateHistogramGroup {..} + +instance ToJSON DateHistogramGroup where + toJSON DateHistogramGroup {..} = + mergeOther + dateHistogramGroupOther + [ "source_field" .= dateHistogramGroupSourceField, + "target_field" .= dateHistogramGroupTargetField, + "interval" .= dateHistogramGroupInterval, + "format" .= dateHistogramGroupFormat, + "time_zone" .= dateHistogramGroupTimeZone + ] + +-- | One entry of the @groups@ array. The docs enumerate three wrapped +-- shapes — @{"terms": {...}}@, @{"histogram": {...}}@, +-- @{"date_histogram": {...}}@ — so the Haskell surface models this as +-- a sum type whose constructor determines the wrapper key. An unknown +-- future variant parses as 'TransformGroupOther' and round-trips +-- losslessly. +-- See +data TransformGroup + = TransformGroupTerms TermsGroup + | TransformGroupHistogram HistogramGroup + | TransformGroupDateHistogram DateHistogramGroup + | TransformGroupOther Value + deriving stock (Eq, Show) + +instance FromJSON TransformGroup where + parseJSON = withObject "TransformGroup" $ \v -> + case (KM.lookup "terms" v, KM.lookup "histogram" v, KM.lookup "date_histogram" v) of + (Just termsVal, Nothing, Nothing) -> + TransformGroupTerms <$> parseJSON termsVal + (Nothing, Just histogramVal, Nothing) -> + TransformGroupHistogram <$> parseJSON histogramVal + (Nothing, Nothing, Just dhVal) -> + TransformGroupDateHistogram <$> parseJSON dhVal + _ -> pure (TransformGroupOther (Object v)) + +instance ToJSON TransformGroup where + toJSON = \case + TransformGroupTerms g -> object ["terms" .= g] + TransformGroupHistogram g -> object ["histogram" .= g] + TransformGroupDateHistogram g -> object ["date_histogram" .= g] + TransformGroupOther val -> val + +-- $transformSchema +-- +-- The 'Transform' request body carries the user-supplied fields the +-- server needs to create or update a transform job. Server-only fields +-- (@schema_version@, @updated_at@, @enabled_at@, @roles@, +-- @transform_id@) are deliberately absent — including them would invite +-- callers to send values the server ignores or rejects. They appear on +-- the 'TransformResponse' round-trip shape. + +-- | The request body for @PUT /_plugins/_transform/{transform_id}@. +-- Required fields: @source_index@, @target_index@, +-- @data_selection_query@, @page_size@, and exactly one of @groups@ or +-- @aggregations@. Everything else is optional and omitted on the wire +-- when 'Nothing'. +-- See +data Transform = Transform + { transformEnabled :: Maybe Bool, + transformContinuous :: Maybe Bool, + transformSchedule :: TransformSchedule, + transformDescription :: Maybe Text, + transformMetadataId :: Maybe Text, + transformSourceIndex :: Text, + transformTargetIndex :: Text, + transformDataSelectionQuery :: Value, + transformPageSize :: Int, + transformGroups :: Maybe [TransformGroup], + transformAggregations :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON Transform where + parseJSON = withObject "Transform" $ \v -> do + transformEnabled <- v .:? "enabled" + transformContinuous <- v .:? "continuous" + transformSchedule <- v .: "schedule" + transformDescription <- v .:? "description" + transformMetadataId <- v .:? "metadata_id" + transformSourceIndex <- v .: "source_index" + transformTargetIndex <- v .: "target_index" + transformDataSelectionQuery <- v .: "data_selection_query" + transformPageSize <- v .: "page_size" + transformGroups <- v .:? "groups" + transformAggregations <- v .:? "aggregations" + pure Transform {..} + +instance ToJSON Transform where + toJSON Transform {..} = + omitNulls + [ "enabled" .= transformEnabled, + "continuous" .= transformContinuous, + "schedule" .= transformSchedule, + "description" .= transformDescription, + "metadata_id" .= transformMetadataId, + "source_index" .= transformSourceIndex, + "target_index" .= transformTargetIndex, + "data_selection_query" .= transformDataSelectionQuery, + "page_size" .= transformPageSize, + "groups" .= transformGroups, + "aggregations" .= transformAggregations + ] + +-- | The persisted transform shape returned in responses (the inner +-- @transform@ object of a 'TransformDocumentResponse'). Carries the +-- full 'Transform' body alongside server-injected bookkeeping fields. +-- The round-trip preserves everything the server sent, so a Get → +-- Update cycle does not lose data the caller never set. +-- See +data TransformResponse = TransformResponse + { transformResponseTransformId :: Maybe Text, + transformResponseSchemaVersion :: Maybe Int, + transformResponseContinuous :: Maybe Bool, + transformResponseSchedule :: TransformSchedule, + transformResponseMetadataId :: Maybe Text, + transformResponseUpdatedAt :: Maybe Integer, + transformResponseEnabled :: Maybe Bool, + transformResponseEnabledAt :: Maybe Integer, + transformResponseDescription :: Maybe Text, + transformResponseSourceIndex :: Text, + transformResponseDataSelectionQuery :: Value, + transformResponseTargetIndex :: Text, + transformResponseRoles :: Maybe [Text], + transformResponsePageSize :: Int, + transformResponseGroups :: Maybe [TransformGroup], + transformResponseAggregations :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON TransformResponse where + parseJSON = withObject "TransformResponse" $ \v -> do + transformResponseTransformId <- v .:? "transform_id" + transformResponseSchemaVersion <- v .:? "schema_version" + transformResponseContinuous <- v .:? "continuous" + transformResponseSchedule <- v .: "schedule" + transformResponseMetadataId <- v .:? "metadata_id" + transformResponseUpdatedAt <- v .:? "updated_at" + transformResponseEnabled <- v .:? "enabled" + transformResponseEnabledAt <- v .:? "enabled_at" + transformResponseDescription <- v .:? "description" + transformResponseSourceIndex <- v .: "source_index" + transformResponseDataSelectionQuery <- v .: "data_selection_query" + transformResponseTargetIndex <- v .: "target_index" + transformResponseRoles <- v .:? "roles" + transformResponsePageSize <- v .: "page_size" + transformResponseGroups <- v .:? "groups" + transformResponseAggregations <- v .:? "aggregations" + pure TransformResponse {..} + +instance ToJSON TransformResponse where + toJSON TransformResponse {..} = + -- We use 'object' (not 'omitNulls') here because @roles@ is + -- documented as a server-injected @[]@ (empty array) and must + -- round-trip as @[]@ — but 'omitNulls' drops empty arrays. + -- 'Nothing' fields serialise as JSON @null@, which round-trips + -- through 'FromJSON' cleanly. + object + [ "transform_id" .= transformResponseTransformId, + "schema_version" .= transformResponseSchemaVersion, + "continuous" .= transformResponseContinuous, + "schedule" .= transformResponseSchedule, + "metadata_id" .= transformResponseMetadataId, + "updated_at" .= transformResponseUpdatedAt, + "enabled" .= transformResponseEnabled, + "enabled_at" .= transformResponseEnabledAt, + "description" .= transformResponseDescription, + "source_index" .= transformResponseSourceIndex, + "data_selection_query" .= transformResponseDataSelectionQuery, + "target_index" .= transformResponseTargetIndex, + "roles" .= transformResponseRoles, + "page_size" .= transformResponsePageSize, + "groups" .= transformResponseGroups, + "aggregations" .= transformResponseAggregations + ] + +-- | Request-body wrapper for @PUT /_plugins/_transform/{transform_id}@ +-- (Create \/ Update) and @POST /_plugins/_transform/_preview@. The +-- server requires the 'Transform' to be nested under the top-level +-- @transform@ key, so this newtype encodes \/ decodes that envelope +-- rather than asking the caller to remember the wrapper at every +-- call site. +-- See +newtype TransformRequest = TransformRequest {transformRequestTransform :: Transform} + deriving stock (Eq, Show) + +instance FromJSON TransformRequest where + parseJSON = withObject "TransformRequest" $ \v -> + TransformRequest <$> v .: "transform" + +instance ToJSON TransformRequest where + toJSON TransformRequest {..} = + object ["transform" .= transformRequestTransform] + +-- | Response body of @PUT /_plugins/_transform/{transform_id}@ +-- (Create \/ Update) and @GET /_plugins/_transform/{transform_id}@ +-- (Get). The server wraps the persisted 'TransformResponse' in a +-- document-write envelope (@_id@, @_version@, @_seq_no@, +-- @_primary_term@) — the same shape OpenSearch uses for any persisted +-- document, and the same shape Anomaly Detection's +-- 'CreateDetectorResponse' uses. +-- See +data TransformDocumentResponse = TransformDocumentResponse + { transformDocumentResponseId :: Text, + transformDocumentResponseVersion :: Int, + transformDocumentResponseSeqNo :: Int, + transformDocumentResponsePrimaryTerm :: Int, + transformDocumentResponseTransform :: TransformResponse + } + deriving stock (Eq, Show) + +instance FromJSON TransformDocumentResponse where + parseJSON = withObject "TransformDocumentResponse" $ \v -> do + transformDocumentResponseId <- v .: "_id" + transformDocumentResponseVersion <- v .: "_version" + transformDocumentResponseSeqNo <- v .: "_seq_no" + transformDocumentResponsePrimaryTerm <- v .: "_primary_term" + transformDocumentResponseTransform <- v .: "transform" + pure TransformDocumentResponse {..} + +instance ToJSON TransformDocumentResponse where + toJSON TransformDocumentResponse {..} = + object + [ "_id" .= transformDocumentResponseId, + "_version" .= transformDocumentResponseVersion, + "_seq_no" .= transformDocumentResponseSeqNo, + "_primary_term" .= transformDocumentResponsePrimaryTerm, + "transform" .= transformDocumentResponseTransform + ] + +-- ========================================================================= +-- List query options: GET /_plugins/_transform +-- ========================================================================= + +-- | Sort direction for the list endpoint +-- (@GET /_plugins/_transform\/@). The plugin docs only document +-- @"ASC"@ and @"DESC"@ (uppercase, unlike most OpenSearch APIs which +-- use lowercase). Unknown values parse as +-- 'TransformSortDirectionCustom' so a future plugin release surfaces +-- as a parsed value rather than a decode failure. +-- See +data TransformSortDirection + = TransformSortDirectionAsc + | TransformSortDirectionDesc + | TransformSortDirectionCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'TransformSortDirection'. +transformSortDirectionText :: TransformSortDirection -> Text +transformSortDirectionText = \case + TransformSortDirectionAsc -> "ASC" + TransformSortDirectionDesc -> "DESC" + TransformSortDirectionCustom t -> t + +instance ToJSON TransformSortDirection where + toJSON = toJSON . transformSortDirectionText + +instance FromJSON TransformSortDirection where + parseJSON = withText "TransformSortDirection" $ \case + "ASC" -> pure TransformSortDirectionAsc + "DESC" -> pure TransformSortDirectionDesc + other -> pure (TransformSortDirectionCustom other) + +-- | Query-string parameters accepted by @GET /_plugins/_transform\/@ +-- (list all transforms). Every field is optional; +-- 'defaultTransformsListOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. +-- See +data TransformsListOptions = TransformsListOptions + { transformsListOptionsFrom :: Maybe Int, + transformsListOptionsSize :: Maybe Int, + transformsListOptionsSearch :: Maybe Text, + transformsListOptionsSortField :: Maybe Text, + transformsListOptionsSortDirection :: Maybe TransformSortDirection + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the +-- plain @GET /_plugins/_transform\/@ when passed to 'getTransforms'. +defaultTransformsListOptions :: TransformsListOptions +defaultTransformsListOptions = + TransformsListOptions + { transformsListOptionsFrom = Nothing, + transformsListOptionsSize = Nothing, + transformsListOptionsSearch = Nothing, + transformsListOptionsSortField = Nothing, + transformsListOptionsSortDirection = Nothing + } + +-- | Render a 'TransformsListOptions' to the query-string pairs accepted +-- by the list endpoint. Fields set to 'Nothing' are omitted (not +-- rendered with an empty value). +transformsListOptionsParams :: TransformsListOptions -> [(Text, Maybe Text)] +transformsListOptionsParams TransformsListOptions {..} = + catMaybes + [ ("from",) . Just . tshow <$> transformsListOptionsFrom, + ("size",) . Just . tshow <$> transformsListOptionsSize, + ("search",) . Just <$> transformsListOptionsSearch, + ("sortField",) . Just <$> transformsListOptionsSortField, + ("sortDirection",) . Just . transformSortDirectionText <$> transformsListOptionsSortDirection + ] + +-- ========================================================================= +-- List response: GET /_plugins/_transform +-- ========================================================================= + +-- | One entry in the @transforms@ array returned by +-- @GET /_plugins/_transform\/@. Structurally a subset of +-- 'TransformDocumentResponse': the same @transform@ payload under the +-- same document-write envelope, but the docs samples omit @_version@ on +-- list entries (the field is therefore 'Maybe' here). +-- See +data GetTransformsListEntry = GetTransformsListEntry + { getTransformsListEntryId :: Text, + getTransformsListEntryVersion :: Maybe Int, + getTransformsListEntrySeqNo :: Maybe Int, + getTransformsListEntryPrimaryTerm :: Maybe Int, + getTransformsListEntryTransform :: TransformResponse + } + deriving stock (Eq, Show) + +instance FromJSON GetTransformsListEntry where + parseJSON = withObject "GetTransformsListEntry" $ \v -> do + getTransformsListEntryId <- v .: "_id" + getTransformsListEntryVersion <- v .:? "_version" + getTransformsListEntrySeqNo <- v .:? "_seq_no" + getTransformsListEntryPrimaryTerm <- v .:? "_primary_term" + getTransformsListEntryTransform <- v .: "transform" + pure GetTransformsListEntry {..} + +instance ToJSON GetTransformsListEntry where + toJSON GetTransformsListEntry {..} = + omitNulls + [ "_id" .= getTransformsListEntryId, + "_version" .= getTransformsListEntryVersion, + "_seq_no" .= getTransformsListEntrySeqNo, + "_primary_term" .= getTransformsListEntryPrimaryTerm, + "transform" .= getTransformsListEntryTransform + ] + +-- | Envelope returned by @GET /_plugins/_transform\/@. The plugin +-- returns @total_transforms@ (the count of all transforms the caller +-- can see, independent of pagination) alongside the per-page +-- @transforms@ array — distinct from the standard search @hits@ +-- envelope. +-- See +data GetTransformsResponse = GetTransformsResponse + { getTransformsResponseTotalTransforms :: Int, + getTransformsResponseTransforms :: [GetTransformsListEntry] + } + deriving stock (Eq, Show) + +instance FromJSON GetTransformsResponse where + parseJSON = withObject "GetTransformsResponse" $ \v -> do + getTransformsResponseTotalTransforms <- v .: "total_transforms" + getTransformsResponseTransforms <- v .:? "transforms" .!= [] + pure GetTransformsResponse {..} + +instance ToJSON GetTransformsResponse where + toJSON GetTransformsResponse {..} = + object + [ "total_transforms" .= getTransformsResponseTotalTransforms, + "transforms" .= getTransformsResponseTransforms + ] + +-- ========================================================================= +-- Explain response: GET /_plugins/_transform/{id}/_explain +-- ========================================================================= + +-- | Per-transform statistics returned inside 'TransformMetadata'. +-- All fields are integers (counts or durations in milliseconds). +-- See +data TransformStats = TransformStats + { transformStatsPagesProcessed :: Maybe Int, + transformStatsDocumentsProcessed :: Maybe Int, + transformStatsDocumentsIndexed :: Maybe Int, + transformStatsIndexTimeInMillis :: Maybe Int, + transformStatsSearchTimeInMillis :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON TransformStats where + parseJSON = withObject "TransformStats" $ \v -> do + transformStatsPagesProcessed <- v .:? "pages_processed" + transformStatsDocumentsProcessed <- v .:? "documents_processed" + transformStatsDocumentsIndexed <- v .:? "documents_indexed" + transformStatsIndexTimeInMillis <- v .:? "index_time_in_millis" + transformStatsSearchTimeInMillis <- v .:? "search_time_in_millis" + pure TransformStats {..} + +instance ToJSON TransformStats where + toJSON TransformStats {..} = + omitNulls + [ "pages_processed" .= transformStatsPagesProcessed, + "documents_processed" .= transformStatsDocumentsProcessed, + "documents_indexed" .= transformStatsDocumentsIndexed, + "index_time_in_millis" .= transformStatsIndexTimeInMillis, + "search_time_in_millis" .= transformStatsSearchTimeInMillis + ] + +-- | Continuous-transform runtime state, only present on transforms +-- where 'transformContinuous' is 'True'. @last_timestamp@ is the +-- epoch-ms of the most recently processed source document; +-- @documents_behind@ maps source index names to the count of source +-- documents not yet reflected in the target. +-- See +data TransformContinuousStats = TransformContinuousStats + { transformContinuousStatsLastTimestamp :: Maybe Integer, + transformContinuousStatsDocumentsBehind :: Maybe (Map Text Int) + } + deriving stock (Eq, Show) + +instance FromJSON TransformContinuousStats where + parseJSON = withObject "TransformContinuousStats" $ \v -> do + transformContinuousStatsLastTimestamp <- v .:? "last_timestamp" + transformContinuousStatsDocumentsBehind <- v .:? "documents_behind" + pure TransformContinuousStats {..} + +instance ToJSON TransformContinuousStats where + toJSON TransformContinuousStats {..} = + omitNulls + [ "last_timestamp" .= transformContinuousStatsLastTimestamp, + "documents_behind" .= transformContinuousStatsDocumentsBehind + ] + +-- | The @transform_metadata@ sub-object of an 'TransformExplain'. +-- @status@ is a free-form 'Text' (the docs example shows @"finished"@; +-- other states like @"failed"@, @"started"@ surface without a parse +-- failure). @failure_reason@ is @null@ on success — the docs literally +-- show the JSON string @"null"@, so we keep it as 'Maybe' 'Text' and +-- rely on aeson to decode a real @null@ as 'Nothing'. +-- See +data TransformMetadata = TransformMetadata + { transformMetadataContinuousStats :: Maybe TransformContinuousStats, + transformMetadataTransformId :: Maybe Text, + transformMetadataLastUpdatedAt :: Maybe Integer, + transformMetadataStatus :: Maybe Text, + transformMetadataFailureReason :: Maybe Text, + transformMetadataStats :: Maybe TransformStats + } + deriving stock (Eq, Show) + +instance FromJSON TransformMetadata where + parseJSON = withObject "TransformMetadata" $ \v -> do + transformMetadataContinuousStats <- v .:? "continuous_stats" + transformMetadataTransformId <- v .:? "transform_id" + transformMetadataLastUpdatedAt <- v .:? "last_updated_at" + transformMetadataStatus <- v .:? "status" + transformMetadataFailureReason <- v .:? "failure_reason" + transformMetadataStats <- v .:? "stats" + pure TransformMetadata {..} + +instance ToJSON TransformMetadata where + toJSON TransformMetadata {..} = + omitNulls + [ "continuous_stats" .= transformMetadataContinuousStats, + "transform_id" .= transformMetadataTransformId, + "last_updated_at" .= transformMetadataLastUpdatedAt, + "status" .= transformMetadataStatus, + "failure_reason" .= transformMetadataFailureReason, + "stats" .= transformMetadataStats + ] + +-- | One value of the @_explain@ response. The plugin returns a top-level +-- object keyed by transform_id whose value combines the @metadata_id@ of +-- the transform's metadata document with the @transform_metadata@ +-- sub-object. The metadata sub-object is 'Maybe' because the plugin +-- omits it on a freshly-created transform that has not yet run. +-- See +data TransformExplain = TransformExplain + { transformExplainMetadataId :: Maybe Text, + transformExplainTransformMetadata :: Maybe TransformMetadata + } + deriving stock (Eq, Show) + +instance FromJSON TransformExplain where + parseJSON = withObject "TransformExplain" $ \v -> do + transformExplainMetadataId <- v .:? "metadata_id" + transformExplainTransformMetadata <- v .:? "transform_metadata" + pure TransformExplain {..} + +instance ToJSON TransformExplain where + toJSON TransformExplain {..} = + omitNulls + [ "metadata_id" .= transformExplainMetadataId, + "transform_metadata" .= transformExplainTransformMetadata + ] + +-- ========================================================================= +-- Preview: POST /_plugins/_transform/_preview +-- ========================================================================= + +-- | Response body of @POST /_plugins/_transform/_preview@. Each entry +-- of @documents@ is a transformed row whose keys are derived from the +-- caller's @groups[].target_field@ names plus @aggregations@ keys. The +-- shape is wholly caller-driven, so the entries are carried as opaque +-- 'Value's. +-- See +newtype PreviewTransformResponse = PreviewTransformResponse + { previewTransformResponseDocuments :: [Value] + } + deriving stock (Eq, Show) + +instance FromJSON PreviewTransformResponse where + parseJSON = withObject "PreviewTransformResponse" $ \v -> do + previewTransformResponseDocuments <- v .:? "documents" .!= [] + pure PreviewTransformResponse {..} + +instance ToJSON PreviewTransformResponse where + toJSON PreviewTransformResponse {..} = + object ["documents" .= previewTransformResponseDocuments] + +-- ========================================================================= +-- Helpers +-- ========================================================================= + +-- | Render the known @(Key, Value)@ pairs of a group entry (omitting +-- 'Nothing' fields), then merge any surviving keys from the +-- per-group 'other' catch-all back in so an unknown forward-compat +-- field round-trips at its original key rather than under a +-- synthesised @other@ wrapper. Known fields take precedence over the +-- catch-all on key collision (a caller hand-building both sides +-- should not be able to end up with two values for one wire key). +-- 'Nothing' known fields are filtered out before the merge so they +-- don't leak as explicit @null@s alongside the catch-all payload +-- (mirroring 'omitNulls' semantics). +mergeOther :: Maybe Value -> [(Key, Value)] -> Value +mergeOther mOther knownPairs = + case mOther of + Nothing -> omitNulls knownPairs + Just (Object otherKm) -> + let knownKm = KM.fromList (filter (not . isNullValue . snd) knownPairs) + in Object (KM.union knownKm otherKm) + Just _otherVal -> + -- An 'other' catch-all that is not an Object is unusual (the + -- decoder only ever produces @Object v@). Emit the known fields + -- (with nulls dropped) and drop the exotic 'other' value + -- rather than guessing how to merge them. + omitNulls knownPairs + +-- | Predicate matching 'omitNulls''s @notNull@: 'Null' and the empty +-- array are filtered; everything else survives. +isNullValue :: Value -> Bool +isNullValue Null = True +isNullValue (Array a) = V.null a +isNullValue _ = False diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/KnnModel.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/KnnModel.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/KnnModel.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.KnnModel + ( KnnModelState (..), + KnnModel (..), + KnnDeleteModelResponse (..), + ) +where + +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Knn (OpenSearchKnnEngine) + +-- $schema +-- +-- The k-NN plugin Get Model API +-- (, +-- @GET /_plugins/_knn/models/{model_id}@) returns a bare object describing a +-- trained model. Some native library index configurations (notably FAISS IVF +-- and HNSW with PQ) require a training step before indexing can begin; the +-- output of training is serialized into the @.opensearch-knn-models@ system +-- index and read back by this endpoint. The model endpoints were introduced +-- in OpenSearch 1.2. +-- +-- Every field except @model_id@ is modelled as 'Maybe' for two reasons. First, +-- the @model_blob@ field is deliberately large (a base64 serialization of the +-- trained graph) and is routinely excluded with @?filter_path@ or +-- @_source_excludes=model_blob@, so a strict parse would reject the common +-- metadata-only read. Second, the same @filter_path@ mechanism lets a caller +-- request any subset of fields, so the parser must tolerate arbitrary +-- omissions (same defensive shape as 'ModelInfo'). +-- +-- The @engine@ field reuses the shared 'OpenSearchKnnEngine' type (also used +-- by index mappings and the search clause), so the wire vocabulary +-- (@faiss@, @nmslib@, @lucene@) is defined in one place. + +-- | The lifecycle state of a k-NN model, as reported by the @state@ field of +-- 'KnnModel'. The k-NN plugin documents exactly three values; an unknown +-- value parse-fails so a future plugin release surfaces as a deliberate +-- error rather than a silent drop. +data KnnModelState + = KnnModelStateCreated + | KnnModelStateFailed + | KnnModelStateTraining + deriving stock (Eq, Show) + +instance ToJSON KnnModelState where + toJSON = \case + KnnModelStateCreated -> "created" + KnnModelStateFailed -> "failed" + KnnModelStateTraining -> "training" + +instance FromJSON KnnModelState where + parseJSON = withText "KnnModelState" $ \case + "created" -> pure KnnModelStateCreated + "failed" -> pure KnnModelStateFailed + "training" -> pure KnnModelStateTraining + other -> fail ("Unknown KnnModelState: " <> T.unpack other) + +-- | Response of @GET /_plugins/_knn/models/{model_id}@. The body is a bare +-- object (no envelope); the server returns every metadata field it has. See +-- the module docs for why every field except @model_id@ is 'Maybe'. +-- +-- The @timestamp@ is the server-formatted creation time (e.g. +-- @2021-11-15T18:45:07.505369036Z@); it is kept as 'Text' rather than parsed +-- to a time type so the client does not couple to the plugin's sub-second +-- precision. +data KnnModel = KnnModel + { knnModelModelId :: Text, + knnModelModelBlob :: Maybe Text, + knnModelState :: Maybe KnnModelState, + knnModelTimestamp :: Maybe Text, + knnModelDescription :: Maybe Text, + knnModelError :: Maybe Text, + knnModelSpaceType :: Maybe Text, + knnModelDimension :: Maybe Int, + knnModelEngine :: Maybe OpenSearchKnnEngine + } + deriving stock (Eq, Show) + +instance FromJSON KnnModel where + parseJSON = withObject "KnnModel" $ \v -> do + knnModelModelId <- v .: "model_id" + knnModelModelBlob <- v .:? "model_blob" + knnModelState <- v .:? "state" + knnModelTimestamp <- v .:? "timestamp" + knnModelDescription <- v .:? "description" + knnModelError <- v .:? "error" + knnModelSpaceType <- v .:? "space_type" + knnModelDimension <- v .:? "dimension" + knnModelEngine <- v .:? "engine" + pure KnnModel {..} + +instance ToJSON KnnModel where + toJSON KnnModel {..} = + omitNulls + [ "model_id" .= knnModelModelId, + "model_blob" .= knnModelModelBlob, + "state" .= knnModelState, + "timestamp" .= knnModelTimestamp, + "description" .= knnModelDescription, + "error" .= knnModelError, + "space_type" .= knnModelSpaceType, + "dimension" .= knnModelDimension, + "engine" .= knnModelEngine + ] + +-- | Response of @DELETE /_plugins/_knn/models/{model_id}@. Per the k-NN +-- plugin's @DeleteModelResponse@, the body is a bare object with two +-- fields: @model_id@ (echoing the id passed in the path) and @result@ +-- (always @"deleted"@ for a successful delete). Note that this is NOT the +-- standard 'Acknowledged' envelope — the k-NN plugin returns a richer +-- response than the typical cluster-level ack, mirroring the shape of +-- 'KnnTrainResponse' rather than 'Acknowledged'. +-- +-- The @result@ field is kept as 'Text' rather than a closed enum: the +-- plugin only emits @"deleted"@ today, but a future version could add +-- @"not_found"@ or similar, and an enum would force a parse failure in +-- that case. +-- +-- /Note on the public docs:/ the k-NN API docs page +-- () +-- shows the response as @{"model_id": ..., "acknowledged": true}@, which is +-- incorrect. The authoritative shape is the one emitted by the plugin's +-- @DeleteModelResponse@ serializer +-- (), +-- i.e. @model_id@ + @result@. The type below follows the serializer, not the +-- docs. +data KnnDeleteModelResponse = KnnDeleteModelResponse + { knnDeleteModelResponseModelId :: Text, + knnDeleteModelResponseResult :: Text + } + deriving stock (Eq, Show) + +instance FromJSON KnnDeleteModelResponse where + parseJSON = withObject "KnnDeleteModelResponse" $ \v -> do + knnDeleteModelResponseModelId <- v .: "model_id" + knnDeleteModelResponseResult <- v .: "result" + pure KnnDeleteModelResponse {..} + +instance ToJSON KnnDeleteModelResponse where + toJSON KnnDeleteModelResponse {..} = + object + [ "model_id" .= knnDeleteModelResponseModelId, + "result" .= knnDeleteModelResponseResult + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/KnnStats.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/KnnStats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/KnnStats.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.KnnStats + ( KnnNodeId (..), + KnnStatName (..), + KnnStats (..), + ) +where + +import Data.Map.Strict qualified as Map +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- @ +-- { +-- "": , +-- ..., +-- "nodes": { "<22-char-node-id>": { "": , ... } } +-- } +-- @ +-- +-- The @GET /_plugins/_knn/stats@ endpoint +-- () +-- returns both cluster-level statistics (a single value for the entire +-- cluster, e.g. @total_load_time@, @hit_count@, @circuit_breaker_triggered@) +-- and node-level statistics (a single value per node, nested under the +-- literal @nodes@ key keyed by opaque node ID). The same stat name can +-- appear either as a cluster-level top-level key or nested under a +-- per-node entry, and the stat-name set is large and version-gated by the +-- plugin — each stat carries the OpenSearch version that introduced it. +-- Modelling every stat as a typed Haskell record field would lock the +-- client to one plugin version and require churn on every release, so the +-- body is kept as a flat 'Map.Map Text Value' — callers get a typed +-- envelope and navigate to the per-node map (via @'Map.lookup' \"nodes\"@) +-- or to any individual cluster stat with the aeson combinators they +-- already use elsewhere (same shape as +-- 'Database.Bloodhound.OpenSearch1.Types.MLStats'). + +-- | A node ID for the k-NN plugin's +-- @\/_plugins\/_knn\/{nodeId}\/stats@ path segment. OpenSearch uses +-- 22-character opaque node IDs (the same identifiers returned by +-- @GET \/_nodes@); we wrap 'Text' so the value round-trips through JSON as a +-- bare string but is distinct from 'NodeName' \/ 'FullNodeId' \/ 'NeuralNodeId' +-- at the type level. +newtype KnnNodeId = KnnNodeId {unKnnNodeId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A stat name filter for the +-- @\/_plugins\/_knn\/stats\/{stat}@ path segment. Each value matches one of +-- the plugin's documented @StatName@ constants (@hit_count@, @miss_count@, +-- @knn_query_cache_size@, ...); the full set changes across OpenSearch +-- releases, so this is intentionally a thin 'Text' newtype rather than a +-- closed enum. +newtype KnnStatName = KnnStatName {unKnnStatName :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Response of @GET /_plugins/_knn/stats@. The body is a JSON object whose +-- top-level keys are either cluster-level stat names (mapping to scalars) or +-- the literal key @nodes@ (mapping to a per-node map keyed by opaque node +-- ID); see the module docs for why the entries are kept as aeson 'Value's +-- rather than modelled per-stat. The 'Map.Map' round-trips a flat JSON +-- object via its aeson instances, so no custom 'ToJSON' \/ 'FromJSON' is +-- needed. To reach per-node stats, decode the @nodes@ value, e.g.: +-- +-- @ +-- case 'Map.lookup' \"nodes\" (knnStatsEntries stats) of +-- 'Just' ('Object' m) -> ... navigate m with aeson KeyMap combinators ... +-- _ -> 'Nothing' +-- @ +newtype KnnStats = KnnStats {knnStatsEntries :: Map.Map Text Value} + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/KnnTrain.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/KnnTrain.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/KnnTrain.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.KnnTrain + ( KnnTrainingMethod (..), + KnnTrainingRequest (..), + KnnTrainResponse (..), + ) +where + +import Data.Aeson +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Knn (OpenSearchKnnEngine) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( FieldName, + IndexName, + ) + +-- $schema +-- +-- The k-NN plugin Train Model API +-- (, +-- @POST /_plugins/_knn/models/{model_id}/_train@, introduced in OpenSearch +-- 1.2) trains a native library model (FAISS IVF, IVF with PQ encoder, ...) +-- from the vectors stored in a @knn_vector@ field of a training index. Only +-- methods that require training are eligible; HNSW/Lucene do not. Training +-- is asynchronous: the request returns as soon as training is scheduled, +-- carrying only the @model_id@; the caller polls +-- 'Database.Bloodhound.OpenSearch1.Client.getKnnModel' to observe the +-- @state@ transition from @training@ to @created@ (success) or @failed@ +-- (with the @error@ field populated). +-- +-- The request body is a flat object with four required fields +-- (@training_index@, @training_field@, @dimension@, @method@) and four +-- optional fields (@space_type@, @max_training_vector_count@, @search_size@, +-- @description@). The @method@ sub-object reuses the standard k-NN method +-- schema (@name@, @engine@, @space_type@, @parameters@); its @parameters@ +-- are deeply nested and engine-specific (e.g. @nlist@, an @encoder@ with +-- its own @parameters@), so they are kept as an opaque aeson 'Value' on the +-- Haskell side — the same passthrough strategy used for +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Knn.KnnInnerHits'. + +-- | The @method@ sub-object of 'KnnTrainingRequest'. Names the training +-- algorithm and its native engine; @parameters@ carries the deeply nested +-- engine-specific knobs (e.g. @{"nlist": 128, "encoder": {...}}@) and is +-- therefore kept as an opaque 'Value'. The @space_type@ may be set here or +-- at the top level of 'KnnTrainingRequest'; the two are alternative +-- locations for the same field. +data KnnTrainingMethod = KnnTrainingMethod + { knnTrainingMethodName :: Text, + knnTrainingMethodEngine :: OpenSearchKnnEngine, + knnTrainingMethodSpaceType :: Maybe Text, + knnTrainingMethodParameters :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON KnnTrainingMethod where + parseJSON = withObject "KnnTrainingMethod" $ \v -> do + knnTrainingMethodName <- v .: "name" + knnTrainingMethodEngine <- v .: "engine" + knnTrainingMethodSpaceType <- v .:? "space_type" + knnTrainingMethodParameters <- v .:? "parameters" + pure KnnTrainingMethod {..} + +instance ToJSON KnnTrainingMethod where + toJSON KnnTrainingMethod {..} = + omitNulls + [ "name" .= knnTrainingMethodName, + "engine" .= knnTrainingMethodEngine, + "space_type" .= knnTrainingMethodSpaceType, + "parameters" .= knnTrainingMethodParameters + ] + +-- | Request body for @POST /_plugins/_knn/models/{model_id}/_train@. The +-- first four fields are required by the plugin and serialized unconditionally; +-- the remaining four are 'Maybe' and omitted by 'omitNulls' when 'Nothing'. +data KnnTrainingRequest = KnnTrainingRequest + { knnTrainingRequestIndex :: IndexName, + knnTrainingRequestField :: FieldName, + knnTrainingRequestDimension :: Int, + knnTrainingRequestMethod :: KnnTrainingMethod, + knnTrainingRequestSpaceType :: Maybe Text, + knnTrainingRequestMaxTrainingVectorCount :: Maybe Int, + knnTrainingRequestSearchSize :: Maybe Int, + knnTrainingRequestDescription :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON KnnTrainingRequest where + parseJSON = withObject "KnnTrainingRequest" $ \v -> do + knnTrainingRequestIndex <- v .: "training_index" + knnTrainingRequestField <- v .: "training_field" + knnTrainingRequestDimension <- v .: "dimension" + knnTrainingRequestMethod <- v .: "method" + knnTrainingRequestSpaceType <- v .:? "space_type" + knnTrainingRequestMaxTrainingVectorCount <- v .:? "max_training_vector_count" + knnTrainingRequestSearchSize <- v .:? "search_size" + knnTrainingRequestDescription <- v .:? "description" + pure KnnTrainingRequest {..} + +instance ToJSON KnnTrainingRequest where + toJSON KnnTrainingRequest {..} = + omitNulls + [ "training_index" .= knnTrainingRequestIndex, + "training_field" .= knnTrainingRequestField, + "dimension" .= knnTrainingRequestDimension, + "method" .= knnTrainingRequestMethod, + "space_type" .= knnTrainingRequestSpaceType, + "max_training_vector_count" .= knnTrainingRequestMaxTrainingVectorCount, + "search_size" .= knnTrainingRequestSearchSize, + "description" .= knnTrainingRequestDescription + ] + +-- | Response of @POST /_plugins/_knn/models/{model_id}/_train@. The body is +-- a bare object echoing the model id under which training was scheduled. +-- The field is the only one the endpoint ever returns; to observe training +-- progress, poll @GET /_plugins/_knn/models/{model_id}@ (decoded as +-- 'Database.Bloodhound.Internal.Versions.OpenSearch1.Types.KnnModel.KnnModel'). +newtype KnnTrainResponse = KnnTrainResponse + { knnTrainResponseModelId :: Text + } + deriving stock (Eq, Show) + +instance FromJSON KnnTrainResponse where + parseJSON = withObject "KnnTrainResponse" $ \v -> + KnnTrainResponse <$> v .: "model_id" + +instance ToJSON KnnTrainResponse where + toJSON KnnTrainResponse {..} = + object ["model_id" .= knnTrainResponseModelId] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/MLModel.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/MLModel.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/MLModel.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.MLModel + ( ModelId (..), + AlgorithmName (..), + ModelFormat (..), + ModelState (..), + ModelConfig (..), + ModelInfo (..), + ModelSearchResponse (..), + ModelShards (..), + ModelTotal (..), + ModelTotalRelation (..), + ModelHit (..), + ) +where + +import Data.Int (Int64) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The ML Commons model APIs that OpenSearch 1.3 actually ships (see +-- ) +-- are the read/invoke surface: get (read metadata), search/list +-- (discover models), and predict (invoke a deployed model). The +-- register/deploy/undeploy/update lifecycle endpoints were added in +-- OpenSearch 2.3+ and are intentionally not modelled here -- they are +-- carried by the OpenSearch2 and OpenSearch3 modules. +-- +-- The predict request body and response are model-specific (the same +-- endpoint serves classical algorithms like kmeans and remote connectors +-- whose @parameters@ and @inference_results@ have no fixed schema), so +-- 'predict' is typed at the boundary as an opaque 'Value' and callers +-- decode the payload with their own model-specific parser. + +-- | A model ID for the @\/_plugins\/_ml\/models\/{model_id}@ path segment +-- and the @model_id@ field returned by get/search. The value is +-- assigned by the server. Wrapped 'Text' so it round-trips as a bare JSON +-- string but is distinct from 'PolicyId' \/ 'IndexName' at the type level. +newtype ModelId = ModelId {unModelId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | An algorithm name for the +-- @\/_plugins\/_ml\/_predict\/{algorithm_name}\/{model_id}@ path segment +-- of the predict endpoint. Values are plugin-defined @FunctionName@ +-- constants (e.g. @kmeans@, @text_embedding@, @remote@); the set changes +-- across releases so this is a thin 'Text' newtype. +newtype AlgorithmName = AlgorithmName {unAlgorithmName :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The serialization format of a model's content. Used by the +-- @model_format@ field of 'ModelInfo'. OpenSearch currently documents +-- two values; unknown values parse-fail so a future plugin release +-- adding a third surfaces as a deliberate error rather than a silent +-- drop. +data ModelFormat + = ModelFormatTorchScript + | ModelFormatOnnx + deriving stock (Eq, Show) + +instance ToJSON ModelFormat where + toJSON = \case + ModelFormatTorchScript -> "TORCH_SCRIPT" + ModelFormatOnnx -> "ONNX" + +instance FromJSON ModelFormat where + parseJSON = withText "ModelFormat" $ \case + "TORCH_SCRIPT" -> pure ModelFormatTorchScript + "ONNX" -> pure ModelFormatOnnx + other -> fail ("Unknown ModelFormat: " <> T.unpack other) + +-- | The lifecycle state of a model, as reported by the @model_state@ field +-- of 'ModelInfo'. The full set is documented at +-- . +data ModelState + = ModelStateRegistering + | ModelStateRegistered + | ModelStateDeploying + | ModelStateDeployed + | ModelStatePartiallyDeployed + | ModelStateUndeployed + | ModelStateDeployFailed + deriving stock (Eq, Show) + +instance ToJSON ModelState where + toJSON = \case + ModelStateRegistering -> "REGISTERING" + ModelStateRegistered -> "REGISTERED" + ModelStateDeploying -> "DEPLOYING" + ModelStateDeployed -> "DEPLOYED" + ModelStatePartiallyDeployed -> "PARTIALLY_DEPLOYED" + ModelStateUndeployed -> "UNDEPLOYED" + ModelStateDeployFailed -> "DEPLOY_FAILED" + +instance FromJSON ModelState where + parseJSON = withText "ModelState" $ \case + "REGISTERING" -> pure ModelStateRegistering + "REGISTERED" -> pure ModelStateRegistered + "DEPLOYING" -> pure ModelStateDeploying + "DEPLOYED" -> pure ModelStateDeployed + "PARTIALLY_DEPLOYED" -> pure ModelStatePartiallyDeployed + "UNDEPLOYED" -> pure ModelStateUndeployed + "DEPLOY_FAILED" -> pure ModelStateDeployFailed + other -> fail ("Unknown ModelState: " <> T.unpack other) + +-- | The @model_config@ object embedded in 'RegisterModelRequest' and +-- returned inside 'ModelInfo'. @model_type@, @embedding_dimension@, and +-- @framework_type@ are required when present; @all_config@ is a minified +-- JSON string of the upstream model config (e.g. HuggingFace +-- @config.json@); @additional_config@ is an opaque JSON object (notably +-- @space_type@ for k-NN distance metric). +data ModelConfig = ModelConfig + { modelConfigModelType :: Text, + modelConfigEmbeddingDimension :: Int, + modelConfigFrameworkType :: Text, + modelConfigAllConfig :: Maybe Text, + modelConfigAdditionalConfig :: Maybe Value, + modelConfigPoolingMode :: Maybe Text, + modelConfigNormalizeResult :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON ModelConfig where + parseJSON = withObject "ModelConfig" $ \v -> do + modelConfigModelType <- v .: "model_type" + modelConfigEmbeddingDimension <- v .: "embedding_dimension" + modelConfigFrameworkType <- v .: "framework_type" + modelConfigAllConfig <- v .:? "all_config" + modelConfigAdditionalConfig <- v .:? "additional_config" + modelConfigPoolingMode <- v .:? "pooling_mode" + modelConfigNormalizeResult <- v .:? "normalize_result" + pure ModelConfig {..} + +instance ToJSON ModelConfig where + toJSON ModelConfig {..} = + omitNulls + [ "model_type" .= modelConfigModelType, + "embedding_dimension" .= modelConfigEmbeddingDimension, + "framework_type" .= modelConfigFrameworkType, + "all_config" .= modelConfigAllConfig, + "additional_config" .= modelConfigAdditionalConfig, + "pooling_mode" .= modelConfigPoolingMode, + "normalize_result" .= modelConfigNormalizeResult + ] + +-- | Response of @GET /_plugins/_ml/models/{model_id}@. The body is a bare +-- object (no envelope); the server returns every metadata field it has. +-- Most fields beyond @name@, @algorithm@, @version@ are conditionally +-- present depending on the model source (pretrained, custom, or remote +-- connector) and lifecycle state, so they are modelled as 'Maybe'. +-- +-- Note: embedding-specific fields (@model_config@, @model_format@, +-- @model_content_*@) are typically absent for remote-connector models +-- (algorithm @remote@); callers serving remote models should not rely on +-- 'modelInfoModelConfig' being present. +data ModelInfo = ModelInfo + { modelInfoModelId :: Maybe Text, + modelInfoName :: Text, + modelInfoAlgorithm :: Text, + modelInfoVersion :: Text, + modelInfoModelFormat :: Maybe ModelFormat, + modelInfoModelState :: Maybe ModelState, + modelInfoModelContentSizeInBytes :: Maybe Int64, + modelInfoModelContentHashValue :: Maybe Text, + modelInfoModelConfig :: Maybe ModelConfig, + modelInfoIsEnabled :: Maybe Bool, + modelInfoGroupId :: Maybe Text, + modelInfoCreatedTime :: Maybe Int64, + modelInfoLastUploadedTime :: Maybe Int64, + modelInfoLastLoadedTime :: Maybe Int64, + modelInfoTotalChunks :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ModelInfo where + parseJSON = withObject "ModelInfo" $ \v -> do + modelInfoModelId <- v .:? "model_id" + modelInfoName <- v .: "name" + modelInfoAlgorithm <- v .: "algorithm" + mModelVersion <- v .:? "model_version" + modelInfoVersion <- case mModelVersion of + Just ver -> pure ver + Nothing -> v .: "version" + modelInfoModelFormat <- v .:? "model_format" + modelInfoModelState <- v .:? "model_state" + modelInfoModelContentSizeInBytes <- v .:? "model_content_size_in_bytes" + modelInfoModelContentHashValue <- v .:? "model_content_hash_value" + modelInfoModelConfig <- v .:? "model_config" + modelInfoIsEnabled <- v .:? "is_enabled" + modelInfoGroupId <- v .:? "model_group_id" + modelInfoCreatedTime <- v .:? "created_time" + modelInfoLastUploadedTime <- v .:? "last_uploaded_time" + modelInfoLastLoadedTime <- v .:? "last_loaded_time" + modelInfoTotalChunks <- v .:? "total_chunks" + pure ModelInfo {..} + +instance ToJSON ModelInfo where + toJSON ModelInfo {..} = + omitNulls + [ "model_id" .= modelInfoModelId, + "name" .= modelInfoName, + "algorithm" .= modelInfoAlgorithm, + "version" .= modelInfoVersion, + "model_format" .= modelInfoModelFormat, + "model_state" .= modelInfoModelState, + "model_content_size_in_bytes" .= modelInfoModelContentSizeInBytes, + "model_content_hash_value" .= modelInfoModelContentHashValue, + "model_config" .= modelInfoModelConfig, + "is_enabled" .= modelInfoIsEnabled, + "model_group_id" .= modelInfoGroupId, + "created_time" .= modelInfoCreatedTime, + "last_uploaded_time" .= modelInfoLastUploadedTime, + "last_loaded_time" .= modelInfoLastLoadedTime, + "total_chunks" .= modelInfoTotalChunks + ] + +-- | The @hits.total.relation@ discriminator on a model search +-- response. Mirrors the Security Analytics 'SARulesTotalRelation' +-- precedent: known values are decoded to specific constructors, and +-- any unknown value round-trips via 'ModelTotalRelationOther' so a +-- future plugin release does not break decoding. +data ModelTotalRelation + = ModelTotalRelationEq + | ModelTotalRelationGe + | ModelTotalRelationOther Text + deriving stock (Eq, Show) + +modelTotalRelationText :: ModelTotalRelation -> Text +modelTotalRelationText = \case + ModelTotalRelationEq -> "eq" + ModelTotalRelationGe -> "ge" + ModelTotalRelationOther t -> t + +instance ToJSON ModelTotalRelation where + toJSON = toJSON . modelTotalRelationText + +instance FromJSON ModelTotalRelation where + parseJSON = withText "ModelTotalRelation" $ \t -> + pure $ + case t of + "eq" -> ModelTotalRelationEq + "ge" -> ModelTotalRelationGe + other -> ModelTotalRelationOther other + +-- | The @hits.total@ sub-object on a model search response +-- (@{value, relation}@). +data ModelTotal = ModelTotal + { modelTotalValue :: Int64, + modelTotalRelation :: ModelTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON ModelTotal where + parseJSON = withObject "ModelTotal" $ \o -> + ModelTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON ModelTotal where + toJSON ModelTotal {..} = + object + [ "value" .= modelTotalValue, + "relation" .= modelTotalRelation + ] + +-- | The @_shards@ sub-object on a model search response. Defined +-- locally under an @Model@ prefix (mirroring the 'SARulesShards' +-- precedent) rather than re-using the cluster-level 'ShardsResult' +-- envelope, which wraps the outer @{\"_shards\": {...}}@ shape — one +-- level too high for inline use here. +data ModelShards = ModelShards + { modelShardsTotal :: Int, + modelShardsSuccessful :: Int, + modelShardsSkipped :: Int, + modelShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON ModelShards where + parseJSON = withObject "ModelShards" $ \o -> + ModelShards + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "skipped" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON ModelShards where + toJSON ModelShards {..} = + object + [ "total" .= modelShardsTotal, + "successful" .= modelShardsSuccessful, + "skipped" .= modelShardsSkipped, + "failed" .= modelShardsFailed + ] + +-- | A single hit in @hits.hits[]@ on a model search response. +data ModelHit = ModelHit + { modelHitIndex :: Maybe Text, + modelHitId :: Text, + modelHitVersion :: Maybe Int64, + modelHitSeqNo :: Maybe Int64, + modelHitPrimaryTerm :: Maybe Int64, + modelHitScore :: Maybe Double, + modelHitSource :: ModelInfo + } + deriving stock (Eq, Show) + +instance FromJSON ModelHit where + parseJSON = withObject "ModelHit" $ \o -> + ModelHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON ModelHit where + toJSON ModelHit {..} = + omitNulls + [ "_index" .= modelHitIndex, + "_id" .= modelHitId, + "_version" .= modelHitVersion, + "_seq_no" .= modelHitSeqNo, + "_primary_term" .= modelHitPrimaryTerm, + "_score" .= modelHitScore, + "_source" .= modelHitSource + ] + +-- | Response envelope for @POST /_plugins/_ml/models/_search@ and +-- @POST /_plugins/_ml/models/_list@. Decoded verbatim from the +-- standard OpenSearch search-response shape; the paging metadata +-- (@took@, @timed_out@, @_shards@, @hits.total@, @hits.max_score@) +-- is preserved alongside the model list so callers can drive +-- pagination and observe shard health. +data ModelSearchResponse = ModelSearchResponse + { modelSearchResponseTook :: Int64, + modelSearchResponseTimedOut :: Bool, + modelSearchResponseShards :: ModelShards, + modelSearchResponseTotal :: ModelTotal, + modelSearchResponseMaxScore :: Maybe Double, + modelSearchResponseHits :: [ModelHit] + } + deriving stock (Eq, Show) + +instance FromJSON ModelSearchResponse where + parseJSON = withObject "ModelSearchResponse" $ \o -> do + hits <- o .: "hits" + ModelSearchResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON ModelSearchResponse where + toJSON ModelSearchResponse {..} = + object + [ "took" .= modelSearchResponseTook, + "timed_out" .= modelSearchResponseTimedOut, + "_shards" .= modelSearchResponseShards, + "hits" + .= object + [ "total" .= modelSearchResponseTotal, + "max_score" .= modelSearchResponseMaxScore, + "hits" .= modelSearchResponseHits + ] + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/MLStats.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/MLStats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/MLStats.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.MLStats + ( MLNodeId (..), + MLStatName (..), + MLStats (..), + ) +where + +import Data.Map.Strict qualified as Map +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The @GET /_plugins/_ml\/stats@ endpoint (ML Commons plugin, see +-- ) returns +-- a JSON object whose top-level keys are either cluster-level stat names +-- (mapping to scalars, e.g. @ml_model_count@, @ml_connector_count@, +-- @ml_model_index_status@) or the literal key @nodes@, whose value is a +-- per-node map keyed by opaque node ID. The stat-name set is large and +-- explicitly version-gated by the plugin (each stat carries the OpenSearch +-- version that introduced it), and the cluster-level stat keys are not +-- syntactically distinguishable from the @nodes@ key (both are bare JSON +-- object keys). Modelling the body as a typed record would lock the client +-- to one plugin version and require churn on every release, so the body is +-- kept as a flat 'Map.Map Text Value' — callers get a typed envelope and +-- navigate to the per-node map (via @'Map.lookup' \"nodes\"@) or to any +-- individual cluster stat with the aeson combinators they already use +-- elsewhere. +-- +-- Unlike the Neural Search plugin's @\/_plugins\/_neural\/stats@ endpoint, +-- this endpoint is always available whenever the ML Commons plugin is +-- installed; no cluster setting needs to be enabled. + +-- | A node ID for the ML Commons plugin's +-- @\/_plugins\/_ml\/{nodeId}\/stats@ path segment. OpenSearch uses +-- 22-character opaque node IDs (the same identifiers returned by +-- @GET \/_nodes@); we wrap 'Text' so the value round-trips through JSON as a +-- bare string but is distinct from 'NodeName' \/ 'FullNodeId' / +-- 'NeuralNodeId' at the type level. +newtype MLNodeId = MLNodeId {unMLNodeId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A stat name filter for the +-- @\/_plugins\/_ml\/stats\/{stat}@ path segment. Each value matches one of +-- the plugin's stat-name constants (case-insensitive on the server); the +-- full set changes across OpenSearch releases, so this is intentionally a +-- thin 'Text' newtype rather than a closed enum. Representative values +-- include @ml_executing_task_count@, @ml_request_count@, @ml_failure_count@, +-- @ml_jvm_heap_usage@, @ml_deployed_model_count@, +-- @ml_circuit_breaker_trigger_count@ (node-level), and @ml_model_count@, +-- @ml_connector_count@, @ml_model_index_status@ (cluster-level). +newtype MLStatName = MLStatName {unMLStatName :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Response of @GET /_plugins/_ml/stats@. The body is a JSON object whose +-- top-level keys are either cluster-level stat names (mapping to scalars) or +-- the literal key @nodes@ (mapping to a per-node map keyed by opaque node +-- ID); see the module docs for why the entries are kept as aeson 'Value's +-- rather than modelled per-stat. The 'Map.Map' round-trips a flat JSON +-- object via its aeson instances, so no custom 'ToJSON' \/ 'FromJSON' is +-- needed. To reach per-node stats, decode the @nodes@ value, e.g.: +-- +-- @ +-- case 'Map.lookup' \"nodes\" (mlStatsEntries stats) of +-- 'Just' ('Object' m) -> ... navigate m with aeson KeyMap combinators ... +-- _ -> 'Nothing' +-- @ +newtype MLStats = MLStats {mlStatsEntries :: Map.Map Text Value} + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/MLTask.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/MLTask.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/MLTask.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.MLTask + ( MLTaskId (..), + MLTaskType (..), + MLTaskState (..), + MLTaskInfo (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withObject, withText, (.:?), (.=)) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Vector (toList) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) + +-- $schema +-- +-- The @GET /_plugins/_ml/tasks/{task_id}@ endpoint +-- () +-- returns the current state of a single ML Commons task. Tasks are created by +-- the asynchronous model APIs (@POST /_plugins/_ml/models/_register@, +-- @POST /_plugins/_ml/models/{id}/_deploy@, training, ...) and survive until +-- they are cleaned up by the plugin. A caller polls 'getMLTask' with the +-- @task_id@ returned by the submit endpoint until 'mlTaskInfoState' reaches +-- 'MLTaskStateCompleted' or 'MLTaskStateFailed'. +-- +-- The response shape is small and stable, so it is modelled as a typed +-- record. Every field is 'Maybe' because the plugin emits different subsets +-- depending on the task's lifecycle state (a @CREATED@ task has no +-- @last_update_time@; a @FAILED@ task carries an @error@ string; etc.) and +-- because the @task_type@ \/ @state@ enums gain values across plugin +-- releases. The enum decoders fall through to an @Other@ constructor for +-- unknown values rather than failing, so a newer plugin emitting a task type +-- the client does not know about round-trips losslessly instead of throwing +-- — the same forward-compatibility rationale documented for the dynamic +-- bodies of 'Database.Bloodhound.OpenSearch3.Types.NeuralStats'. +-- +-- /Note/: the @worker_node@ field changed shape between OpenSearch versions. +-- OS 1.x emits a single string; OS 2.x+ emits an array of strings. The +-- 'FromJSON' instance tolerates both shapes (coercing a single string to a +-- one-element list) so the same client works against every backend version +-- without forcing a parse failure on either. + +-- | A task identifier for the ML Commons plugin's +-- @\/_plugins\/_ml\/tasks\/{task_id}@ path segment. The value is the opaque +-- string returned in the @task_id@ field of @POST /_plugins/_ml/models/_register@ +-- and friends; we wrap 'Text' so the value round-trips through JSON as a bare +-- string but is distinct from 'KnnNodeId' \/ 'NeuralNodeId' \/ the ES-core +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Task.TaskInfo' id at the +-- type level. +newtype MLTaskId = MLTaskId {unMLTaskId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @task_type@ enum reported by 'getMLTask'. The plugin emits this as an +-- upper-snake-case string (@REGISTER_MODEL@, @DEPLOY_MODEL@, ...). The set +-- grows across releases (remote / streaming / async variants landed in OS 2.x +-- and 3.x); unknown values decode to 'MLTaskTypeOther' so the client does not +-- break when polling a task whose type the library has not been taught about. +data MLTaskType + = MLTaskTypeRegisterModel + | MLTaskTypeDeployModel + | MLTaskTypeTraining + | MLTaskTypeRegisterRemoteModel + | MLTaskTypeDeployRemoteModel + | MLTaskTypeOther Text + deriving stock (Eq, Show) + +instance ToJSON MLTaskType where + toJSON = toJSON . renderMLTaskType + +instance FromJSON MLTaskType where + parseJSON = withText "MLTaskType" $ \case + "REGISTER_MODEL" -> pure MLTaskTypeRegisterModel + "DEPLOY_MODEL" -> pure MLTaskTypeDeployModel + "TRAINING" -> pure MLTaskTypeTraining + "REGISTER_REMOTE_MODEL" -> pure MLTaskTypeRegisterRemoteModel + "DEPLOY_REMOTE_MODEL" -> pure MLTaskTypeDeployRemoteModel + other -> pure (MLTaskTypeOther other) + +renderMLTaskType :: MLTaskType -> Text +renderMLTaskType = \case + MLTaskTypeRegisterModel -> "REGISTER_MODEL" + MLTaskTypeDeployModel -> "DEPLOY_MODEL" + MLTaskTypeTraining -> "TRAINING" + MLTaskTypeRegisterRemoteModel -> "REGISTER_REMOTE_MODEL" + MLTaskTypeDeployRemoteModel -> "DEPLOY_REMOTE_MODEL" + MLTaskTypeOther t -> t + +-- | The @state@ enum reported by 'getMLTask'. The lifecycle is +-- @CREATED -> RUNNING -> COMPLETED@ on success or @FAILED@ on error; the +-- plugin additionally emits @NOT_FOUND@ when the supplied task id has been +-- cleaned up. Unknown values decode to 'MLTaskStateOther' for forward +-- compatibility. +data MLTaskState + = MLTaskStateCreated + | MLTaskStateRunning + | MLTaskStateCompleted + | MLTaskStateFailed + | MLTaskStateNotFound + | MLTaskStateOther Text + deriving stock (Eq, Show) + +instance ToJSON MLTaskState where + toJSON = toJSON . renderMLTaskState + +instance FromJSON MLTaskState where + parseJSON = withText "MLTaskState" $ \case + "CREATED" -> pure MLTaskStateCreated + "RUNNING" -> pure MLTaskStateRunning + "COMPLETED" -> pure MLTaskStateCompleted + "FAILED" -> pure MLTaskStateFailed + "NOT_FOUND" -> pure MLTaskStateNotFound + other -> pure (MLTaskStateOther other) + +renderMLTaskState :: MLTaskState -> Text +renderMLTaskState = \case + MLTaskStateCreated -> "CREATED" + MLTaskStateRunning -> "RUNNING" + MLTaskStateCompleted -> "COMPLETED" + MLTaskStateFailed -> "FAILED" + MLTaskStateNotFound -> "NOT_FOUND" + MLTaskStateOther t -> t + +-- | Response of @GET /_plugins/_ml/tasks/{task_id}@. Every field is 'Maybe' +-- because the plugin emits different subsets depending on the task's +-- lifecycle state and the OpenSearch version (see the module-level docs). +data MLTaskInfo = MLTaskInfo + { mlTaskInfoTaskId :: Maybe Text, + mlTaskInfoModelId :: Maybe Text, + mlTaskInfoTaskType :: Maybe MLTaskType, + mlTaskInfoFunctionName :: Maybe Text, + mlTaskInfoState :: Maybe MLTaskState, + mlTaskInfoWorkerNode :: Maybe [Text], + mlTaskInfoCreateTime :: Maybe Int64, + mlTaskInfoLastUpdateTime :: Maybe Int64, + mlTaskInfoIsAsync :: Maybe Bool, + mlTaskInfoError :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON MLTaskInfo where + parseJSON = withObject "MLTaskInfo" $ \o -> do + mlTaskInfoTaskId <- o .:? "task_id" + mlTaskInfoModelId <- o .:? "model_id" + mlTaskInfoTaskType <- o .:? "task_type" + mlTaskInfoFunctionName <- o .:? "function_name" + mlTaskInfoState <- o .:? "state" + mWorkerNode <- o .:? "worker_node" + let mlTaskInfoWorkerNode = case mWorkerNode of + Nothing -> Nothing + Just (String s) -> Just [s] + Just (Array xs) -> Just [t | String t <- toList xs] + Just _ -> Nothing + mlTaskInfoCreateTime <- o .:? "create_time" + mlTaskInfoLastUpdateTime <- o .:? "last_update_time" + mlTaskInfoIsAsync <- o .:? "is_async" + mlTaskInfoError <- o .:? "error" + return MLTaskInfo {..} + +instance ToJSON MLTaskInfo where + toJSON MLTaskInfo {..} = + omitNulls + [ "task_id" .= mlTaskInfoTaskId, + "model_id" .= mlTaskInfoModelId, + "task_type" .= mlTaskInfoTaskType, + "function_name" .= mlTaskInfoFunctionName, + "state" .= mlTaskInfoState, + "worker_node" .= mlTaskInfoWorkerNode, + "create_time" .= mlTaskInfoCreateTime, + "last_update_time" .= mlTaskInfoLastUpdateTime, + "is_async" .= mlTaskInfoIsAsync, + "error" .= mlTaskInfoError + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/Rollups.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/Rollups.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/Rollups.hs @@ -0,0 +1,710 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.Rollups + ( RollupId (..), + Rollup (..), + RollupWrapper (..), + RollupSchedule (..), + RollupInterval (..), + RollupIntervalUnit (..), + rollupIntervalUnitText, + RollupCron (..), + RollupDimension (..), + RollupDateHistogram (..), + RollupTerms (..), + RollupHistogram (..), + RollupMetric (..), + RollupMetricAgg (..), + rollupMetricAggText, + RollupResponse (..), + RollupResponseInner (..), + ExplainRollupResponse (..), + explainRollupResponseLookup, + explainRollupResponseToList, + ExplainRollupEntry (..), + RollupMetadata (..), + RollupStatus (..), + rollupStatusText, + RollupStats (..), + ) +where + +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The OpenSearch Index Rollups plugin +-- () +-- periodically reduces a high-granularity source index into a coarser +-- target index by aggregating documents along configurable dimensions +-- (date_histogram / terms / histogram) and computing metrics +-- (avg / sum / max / min / value_count) per bucket. A 'Rollup' binds a +-- 'rollupSourceIndex', a 'rollupTargetIndex', a 'RollupSchedule', the +-- 'rollupDimensions' to group by and the 'rollupMetrics' to compute; the +-- server persists it under @.opendistro-ism-config@ (the ISM config +-- index) and returns a 'RollupResponse' wrapping the persisted +-- 'RollupResponseInner' with server-injected bookkeeping fields +-- (@_id@, @_version@, @_seq_no@, @_primary_term@, @rollup_id@, +-- @last_updated_time@, @enabled_time@, @schema_version@, @metadata_id@). +-- +-- We split the request shape ('Rollup') from the response inner shape +-- ('RollupResponseInner') so the request cannot accidentally carry +-- server-only fields, while the response still round-trips the full +-- server payload. This mirrors the 'Detector' / 'DetectorResponse' +-- split used for the Anomaly Detection plugin. +-- +-- The plugin is shipped with OpenSearch 1.0+; it is present (and +-- wire-compatible) on OS1, OS2 and OS3, hence this module is duplicated +-- across all three versions. The @routing_field@ option is documented as +-- OS 3.7+ only, but is modelled as 'Maybe' 'Text' here on every version: +-- older clusters simply never receive it (it is omitted under +-- 'omitNulls'), so a single code path serves all three. +-- +-- Doc ambiguities handled here deliberately: +-- +-- * The @_seq_no@ / @_primary_term@ fields are emitted in snake_case on +-- the PUT response but camelCase (@_seqNo@ / @_primaryTerm@) on the GET +-- response. The 'RollupResponse' parser accepts both spellings (see +-- 'rollupKey'). +-- * The @schedule.interval.period@ field is documented with type String +-- but every documented example emits it as a bare number (@1@). We +-- type it as 'Int', matching the wire format the server actually sends. +-- * The @metadata_id@ field is JSON @null@ (not absent) when the rollup +-- has not yet executed, so it is parsed with '.:?' (tolerating both +-- @null@ and omission). +-- * The @GET /_plugins/_rollup/jobs@ (list-all) endpoint is undocumented +-- in the field tables; its response is decoded as an opaque 'Value' at +-- the 'Requests' layer rather than typed here. +-- * Each 'RollupDimension' / 'RollupMetricAgg' is encoded as a +-- single-key JSON object (e.g. @{"avg":{}}@) following the +-- aggregation-DSL convention the plugin reuses. + +-- | Identifies a rollup job in the +-- @\/_plugins\/_rollup\/jobs\/{rollup_id}@ URL path. Wraps 'Text' so it +-- round-trips through JSON as a bare string but is distinct at the +-- Haskell type level. +-- See +newtype RollupId = RollupId {unRollupId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The request body for @PUT /_plugins/_rollup/jobs/{rollup_id}@, +-- unwrapped. Required fields: @source_index@, @target_index@, +-- @schedule@, @page_size@, @dimensions@. Everything else is optional and +-- omitted on the wire when 'Nothing'. Server-only bookkeeping fields +-- (@rollup_id@, @last_updated_time@, @enabled_time@, @schema_version@, +-- @metadata_id@) are deliberately absent — they appear on the +-- 'RollupResponseInner' round-trip shape. +-- See +data Rollup = Rollup + { rollupSourceIndex :: Text, + rollupTargetIndex :: Text, + rollupTargetIndexSettings :: Maybe Value, + rollupSchedule :: RollupSchedule, + rollupDescription :: Maybe Text, + rollupEnabled :: Maybe Bool, + rollupContinuous :: Maybe Bool, + rollupPageSize :: Int, + rollupDelay :: Maybe Integer, + rollupRoles :: Maybe [Text], + rollupRoutingField :: Maybe Text, + rollupDimensions :: [RollupDimension], + rollupMetrics :: Maybe [RollupMetric], + rollupErrorNotification :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON Rollup where + parseJSON = withObject "Rollup" $ \v -> do + rollupSourceIndex <- v .: "source_index" + rollupTargetIndex <- v .: "target_index" + rollupTargetIndexSettings <- v .:? "target_index_settings" + rollupSchedule <- v .: "schedule" + rollupDescription <- v .:? "description" + rollupEnabled <- v .:? "enabled" + rollupContinuous <- v .:? "continuous" + rollupPageSize <- v .: "page_size" + rollupDelay <- v .:? "delay" + rollupRoles <- v .:? "roles" + rollupRoutingField <- v .:? "routing_field" + rollupDimensions <- v .:? "dimensions" .!= [] + rollupMetrics <- v .:? "metrics" + rollupErrorNotification <- v .:? "error_notification" + pure Rollup {..} + +instance ToJSON Rollup where + toJSON Rollup {..} = + omitNulls + [ "source_index" .= rollupSourceIndex, + "target_index" .= rollupTargetIndex, + "target_index_settings" .= rollupTargetIndexSettings, + "schedule" .= rollupSchedule, + "description" .= rollupDescription, + "enabled" .= rollupEnabled, + "continuous" .= rollupContinuous, + "page_size" .= rollupPageSize, + "delay" .= rollupDelay, + "roles" .= rollupRoles, + "routing_field" .= rollupRoutingField, + "dimensions" .= rollupDimensions, + "metrics" .= rollupMetrics, + "error_notification" .= rollupErrorNotification + ] + +-- | The @{"rollup": }@ envelope the PUT endpoint expects around +-- the 'Rollup' body. +-- See +newtype RollupWrapper = RollupWrapper {rollupWrapperRollup :: Rollup} + deriving stock (Eq, Show) + +instance ToJSON RollupWrapper where + toJSON (RollupWrapper r) = object ["rollup" .= r] + +instance FromJSON RollupWrapper where + parseJSON = withObject "RollupWrapper" $ \v -> + RollupWrapper <$> v .: "rollup" + +-- | The @schedule@ object. Currently only the @interval@ form is +-- documented; @cron@ lives one level deeper inside 'RollupInterval'. +-- See +newtype RollupSchedule = RollupSchedule {rollupScheduleInterval :: RollupInterval} + deriving stock (Eq, Show) + +instance FromJSON RollupSchedule where + parseJSON = withObject "RollupSchedule" $ \v -> + RollupSchedule <$> v .: "interval" + +instance ToJSON RollupSchedule where + toJSON (RollupSchedule interval) = object ["interval" .= interval] + +-- | The @schedule.interval@ object. Either the @period@\/@unit@ pair or a +-- @cron@ list governs execution frequency; @start_time@ and +-- @schedule_delay@ are server-populated on the response. +-- See +data RollupInterval = RollupInterval + { rollupIntervalPeriod :: Maybe Int, + rollupIntervalUnit :: Maybe RollupIntervalUnit, + rollupIntervalStartTime :: Maybe Integer, + rollupIntervalScheduleDelay :: Maybe Integer, + rollupIntervalCron :: Maybe [RollupCron] + } + deriving stock (Eq, Show) + +instance FromJSON RollupInterval where + parseJSON = withObject "RollupInterval" $ \v -> do + rollupIntervalPeriod <- v .:? "period" + rollupIntervalUnit <- v .:? "unit" + rollupIntervalStartTime <- v .:? "start_time" + rollupIntervalScheduleDelay <- v .:? "schedule_delay" + rollupIntervalCron <- v .:? "cron" + pure RollupInterval {..} + +instance ToJSON RollupInterval where + toJSON RollupInterval {..} = + omitNulls + [ "period" .= rollupIntervalPeriod, + "unit" .= rollupIntervalUnit, + "start_time" .= rollupIntervalStartTime, + "schedule_delay" .= rollupIntervalScheduleDelay, + "cron" .= rollupIntervalCron + ] + +-- | The @schedule.interval.unit@ enum. The docs only show @"Days"@ in +-- examples; the plugin source accepts the standard time units +-- enumerated here. Unknown values surface as 'RollupIntervalUnitCustom' +-- rather than failing the decode. +-- See +data RollupIntervalUnit + = RollupIntervalUnitMinutes + | RollupIntervalUnitHours + | RollupIntervalUnitDays + | RollupIntervalUnitWeeks + | RollupIntervalUnitMonths + | RollupIntervalUnitCustom Text + deriving stock (Eq, Show) + +rollupIntervalUnitText :: RollupIntervalUnit -> Text +rollupIntervalUnitText = \case + RollupIntervalUnitMinutes -> "Minutes" + RollupIntervalUnitHours -> "Hours" + RollupIntervalUnitDays -> "Days" + RollupIntervalUnitWeeks -> "Weeks" + RollupIntervalUnitMonths -> "Months" + RollupIntervalUnitCustom t -> t + +instance ToJSON RollupIntervalUnit where + toJSON = toJSON . rollupIntervalUnitText + +instance FromJSON RollupIntervalUnit where + parseJSON = withText "RollupIntervalUnit" $ \case + "Minutes" -> pure RollupIntervalUnitMinutes + "Hours" -> pure RollupIntervalUnitHours + "Days" -> pure RollupIntervalUnitDays + "Weeks" -> pure RollupIntervalUnitWeeks + "Months" -> pure RollupIntervalUnitMonths + other -> pure (RollupIntervalUnitCustom other) + +-- | A cron expression entry inside @schedule.interval.cron@. +-- See +data RollupCron = RollupCron + { rollupCronExpression :: Text, + rollupCronTimezone :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupCron where + parseJSON = withObject "RollupCron" $ \v -> do + rollupCronExpression <- v .: "expression" + rollupCronTimezone <- v .:? "timezone" + pure RollupCron {..} + +instance ToJSON RollupCron where + toJSON RollupCron {..} = + omitNulls + [ "expression" .= rollupCronExpression, + "timezone" .= rollupCronTimezone + ] + +-- | A single dimension (bucket aggregation) the rollup groups by. The +-- plugin models each as a single-key object whose key selects the +-- aggregation kind; we keep that shape on the wire. +-- See +data RollupDimension + = RollupDimensionDateHistogram RollupDateHistogram + | RollupDimensionTerms RollupTerms + | RollupDimensionHistogram RollupHistogram + deriving stock (Eq, Show) + +instance ToJSON RollupDimension where + toJSON = \case + RollupDimensionDateHistogram dh -> object ["date_histogram" .= dh] + RollupDimensionTerms t -> object ["terms" .= t] + RollupDimensionHistogram h -> object ["histogram" .= h] + +instance FromJSON RollupDimension where + parseJSON = withObject "RollupDimension" $ \v -> case KeyMap.toList v of + [("date_histogram", o)] -> RollupDimensionDateHistogram <$> parseJSON o + [("terms", o)] -> RollupDimensionTerms <$> parseJSON o + [("histogram", o)] -> RollupDimensionHistogram <$> parseJSON o + _ -> + fail + ( "RollupDimension: expected a single-key object with one of \ + \date_histogram / terms / histogram, got keys: " + <> T.unpack (T.intercalate ", " (fmap (T.pack . show) (KeyMap.keys v))) + ) + +-- | The @date_histogram@ dimension. @fixed_interval@ is the documented +-- form (e.g. @"1h"@); @calendar_interval@ is also accepted by the plugin. +-- @target_field@ is server-populated on the response (mirroring +-- @source_field@ by default) and omitted on the request. +-- See +data RollupDateHistogram = RollupDateHistogram + { rollupDateHistogramSourceField :: Text, + rollupDateHistogramFixedInterval :: Maybe Text, + rollupDateHistogramCalendarInterval :: Maybe Text, + rollupDateHistogramTimezone :: Maybe Text, + rollupDateHistogramTargetField :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupDateHistogram where + parseJSON = withObject "RollupDateHistogram" $ \v -> do + rollupDateHistogramSourceField <- v .: "source_field" + rollupDateHistogramFixedInterval <- v .:? "fixed_interval" + rollupDateHistogramCalendarInterval <- v .:? "calendar_interval" + rollupDateHistogramTimezone <- v .:? "timezone" + rollupDateHistogramTargetField <- v .:? "target_field" + pure RollupDateHistogram {..} + +instance ToJSON RollupDateHistogram where + toJSON RollupDateHistogram {..} = + omitNulls + [ "source_field" .= rollupDateHistogramSourceField, + "fixed_interval" .= rollupDateHistogramFixedInterval, + "calendar_interval" .= rollupDateHistogramCalendarInterval, + "timezone" .= rollupDateHistogramTimezone, + "target_field" .= rollupDateHistogramTargetField + ] + +-- | The @terms@ dimension. @target_field@ is server-populated on the +-- response and omitted on the request. +-- See +data RollupTerms = RollupTerms + { rollupTermsSourceField :: Text, + rollupTermsTargetField :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupTerms where + parseJSON = withObject "RollupTerms" $ \v -> do + rollupTermsSourceField <- v .: "source_field" + rollupTermsTargetField <- v .:? "target_field" + pure RollupTerms {..} + +instance ToJSON RollupTerms where + toJSON RollupTerms {..} = + omitNulls + [ "source_field" .= rollupTermsSourceField, + "target_field" .= rollupTermsTargetField + ] + +-- | The @histogram@ dimension (numeric). @target_field@ is +-- server-populated on the response and omitted on the request. +-- See +data RollupHistogram = RollupHistogram + { rollupHistogramSourceField :: Text, + rollupHistogramInterval :: Scientific, + rollupHistogramTargetField :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupHistogram where + parseJSON = withObject "RollupHistogram" $ \v -> do + rollupHistogramSourceField <- v .: "source_field" + rollupHistogramInterval <- v .: "interval" + rollupHistogramTargetField <- v .:? "target_field" + pure RollupHistogram {..} + +instance ToJSON RollupHistogram where + toJSON RollupHistogram {..} = + omitNulls + [ "source_field" .= rollupHistogramSourceField, + "interval" .= rollupHistogramInterval, + "target_field" .= rollupHistogramTargetField + ] + +-- | A field + the metrics to compute over it. Each 'RollupMetricAgg' +-- encodes as a single-key object (e.g. @{"avg":{}}@). +-- See +data RollupMetric = RollupMetric + { rollupMetricSourceField :: Text, + rollupMetricMetrics :: [RollupMetricAgg] + } + deriving stock (Eq, Show) + +instance FromJSON RollupMetric where + parseJSON = withObject "RollupMetric" $ \v -> do + rollupMetricSourceField <- v .: "source_field" + rollupMetricMetrics <- v .:? "metrics" .!= [] + pure RollupMetric {..} + +instance ToJSON RollupMetric where + toJSON RollupMetric {..} = + omitNulls + [ "source_field" .= rollupMetricSourceField, + "metrics" .= rollupMetricMetrics + ] + +-- | The supported per-field metric aggregations. Each encodes to a +-- single-key object whose value is an empty object (@{"avg":{}}@). +-- Unknown keys surface as 'RollupMetricAggCustom' rather than failing. +-- See +data RollupMetricAgg + = RollupMetricAvg + | RollupMetricSum + | RollupMetricMax + | RollupMetricMin + | RollupMetricValueCount + | RollupMetricAggCustom Text + deriving stock (Eq, Show) + +rollupMetricAggText :: RollupMetricAgg -> Text +rollupMetricAggText = \case + RollupMetricAvg -> "avg" + RollupMetricSum -> "sum" + RollupMetricMax -> "max" + RollupMetricMin -> "min" + RollupMetricValueCount -> "value_count" + RollupMetricAggCustom t -> t + +instance ToJSON RollupMetricAgg where + toJSON agg = object [fromText (rollupMetricAggText agg) .= object []] + +instance FromJSON RollupMetricAgg where + parseJSON = withObject "RollupMetricAgg" $ \v -> case KeyMap.toList v of + [(k, _)] -> pure (rollupMetricAggFromKey (toText k)) + _ -> + fail + ( "RollupMetricAgg: expected a single-key object (e.g. {\"avg\":{}}), \ + \got keys: " + <> T.unpack (T.intercalate ", " (fmap (T.pack . show) (KeyMap.keys v))) + ) + +rollupMetricAggFromKey :: Text -> RollupMetricAgg +rollupMetricAggFromKey = \case + "avg" -> RollupMetricAvg + "sum" -> RollupMetricSum + "max" -> RollupMetricMax + "min" -> RollupMetricMin + "value_count" -> RollupMetricValueCount + other -> RollupMetricAggCustom other + +-- | Parse a 'Maybe' field that may appear under either of two JSON keys. +-- Used for @_seq_no@\/@_seqNo@ and @_primary_term@\/@_primaryTerm@, which +-- the rollup plugin emits in snake_case on PUT responses and camelCase +-- on GET responses. +rollupKey :: (FromJSON a) => Object -> Key -> Key -> Parser (Maybe a) +rollupKey o snake camel = do + m <- o .:? snake + case m of + Just x -> pure (Just x) + Nothing -> o .:? camel + +-- | Response body of @PUT \/_plugins\/_rollup\/jobs\/{rollup_id}@ and +-- @GET \/_plugins\/_rollup\/jobs\/{rollup_id}@. Wraps the persisted +-- 'RollupResponseInner' in a document-write envelope (@_id@, @_version@, +-- @_seq_no@, @_primary_term@). The PUT response uses snake_case +-- (@_seq_no@\/@_primary_term@); the GET response uses camelCase +-- (@_seqNo@\/@_primaryTerm@); both are accepted via 'rollupKey'. +-- See +data RollupResponse = RollupResponse + { rollupResponseId :: Text, + rollupResponseVersion :: Maybe Int, + rollupResponseSeqNo :: Maybe Int, + rollupResponsePrimaryTerm :: Maybe Int, + rollupResponseRollup :: RollupResponseInner + } + deriving stock (Eq, Show) + +instance FromJSON RollupResponse where + parseJSON = withObject "RollupResponse" $ \v -> do + rollupResponseId <- v .: "_id" + rollupResponseVersion <- v .:? "_version" + rollupResponseSeqNo <- rollupKey v "_seq_no" "_seqNo" + rollupResponsePrimaryTerm <- rollupKey v "_primary_term" "_primaryTerm" + rollupResponseRollup <- v .: "rollup" + pure RollupResponse {..} + +instance ToJSON RollupResponse where + toJSON RollupResponse {..} = + omitNulls + [ "_id" .= rollupResponseId, + "_version" .= rollupResponseVersion, + "_seq_no" .= rollupResponseSeqNo, + "_primary_term" .= rollupResponsePrimaryTerm, + "rollup" .= rollupResponseRollup + ] + +-- | The persisted @rollup@ object returned in responses. Carries the +-- full 'Rollup' body alongside server-injected bookkeeping fields +-- (@rollup_id@, @last_updated_time@, @enabled_time@, @schema_version@, +-- @metadata_id@). The round-trip preserves everything the server sent, +-- so a Get -> Update cycle does not lose data the caller never set. +-- See +data RollupResponseInner = RollupResponseInner + { rollupResponseInnerSourceIndex :: Text, + rollupResponseInnerTargetIndex :: Text, + rollupResponseInnerTargetIndexSettings :: Maybe Value, + rollupResponseInnerSchedule :: RollupSchedule, + rollupResponseInnerDescription :: Maybe Text, + rollupResponseInnerEnabled :: Maybe Bool, + rollupResponseInnerContinuous :: Maybe Bool, + rollupResponseInnerPageSize :: Maybe Int, + rollupResponseInnerDelay :: Maybe Integer, + rollupResponseInnerRoles :: Maybe [Text], + rollupResponseInnerRoutingField :: Maybe Text, + rollupResponseInnerDimensions :: [RollupDimension], + rollupResponseInnerMetrics :: Maybe [RollupMetric], + rollupResponseInnerErrorNotification :: Maybe Value, + rollupResponseInnerRollupId :: Maybe Text, + rollupResponseInnerLastUpdatedTime :: Maybe Integer, + rollupResponseInnerEnabledTime :: Maybe Integer, + rollupResponseInnerSchemaVersion :: Maybe Int, + rollupResponseInnerMetadataId :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupResponseInner where + parseJSON = withObject "RollupResponseInner" $ \v -> do + rollupResponseInnerSourceIndex <- v .: "source_index" + rollupResponseInnerTargetIndex <- v .: "target_index" + rollupResponseInnerTargetIndexSettings <- v .:? "target_index_settings" + rollupResponseInnerSchedule <- v .: "schedule" + rollupResponseInnerDescription <- v .:? "description" + rollupResponseInnerEnabled <- v .:? "enabled" + rollupResponseInnerContinuous <- v .:? "continuous" + rollupResponseInnerPageSize <- v .:? "page_size" + rollupResponseInnerDelay <- v .:? "delay" + rollupResponseInnerRoles <- v .:? "roles" + rollupResponseInnerRoutingField <- v .:? "routing_field" + rollupResponseInnerDimensions <- v .:? "dimensions" .!= [] + rollupResponseInnerMetrics <- v .:? "metrics" + rollupResponseInnerErrorNotification <- v .:? "error_notification" + rollupResponseInnerRollupId <- v .:? "rollup_id" + rollupResponseInnerLastUpdatedTime <- v .:? "last_updated_time" + rollupResponseInnerEnabledTime <- v .:? "enabled_time" + rollupResponseInnerSchemaVersion <- v .:? "schema_version" + rollupResponseInnerMetadataId <- v .:? "metadata_id" + pure RollupResponseInner {..} + +instance ToJSON RollupResponseInner where + toJSON RollupResponseInner {..} = + omitNulls + [ "source_index" .= rollupResponseInnerSourceIndex, + "target_index" .= rollupResponseInnerTargetIndex, + "target_index_settings" .= rollupResponseInnerTargetIndexSettings, + "schedule" .= rollupResponseInnerSchedule, + "description" .= rollupResponseInnerDescription, + "enabled" .= rollupResponseInnerEnabled, + "continuous" .= rollupResponseInnerContinuous, + "page_size" .= rollupResponseInnerPageSize, + "delay" .= rollupResponseInnerDelay, + "roles" .= rollupResponseInnerRoles, + "routing_field" .= rollupResponseInnerRoutingField, + "dimensions" .= rollupResponseInnerDimensions, + "metrics" .= rollupResponseInnerMetrics, + "error_notification" .= rollupResponseInnerErrorNotification, + "rollup_id" .= rollupResponseInnerRollupId, + "last_updated_time" .= rollupResponseInnerLastUpdatedTime, + "enabled_time" .= rollupResponseInnerEnabledTime, + "schema_version" .= rollupResponseInnerSchemaVersion, + "metadata_id" .= rollupResponseInnerMetadataId + ] + +-- | Response body of @GET \/_plugins\/_rollup\/jobs\/{rollup_id}\/_explain@. +-- The plugin keys the response by the rollup job id at the top level, so +-- the body is decoded into a 'Map' from rollup id to 'ExplainRollupEntry'. +-- The caller looks up the entry for the id it requested via +-- 'explainRollupResponseLookup'. +-- See +newtype ExplainRollupResponse = ExplainRollupResponse + { explainRollupResponseMap :: Map.Map Text ExplainRollupEntry + } + deriving stock (Eq, Show) + +instance FromJSON ExplainRollupResponse where + parseJSON v = ExplainRollupResponse <$> parseJSON v + +-- | Lookup the entry for a rollup id. Returns 'Nothing' if the id is +-- absent from the response. +explainRollupResponseLookup :: Text -> ExplainRollupResponse -> Maybe ExplainRollupEntry +explainRollupResponseLookup rid = Map.lookup rid . explainRollupResponseMap + +-- | The entries of an 'ExplainRollupResponse', as an association list. +explainRollupResponseToList :: ExplainRollupResponse -> [(Text, ExplainRollupEntry)] +explainRollupResponseToList = Map.toList . explainRollupResponseMap + +-- | One entry under the explain-response top-level map. Both fields are +-- JSON @null@ (not absent) when the rollup job has not yet executed. +-- See +data ExplainRollupEntry = ExplainRollupEntry + { explainRollupEntryMetadataId :: Maybe Text, + explainRollupEntryRollupMetadata :: Maybe RollupMetadata + } + deriving stock (Eq, Show) + +instance FromJSON ExplainRollupEntry where + parseJSON = withObject "ExplainRollupEntry" $ \v -> do + explainRollupEntryMetadataId <- v .:? "metadata_id" + explainRollupEntryRollupMetadata <- v .:? "rollup_metadata" + pure ExplainRollupEntry {..} + +-- | The @rollup_metadata@ object inside an explain entry. Carries the +-- job execution status, failure reason and run statistics. @status@ is +-- a closed enum with a forward-compat escape hatch. +-- See +data RollupMetadata = RollupMetadata + { rollupMetadataRollupId :: Text, + rollupMetadataLastUpdatedTime :: Integer, + rollupMetadataStatus :: RollupStatus, + rollupMetadataFailureReason :: Maybe Text, + rollupMetadataStats :: Maybe RollupStats, + rollupMetadataNextWindowStartTime :: Maybe Integer, + rollupMetadataNextWindowEndTime :: Maybe Integer + } + deriving stock (Eq, Show) + +instance FromJSON RollupMetadata where + parseJSON = withObject "RollupMetadata" $ \v -> do + rollupMetadataRollupId <- v .: "rollup_id" + rollupMetadataLastUpdatedTime <- v .: "last_updated_time" + rollupMetadataStatus <- v .: "status" + rollupMetadataFailureReason <- v .:? "failure_reason" + rollupMetadataStats <- v .:? "stats" + rollupMetadataNextWindowStartTime <- v .:? "next_window_start_time" + rollupMetadataNextWindowEndTime <- v .:? "next_window_end_time" + pure RollupMetadata {..} + +instance ToJSON RollupMetadata where + toJSON RollupMetadata {..} = + omitNulls + [ "rollup_id" .= rollupMetadataRollupId, + "last_updated_time" .= rollupMetadataLastUpdatedTime, + "status" .= rollupMetadataStatus, + "failure_reason" .= rollupMetadataFailureReason, + "stats" .= rollupMetadataStats, + "next_window_start_time" .= rollupMetadataNextWindowStartTime, + "next_window_end_time" .= rollupMetadataNextWindowEndTime + ] + +-- | The @rollup_metadata.status@ enum. +-- See +data RollupStatus + = RollupStatusInit + | RollupStatusStarted + | RollupStatusFinished + | RollupStatusFailed + | RollupStatusStopped + | RollupStatusRetry + | RollupStatusCustom Text + deriving stock (Eq, Show) + +rollupStatusText :: RollupStatus -> Text +rollupStatusText = \case + RollupStatusInit -> "init" + RollupStatusStarted -> "started" + RollupStatusFinished -> "finished" + RollupStatusFailed -> "failed" + RollupStatusStopped -> "stopped" + RollupStatusRetry -> "retry" + RollupStatusCustom t -> t + +instance ToJSON RollupStatus where + toJSON = toJSON . rollupStatusText + +instance FromJSON RollupStatus where + parseJSON = withText "RollupStatus" $ \case + "init" -> pure RollupStatusInit + "started" -> pure RollupStatusStarted + "finished" -> pure RollupStatusFinished + "failed" -> pure RollupStatusFailed + "stopped" -> pure RollupStatusStopped + "retry" -> pure RollupStatusRetry + other -> pure (RollupStatusCustom other) + +-- | The @rollup_metadata.stats@ object. +-- See +data RollupStats = RollupStats + { rollupStatsPagesProcessed :: Int, + rollupStatsDocumentsProcessed :: Int, + rollupStatsRollupsIndexed :: Int, + rollupStatsIndexTimeInMillis :: Integer, + rollupStatsSearchTimeInMillis :: Integer + } + deriving stock (Eq, Show) + +instance FromJSON RollupStats where + parseJSON = withObject "RollupStats" $ \v -> do + rollupStatsPagesProcessed <- v .: "pages_processed" + rollupStatsDocumentsProcessed <- v .: "documents_processed" + rollupStatsRollupsIndexed <- v .: "rollups_indexed" + rollupStatsIndexTimeInMillis <- v .: "index_time_in_millis" + rollupStatsSearchTimeInMillis <- v .: "search_time_in_millis" + pure RollupStats {..} + +instance ToJSON RollupStats where + toJSON RollupStats {..} = + object + [ "pages_processed" .= rollupStatsPagesProcessed, + "documents_processed" .= rollupStatsDocumentsProcessed, + "rollups_indexed" .= rollupStatsRollupsIndexed, + "index_time_in_millis" .= rollupStatsIndexTimeInMillis, + "search_time_in_millis" .= rollupStatsSearchTimeInMillis + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/SQLPPL.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/SQLPPL.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/SQLPPL.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.SQLPPL + ( SQLRequest (..), + PPLRequest (..), + SQLParameter (..), + SQLCursor (..), + SQLCursorRequest (..), + SQLColumn (..), + SQLResult (..), + PPLResult, + SQLCloseResult (..), + ) +where + +import Data.Aeson + ( FromJSON (..), + ToJSON (..), + Value, + object, + withObject, + (.:), + (.:?), + (.=), + ) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) + +-- $schema +-- +-- The OpenSearch SQL and PPL query endpoints +-- () +-- share a single Query API surface that differs only by path +-- (@POST /_plugins/_sql@ versus @POST /_plugins/_ppl@) and by the dialect of +-- the @query@ string. The response shape (a JDBC-style rowset) is identical. +-- +-- /Pagination/ is SQL-only: when the request body includes a positive +-- @fetch_size@, the first response carries a 'SQLCursor' and subsequent pages +-- are fetched by POSTing a 'SQLCursorRequest' body (@{"cursor": "..."}@) to +-- the same @/_plugins/_sql@ endpoint. A continuation response omits the +-- @schema@, @total@, @size@ and @status@ fields, so every field of 'SQLResult' +-- except @datarows@ is 'Maybe'. The cursor is opaque (a @d:@-prefixed +-- server-generated token); release it with @POST /_plugins/_sql/close@. +-- +-- /Wire inconsistencies./ The plugin's response-field table documents the +-- row array as @data_rows@ and the HTTP status as a String; every JSON +-- example in the same docs uses @datarows@ and an integer (@200@). We trust +-- the wire (examples) over the prose: the field is @datarows@ and 'sqlResultStatus' +-- is 'Int'. +-- +-- /Format./ This module models the default @jdbc@ response format (the only +-- format whose body is the JSON shape below). The @csv@, @raw@ and @json@ +-- formats return non-JSON bodies and are out of scope; callers that need +-- them should bypass these types. + +-- | Request body for @POST /_plugins/_sql@. Only 'sqlRequestQuery' is +-- required; the rest are optional. @fetch_size@ requires the @jdbc@ +-- response format (the default) and triggers cursor pagination; a value of +-- @0@ falls back to non-paginated. @parameters@ carries prepared-statement +-- bind variables (shown in the plugin's @_explain@ examples though absent +-- from its field table). +data SQLRequest = SQLRequest + { sqlRequestQuery :: Text, + sqlRequestFilter :: Maybe Value, + sqlRequestFetchSize :: Maybe Int, + sqlRequestParameters :: Maybe [SQLParameter] + } + deriving stock (Eq, Show) + +instance ToJSON SQLRequest where + toJSON SQLRequest {..} = + omitNulls + [ "query" .= sqlRequestQuery, + "filter" .= sqlRequestFilter, + "fetch_size" .= sqlRequestFetchSize, + "parameters" .= sqlRequestParameters + ] + +instance FromJSON SQLRequest where + parseJSON = withObject "SQLRequest" $ \v -> do + sqlRequestQuery <- v .: "query" + sqlRequestFilter <- v .:? "filter" + sqlRequestFetchSize <- v .:? "fetch_size" + sqlRequestParameters <- v .:? "parameters" + pure SQLRequest {..} + +-- | Request body for @POST /_plugins/_ppl@. PPL does not support +-- @fetch_size@ / cursor pagination (the plugin documents @fetch_size@ as +-- SQL-only), so this record has no such field. +data PPLRequest = PPLRequest + { pplRequestQuery :: Text, + pplRequestFilter :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON PPLRequest where + toJSON PPLRequest {..} = + omitNulls + [ "query" .= pplRequestQuery, + "filter" .= pplRequestFilter + ] + +instance FromJSON PPLRequest where + parseJSON = withObject "PPLRequest" $ \v -> do + pplRequestQuery <- v .: "query" + pplRequestFilter <- v .:? "filter" + pure PPLRequest {..} + +-- | A prepared-statement bind variable, as documented by the plugin's +-- @_explain@ examples: @{"type": "integer", "value": 30}@. The @type@ field +-- uses an open vocabulary (@integer@, @string@, @long@, @boolean@, ...) so +-- it is kept as 'Text' rather than a closed enum. +data SQLParameter = SQLParameter + { sqlParameterType :: Text, + sqlParameterValue :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SQLParameter where + toJSON SQLParameter {..} = + object + [ "type" .= sqlParameterType, + "value" .= sqlParameterValue + ] + +instance FromJSON SQLParameter where + parseJSON = withObject "SQLParameter" $ \v -> do + sqlParameterType <- v .: "type" + sqlParameterValue <- v .: "value" + pure SQLParameter {..} + +-- | An opaque pagination cursor returned by paginated SQL responses. The +-- wire value is a @d:@-prefixed base64 blob; treat it as opaque and send it +-- back verbatim via 'SQLCursorRequest' or @POST /_plugins/_sql/close@. +newtype SQLCursor = SQLCursor {unSQLCursor :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Request body for cursor continuation and close requests +-- (@{"cursor": "..."}@). The server rejects a body that carries both +-- @query@ and @cursor@, so this is a distinct type from 'SQLRequest'. +newtype SQLCursorRequest = SQLCursorRequest {sqlCursorRequestCursor :: SQLCursor} + deriving stock (Eq, Show) + +instance ToJSON SQLCursorRequest where + toJSON SQLCursorRequest {..} = + object ["cursor" .= sqlCursorRequestCursor] + +instance FromJSON SQLCursorRequest where + parseJSON = withObject "SQLCursorRequest" $ \v -> do + sqlCursorRequestCursor <- v .: "cursor" + pure SQLCursorRequest {..} + +-- | One column descriptor from the 'SQLResult' @schema@ array. The @type@ +-- field uses an open vocabulary (@long@, @text@, @double@, @boolean@, +-- @keyword@, ...) plus user-defined types via index mappings, so it is kept +-- as 'Text' rather than a closed enum. +data SQLColumn = SQLColumn + { sqlColumnName :: Text, + sqlColumnType :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SQLColumn where + parseJSON = withObject "SQLColumn" $ \v -> do + sqlColumnName <- v .: "name" + sqlColumnType <- v .: "type" + pure SQLColumn {..} + +instance ToJSON SQLColumn where + toJSON SQLColumn {..} = + object + [ "name" .= sqlColumnName, + "type" .= sqlColumnType + ] + +-- | Response of @POST /_plugins/_sql@ and @POST /_plugins/_ppl@. Only +-- 'sqlResultDatarows' is present on every response (initial, continuation, +-- and final page); @schema@, @total@, @size@ and @status@ are dropped on +-- cursor-continuation pages and are therefore 'Maybe'. @cursor@ is present +-- on every page except the last. Each row in @datarows@ is a heterogeneous +-- JSON array whose cells line up with 'sqlResultSchema'; cells are kept as +-- aeson 'Value's because the column type governs interpretation, not the +-- Haskell type. +data SQLResult = SQLResult + { sqlResultSchema :: Maybe [SQLColumn], + sqlResultDatarows :: [[Value]], + sqlResultTotal :: Maybe Int, + sqlResultSize :: Maybe Int, + sqlResultStatus :: Maybe Int, + sqlResultCursor :: Maybe SQLCursor + } + deriving stock (Eq, Show) + +instance FromJSON SQLResult where + parseJSON = withObject "SQLResult" $ \v -> do + sqlResultSchema <- v .:? "schema" + sqlResultDatarows <- v .: "datarows" + sqlResultTotal <- v .:? "total" + sqlResultSize <- v .:? "size" + sqlResultStatus <- v .:? "status" + sqlResultCursor <- v .:? "cursor" + pure SQLResult {..} + +instance ToJSON SQLResult where + toJSON SQLResult {..} = + omitNulls + [ "schema" .= sqlResultSchema, + "datarows" .= sqlResultDatarows, + "total" .= sqlResultTotal, + "size" .= sqlResultSize, + "status" .= sqlResultStatus, + "cursor" .= sqlResultCursor + ] + +-- | PPL uses the same response shape as SQL. The alias keeps the bead's +-- acceptance signature (@pplQuery :: ... -> m PPLResult@) self-documenting +-- without duplicating aeson instances. +type PPLResult = SQLResult + +-- | Response of @POST /_plugins/_sql/close@. Always @{"succeeded": true}@ on +-- a successful cursor release. +newtype SQLCloseResult = SQLCloseResult + { sqlCloseResultSucceeded :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON SQLCloseResult where + parseJSON = withObject "SQLCloseResult" $ \v -> do + sqlCloseResultSucceeded <- v .: "succeeded" + pure SQLCloseResult {..} + +instance ToJSON SQLCloseResult where + toJSON SQLCloseResult {..} = + object ["succeeded" .= sqlCloseResultSucceeded] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/SQLStats.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/SQLStats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch1/Types/SQLStats.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch1.Types.SQLStats + ( SQLPluginStats (..), + ) +where + +import Data.Map.Strict qualified as Map +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The @GET /_plugins/_sql/stats@ endpoint (SQL plugin, see +-- ) +-- returns a JSON object whose keys are metric names (@request_total@, +-- @request_count@, @default_cursor_request_total@, +-- @default_cursor_request_count@, @failed_request_count_syserr@, +-- @failed_request_count_cuserr@, @failed_request_count_cb@, +-- @circuit_breaker@) and whose values are integers. The endpoint is +-- node-level only (the plugin explicitly documents that cluster-level +-- stats are not implemented), so unlike 'MLStats' there is no @nodes@ +-- sub-key and no cluster-level envelope — the body is one flat object +-- describing the node you hit. +-- +-- The metric-name set is large and grows across OpenSearch releases +-- (eight keys on 1.x; @ppl_*@, @datasource_*@, @async_query_*@, @emr_*@ +-- and @streaming_*@ keys land in later versions). Modelling the body as +-- a typed record would lock the client to one plugin version and +-- require churn on every release, so the body is kept as a flat +-- 'Map.Map Text Value' — callers get a typed envelope and navigate to +-- any individual metric with the aeson combinators they already use +-- elsewhere (e.g. @'Map.lookup' \"request_total\"@ followed by +-- @'fromJSON'@ into a 'Integer'). Every value the plugin emits today is +-- a JSON integer, but 'Value' is preferred over 'Integer' for forward +-- compatibility: if the plugin ever introduces a non-integer metric +-- (a string state, a floating-point ratio), the decoder does not need +-- to change. + +-- | Response of @GET /_plugins/_sql/stats@. The body is a flat JSON +-- object mapping metric names to integer values; see the module docs +-- for why the entries are kept as aeson 'Value's rather than modelled +-- per-metric. The 'Map.Map' round-trips a flat JSON object via its +-- aeson instances, so no custom 'ToJSON' \/ 'FromJSON' is needed. To +-- read an individual metric, decode the value with aeson, e.g.: +-- +-- @ +-- case 'Map.lookup' \"request_total\" (sqlPluginStatsEntries stats) of +-- 'Just' ('Number' n) -> ... n is a 'Scientific' ... +-- _ -> 'Nothing' +-- @ +newtype SQLPluginStats = SQLPluginStats + { sqlPluginStatsEntries :: Map.Map Text Value + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/Alerting.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/Alerting.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/Alerting.hs @@ -0,0 +1,2494 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.Alerting + ( -- * Identifiers + MonitorId (..), + DestinationId (..), + + -- * Discriminators + AlertType (..), + alertTypeText, + MonitorType (..), + monitorTypeText, + + -- * Schedule + Schedule (..), + SchedulePeriod (..), + ScheduleCron (..), + + -- * Inputs, triggers, actions + MonitorInput (..), + Trigger (..), + Action (..), + MessageTemplate (..), + Throttle (..), + AlertingShards (..), + + -- * Monitor and response wrappers + Monitor (..), + MonitorResponse (..), + DeleteMonitorResponse (..), + + -- * Monitor search (POST /_plugins/_alerting/monitors/_search) + MonitorsSearchQuery (..), + defaultMonitorsSearchQuery, + MonitorHit (..), + MonitorsTotal (..), + MonitorsTotalRelation (..), + monitorsTotalRelationText, + SearchMonitorsResponse (..), + searchMonitorsResponseMonitors, + + -- * Execute monitor (POST /_plugins/_alerting/monitors/{id}/_execute) + ExecuteMonitorRequest (..), + defaultExecuteMonitorRequest, + ExecuteMonitorResponse (..), + + -- * Destinations (GET /_plugins/_alerting/destinations) + DestinationType (..), + destinationTypeText, + Destination (..), + DestinationSortOrder (..), + destinationSortOrderText, + DestinationListOptions (..), + defaultDestinationListOptions, + destinationListOptionsParams, + GetDestinationsResponse (..), + + -- * Destination lifecycle (POST/PUT/DELETE /_plugins/_alerting/destinations[/{id}]) + DestinationResponse (..), + DeleteDestinationResponse (..), + + -- * Get alerts (GET /_plugins/_alerting/monitors/alerts) + AlertSortOrder (..), + alertSortOrderText, + AlertState (..), + alertStateText, + GetAlertsOptions (..), + defaultGetAlertsOptions, + getAlertsOptionsParams, + Alert (..), + GetAlertsResponse (..), + + -- * Acknowledge alert (POST /_plugins/_alerting/monitors/{id}/_acknowledge/alerts) + AcknowledgeAlertRequest (..), + defaultAcknowledgeAlertRequest, + AcknowledgeAlertResponse (..), + + -- * Monitor stats (GET /_plugins/_alerting/stats[/...]) + MonitorStats (..), + MonitorStatsNodesCount (..), + + -- * Email account lifecycle (POST/PUT/GET/DELETE /_plugins/_alerting/destinations/email_accounts[/{id}]) + EmailAccountId (..), + EmailAccount (..), + EmailAccountResponse (..), + DeleteEmailAccountResponse (..), + + -- * Email group lifecycle (POST/PUT/GET/DELETE /_plugins/_alerting/destinations/email_groups[/{id}]) + EmailGroupId (..), + EmailGroupRecipient (..), + EmailGroup (..), + EmailGroupResponse (..), + DeleteEmailGroupResponse (..), + + -- * Email account search (POST /_plugins/_alerting/destinations/email_accounts/_search) + EmailAccountSearchQuery (..), + defaultEmailAccountSearchQuery, + EmailAccountSearchHit (..), + SearchEmailAccountsResponse (..), + + -- * Email group search (POST /_plugins/_alerting/destinations/email_groups/_search) + EmailGroupSearchQuery (..), + defaultEmailGroupSearchQuery, + EmailGroupSearchHit (..), + SearchEmailGroupsResponse (..), + + -- * Findings search (GET /_plugins/_alerting/findings/_search) + FindingsSearchOptions (..), + defaultFindingsSearchOptions, + findingsSearchOptionsParams, + SearchFindingsResponse (..), + + -- * Comments API (POST/PUT/GET/DELETE /_plugins/_alerting/comments[/{id}]) + CommentId (..), + Comment (..), + CreateCommentRequest (..), + UpdateCommentRequest (..), + CommentResponse (..), + CommentSearchQuery (..), + defaultCommentSearchQuery, + CommentSearchHit (..), + SearchCommentsResponse (..), + DeleteCommentResponse (..), + + -- * Internal helpers (re-exported for the test suite) + alertingTriggerWrapperKeys, + ) +where + +import Data.Aeson +import Data.Aeson.Key qualified as K (fromText) +import Data.Aeson.KeyMap qualified as KM +import Data.Int (Int64) +import Database.Bloodhound.Internal.Utils.Imports +import Numeric.Natural (Natural) + +-- $schema +-- +-- The Alerting plugin (see +-- ) +-- runs scheduled monitors over cluster data and dispatches actions +-- (notifications) to destinations when trigger conditions fire. This +-- module covers the monitor lifecycle endpoints +-- (@POST \/\/_plugins\/_alerting\/monitors@ etc.) for OpenSearch 2.x. +-- +-- The wire shape of a 'Monitor' is a discriminated object: the +-- @monitor_type@ field selects one of several execution models +-- (query-level, bucket-level, document-level, cluster-metrics, remote), +-- and the @inputs@ and @triggers@ arrays carry per-kind payloads whose +-- exact shape varies widely. Following the pragmatic precedent set by +-- the ML Commons @predict@ endpoint, this module types the /shell/ — +-- the stable fields common to every monitor (name, enabled, schedule, +-- trigger names\/severities, action destination ids) — and models the +-- per-kind payloads as opaque aeson 'Value's. This keeps the public +-- surface small and stable while letting callers construct and inspect +-- any monitor kind, including ones the docs page does not enumerate. +-- Unknown top-level keys are preserved verbatim in 'monitorOther' so +-- future plugin additions and the @ui_metadata@\/@metadata@ fields +-- round-trip cleanly. +-- +-- The three response wrappers are modelled distinctly because they are +-- distinct on the wire: +-- +-- * 'MonitorResponse' wraps the create\/update response +-- (@{_id,_version,_seq_no,_primary_term, monitor:{...}}@). +-- * A bare 'Monitor' is the get-monitor response body (the @monitor@ +-- field is unwrapped by the 'FromJSON' instance of the endpoint +-- wrapper — see 'getMonitor'). +-- * 'DeleteMonitorResponse' mirrors the standard Elasticsearch +-- delete-document response. It deliberately deviates from the bead's +-- @m 'Acknowledged'@ acceptance (the endpoint returns @_shards@, not +-- @acknowledged@ — see the Haddock on 'DeleteMonitorResponse' and the +-- changelog entry for bloodhound-04f.6.7.4). +-- +-- Doc-level monitors were introduced in OpenSearch 2.0, so OS 1.x +-- callers must not construct 'MonitorTypeDocLevel'; the type still +-- carries the constructor because the wire grammar is identical. + +-- | The server-assigned identifier of a monitor. Wraps 'Text' so it +-- round-trips as a bare JSON string but stays distinct from +-- 'Database.Bloodhound.Common.Types.IndexName' and friends at the type +-- level. +newtype MonitorId = MonitorId {unMonitorId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The server-assigned identifier of an alerting destination. Wraps +-- 'Text' so it round-trips as a bare JSON string but stays distinct +-- from 'MonitorId' and 'Database.Bloodhound.Common.Types.IndexName' at +-- the type level. Used by the update\/delete destination endpoints +-- (@PUT@\/@DELETE /_plugins/_alerting/destinations/{id}@). +newtype DestinationId = DestinationId {unDestinationId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The top-level @type@ field of a monitor document. Documented as the +-- constant @"monitor"@ for non-composite monitors (composite monitors +-- use @"workflow"@ and live behind a separate API not covered here). +-- Unknown values fall through to 'AlertTypeOther' rather than +-- parse-failing, because the field is informational on requests and the +-- server is the authority. +data AlertType + = AlertTypeMonitor + | AlertTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for an 'AlertType'. +alertTypeText :: AlertType -> Text +alertTypeText AlertTypeMonitor = "monitor" +alertTypeText (AlertTypeOther t) = t + +instance ToJSON AlertType where + toJSON = toJSON . alertTypeText + +instance FromJSON AlertType where + parseJSON = withText "AlertType" $ \case + "monitor" -> pure AlertTypeMonitor + other -> pure (AlertTypeOther other) + +-- | The @monitor_type@ discriminator selecting the monitor's execution +-- model. The three documented on the API page are given dedicated +-- constructors; @cluster_metrics@, @remote@, and any future kind fall +-- through to 'MonitorTypeOther'. 'monitorTypeText' round-trips every +-- constructor. +data MonitorType + = MonitorTypeQueryLevel + | MonitorTypeBucketLevel + | MonitorTypeDocLevel + | MonitorTypeClusterMetrics + | MonitorTypeRemote + | MonitorTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'MonitorType'. Values are the lower-snake forms +-- documented at +-- . +monitorTypeText :: MonitorType -> Text +monitorTypeText = \case + MonitorTypeQueryLevel -> "query_level_monitor" + MonitorTypeBucketLevel -> "bucket_level_monitor" + MonitorTypeDocLevel -> "doc_level_monitor" + MonitorTypeClusterMetrics -> "cluster_metrics_monitor" + MonitorTypeRemote -> "remote_monitor" + MonitorTypeOther t -> t + +instance ToJSON MonitorType where + toJSON = toJSON . monitorTypeText + +instance FromJSON MonitorType where + parseJSON = + withText "MonitorType" $ \t -> + pure $ + case t of + "query_level_monitor" -> MonitorTypeQueryLevel + "bucket_level_monitor" -> MonitorTypeBucketLevel + "doc_level_monitor" -> MonitorTypeDocLevel + "cluster_metrics_monitor" -> MonitorTypeClusterMetrics + "remote_monitor" -> MonitorTypeRemote + other -> MonitorTypeOther other + +-- | The @schedule@ sub-object. The API documents two variants +-- (@period {interval, unit}@ and @cron {expression, timezone}@); any +-- other shape (e.g. a future schedule kind) is preserved verbatim via +-- 'ScheduleOther' so a decode never drops user data. +data Schedule + = PeriodSchedule SchedulePeriod + | CronSchedule ScheduleCron + | OtherSchedule Value + deriving stock (Eq, Show) + +instance ToJSON Schedule where + toJSON = \case + PeriodSchedule p -> object ["period" .= p] + CronSchedule c -> object ["cron" .= c] + OtherSchedule v -> v + +instance FromJSON Schedule where + parseJSON = withObject "Schedule" $ \o -> + (PeriodSchedule <$> o .: "period") + <|> (CronSchedule <$> o .: "cron") + <|> pure (OtherSchedule (Object o)) + +-- | The @period@ schedule variant. @unit@ is an upper-case string such +-- as @"MINUTES"@; the docs only enumerate @MINUTES@ in examples, so the +-- field is typed as 'Text' (not a closed enum) to avoid a library +-- release when OpenSearch advertises another unit. +data SchedulePeriod = SchedulePeriod + { schedulePeriodInterval :: Int, + schedulePeriodUnit :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SchedulePeriod where + toJSON SchedulePeriod {..} = + object + [ "interval" .= schedulePeriodInterval, + "unit" .= schedulePeriodUnit + ] + +instance FromJSON SchedulePeriod where + parseJSON = withObject "SchedulePeriod" $ \o -> + SchedulePeriod + <$> o .: "interval" + <*> o .: "unit" + +-- | The @cron@ schedule variant. @expression@ is a cron expression, +-- @timezone@ is a Java @ZoneId@ (e.g. @"America/Los_Angeles"@). +data ScheduleCron = ScheduleCron + { scheduleCronExpression :: Text, + scheduleCronTimezone :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON ScheduleCron where + toJSON ScheduleCron {..} = + omitNulls + [ "expression" .= scheduleCronExpression, + "timezone" .= scheduleCronTimezone + ] + +instance FromJSON ScheduleCron where + parseJSON = withObject "ScheduleCron" $ \o -> + ScheduleCron + <$> o .: "expression" + <*> o .:? "timezone" + +-- | A single element of the @inputs@ array. The shape varies by monitor +-- kind (@search@ for query\/bucket-level, @doc_level_input@ for +-- document-level, @clusters@ for cluster-metrics, ...), so the payload +-- is kept as an opaque 'Value' and callers decode it with their own +-- kind-specific parser. This mirrors the ML Commons @predict@ precedent. +newtype MonitorInput = MonitorInput {unMonitorInput :: Value} + deriving stock (Eq, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A @message_template@ \/ @subject_template@ sub-object. The server +-- injects @"lang": "mustache"@ on responses even when the request omits +-- it; both directions round-trip here. +data MessageTemplate = MessageTemplate + { messageTemplateSource :: Text, + messageTemplateLang :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON MessageTemplate where + toJSON MessageTemplate {..} = + omitNulls + [ "source" .= messageTemplateSource, + "lang" .= messageTemplateLang + ] + +instance FromJSON MessageTemplate where + parseJSON = withObject "MessageTemplate" $ \o -> + MessageTemplate + <$> o .: "source" + <*> o .:? "lang" + +-- | A @throttle@ sub-object (@{value, unit}@). Present on every action +-- response regardless of the @throttle_enabled@ flag. +data Throttle = Throttle + { throttleValue :: Int, + throttleUnit :: Text + } + deriving stock (Eq, Show) + +instance ToJSON Throttle where + toJSON Throttle {..} = + object + [ "value" .= throttleValue, + "unit" .= throttleUnit + ] + +instance FromJSON Throttle where + parseJSON = withObject "Throttle" $ \o -> + Throttle + <$> o .: "value" + <*> o .: "unit" + +-- | A single action within a trigger. The typed fields are those +-- documented across every action shape; the @action_execution_policy@ +-- sub-object (whose @action_execution_scope@ varies between +-- @per_alert@\/@per_action@ and carries @actionable_alerts@ enums) is +-- kept as an opaque 'Value', as is any forward-compat key in +-- 'actionOther'. +data Action = Action + { actionName :: Text, + actionDestinationId :: Text, + actionMessageTemplate :: MessageTemplate, + actionSubjectTemplate :: Maybe MessageTemplate, + actionThrottleEnabled :: Maybe Bool, + actionThrottle :: Maybe Throttle, + actionExecutionPolicy :: Maybe Value, + actionOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON Action where + toJSON a = + case actionOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= actionName a, + "destination_id" .= actionDestinationId a, + "message_template" .= actionMessageTemplate a, + "subject_template" .= actionSubjectTemplate a, + "throttle_enabled" .= actionThrottleEnabled a, + "throttle" .= actionThrottle a, + "action_execution_policy" .= actionExecutionPolicy a + ] + +instance FromJSON Action where + parseJSON = withObject "Action" $ \o -> do + Action + <$> o .: "name" + <*> o .: "destination_id" + <*> o .: "message_template" + <*> o .:? "subject_template" + <*> o .:? "throttle_enabled" + <*> o .:? "throttle" + <*> o .:? "action_execution_policy" + <*> pure (Object o) + +-- | The set of wrapper keys the Alerting plugin uses to discriminate +-- non-query-level triggers inside the @triggers@ array. Query-level +-- triggers carry their fields directly on the element; bucket-level and +-- document-level triggers wrap them under exactly one of these keys. +-- Re-exported so the test suite can pin the set. +alertingTriggerWrapperKeys :: [Text] +alertingTriggerWrapperKeys = ["bucket_level_trigger", "document_level_trigger"] + +-- | A single trigger. The wire shape differs by monitor kind: query-level +-- triggers put the fields directly on the element, while bucket-level +-- and document-level triggers wrap them under a discriminator key (see +-- 'alertingTriggerWrapperKeys'). The 'FromJSON' instance transparently +-- descends into the wrapper when present, so the typed fields are +-- readable uniformly; the full original element (wrapper and all) is +-- preserved in 'triggerOther' so a round-trip encode is lossless. +-- +-- @triggerSeverity@ is a 'Text' rather than an 'Int' because the wire +-- emits a string-encoded integer (e.g. @"1"@); parsing it as a number +-- would silently drop real monitor documents. +-- +-- @triggerCondition@ is an opaque 'Value' because the condition body +-- varies by trigger kind (@script {source, lang}@ for query-level; +-- @buckets_path@ + @parent_bucket_path@ + @script@ for bucket-level). +data Trigger = Trigger + { triggerName :: Text, + triggerSeverity :: Text, + triggerCondition :: Value, + triggerActions :: [Action], + triggerOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON Trigger where + toJSON t = + case triggerOther t of + Object o + | (wrapperKey, Object body) : _ <- wrappedBodies o -> + -- Captured element carried a discriminator wrapper key + -- (bucket-level / document-level). Re-inject the typed fields + -- into the wrapper body so caller modifications survive a + -- round-trip, and keep the wrapper as the sole top-level key + -- (matching the wire shape). + Object (KM.insert wrapperKey (Object (mergeIgnoringNulls typed body)) (deleteSeveral [wrapperKey] o)) + | otherwise -> + -- Query-level trigger: fields live directly on the element. + -- Overlay the typed fields on the captured object. + Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= triggerName t, + "severity" .= triggerSeverity t, + "condition" .= triggerCondition t, + "actions" .= triggerActions t + ] + wrappedBodies o = + [ (wk, v) + | k <- alertingTriggerWrapperKeys, + let wk = K.fromText k, + Just v <- [KM.lookup wk o] + ] + +instance FromJSON Trigger where + parseJSON = withObject "Trigger" $ \o' -> do + let body = unwrapTrigger o' + Trigger + <$> body .: "name" + <*> body .: "severity" + <*> body .: "condition" + <*> body .:? "actions" .!= [] + <*> pure (Object o') + where + unwrapTrigger o = + case catMaybes (mapMaybeWrapper o) of + (inner : _) -> inner + [] -> o + mapMaybeWrapper o = + [ KM.lookup (K.fromText k) o >>= (\case Object ob -> Just ob; _ -> Nothing) + | k <- alertingTriggerWrapperKeys + ] + +-- | The top-level 'Monitor' document. Typed fields cover every key the +-- API documents on requests and responses; 'monitorOther' captures the +-- whole original object so @ui_metadata@, @metadata@, future plugin +-- keys, and any field this type does not yet model round-trip +-- losslessly (mirrors the 'PendingTask' precedent). +data Monitor = Monitor + { monitorName :: Text, + monitorType :: Maybe AlertType, + monitorMonitorType :: Maybe MonitorType, + monitorEnabled :: Maybe Bool, + monitorEnabledTime :: Maybe Int64, + monitorLastUpdateTime :: Maybe Int64, + monitorSchemaVersion :: Maybe Int, + monitorSchedule :: Schedule, + monitorInputs :: [MonitorInput], + monitorTriggers :: [Trigger], + monitorUser :: Maybe Value, + monitorRbacRoles :: Maybe [Text], + monitorOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON Monitor where + toJSON m = + case monitorOther m of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= monitorName m, + "type" .= monitorType m, + "monitor_type" .= monitorMonitorType m, + "enabled" .= monitorEnabled m, + "enabled_time" .= monitorEnabledTime m, + "last_update_time" .= monitorLastUpdateTime m, + "schema_version" .= monitorSchemaVersion m, + "schedule" .= monitorSchedule m, + "inputs" .= monitorInputs m, + "triggers" .= monitorTriggers m, + "user" .= monitorUser m, + "rbac_roles" .= monitorRbacRoles m + ] + +instance FromJSON Monitor where + parseJSON = withObject "Monitor" $ \o -> + Monitor + <$> o .: "name" + <*> o .:? "type" + <*> o .:? "monitor_type" + <*> o .:? "enabled" + <*> o .:? "enabled_time" + <*> o .:? "last_update_time" + <*> o .:? "schema_version" + <*> o .: "schedule" + <*> o .:? "inputs" .!= [] + <*> o .:? "triggers" .!= [] + <*> o .:? "user" + <*> o .:? "rbac_roles" + <*> pure (Object o) + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/monitors[\/{id}]@. Carries the indexing metadata +-- alongside the persisted monitor document. +data MonitorResponse = MonitorResponse + { monitorResponseId :: Text, + monitorResponseVersion :: Int64, + monitorResponseSeqNo :: Int64, + monitorResponsePrimaryTerm :: Int64, + monitorResponseMonitor :: Monitor + } + deriving stock (Eq, Show) + +instance FromJSON MonitorResponse where + parseJSON = withObject "MonitorResponse" $ \o -> + MonitorResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "monitor" + +instance ToJSON MonitorResponse where + toJSON MonitorResponse {..} = + object + [ "_id" .= monitorResponseId, + "_version" .= monitorResponseVersion, + "_seq_no" .= monitorResponseSeqNo, + "_primary_term" .= monitorResponsePrimaryTerm, + "monitor" .= monitorResponseMonitor + ] + +-- | The @_shards@ sub-object of 'DeleteMonitorResponse'. Modelled +-- locally rather than reusing +-- "Database.Bloodhound.Internal.Versions.Common.Types.Nodes".'ShardsResult' +-- because that type wraps the outer @{"_shards": {...}}@ envelope (one +-- level too high for inline use here), and keeping the local shape +-- avoids widening the export surface of the Common types for this +-- single-purpose borrow. +data AlertingShards = AlertingShards + { alertingShardsTotal :: Int, + alertingShardsSuccessful :: Int, + alertingShardsSkipped :: Int, + alertingShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON AlertingShards where + parseJSON = withObject "AlertingShards" $ \o -> + AlertingShards + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "skipped" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON AlertingShards where + toJSON AlertingShards {..} = + object + [ "total" .= alertingShardsTotal, + "successful" .= alertingShardsSuccessful, + "skipped" .= alertingShardsSkipped, + "failed" .= alertingShardsFailed + ] + +-- | Response shape for @DELETE /_plugins/_alerting/monitors/{id}@. +-- +-- Deviates from the bead's @m 'Acknowledged'@ acceptance: the body +-- never carries an @acknowledged@ key, so an 'Acknowledged' decoder +-- would raise 'EsProtocolException' at runtime (same deviation pattern +-- as bloodhound-04f.3.13 rethrottle). +-- +-- The exact shape is version-dependent (live-verified in bead +-- bloodhound-z5j on OS 1.3.19, 2.19.5 and 3.7.0): +-- +-- * OS 1.3.x returns the full bare Elasticsearch delete-document +-- response — @_index@, @_type@, @_id@, @_version@, @result@, +-- @forced_refresh@, @_shards@, @_seq_no@, @_primary_term@. +-- * OS 2.x and 3.x return a minimal @_id@ + @_version@ envelope; the +-- indexing-metadata fields (@_index@, @result@, @_shards@, +-- @_seq_no@, ...) are omitted entirely. +-- +-- Only @_id@ and @_version@ are present on every version, so they are +-- the sole required fields; the rest are 'Maybe' and decode as +-- 'Nothing' on OS 2.x\/3.x. +data DeleteMonitorResponse = DeleteMonitorResponse + { deleteMonitorResponseId :: Text, + deleteMonitorResponseVersion :: Int64, + deleteMonitorResponseIndex :: Maybe Text, + deleteMonitorResponseResult :: Maybe Text, + deleteMonitorResponseForcedRefresh :: Maybe Bool, + deleteMonitorResponseShards :: Maybe AlertingShards, + deleteMonitorResponseSeqNo :: Maybe Int64, + deleteMonitorResponsePrimaryTerm :: Maybe Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteMonitorResponse where + parseJSON = withObject "DeleteMonitorResponse" $ \o -> + DeleteMonitorResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .:? "_index" + <*> o .:? "result" + <*> o .:? "forced_refresh" + <*> o .:? "_shards" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + +instance ToJSON DeleteMonitorResponse where + toJSON DeleteMonitorResponse {..} = + omitNulls + [ "_id" .= deleteMonitorResponseId, + "_version" .= deleteMonitorResponseVersion, + "_index" .= deleteMonitorResponseIndex, + "result" .= deleteMonitorResponseResult, + "forced_refresh" .= deleteMonitorResponseForcedRefresh, + "_shards" .= deleteMonitorResponseShards, + "_seq_no" .= deleteMonitorResponseSeqNo, + "_primary_term" .= deleteMonitorResponsePrimaryTerm + ] + +-- ========================================================================= +-- Destinations: GET /_plugins/_alerting/destinations +-- ========================================================================= +-- +-- The Alerting plugin's destinations API is the legacy notification +-- surface that pre-dates the Notifications plugin (covered separately +-- in "OpenSearchN.Types.Notifications"). A destination is a typed +-- notification target: a Slack incoming webhook, a Chime webhook, a +-- custom webhook, or an email account. Monitors reference destinations +-- by id via the @destination_id@ field on each 'Action'. The +-- @GET /_plugins/_alerting/destinations@ endpoint lists configured +-- destinations; the OpenSearch docs +-- () +-- document the wire shape. +-- +-- The destination record follows the same pragmatic pattern used by +-- 'Monitor' in this module: typed shell for the stable, common fields +-- (@id@, @type@, @name@, @schema_version@, @seq_no@, @primary_term@, +-- @last_update_time@, optional @user@) plus an opaque aeson 'Value' for +-- the per-type sub-object (the @slack@ \/ @chime@ \/ @custom_webhook@ +-- \/ @email@ key whose name matches the @type@ discriminator). The +-- shape of that sub-object varies by type and the docs do not fully +-- enumerate every variant, so it is kept opaque; callers decode it +-- with their own type-specific parser. The full original object is +-- captured in 'destinationOther' so unknown top-level keys round-trip +-- losslessly (same approach as 'monitorOther'). + +-- | The @type@ discriminator of a destination. The five values +-- enumerated by the @DestinationType@ enum in the plugin source are +-- given dedicated constructors; any future value falls through to +-- 'DestinationTypeOther' rather than parse-failing, because the field +-- is informational on requests and the server is the authority. +data DestinationType + = DestinationTypeSlack + | DestinationTypeChime + | DestinationTypeCustomWebhook + | DestinationTypeEmail + | DestinationTypeTestAction + | DestinationTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'DestinationType'. +destinationTypeText :: DestinationType -> Text +destinationTypeText = \case + DestinationTypeSlack -> "slack" + DestinationTypeChime -> "chime" + DestinationTypeCustomWebhook -> "custom_webhook" + DestinationTypeEmail -> "email" + DestinationTypeTestAction -> "test_action" + DestinationTypeOther t -> t + +instance ToJSON DestinationType where + toJSON = toJSON . destinationTypeText + +instance FromJSON DestinationType where + parseJSON = withText "DestinationType" $ \t -> + pure $ + case t of + "slack" -> DestinationTypeSlack + "chime" -> DestinationTypeChime + "custom_webhook" -> DestinationTypeCustomWebhook + "email" -> DestinationTypeEmail + "test_action" -> DestinationTypeTestAction + other -> DestinationTypeOther other + +-- | A single destination record returned by +-- @GET /_plugins/_alerting/destinations@. The typed fields cover every +-- key the API documents on responses; 'destinationBody' carries the +-- per-type sub-object keyed by 'destinationTypeText' (so +-- 'DestinationTypeSlack' implies a @slack@ sub-object, +-- 'DestinationTypeEmail' implies an @email@ sub-object, etc.). The +-- @test_action@ type carries no sub-object; its 'destinationBody' is +-- 'Null' on decode and omitted on encode. 'destinationOther' captures +-- the whole original object so any forward-compat top-level key +-- round-trips losslessly (mirrors the 'monitorOther' precedent). +data Destination = Destination + { destinationId :: Text, + destinationType :: DestinationType, + destinationName :: Text, + destinationSchemaVersion :: Int, + destinationSeqNo :: Int64, + destinationPrimaryTerm :: Int64, + destinationLastUpdateTime :: Maybe Int64, + destinationUser :: Maybe Value, + destinationBody :: Value, + destinationOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON Destination where + parseJSON = withObject "Destination" $ \o -> do + destinationId <- o .: "id" + destinationType <- o .: "type" + destinationName <- o .: "name" + destinationSchemaVersion <- o .:? "schema_version" .!= 0 + destinationSeqNo <- o .:? "seq_no" .!= 0 + destinationPrimaryTerm <- o .:? "primary_term" .!= 0 + destinationLastUpdateTime <- o .:? "last_update_time" + destinationUser <- o .:? "user" + let typeKey = K.fromText (destinationTypeText destinationType) + destinationBody = maybe Null id (KM.lookup typeKey o) + pure Destination {destinationOther = Object o, ..} + +instance ToJSON Destination where + toJSON d = + case destinationOther d of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= destinationId d, + "type" .= destinationType d, + "name" .= destinationName d, + "schema_version" .= destinationSchemaVersion d, + "seq_no" .= destinationSeqNo d, + "primary_term" .= destinationPrimaryTerm d, + "last_update_time" .= destinationLastUpdateTime d, + "user" .= destinationUser d, + K.fromText (destinationTypeText (destinationType d)) .= destinationBody d + ] + +-- | Sort direction for @GET /_plugins/_alerting/destinations@. The +-- plugin docs only document @"asc"@ and @"desc"@. +data DestinationSortOrder + = DestinationSortOrderAsc + | DestinationSortOrderDesc + deriving stock (Eq, Show) + +-- | Wire string for a 'DestinationSortOrder'. +destinationSortOrderText :: DestinationSortOrder -> Text +destinationSortOrderText = \case + DestinationSortOrderAsc -> "asc" + DestinationSortOrderDesc -> "desc" + +-- | Query-string parameters accepted by +-- @GET /_plugins/_alerting/destinations@. Every field is optional; +-- 'defaultDestinationListOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. The server-side defaults when the +-- parameter is omitted are: @size=20@, @start_index=0@, +-- @sortString=destination.name.keyword@, @sortOrder=asc@, +-- @missing=null@, @searchString=""@, @destinationType=ALL@. +data DestinationListOptions = DestinationListOptions + { destinationListOptionsSize :: Maybe Natural, + destinationListOptionsStartIndex :: Maybe Natural, + destinationListOptionsSortString :: Maybe Text, + destinationListOptionsSortOrder :: Maybe DestinationSortOrder, + destinationListOptionsMissing :: Maybe Text, + destinationListOptionsSearchString :: Maybe Text, + destinationListOptionsDestinationType :: Maybe DestinationType + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the +-- plain @GET /_plugins/_alerting/destinations@ (server defaults apply) +-- when passed to 'getDestinationsWith'. +defaultDestinationListOptions :: DestinationListOptions +defaultDestinationListOptions = + DestinationListOptions + { destinationListOptionsSize = Nothing, + destinationListOptionsStartIndex = Nothing, + destinationListOptionsSortString = Nothing, + destinationListOptionsSortOrder = Nothing, + destinationListOptionsMissing = Nothing, + destinationListOptionsSearchString = Nothing, + destinationListOptionsDestinationType = Nothing + } + +-- | Render a 'DestinationListOptions' to the query-string pairs +-- accepted by the GET endpoint. Fields set to 'Nothing' are omitted +-- (not rendered with an empty value). The parameter names are +-- camelCase, matching the alerting plugin's @RestGetDestinationsAction@ +-- (note: the Notifications plugin uses snake_case for its sibling +-- parameters — these are distinct plugin surfaces and the casings +-- genuinely differ on the wire). +destinationListOptionsParams :: DestinationListOptions -> [(Text, Maybe Text)] +destinationListOptionsParams DestinationListOptions {..} = + catMaybes + [ (("size",) . Just . tshow) <$> destinationListOptionsSize, + (("start_index",) . Just . tshow) <$> destinationListOptionsStartIndex, + (("sortString",) . Just) <$> destinationListOptionsSortString, + (("sortOrder",) . Just . destinationSortOrderText) <$> destinationListOptionsSortOrder, + (("missing",) . Just) <$> destinationListOptionsMissing, + (("searchString",) . Just) <$> destinationListOptionsSearchString, + (("destinationType",) . Just . destinationTypeText) <$> destinationListOptionsDestinationType + ] + +-- | Envelope returned by @GET /_plugins/_alerting/destinations@. +-- @totalDestinations@ is the total hit count matching the query (not +-- the size of @destinations@, which is the current page constrained by +-- the @size@ \/ @start_index@ parameters); @destinations@ is the +-- current page of records. The paging metadata is decoded for +-- completeness but discarded by the public 'getDestinations' wrapper, +-- which returns only the @destinations@ list. +data GetDestinationsResponse = GetDestinationsResponse + { getDestinationsResponseTotalDestinations :: Int, + getDestinationsResponseDestinations :: [Destination] + } + deriving stock (Eq, Show) + +instance FromJSON GetDestinationsResponse where + parseJSON = withObject "GetDestinationsResponse" $ \o -> do + getDestinationsResponseTotalDestinations <- o .:? "totalDestinations" .!= 0 + getDestinationsResponseDestinations <- o .:? "destinations" .!= [] + pure GetDestinationsResponse {..} + +instance ToJSON GetDestinationsResponse where + toJSON GetDestinationsResponse {..} = + object + [ "totalDestinations" .= getDestinationsResponseTotalDestinations, + "destinations" .= getDestinationsResponseDestinations + ] + +-- ========================================================================= +-- Monitor search: POST /_plugins/_alerting/monitors/_search +-- ========================================================================= +-- +-- The Alerting plugin exposes the monitor store as a regular +-- OpenSearch index (@.opendistro-allocator-config@ \/ +-- @.opensearch-scheduled-jobs@, depending on version), so the search +-- endpoint takes the standard OpenSearch query DSL and returns the +-- standard search envelope. The 'MonitorsSearchQuery' body mirrors the +-- 'SARulesQuery' shape (opaque @query@ DSL plus @from@ \/ @size@ +-- pagination); the 'SearchMonitorsResponse' envelope mirrors +-- 'SARulesSearchResponse'. Each hit's @_source@ is a bare 'Monitor' +-- (the indexed document source — no @monitor@ wrapper, unlike the +-- create\/update response). + +-- | Optional query body for 'searchMonitors'. The @from@ \/ @size@ +-- pair is the standard OpenSearch pagination cursor; @query@ is the +-- standard OpenSearch query DSL, kept opaque because its shape varies +-- by use case (term match on @monitor.name@, range on +-- @enabled_time@, ...). Pass 'Nothing' to 'searchMonitors' (or +-- 'defaultMonitorsSearchQuery' to the body renderer) for the plain +-- empty-body @{}@ POST that returns the first page of all monitors. +data MonitorsSearchQuery = MonitorsSearchQuery + { monitorsSearchQueryFrom :: Maybe Int, + monitorsSearchQuerySize :: Maybe Int, + monitorsSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultMonitorsSearchQuery :: MonitorsSearchQuery +defaultMonitorsSearchQuery = MonitorsSearchQuery Nothing Nothing Nothing + +instance ToJSON MonitorsSearchQuery where + toJSON MonitorsSearchQuery {..} = + omitNulls + [ "from" .= monitorsSearchQueryFrom, + "size" .= monitorsSearchQuerySize, + "query" .= monitorsSearchQueryQuery + ] + +instance FromJSON MonitorsSearchQuery where + parseJSON = withObject "MonitorsSearchQuery" $ \o -> + MonitorsSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "query" + +-- | The @hits.total.relation@ discriminator on a monitor search +-- response. OpenSearch documents @"eq"@ (exact count) and @"ge"@ +-- (lower bound, when @track_total_hits@ is false); any future value +-- falls through to 'MonitorsTotalRelationOther' rather than +-- parse-failing. +data MonitorsTotalRelation + = MonitorsTotalRelationEq + | MonitorsTotalRelationGe + | MonitorsTotalRelationOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'MonitorsTotalRelation'. +monitorsTotalRelationText :: MonitorsTotalRelation -> Text +monitorsTotalRelationText = \case + MonitorsTotalRelationEq -> "eq" + MonitorsTotalRelationGe -> "ge" + MonitorsTotalRelationOther t -> t + +instance ToJSON MonitorsTotalRelation where + toJSON = toJSON . monitorsTotalRelationText + +instance FromJSON MonitorsTotalRelation where + parseJSON = withText "MonitorsTotalRelation" $ \t -> + pure $ + case t of + "eq" -> MonitorsTotalRelationEq + "ge" -> MonitorsTotalRelationGe + other -> MonitorsTotalRelationOther other + +-- | The @hits.total@ sub-object on a monitor search response +-- (@{value, relation}@). +data MonitorsTotal = MonitorsTotal + { monitorsTotalValue :: Int64, + monitorsTotalRelation :: MonitorsTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON MonitorsTotal where + parseJSON = withObject "MonitorsTotal" $ \o -> + MonitorsTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON MonitorsTotal where + toJSON MonitorsTotal {..} = + object + [ "value" .= monitorsTotalValue, + "relation" .= monitorsTotalRelation + ] + +-- | A single hit in @hits.hits[]@ on a monitor search response. The +-- typed fields mirror the standard search-hit envelope; the @_source@ +-- is decoded as a bare 'Monitor' (the indexed document source). +data MonitorHit = MonitorHit + { monitorHitIndex :: Maybe Text, + monitorHitId :: Text, + monitorHitVersion :: Maybe Int64, + monitorHitSeqNo :: Maybe Int64, + monitorHitPrimaryTerm :: Maybe Int64, + monitorHitScore :: Maybe Double, + monitorHitSource :: Monitor + } + deriving stock (Eq, Show) + +instance FromJSON MonitorHit where + parseJSON = withObject "MonitorHit" $ \o -> + MonitorHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON MonitorHit where + toJSON MonitorHit {..} = + omitNulls + [ "_index" .= monitorHitIndex, + "_id" .= monitorHitId, + "_version" .= monitorHitVersion, + "_seq_no" .= monitorHitSeqNo, + "_primary_term" .= monitorHitPrimaryTerm, + "_score" .= monitorHitScore, + "_source" .= monitorHitSource + ] + +-- | Response envelope for 'searchMonitors'. Decoded verbatim from the +-- standard OpenSearch search-response shape; the paging metadata +-- (@took@, @timed_out@, @_shards@, @hits.total@, @hits.max_score@) is +-- preserved alongside the monitor list so callers can drive pagination +-- and observe shard health. The @_shards@ sub-object reuses the local +-- 'AlertingShards' (the standard @{total,successful,skipped,failed}@ +-- shape already modelled for 'DeleteMonitorResponse'). +data SearchMonitorsResponse = SearchMonitorsResponse + { searchMonitorsResponseTook :: Int64, + searchMonitorsResponseTimedOut :: Bool, + searchMonitorsResponseShards :: AlertingShards, + searchMonitorsResponseTotal :: MonitorsTotal, + searchMonitorsResponseMaxScore :: Maybe Double, + searchMonitorsResponseHits :: [MonitorHit] + } + deriving stock (Eq, Show) + +instance FromJSON SearchMonitorsResponse where + parseJSON = withObject "SearchMonitorsResponse" $ \o -> do + hits <- o .: "hits" + SearchMonitorsResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SearchMonitorsResponse where + toJSON SearchMonitorsResponse {..} = + object + [ "took" .= searchMonitorsResponseTook, + "timed_out" .= searchMonitorsResponseTimedOut, + "_shards" .= searchMonitorsResponseShards, + "hits" + .= object + [ "total" .= searchMonitorsResponseTotal, + "max_score" .= searchMonitorsResponseMaxScore, + "hits" .= searchMonitorsResponseHits + ] + ] + +-- | Project the decoded 'Monitor' list out of a 'SearchMonitorsResponse' +-- (convenience for callers who only want the monitors and not the +-- paging envelope). +searchMonitorsResponseMonitors :: SearchMonitorsResponse -> [Monitor] +searchMonitorsResponseMonitors = map monitorHitSource . searchMonitorsResponseHits + +-- ========================================================================= +-- Execute monitor: POST /_plugins/_alerting/monitors/{id}/_execute +-- ========================================================================= +-- +-- The execute endpoint runs a monitor's inputs and triggers immediately +-- (out of schedule) and returns the per-trigger execution result. The +-- response shape varies widely by monitor kind (@trigger_results@ is a +-- map keyed by trigger name whose value differs for query-level, +-- bucket-level, and document-level triggers; @input_results@ carries +-- the search response the monitor ran against). Following the ML +-- Commons @predict@ precedent, the stable shell fields +-- (@monitor_name@, @period_start@, @period_end@, @dry_run@) are typed +-- and the variable result sub-objects are kept as opaque aeson +-- 'Value's so any monitor kind round-trips losslessly. + +-- | Optional request parameters for 'executeMonitor'. @dryrun@ (default +-- 'False' on the server) skips dispatching actions to destinations; it +-- is sent as the @?dryrun=true@ query parameter (the @_execute@ +-- endpoint takes no request body). Pass 'Nothing' to 'executeMonitor' +-- (or 'defaultExecuteMonitorRequest') for a real execution with action +-- dispatch. +data ExecuteMonitorRequest = ExecuteMonitorRequest + { executeMonitorRequestDryrun :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | The empty request: a real execution with action dispatch (no +-- @?dryrun@ query parameter). +defaultExecuteMonitorRequest :: ExecuteMonitorRequest +defaultExecuteMonitorRequest = ExecuteMonitorRequest Nothing + +instance ToJSON ExecuteMonitorRequest where + toJSON ExecuteMonitorRequest {..} = + omitNulls ["dryrun" .= executeMonitorRequestDryrun] + +instance FromJSON ExecuteMonitorRequest where + parseJSON = withObject "ExecuteMonitorRequest" $ \o -> + ExecuteMonitorRequest <$> o .:? "dryrun" + +-- | Response shape for @POST /_plugins/_alerting/monitors/{id}/_execute@. +-- The typed shell carries the stable fields every execution result +-- shares; @trigger_results@, @input_results@, and @script_actions@ are +-- kept as opaque aeson 'Value's because their shape varies by monitor +-- kind and trigger type (mirrors the ML Commons @predict@ precedent). +-- The full original object is captured in 'executeMonitorResponseOther' +-- so any forward-compat key round-trips losslessly. +data ExecuteMonitorResponse = ExecuteMonitorResponse + { executeMonitorResponseMonitorName :: Maybe Text, + executeMonitorResponsePeriodStart :: Maybe Int64, + executeMonitorResponsePeriodEnd :: Maybe Int64, + executeMonitorResponseDryRun :: Maybe Bool, + executeMonitorResponseTriggerResults :: Maybe Value, + executeMonitorResponseInputResults :: Maybe Value, + executeMonitorResponseScriptActions :: Maybe Value, + executeMonitorResponseOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON ExecuteMonitorResponse where + parseJSON = withObject "ExecuteMonitorResponse" $ \o -> + ExecuteMonitorResponse + <$> o .:? "monitor_name" + <*> o .:? "period_start" + <*> o .:? "period_end" + <*> o .:? "dry_run" + <*> o .:? "trigger_results" + <*> o .:? "input_results" + <*> o .:? "script_actions" + <*> pure (Object o) + +instance ToJSON ExecuteMonitorResponse where + toJSON r = + case executeMonitorResponseOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "monitor_name" .= executeMonitorResponseMonitorName r, + "period_start" .= executeMonitorResponsePeriodStart r, + "period_end" .= executeMonitorResponsePeriodEnd r, + "dry_run" .= executeMonitorResponseDryRun r, + "trigger_results" .= executeMonitorResponseTriggerResults r, + "input_results" .= executeMonitorResponseInputResults r, + "script_actions" .= executeMonitorResponseScriptActions r + ] + +-- ========================================================================= +-- Destination lifecycle: POST/PUT/DELETE /_plugins/_alerting/destinations[/{id}] +-- ========================================================================= +-- +-- The create and update destination endpoints take a 'Destination' as +-- the request body (the server assigns @id@, @schema_version@, +-- @seq_no@, @primary_term@ on write) and return the +-- 'DestinationResponse' wrapper (@{_id,_version,_seq_no,_primary_term, +-- destination:{...}}@) — the destination analogue of 'MonitorResponse'. +-- The delete endpoint returns the standard Elasticsearch +-- delete-document response (bare, no @acknowledged@ key, with a +-- @_shards@ report), modelled distinctly as 'DeleteDestinationResponse' +-- for the same reason as 'DeleteMonitorResponse' (an 'Acknowledged' +-- decoder would raise 'EsProtocolException' at runtime). + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/destinations[/{id}]@. Carries the indexing +-- metadata alongside the persisted destination document. Mirrors +-- 'MonitorResponse'. +data DestinationResponse = DestinationResponse + { destinationResponseId :: Text, + destinationResponseVersion :: Int64, + destinationResponseSeqNo :: Int64, + destinationResponsePrimaryTerm :: Int64, + destinationResponseDestination :: Destination + } + deriving stock (Eq, Show) + +instance FromJSON DestinationResponse where + parseJSON = withObject "DestinationResponse" $ \o -> + DestinationResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "destination" + +instance ToJSON DestinationResponse where + toJSON DestinationResponse {..} = + object + [ "_id" .= destinationResponseId, + "_version" .= destinationResponseVersion, + "_seq_no" .= destinationResponseSeqNo, + "_primary_term" .= destinationResponsePrimaryTerm, + "destination" .= destinationResponseDestination + ] + +-- | Response shape for @DELETE /_plugins/_alerting/destinations/{id}@. +-- Wire-identical to 'DeleteMonitorResponse' (the standard Elasticsearch +-- delete-document response — bare, no destination echo, no +-- @acknowledged@ key, with a @_shards@ report) but modelled as a +-- distinct type so the public API reads correctly at call sites. +-- 'AlertingShards' is reused for the @_shards@ sub-object. +data DeleteDestinationResponse = DeleteDestinationResponse + { deleteDestinationResponseIndex :: Text, + deleteDestinationResponseId :: Text, + deleteDestinationResponseVersion :: Int64, + deleteDestinationResponseResult :: Text, + deleteDestinationResponseForcedRefresh :: Bool, + deleteDestinationResponseShards :: AlertingShards, + deleteDestinationResponseSeqNo :: Int64, + deleteDestinationResponsePrimaryTerm :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteDestinationResponse where + parseJSON = withObject "DeleteDestinationResponse" $ \o -> + DeleteDestinationResponse + <$> o .: "_index" + <*> o .: "_id" + <*> o .: "_version" + <*> o .: "result" + <*> o .:? "forced_refresh" .!= False + <*> o .: "_shards" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + +instance ToJSON DeleteDestinationResponse where + toJSON DeleteDestinationResponse {..} = + object + [ "_index" .= deleteDestinationResponseIndex, + "_id" .= deleteDestinationResponseId, + "_version" .= deleteDestinationResponseVersion, + "result" .= deleteDestinationResponseResult, + "forced_refresh" .= deleteDestinationResponseForcedRefresh, + "_shards" .= deleteDestinationResponseShards, + "_seq_no" .= deleteDestinationResponseSeqNo, + "_primary_term" .= deleteDestinationResponsePrimaryTerm + ] + +-- ========================================================================= +-- Get alerts: GET /_plugins/_alerting/monitors/alerts +-- ========================================================================= +-- +-- The get-alerts endpoint returns the active alert documents for the +-- whole cluster (optionally filtered by a rich set of query-string +-- parameters). An alert document carries a large, partly variable body +-- (@monitor_user@, @alert_history@, @action_execution_results@ sub-objects +-- whose shape tracks the monitor kind and action type). Following the +-- pragmatic precedent used by 'Monitor' and 'ExecuteMonitorResponse', +-- the stable shell fields are typed and the variable sub-objects are +-- kept as opaque aeson 'Value's (captured together in 'alertOther') so +-- any alert round-trips losslessly. The OpenSearch docs +-- () +-- document the wire shape. + +-- | Sort direction for @GET /_plugins/_alerting/monitors/alerts@. The +-- plugin documents only @"asc"@ and @"desc"@. Modelled as a distinct +-- type from 'DestinationSortOrder' so the call site reads correctly, +-- even though the wire values coincide. +data AlertSortOrder + = AlertSortOrderAsc + | AlertSortOrderDesc + deriving stock (Eq, Show) + +-- | Wire string for an 'AlertSortOrder'. +alertSortOrderText :: AlertSortOrder -> Text +alertSortOrderText = \case + AlertSortOrderAsc -> "asc" + AlertSortOrderDesc -> "desc" + +instance ToJSON AlertSortOrder where + toJSON = toJSON . alertSortOrderText + +-- | The @state@ field of an alert document, and the @alertState@ query +-- parameter. The four documented states are given dedicated +-- constructors; any future value falls through to 'AlertStateOther' +-- rather than parse-failing, because the server is the authority. +data AlertState + = AlertStateActive + | AlertStateCompleted + | AlertStateError + | AlertStateAcknowledged + | AlertStateOther Text + deriving stock (Eq, Show) + +-- | Wire string for an 'AlertState'. +alertStateText :: AlertState -> Text +alertStateText = \case + AlertStateActive -> "ACTIVE" + AlertStateCompleted -> "COMPLETED" + AlertStateError -> "ERROR" + AlertStateAcknowledged -> "ACKNOWLEDGED" + AlertStateOther t -> t + +instance ToJSON AlertState where + toJSON = toJSON . alertStateText + +instance FromJSON AlertState where + parseJSON = withText "AlertState" $ \t -> + pure $ + case t of + "ACTIVE" -> AlertStateActive + "COMPLETED" -> AlertStateCompleted + "ERROR" -> AlertStateError + "ACKNOWLEDGED" -> AlertStateAcknowledged + other -> AlertStateOther other + +-- | Query-string parameters accepted by +-- @GET /_plugins/_alerting/monitors/alerts@. Every field is optional; +-- 'defaultGetAlertsOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. The server-side defaults when a +-- parameter is omitted are: @size=20@, @startIndex=0@, +-- @sortString=monitor_name.keyword@, @sortOrder=asc@, +-- @searchString=""@, @severityLevel=ALL@, @alertState=ALL@. The +-- @severityLevel@ is kept as 'Text' because the wire values are +-- string-encoded severities (@\"1\"@..@\"4\"@) plus the literal +-- @\"ALL\"@, which is awkward to model as a closed enum. The +-- @workflowIds@ parameter is documented for OpenSearch 2.9+ (comma- +-- separated workflow ids for chained-alert dashboards); it is harmlessly +-- ignored by older servers, so it is exposed uniformly across OS1\/2\/3. +data GetAlertsOptions = GetAlertsOptions + { getAlertsOptionsSortString :: Maybe Text, + getAlertsOptionsSortOrder :: Maybe AlertSortOrder, + getAlertsOptionsMissing :: Maybe Text, + getAlertsOptionsSize :: Maybe Natural, + getAlertsOptionsStartIndex :: Maybe Natural, + getAlertsOptionsSearchString :: Maybe Text, + getAlertsOptionsSeverityLevel :: Maybe Text, + getAlertsOptionsAlertState :: Maybe AlertState, + getAlertsOptionsMonitorId :: Maybe Text, + getAlertsOptionsWorkflowIds :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the plain +-- @GET /_plugins/_alerting/monitors/alerts@ (server defaults apply) when +-- passed to 'getAlertsWith'. +defaultGetAlertsOptions :: GetAlertsOptions +defaultGetAlertsOptions = + GetAlertsOptions + { getAlertsOptionsSortString = Nothing, + getAlertsOptionsSortOrder = Nothing, + getAlertsOptionsMissing = Nothing, + getAlertsOptionsSize = Nothing, + getAlertsOptionsStartIndex = Nothing, + getAlertsOptionsSearchString = Nothing, + getAlertsOptionsSeverityLevel = Nothing, + getAlertsOptionsAlertState = Nothing, + getAlertsOptionsMonitorId = Nothing, + getAlertsOptionsWorkflowIds = Nothing + } + +-- | Render a 'GetAlertsOptions' to the query-string pairs accepted by +-- the get-alerts endpoint. Fields set to 'Nothing' are omitted (not +-- rendered with an empty value). The parameter names are camelCase, +-- matching the alerting plugin's @RestGetAlertsAction@ (note: +-- @startIndex@ is camelCase here, whereas the destinations GET uses +-- snake_case @start_index@ — these are distinct plugin routes and the +-- casings genuinely differ on the wire). +getAlertsOptionsParams :: GetAlertsOptions -> [(Text, Maybe Text)] +getAlertsOptionsParams GetAlertsOptions {..} = + catMaybes + [ ("sortString",) . Just <$> getAlertsOptionsSortString, + ("sortOrder",) . Just . alertSortOrderText <$> getAlertsOptionsSortOrder, + ("missing",) . Just <$> getAlertsOptionsMissing, + ("size",) . Just . tshow <$> getAlertsOptionsSize, + ("startIndex",) . Just . tshow <$> getAlertsOptionsStartIndex, + ("searchString",) . Just <$> getAlertsOptionsSearchString, + ("severityLevel",) . Just <$> getAlertsOptionsSeverityLevel, + ("alertState",) . Just . alertStateText <$> getAlertsOptionsAlertState, + ("monitorId",) . Just <$> getAlertsOptionsMonitorId, + ("workflowIds",) . Just <$> getAlertsOptionsWorkflowIds + ] + +-- | A single alert document returned by +-- @GET /_plugins/_alerting/monitors/alerts@. The typed shell covers the +-- stable fields every alert shares; @monitor_user@, @alert_history@, and +-- @action_execution_results@ are kept as opaque aeson 'Value's (captured +-- in 'alertOther') because their shape varies by monitor kind and action +-- type. @alertSeverity@ is a 'Text' rather than an 'Int' because the +-- wire emits a string-encoded integer (e.g. @\"1\"@) — the same +-- deviation from the docs as 'triggerSeverity'. The full original +-- object is captured in 'alertOther' so any forward-compat key +-- round-trips losslessly (mirrors the 'monitorOther' precedent). +data Alert = Alert + { alertId :: Text, + alertVersion :: Int64, + alertMonitorId :: Text, + alertSchemaVersion :: Maybe Int, + alertMonitorVersion :: Maybe Int64, + alertMonitorName :: Text, + alertTriggerId :: Text, + alertTriggerName :: Text, + alertState :: AlertState, + alertSeverity :: Text, + alertErrorMessage :: Maybe Text, + alertStartTime :: Maybe Int64, + alertLastNotificationTime :: Maybe Int64, + alertEndTime :: Maybe Int64, + alertAcknowledgedTime :: Maybe Int64, + alertOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON Alert where + parseJSON = withObject "Alert" $ \o -> + Alert + <$> o .: "id" + <*> o .:? "version" .!= 0 + <*> o .: "monitor_id" + <*> o .:? "schema_version" + <*> o .:? "monitor_version" + <*> o .: "monitor_name" + <*> o .: "trigger_id" + <*> o .: "trigger_name" + <*> o .:? "state" .!= AlertStateOther "" + <*> o .:? "severity" .!= "" + <*> o .:? "error_message" + <*> o .:? "start_time" + <*> o .:? "last_notification_time" + <*> o .:? "end_time" + <*> o .:? "acknowledged_time" + <*> pure (Object o) + +instance ToJSON Alert where + toJSON a = + case alertOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= alertId a, + "version" .= alertVersion a, + "monitor_id" .= alertMonitorId a, + "schema_version" .= alertSchemaVersion a, + "monitor_version" .= alertMonitorVersion a, + "monitor_name" .= alertMonitorName a, + "trigger_id" .= alertTriggerId a, + "trigger_name" .= alertTriggerName a, + "state" .= alertState a, + "severity" .= alertSeverity a, + "error_message" .= alertErrorMessage a, + "start_time" .= alertStartTime a, + "last_notification_time" .= alertLastNotificationTime a, + "end_time" .= alertEndTime a, + "acknowledged_time" .= alertAcknowledgedTime a + ] + +-- | Envelope returned by @GET /_plugins/_alerting/monitors/alerts@. +-- @totalAlerts@ is the total hit count matching the query (not the size +-- of @alerts@, which is the current page constrained by the @size@ \/ +-- @startIndex@ parameters); @alerts@ is the current page of records. +data GetAlertsResponse = GetAlertsResponse + { getAlertsResponseAlerts :: [Alert], + getAlertsResponseTotalAlerts :: Int + } + deriving stock (Eq, Show) + +instance FromJSON GetAlertsResponse where + parseJSON = withObject "GetAlertsResponse" $ \o -> do + getAlertsResponseAlerts <- o .:? "alerts" .!= [] + getAlertsResponseTotalAlerts <- o .:? "totalAlerts" .!= 0 + pure GetAlertsResponse {..} + +instance ToJSON GetAlertsResponse where + toJSON GetAlertsResponse {..} = + object + [ "alerts" .= getAlertsResponseAlerts, + "totalAlerts" .= getAlertsResponseTotalAlerts + ] + +-- ========================================================================= +-- Acknowledge alert: POST /_plugins/_alerting/monitors/{id}/_acknowledge/alerts +-- ========================================================================= +-- +-- The acknowledge endpoint takes a list of alert ids (belonging to the +-- monitor in the path) and flips each to the @ACKNOWLEDGED@ state. Alerts +-- already in an @ERROR@, @COMPLETED@, or @ACKNOWLEDGED@ state are not +-- transitioned and are echoed back in the @failed@ array. See +-- . + +-- | Request body for 'acknowledgeAlert'. @alerts@ is the list of alert +-- ids to acknowledge. 'defaultAcknowledgeAlertRequest' renders to the +-- empty-list body @{"alerts":[]}@. +newtype AcknowledgeAlertRequest = AcknowledgeAlertRequest + { acknowledgeAlertRequestAlerts :: [Text] + } + deriving stock (Eq, Show) + +defaultAcknowledgeAlertRequest :: AcknowledgeAlertRequest +defaultAcknowledgeAlertRequest = AcknowledgeAlertRequest [] + +instance ToJSON AcknowledgeAlertRequest where + toJSON AcknowledgeAlertRequest {..} = + object ["alerts" .= acknowledgeAlertRequestAlerts] + +instance FromJSON AcknowledgeAlertRequest where + parseJSON = withObject "AcknowledgeAlertRequest" $ \o -> + AcknowledgeAlertRequest + <$> o .:? "alerts" .!= [] + +-- | Response shape for +-- @POST /_plugins/_alerting/monitors/{id}/_acknowledge/alerts@. @success@ +-- lists the alert ids that were transitioned to @ACKNOWLEDGED@; @failed@ +-- lists the alert ids that were not (already in a terminal state). +data AcknowledgeAlertResponse = AcknowledgeAlertResponse + { acknowledgeAlertResponseSuccess :: [Text], + acknowledgeAlertResponseFailed :: [Text] + } + deriving stock (Eq, Show) + +instance FromJSON AcknowledgeAlertResponse where + parseJSON = withObject "AcknowledgeAlertResponse" $ \o -> do + acknowledgeAlertResponseSuccess <- o .:? "success" .!= [] + acknowledgeAlertResponseFailed <- o .:? "failed" .!= [] + pure AcknowledgeAlertResponse {..} + +instance ToJSON AcknowledgeAlertResponse where + toJSON AcknowledgeAlertResponse {..} = + object + [ "success" .= acknowledgeAlertResponseSuccess, + "failed" .= acknowledgeAlertResponseFailed + ] + +-- ========================================================================= +-- Monitor stats: GET /_plugins/_alerting/stats[/...] +-- ========================================================================= +-- +-- The stats endpoint returns node-level alerting scheduler metrics. The +-- response is a large, deeply-nested object: a stable shell +-- (@_nodes@ count, @cluster_name@, scheduled-job index health booleans, +-- @nodes_on_schedule@ \/ @nodes_not_on_schedule@ counts) wrapping a +-- @nodes@ map keyed by node id whose value carries per-node roles, +-- schedule status, job-scheduling metrics, and a per-job @jobs_info@ +-- map. The @nodes@ sub-object's shape grows across OpenSearch releases, +-- so following the pragmatic precedent used by +-- 'ExecuteMonitorResponse', the stable shell is typed and the variable +-- @nodes@ map (plus any forward-compat key) is kept as an opaque aeson +-- 'Value' in 'monitorStatsOther'. See +-- . + +-- | The @_nodes@ sub-object of 'MonitorStats' +-- (@{total, successful, failed}@). Modelled locally (rather than reusing +-- 'AlertingShards') because the stats @_nodes@ object carries no +-- @skipped@ field and the names describe cluster-node bookkeeping, not +-- shard execution. +data MonitorStatsNodesCount = MonitorStatsNodesCount + { monitorStatsNodesCountTotal :: Int, + monitorStatsNodesCountSuccessful :: Int, + monitorStatsNodesCountFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON MonitorStatsNodesCount where + parseJSON = withObject "MonitorStatsNodesCount" $ \o -> + MonitorStatsNodesCount + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON MonitorStatsNodesCount where + toJSON MonitorStatsNodesCount {..} = + object + [ "total" .= monitorStatsNodesCountTotal, + "successful" .= monitorStatsNodesCountSuccessful, + "failed" .= monitorStatsNodesCountFailed + ] + +-- | Response shape for @GET /_plugins/_alerting/stats[/...]@. The typed +-- shell carries the stable, cluster-level fields every stats response +-- shares; the deeply-nested @nodes@ map (and any forward-compat key) is +-- captured in 'monitorStatsOther' as an opaque aeson 'Value'. Note the +-- literal dotted key @plugins.scheduled_jobs.enabled@ on the wire. +data MonitorStats = MonitorStats + { monitorStatsNodes :: Maybe MonitorStatsNodesCount, + monitorStatsClusterName :: Maybe Text, + monitorStatsScheduledJobsEnabled :: Maybe Bool, + monitorStatsScheduledJobIndexExists :: Maybe Bool, + monitorStatsScheduledJobIndexStatus :: Maybe Text, + monitorStatsNodesOnSchedule :: Maybe Int, + monitorStatsNodesNotOnSchedule :: Maybe Int, + monitorStatsOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON MonitorStats where + parseJSON = withObject "MonitorStats" $ \o -> + MonitorStats + <$> o .:? "_nodes" + <*> o .:? "cluster_name" + <*> o .:? "plugins.scheduled_jobs.enabled" + <*> o .:? "scheduled_job_index_exists" + <*> o .:? "scheduled_job_index_status" + <*> o .:? "nodes_on_schedule" + <*> o .:? "nodes_not_on_schedule" + <*> pure (Object o) + +instance ToJSON MonitorStats where + toJSON s = + case monitorStatsOther s of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "_nodes" .= monitorStatsNodes s, + "cluster_name" .= monitorStatsClusterName s, + "plugins.scheduled_jobs.enabled" .= monitorStatsScheduledJobsEnabled s, + "scheduled_job_index_exists" .= monitorStatsScheduledJobIndexExists s, + "scheduled_job_index_status" .= monitorStatsScheduledJobIndexStatus s, + "nodes_on_schedule" .= monitorStatsNodesOnSchedule s, + "nodes_not_on_schedule" .= monitorStatsNodesNotOnSchedule s + ] + +-- ========================================================================= +-- Email account lifecycle: POST/PUT/GET/DELETE /_plugins/_alerting/destinations/email_accounts[/{id}] +-- ========================================================================= +-- +-- The legacy alerting email surface (predating the Notifications +-- plugin). An email account is an SMTP sender (host, port, method, +-- credentials) referenced by id from an email 'Destination'. The +-- create\/update endpoints take an 'EmailAccount' body and return the +-- 'EmailAccountResponse' wrapper +-- (@{_id,_version,_seq_no,_primary_term, email_account:{...}}@) — the +-- email-account analogue of 'MonitorResponse'. The delete endpoint +-- returns the standard Elasticsearch delete-document response (bare, no +-- @acknowledged@ key, with a @_shards@ report), modelled distinctly as +-- 'DeleteEmailAccountResponse'. See +-- . + +-- | The server-assigned identifier of an alerting email account. Wraps +-- 'Text' so it round-trips as a bare JSON string but stays distinct from +-- 'MonitorId' and 'DestinationId' at the type level. +newtype EmailAccountId = EmailAccountId {unEmailAccountId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | An SMTP sender account. @method@ is typed as 'Text' (the docs +-- enumerate @ssl@ \/ @none@ \/ @start_tls@ \/ @ssl_tls@ but the set is +-- not pinned in the plugin schema, so a closed enum would risk a +-- library release on the next addition — same reasoning as +-- 'schedulePeriodUnit'). The full original object is captured in +-- 'emailAccountOther' so any forward-compat key round-trips losslessly. +data EmailAccount = EmailAccount + { emailAccountName :: Text, + emailAccountEmail :: Text, + emailAccountHost :: Text, + emailAccountPort :: Int, + emailAccountMethod :: Text, + emailAccountSchemaVersion :: Maybe Int, + emailAccountOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailAccount where + parseJSON = withObject "EmailAccount" $ \o -> do + emailAccountName <- o .: "name" + emailAccountEmail <- o .: "email" + emailAccountHost <- o .: "host" + emailAccountPort <- o .:? "port" .!= 0 + emailAccountMethod <- o .:? "method" .!= "" + emailAccountSchemaVersion <- o .:? "schema_version" + pure EmailAccount {emailAccountOther = Object o, ..} + +instance ToJSON EmailAccount where + toJSON a = + case emailAccountOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= emailAccountName a, + "email" .= emailAccountEmail a, + "host" .= emailAccountHost a, + "port" .= emailAccountPort a, + "method" .= emailAccountMethod a, + "schema_version" .= emailAccountSchemaVersion a + ] + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/destinations/email_accounts[/{id}]@. Carries the +-- indexing metadata alongside the persisted email account. Mirrors +-- 'MonitorResponse' \/ 'DestinationResponse'. +data EmailAccountResponse = EmailAccountResponse + { emailAccountResponseId :: Text, + emailAccountResponseVersion :: Int64, + emailAccountResponseSeqNo :: Int64, + emailAccountResponsePrimaryTerm :: Int64, + emailAccountResponseEmailAccount :: EmailAccount + } + deriving stock (Eq, Show) + +instance FromJSON EmailAccountResponse where + parseJSON = withObject "EmailAccountResponse" $ \o -> + EmailAccountResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "email_account" + +instance ToJSON EmailAccountResponse where + toJSON EmailAccountResponse {..} = + object + [ "_id" .= emailAccountResponseId, + "_version" .= emailAccountResponseVersion, + "_seq_no" .= emailAccountResponseSeqNo, + "_primary_term" .= emailAccountResponsePrimaryTerm, + "email_account" .= emailAccountResponseEmailAccount + ] + +-- | Response shape for +-- @DELETE /_plugins/_alerting/destinations/email_accounts/{id}@. +-- Wire-identical to 'DeleteDestinationResponse' (the standard +-- Elasticsearch delete-document response) but modelled as a distinct +-- type so the public API reads correctly at call sites. 'AlertingShards' +-- is reused for the @_shards@ sub-object. +data DeleteEmailAccountResponse = DeleteEmailAccountResponse + { deleteEmailAccountResponseIndex :: Text, + deleteEmailAccountResponseId :: Text, + deleteEmailAccountResponseVersion :: Int64, + deleteEmailAccountResponseResult :: Text, + deleteEmailAccountResponseForcedRefresh :: Bool, + deleteEmailAccountResponseShards :: AlertingShards, + deleteEmailAccountResponseSeqNo :: Int64, + deleteEmailAccountResponsePrimaryTerm :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteEmailAccountResponse where + parseJSON = withObject "DeleteEmailAccountResponse" $ \o -> + DeleteEmailAccountResponse + <$> o .: "_index" + <*> o .: "_id" + <*> o .: "_version" + <*> o .: "result" + <*> o .:? "forced_refresh" .!= False + <*> o .: "_shards" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + +instance ToJSON DeleteEmailAccountResponse where + toJSON DeleteEmailAccountResponse {..} = + object + [ "_index" .= deleteEmailAccountResponseIndex, + "_id" .= deleteEmailAccountResponseId, + "_version" .= deleteEmailAccountResponseVersion, + "result" .= deleteEmailAccountResponseResult, + "forced_refresh" .= deleteEmailAccountResponseForcedRefresh, + "_shards" .= deleteEmailAccountResponseShards, + "_seq_no" .= deleteEmailAccountResponseSeqNo, + "_primary_term" .= deleteEmailAccountResponsePrimaryTerm + ] + +-- ========================================================================= +-- Email group lifecycle: POST/PUT/GET/DELETE /_plugins/_alerting/destinations/email_groups[/{id}] +-- ========================================================================= +-- +-- An email group is a named list of recipients (@emails@) referenced by +-- id from an email 'Destination'. The create\/update endpoints take an +-- 'EmailGroup' body and return the 'EmailGroupResponse' wrapper +-- (@{_id,_version,_seq_no,_primary_term, email_group:{...}}@); the delete +-- endpoint returns the standard Elasticsearch delete-document response, +-- modelled as 'DeleteEmailGroupResponse'. See +-- . + +-- | The server-assigned identifier of an alerting email group. Wraps +-- 'Text' so it round-trips as a bare JSON string but stays distinct from +-- the other alerting ids at the type level. +newtype EmailGroupId = EmailGroupId {unEmailGroupId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A single recipient within an 'EmailGroup'. The wire object is +-- @{"email": "..."}@; any forward-compat key is captured in +-- 'emailGroupRecipientOther'. +data EmailGroupRecipient = EmailGroupRecipient + { emailGroupRecipientEmail :: Text, + emailGroupRecipientOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroupRecipient where + parseJSON = withObject "EmailGroupRecipient" $ \o -> do + emailGroupRecipientEmail <- o .: "email" + pure EmailGroupRecipient {emailGroupRecipientOther = Object o, ..} + +instance ToJSON EmailGroupRecipient where + toJSON r = + case emailGroupRecipientOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = ["email" .= emailGroupRecipientEmail r] + +-- | An email group document. The full original object is captured in +-- 'emailGroupOther' so any forward-compat key round-trips losslessly. +data EmailGroup = EmailGroup + { emailGroupName :: Text, + emailGroupEmails :: [EmailGroupRecipient], + emailGroupSchemaVersion :: Maybe Int, + emailGroupOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroup where + parseJSON = withObject "EmailGroup" $ \o -> do + emailGroupName <- o .: "name" + emailGroupEmails <- o .:? "emails" .!= [] + emailGroupSchemaVersion <- o .:? "schema_version" + pure EmailGroup {emailGroupOther = Object o, ..} + +instance ToJSON EmailGroup where + toJSON g = + case emailGroupOther g of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= emailGroupName g, + "emails" .= emailGroupEmails g, + "schema_version" .= emailGroupSchemaVersion g + ] + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/destinations/email_groups[/{id}]@. Carries the +-- indexing metadata alongside the persisted email group. Mirrors +-- 'MonitorResponse' \/ 'DestinationResponse' \/ 'EmailAccountResponse'. +data EmailGroupResponse = EmailGroupResponse + { emailGroupResponseId :: Text, + emailGroupResponseVersion :: Int64, + emailGroupResponseSeqNo :: Int64, + emailGroupResponsePrimaryTerm :: Int64, + emailGroupResponseEmailGroup :: EmailGroup + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroupResponse where + parseJSON = withObject "EmailGroupResponse" $ \o -> + EmailGroupResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "email_group" + +instance ToJSON EmailGroupResponse where + toJSON EmailGroupResponse {..} = + object + [ "_id" .= emailGroupResponseId, + "_version" .= emailGroupResponseVersion, + "_seq_no" .= emailGroupResponseSeqNo, + "_primary_term" .= emailGroupResponsePrimaryTerm, + "email_group" .= emailGroupResponseEmailGroup + ] + +-- | Response shape for +-- @DELETE /_plugins/_alerting/destinations/email_groups/{id}@. +-- Wire-identical to 'DeleteDestinationResponse' (the standard +-- Elasticsearch delete-document response) but modelled as a distinct +-- type so the public API reads correctly at call sites. 'AlertingShards' +-- is reused for the @_shards@ sub-object. +data DeleteEmailGroupResponse = DeleteEmailGroupResponse + { deleteEmailGroupResponseIndex :: Text, + deleteEmailGroupResponseId :: Text, + deleteEmailGroupResponseVersion :: Int64, + deleteEmailGroupResponseResult :: Text, + deleteEmailGroupResponseForcedRefresh :: Bool, + deleteEmailGroupResponseShards :: AlertingShards, + deleteEmailGroupResponseSeqNo :: Int64, + deleteEmailGroupResponsePrimaryTerm :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteEmailGroupResponse where + parseJSON = withObject "DeleteEmailGroupResponse" $ \o -> + DeleteEmailGroupResponse + <$> o .: "_index" + <*> o .: "_id" + <*> o .: "_version" + <*> o .: "result" + <*> o .:? "forced_refresh" .!= False + <*> o .: "_shards" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + +instance ToJSON DeleteEmailGroupResponse where + toJSON DeleteEmailGroupResponse {..} = + object + [ "_index" .= deleteEmailGroupResponseIndex, + "_id" .= deleteEmailGroupResponseId, + "_version" .= deleteEmailGroupResponseVersion, + "result" .= deleteEmailGroupResponseResult, + "forced_refresh" .= deleteEmailGroupResponseForcedRefresh, + "_shards" .= deleteEmailGroupResponseShards, + "_seq_no" .= deleteEmailGroupResponseSeqNo, + "_primary_term" .= deleteEmailGroupResponsePrimaryTerm + ] + +-- ========================================================================= +-- Email account search: POST /_plugins/_alerting/destinations/email_accounts/_search +-- ========================================================================= +-- +-- The email account search endpoint exposes the email-account store as a +-- standard OpenSearch index, so the search body takes the standard query +-- DSL plus @from@ \/ @size@ \/ @sort@ and returns the standard search +-- envelope. Each hit's @_source@ is a bare 'EmailAccount' (the indexed +-- document source). Mirrors the 'MonitorsSearchQuery' / +-- 'SearchMonitorsResponse' pattern but with 'EmailAccount' sources. + +-- | Optional query body for 'searchEmailAccounts'. The @from@ \/ @size@ +-- pair is the standard OpenSearch pagination cursor; @sort@ is an opaque +-- 'Value' (the docs show @{"field.keyword": "desc"}@); @query@ is the +-- standard OpenSearch query DSL. Pass 'Nothing' to 'searchEmailAccounts' +-- (or 'defaultEmailAccountSearchQuery' to the body renderer) for the plain +-- empty-body @{}@ POST that returns the first page of all email accounts. +data EmailAccountSearchQuery = EmailAccountSearchQuery + { emailAccountSearchQueryFrom :: Maybe Int, + emailAccountSearchQuerySize :: Maybe Int, + emailAccountSearchQuerySort :: Maybe Value, + emailAccountSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultEmailAccountSearchQuery :: EmailAccountSearchQuery +defaultEmailAccountSearchQuery = EmailAccountSearchQuery Nothing Nothing Nothing Nothing + +instance ToJSON EmailAccountSearchQuery where + toJSON EmailAccountSearchQuery {..} = + omitNulls + [ "from" .= emailAccountSearchQueryFrom, + "size" .= emailAccountSearchQuerySize, + "sort" .= emailAccountSearchQuerySort, + "query" .= emailAccountSearchQueryQuery + ] + +instance FromJSON EmailAccountSearchQuery where + parseJSON = withObject "EmailAccountSearchQuery" $ \o -> + EmailAccountSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "sort" + <*> o .:? "query" + +-- | A single hit in @hits.hits[]@ on an email account search response. +-- The typed fields mirror the standard search-hit envelope; the @_source@ +-- is decoded as a bare 'EmailAccount'. The @sort@ field (present when a +-- sort is supplied in the query) is preserved as an opaque 'Value' in +-- 'emailAccountSearchHitSort' so callers can drive cursor-based +-- pagination. +data EmailAccountSearchHit = EmailAccountSearchHit + { emailAccountSearchHitIndex :: Maybe Text, + emailAccountSearchHitId :: Text, + emailAccountSearchHitVersion :: Maybe Int64, + emailAccountSearchHitSeqNo :: Maybe Int64, + emailAccountSearchHitPrimaryTerm :: Maybe Int64, + emailAccountSearchHitScore :: Maybe Double, + emailAccountSearchHitSource :: EmailAccount, + emailAccountSearchHitSort :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailAccountSearchHit where + parseJSON = withObject "EmailAccountSearchHit" $ \o -> + EmailAccountSearchHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + <*> o .:? "sort" + +instance ToJSON EmailAccountSearchHit where + toJSON EmailAccountSearchHit {..} = + omitNulls + [ "_index" .= emailAccountSearchHitIndex, + "_id" .= emailAccountSearchHitId, + "_version" .= emailAccountSearchHitVersion, + "_seq_no" .= emailAccountSearchHitSeqNo, + "_primary_term" .= emailAccountSearchHitPrimaryTerm, + "_score" .= emailAccountSearchHitScore, + "_source" .= emailAccountSearchHitSource, + "sort" .= emailAccountSearchHitSort + ] + +-- | Response envelope for 'searchEmailAccounts'. Reuses 'MonitorsTotal' +-- and 'MonitorsTotalRelation' for the @hits.total@ sub-object and +-- 'AlertingShards' for the @_shards@ sub-object (same wire shapes). +data SearchEmailAccountsResponse = SearchEmailAccountsResponse + { searchEmailAccountsResponseTook :: Int64, + searchEmailAccountsResponseTimedOut :: Bool, + searchEmailAccountsResponseShards :: AlertingShards, + searchEmailAccountsResponseTotal :: MonitorsTotal, + searchEmailAccountsResponseMaxScore :: Maybe Double, + searchEmailAccountsResponseHits :: [EmailAccountSearchHit] + } + deriving stock (Eq, Show) + +instance FromJSON SearchEmailAccountsResponse where + parseJSON = withObject "SearchEmailAccountsResponse" $ \o -> do + hits <- o .: "hits" + SearchEmailAccountsResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SearchEmailAccountsResponse where + toJSON SearchEmailAccountsResponse {..} = + object + [ "took" .= searchEmailAccountsResponseTook, + "timed_out" .= searchEmailAccountsResponseTimedOut, + "_shards" .= searchEmailAccountsResponseShards, + "hits" + .= object + [ "total" .= searchEmailAccountsResponseTotal, + "max_score" .= searchEmailAccountsResponseMaxScore, + "hits" .= searchEmailAccountsResponseHits + ] + ] + +-- ========================================================================= +-- Email group search: POST /_plugins/_alerting/destinations/email_groups/_search +-- ========================================================================= +-- +-- Wire-identical in shape to the email account search; the @_source@ of +-- each hit is a bare 'EmailGroup' instead. + +-- | Optional query body for 'searchEmailGroups'. Same shape as +-- 'EmailAccountSearchQuery'. Pass 'Nothing' or +-- 'defaultEmailGroupSearchQuery' for the plain empty-body @{}@ POST. +data EmailGroupSearchQuery = EmailGroupSearchQuery + { emailGroupSearchQueryFrom :: Maybe Int, + emailGroupSearchQuerySize :: Maybe Int, + emailGroupSearchQuerySort :: Maybe Value, + emailGroupSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultEmailGroupSearchQuery :: EmailGroupSearchQuery +defaultEmailGroupSearchQuery = EmailGroupSearchQuery Nothing Nothing Nothing Nothing + +instance ToJSON EmailGroupSearchQuery where + toJSON EmailGroupSearchQuery {..} = + omitNulls + [ "from" .= emailGroupSearchQueryFrom, + "size" .= emailGroupSearchQuerySize, + "sort" .= emailGroupSearchQuerySort, + "query" .= emailGroupSearchQueryQuery + ] + +instance FromJSON EmailGroupSearchQuery where + parseJSON = withObject "EmailGroupSearchQuery" $ \o -> + EmailGroupSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "sort" + <*> o .:? "query" + +-- | A single hit in @hits.hits[]@ on an email group search response. +-- Mirrors 'EmailAccountSearchHit' but with 'EmailGroup' source. +data EmailGroupSearchHit = EmailGroupSearchHit + { emailGroupSearchHitIndex :: Maybe Text, + emailGroupSearchHitId :: Text, + emailGroupSearchHitVersion :: Maybe Int64, + emailGroupSearchHitSeqNo :: Maybe Int64, + emailGroupSearchHitPrimaryTerm :: Maybe Int64, + emailGroupSearchHitScore :: Maybe Double, + emailGroupSearchHitSource :: EmailGroup, + emailGroupSearchHitSort :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroupSearchHit where + parseJSON = withObject "EmailGroupSearchHit" $ \o -> + EmailGroupSearchHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + <*> o .:? "sort" + +instance ToJSON EmailGroupSearchHit where + toJSON EmailGroupSearchHit {..} = + omitNulls + [ "_index" .= emailGroupSearchHitIndex, + "_id" .= emailGroupSearchHitId, + "_version" .= emailGroupSearchHitVersion, + "_seq_no" .= emailGroupSearchHitSeqNo, + "_primary_term" .= emailGroupSearchHitPrimaryTerm, + "_score" .= emailGroupSearchHitScore, + "_source" .= emailGroupSearchHitSource, + "sort" .= emailGroupSearchHitSort + ] + +-- | Response envelope for 'searchEmailGroups'. Reuses 'MonitorsTotal' +-- and 'AlertingShards'. +data SearchEmailGroupsResponse = SearchEmailGroupsResponse + { searchEmailGroupsResponseTook :: Int64, + searchEmailGroupsResponseTimedOut :: Bool, + searchEmailGroupsResponseShards :: AlertingShards, + searchEmailGroupsResponseTotal :: MonitorsTotal, + searchEmailGroupsResponseMaxScore :: Maybe Double, + searchEmailGroupsResponseHits :: [EmailGroupSearchHit] + } + deriving stock (Eq, Show) + +instance FromJSON SearchEmailGroupsResponse where + parseJSON = withObject "SearchEmailGroupsResponse" $ \o -> do + hits <- o .: "hits" + SearchEmailGroupsResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SearchEmailGroupsResponse where + toJSON SearchEmailGroupsResponse {..} = + object + [ "took" .= searchEmailGroupsResponseTook, + "timed_out" .= searchEmailGroupsResponseTimedOut, + "_shards" .= searchEmailGroupsResponseShards, + "hits" + .= object + [ "total" .= searchEmailGroupsResponseTotal, + "max_score" .= searchEmailGroupsResponseMaxScore, + "hits" .= searchEmailGroupsResponseHits + ] + ] + +-- ========================================================================= +-- Findings search: GET /_plugins/_alerting/findings/_search +-- ========================================================================= +-- +-- The findings search endpoint queries the +-- @.opensearch-alerting-finding*@ index for document-level monitor +-- findings. Unlike the monitor\/email-account\/email-group search +-- endpoints (which take a POST body with the standard query DSL), the +-- findings search is a GET with query-string parameters only. The +-- response carries a @total_findings@ count and a list of finding +-- objects. The OpenSearch docs +-- () +-- document the query parameters but do not show a full finding response +-- example, so the findings list is kept as an opaque aeson 'Value' to +-- avoid guessing at an under-documented schema. + +-- | Query-string parameters accepted by +-- @GET /_plugins/_alerting/findings/_search@. Every field is optional; +-- 'defaultFindingsSearchOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET that returns all findings. The +-- server-side defaults are: @sortString=id@, @sortOrder=asc@, +-- @size=unlimited@, @startIndex=0@, @searchString=""@. +data FindingsSearchOptions = FindingsSearchOptions + { findingsSearchOptionsFindingId :: Maybe Text, + findingsSearchOptionsSortString :: Maybe Text, + findingsSearchOptionsSortOrder :: Maybe DestinationSortOrder, + findingsSearchOptionsSize :: Maybe Natural, + findingsSearchOptionsStartIndex :: Maybe Natural, + findingsSearchOptionsSearchString :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record -- no query parameters. +defaultFindingsSearchOptions :: FindingsSearchOptions +defaultFindingsSearchOptions = + FindingsSearchOptions + { findingsSearchOptionsFindingId = Nothing, + findingsSearchOptionsSortString = Nothing, + findingsSearchOptionsSortOrder = Nothing, + findingsSearchOptionsSize = Nothing, + findingsSearchOptionsStartIndex = Nothing, + findingsSearchOptionsSearchString = Nothing + } + +-- | Render a 'FindingsSearchOptions' to the query-string pairs accepted +-- by the findings search endpoint. Fields set to 'Nothing' are omitted. +findingsSearchOptionsParams :: FindingsSearchOptions -> [(Text, Maybe Text)] +findingsSearchOptionsParams FindingsSearchOptions {..} = + catMaybes + [ ("findingId",) . Just <$> findingsSearchOptionsFindingId, + ("sortString",) . Just <$> findingsSearchOptionsSortString, + ("sortOrder",) . Just . destinationSortOrderText <$> findingsSearchOptionsSortOrder, + ("size",) . Just . tshow <$> findingsSearchOptionsSize, + ("startIndex",) . Just . tshow <$> findingsSearchOptionsStartIndex, + ("searchString",) . Just <$> findingsSearchOptionsSearchString + ] + +-- | Response shape for +-- @GET /_plugins/_alerting/findings/_search@. @totalFindings@ is the +-- total hit count; @findings@ is the list of finding objects, kept as an +-- opaque aeson 'Value' because the docs do not document the full finding +-- schema. Mirrors the pragmatic-typing precedent (typed shell + opaque +-- variable payload). +data SearchFindingsResponse = SearchFindingsResponse + { searchFindingsResponseTotalFindings :: Int, + searchFindingsResponseFindings :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SearchFindingsResponse where + parseJSON = withObject "SearchFindingsResponse" $ \o -> + SearchFindingsResponse + <$> o .:? "total_findings" .!= 0 + <*> o .:? "findings" .!= Null + +instance ToJSON SearchFindingsResponse where + toJSON SearchFindingsResponse {..} = + object + [ "total_findings" .= searchFindingsResponseTotalFindings, + "findings" .= searchFindingsResponseFindings + ] + +-- ========================================================================= +-- Comments API: POST/PUT/GET/DELETE /_plugins/_alerting/comments[/{id}] +-- ========================================================================= +-- +-- The comments API provides CRUD over comment documents associated with +-- alert entities. Comments are stored in a +-- @.opensearch-alerting-comments-history-*@ index. Each comment carries +-- an @entity_id@ (the alert id), @entity_type@ (documented as @"alert"@), +-- the @content@ text, timestamps (@created_time@, +-- @last_updated_time@), and the @user@ who created it. See +-- . + +-- | The server-assigned identifier of a comment. Wraps 'Text' so it +-- round-trips as a bare JSON string but stays distinct from the other +-- alerting ids at the type level. +newtype CommentId = CommentId {unCommentId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A comment document. @entityType@ is typed as 'Text' (the docs only +-- show @"alert"@ but the field name implies extensibility). @user@ is +-- also 'Text' (the docs show a bare username string, not the rich user +-- object used by 'Destination'). The full original object is captured in +-- 'commentOther' so any forward-compat key round-trips losslessly. +data Comment = Comment + { commentEntityId :: Text, + commentEntityType :: Text, + commentContent :: Text, + commentCreatedTime :: Maybe Int64, + commentLastUpdatedTime :: Maybe Int64, + commentUser :: Maybe Text, + commentOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON Comment where + parseJSON = withObject "Comment" $ \o -> do + commentEntityId <- o .: "entity_id" + commentEntityType <- o .: "entity_type" + commentContent <- o .: "content" + commentCreatedTime <- o .:? "created_time" + commentLastUpdatedTime <- o .:? "last_updated_time" + commentUser <- o .:? "user" + pure Comment {commentOther = Object o, ..} + +instance ToJSON Comment where + toJSON c = + case commentOther c of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "entity_id" .= commentEntityId c, + "entity_type" .= commentEntityType c, + "content" .= commentContent c, + "created_time" .= commentCreatedTime c, + "last_updated_time" .= commentLastUpdatedTime c, + "user" .= commentUser c + ] + +-- | Request body for 'createComment'. @content@ is the comment text. +newtype CreateCommentRequest = CreateCommentRequest + { createCommentRequestContent :: Text + } + deriving stock (Eq, Show) + +instance ToJSON CreateCommentRequest where + toJSON CreateCommentRequest {..} = + object ["content" .= createCommentRequestContent] + +instance FromJSON CreateCommentRequest where + parseJSON = withObject "CreateCommentRequest" $ \o -> + CreateCommentRequest <$> o .: "content" + +-- | Request body for 'updateComment'. Same shape as +-- 'CreateCommentRequest'. +newtype UpdateCommentRequest = UpdateCommentRequest + { updateCommentRequestContent :: Text + } + deriving stock (Eq, Show) + +instance ToJSON UpdateCommentRequest where + toJSON UpdateCommentRequest {..} = + object ["content" .= updateCommentRequestContent] + +instance FromJSON UpdateCommentRequest where + parseJSON = withObject "UpdateCommentRequest" $ \o -> + UpdateCommentRequest <$> o .: "content" + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/comments[/{id}]@. Carries the indexing metadata +-- alongside the persisted comment. Mirrors 'MonitorResponse' / +-- 'EmailAccountResponse' but without @_version@ (the docs do not show +-- a @_version@ field on comment responses). +data CommentResponse = CommentResponse + { commentResponseId :: Text, + commentResponseSeqNo :: Int64, + commentResponsePrimaryTerm :: Int64, + commentResponseComment :: Comment + } + deriving stock (Eq, Show) + +instance FromJSON CommentResponse where + parseJSON = withObject "CommentResponse" $ \o -> + CommentResponse + <$> o .: "_id" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "comment" + +instance ToJSON CommentResponse where + toJSON CommentResponse {..} = + object + [ "_id" .= commentResponseId, + "_seq_no" .= commentResponseSeqNo, + "_primary_term" .= commentResponsePrimaryTerm, + "comment" .= commentResponseComment + ] + +-- | Optional query body for 'searchComments'. The @from@ \/ @size@ +-- pair is the standard OpenSearch pagination cursor; @sort@ is an opaque +-- 'Value'; @query@ is the standard OpenSearch query DSL. Pass 'Nothing' +-- or 'defaultCommentSearchQuery' for the plain empty-body @{}@ request. +data CommentSearchQuery = CommentSearchQuery + { commentSearchQueryFrom :: Maybe Int, + commentSearchQuerySize :: Maybe Int, + commentSearchQuerySort :: Maybe Value, + commentSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultCommentSearchQuery :: CommentSearchQuery +defaultCommentSearchQuery = CommentSearchQuery Nothing Nothing Nothing Nothing + +instance ToJSON CommentSearchQuery where + toJSON CommentSearchQuery {..} = + omitNulls + [ "from" .= commentSearchQueryFrom, + "size" .= commentSearchQuerySize, + "sort" .= commentSearchQuerySort, + "query" .= commentSearchQueryQuery + ] + +instance FromJSON CommentSearchQuery where + parseJSON = withObject "CommentSearchQuery" $ \o -> + CommentSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "sort" + <*> o .:? "query" + +-- | A single hit in @hits.hits[]@ on a comment search response. The +-- typed fields mirror the standard search-hit envelope; the @_source@ is +-- decoded as a bare 'Comment'. +data CommentSearchHit = CommentSearchHit + { commentSearchHitIndex :: Maybe Text, + commentSearchHitId :: Text, + commentSearchHitVersion :: Maybe Int64, + commentSearchHitSeqNo :: Maybe Int64, + commentSearchHitPrimaryTerm :: Maybe Int64, + commentSearchHitScore :: Maybe Double, + commentSearchHitSource :: Comment + } + deriving stock (Eq, Show) + +instance FromJSON CommentSearchHit where + parseJSON = withObject "CommentSearchHit" $ \o -> + CommentSearchHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON CommentSearchHit where + toJSON CommentSearchHit {..} = + omitNulls + [ "_index" .= commentSearchHitIndex, + "_id" .= commentSearchHitId, + "_version" .= commentSearchHitVersion, + "_seq_no" .= commentSearchHitSeqNo, + "_primary_term" .= commentSearchHitPrimaryTerm, + "_score" .= commentSearchHitScore, + "_source" .= commentSearchHitSource + ] + +-- | Response envelope for 'searchComments'. Reuses 'MonitorsTotal' and +-- 'AlertingShards'. +data SearchCommentsResponse = SearchCommentsResponse + { searchCommentsResponseTook :: Int64, + searchCommentsResponseTimedOut :: Bool, + searchCommentsResponseShards :: AlertingShards, + searchCommentsResponseTotal :: MonitorsTotal, + searchCommentsResponseMaxScore :: Maybe Double, + searchCommentsResponseHits :: [CommentSearchHit] + } + deriving stock (Eq, Show) + +instance FromJSON SearchCommentsResponse where + parseJSON = withObject "SearchCommentsResponse" $ \o -> do + hits <- o .: "hits" + SearchCommentsResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SearchCommentsResponse where + toJSON SearchCommentsResponse {..} = + object + [ "took" .= searchCommentsResponseTook, + "timed_out" .= searchCommentsResponseTimedOut, + "_shards" .= searchCommentsResponseShards, + "hits" + .= object + [ "total" .= searchCommentsResponseTotal, + "max_score" .= searchCommentsResponseMaxScore, + "hits" .= searchCommentsResponseHits + ] + ] + +-- | Response shape for @DELETE /_plugins/_alerting/comments/{id}@. +-- Minimal: just the @_id@ of the deleted comment. +newtype DeleteCommentResponse = DeleteCommentResponse + { deleteCommentResponseId :: Text + } + deriving stock (Eq, Show) + +instance FromJSON DeleteCommentResponse where + parseJSON = withObject "DeleteCommentResponse" $ \o -> + DeleteCommentResponse <$> o .: "_id" + +instance ToJSON DeleteCommentResponse where + toJSON DeleteCommentResponse {..} = + object ["_id" .= deleteCommentResponseId] + +-- | Overlay the typed key-value pairs on top of a captured object, +-- dropping typed pairs whose value is @null@ (so optional fields left +-- 'Nothing' do not clobber a non-null value captured from the wire). +-- Mirrors the helper in +-- "Database.Bloodhound.Internal.Versions.Common.Types.PendingTask". +mergeIgnoringNulls :: [(Key, Value)] -> KM.KeyMap Value -> KM.KeyMap Value +mergeIgnoringNulls kvs o = KM.union (KM.fromList (filter notNull kvs)) o + where + notNull (_, Null) = False + notNull _ = True diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/AnomalyDetection.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/AnomalyDetection.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/AnomalyDetection.hs @@ -0,0 +1,1426 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.AnomalyDetection + ( DetectorId (..), + PeriodUnit (..), + periodUnitText, + Period (..), + WindowPeriod (..), + FeatureAttribute (..), + DetectorType (..), + detectorTypeText, + User (..), + Detector (..), + DetectorResponse (..), + CreateDetectorResponse (..), + GetDetectorResponse (..), + GetDetectorParams (..), + defaultGetDetectorParams, + DetectorJob (..), + DetectorJobSchedule (..), + DetectorJobScheduleInterval (..), + DetectionTask (..), + DetectionDateRange (..), + DetectionTaskType (..), + detectionTaskTypeText, + PreviewRequest (..), + FeatureData (..), + Entity (..), + AnomalyResult (..), + PreviewResponse (..), + StartDetectorJobRequest (..), + DetectorJobAcknowledgment (..), + -- | Update / Delete detector + AnomalyShards (..), + DeleteDetectorResponse (..), + -- | Validate detector + ValidateDetectorMode (..), + validateDetectorModeSegments, + ValidateDetectorResponse (..), + -- | Search envelope (detectors / results / tasks) + AnomalySearchTotalRelation (..), + AnomalySearchTotal (..), + AnomalySearchHit (..), + AnomalySearchResponse (..), + anomalySearchResponseSources, + SearchDetectorsResponse, + SearchDetectorResultsResponse, + DeleteDetectorResultsResponse, + SearchDetectorTasksResponse, + -- | Profile / Stats + DetectorProfileResponse (..), + DetectorStatsResponse (..), + -- | Top anomalies + TopAnomaliesOrder (..), + topAnomaliesOrderText, + TopAnomaliesRequest (..), + defaultTopAnomaliesRequest, + TopAnomalyBucket (..), + TopAnomaliesResponse (..), + ) +where + +import Data.Text qualified as T +import Database.Bloodhound.Internal.Client.Doc (DocVersion) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes (DeletedDocuments) + +-- $schema +-- +-- The OpenSearch Anomaly Detection (AD) plugin +-- () +-- detects anomalies in time-series data using Random Cut Forest (RCF). A +-- 'Detector' binds a name and a target index to one or more +-- 'FeatureAttribute's (aggregations the plugin evaluates each +-- 'detectionInterval'); the server persists it under +-- @.opendistro-anomaly-detection-state@ and returns a +-- 'CreateDetectorResponse' wrapping the persisted 'DetectorResponse' with +-- server-injected bookkeeping fields (@_id@, @_version@, @_seq_no@, +-- @_primary_term@, @shingle_size@, @schema_version@, @last_update_time@, +-- @user@, @detector_type@, @rules@, @recency_emphasis@, @history@). +-- +-- We split the request shape ('Detector') from the response shape +-- ('DetectorResponse') so the request cannot accidentally carry +-- server-only fields, while the response still round-trips the full +-- server payload. This mirrors the 'ISMPolicyRequest' / +-- 'ISMPolicyResponse' split used for the ISM plugin. +-- +-- The plugin is shipped with OpenSearch 1.0+; it is present (and +-- wire-compatible) on OS1, OS2 and OS3, hence this module is duplicated +-- across all three versions. +-- +-- Doc ambiguities handled here deliberately: +-- +-- * The @period.unit@ field is documented with only @"Minutes"@ in +-- examples. The plugin source also accepts @Hours@, @Seconds@, @Days@, +-- @Weeks@ and @Months@; we type 'PeriodUnit' as a closed enum with a +-- 'PeriodUnitCustom' escape hatch so future additions surface as a +-- parsed value rather than a decode failure. +-- * The @detector_type@ field is server-derived from the presence of +-- @category_field@. The docs enumerate @"SINGLE_ENTITY"@ and +-- @"MULTI_ENTITY"@; we add 'DetectorTypeCustom' for forward +-- compatibility. +-- * The @rules@ array is server-injected as a default +-- @IGNORE_ANOMALY@ rule (observed in live responses) but is not +-- documented in the field table. We carry it as an opaque 'Value' +-- until the typed schema lands (tracked separately). +-- * The @_start@ endpoint serves double duty: with no body it starts the +-- real-time detector job, and with a 'StartDetectorJobRequest' body it +-- kicks off a one-shot historical backfill (the documented successor to +-- the legacy @_run@). The two forms share one URL and one +-- 'DetectorJobAcknowledgment' response shape but return different +-- @_id@ values (detector id vs historical batch task id). + +-- | Identifies an anomaly detector in the +-- @\/_plugins\/_anomaly_detection\/detectors\/{id}@ URL path. Wraps +-- 'Text' so it round-trips through JSON as a bare string but is distinct +-- at the Haskell type level. +-- See +newtype DetectorId = DetectorId {unDetectorId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @period.unit@ enum documented at +-- . +-- The docs only show @"Minutes"@ in examples; the plugin source accepts +-- a handful of additional values, all enumerated here. Unknown values +-- (forward compatibility) parse as 'PeriodUnitCustom'. +data PeriodUnit + = PeriodUnitMinutes + | PeriodUnitHours + | PeriodUnitSeconds + | PeriodUnitDays + | PeriodUnitWeeks + | PeriodUnitMonths + | PeriodUnitCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'PeriodUnit' — the same mapping the 'ToJSON' +-- \/ 'FromJSON' instances use, exposed as plain 'Text' for callers that +-- need the wire string without going through a 'Data.Aeson.Value'. +periodUnitText :: PeriodUnit -> Text +periodUnitText = \case + PeriodUnitMinutes -> "Minutes" + PeriodUnitHours -> "Hours" + PeriodUnitSeconds -> "Seconds" + PeriodUnitDays -> "Days" + PeriodUnitWeeks -> "Weeks" + PeriodUnitMonths -> "Months" + PeriodUnitCustom t -> t + +instance ToJSON PeriodUnit where + toJSON = toJSON . periodUnitText + +instance FromJSON PeriodUnit where + parseJSON = withText "PeriodUnit" $ \case + "Minutes" -> pure PeriodUnitMinutes + "Hours" -> pure PeriodUnitHours + "Seconds" -> pure PeriodUnitSeconds + "Days" -> pure PeriodUnitDays + "Weeks" -> pure PeriodUnitWeeks + "Months" -> pure PeriodUnitMonths + other -> pure (PeriodUnitCustom other) + +-- | The inner @{interval, unit}@ object shared by 'WindowPeriod'. The +-- @interval@ is a positive integer; @unit@ names the time unit. +-- See +data Period = Period + { periodInterval :: Int, + periodUnit :: PeriodUnit + } + deriving stock (Eq, Show) + +instance FromJSON Period where + parseJSON = withObject "Period" $ \v -> do + periodInterval <- v .: "interval" + periodUnit <- v .: "unit" + pure Period {..} + +instance ToJSON Period where + toJSON Period {..} = + object + [ "interval" .= periodInterval, + "unit" .= periodUnit + ] + +-- | The wrapper @{period: {interval, unit}}@ used by both +-- @detection_interval@ and @window_delay@. Distinct from 'Period' so the +-- two levels cannot be confused at the call site. +-- See +newtype WindowPeriod = WindowPeriod {windowPeriodPeriod :: Period} + deriving stock (Eq, Show) + +instance FromJSON WindowPeriod where + parseJSON = withObject "WindowPeriod" $ \v -> + WindowPeriod <$> v .: "period" + +instance ToJSON WindowPeriod where + toJSON WindowPeriod {..} = + object ["period" .= windowPeriodPeriod] + +-- | A feature attribute: a named aggregation the plugin evaluates each +-- detection interval. The request shape omits @feature_id@ (the server +-- generates one); the response shape fills it in via 'featureAttributeId'. +-- @aggregation_query@ is an arbitrary OpenSearch aggregations DSL body, +-- so it is carried as an opaque 'Value' (the same approach the ISM +-- module takes for untyped DSL fragments). +-- See +data FeatureAttribute = FeatureAttribute + { featureAttributeId :: Maybe Text, + featureAttributeName :: Text, + featureAttributeEnabled :: Bool, + featureAttributeAggregationQuery :: Value + } + deriving stock (Eq, Show) + +instance FromJSON FeatureAttribute where + parseJSON = withObject "FeatureAttribute" $ \v -> do + featureAttributeId <- v .:? "feature_id" + featureAttributeName <- v .: "feature_name" + featureAttributeEnabled <- v .:? "feature_enabled" .!= True + featureAttributeAggregationQuery <- v .: "aggregation_query" + pure FeatureAttribute {..} + +instance ToJSON FeatureAttribute where + toJSON FeatureAttribute {..} = + omitNulls + [ "feature_id" .= featureAttributeId, + "feature_name" .= featureAttributeName, + "feature_enabled" .= featureAttributeEnabled, + "aggregation_query" .= featureAttributeAggregationQuery + ] + +-- | The @detector_type@ enum. The docs enumerate @"SINGLE_ENTITY"@ (no +-- @category_field@ set) and @"MULTI_ENTITY"@ (@category_field@ set); +-- unknown values parse as 'DetectorTypeCustom' so future plugin +-- releases surface as a parsed value rather than a decode failure. +-- The field is server-derived; callers never need to construct it. +data DetectorType + = DetectorTypeSingleEntity + | DetectorTypeMultiEntity + | DetectorTypeCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'DetectorType' — the same mapping the +-- 'ToJSON' \/ 'FromJSON' instances use. +detectorTypeText :: DetectorType -> Text +detectorTypeText = \case + DetectorTypeSingleEntity -> "SINGLE_ENTITY" + DetectorTypeMultiEntity -> "MULTI_ENTITY" + DetectorTypeCustom t -> t + +instance ToJSON DetectorType where + toJSON = toJSON . detectorTypeText + +instance FromJSON DetectorType where + parseJSON = withText "DetectorType" $ \case + "SINGLE_ENTITY" -> pure DetectorTypeSingleEntity + "MULTI_ENTITY" -> pure DetectorTypeMultiEntity + other -> pure (DetectorTypeCustom other) + +-- | The server-injected @user@ object carried on every detector +-- response. The plugin populates it from the authenticated caller; the +-- request never supplies it. All fields are 'Maybe' because the plugin +-- docs do not enumerate which subsets may be absent for non-admin +-- callers or internal users. +-- See +data User = User + { userName :: Maybe Text, + userBackendRoles :: Maybe [Text], + userRoles :: Maybe [Text], + userCustomAttributeNames :: Maybe [Value], + userUserRequestedTenant :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON User where + parseJSON = withObject "User" $ \v -> do + userName <- v .:? "name" + userBackendRoles <- v .:? "backend_roles" + userRoles <- v .:? "roles" + userCustomAttributeNames <- v .:? "custom_attribute_names" + userUserRequestedTenant <- v .:? "user_requested_tenant" + pure User {..} + +instance ToJSON User where + toJSON User {..} = + omitNulls + [ "name" .= userName, + "backend_roles" .= userBackendRoles, + "roles" .= userRoles, + "custom_attribute_names" .= userCustomAttributeNames, + "user_requested_tenant" .= userUserRequestedTenant + ] + +-- $detectorSchema +-- +-- The 'Detector' request body carries the user-supplied fields the +-- server needs to create or update an anomaly detector. Server-only +-- fields (@shingle_size@, @schema_version@, @last_update_time@, @user@, +-- @detector_type@, @rules@, @recency_emphasis@, @history@) are +-- deliberately absent — including them would invite callers to send +-- values the server ignores or rejects. They appear on the +-- 'DetectorResponse' round-trip shape. + +-- | The request body for @POST /_plugins/_anomaly_detection/detectors@. +-- Required fields: @name@, @time_field@, @indices@, +-- @feature_attributes@, @detection_interval@. Everything else is +-- optional and omitted on the wire when 'Nothing'. +-- See +data Detector = Detector + { detectorName :: Text, + detectorDescription :: Maybe Text, + detectorTimeField :: Text, + detectorIndices :: [Text], + detectorFeatureAttributes :: [FeatureAttribute], + detectorFilterQuery :: Maybe Value, + detectorDetectionInterval :: WindowPeriod, + detectorWindowDelay :: Maybe WindowPeriod, + detectorCategoryField :: Maybe [Text], + detectorResultIndex :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON Detector where + parseJSON = withObject "Detector" $ \v -> do + detectorName <- v .: "name" + detectorDescription <- v .:? "description" + detectorTimeField <- v .: "time_field" + detectorIndices <- v .:? "indices" .!= [] + detectorFeatureAttributes <- v .:? "feature_attributes" .!= [] + detectorFilterQuery <- v .:? "filter_query" + detectorDetectionInterval <- v .: "detection_interval" + detectorWindowDelay <- v .:? "window_delay" + detectorCategoryField <- v .:? "category_field" + detectorResultIndex <- v .:? "result_index" + pure Detector {..} + +instance ToJSON Detector where + toJSON Detector {..} = + omitNulls + [ "name" .= detectorName, + "description" .= detectorDescription, + "time_field" .= detectorTimeField, + "indices" .= detectorIndices, + "feature_attributes" .= detectorFeatureAttributes, + "filter_query" .= detectorFilterQuery, + "detection_interval" .= detectorDetectionInterval, + "window_delay" .= detectorWindowDelay, + "category_field" .= detectorCategoryField, + "result_index" .= detectorResultIndex + ] + +-- | The persisted detector shape returned in responses (the inner +-- @anomaly_detector@ object of a 'CreateDetectorResponse' / +-- 'GetDetectorResponse' / 'PreviewResponse'). Carries the full +-- 'Detector' body alongside server-injected bookkeeping fields. The +-- round-trip preserves everything the server sent, so a Get → Update +-- cycle does not lose data the caller never set. +-- See +data DetectorResponse = DetectorResponse + { detectorResponseName :: Text, + detectorResponseDescription :: Maybe Text, + detectorResponseTimeField :: Text, + detectorResponseIndices :: [Text], + detectorResponseFilterQuery :: Maybe Value, + detectorResponseDetectionInterval :: WindowPeriod, + detectorResponseWindowDelay :: Maybe WindowPeriod, + detectorResponseShingleSize :: Maybe Int, + detectorResponseSchemaVersion :: Maybe Int, + detectorResponseFeatureAttributes :: [FeatureAttribute], + detectorResponseLastUpdateTime :: Maybe Integer, + detectorResponseUser :: Maybe User, + detectorResponseDetectorType :: Maybe DetectorType, + detectorResponseCategoryField :: Maybe [Text], + detectorResponseResultIndex :: Maybe Text, + -- Server-injected bookkeeping the docs do not enumerate but live + -- responses carry. Typed as 'Value' / 'Int' until a follow-up + -- promotes them (see module docs). + detectorResponseRecencyEmphasis :: Maybe Int, + detectorResponseHistory :: Maybe Int, + detectorResponseRules :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON DetectorResponse where + parseJSON = withObject "DetectorResponse" $ \v -> do + detectorResponseName <- v .: "name" + detectorResponseDescription <- v .:? "description" + detectorResponseTimeField <- v .: "time_field" + detectorResponseIndices <- v .:? "indices" .!= [] + detectorResponseFilterQuery <- v .:? "filter_query" + detectorResponseDetectionInterval <- v .: "detection_interval" + detectorResponseWindowDelay <- v .:? "window_delay" + detectorResponseShingleSize <- v .:? "shingle_size" + detectorResponseSchemaVersion <- v .:? "schema_version" + detectorResponseFeatureAttributes <- v .:? "feature_attributes" .!= [] + detectorResponseLastUpdateTime <- v .:? "last_update_time" + detectorResponseUser <- v .:? "user" + detectorResponseDetectorType <- v .:? "detector_type" + detectorResponseCategoryField <- v .:? "category_field" + detectorResponseResultIndex <- v .:? "result_index" + detectorResponseRecencyEmphasis <- v .:? "recency_emphasis" + detectorResponseHistory <- v .:? "history" + detectorResponseRules <- v .:? "rules" + pure DetectorResponse {..} + +instance ToJSON DetectorResponse where + toJSON DetectorResponse {..} = + omitNulls + [ "name" .= detectorResponseName, + "description" .= detectorResponseDescription, + "time_field" .= detectorResponseTimeField, + "indices" .= detectorResponseIndices, + "filter_query" .= detectorResponseFilterQuery, + "detection_interval" .= detectorResponseDetectionInterval, + "window_delay" .= detectorResponseWindowDelay, + "shingle_size" .= detectorResponseShingleSize, + "schema_version" .= detectorResponseSchemaVersion, + "feature_attributes" .= detectorResponseFeatureAttributes, + "last_update_time" .= detectorResponseLastUpdateTime, + "user" .= detectorResponseUser, + "detector_type" .= detectorResponseDetectorType, + "category_field" .= detectorResponseCategoryField, + "result_index" .= detectorResponseResultIndex, + "recency_emphasis" .= detectorResponseRecencyEmphasis, + "history" .= detectorResponseHistory, + "rules" .= detectorResponseRules + ] + +-- | Response body of @POST /_plugins/_anomaly_detection/detectors@. The +-- server wraps the persisted 'DetectorResponse' in a document-write +-- envelope (@_id@, @_version@, @_primary_term@, @_seq_no@) — the same +-- shape OpenSearch uses for any persisted document. +-- See +data CreateDetectorResponse = CreateDetectorResponse + { createDetectorResponseId :: Text, + createDetectorResponseVersion :: DocVersion, + createDetectorResponsePrimaryTerm :: Int, + createDetectorResponseSeqNo :: Int, + createDetectorResponseDetector :: DetectorResponse + } + deriving stock (Eq, Show) + +instance FromJSON CreateDetectorResponse where + parseJSON = withObject "CreateDetectorResponse" $ \v -> do + createDetectorResponseId <- v .: "_id" + createDetectorResponseVersion <- v .: "_version" + createDetectorResponsePrimaryTerm <- v .: "_primary_term" + createDetectorResponseSeqNo <- v .: "_seq_no" + createDetectorResponseDetector <- v .: "anomaly_detector" + pure CreateDetectorResponse {..} + +instance ToJSON CreateDetectorResponse where + toJSON CreateDetectorResponse {..} = + object + [ "_id" .= createDetectorResponseId, + "_version" .= createDetectorResponseVersion, + "_primary_term" .= createDetectorResponsePrimaryTerm, + "_seq_no" .= createDetectorResponseSeqNo, + "anomaly_detector" .= createDetectorResponseDetector + ] + +-- | Response body of @GET /_plugins/_anomaly_detection/detectors/{id}@. +-- Structurally a superset of 'CreateDetectorResponse': the same +-- document-write envelope (@_id@, @_version@, @_primary_term@, @_seq_no@) +-- around the same inner 'DetectorResponse', plus up to three optional +-- sibling objects that the server only embeds when the corresponding +-- query flag is set on the request ('GetDetectorParams'): +-- +-- * @?job=true@ adds 'getDetectorResponseJob' (@anomaly_detector_job@); +-- * @?task=true@ adds 'getDetectorResponseRealtimeTask' +-- (@realtime_detection_task@) and 'getDetectorResponseHistoricalTask' +-- (@historical_analysis_task@). +-- +-- Without either flag the three 'Maybe' fields decode as 'Nothing', so a +-- plain GET round-trips exactly like the old 'CreateDetectorResponse'. +-- See +data GetDetectorResponse = GetDetectorResponse + { getDetectorResponseId :: Text, + getDetectorResponseVersion :: DocVersion, + getDetectorResponsePrimaryTerm :: Int, + getDetectorResponseSeqNo :: Int, + getDetectorResponseDetector :: DetectorResponse, + getDetectorResponseJob :: Maybe DetectorJob, + getDetectorResponseRealtimeTask :: Maybe DetectionTask, + getDetectorResponseHistoricalTask :: Maybe DetectionTask + } + deriving stock (Eq, Show) + +instance FromJSON GetDetectorResponse where + parseJSON = withObject "GetDetectorResponse" $ \v -> do + getDetectorResponseId <- v .: "_id" + getDetectorResponseVersion <- v .: "_version" + getDetectorResponsePrimaryTerm <- v .: "_primary_term" + getDetectorResponseSeqNo <- v .: "_seq_no" + getDetectorResponseDetector <- v .: "anomaly_detector" + getDetectorResponseJob <- v .:? "anomaly_detector_job" + getDetectorResponseRealtimeTask <- v .:? "realtime_detection_task" + getDetectorResponseHistoricalTask <- v .:? "historical_analysis_task" + pure GetDetectorResponse {..} + +instance ToJSON GetDetectorResponse where + toJSON GetDetectorResponse {..} = + omitNulls + [ "_id" .= getDetectorResponseId, + "_version" .= getDetectorResponseVersion, + "_primary_term" .= getDetectorResponsePrimaryTerm, + "_seq_no" .= getDetectorResponseSeqNo, + "anomaly_detector" .= getDetectorResponseDetector, + "anomaly_detector_job" .= getDetectorResponseJob, + "realtime_detection_task" .= getDetectorResponseRealtimeTask, + "historical_analysis_task" .= getDetectorResponseHistoricalTask + ] + +-- | Optional flags for 'getDetector' that select which extra sibling +-- objects the server embeds in the 'GetDetectorResponse'. Both default +-- to 'False' via 'defaultGetDetectorParams', reproducing the bare GET. +-- See +data GetDetectorParams = GetDetectorParams + { -- | @?job=true@ — embed 'getDetectorResponseJob' (real-time job + -- schedule / state). + getDetectorParamsJob :: Bool, + -- | @?task=true@ — embed 'getDetectorResponseRealtimeTask' and + -- 'getDetectorResponseHistoricalTask' (running task records). + getDetectorParamsTask :: Bool + } + deriving stock (Eq, Show) + +-- | The all-false 'GetDetectorParams', equivalent to a bare GET. +defaultGetDetectorParams :: GetDetectorParams +defaultGetDetectorParams = GetDetectorParams {getDetectorParamsJob = False, getDetectorParamsTask = False} + +-- ========================================================================= +-- Detector job (anomaly_detector_job, returned with ?job=true) +-- ========================================================================= + +-- | The @anomaly_detector_job@ object the server embeds in a +-- 'GetDetectorResponse' when the request carries @?job=true@. The job +-- binds the real-time detector's schedule and runtime bookkeeping. +-- All fields are 'Maybe' because the docs describe the shape only by +-- example; some may be absent for internal or disabled detectors. +-- See +data DetectorJob = DetectorJob + { detectorJobName :: Maybe Text, + detectorJobSchedule :: Maybe DetectorJobSchedule, + detectorJobWindowDelay :: Maybe WindowPeriod, + detectorJobEnabled :: Maybe Bool, + detectorJobEnabledTime :: Maybe Integer, + detectorJobLastUpdateTime :: Maybe Integer, + detectorJobLockDurationSeconds :: Maybe Int, + detectorJobUser :: Maybe User + } + deriving stock (Eq, Show) + +instance FromJSON DetectorJob where + parseJSON = withObject "DetectorJob" $ \v -> do + detectorJobName <- v .:? "name" + detectorJobSchedule <- v .:? "schedule" + detectorJobWindowDelay <- v .:? "window_delay" + detectorJobEnabled <- v .:? "enabled" + detectorJobEnabledTime <- v .:? "enabled_time" + detectorJobLastUpdateTime <- v .:? "last_update_time" + detectorJobLockDurationSeconds <- v .:? "lock_duration_seconds" + detectorJobUser <- v .:? "user" + pure DetectorJob {..} + +instance ToJSON DetectorJob where + toJSON DetectorJob {..} = + omitNulls + [ "name" .= detectorJobName, + "schedule" .= detectorJobSchedule, + "window_delay" .= detectorJobWindowDelay, + "enabled" .= detectorJobEnabled, + "enabled_time" .= detectorJobEnabledTime, + "last_update_time" .= detectorJobLastUpdateTime, + "lock_duration_seconds" .= detectorJobLockDurationSeconds, + "user" .= detectorJobUser + ] + +-- | The @schedule@ object of a 'DetectorJob'. The docs only show the +-- 'DetectorJobScheduleInterval' (@{interval: {...}}@) form; other +-- schedule variants (e.g. cron) are not documented and would need a +-- follow-up to type. They surface as a decode failure today. +-- See +data DetectorJobSchedule = DetectorJobSchedule + { detectorJobScheduleInterval :: DetectorJobScheduleInterval + } + deriving stock (Eq, Show) + +instance FromJSON DetectorJobSchedule where + parseJSON = withObject "DetectorJobSchedule" $ \v -> do + detectorJobScheduleInterval <- v .: "interval" + pure DetectorJobSchedule {..} + +instance ToJSON DetectorJobSchedule where + toJSON DetectorJobSchedule {..} = + object ["interval" .= detectorJobScheduleInterval] + +-- | The @interval@ object inside a 'DetectorJobSchedule'. Mirrors the +-- 'WindowPeriod' @{interval, unit}@ pair but adds an optional +-- @start_time@ (epoch ms) the scheduler uses to stagger the first run. +-- See +data DetectorJobScheduleInterval = DetectorJobScheduleInterval + { detectorJobScheduleIntervalStartTime :: Maybe Integer, + detectorJobScheduleIntervalPeriod :: Int, + detectorJobScheduleIntervalUnit :: PeriodUnit + } + deriving stock (Eq, Show) + +instance FromJSON DetectorJobScheduleInterval where + parseJSON = withObject "DetectorJobScheduleInterval" $ \v -> do + detectorJobScheduleIntervalStartTime <- v .:? "start_time" + detectorJobScheduleIntervalPeriod <- v .: "period" + detectorJobScheduleIntervalUnit <- v .: "unit" + pure DetectorJobScheduleInterval {..} + +instance ToJSON DetectorJobScheduleInterval where + toJSON DetectorJobScheduleInterval {..} = + omitNulls + [ "start_time" .= detectorJobScheduleIntervalStartTime, + "period" .= detectorJobScheduleIntervalPeriod, + "unit" .= detectorJobScheduleIntervalUnit + ] + +-- ========================================================================= +-- Detection tasks (realtime_detection_task / historical_analysis_task, +-- returned with ?task=true) +-- ========================================================================= + +-- | The @task_type@ enum carried by a 'DetectionTask'. The docs +-- enumerate the two single-entity values (@REALTIME_SINGLE_ENTITY@, +-- @HISTORICAL_SINGLE_ENTITY@); the two multi-entity values +-- (@REALTIME_MULTI_ENTITY@, @HISTORICAL_MULTI_ENTITY@) are inferred from +-- the naming convention. Unknown values parse as +-- 'DetectionTaskTypeCustom' so future plugin releases surface as a +-- parsed value rather than a decode failure. +data DetectionTaskType + = DetectionTaskTypeRealtimeSingleEntity + | DetectionTaskTypeHistoricalSingleEntity + | DetectionTaskTypeRealtimeMultiEntity + | DetectionTaskTypeHistoricalMultiEntity + | DetectionTaskTypeCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'DetectionTaskType' — the same mapping the +-- 'ToJSON' \/ 'FromJSON' instances use. +detectionTaskTypeText :: DetectionTaskType -> Text +detectionTaskTypeText = \case + DetectionTaskTypeRealtimeSingleEntity -> "REALTIME_SINGLE_ENTITY" + DetectionTaskTypeHistoricalSingleEntity -> "HISTORICAL_SINGLE_ENTITY" + DetectionTaskTypeRealtimeMultiEntity -> "REALTIME_MULTI_ENTITY" + DetectionTaskTypeHistoricalMultiEntity -> "HISTORICAL_MULTI_ENTITY" + DetectionTaskTypeCustom t -> t + +instance ToJSON DetectionTaskType where + toJSON = toJSON . detectionTaskTypeText + +instance FromJSON DetectionTaskType where + parseJSON = withText "DetectionTaskType" $ \case + "REALTIME_SINGLE_ENTITY" -> pure DetectionTaskTypeRealtimeSingleEntity + "HISTORICAL_SINGLE_ENTITY" -> pure DetectionTaskTypeHistoricalSingleEntity + "REALTIME_MULTI_ENTITY" -> pure DetectionTaskTypeRealtimeMultiEntity + "HISTORICAL_MULTI_ENTITY" -> pure DetectionTaskTypeHistoricalMultiEntity + other -> pure (DetectionTaskTypeCustom other) + +-- | A detection task record. The server embeds one of these under +-- @realtime_detection_task@ (the running real-time job) and/or +-- @historical_analysis_task@ (a historical backfill batch) in a +-- 'GetDetectorResponse' when the request carries @?task=true@. +-- +-- The shape is the union of the two documented examples: some fields +-- appear only on the real-time variant (@estimated_minutes_left@) and +-- some only on the historical variant (@current_piece@, @worker_node@, +-- 'detectionTaskDetectionDateRange'), so every field except @task_id@ +-- is 'Maybe'. Progress fractions are 'Scientific' because the plugin +-- emits them as either an integer (@0@) or a fraction (@0.89285713@); +-- 'Scientific' round-trips both losslessly. +-- See +data DetectionTask = DetectionTask + { detectionTaskTaskId :: Text, + detectionTaskType :: Maybe DetectionTaskType, + detectionTaskState :: Maybe Text, + detectionTaskDetectorId :: Maybe DetectorId, + detectionTaskDetector :: Maybe DetectorResponse, + detectionTaskTaskProgress :: Maybe Scientific, + detectionTaskInitProgress :: Maybe Scientific, + detectionTaskIsLatest :: Maybe Bool, + detectionTaskExecutionStartTime :: Maybe Integer, + detectionTaskLastUpdateTime :: Maybe Integer, + detectionTaskCurrentPiece :: Maybe Integer, + detectionTaskDetectionDateRange :: Maybe DetectionDateRange, + detectionTaskEstimatedMinutesLeft :: Maybe Int, + detectionTaskCoordinatingNode :: Maybe Text, + detectionTaskWorkerNode :: Maybe Text, + detectionTaskStartedBy :: Maybe Text, + detectionTaskError :: Maybe Text, + detectionTaskUser :: Maybe User + } + deriving stock (Eq, Show) + +instance FromJSON DetectionTask where + parseJSON = withObject "DetectionTask" $ \v -> do + detectionTaskTaskId <- v .: "task_id" + detectionTaskType <- v .:? "task_type" + detectionTaskState <- v .:? "state" + detectionTaskDetectorId <- v .:? "detector_id" + detectionTaskDetector <- v .:? "detector" + detectionTaskTaskProgress <- v .:? "task_progress" + detectionTaskInitProgress <- v .:? "init_progress" + detectionTaskIsLatest <- v .:? "is_latest" + detectionTaskExecutionStartTime <- v .:? "execution_start_time" + detectionTaskLastUpdateTime <- v .:? "last_update_time" + detectionTaskCurrentPiece <- v .:? "current_piece" + detectionTaskDetectionDateRange <- v .:? "detection_date_range" + detectionTaskEstimatedMinutesLeft <- v .:? "estimated_minutes_left" + detectionTaskCoordinatingNode <- v .:? "coordinating_node" + detectionTaskWorkerNode <- v .:? "worker_node" + detectionTaskStartedBy <- v .:? "started_by" + detectionTaskError <- v .:? "error" + detectionTaskUser <- v .:? "user" + pure DetectionTask {..} + +instance ToJSON DetectionTask where + toJSON DetectionTask {..} = + omitNulls + [ "task_id" .= detectionTaskTaskId, + "task_type" .= detectionTaskType, + "state" .= detectionTaskState, + "detector_id" .= detectionTaskDetectorId, + "detector" .= detectionTaskDetector, + "task_progress" .= detectionTaskTaskProgress, + "init_progress" .= detectionTaskInitProgress, + "is_latest" .= detectionTaskIsLatest, + "execution_start_time" .= detectionTaskExecutionStartTime, + "last_update_time" .= detectionTaskLastUpdateTime, + "current_piece" .= detectionTaskCurrentPiece, + "detection_date_range" .= detectionTaskDetectionDateRange, + "estimated_minutes_left" .= detectionTaskEstimatedMinutesLeft, + "coordinating_node" .= detectionTaskCoordinatingNode, + "worker_node" .= detectionTaskWorkerNode, + "started_by" .= detectionTaskStartedBy, + "error" .= detectionTaskError, + "user" .= detectionTaskUser + ] + +-- | The @detection_date_range@ object carried by a historical +-- 'DetectionTask'. Bounds the historical window the batch is +-- backfilling, as epoch-ms timestamps. Absent on real-time tasks. +-- See +data DetectionDateRange = DetectionDateRange + { detectionDateRangeStartTime :: Maybe Integer, + detectionDateRangeEndTime :: Maybe Integer + } + deriving stock (Eq, Show) + +instance FromJSON DetectionDateRange where + parseJSON = withObject "DetectionDateRange" $ \v -> do + detectionDateRangeStartTime <- v .:? "start_time" + detectionDateRangeEndTime <- v .:? "end_time" + pure DetectionDateRange {..} + +instance ToJSON DetectionDateRange where + toJSON DetectionDateRange {..} = + omitNulls + [ "start_time" .= detectionDateRangeStartTime, + "end_time" .= detectionDateRangeEndTime + ] + +-- ========================================================================= +-- Preview endpoint: POST /_plugins/_anomaly_detection/detectors/_preview +-- ========================================================================= + +-- | Request body for the Anomaly Detection plugin Preview Detector API +-- (@POST /_plugins/_anomaly_detection/detectors/_preview@). The two +-- fields @period_start@ and @period_end@ are epoch-ms timestamps +-- bracketing the historical window the plugin should re-analyze. The +-- plugin requires both (a missing value yields HTTP 400 with +-- @Must set both period start and end date with epoch of milliseconds@). +-- +-- The optional 'previewRequestDetectorId' names the detector to preview +-- (set by 'previewDetector' from its path argument, or directly by the +-- caller of 'previewDetectorInline'); 'previewRequestDetector' carries a +-- full unpersisted 'Detector' config for the inline form. Both are +-- omitted from the wire payload when 'Nothing', so a periods-only body +-- round-trips as just the two timestamps. +-- See +data PreviewRequest = PreviewRequest + { previewRequestPeriodStart :: Integer, + previewRequestPeriodEnd :: Integer, + previewRequestDetector :: Maybe Detector, + previewRequestDetectorId :: Maybe DetectorId + } + deriving stock (Eq, Show) + +instance FromJSON PreviewRequest where + parseJSON = withObject "PreviewRequest" $ \v -> do + previewRequestPeriodStart <- v .: "period_start" + previewRequestPeriodEnd <- v .: "period_end" + previewRequestDetector <- v .:? "detector" + previewRequestDetectorId <- v .:? "detector_id" + pure PreviewRequest {..} + +instance ToJSON PreviewRequest where + toJSON PreviewRequest {..} = + omitNulls + [ "period_start" .= previewRequestPeriodStart, + "period_end" .= previewRequestPeriodEnd, + "detector" .= previewRequestDetector, + "detector_id" .= previewRequestDetectorId + ] + +-- | One entry in the @feature_data@ array of an 'AnomalyResult'. The +-- @feature_id@ echoes the corresponding 'FeatureAttribute' identifier; +-- @data@ is the observed feature value for the window. Both come back +-- as @0@ in fresh / sparse fixtures, so they are 'Maybe' for safety. +data FeatureData = FeatureData + { featureDataFeatureId :: Maybe Text, + featureDataFeatureName :: Text, + featureDataData :: Maybe Double + } + deriving stock (Eq, Show) + +instance FromJSON FeatureData where + parseJSON = withObject "FeatureData" $ \v -> do + featureDataFeatureId <- v .:? "feature_id" + featureDataFeatureName <- v .: "feature_name" + featureDataData <- v .:? "data" + pure FeatureData {..} + +instance ToJSON FeatureData where + toJSON FeatureData {..} = + omitNulls + [ "feature_id" .= featureDataFeatureId, + "feature_name" .= featureDataFeatureName, + "data" .= featureDataData + ] + +-- | One entry in the @entity@ array of a multi-entity 'AnomalyResult'. +-- The plugin emits @entity@ only when the detector was created with a +-- @category_field@; each entry names the categorical dimension +-- (@name@) and the value the anomaly was graded against (@value@). +-- See +data Entity = Entity + { entityName :: Text, + entityValue :: Text + } + deriving stock (Eq, Show) + +instance FromJSON Entity where + parseJSON = withObject "Entity" $ \v -> do + entityName <- v .: "name" + entityValue <- v .: "value" + pure Entity {..} + +instance ToJSON Entity where + toJSON Entity {..} = + object + [ "name" .= entityName, + "value" .= entityValue + ] + +-- | One entry in the @anomaly_result@ array of a 'PreviewResponse'. +-- Every field is 'Maybe' or has a sensible empty default because the +-- plugin emits a sparse shape early in training (zero @anomaly_grade@, +-- zero @confidence@, empty @feature_data@) and a fuller shape once the +-- model has converged. +-- See +data AnomalyResult = AnomalyResult + { anomalyResultDetectorId :: Maybe Text, + anomalyResultDataStartTime :: Integer, + anomalyResultDataEndTime :: Integer, + anomalyResultSchemaVersion :: Maybe Int, + anomalyResultFeatureData :: [FeatureData], + anomalyResultAnomalyGrade :: Maybe Double, + anomalyResultConfidence :: Maybe Double, + anomalyResultEntity :: Maybe [Entity], + anomalyResultUser :: Maybe User + } + deriving stock (Eq, Show) + +instance FromJSON AnomalyResult where + parseJSON = withObject "AnomalyResult" $ \v -> do + anomalyResultDetectorId <- v .:? "detector_id" + anomalyResultDataStartTime <- v .: "data_start_time" + anomalyResultDataEndTime <- v .: "data_end_time" + anomalyResultSchemaVersion <- v .:? "schema_version" + anomalyResultFeatureData <- v .:? "feature_data" .!= [] + anomalyResultAnomalyGrade <- v .:? "anomaly_grade" + anomalyResultConfidence <- v .:? "confidence" + anomalyResultEntity <- v .:? "entity" + anomalyResultUser <- v .:? "user" + pure AnomalyResult {..} + +instance ToJSON AnomalyResult where + toJSON AnomalyResult {..} = + omitNulls + [ "detector_id" .= anomalyResultDetectorId, + "data_start_time" .= anomalyResultDataStartTime, + "data_end_time" .= anomalyResultDataEndTime, + "schema_version" .= anomalyResultSchemaVersion, + "feature_data" .= anomalyResultFeatureData, + "anomaly_grade" .= anomalyResultAnomalyGrade, + "confidence" .= anomalyResultConfidence, + "entity" .= anomalyResultEntity, + "user" .= anomalyResultUser + ] + +-- | Response body of @_preview@: an @anomaly_result@ array plus the +-- detector snapshot the plugin graded against (the same +-- 'DetectorResponse' shape returned by create / get). +-- See +data PreviewResponse = PreviewResponse + { previewResponseAnomalyResult :: [AnomalyResult], + previewResponseAnomalyDetector :: DetectorResponse + } + deriving stock (Eq, Show) + +instance FromJSON PreviewResponse where + parseJSON = withObject "PreviewResponse" $ \v -> do + previewResponseAnomalyResult <- v .:? "anomaly_result" .!= [] + previewResponseAnomalyDetector <- v .: "anomaly_detector" + pure PreviewResponse {..} + +instance ToJSON PreviewResponse where + toJSON PreviewResponse {..} = + object + [ "anomaly_result" .= previewResponseAnomalyResult, + "anomaly_detector" .= previewResponseAnomalyDetector + ] + +-- ========================================================================= +-- Update / Delete detector +-- ========================================================================= + +-- | The standard @{total, successful, skipped, failed}@ shard-report +-- sub-object carried by AD delete and search responses. Defined locally +-- (mirroring the 'AlertingShards' pattern) rather than borrowing a +-- Common type, to keep the AD module self-contained. +data AnomalyShards = AnomalyShards + { anomalyShardsTotal :: Int, + anomalyShardsSuccessful :: Int, + anomalyShardsSkipped :: Int, + anomalyShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON AnomalyShards where + parseJSON = withObject "AnomalyShards" $ \v -> + AnomalyShards + <$> v .:? "total" .!= 0 + <*> v .:? "successful" .!= 0 + <*> v .:? "skipped" .!= 0 + <*> v .:? "failed" .!= 0 + +instance ToJSON AnomalyShards where + toJSON AnomalyShards {..} = + object + [ "total" .= anomalyShardsTotal, + "successful" .= anomalyShardsSuccessful, + "skipped" .= anomalyShardsSkipped, + "failed" .= anomalyShardsFailed + ] + +-- | Response body of @DELETE /_plugins/_anomaly_detection/detectors/{id}@. +-- The AD delete endpoint returns the bare Elasticsearch delete-document +-- envelope (@_index@, @_id@, @_version@, @result@, @forced_refresh@, +-- @_shards@, @_seq_no@, @_primary_term@) — NOT an @{acknowledged: true}@ +-- ack, so an 'Acknowledged' decoder would raise 'EsProtocolException' at +-- runtime. Modelled verbatim, mirroring the Alerting 'DeleteMonitorResponse' +-- and Security Analytics 'DeleteSADetectorResponse' precedent. +-- See +data DeleteDetectorResponse = DeleteDetectorResponse + { deleteDetectorResponseIndex :: Text, + deleteDetectorResponseId :: Text, + deleteDetectorResponseVersion :: Int, + deleteDetectorResponseResult :: Text, + deleteDetectorResponseForcedRefresh :: Bool, + deleteDetectorResponseShards :: AnomalyShards, + deleteDetectorResponseSeqNo :: Int, + deleteDetectorResponsePrimaryTerm :: Int + } + deriving stock (Eq, Show) + +instance FromJSON DeleteDetectorResponse where + parseJSON = withObject "DeleteDetectorResponse" $ \v -> + DeleteDetectorResponse + <$> v .: "_index" + <*> v .: "_id" + <*> v .: "_version" + <*> v .: "result" + <*> v .:? "forced_refresh" .!= False + <*> v .: "_shards" + <*> v .: "_seq_no" + <*> v .: "_primary_term" + +instance ToJSON DeleteDetectorResponse where + toJSON DeleteDetectorResponse {..} = + object + [ "_index" .= deleteDetectorResponseIndex, + "_id" .= deleteDetectorResponseId, + "_version" .= deleteDetectorResponseVersion, + "result" .= deleteDetectorResponseResult, + "forced_refresh" .= deleteDetectorResponseForcedRefresh, + "_shards" .= deleteDetectorResponseShards, + "_seq_no" .= deleteDetectorResponseSeqNo, + "_primary_term" .= deleteDetectorResponsePrimaryTerm + ] + +-- ========================================================================= +-- Start / Stop detector job +-- ========================================================================= + +-- | Request body for the historical-analysis form of +-- @POST /_plugins/_anomaly_detection/detectors/{id}/_start@. +-- +-- The @_start@ endpoint serves two roles: with no body it starts the +-- real-time detector job, and with a body it kicks off a one-shot +-- historical backfill over the window bounded by +-- 'startDetectorJobRequestStartTime' / 'startDetectorJobRequestEndTime' +-- (epoch milliseconds). Both @start_time@ and @end_time@ are required +-- when a body is sent; the server returns a 'DetectorJobAcknowledgment' +-- whose @_id@ is the historical batch task id (a UUID), distinct from +-- the detector id returned by the real-time form. +-- See +data StartDetectorJobRequest = StartDetectorJobRequest + { startDetectorJobRequestStartTime :: Integer, + startDetectorJobRequestEndTime :: Integer + } + deriving stock (Eq, Show) + +instance FromJSON StartDetectorJobRequest where + parseJSON = withObject "StartDetectorJobRequest" $ \v -> do + startDetectorJobRequestStartTime <- v .: "start_time" + startDetectorJobRequestEndTime <- v .: "end_time" + pure StartDetectorJobRequest {..} + +instance ToJSON StartDetectorJobRequest where + toJSON StartDetectorJobRequest {..} = + object + [ "start_time" .= startDetectorJobRequestStartTime, + "end_time" .= startDetectorJobRequestEndTime + ] + +-- | Response body of @_start@ and @_stop@. Both endpoints return the +-- same small write-acknowledgment envelope (@_id@, @_version@, +-- @_seq_no@, @_primary_term@). For @_start@, @_id@ is the real-time job +-- id (= the detector id) when no body is sent, or the historical batch +-- task id (a UUID) when a 'StartDetectorJobRequest' body is sent. For +-- @_stop@, @_version@, @_seq_no@ and @_primary_term@ are zeroed on +-- success. Note @_version@ is a plain 'Int' (not 'DocVersion') because +-- the @_stop@ response legitimately carries @0@, which is below +-- 'DocVersion'\'s @minBound@ of @1@. +-- See +-- and +data DetectorJobAcknowledgment = DetectorJobAcknowledgment + { detectorJobAcknowledgmentId :: Text, + detectorJobAcknowledgmentVersion :: Int, + detectorJobAcknowledgmentSeqNo :: Int, + detectorJobAcknowledgmentPrimaryTerm :: Int + } + deriving stock (Eq, Show) + +instance FromJSON DetectorJobAcknowledgment where + parseJSON = withObject "DetectorJobAcknowledgment" $ \v -> do + detectorJobAcknowledgmentId <- v .: "_id" + -- OS 2.x only returns @_id@ for start/stop acknowledgments; the + -- @_version@, @_seq_no@, @_primary_term@ fields are absent (older + -- docs and some patch levels emit them zeroed). Default to 0 when + -- missing so the parser tolerates both wire shapes. + detectorJobAcknowledgmentVersion <- v .:? "_version" .!= 0 + detectorJobAcknowledgmentSeqNo <- v .:? "_seq_no" .!= 0 + detectorJobAcknowledgmentPrimaryTerm <- v .:? "_primary_term" .!= 0 + pure DetectorJobAcknowledgment {..} + +instance ToJSON DetectorJobAcknowledgment where + toJSON DetectorJobAcknowledgment {..} = + object + [ "_id" .= detectorJobAcknowledgmentId, + "_version" .= detectorJobAcknowledgmentVersion, + "_seq_no" .= detectorJobAcknowledgmentSeqNo, + "_primary_term" .= detectorJobAcknowledgmentPrimaryTerm + ] + +-- ========================================================================= +-- Validate detector: POST /_plugins/_anomaly_detection/detectors/_validate[/mode] +-- ========================================================================= + +-- | Selects the validation mode (the trailing path segment). The bare +-- @\/_validate@ form is a server-side alias for @\/_validate\/detector@; +-- 'ValidateDetector' covers both. @\/_validate\/model@ validates against +-- source data and is advisory only. +-- See +data ValidateDetectorMode = ValidateDetector | ValidateModel + deriving stock (Eq, Show) + +-- | The trailing path segment(s) for 'ValidateDetectorMode' — empty for +-- the detector default (bare @\/_validate@), @["model"]@ for the model +-- advisory check. +validateDetectorModeSegments :: ValidateDetectorMode -> [Text] +validateDetectorModeSegments = \case + ValidateDetector -> [] + ValidateModel -> ["model"] + +-- | Response body of the validate endpoint. Variable by outcome: an empty +-- object @{}@ when no issues are found; @{"detector": {...}}@ for blocking +-- issues from @\/_validate\/detector@; @{"model": {...}}@ for advisory +-- issues from @\/_validate\/model@. Carried as an opaque aeson 'Value' so +-- every shape round-trips losslessly (the pragmatic-typing precedent used +-- for ML Commons @predict@). +newtype ValidateDetectorResponse = ValidateDetectorResponse + { getValidateDetectorResponse :: Value + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- ========================================================================= +-- Search envelope: detectors / results / tasks +-- ========================================================================= + +-- | The @hits.total.relation@ discriminator on an AD search response. +data AnomalySearchTotalRelation + = AnomalySearchTotalRelationEq + | AnomalySearchTotalRelationGe + | AnomalySearchTotalRelationOther Text + deriving stock (Eq, Show) + +instance FromJSON AnomalySearchTotalRelation where + parseJSON = withText "AnomalySearchTotalRelation" $ \case + "eq" -> pure AnomalySearchTotalRelationEq + "ge" -> pure AnomalySearchTotalRelationGe + other -> pure (AnomalySearchTotalRelationOther other) + +instance ToJSON AnomalySearchTotalRelation where + toJSON = \case + AnomalySearchTotalRelationEq -> "eq" + AnomalySearchTotalRelationGe -> "ge" + AnomalySearchTotalRelationOther t -> toJSON t + +-- | The @hits.total@ sub-object on an AD search response +-- (@{value, relation}@). +data AnomalySearchTotal = AnomalySearchTotal + { anomalySearchTotalValue :: Int, + anomalySearchTotalRelation :: AnomalySearchTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON AnomalySearchTotal where + parseJSON = withObject "AnomalySearchTotal" $ \v -> + AnomalySearchTotal + <$> v .: "value" + <*> v .: "relation" + +instance ToJSON AnomalySearchTotal where + toJSON AnomalySearchTotal {..} = + object + [ "value" .= anomalySearchTotalValue, + "relation" .= anomalySearchTotalRelation + ] + +-- | A single hit in @hits.hits[]@ on an AD search response. The @_source@ +-- is decoded as the @source@ type parameter: 'DetectorResponse' for the +-- detector-config index, 'Value' for the variable anomaly-result and task +-- records (pragmatic typing — the full schema lives in the separate AD +-- result-mapping doc page). +data AnomalySearchHit source = AnomalySearchHit + { anomalySearchHitIndex :: Maybe Text, + anomalySearchHitId :: Text, + anomalySearchHitVersion :: Maybe Int, + anomalySearchHitSeqNo :: Maybe Int, + anomalySearchHitPrimaryTerm :: Maybe Int, + anomalySearchHitScore :: Maybe Double, + anomalySearchHitSource :: source + } + deriving stock (Eq, Show) + +instance (FromJSON source) => FromJSON (AnomalySearchHit source) where + parseJSON = withObject "AnomalySearchHit" $ \v -> + AnomalySearchHit + <$> v .:? "_index" + <*> v .: "_id" + <*> v .:? "_version" + <*> v .:? "_seq_no" + <*> v .:? "_primary_term" + <*> v .:? "_score" + <*> v .: "_source" + +instance (ToJSON source) => ToJSON (AnomalySearchHit source) where + toJSON AnomalySearchHit {..} = + omitNulls + [ "_index" .= anomalySearchHitIndex, + "_id" .= anomalySearchHitId, + "_version" .= anomalySearchHitVersion, + "_seq_no" .= anomalySearchHitSeqNo, + "_primary_term" .= anomalySearchHitPrimaryTerm, + "_score" .= anomalySearchHitScore, + "_source" .= anomalySearchHitSource + ] + +-- | The standard OpenSearch search-response envelope +-- (@took@, @timed_out@, @_shards@, @hits.total@, @hits.max_score@, +-- @hits.hits@) parametrised by the @_source@ type. Specialised by the AD +-- search endpoints: +-- +-- * 'SearchDetectorsResponse' — @_source@ is a typed 'DetectorResponse'. +-- * 'SearchDetectorResultsResponse' / 'SearchDetectorTasksResponse' — +-- @_source@ is an opaque 'Value' (the anomaly-result and task records +-- carry many optional fields; the full mapping lives in a separate doc +-- page). +data AnomalySearchResponse source = AnomalySearchResponse + { anomalySearchResponseTook :: Int, + anomalySearchResponseTimedOut :: Bool, + anomalySearchResponseShards :: AnomalyShards, + anomalySearchResponseTotal :: AnomalySearchTotal, + anomalySearchResponseMaxScore :: Maybe Double, + anomalySearchResponseHits :: [AnomalySearchHit source] + } + deriving stock (Eq, Show) + +instance (FromJSON source) => FromJSON (AnomalySearchResponse source) where + parseJSON = withObject "AnomalySearchResponse" $ \v -> do + hits <- v .: "hits" + AnomalySearchResponse + <$> v .: "took" + <*> v .: "timed_out" + <*> v .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance (ToJSON source) => ToJSON (AnomalySearchResponse source) where + toJSON AnomalySearchResponse {..} = + object + [ "took" .= anomalySearchResponseTook, + "timed_out" .= anomalySearchResponseTimedOut, + "_shards" .= anomalySearchResponseShards, + "hits" + .= object + [ "total" .= anomalySearchResponseTotal, + "max_score" .= anomalySearchResponseMaxScore, + "hits" .= anomalySearchResponseHits + ] + ] + +-- | Project the @source@ values out of an 'AnomalySearchResponse' +-- (convenience for callers who only want the hits). +anomalySearchResponseSources :: AnomalySearchResponse source -> [source] +anomalySearchResponseSources = map anomalySearchHitSource . anomalySearchResponseHits + +-- | Response of @POST /_plugins/_anomaly_detection/detectors/_search@ — +-- a search over the detector-config index. @_source@ is a typed +-- 'DetectorResponse'. +type SearchDetectorsResponse = AnomalySearchResponse DetectorResponse + +-- | Response of @POST /_plugins/_anomaly_detection/detectors/results/_search@. +-- @_source@ is an opaque 'Value' (the anomaly-result record). +type SearchDetectorResultsResponse = AnomalySearchResponse Value + +-- | Response of @DELETE /_plugins/_anomaly_detection/detectors/results@. +-- The plugin returns the bare @_delete_by_query@ envelope, which is +-- structurally identical to the document-API 'DeletedDocuments' — we +-- alias to it rather than duplicate the type. Fork here (make a +-- dedicated AD type) if the plugin ever diverges from the document +-- envelope. +type DeleteDetectorResultsResponse = DeletedDocuments + +-- | Response of @POST /_plugins/_anomaly_detection/detectors/tasks/_search@. +-- @_source@ is an opaque 'Value' (the task record). +type SearchDetectorTasksResponse = AnomalySearchResponse Value + +-- ========================================================================= +-- Profile detector: GET /_plugins/_anomaly_detection/detectors/{id}/_profile[/types|?_all=true] +-- ========================================================================= + +-- | Response body of the profile endpoint. The shape varies widely by +-- requested profile kind (@_profile@, @_profile\/{type}@, @?_all=true@, +-- entity-filtered) and by detector kind (single-entity vs +-- high-cardinality); the docs enumerate many distinct sub-shapes. +-- Carried as an opaque aeson 'Value' so every variant round-trips +-- losslessly (pragmatic-typing precedent). +-- See +newtype DetectorProfileResponse = DetectorProfileResponse + { getDetectorProfileResponse :: Value + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- ========================================================================= +-- Detector stats: GET /_plugins/_anomaly_detection/stats[/{stat}] etc. +-- ========================================================================= + +-- | Response body of the stats endpoint. The full form returns several +-- top-level index-status keys plus a @nodes@ map; the filtered forms +-- (@\/stats\/{stat}@, @\/{node_id}\/stats@) return only a subset. +-- Carried as an opaque aeson 'Value' (pragmatic-typing precedent) so the +-- variable top-level surface round-trips losslessly. +-- See +newtype DetectorStatsResponse = DetectorStatsResponse + { getDetectorStatsResponse :: Value + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- ========================================================================= +-- Top anomalies: GET /_plugins/_anomaly_detection/detectors/{id}/results/_topAnomalies +-- ========================================================================= + +-- | The @order@ enum for 'TopAnomaliesRequest' — @severity@ (default) or +-- @occurrence@. +data TopAnomaliesOrder + = TopAnomaliesOrderSeverity + | TopAnomaliesOrderOccurrence + deriving stock (Eq, Show) + +-- | Wire string for a 'TopAnomaliesOrder'. +topAnomaliesOrderText :: TopAnomaliesOrder -> Text +topAnomaliesOrderText = \case + TopAnomaliesOrderSeverity -> "severity" + TopAnomaliesOrderOccurrence -> "occurrence" + +instance ToJSON TopAnomaliesOrder where + toJSON = toJSON . topAnomaliesOrderText + +instance FromJSON TopAnomaliesOrder where + parseJSON = withText "TopAnomaliesOrder" $ \case + "severity" -> pure TopAnomaliesOrderSeverity + "occurrence" -> pure TopAnomaliesOrderOccurrence + other -> + fail ("unknown TopAnomaliesOrder: " <> T.unpack other) + +-- | Request body for the top-anomalies endpoint (sent with the GET). +-- @start_time_ms@ and @end_time_ms@ are required epoch-ms; the rest are +-- optional. 'Nothing' for @size@ leaves the server default (10, max +-- 10000); 'Nothing' for @category_field@ defaults to all detector +-- category fields; 'Nothing' for @task_id@ is only meaningful when the +-- request is historical (ignored otherwise). +-- See +data TopAnomaliesRequest = TopAnomaliesRequest + { topAnomaliesRequestSize :: Maybe Int, + topAnomaliesRequestCategoryField :: Maybe [Text], + topAnomaliesRequestOrder :: Maybe TopAnomaliesOrder, + topAnomaliesRequestTaskId :: Maybe Text, + topAnomaliesRequestStartTimeMs :: Integer, + topAnomaliesRequestEndTimeMs :: Integer + } + deriving stock (Eq, Show) + +-- | The minimal 'TopAnomaliesRequest' carrying only the two required +-- epoch-ms timestamps; every optional field is 'Nothing' (server +-- defaults). +defaultTopAnomaliesRequest :: Integer -> Integer -> TopAnomaliesRequest +defaultTopAnomaliesRequest start end = + TopAnomaliesRequest + { topAnomaliesRequestSize = Nothing, + topAnomaliesRequestCategoryField = Nothing, + topAnomaliesRequestOrder = Nothing, + topAnomaliesRequestTaskId = Nothing, + topAnomaliesRequestStartTimeMs = start, + topAnomaliesRequestEndTimeMs = end + } + +instance ToJSON TopAnomaliesRequest where + toJSON TopAnomaliesRequest {..} = + omitNulls + [ "size" .= topAnomaliesRequestSize, + "category_field" .= topAnomaliesRequestCategoryField, + "order" .= topAnomaliesRequestOrder, + "task_id" .= topAnomaliesRequestTaskId, + "start_time_ms" .= topAnomaliesRequestStartTimeMs, + "end_time_ms" .= topAnomaliesRequestEndTimeMs + ] + +instance FromJSON TopAnomaliesRequest where + parseJSON = withObject "TopAnomaliesRequest" $ \v -> + TopAnomaliesRequest + <$> v .:? "size" + <*> v .:? "category_field" + <*> v .:? "order" + <*> v .:? "task_id" + <*> v .: "start_time_ms" + <*> v .: "end_time_ms" + +-- | One bucket in the top-anomalies response: a categorical @key@ (a map +-- from category-field name to value), the @doc_count@ of anomalies in +-- that bucket, and the @max_anomaly_grade@ observed. +data TopAnomalyBucket = TopAnomalyBucket + { topAnomalyBucketKey :: Value, + topAnomalyBucketDocCount :: Int, + topAnomalyBucketMaxAnomalyGrade :: Double + } + deriving stock (Eq, Show) + +instance FromJSON TopAnomalyBucket where + parseJSON = withObject "TopAnomalyBucket" $ \v -> + TopAnomalyBucket + <$> v .: "key" + <*> v .: "doc_count" + <*> v .: "max_anomaly_grade" + +instance ToJSON TopAnomalyBucket where + toJSON TopAnomalyBucket {..} = + object + [ "key" .= topAnomalyBucketKey, + "doc_count" .= topAnomalyBucketDocCount, + "max_anomaly_grade" .= topAnomalyBucketMaxAnomalyGrade + ] + +-- | Response body of the top-anomalies endpoint: a @buckets@ array of +-- 'TopAnomalyBucket'. +-- See +data TopAnomaliesResponse = TopAnomaliesResponse + { topAnomaliesResponseBuckets :: [TopAnomalyBucket] + } + deriving stock (Eq, Show) + +instance FromJSON TopAnomaliesResponse where + parseJSON = withObject "TopAnomaliesResponse" $ \v -> + TopAnomaliesResponse + <$> v .:? "buckets" .!= [] + +instance ToJSON TopAnomaliesResponse where + toJSON TopAnomaliesResponse {..} = + object ["buckets" .= topAnomaliesResponseBuckets] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/CCR.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/CCR.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/CCR.hs @@ -0,0 +1,573 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.CCR + ( -- * Requests + ReplicationUseRoles (..), + StartReplicationRequest (..), + UpdateReplicationSettingsRequest (..), + CreateAutoFollowPatternRequest (..), + DeleteAutoFollowPatternRequest (..), + + -- * Status + ReplicationStatus (..), + replicationStatusText, + SyncingDetails (..), + ReplicationStatusResponse (..), + ReplicationStatusOptions (..), + defaultReplicationStatusOptions, + replicationStatusOptionsParams, + + -- * Leader stats + LeaderIndexStats (..), + LeaderStatsResponse (..), + + -- * Follower stats + FollowerIndexStats (..), + FollowerStatsResponse (..), + + -- * Auto-follow stats + AutoFollowRuleStats (..), + AutoFollowStatsResponse (..), + ) +where + +import Data.Map.Strict (Map) +import Database.Bloodhound.Internal.Utils.Imports + +-- $ccrSchema +-- +-- The Cross-Cluster Replication (CCR) plugin (see +-- ) +-- replicates indexes from a /leader/ cluster to a /follower/ cluster in +-- near real-time. The follower cluster pulls changes from the leader's +-- translog; the follower index stays read-only while replication is +-- active. The plugin has shipped with OpenSearch since 1.1, hence this +-- module exists for OS1, OS2 and OS3. +-- +-- The REST surface lives under @\/_plugins\/_replication\/*@ on both +-- clusters. Follower-lifecycle operations (start\/stop\/pause\/resume\/ +-- update) and the per-index @\/_status@ are sent to the /follower/ +-- cluster; the leader cluster only serves @leader_stats@. The +-- @follower_stats@ and @autofollow_stats@ endpoints, plus the +-- auto-follow pattern create\/delete, are sent to the follower cluster. +-- +-- Most mutation endpoints return the trivial +-- @{\"acknowledged\":true}@ envelope, modelled by the shared +-- 'Database.Bloodhound.Internal.Client.BHRequest.Acknowledged' type +-- (re-exported via "Database.Bloodhound.Common.Types"). The interesting +-- wire shapes are the status and the three stats responses, modelled +-- below as dedicated records. + +-- | The @use_roles@ object embedded in 'StartReplicationRequest' and +-- 'CreateAutoFollowPatternRequest'. Required when the Security plugin is +-- enabled (the common case); the plugin uses these roles to authorize +-- cross-cluster reads on the leader and writes on the follower. +data ReplicationUseRoles = ReplicationUseRoles + { replicationUseRolesLeaderClusterRole :: Text, + replicationUseRolesFollowerClusterRole :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ReplicationUseRoles where + parseJSON = withObject "ReplicationUseRoles" $ \v -> do + replicationUseRolesLeaderClusterRole <- v .: "leader_cluster_role" + replicationUseRolesFollowerClusterRole <- v .: "follower_cluster_role" + pure ReplicationUseRoles {..} + +instance ToJSON ReplicationUseRoles where + toJSON ReplicationUseRoles {..} = + object + [ "leader_cluster_role" .= replicationUseRolesLeaderClusterRole, + "follower_cluster_role" .= replicationUseRolesFollowerClusterRole + ] + +-- | The request body for @PUT \/_plugins\/_replication\/{follower-index}\/_start@. +-- @leader_alias@ names the cross-cluster connection (configured via the +-- cluster settings @cluster.remote..seeds@), and @leader_index@ is +-- the source index on the leader cluster. +data StartReplicationRequest = StartReplicationRequest + { startReplicationRequestLeaderAlias :: Text, + startReplicationRequestLeaderIndex :: Text, + startReplicationRequestUseRoles :: Maybe ReplicationUseRoles + } + deriving stock (Eq, Show) + +instance FromJSON StartReplicationRequest where + parseJSON = withObject "StartReplicationRequest" $ \v -> do + startReplicationRequestLeaderAlias <- v .: "leader_alias" + startReplicationRequestLeaderIndex <- v .: "leader_index" + startReplicationRequestUseRoles <- v .:? "use_roles" + pure StartReplicationRequest {..} + +instance ToJSON StartReplicationRequest where + toJSON StartReplicationRequest {..} = + omitNulls + [ "leader_alias" .= startReplicationRequestLeaderAlias, + "leader_index" .= startReplicationRequestLeaderIndex, + "use_roles" .= startReplicationRequestUseRoles + ] + +-- | The request body for +-- @PUT \/_plugins\/_replication\/{follower-index}\/_update@. Carries an +-- arbitrary map of index-level settings (e.g. +-- @index.number_of_replicas@) to apply to the follower index. Values are +-- kept as aeson 'Value's because settings may be numbers, strings, or +-- booleans and the plugin forwards them verbatim. +newtype UpdateReplicationSettingsRequest = UpdateReplicationSettingsRequest + { updateReplicationSettingsRequestSettings :: Map Text Value + } + deriving stock (Eq, Show) + +instance FromJSON UpdateReplicationSettingsRequest where + parseJSON = withObject "UpdateReplicationSettingsRequest" $ \v -> do + updateReplicationSettingsRequestSettings <- v .: "settings" + pure UpdateReplicationSettingsRequest {..} + +instance ToJSON UpdateReplicationSettingsRequest where + toJSON UpdateReplicationSettingsRequest {..} = + object ["settings" .= updateReplicationSettingsRequestSettings] + +-- | The request body for @POST \/_plugins\/_replication\/_autofollow@. +-- Creates (or, re-POSTed with the same @name@, updates) an auto-follow +-- rule that automatically starts replication on any existing /and/ +-- future leader indexes whose names match @pattern@. +data CreateAutoFollowPatternRequest = CreateAutoFollowPatternRequest + { createAutoFollowPatternRequestLeaderAlias :: Text, + createAutoFollowPatternRequestName :: Text, + createAutoFollowPatternRequestPattern :: Text, + createAutoFollowPatternRequestUseRoles :: Maybe ReplicationUseRoles + } + deriving stock (Eq, Show) + +instance FromJSON CreateAutoFollowPatternRequest where + parseJSON = withObject "CreateAutoFollowPatternRequest" $ \v -> do + createAutoFollowPatternRequestLeaderAlias <- v .: "leader_alias" + createAutoFollowPatternRequestName <- v .: "name" + createAutoFollowPatternRequestPattern <- v .: "pattern" + createAutoFollowPatternRequestUseRoles <- v .:? "use_roles" + pure CreateAutoFollowPatternRequest {..} + +instance ToJSON CreateAutoFollowPatternRequest where + toJSON CreateAutoFollowPatternRequest {..} = + omitNulls + [ "leader_alias" .= createAutoFollowPatternRequestLeaderAlias, + "name" .= createAutoFollowPatternRequestName, + "pattern" .= createAutoFollowPatternRequestPattern, + "use_roles" .= createAutoFollowPatternRequestUseRoles + ] + +-- | The request body for @DELETE \/_plugins\/_replication\/_autofollow@. +-- Deletes an auto-follow rule. This prevents /new/ indexes from being +-- replicated but does /not/ stop replication already initiated by the +-- rule (stop those individually with 'stopReplication'). +data DeleteAutoFollowPatternRequest = DeleteAutoFollowPatternRequest + { deleteAutoFollowPatternRequestLeaderAlias :: Text, + deleteAutoFollowPatternRequestName :: Text + } + deriving stock (Eq, Show) + +instance FromJSON DeleteAutoFollowPatternRequest where + parseJSON = withObject "DeleteAutoFollowPatternRequest" $ \v -> do + deleteAutoFollowPatternRequestLeaderAlias <- v .: "leader_alias" + deleteAutoFollowPatternRequestName <- v .: "name" + pure DeleteAutoFollowPatternRequest {..} + +instance ToJSON DeleteAutoFollowPatternRequest where + toJSON DeleteAutoFollowPatternRequest {..} = + object + [ "leader_alias" .= deleteAutoFollowPatternRequestLeaderAlias, + "name" .= deleteAutoFollowPatternRequestName + ] + +-- | The @status@ enum reported by +-- @GET \/_plugins\/_replication\/{follower-index}\/_status@. Modelled as +-- an /open/ enum: the four documented values map to dedicated +-- constructors, and any unknown status string round-trips through +-- 'ReplicationStatusOther'. This guards against plugin releases adding a +-- fifth state (or undocumented intermediate states) surfacing as a +-- silent parse failure. Note the documented @REPLICATION NOT IN +-- PROGRESS@ value contains spaces. +data ReplicationStatus + = ReplicationStatusSyncing + | ReplicationStatusBootstrapping + | ReplicationStatusPaused + | ReplicationStatusNotInProgress + | ReplicationStatusOther Text + deriving stock (Eq, Show) + +instance FromJSON ReplicationStatus where + parseJSON = withText "ReplicationStatus" $ \t -> + pure $ case t of + "SYNCING" -> ReplicationStatusSyncing + "BOOTSTRAPPING" -> ReplicationStatusBootstrapping + "PAUSED" -> ReplicationStatusPaused + "REPLICATION NOT IN PROGRESS" -> ReplicationStatusNotInProgress + other -> ReplicationStatusOther other + +instance ToJSON ReplicationStatus where + toJSON = toJSON . replicationStatusText + +-- | The wire string for a 'ReplicationStatus', exposed as plain 'Text' +-- for callers that need the wire value without going through a +-- 'Data.Aeson.Value'. 'ReplicationStatusOther' round-trips its payload. +replicationStatusText :: ReplicationStatus -> Text +replicationStatusText = \case + ReplicationStatusSyncing -> "SYNCING" + ReplicationStatusBootstrapping -> "BOOTSTRAPPING" + ReplicationStatusPaused -> "PAUSED" + ReplicationStatusNotInProgress -> "REPLICATION NOT IN PROGRESS" + ReplicationStatusOther t -> t + +-- | The @syncing_details@ object embedded in 'ReplicationStatusResponse' +-- when the status is @SYNCING@. Checkpoints start negative (-1 per +-- shard) and increment with each change; equal leader\/follower +-- checkpoints mean the indexes are fully synced. +data SyncingDetails = SyncingDetails + { syncingDetailsLeaderCheckpoint :: Int, + syncingDetailsFollowerCheckpoint :: Int, + syncingDetailsSeqNo :: Int + } + deriving stock (Eq, Show) + +instance FromJSON SyncingDetails where + parseJSON = withObject "SyncingDetails" $ \v -> do + syncingDetailsLeaderCheckpoint <- v .: "leader_checkpoint" + syncingDetailsFollowerCheckpoint <- v .: "follower_checkpoint" + syncingDetailsSeqNo <- v .: "seq_no" + pure SyncingDetails {..} + +instance ToJSON SyncingDetails where + toJSON SyncingDetails {..} = + object + [ "leader_checkpoint" .= syncingDetailsLeaderCheckpoint, + "follower_checkpoint" .= syncingDetailsFollowerCheckpoint, + "seq_no" .= syncingDetailsSeqNo + ] + +-- | The response of +-- @GET \/_plugins\/_replication\/{follower-index}\/_status@. The +-- @syncing_details@ object is only present when @status@ is @SYNCING@; +-- it is 'Nothing' for the other states. +data ReplicationStatusResponse = ReplicationStatusResponse + { replicationStatusResponseStatus :: ReplicationStatus, + replicationStatusResponseReason :: Text, + replicationStatusResponseLeaderAlias :: Text, + replicationStatusResponseLeaderIndex :: Text, + replicationStatusResponseFollowerIndex :: Text, + replicationStatusResponseSyncingDetails :: Maybe SyncingDetails + } + deriving stock (Eq, Show) + +instance FromJSON ReplicationStatusResponse where + parseJSON = withObject "ReplicationStatusResponse" $ \v -> do + replicationStatusResponseStatus <- v .: "status" + replicationStatusResponseReason <- v .: "reason" + replicationStatusResponseLeaderAlias <- v .: "leader_alias" + replicationStatusResponseLeaderIndex <- v .: "leader_index" + replicationStatusResponseFollowerIndex <- v .: "follower_index" + replicationStatusResponseSyncingDetails <- v .:? "syncing_details" + pure ReplicationStatusResponse {..} + +instance ToJSON ReplicationStatusResponse where + toJSON ReplicationStatusResponse {..} = + omitNulls + [ "status" .= replicationStatusResponseStatus, + "reason" .= replicationStatusResponseReason, + "leader_alias" .= replicationStatusResponseLeaderAlias, + "leader_index" .= replicationStatusResponseLeaderIndex, + "follower_index" .= replicationStatusResponseFollowerIndex, + "syncing_details" .= replicationStatusResponseSyncingDetails + ] + +-- | Query-string options for +-- 'Database.Bloodhound.OpenSearch2.Requests.getReplicationStatus'. The +-- plugin documents only @verbose@: when @true@, the response includes +-- shard-level @syncing_details@; when omitted or @false@, the details +-- are absent. +data ReplicationStatusOptions = ReplicationStatusOptions + { replicationStatusOptionsVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | No query-string parameters — the plain @GET ...\/_status@. +defaultReplicationStatusOptions :: ReplicationStatusOptions +defaultReplicationStatusOptions = + ReplicationStatusOptions + { replicationStatusOptionsVerbose = Nothing + } + +-- | Render 'ReplicationStatusOptions' as query-string pairs for +-- 'withQueries'. +replicationStatusOptionsParams :: ReplicationStatusOptions -> [(Text, Maybe Text)] +replicationStatusOptionsParams ReplicationStatusOptions {..} = + catMaybes + [ (("verbose",) . Just . \case True -> "true"; False -> "false") <$> replicationStatusOptionsVerbose + ] + +-- | Per-index leader statistics, the value entries of the +-- @index_stats@ map in 'LeaderStatsResponse'. These are the read-side +-- counters the leader cluster reports for a single replicated index. +data LeaderIndexStats = LeaderIndexStats + { leaderIndexStatsOperationsRead :: Int, + leaderIndexStatsTranslogSizeBytes :: Int, + leaderIndexStatsOperationsReadLucene :: Int, + leaderIndexStatsOperationsReadTranslog :: Int, + leaderIndexStatsTotalReadTimeLuceneMillis :: Int, + leaderIndexStatsTotalReadTimeTranslogMillis :: Int, + leaderIndexStatsBytesRead :: Int + } + deriving stock (Eq, Show) + +instance FromJSON LeaderIndexStats where + parseJSON = withObject "LeaderIndexStats" $ \v -> do + leaderIndexStatsOperationsRead <- v .: "operations_read" + leaderIndexStatsTranslogSizeBytes <- v .: "translog_size_bytes" + leaderIndexStatsOperationsReadLucene <- v .: "operations_read_lucene" + leaderIndexStatsOperationsReadTranslog <- v .: "operations_read_translog" + leaderIndexStatsTotalReadTimeLuceneMillis <- v .: "total_read_time_lucene_millis" + leaderIndexStatsTotalReadTimeTranslogMillis <- v .: "total_read_time_translog_millis" + leaderIndexStatsBytesRead <- v .: "bytes_read" + pure LeaderIndexStats {..} + +instance ToJSON LeaderIndexStats where + toJSON LeaderIndexStats {..} = + object + [ "operations_read" .= leaderIndexStatsOperationsRead, + "translog_size_bytes" .= leaderIndexStatsTranslogSizeBytes, + "operations_read_lucene" .= leaderIndexStatsOperationsReadLucene, + "operations_read_translog" .= leaderIndexStatsOperationsReadTranslog, + "total_read_time_lucene_millis" .= leaderIndexStatsTotalReadTimeLuceneMillis, + "total_read_time_translog_millis" .= leaderIndexStatsTotalReadTimeTranslogMillis, + "bytes_read" .= leaderIndexStatsBytesRead + ] + +-- | The response of @GET \/_plugins\/_replication\/leader_stats@ (sent +-- to the /leader/ cluster). Aggregates read-side counters across all +-- replicated indexes, plus a per-index breakdown under @index_stats@. +-- The per-index values reuse 'LeaderIndexStats'. The @index_stats@ map +-- defaults to empty when the plugin omits it (e.g. no replication +-- configured). +data LeaderStatsResponse = LeaderStatsResponse + { leaderStatsResponseNumReplicatedIndices :: Int, + leaderStatsResponseOperationsRead :: Int, + leaderStatsResponseTranslogSizeBytes :: Int, + leaderStatsResponseOperationsReadLucene :: Int, + leaderStatsResponseOperationsReadTranslog :: Int, + leaderStatsResponseTotalReadTimeLuceneMillis :: Int, + leaderStatsResponseTotalReadTimeTranslogMillis :: Int, + leaderStatsResponseBytesRead :: Int, + leaderStatsResponseIndexStats :: Map Text LeaderIndexStats + } + deriving stock (Eq, Show) + +instance FromJSON LeaderStatsResponse where + parseJSON = withObject "LeaderStatsResponse" $ \v -> do + leaderStatsResponseNumReplicatedIndices <- v .: "num_replicated_indices" + leaderStatsResponseOperationsRead <- v .: "operations_read" + leaderStatsResponseTranslogSizeBytes <- v .: "translog_size_bytes" + leaderStatsResponseOperationsReadLucene <- v .: "operations_read_lucene" + leaderStatsResponseOperationsReadTranslog <- v .: "operations_read_translog" + leaderStatsResponseTotalReadTimeLuceneMillis <- v .: "total_read_time_lucene_millis" + leaderStatsResponseTotalReadTimeTranslogMillis <- v .: "total_read_time_translog_millis" + leaderStatsResponseBytesRead <- v .: "bytes_read" + leaderStatsResponseIndexStats <- v .:? "index_stats" .!= mempty + pure LeaderStatsResponse {..} + +instance ToJSON LeaderStatsResponse where + toJSON LeaderStatsResponse {..} = + object + [ "num_replicated_indices" .= leaderStatsResponseNumReplicatedIndices, + "operations_read" .= leaderStatsResponseOperationsRead, + "translog_size_bytes" .= leaderStatsResponseTranslogSizeBytes, + "operations_read_lucene" .= leaderStatsResponseOperationsReadLucene, + "operations_read_translog" .= leaderStatsResponseOperationsReadTranslog, + "total_read_time_lucene_millis" .= leaderStatsResponseTotalReadTimeLuceneMillis, + "total_read_time_translog_millis" .= leaderStatsResponseTotalReadTimeTranslogMillis, + "bytes_read" .= leaderStatsResponseBytesRead, + "index_stats" .= leaderStatsResponseIndexStats + ] + +-- | Per-index follower statistics, the value entries of the +-- @index_stats@ map in 'FollowerStatsResponse'. These are the write-side +-- counters the follower cluster reports for a single syncing index. +data FollowerIndexStats = FollowerIndexStats + { followerIndexStatsOperationsWritten :: Int, + followerIndexStatsOperationsRead :: Int, + followerIndexStatsFailedReadRequests :: Int, + followerIndexStatsThrottledReadRequests :: Int, + followerIndexStatsFailedWriteRequests :: Int, + followerIndexStatsThrottledWriteRequests :: Int, + followerIndexStatsFollowerCheckpoint :: Int, + followerIndexStatsLeaderCheckpoint :: Int, + followerIndexStatsTotalWriteTimeMillis :: Int + } + deriving stock (Eq, Show) + +instance FromJSON FollowerIndexStats where + parseJSON = withObject "FollowerIndexStats" $ \v -> do + followerIndexStatsOperationsWritten <- v .: "operations_written" + followerIndexStatsOperationsRead <- v .: "operations_read" + followerIndexStatsFailedReadRequests <- v .: "failed_read_requests" + followerIndexStatsThrottledReadRequests <- v .: "throttled_read_requests" + followerIndexStatsFailedWriteRequests <- v .: "failed_write_requests" + followerIndexStatsThrottledWriteRequests <- v .: "throttled_write_requests" + followerIndexStatsFollowerCheckpoint <- v .: "follower_checkpoint" + followerIndexStatsLeaderCheckpoint <- v .: "leader_checkpoint" + followerIndexStatsTotalWriteTimeMillis <- v .: "total_write_time_millis" + pure FollowerIndexStats {..} + +instance ToJSON FollowerIndexStats where + toJSON FollowerIndexStats {..} = + object + [ "operations_written" .= followerIndexStatsOperationsWritten, + "operations_read" .= followerIndexStatsOperationsRead, + "failed_read_requests" .= followerIndexStatsFailedReadRequests, + "throttled_read_requests" .= followerIndexStatsThrottledReadRequests, + "failed_write_requests" .= followerIndexStatsFailedWriteRequests, + "throttled_write_requests" .= followerIndexStatsThrottledWriteRequests, + "follower_checkpoint" .= followerIndexStatsFollowerCheckpoint, + "leader_checkpoint" .= followerIndexStatsLeaderCheckpoint, + "total_write_time_millis" .= followerIndexStatsTotalWriteTimeMillis + ] + +-- | The response of @GET \/_plugins\/_replication\/follower_stats@ (sent +-- to the /follower/ cluster). Reports counts of follower indexes by +-- state (syncing\/bootstrapping\/paused\/failed), shard- and index-level +-- task counts, and aggregate write-side throughput, plus a per-index +-- breakdown under @index_stats@. The @index_stats@ map defaults to +-- empty when the plugin omits it. +data FollowerStatsResponse = FollowerStatsResponse + { followerStatsResponseNumSyncingIndices :: Int, + followerStatsResponseNumBootstrappingIndices :: Int, + followerStatsResponseNumPausedIndices :: Int, + followerStatsResponseNumFailedIndices :: Int, + followerStatsResponseNumShardTasks :: Int, + followerStatsResponseNumIndexTasks :: Int, + followerStatsResponseOperationsWritten :: Int, + followerStatsResponseOperationsRead :: Int, + followerStatsResponseFailedReadRequests :: Int, + followerStatsResponseThrottledReadRequests :: Int, + followerStatsResponseFailedWriteRequests :: Int, + followerStatsResponseThrottledWriteRequests :: Int, + followerStatsResponseFollowerCheckpoint :: Int, + followerStatsResponseLeaderCheckpoint :: Int, + followerStatsResponseTotalWriteTimeMillis :: Int, + followerStatsResponseIndexStats :: Map Text FollowerIndexStats + } + deriving stock (Eq, Show) + +instance FromJSON FollowerStatsResponse where + parseJSON = withObject "FollowerStatsResponse" $ \v -> do + followerStatsResponseNumSyncingIndices <- v .: "num_syncing_indices" + followerStatsResponseNumBootstrappingIndices <- v .: "num_bootstrapping_indices" + followerStatsResponseNumPausedIndices <- v .: "num_paused_indices" + followerStatsResponseNumFailedIndices <- v .: "num_failed_indices" + followerStatsResponseNumShardTasks <- v .: "num_shard_tasks" + followerStatsResponseNumIndexTasks <- v .: "num_index_tasks" + followerStatsResponseOperationsWritten <- v .: "operations_written" + followerStatsResponseOperationsRead <- v .: "operations_read" + followerStatsResponseFailedReadRequests <- v .: "failed_read_requests" + followerStatsResponseThrottledReadRequests <- v .: "throttled_read_requests" + followerStatsResponseFailedWriteRequests <- v .: "failed_write_requests" + followerStatsResponseThrottledWriteRequests <- v .: "throttled_write_requests" + followerStatsResponseFollowerCheckpoint <- v .: "follower_checkpoint" + followerStatsResponseLeaderCheckpoint <- v .: "leader_checkpoint" + followerStatsResponseTotalWriteTimeMillis <- v .: "total_write_time_millis" + followerStatsResponseIndexStats <- v .:? "index_stats" .!= mempty + pure FollowerStatsResponse {..} + +instance ToJSON FollowerStatsResponse where + toJSON FollowerStatsResponse {..} = + object + [ "num_syncing_indices" .= followerStatsResponseNumSyncingIndices, + "num_bootstrapping_indices" .= followerStatsResponseNumBootstrappingIndices, + "num_paused_indices" .= followerStatsResponseNumPausedIndices, + "num_failed_indices" .= followerStatsResponseNumFailedIndices, + "num_shard_tasks" .= followerStatsResponseNumShardTasks, + "num_index_tasks" .= followerStatsResponseNumIndexTasks, + "operations_written" .= followerStatsResponseOperationsWritten, + "operations_read" .= followerStatsResponseOperationsRead, + "failed_read_requests" .= followerStatsResponseFailedReadRequests, + "throttled_read_requests" .= followerStatsResponseThrottledReadRequests, + "failed_write_requests" .= followerStatsResponseFailedWriteRequests, + "throttled_write_requests" .= followerStatsResponseThrottledWriteRequests, + "follower_checkpoint" .= followerStatsResponseFollowerCheckpoint, + "leader_checkpoint" .= followerStatsResponseLeaderCheckpoint, + "total_write_time_millis" .= followerStatsResponseTotalWriteTimeMillis, + "index_stats" .= followerStatsResponseIndexStats + ] + +-- | Per-rule auto-follow statistics, the list entries of the +-- @autofollow_stats@ array in 'AutoFollowStatsResponse'. Each entry +-- describes one auto-follow rule (its name and match pattern) and its +-- success\/failure counters. The @failed_indices@ array lists the +-- leader index names that failed to start replicating under this rule. +data AutoFollowRuleStats = AutoFollowRuleStats + { autoFollowRuleStatsName :: Text, + autoFollowRuleStatsPattern :: Text, + autoFollowRuleStatsNumSuccessStartReplication :: Int, + autoFollowRuleStatsNumFailedStartReplication :: Int, + autoFollowRuleStatsNumFailedLeaderCalls :: Int, + autoFollowRuleStatsFailedIndices :: [Text] + } + deriving stock (Eq, Show) + +instance FromJSON AutoFollowRuleStats where + parseJSON = withObject "AutoFollowRuleStats" $ \v -> do + autoFollowRuleStatsName <- v .: "name" + autoFollowRuleStatsPattern <- v .: "pattern" + autoFollowRuleStatsNumSuccessStartReplication <- v .: "num_success_start_replication" + autoFollowRuleStatsNumFailedStartReplication <- v .: "num_failed_start_replication" + autoFollowRuleStatsNumFailedLeaderCalls <- v .: "num_failed_leader_calls" + autoFollowRuleStatsFailedIndices <- v .:? "failed_indices" .!= [] + pure AutoFollowRuleStats {..} + +instance ToJSON AutoFollowRuleStats where + toJSON AutoFollowRuleStats {..} = + object + [ "name" .= autoFollowRuleStatsName, + "pattern" .= autoFollowRuleStatsPattern, + "num_success_start_replication" .= autoFollowRuleStatsNumSuccessStartReplication, + "num_failed_start_replication" .= autoFollowRuleStatsNumFailedStartReplication, + "num_failed_leader_calls" .= autoFollowRuleStatsNumFailedLeaderCalls, + "failed_indices" .= autoFollowRuleStatsFailedIndices + ] + +-- | The response of @GET \/_plugins\/_replication\/autofollow_stats@ +-- (sent to the /follower/ cluster). Aggregates auto-follow activity +-- across all rules, plus a per-rule breakdown under @autofollow_stats@. +-- The docs note there is no dedicated \"list patterns\" endpoint — this +-- stats response is the only way to discover existing auto-follow rules, +-- hence each rule carries its @name@ and @pattern@. Both @failed_indices@ +-- and @autofollow_stats@ default to empty when the plugin omits them. +data AutoFollowStatsResponse = AutoFollowStatsResponse + { autoFollowStatsResponseNumSuccessStartReplication :: Int, + autoFollowStatsResponseNumFailedStartReplication :: Int, + autoFollowStatsResponseNumFailedLeaderCalls :: Int, + autoFollowStatsResponseFailedIndices :: [Text], + autoFollowStatsResponseAutoFollowStats :: [AutoFollowRuleStats] + } + deriving stock (Eq, Show) + +instance FromJSON AutoFollowStatsResponse where + parseJSON = withObject "AutoFollowStatsResponse" $ \v -> do + autoFollowStatsResponseNumSuccessStartReplication <- v .: "num_success_start_replication" + autoFollowStatsResponseNumFailedStartReplication <- v .: "num_failed_start_replication" + autoFollowStatsResponseNumFailedLeaderCalls <- v .: "num_failed_leader_calls" + autoFollowStatsResponseFailedIndices <- v .:? "failed_indices" .!= [] + autoFollowStatsResponseAutoFollowStats <- v .:? "autofollow_stats" .!= [] + pure AutoFollowStatsResponse {..} + +instance ToJSON AutoFollowStatsResponse where + toJSON AutoFollowStatsResponse {..} = + object + [ "num_success_start_replication" .= autoFollowStatsResponseNumSuccessStartReplication, + "num_failed_start_replication" .= autoFollowStatsResponseNumFailedStartReplication, + "num_failed_leader_calls" .= autoFollowStatsResponseNumFailedLeaderCalls, + "failed_indices" .= autoFollowStatsResponseFailedIndices, + "autofollow_stats" .= autoFollowStatsResponseAutoFollowStats + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/ISM.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/ISM.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/ISM.hs @@ -0,0 +1,1454 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.ISM where + +import Data.Aeson.Key qualified as AKey +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Database.Bloodhound.Internal.Client.Doc (DocVersion) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) + +-- $policySchema +-- +-- The OpenSearch ISM policy body has two faces: +-- +-- 1. The @PUT /_plugins/_ism/policies/{id}@ request carries the user-supplied +-- policy definition (no @policy_id@, no @schema_version@, no +-- @last_updated_time@ — the server injects those). +-- 2. The @GET /_plugins/_ism/policies\/{_id}@ response (and the inner @policy@ +-- object of the @PUT@ response) carries the same body with server-injected +-- metadata mixed in. +-- +-- We split these into 'ISMPolicyRequest' and 'ISMPolicyResponse' so the +-- request shape cannot accidentally carry server-only fields and the +-- response shape can still round-trip the full server payload. +-- +-- See + +-- | The shared user-supplied policy body, used by both 'ISMPolicyRequest' and +-- 'ISMPolicyResponse'. Carries only the fields the client supplies: +-- @description@, @default_state@, @states@, optional @ism_template@, +-- optional @error_notification@, optional @user_vars@. +data ISMPolicyBody = ISMPolicyBody + { ismPolicyBodyDescription :: Maybe Text, + ismPolicyBodyDefaultState :: Text, + ismPolicyBodyStates :: [ISMState], + ismPolicyBodyIsmTemplate :: [ISMTemplate], + ismPolicyBodyErrorNotification :: Maybe ISMErrorNotification, + ismPolicyBodyUserVariables :: Maybe ISMUserVariables + } + deriving stock (Eq, Show) + +instance FromJSON ISMPolicyBody where + parseJSON = withObject "ISMPolicyBody" $ \v -> do + ismPolicyBodyDescription <- v .:? "description" + ismPolicyBodyDefaultState <- v .: "default_state" + -- 'states' is required by OpenSearch and must be non-empty; we read it + -- strictly so malformed bodies missing the key fail-fast instead of + -- silently producing a policy whose 'default_state' points at nothing. + ismPolicyBodyStates <- v .: "states" + -- The spec allows @ism_template@ as a single object, @null@, or an array + -- of objects; a policy may carry one or more templates. Normalise all + -- three forms into a list: missing/null -> [], a bare object -> [obj], + -- an array -> its elements. + rawTemplate <- v .:? "ism_template" + ismPolicyBodyIsmTemplate <- case rawTemplate of + Nothing -> pure [] + Just Null -> pure [] + Just arr@(Array _) -> parseJSON arr + Just other -> (: []) <$> parseJSON other + ismPolicyBodyErrorNotification <- v .:? "error_notification" + ismPolicyBodyUserVariables <- v .:? "user_vars" + return ISMPolicyBody {..} + +instance ToJSON ISMPolicyBody where + toJSON ISMPolicyBody {..} = + omitNulls + [ "description" .= ismPolicyBodyDescription, + "default_state" .= ismPolicyBodyDefaultState, + "states" .= ismPolicyBodyStates, + "ism_template" .= ismPolicyBodyIsmTemplate, + "error_notification" .= ismPolicyBodyErrorNotification, + "user_vars" .= ismPolicyBodyUserVariables + ] + +-- | The request body for @PUT /_plugins/_ism/policies/{id}@. OpenSearch +-- requires the user-supplied policy body to be wrapped in a top-level +-- @policy@ key, so 'ISMPolicyRequest' encodes as +-- @{"policy": {…body…}}@. The wrapper is invisible at the type level: callers +-- build an 'ISMPolicyBody', wrap it in 'ISMPolicyRequest', and the +-- 'ToJSON' instance handles the wire-level wrapping. +-- See +newtype ISMPolicyRequest = ISMPolicyRequest {unISMPolicyRequest :: ISMPolicyBody} + deriving stock (Eq, Show) + +instance FromJSON ISMPolicyRequest where + parseJSON original@(Object o) = + -- Prefer the wrapped shape @{"policy": {…}}@; fall back to a bare body + -- so hand-built fixtures that skip the wrapper still decode cleanly. + (ISMPolicyRequest <$> o .: "policy") + <|> (ISMPolicyRequest <$> parseJSON original) + parseJSON v = ISMPolicyRequest <$> parseJSON v + +instance ToJSON ISMPolicyRequest where + toJSON req = object ["policy" .= unISMPolicyRequest req] + +-- | The policy shape returned in responses (@GET /_plugins/_ism/policies@, the +-- inner @policy@ object of a @PUT@ response). Adds the three server-injected +-- fields (@policy_id@, @schema_version@, @last_updated_time@) alongside the +-- shared body fields. OpenSearch populates them inside the inner policy body +-- on @GET /_plugins/_ism/policies\/{_id}@; @PUT@ responses historically put +-- them on the outer @policy@ wrapper. 'PutISMPolicyResponse' reconciles both +-- placements by reading the inner body verbatim and falling back to the outer +-- wrapper fields when the inner doesn't carry them. +data ISMPolicyResponse = ISMPolicyResponse + { ismPolicyResponsePolicyId :: Maybe Text, + ismPolicyResponseSchemaVersion :: Maybe Int, + ismPolicyResponseLastUpdatedTime :: Maybe Int, + ismPolicyResponseBody :: ISMPolicyBody + } + deriving stock (Eq, Show) + +instance FromJSON ISMPolicyResponse where + parseJSON v = do + body <- parseJSON v + withObject + "ISMPolicyResponse" + ( \o -> do + ismPolicyResponsePolicyId <- o .:? "policy_id" + ismPolicyResponseSchemaVersion <- o .:? "schema_version" + ismPolicyResponseLastUpdatedTime <- o .:? "last_updated_time" + return ISMPolicyResponse {ismPolicyResponseBody = body, ..} + ) + v + +instance ToJSON ISMPolicyResponse where + toJSON ISMPolicyResponse {..} = + omitNulls $ + catMaybes + [ fmap ("policy_id" .=) ismPolicyResponsePolicyId, + fmap ("schema_version" .=) ismPolicyResponseSchemaVersion, + fmap ("last_updated_time" .=) ismPolicyResponseLastUpdatedTime + ] + <> bodyPairs + where + bodyPairs = + case toJSON ismPolicyResponseBody of + Object o -> KM.toList o + _ -> [] + +-- | 'PolicyId' identifies an ISM policy in the +-- @\/_plugins\/_ism\/policies\/{id}@ URL path. Wraps 'Text' so it round-trips +-- through JSON as a bare string but is distinct at the Haskell type level. +-- See +newtype PolicyId = PolicyId {unPolicyId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Response of @PUT /_plugins/_ism/policies/{id}@. The server returns the +-- standard document-write envelope (@_id@, @_version@, @_seq_no@, +-- @_primary_term@) wrapping a single @policy@ key. That @policy@ object +-- itself contains @schema_version@, @last_updated_time@ and an inner +-- @policy@ body. Different OpenSearch versions disagree on whether +-- @schema_version@ / @last_updated_time@ live on the outer wrapper or inside +-- the inner body, so the decoder merges both sources into the inner +-- 'ISMPolicyResponse'. Callers should read those fields from +-- 'putISMPolicyResponsePolicy' rather than expecting them at the outer level. +data PutISMPolicyResponse = PutISMPolicyResponse + { putISMPolicyResponseId :: Text, + putISMPolicyResponseVersion :: DocVersion, + putISMPolicyResponsePrimaryTerm :: Int, + putISMPolicyResponseSeqNo :: Int, + putISMPolicyResponsePolicy :: ISMPolicyResponse + } + deriving stock (Eq, Show) + +instance FromJSON PutISMPolicyResponse where + parseJSON = withObject "PutISMPolicyResponse" $ \v -> do + putISMPolicyResponseId <- v .: "_id" + putISMPolicyResponseVersion <- v .: "_version" + putISMPolicyResponsePrimaryTerm <- v .: "_primary_term" + putISMPolicyResponseSeqNo <- v .: "_seq_no" + envelope <- v .: "policy" + -- OpenSearch's documented shape nests the user body inside + -- policy.policy and carries schema_version/last_updated_time there + -- (and sometimes also on the outer policy wrapper). Read the inner + -- body verbatim into ISMPolicyResponse (which already picks up + -- schema_version/last_updated_time when present) and merge the outer + -- envelope fields in when the inner doesn't carry them. + innerBody <- envelope .: "policy" + outerSchemaVersion <- envelope .:? "schema_version" + outerLastUpdated <- envelope .:? "last_updated_time" + parsedInner <- parseJSON innerBody + let merged = + parsedInner + { ismPolicyResponseSchemaVersion = + ismPolicyResponseSchemaVersion parsedInner <|> outerSchemaVersion, + ismPolicyResponseLastUpdatedTime = + ismPolicyResponseLastUpdatedTime parsedInner <|> outerLastUpdated + } + return PutISMPolicyResponse {putISMPolicyResponsePolicy = merged, ..} + +instance ToJSON PutISMPolicyResponse where + toJSON PutISMPolicyResponse {..} = + omitNulls + [ "_id" .= putISMPolicyResponseId, + "_version" .= putISMPolicyResponseVersion, + "_primary_term" .= putISMPolicyResponsePrimaryTerm, + "_seq_no" .= putISMPolicyResponseSeqNo, + "policy" .= object ["policy" .= putISMPolicyResponsePolicy] + ] + +-- | A named state in the policy state machine. The managed index transitions +-- from @name@ to the next state when any of @transitions@ matches; on entry it +-- runs every @actions@ entry. Both lists default to empty so a minimal +-- @{\"name\": \"hot\"}@ state decodes cleanly. +-- See +data ISMState = ISMState + { ismStateName :: Text, + ismStateActions :: [ISMActionEntry], + ismStateTransitions :: [ISMTransition] + } + deriving stock (Eq, Show) + +instance FromJSON ISMState where + parseJSON = withObject "ISMState" $ \v -> do + ismStateName <- v .: "name" + ismStateActions <- v .:? "actions" .!= [] + ismStateTransitions <- v .:? "transitions" .!= [] + return ISMState {..} + +instance ToJSON ISMState where + toJSON ISMState {..} = + omitNulls + [ "name" .= ismStateName, + "actions" .= ismStateActions, + "transitions" .= ismStateTransitions + ] + +-- | A state transition. @stateName@ names the destination state; @conditions@ +-- is the optional guard. When @conditions@ is 'Nothing' the transition is +-- unconditional. +-- See +data ISMTransition = ISMTransition + { ismTransitionStateName :: Text, + ismTransitionConditions :: Maybe ISMCondition + } + deriving stock (Eq, Show) + +instance FromJSON ISMTransition where + parseJSON = withObject "ISMTransition" $ \v -> do + ismTransitionStateName <- v .: "state_name" + ismTransitionConditions <- v .:? "conditions" + return ISMTransition {..} + +instance ToJSON ISMTransition where + toJSON ISMTransition {..} = + omitNulls + [ "state_name" .= ismTransitionStateName, + "conditions" .= ismTransitionConditions + ] + +-- | The guard on a transition. OpenSearch accepts any subset of these +-- thresholds; all are 'Maybe' so callers can express just the ones they need. +-- See +data ISMCondition = ISMCondition + { ismConditionMinSize :: Maybe Text, + ismConditionMinDocCount :: Maybe Int, + ismConditionMinIndexAge :: Maybe Text, + ismConditionMinRolloverAge :: Maybe Text, + ismConditionCron :: Maybe ISMCron, + ismConditionDsl :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMCondition where + parseJSON = withObject "ISMCondition" $ \v -> do + ismConditionMinSize <- v .:? "min_size" + ismConditionMinDocCount <- v .:? "min_doc_count" + ismConditionMinIndexAge <- v .:? "min_index_age" + ismConditionMinRolloverAge <- v .:? "min_rollover_age" + ismConditionCron <- v .:? "cron" + ismConditionDsl <- v .:? "dsl" + return ISMCondition {..} + +instance ToJSON ISMCondition where + toJSON ISMCondition {..} = + omitNulls + [ "min_size" .= ismConditionMinSize, + "min_doc_count" .= ismConditionMinDocCount, + "min_index_age" .= ismConditionMinIndexAge, + "min_rollover_age" .= ismConditionMinRolloverAge, + "cron" .= ismConditionCron, + "dsl" .= ismConditionDsl + ] + +-- | Inner payload of a cron transition condition: the cron expression and an +-- optional timezone. See 'ISMCron' for the outer wrapper OpenSearch expects. +-- See +data ISMCronCondition = ISMCronCondition + { ismCronConditionExpression :: Text, + ismCronConditionTimezone :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMCronCondition where + parseJSON = withObject "ISMCronCondition" $ \v -> do + ismCronConditionExpression <- v .: "expression" + ismCronConditionTimezone <- v .:? "timezone" + return ISMCronCondition {..} + +instance ToJSON ISMCronCondition where + toJSON ISMCronCondition {..} = + omitNulls + [ "expression" .= ismCronConditionExpression, + "timezone" .= ismCronConditionTimezone + ] + +-- | Outer wrapper OpenSearch requires around an 'ISMCronCondition'. The +-- documented @conditions.cron@ value is an object containing a nested @cron@ +-- key: @{\"cron\":{\"cron\":{\"expression\":...,\"timezone\":...}}}@. The +-- outer 'ISMCron' models the middle layer so 'ISMCondition''s parser can +-- decode the documented shape directly. +-- See +newtype ISMCron = ISMCron {ismCronInner :: ISMCronCondition} + deriving stock (Eq, Show) + +instance FromJSON ISMCron where + parseJSON = withObject "ISMCron" $ \v -> do + inner <- v .: "cron" + return (ISMCron inner) + +instance ToJSON ISMCron where + toJSON (ISMCron inner) = + omitNulls ["cron" .= inner] + +-- | The auto-apply template that attaches this policy to newly-created indices +-- whose name matches one of @indexPatterns@. @priority@ breaks ties when +-- multiple templates match. +-- See +data ISMTemplate = ISMTemplate + { ismTemplateIndexPatterns :: [Text], + ismTemplatePriority :: Maybe Scientific + } + deriving stock (Eq, Show) + +instance FromJSON ISMTemplate where + parseJSON = withObject "ISMTemplate" $ \v -> do + ismTemplateIndexPatterns <- v .:? "index_patterns" .!= [] + ismTemplatePriority <- v .:? "priority" + return ISMTemplate {..} + +instance ToJSON ISMTemplate where + toJSON ISMTemplate {..} = + omitNulls + [ "index_patterns" .= ismTemplateIndexPatterns, + "priority" .= ismTemplatePriority + ] + +-- | The destination of an 'ISMErrorNotification'. OpenSearch's Policies doc +-- (https://docs.opensearch.org/2.18/im-plugin/ism/policies/#error-notification) +-- lists three destination kinds: @chime@, @custom_webhook@ and @slack@. +-- Unknown destination types fall through to 'ISMErrorNotificationDestinationCustom'. +data ISMErrorNotificationDestination + = ISMErrorNotificationDestinationChime (Maybe Value) + | ISMErrorNotificationDestinationCustomWebhook (Maybe Value) + | ISMErrorNotificationDestinationSlack (Maybe Value) + | ISMErrorNotificationDestinationCustom Text (Maybe Value) + deriving stock (Eq, Show) + +destinationTag :: ISMErrorNotificationDestination -> Text +destinationTag = \case + ISMErrorNotificationDestinationChime _ -> "chime" + ISMErrorNotificationDestinationCustomWebhook _ -> "custom_webhook" + ISMErrorNotificationDestinationSlack _ -> "slack" + ISMErrorNotificationDestinationCustom tag _ -> tag + +destinationConfig :: ISMErrorNotificationDestination -> Maybe Value +destinationConfig = \case + ISMErrorNotificationDestinationChime cfg -> cfg + ISMErrorNotificationDestinationCustomWebhook cfg -> cfg + ISMErrorNotificationDestinationSlack cfg -> cfg + ISMErrorNotificationDestinationCustom _ cfg -> cfg + +instance FromJSON ISMErrorNotificationDestination where + parseJSON = withObject "ISMErrorNotificationDestination" $ \o -> case KM.toList o of + [] -> fail "ISMErrorNotificationDestination: empty object" + ((k, v) : _) -> case AKey.toText k of + "chime" -> ISMErrorNotificationDestinationChime <$> parseJSON v + "custom_webhook" -> ISMErrorNotificationDestinationCustomWebhook <$> parseJSON v + "slack" -> ISMErrorNotificationDestinationSlack <$> parseJSON v + other -> ISMErrorNotificationDestinationCustom other <$> parseJSON v + +instance ToJSON ISMErrorNotificationDestination where + toJSON d = + object + [ AKey.fromText (destinationTag d) + .= maybe (object []) id (destinationConfig d) + ] + +-- | The Mustache template used to render an 'ISMErrorNotification' message. +-- OpenSearch documents only the @source@ field, but the server injects @lang@ +-- (typically @"mustache"@) on responses; we carry it as 'Maybe' so a GET → PUT +-- round-trip is lossless (mirrors the Alerting plugin's @MessageTemplate@). See +-- the @message_template@ parameter at +-- . +data ISMMessageTemplate = ISMMessageTemplate + { ismMessageTemplateSource :: Text, + ismMessageTemplateLang :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMMessageTemplate where + parseJSON = withObject "ISMMessageTemplate" $ \v -> do + ismMessageTemplateSource <- v .: "source" + ismMessageTemplateLang <- v .:? "lang" + pure ISMMessageTemplate {..} + +instance ToJSON ISMMessageTemplate where + toJSON ISMMessageTemplate {..} = + omitNulls + [ "source" .= ismMessageTemplateSource, + "lang" .= ismMessageTemplateLang + ] + +-- | Error-notification block attached to a policy: when an action fails, OS +-- notifies either a @destination@ (Slack/Chime/webhook URL) or a Notifications +-- plugin @channel@. Per the policies doc, exactly one of 'destination' / +-- 'channel' must be present (they are mutually exclusive); the parser enforces +-- that invariant. +-- See +data ISMErrorNotification = ISMErrorNotification + { ismErrorNotificationDestination :: Maybe ISMErrorNotificationDestination, + ismErrorNotificationChannelId :: Maybe Text, + ismErrorNotificationMessageTemplate :: ISMMessageTemplate + } + deriving stock (Eq, Show) + +instance FromJSON ISMErrorNotification where + parseJSON = withObject "ISMErrorNotification" $ \v -> do + ismErrorNotificationDestination <- v .:? "destination" + mChannel <- v .:? "channel" + case (ismErrorNotificationDestination, mChannel) of + (Nothing, Nothing) -> + fail "ISMErrorNotification requires either 'destination' or 'channel'" + (Just _, Just _) -> + fail "ISMErrorNotification: 'destination' and 'channel' are mutually exclusive" + _ -> pure () + ismErrorNotificationChannelId <- case mChannel of + Nothing -> pure Nothing + Just ch -> Just <$> withObject "ISMErrorNotification channel" (.: "id") ch + ismErrorNotificationMessageTemplate <- v .: "message_template" + return ISMErrorNotification {..} + +instance ToJSON ISMErrorNotification where + toJSON ISMErrorNotification {..} = + omitNulls + [ "destination" .= ismErrorNotificationDestination, + "channel" .= channelValue ismErrorNotificationChannelId, + "message_template" .= ismErrorNotificationMessageTemplate + ] + where + channelValue = \case + Nothing -> Null + Just cid -> object ["id" .= cid] + +-- | User-supplied variable substitutions, used inside Mustache templates +-- (@{{{ctx.user_vars.}}}@). OS allows arbitrary JSON here; we expose the +-- common @Map Text Text@ shape and lose anything more exotic. +-- See +newtype ISMUserVariables = ISMUserVariables {unISMUserVariables :: Map.Map Text Text} + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- $actions +-- +-- OpenSearch encodes a state @actions@ entry as a JSON object whose keys +-- are the action name plus optional @timeout@ \/ @retry@ siblings. The +-- action-name key carries that action's config (or @{}@ when there is +-- none). For example: +-- +-- @{"rollover": {"min_size": "1gb"}}@, @{"delete": {}}@, and (with meta) +-- @{"rollover": {"min_size": "1gb"}, "timeout": "1d"}@. +-- +-- 'ISMAction' models the action half (one constructor per known action +-- plus an 'ISMActionCustom' escape hatch that preserves unknown action +-- types losslessly); 'ISMActionEntry' pairs it with the optional +-- per-action meta. Only the three most common actions ('ISMActionRollover', +-- 'ISMActionForceMerge', 'ISMActionAllocation') carry typed configs today; the +-- remaining constructors carry their config as an opaque 'Value' (typing them +-- is tracked as follow-up work). + +data ISMAction + = ISMActionRollover (Maybe ISMRolloverConfig) + | ISMActionDelete + | ISMActionForceMerge (Maybe ISMForceMergeConfig) + | ISMActionAllocation (Maybe ISMAllocationConfig) + | ISMActionNotification (Maybe Value) + | ISMActionSnapshot (Maybe Value) + | ISMActionReadWrite (Maybe Value) + | ISMActionReadOnly + | ISMActionShrink (Maybe Value) + | ISMActionOpen + | ISMActionClose + | ISMActionRollup (Maybe Value) + | ISMActionIndexPriority (Maybe Value) + | ISMActionFreeze + | ISMActionUnfreeze + | ISMActionWaitFor (Maybe Value) + | ISMActionReplicaCount (Maybe ISMReplicaCountConfig) + | ISMActionAlias (Maybe ISMAliasConfig) + | ISMActionCustom Text (Maybe Value) + deriving stock (Eq, Show) + +-- | Name of the single JSON key that encodes this action (matches what OS +-- sends on the wire). +actionTagName :: ISMAction -> Text +actionTagName = \case + ISMActionRollover _ -> "rollover" + ISMActionDelete -> "delete" + ISMActionForceMerge _ -> "force_merge" + ISMActionAllocation _ -> "allocation" + ISMActionNotification _ -> "notification" + ISMActionSnapshot _ -> "snapshot" + ISMActionReadWrite _ -> "read_write" + ISMActionReadOnly -> "read_only" + ISMActionShrink _ -> "shrink" + ISMActionOpen -> "open" + ISMActionClose -> "close" + ISMActionRollup _ -> "rollup" + ISMActionIndexPriority _ -> "index_priority" + ISMActionFreeze -> "freeze" + ISMActionUnfreeze -> "unfreeze" + ISMActionWaitFor _ -> "wait_for" + ISMActionReplicaCount _ -> "replica_count" + ISMActionAlias _ -> "alias" + ISMActionCustom tag _ -> tag + +-- | Render the action's config as a 'Value'. For actions without a config this +-- is an empty object @{}@; for opaque actions it is whatever the caller put in +-- (or @{}@ if 'Nothing'). +actionConfigValue :: ISMAction -> Value +actionConfigValue = \case + ISMActionRollover cfg -> maybe (object []) toJSON cfg + ISMActionDelete -> object [] + ISMActionForceMerge cfg -> maybe (object []) toJSON cfg + ISMActionAllocation cfg -> maybe (object []) toJSON cfg + ISMActionNotification cfg -> maybe (object []) toJSON cfg + ISMActionSnapshot cfg -> maybe (object []) toJSON cfg + ISMActionReadWrite cfg -> maybe (object []) toJSON cfg + ISMActionReadOnly -> object [] + ISMActionShrink cfg -> maybe (object []) toJSON cfg + ISMActionOpen -> object [] + ISMActionClose -> object [] + ISMActionRollup cfg -> maybe (object []) toJSON cfg + ISMActionIndexPriority cfg -> maybe (object []) toJSON cfg + ISMActionFreeze -> object [] + ISMActionUnfreeze -> object [] + ISMActionWaitFor cfg -> maybe (object []) toJSON cfg + ISMActionReplicaCount cfg -> maybe (object []) toJSON cfg + ISMActionAlias cfg -> maybe (object []) toJSON cfg + ISMActionCustom _ cfg -> maybe (object []) toJSON cfg + +instance FromJSON ISMAction where + parseJSON = withObject "ISMAction" $ \o -> case KM.toList o of + [] -> fail "ISMAction: empty object" + ((k, v) : _) -> case AKey.toText k of + "rollover" -> ISMActionRollover <$> parseJSON v + "delete" -> pure ISMActionDelete + "force_merge" -> ISMActionForceMerge <$> parseJSON v + "allocation" -> ISMActionAllocation <$> parseJSON v + "notification" -> ISMActionNotification <$> parseJSON v + "snapshot" -> ISMActionSnapshot <$> parseJSON v + "read_write" -> ISMActionReadWrite <$> parseJSON v + "read_only" -> pure ISMActionReadOnly + "shrink" -> ISMActionShrink <$> parseJSON v + "open" -> pure ISMActionOpen + "close" -> pure ISMActionClose + "rollup" -> ISMActionRollup <$> parseJSON v + "index_priority" -> ISMActionIndexPriority <$> parseJSON v + "freeze" -> pure ISMActionFreeze + "unfreeze" -> pure ISMActionUnfreeze + "wait_for" -> ISMActionWaitFor <$> parseJSON v + "replica_count" -> ISMActionReplicaCount <$> parseJSON v + "alias" -> ISMActionAlias <$> parseJSON v + other -> ISMActionCustom other <$> parseJSON v + +instance ToJSON ISMAction where + toJSON a = object [AKey.fromText (actionTagName a) .= actionConfigValue a] + +-- $actionMeta +-- +-- Beyond the action-specific config, OS accepts two orthogonal parameters +-- on every action entry: @timeout@ and @retry@ +-- (). +-- These sit alongside the action key as siblings in the same JSON object, +-- e.g.: +-- +-- @ +-- { "rollover": {"min_size": "50gb"}, +-- , "timeout": "1d" +-- , "retry": {"count": 3, "backoff": "exponential", "delay": "1m"} +-- } +-- @ +-- +-- 'ISMActionEntry' pairs an 'ISMAction' with its optional meta so the +-- per-action configuration stays orthogonal to the action type itself. +-- 'mkISMActionEntry' produces an entry whose wire shape is byte-for-byte +-- identical to the legacy bare 'ISMAction' for any *known* action (no +-- @timeout@\/@retry@ keys emitted), preserving backwards compatibility +-- with existing callers. The names @"timeout"@ and @"retry"@ are +-- reserved: an 'ISMActionCustom' that reuses either as its tag would be +-- shadowed by the meta merge — see the note on 'ISMActionEntry's +-- 'ToJSON' instance. +-- +-- /Maintainer note:/ 'ISMActionEntry's codecs strip exactly +-- @["timeout", "retry"]@ before delegating to 'ISMAction'. If OS grows +-- additional per-action meta siblings in a future release, extend that +-- strip list in both 'FromJSON' and 'ToJSON' to keep the action parser +-- from mis-reading the new sibling as an 'ISMActionCustom'. + +-- | Backoff strategy used by 'ISMRetryConfig'. OS accepts exactly these +-- three values; the 'FromJSON' instance rejects anything else so a typo +-- surfaces at decode time rather than being silently dropped. +data ISMRetryBackoff + = ISMRetryBackoffExponential + | ISMRetryBackoffConstant + | ISMRetryBackoffLinear + deriving stock (Eq, Show) + +ismRetryBackoffText :: ISMRetryBackoff -> Text +ismRetryBackoffText ISMRetryBackoffExponential = "exponential" +ismRetryBackoffText ISMRetryBackoffConstant = "constant" +ismRetryBackoffText ISMRetryBackoffLinear = "linear" + +instance FromJSON ISMRetryBackoff where + parseJSON = withText "ISMRetryBackoff" $ \case + "exponential" -> pure ISMRetryBackoffExponential + "constant" -> pure ISMRetryBackoffConstant + "linear" -> pure ISMRetryBackoffLinear + other -> fail ("unknown ISM retry backoff: " <> T.unpack other) + +instance ToJSON ISMRetryBackoff where + toJSON = String . ismRetryBackoffText + +-- | Per-action retry configuration. Every field is optional; OS fills in +-- sensible defaults when omitted. +-- See +data ISMRetryConfig = ISMRetryConfig + { ismRetryConfigCount :: Maybe Int, + ismRetryConfigBackoff :: Maybe ISMRetryBackoff, + ismRetryConfigDelay :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMRetryConfig where + parseJSON = withObject "ISMRetryConfig" $ \v -> do + ismRetryConfigCount <- v .:? "count" + ismRetryConfigBackoff <- v .:? "backoff" + ismRetryConfigDelay <- v .:? "delay" + return ISMRetryConfig {..} + +instance ToJSON ISMRetryConfig where + toJSON ISMRetryConfig {..} = + omitNulls + [ "count" .= ismRetryConfigCount, + "backoff" .= ismRetryConfigBackoff, + "delay" .= ismRetryConfigDelay + ] + +-- | One entry in 'ismStateActions'. Pairs the action-specific config +-- ('ISMAction') with the orthogonal per-action meta (@timeout@, @retry@). +-- Use 'mkISMActionEntry' to construct an entry that decodes byte-for-byte +-- like the legacy bare 'ISMAction'. +data ISMActionEntry = ISMActionEntry + { ismActionEntryAction :: ISMAction, + -- | @timeout@ sibling. OS accepts time units for minutes, hours and + -- days (e.g. @"1d"@, @"60m"@). Kept as plain 'Text' so callers can + -- build any valid OS literal without the library having to model the + -- restricted grammar. + ismActionEntryTimeout :: Maybe Text, + ismActionEntryRetry :: Maybe ISMRetryConfig + } + deriving stock (Eq, Show) + +-- | Smart constructor that produces an entry with no meta. The resulting +-- wire shape is byte-for-byte identical to the bare 'ISMAction', so +-- callers migrating from the legacy @[ISMAction]@ shape can wrap each +-- element mechanically. +mkISMActionEntry :: ISMAction -> ISMActionEntry +mkISMActionEntry a = ISMActionEntry a Nothing Nothing + +instance FromJSON ISMActionEntry where + parseJSON = withObject "ISMActionEntry" $ \o -> do + -- Strip the meta keys so the remaining single-key object parses as + -- the underlying 'ISMAction' via its existing instance. + let body = Object (deleteSeveral ["timeout", "retry"] o) + ismActionEntryAction <- parseJSON body + ismActionEntryTimeout <- o .:? "timeout" + ismActionEntryRetry <- o .:? "retry" + return ISMActionEntry {..} + +instance ToJSON ISMActionEntry where + toJSON ISMActionEntry {..} = + case toJSON ismActionEntryAction of + Object inner -> + Object (deleteSeveral ["timeout", "retry"] inner <> meta) + where + meta = + KM.fromList $ + [ ("timeout", toJSON t) | Just t <- [ismActionEntryTimeout] + ] + <> [ ("retry", toJSON r) | Just r <- [ismActionEntryRetry] + ] + -- Defensive: 'ISMAction' always renders to a single-key 'Object', + -- so this branch is unreachable in practice but keeps the instance + -- total. + other -> other + +ismActionEntryActionLens :: Lens' ISMActionEntry ISMAction +ismActionEntryActionLens = lens ismActionEntryAction (\x y -> x {ismActionEntryAction = y}) + +ismActionEntryTimeoutLens :: Lens' ISMActionEntry (Maybe Text) +ismActionEntryTimeoutLens = lens ismActionEntryTimeout (\x y -> x {ismActionEntryTimeout = y}) + +ismActionEntryRetryLens :: Lens' ISMActionEntry (Maybe ISMRetryConfig) +ismActionEntryRetryLens = lens ismActionEntryRetry (\x y -> x {ismActionEntryRetry = y}) + +-- | Config for 'ISMActionRollover'. OS requires at least one threshold; we keep +-- all four 'Maybe' so callers can express any subset. Sizes/ages carry units +-- (e.g. @"1gb"@, @"1d"@) so they are 'Text', not numbers. +-- See +data ISMRolloverConfig = ISMRolloverConfig + { ismRolloverConfigMinSize :: Maybe Text, + ismRolloverConfigMinDocCount :: Maybe Int, + ismRolloverConfigMinIndexAge :: Maybe Text, + ismRolloverConfigMinPrimaryShardSize :: Maybe Text, + ismRolloverConfigCopyAlias :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON ISMRolloverConfig where + parseJSON = withObject "ISMRolloverConfig" $ \v -> do + ismRolloverConfigMinSize <- v .:? "min_size" + ismRolloverConfigMinDocCount <- v .:? "min_doc_count" + ismRolloverConfigMinIndexAge <- v .:? "min_index_age" + ismRolloverConfigMinPrimaryShardSize <- v .:? "min_primary_shard_size" + ismRolloverConfigCopyAlias <- v .:? "copy_alias" + return ISMRolloverConfig {..} + +instance ToJSON ISMRolloverConfig where + toJSON ISMRolloverConfig {..} = + omitNulls + [ "min_size" .= ismRolloverConfigMinSize, + "min_doc_count" .= ismRolloverConfigMinDocCount, + "min_index_age" .= ismRolloverConfigMinIndexAge, + "min_primary_shard_size" .= ismRolloverConfigMinPrimaryShardSize, + "copy_alias" .= ismRolloverConfigCopyAlias + ] + +-- | Config for 'ISMActionForceMerge'. Of the three fields, only +-- @max_num_segments@ appears in the official OpenSearch ISM @force_merge@ +-- documentation; @wait_for_completion@ and @task_execution_timeout@ are +-- accepted by the server but undocumented on the policies page. +-- @wait_for_completion@ (default @true@) is a 'Bool' gating whether the +-- action blocks until the merge finishes; @task_execution_timeout@ (default +-- @1h@, only meaningful when @wait_for_completion@ is @false@) is a duration +-- string (e.g. @"1h"@), hence 'Text'. All three are 'Maybe' so minimal +-- payloads round-trip byte-stable. +-- See +data ISMForceMergeConfig = ISMForceMergeConfig + { ismForceMergeConfigMaxNumSegments :: Maybe Int, + ismForceMergeConfigWaitForCompletion :: Maybe Bool, + ismForceMergeConfigTaskExecutionTimeout :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMForceMergeConfig where + parseJSON = withObject "ISMForceMergeConfig" $ \v -> do + ismForceMergeConfigMaxNumSegments <- v .:? "max_num_segments" + ismForceMergeConfigWaitForCompletion <- v .:? "wait_for_completion" + ismForceMergeConfigTaskExecutionTimeout <- v .:? "task_execution_timeout" + return ISMForceMergeConfig {..} + +instance ToJSON ISMForceMergeConfig where + toJSON ISMForceMergeConfig {..} = + omitNulls + [ "max_num_segments" .= ismForceMergeConfigMaxNumSegments, + "wait_for_completion" .= ismForceMergeConfigWaitForCompletion, + "task_execution_timeout" .= ismForceMergeConfigTaskExecutionTimeout + ] + +-- | Config for 'ISMActionAllocation'. Each of @require@, @include@, @exclude@ +-- maps allocation attribute names to (comma-separated) values. @wait_for@ +-- gates whether the policy blocks until the reallocation completes +-- (: +-- @val waitFor: Boolean = false@). +-- See +data ISMAllocationConfig = ISMAllocationConfig + { ismAllocationConfigRequire :: Maybe (Map.Map Text Text), + ismAllocationConfigInclude :: Maybe (Map.Map Text Text), + ismAllocationConfigExclude :: Maybe (Map.Map Text Text), + ismAllocationConfigWaitFor :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON ISMAllocationConfig where + parseJSON = withObject "ISMAllocationConfig" $ \v -> do + ismAllocationConfigRequire <- v .:? "require" + ismAllocationConfigInclude <- v .:? "include" + ismAllocationConfigExclude <- v .:? "exclude" + ismAllocationConfigWaitFor <- v .:? "wait_for" + return ISMAllocationConfig {..} + +instance ToJSON ISMAllocationConfig where + toJSON ISMAllocationConfig {..} = + omitNulls + [ "require" .= ismAllocationConfigRequire, + "include" .= ismAllocationConfigInclude, + "exclude" .= ismAllocationConfigExclude, + "wait_for" .= ismAllocationConfigWaitFor + ] + +-- | Config for 'ISMActionReplicaCount'. OS requires @number_of_replicas@ to be +-- present (it has no sensible default), so the field is a strict 'Int' rather +-- than 'Maybe'. A caller who builds 'ISMActionReplicaCount' 'Nothing' encodes +-- as @{"replica_count":{}}@ which the server will reject — that path is +-- intended only for round-tripping malformed payloads. +-- See +data ISMReplicaCountConfig = ISMReplicaCountConfig + { ismReplicaCountConfigNumberOfReplicas :: Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMReplicaCountConfig where + parseJSON = withObject "ISMReplicaCountConfig" $ \v -> do + ismReplicaCountConfigNumberOfReplicas <- v .: "number_of_replicas" + return ISMReplicaCountConfig {..} + +instance ToJSON ISMReplicaCountConfig where + toJSON ISMReplicaCountConfig {..} = + object ["number_of_replicas" .= ismReplicaCountConfigNumberOfReplicas] + +-- | One sub-action inside an 'ISMAliasConfig' @actions@ array. OS supports +-- @add@ and @remove@; both carry at least the alias name. @add@ additionally +-- accepts @index@ (which index to attach) and @is_write_index@. This is the +-- minimal typed surface covering the documented example +-- (); any +-- more exotic sub-action can still be carried losslessly via +-- 'ISMActionCustom' on the outer 'ISMAction'. +data ISMAliasAction + = ISMAliasActionAdd + { ismAliasActionAddAlias :: Text, + ismAliasActionAddIndex :: Maybe Text, + ismAliasActionAddIsWriteIndex :: Maybe Bool + } + | ISMAliasActionRemove + { ismAliasActionRemoveAlias :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMAliasAction where + parseJSON = withObject "ISMAliasAction" $ \o -> case KM.toList o of + [] -> fail "ISMAliasAction: empty object" + ((k, v) : _) -> case AKey.toText k of + "add" -> + withObject + "ISMAliasActionAdd" + ( \cfg -> do + ismAliasActionAddAlias <- cfg .: "alias" + ismAliasActionAddIndex <- cfg .:? "index" + ismAliasActionAddIsWriteIndex <- cfg .:? "is_write_index" + return ISMAliasActionAdd {..} + ) + v + "remove" -> + withObject + "ISMAliasActionRemove" + ( \cfg -> do + ismAliasActionRemoveAlias <- cfg .: "alias" + return ISMAliasActionRemove {..} + ) + v + other -> fail ("ISMAliasAction: unexpected key " <> T.unpack other) + +instance ToJSON ISMAliasAction where + toJSON = \case + ISMAliasActionAdd {..} -> + object + [ AKey.fromText "add" + .= omitNulls + [ "alias" .= ismAliasActionAddAlias, + "index" .= ismAliasActionAddIndex, + "is_write_index" .= ismAliasActionAddIsWriteIndex + ] + ] + ISMAliasActionRemove {..} -> + object + [ AKey.fromText "remove" + .= object ["alias" .= ismAliasActionRemoveAlias] + ] + +-- | Config for 'ISMActionAlias'. Wraps the @actions@ array of @add@ \/ @remove@ +-- sub-actions (see 'ISMAliasAction'). +-- See +newtype ISMAliasConfig = ISMAliasConfig + { ismAliasConfigActions :: [ISMAliasAction] + } + deriving stock (Eq, Show) + +instance FromJSON ISMAliasConfig where + parseJSON = withObject "ISMAliasConfig" $ \v -> do + ismAliasConfigActions <- v .:? "actions" .!= [] + return ISMAliasConfig {..} + +instance ToJSON ISMAliasConfig where + toJSON ISMAliasConfig {..} = + object ["actions" .= ismAliasConfigActions] + +-- | One entry in the @failed_indices@ array of an 'ISMUpdatedIndicesResponse'. +-- Carries the index that rejected an ISM policy operation along with the +-- reason. @index_uuid@ is @null@ when the index does not exist. +-- See +data ISMFailedIndex = ISMFailedIndex + { ismFailedIndexName :: Text, + ismFailedIndexUuid :: Maybe Text, + ismFailedIndexReason :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMFailedIndex where + parseJSON = withObject "ISMFailedIndex" $ \v -> do + ismFailedIndexName <- v .: "index_name" + ismFailedIndexUuid <- v .:? "index_uuid" + ismFailedIndexReason <- v .: "reason" + return ISMFailedIndex {..} + +instance ToJSON ISMFailedIndex where + toJSON ISMFailedIndex {..} = + object + [ "index_name" .= ismFailedIndexName, + "index_uuid" .= ismFailedIndexUuid, + "reason" .= ismFailedIndexReason + ] + +-- | Response body shared by the ISM index-mutation endpoints +-- @POST /_plugins/_ism/add\/remove\/change_policy\/retry\/{index}@. +-- OpenSearch reports @updated_indices@, whether any @failures@ occurred, and a +-- @failed_indices@ list describing each index that rejected the operation. +-- See +data ISMUpdatedIndicesResponse = ISMUpdatedIndicesResponse + { ismUpdatedIndicesResponseUpdatedIndices :: Int, + ismUpdatedIndicesResponseFailures :: Bool, + ismUpdatedIndicesResponseFailedIndices :: [ISMFailedIndex] + } + deriving stock (Eq, Show) + +-- | Backwards-compatible alias. The @add@, @remove@, @change_policy@ and +-- @retry@ ISM endpoints all share this response shape; the type was originally +-- introduced as @AddISMPolicyResponse@ before the shared shape was recognised. +type AddISMPolicyResponse = ISMUpdatedIndicesResponse + +instance FromJSON ISMUpdatedIndicesResponse where + parseJSON = withObject "ISMUpdatedIndicesResponse" $ \v -> do + ismUpdatedIndicesResponseUpdatedIndices <- v .: "updated_indices" + ismUpdatedIndicesResponseFailures <- v .: "failures" + ismUpdatedIndicesResponseFailedIndices <- v .:? "failed_indices" .!= [] + return ISMUpdatedIndicesResponse {..} + +instance ToJSON ISMUpdatedIndicesResponse where + toJSON ISMUpdatedIndicesResponse {..} = + object + [ "updated_indices" .= ismUpdatedIndicesResponseUpdatedIndices, + "failures" .= ismUpdatedIndicesResponseFailures, + "failed_indices" .= ismUpdatedIndicesResponseFailedIndices + ] + +-- | Optional filter inside a 'ChangePolicyRequest'. Restricts the policy change +-- to managed indices currently in the given @state@. +-- See +data ISMChangePolicyInclude = ISMChangePolicyInclude + { ismChangePolicyIncludeState :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMChangePolicyInclude where + parseJSON = withObject "ISMChangePolicyInclude" $ \v -> do + ismChangePolicyIncludeState <- v .: "state" + return ISMChangePolicyInclude {..} + +instance ToJSON ISMChangePolicyInclude where + toJSON ISMChangePolicyInclude {..} = + object ["state" .= ismChangePolicyIncludeState] + +-- | Request body for @POST /_plugins/_ism/change_policy\/{index}@. +-- @policy_id@ selects the new policy; @state@ optionally names the state the +-- managed index transitions to after the change takes effect; @include@ +-- optionally filters which currently-managed indices the change applies to. +-- See +data ChangePolicyRequest = ChangePolicyRequest + { changePolicyRequestId :: PolicyId, + changePolicyRequestState :: Maybe Text, + changePolicyRequestInclude :: [ISMChangePolicyInclude] + } + deriving stock (Eq, Show) + +instance FromJSON ChangePolicyRequest where + parseJSON = withObject "ChangePolicyRequest" $ \v -> do + changePolicyRequestId <- v .: "policy_id" + changePolicyRequestState <- v .:? "state" + changePolicyRequestInclude <- v .:? "include" .!= [] + return ChangePolicyRequest {..} + +instance ToJSON ChangePolicyRequest where + toJSON ChangePolicyRequest {..} = + omitNulls + [ "policy_id" .= unPolicyId changePolicyRequestId, + "state" .= changePolicyRequestState, + "include" .= changePolicyRequestInclude + ] + +-- $explainSubshapes +-- +-- The @GET /_plugins/_ism/explain/{index}@ response is a JSON object keyed by +-- index name. Each value mixes (a) arbitrary index settings whose keys contain +-- dots (e.g. @index.plugins.index_state_management.policy_id@) with (b) a +-- fixed set of managed-index fields (@index@, @state@, @action@, ...). To stay +-- lossless for the unmanaged case, the dotted @policy_id@ settings are +-- captured explicitly; every managed-index field is 'Maybe' so the minimal +-- unmanaged body @{"index.plugins...policy_id": "p"}@ decodes cleanly. +-- +-- The full @policy@ sub-object is carried as an opaque 'Value' until the typed +-- ISM policy schema lands (tracked separately). +-- +-- See + +-- | A named ISM runtime entity (a @state@ or an @action@) with the epoch-ms +-- instant at which it became active. +data ISMExplanationNamed = ISMExplanationNamed + { ismExplanationNamedName :: Text, + ismExplanationNamedStartTime :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationNamed where + parseJSON = withObject "ISMExplanationNamed" $ \v -> do + ismExplanationNamedName <- v .: "name" + ismExplanationNamedStartTime <- v .:? "start_time" + return ISMExplanationNamed {..} + +instance ToJSON ISMExplanationNamed where + toJSON ISMExplanationNamed {..} = + omitNulls + [ "name" .= ismExplanationNamedName, + "start_time" .= ismExplanationNamedStartTime + ] + +-- | The @action@ object in an explain entry. +data ISMExplanationAction = ISMExplanationAction + { ismExplanationActionName :: Text, + ismExplanationActionStartTime :: Maybe Int, + ismExplanationActionIndex :: Maybe Int, + ismExplanationActionFailed :: Maybe Bool, + ismExplanationActionConsumedRetries :: Maybe Int, + ismExplanationActionLastRetryTime :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationAction where + parseJSON = withObject "ISMExplanationAction" $ \v -> do + ismExplanationActionName <- v .: "name" + ismExplanationActionStartTime <- v .:? "start_time" + ismExplanationActionIndex <- v .:? "index" + ismExplanationActionFailed <- v .:? "failed" + ismExplanationActionConsumedRetries <- v .:? "consumed_retries" + ismExplanationActionLastRetryTime <- v .:? "last_retry_time" + return ISMExplanationAction {..} + +instance ToJSON ISMExplanationAction where + toJSON ISMExplanationAction {..} = + omitNulls + [ "name" .= ismExplanationActionName, + "start_time" .= ismExplanationActionStartTime, + "index" .= ismExplanationActionIndex, + "failed" .= ismExplanationActionFailed, + "consumed_retries" .= ismExplanationActionConsumedRetries, + "last_retry_time" .= ismExplanationActionLastRetryTime + ] + +-- | The @step@ object in an explain entry. +data ISMExplanationStep = ISMExplanationStep + { ismExplanationStepName :: Text, + ismExplanationStepStartTime :: Maybe Int, + ismExplanationStepStepStatus :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationStep where + parseJSON = withObject "ISMExplanationStep" $ \v -> do + ismExplanationStepName <- v .: "name" + ismExplanationStepStartTime <- v .:? "start_time" + ismExplanationStepStepStatus <- v .:? "step_status" + return ISMExplanationStep {..} + +instance ToJSON ISMExplanationStep where + toJSON ISMExplanationStep {..} = + omitNulls + [ "name" .= ismExplanationStepName, + "start_time" .= ismExplanationStepStartTime, + "step_status" .= ismExplanationStepStepStatus + ] + +-- | The @retry_info@ object in an explain entry. +data ISMExplanationRetryInfo = ISMExplanationRetryInfo + { ismExplanationRetryInfoFailed :: Bool, + ismExplanationRetryInfoConsumedRetries :: Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationRetryInfo where + parseJSON = withObject "ISMExplanationRetryInfo" $ \v -> do + ismExplanationRetryInfoFailed <- v .: "failed" + ismExplanationRetryInfoConsumedRetries <- v .: "consumed_retries" + return ISMExplanationRetryInfo {..} + +instance ToJSON ISMExplanationRetryInfo where + toJSON ISMExplanationRetryInfo {..} = + object + [ "failed" .= ismExplanationRetryInfoFailed, + "consumed_retries" .= ismExplanationRetryInfoConsumedRetries + ] + +-- | The @info@ object in an explain entry. +data ISMExplanationInfo = ISMExplanationInfo + { ismExplanationInfoMessage :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationInfo where + parseJSON = withObject "ISMExplanationInfo" $ \v -> do + ismExplanationInfoMessage <- v .: "message" + return ISMExplanationInfo {..} + +instance ToJSON ISMExplanationInfo where + toJSON ISMExplanationInfo {..} = + object ["message" .= ismExplanationInfoMessage] + +-- | The @validate@ object returned when explain is called with +-- @validate_action=true@. +data ISMExplanationValidate = ISMExplanationValidate + { ismExplanationValidateValidationMessage :: Text, + ismExplanationValidateValidationStatus :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationValidate where + parseJSON = withObject "ISMExplanationValidate" $ \v -> do + ismExplanationValidateValidationMessage <- v .: "validation_message" + ismExplanationValidateValidationStatus <- v .: "validation_status" + return ISMExplanationValidate {..} + +instance ToJSON ISMExplanationValidate where + toJSON ISMExplanationValidate {..} = + object + [ "validation_message" .= ismExplanationValidateValidationMessage, + "validation_status" .= ismExplanationValidateValidationStatus + ] + +-- | Per-index value in an 'ISMExplanation'. Every field is 'Maybe' because the +-- explain response ranges from a bare settings-only object (unmanaged index) +-- to the full managed-index status. The dotted @policy_id@ settings are +-- captured explicitly so the unmanaged case is not lossy. +data ISMExplanationEntry = ISMExplanationEntry + { ismExplanationEntryIndex :: Maybe Text, + ismExplanationEntryIndexUuid :: Maybe Text, + ismExplanationEntryPolicyId :: Maybe Text, + ismExplanationEntryEnabled :: Maybe Bool, + ismExplanationEntryEnabledTime :: Maybe Int, + ismExplanationEntryPolicySeqNo :: Maybe Int, + ismExplanationEntryPolicyPrimaryTerm :: Maybe Int, + ismExplanationEntryRolledOver :: Maybe Bool, + ismExplanationEntryIndexCreationDate :: Maybe Int, + ismExplanationEntryState :: Maybe ISMExplanationNamed, + ismExplanationEntryAction :: Maybe ISMExplanationAction, + ismExplanationEntryStep :: Maybe ISMExplanationStep, + ismExplanationEntryRetryInfo :: Maybe ISMExplanationRetryInfo, + ismExplanationEntryInfo :: Maybe ISMExplanationInfo, + ismExplanationEntryPolicy :: Maybe Value, + ismExplanationEntryValidate :: Maybe ISMExplanationValidate, + ismExplanationEntryPolicyIdSetting :: Maybe Text, + ismExplanationEntryOpendistroPolicyIdSetting :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationEntry where + parseJSON = withObject "ISMExplanationEntry" $ \v -> do + ismExplanationEntryIndex <- v .:? "index" + ismExplanationEntryIndexUuid <- v .:? "index_uuid" + ismExplanationEntryPolicyId <- v .:? "policy_id" + ismExplanationEntryEnabled <- v .:? "enabled" + ismExplanationEntryEnabledTime <- v .:? "enabled_time" + ismExplanationEntryPolicySeqNo <- v .:? "policy_seq_no" + ismExplanationEntryPolicyPrimaryTerm <- v .:? "policy_primary_term" + ismExplanationEntryRolledOver <- v .:? "rolled_over" + ismExplanationEntryIndexCreationDate <- v .:? "index_creation_date" + ismExplanationEntryState <- v .:? "state" + ismExplanationEntryAction <- v .:? "action" + ismExplanationEntryStep <- v .:? "step" + ismExplanationEntryRetryInfo <- v .:? "retry_info" + ismExplanationEntryInfo <- v .:? "info" + ismExplanationEntryPolicy <- v .:? "policy" + ismExplanationEntryValidate <- v .:? "validate" + ismExplanationEntryPolicyIdSetting <- + v .:? "index.plugins.index_state_management.policy_id" + ismExplanationEntryOpendistroPolicyIdSetting <- + v .:? "index.opendistro.index_state_management.policy_id" + return ISMExplanationEntry {..} + +instance ToJSON ISMExplanationEntry where + toJSON ISMExplanationEntry {..} = + omitNulls + [ "index" .= ismExplanationEntryIndex, + "index_uuid" .= ismExplanationEntryIndexUuid, + "policy_id" .= ismExplanationEntryPolicyId, + "enabled" .= ismExplanationEntryEnabled, + "enabled_time" .= ismExplanationEntryEnabledTime, + "policy_seq_no" .= ismExplanationEntryPolicySeqNo, + "policy_primary_term" .= ismExplanationEntryPolicyPrimaryTerm, + "rolled_over" .= ismExplanationEntryRolledOver, + "index_creation_date" .= ismExplanationEntryIndexCreationDate, + "state" .= ismExplanationEntryState, + "action" .= ismExplanationEntryAction, + "step" .= ismExplanationEntryStep, + "retry_info" .= ismExplanationEntryRetryInfo, + "info" .= ismExplanationEntryInfo, + "policy" .= ismExplanationEntryPolicy, + "validate" .= ismExplanationEntryValidate, + "index.plugins.index_state_management.policy_id" .= ismExplanationEntryPolicyIdSetting, + "index.opendistro.index_state_management.policy_id" .= ismExplanationEntryOpendistroPolicyIdSetting + ] + +-- | Response of @GET /_plugins/_ism/explain/{index}@: a map keyed by index +-- name plus an optional @total_managed_indices@ count (present when at least +-- one queried index is managed). Unknown per-index keys are ignored; the +-- dotted @policy_id@ settings are captured by 'ISMExplanationEntry'. +-- See +data ISMExplanation = ISMExplanation + { ismExplanationEntries :: Map.Map Text ISMExplanationEntry, + ismExplanationTotalManagedIndices :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanation where + parseJSON = withObject "ISMExplanation" $ \v -> do + ismExplanationTotalManagedIndices <- v .:? "total_managed_indices" + let entryPairs = + [ (AKey.toText k, val) + | (k, val) <- KM.toList v, + k /= "total_managed_indices" + ] + ismExplanationEntries <- + Map.fromList + <$> traverse + (\(k, val) -> fmap ((,) k) (parseJSON val)) + entryPairs + return ISMExplanation {..} + +instance ToJSON ISMExplanation where + toJSON ISMExplanation {..} = + Object $ + KM.fromList $ + [ (AKey.fromText k, toJSON e) + | (k, e) <- Map.toList ismExplanationEntries + ] + <> [ (AKey.fromText "total_managed_indices", toJSON n) + | Just n <- [ismExplanationTotalManagedIndices] + ] + +-- | Filter criteria for 'explainISMIndexFiltered' +-- (@POST /_plugins/_ism/explain/{index}@, "Explain index with filtering", +-- introduced in OpenSearch 2.12). Every field is optional; 'Nothing' means +-- "any value". The server returns only indexes matching /all/ specified +-- criteria. The wire body wraps this in a @filter@ key — see +-- 'ISMExplainFilterRequest'. +-- See +data ISMExplainFilter = ISMExplainFilter + { ismExplainFilterPolicyId :: Maybe Text, + ismExplainFilterState :: Maybe Text, + ismExplainFilterActionType :: Maybe Text, + ismExplainFilterFailed :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'ISMExplainFilter' with every criterion set to 'Nothing' (no filtering). +-- Encodes to @{}@, so the resulting request body is @{"filter":{}}@. +defaultISMExplainFilter :: ISMExplainFilter +defaultISMExplainFilter = + ISMExplainFilter + { ismExplainFilterPolicyId = Nothing, + ismExplainFilterState = Nothing, + ismExplainFilterActionType = Nothing, + ismExplainFilterFailed = Nothing + } + +instance ToJSON ISMExplainFilter where + toJSON ISMExplainFilter {..} = + omitNulls + [ "policy_id" .= ismExplainFilterPolicyId, + "state" .= ismExplainFilterState, + "action_type" .= ismExplainFilterActionType, + "failed" .= ismExplainFilterFailed + ] + +-- | Request body for 'explainISMIndexFiltered'. Wraps an 'ISMExplainFilter' +-- in the @filter@ key so the encoded body matches the documented +-- @{"filter": {...}}@ shape. +data ISMExplainFilterRequest = ISMExplainFilterRequest + { ismExplainFilterRequestFilter :: ISMExplainFilter + } + deriving stock (Eq, Show) + +instance ToJSON ISMExplainFilterRequest where + toJSON ISMExplainFilterRequest {..} = + object ["filter" .= ismExplainFilterRequestFilter] + +-- | A single policy entry as returned by @GET /_plugins/_ism/policies[\/{id}]@. +-- The @policy@ sub-object is the full managed-policy wrapper (with +-- @policy_id@, @schema_version@, @states@, ...) and is carried as an opaque +-- 'Value' until the typed ISM policy schema lands (tracked separately). +-- See +data ISMPolicyInfo = ISMPolicyInfo + { ismPolicyInfoId :: Text, + ismPolicyInfoVersion :: Maybe DocVersion, + ismPolicyInfoSeqNo :: Int, + ismPolicyInfoPrimaryTerm :: Int, + ismPolicyInfoPolicy :: Value + } + deriving stock (Eq, Show) + +instance FromJSON ISMPolicyInfo where + parseJSON = withObject "ISMPolicyInfo" $ \v -> do + ismPolicyInfoId <- v .: "_id" + ismPolicyInfoVersion <- v .:? "_version" + ismPolicyInfoSeqNo <- v .: "_seq_no" + ismPolicyInfoPrimaryTerm <- v .: "_primary_term" + ismPolicyInfoPolicy <- v .: "policy" + return ISMPolicyInfo {..} + +instance ToJSON ISMPolicyInfo where + toJSON ISMPolicyInfo {..} = + omitNulls + [ "_id" .= ismPolicyInfoId, + "_version" .= ismPolicyInfoVersion, + "_seq_no" .= ismPolicyInfoSeqNo, + "_primary_term" .= ismPolicyInfoPrimaryTerm, + "policy" .= ismPolicyInfoPolicy + ] + +-- | Response of @GET /_plugins/_ism/policies@ (the list variant). +-- See +data GetISMPoliciesResponse = GetISMPoliciesResponse + { getISMPoliciesResponsePolicies :: [ISMPolicyInfo] + } + deriving stock (Eq, Show) + +instance FromJSON GetISMPoliciesResponse where + parseJSON = withObject "GetISMPoliciesResponse" $ \v -> do + getISMPoliciesResponsePolicies <- v .: "policies" + return GetISMPoliciesResponse {..} + +instance ToJSON GetISMPoliciesResponse where + toJSON GetISMPoliciesResponse {..} = + object ["policies" .= getISMPoliciesResponsePolicies] + +-- | Optional filtering / pagination parameters for 'getISMPolicies'. +-- All fields are optional; see the @Get policies@ query parameters table. +data ISMPoliciesQuery = ISMPoliciesQuery + { ismPoliciesQuerySize :: Maybe Int, + ismPoliciesQueryFrom :: Maybe Int, + ismPoliciesQuerySortField :: Maybe Text, + ismPoliciesQuerySortOrder :: Maybe Text, + ismPoliciesQueryQueryString :: Maybe Text + } + deriving stock (Eq, Show) + +-- | Render an 'ISMPoliciesQuery' as the query-string pairs accepted by the +-- @GET /_plugins/_ism/policies@ endpoint. 'Nothing' fields are omitted so the +-- request only carries the parameters the caller set. +ismPoliciesQueryToPairs :: ISMPoliciesQuery -> [(Text, Maybe Text)] +ismPoliciesQueryToPairs ISMPoliciesQuery {..} = + catMaybes + [ fmap (\n -> ("size", Just (showText n))) ismPoliciesQuerySize, + fmap (\n -> ("from", Just (showText n))) ismPoliciesQueryFrom, + fmap (\t -> ("sortField", Just t)) ismPoliciesQuerySortField, + fmap (\t -> ("sortOrder", Just t)) ismPoliciesQuerySortOrder, + fmap (\t -> ("queryString", Just t)) ismPoliciesQueryQueryString + ] + +-- | Optional parameters for 'explainISMIndexWith' +-- (@GET /_plugins/_ism/explain/{index}@). All four documented query +-- parameters are modelled: +-- +-- * @show_policy@ — returns the full managed-index policy in the response. +-- * @validate_action@ — validates the cached actions in the managed index +-- metadata. +-- * @local@ — /OpenSearch only/. Whether to return local information such +-- as the managed index metadata. Default is @false@. +-- * @expand_wildcards@ — controls wildcard index expansion (@open@, +-- @closed@, @hidden@, @all@, @none@). Reuses the 'ExpandWildcards' sum +-- type shared with the search and count endpoints; the server accepts a +-- comma-separated list so we model it as a 'NonEmpty' to encode "at +-- least one". +-- +-- See +data ISMExplainOptions = ISMExplainOptions + { ismExplainOptionsShowPolicy :: Bool, + ismExplainOptionsValidateAction :: Bool, + ismExplainOptionsLocal :: Maybe Bool, + ismExplainOptionsExpandWildcards :: Maybe (NonEmpty ExpandWildcards) + } + deriving stock (Eq, Show) + +-- | 'ISMExplainOptions' with every parameter set to its no-op value +-- (@show_policy = False@, @validate_action = False@, @local = Nothing@, +-- @expand_wildcards = Nothing@). Produces no query string, so a call made +-- with this value is byte-identical to the legacy @explainISMIndex@ wire +-- shape. +defaultISMExplainOptions :: ISMExplainOptions +defaultISMExplainOptions = + ISMExplainOptions + { ismExplainOptionsShowPolicy = False, + ismExplainOptionsValidateAction = False, + ismExplainOptionsLocal = Nothing, + ismExplainOptionsExpandWildcards = Nothing + } + +-- | Render an 'ISMExplainOptions' as the query-string pairs accepted by the +-- @GET /_plugins/_ism/explain/{index}@ endpoint. 'False' bool flags and +-- 'Nothing' fields are omitted, so 'defaultISMExplainOptions' produces an +-- empty list. The order of the returned list is stable but /unspecified/ — +-- callers (including tests) should treat it as a set and not pattern-match +-- on the head. The underlying 'withQueries' is order-insensitive. +ismExplainOptionsParams :: ISMExplainOptions -> [(Text, Maybe Text)] +ismExplainOptionsParams ISMExplainOptions {..} = + catMaybes + [ if ismExplainOptionsShowPolicy + then Just ("show_policy", Just "true") + else Nothing, + if ismExplainOptionsValidateAction + then Just ("validate_action", Just "true") + else Nothing, + fmap (\b -> ("local", Just (if b then "true" else "false"))) ismExplainOptionsLocal, + fmap (\xs -> ("expand_wildcards", Just (renderExpandWildcards xs))) ismExplainOptionsExpandWildcards + ] + where + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/IndexTransforms.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/IndexTransforms.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/IndexTransforms.hs @@ -0,0 +1,837 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.IndexTransforms + ( TransformId (..), + TransformPeriodUnit (..), + transformPeriodUnitText, + TransformInterval (..), + TransformSchedule (..), + TransformGroup (..), + TermsGroup (..), + HistogramGroup (..), + DateHistogramGroup (..), + Transform (..), + TransformResponse (..), + TransformRequest (..), + TransformDocumentResponse (..), + TransformSortDirection (..), + transformSortDirectionText, + TransformsListOptions (..), + defaultTransformsListOptions, + transformsListOptionsParams, + GetTransformsResponse (..), + GetTransformsListEntry (..), + TransformExplain (..), + TransformMetadata (..), + TransformStats (..), + TransformContinuousStats (..), + PreviewTransformResponse (..), + ) +where + +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict (Map) +import Data.Vector qualified as V +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The OpenSearch Index Transforms plugin +-- () +-- materialises a target index from aggregations over a source index on a +-- schedule. A 'Transform' binds a 'transformSourceIndex' to a +-- 'transformTargetIndex' via either 'transformGroups' (terms \/ histogram +-- \/ date_histogram buckets) or 'transformAggregations' (sum \/ avg \/ +-- \/ max \/ min \/ value_count \/ scripted_metric \/ percentiles), +-- evaluated under 'transformDataSelectionQuery' (a query DSL filter on +-- the source). The plugin persists the transform under the +-- @.opensearch-ism-config@ system index (transforms are stored alongside +-- ISM policies) and returns the document-write envelope +-- (@_id@, @_version@, @_seq_no@, @_primary_term@) wrapping the +-- 'TransformResponse' under the @transform@ key. +-- +-- We split the request shape ('Transform') from the response shape +-- ('TransformResponse') so the request cannot accidentally carry +-- server-only fields, while the response still round-trips the full +-- server payload. This mirrors the 'ISMPolicyRequest' / +-- 'ISMPolicyResponse' split used for the ISM plugin and the +-- 'Detector' / 'DetectorResponse' split used by Anomaly Detection. +-- +-- The plugin is shipped with OpenSearch 1.0+; it is present (and +-- wire-compatible) on OS1, OS2 and OS3, hence this module is duplicated +-- across all three versions. +-- +-- Doc ambiguities handled here deliberately: +-- +-- * The @schedule.interval.unit@ field is documented with only +-- @"Minutes"@, @"Hours"@, and @"Days"@ in the examples. The plugin +-- source (the underlying job-scheduler) accepts more (e.g. @Seconds@, +-- @Weeks@, @Months@); we type 'TransformPeriodUnit' as a closed enum +-- with a 'TransformPeriodUnitCustom' escape hatch so future additions +-- surface as a parsed value rather than a decode failure. +-- * Only the @interval@ schedule variant is documented on the Transforms +-- page; the job-scheduler plugin also supports @cron@ and other +-- variants. 'TransformSchedule' is a sum type with a +-- 'TransformScheduleOther' escape hatch so unknown schedule variants +-- round-trip losslessly instead of failing decode. +-- * The @groups@ array entries are wrapped under a per-type key +-- (@terms@ \/ @histogram@ \/ @date_histogram@); we model this as a +-- 'TransformGroup' sum type so an entry cannot be constructed with an +-- inconsistent (wrapper, body) pair. The wrapped objects are +-- intentionally light (the documented fields plus an opaque 'Value' +-- catch-all) — future bucket options surface as the catch-all rather +-- than a parse failure. +-- * The @data_selection_query@ and @aggregations@ fields are arbitrary +-- OpenSearch query \/ aggregation DSL bodies, so both are carried as +-- opaque 'Value's (the same approach Anomaly Detection's +-- 'featureAttributeAggregationQuery' takes). +-- * The @_explain@ response is keyed by transform_id at the top level; +-- we decode it as @'Map' 'Text' 'TransformExplain'@. The whole +-- @transform_metadata@ sub-object is 'Maybe' because the plugin omits +-- it on a freshly-created transform that has not yet run. The +-- @continuous_stats@ sub-object only appears on continuous transforms, +-- so it is itself 'Maybe' inside 'TransformMetadata'. +-- * The @delete@ endpoint returns a bulk-response envelope (the +-- transform is stored as a doc in @.opensearch-ism-config@, so DELETE +-- surfaces through the bulk handler). The shared +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Bulk.BulkResponse' +-- matches that envelope byte-for-byte, so the request builder reuses +-- it rather than introducing a per-plugin wrapper. + +-- | Identifies a transform job in the +-- @\/_plugins\/_transform\/{transform_id}@ URL path. Wraps 'Text' so it +-- round-trips through JSON as a bare string but is distinct at the +-- Haskell type level. +-- See +newtype TransformId = TransformId {unTransformId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @schedule.interval.unit@ enum documented at +-- . +-- The Transforms docs enumerate @"Minutes"@, @"Hours"@, and @"Days"@ in +-- the examples; the underlying job-scheduler plugin accepts more values +-- (a 'TransformPeriodUnitCustom' escape hatch preserves them). +data TransformPeriodUnit + = TransformPeriodUnitMinutes + | TransformPeriodUnitHours + | TransformPeriodUnitDays + | TransformPeriodUnitSeconds + | TransformPeriodUnitWeeks + | TransformPeriodUnitMonths + | TransformPeriodUnitCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'TransformPeriodUnit' — the same mapping the +-- 'ToJSON' \/ 'FromJSON' instances use, exposed as plain 'Text' for +-- callers that need the wire string without going through a +-- 'Data.Aeson.Value'. +transformPeriodUnitText :: TransformPeriodUnit -> Text +transformPeriodUnitText = \case + TransformPeriodUnitMinutes -> "Minutes" + TransformPeriodUnitHours -> "Hours" + TransformPeriodUnitDays -> "Days" + TransformPeriodUnitSeconds -> "Seconds" + TransformPeriodUnitWeeks -> "Weeks" + TransformPeriodUnitMonths -> "Months" + TransformPeriodUnitCustom t -> t + +instance ToJSON TransformPeriodUnit where + toJSON = toJSON . transformPeriodUnitText + +instance FromJSON TransformPeriodUnit where + parseJSON = withText "TransformPeriodUnit" $ \case + "Minutes" -> pure TransformPeriodUnitMinutes + "Hours" -> pure TransformPeriodUnitHours + "Days" -> pure TransformPeriodUnitDays + "Seconds" -> pure TransformPeriodUnitSeconds + "Weeks" -> pure TransformPeriodUnitWeeks + "Months" -> pure TransformPeriodUnitMonths + other -> pure (TransformPeriodUnitCustom other) + +-- | The inner @{period, unit, start_time}@ object carried inside a +-- 'TransformSchedule'. @start_time@ is documented as a Unix epoch +-- (seconds); the docs page puts it under @interval.start_time@, which +-- is the only placement the encoder emits. +-- See +data TransformInterval = TransformInterval + { transformIntervalPeriod :: Int, + transformIntervalUnit :: TransformPeriodUnit, + transformIntervalStartTime :: Maybe Integer + } + deriving stock (Eq, Show) + +instance FromJSON TransformInterval where + parseJSON = withObject "TransformInterval" $ \v -> do + transformIntervalPeriod <- v .: "period" + transformIntervalUnit <- v .: "unit" + transformIntervalStartTime <- v .:? "start_time" + pure TransformInterval {..} + +instance ToJSON TransformInterval where + toJSON TransformInterval {..} = + omitNulls + [ "period" .= transformIntervalPeriod, + "unit" .= transformIntervalUnit, + "start_time" .= transformIntervalStartTime + ] + +-- | The @schedule@ object. The Transforms docs only document the +-- @interval@ variant; the underlying job-scheduler plugin also supports +-- @cron@ and others, so unknown schedule shapes parse as +-- 'TransformScheduleOther' and round-trip losslessly. +-- See +data TransformSchedule + = TransformScheduleInterval TransformInterval + | TransformScheduleOther Value + deriving stock (Eq, Show) + +instance FromJSON TransformSchedule where + parseJSON = withObject "TransformSchedule" $ \v -> + case KM.lookup "interval" v of + Just _ -> TransformScheduleInterval <$> v .: "interval" + Nothing -> pure (TransformScheduleOther (Object v)) + +instance ToJSON TransformSchedule where + toJSON = \case + TransformScheduleInterval i -> object ["interval" .= i] + TransformScheduleOther val -> val + +-- | A @terms@ group entry of the @groups@ array. +-- See +data TermsGroup = TermsGroup + { termsGroupSourceField :: Text, + termsGroupTargetField :: Maybe Text, + termsGroupOther :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON TermsGroup where + parseJSON = withObject "TermsGroup" $ \v -> do + termsGroupSourceField <- v .: "source_field" + termsGroupTargetField <- v .:? "target_field" + let deleted = deleteSeveral ["source_field", "target_field"] v + termsGroupOther = + if null deleted + then Nothing + else Just (Object deleted) + pure TermsGroup {..} + +instance ToJSON TermsGroup where + toJSON TermsGroup {..} = + mergeOther + termsGroupOther + [ "source_field" .= termsGroupSourceField, + "target_field" .= termsGroupTargetField + ] + +-- | A @histogram@ group entry of the @groups@ array. +-- See +data HistogramGroup = HistogramGroup + { histogramGroupSourceField :: Text, + histogramGroupTargetField :: Maybe Text, + histogramGroupInterval :: Maybe Scientific, + histogramGroupOther :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON HistogramGroup where + parseJSON = withObject "HistogramGroup" $ \v -> do + histogramGroupSourceField <- v .: "source_field" + histogramGroupTargetField <- v .:? "target_field" + histogramGroupInterval <- v .:? "interval" + let deleted = deleteSeveral ["source_field", "target_field", "interval"] v + histogramGroupOther = + if null deleted + then Nothing + else Just (Object deleted) + pure HistogramGroup {..} + +instance ToJSON HistogramGroup where + toJSON HistogramGroup {..} = + mergeOther + histogramGroupOther + [ "source_field" .= histogramGroupSourceField, + "target_field" .= histogramGroupTargetField, + "interval" .= histogramGroupInterval + ] + +-- | A @date_histogram@ group entry of the @groups@ array. +-- See +data DateHistogramGroup = DateHistogramGroup + { dateHistogramGroupSourceField :: Text, + dateHistogramGroupTargetField :: Maybe Text, + dateHistogramGroupInterval :: Maybe Text, + dateHistogramGroupFormat :: Maybe Text, + dateHistogramGroupTimeZone :: Maybe Text, + dateHistogramGroupOther :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON DateHistogramGroup where + parseJSON = withObject "DateHistogramGroup" $ \v -> do + dateHistogramGroupSourceField <- v .: "source_field" + dateHistogramGroupTargetField <- v .:? "target_field" + dateHistogramGroupInterval <- v .:? "interval" + dateHistogramGroupFormat <- v .:? "format" + dateHistogramGroupTimeZone <- v .:? "time_zone" + let deleted = + deleteSeveral + ["source_field", "target_field", "interval", "format", "time_zone"] + v + dateHistogramGroupOther = + if null deleted + then Nothing + else Just (Object deleted) + pure DateHistogramGroup {..} + +instance ToJSON DateHistogramGroup where + toJSON DateHistogramGroup {..} = + mergeOther + dateHistogramGroupOther + [ "source_field" .= dateHistogramGroupSourceField, + "target_field" .= dateHistogramGroupTargetField, + "interval" .= dateHistogramGroupInterval, + "format" .= dateHistogramGroupFormat, + "time_zone" .= dateHistogramGroupTimeZone + ] + +-- | One entry of the @groups@ array. The docs enumerate three wrapped +-- shapes — @{"terms": {...}}@, @{"histogram": {...}}@, +-- @{"date_histogram": {...}}@ — so the Haskell surface models this as +-- a sum type whose constructor determines the wrapper key. An unknown +-- future variant parses as 'TransformGroupOther' and round-trips +-- losslessly. +-- See +data TransformGroup + = TransformGroupTerms TermsGroup + | TransformGroupHistogram HistogramGroup + | TransformGroupDateHistogram DateHistogramGroup + | TransformGroupOther Value + deriving stock (Eq, Show) + +instance FromJSON TransformGroup where + parseJSON = withObject "TransformGroup" $ \v -> + case (KM.lookup "terms" v, KM.lookup "histogram" v, KM.lookup "date_histogram" v) of + (Just termsVal, Nothing, Nothing) -> + TransformGroupTerms <$> parseJSON termsVal + (Nothing, Just histogramVal, Nothing) -> + TransformGroupHistogram <$> parseJSON histogramVal + (Nothing, Nothing, Just dhVal) -> + TransformGroupDateHistogram <$> parseJSON dhVal + _ -> pure (TransformGroupOther (Object v)) + +instance ToJSON TransformGroup where + toJSON = \case + TransformGroupTerms g -> object ["terms" .= g] + TransformGroupHistogram g -> object ["histogram" .= g] + TransformGroupDateHistogram g -> object ["date_histogram" .= g] + TransformGroupOther val -> val + +-- $transformSchema +-- +-- The 'Transform' request body carries the user-supplied fields the +-- server needs to create or update a transform job. Server-only fields +-- (@schema_version@, @updated_at@, @enabled_at@, @roles@, +-- @transform_id@) are deliberately absent — including them would invite +-- callers to send values the server ignores or rejects. They appear on +-- the 'TransformResponse' round-trip shape. + +-- | The request body for @PUT /_plugins/_transform/{transform_id}@. +-- Required fields: @source_index@, @target_index@, +-- @data_selection_query@, @page_size@, and exactly one of @groups@ or +-- @aggregations@. Everything else is optional and omitted on the wire +-- when 'Nothing'. +-- See +data Transform = Transform + { transformEnabled :: Maybe Bool, + transformContinuous :: Maybe Bool, + transformSchedule :: TransformSchedule, + transformDescription :: Maybe Text, + transformMetadataId :: Maybe Text, + transformSourceIndex :: Text, + transformTargetIndex :: Text, + transformDataSelectionQuery :: Value, + transformPageSize :: Int, + transformGroups :: Maybe [TransformGroup], + transformAggregations :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON Transform where + parseJSON = withObject "Transform" $ \v -> do + transformEnabled <- v .:? "enabled" + transformContinuous <- v .:? "continuous" + transformSchedule <- v .: "schedule" + transformDescription <- v .:? "description" + transformMetadataId <- v .:? "metadata_id" + transformSourceIndex <- v .: "source_index" + transformTargetIndex <- v .: "target_index" + transformDataSelectionQuery <- v .: "data_selection_query" + transformPageSize <- v .: "page_size" + transformGroups <- v .:? "groups" + transformAggregations <- v .:? "aggregations" + pure Transform {..} + +instance ToJSON Transform where + toJSON Transform {..} = + omitNulls + [ "enabled" .= transformEnabled, + "continuous" .= transformContinuous, + "schedule" .= transformSchedule, + "description" .= transformDescription, + "metadata_id" .= transformMetadataId, + "source_index" .= transformSourceIndex, + "target_index" .= transformTargetIndex, + "data_selection_query" .= transformDataSelectionQuery, + "page_size" .= transformPageSize, + "groups" .= transformGroups, + "aggregations" .= transformAggregations + ] + +-- | The persisted transform shape returned in responses (the inner +-- @transform@ object of a 'TransformDocumentResponse'). Carries the +-- full 'Transform' body alongside server-injected bookkeeping fields. +-- The round-trip preserves everything the server sent, so a Get → +-- Update cycle does not lose data the caller never set. +-- See +data TransformResponse = TransformResponse + { transformResponseTransformId :: Maybe Text, + transformResponseSchemaVersion :: Maybe Int, + transformResponseContinuous :: Maybe Bool, + transformResponseSchedule :: TransformSchedule, + transformResponseMetadataId :: Maybe Text, + transformResponseUpdatedAt :: Maybe Integer, + transformResponseEnabled :: Maybe Bool, + transformResponseEnabledAt :: Maybe Integer, + transformResponseDescription :: Maybe Text, + transformResponseSourceIndex :: Text, + transformResponseDataSelectionQuery :: Value, + transformResponseTargetIndex :: Text, + transformResponseRoles :: Maybe [Text], + transformResponsePageSize :: Int, + transformResponseGroups :: Maybe [TransformGroup], + transformResponseAggregations :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON TransformResponse where + parseJSON = withObject "TransformResponse" $ \v -> do + transformResponseTransformId <- v .:? "transform_id" + transformResponseSchemaVersion <- v .:? "schema_version" + transformResponseContinuous <- v .:? "continuous" + transformResponseSchedule <- v .: "schedule" + transformResponseMetadataId <- v .:? "metadata_id" + transformResponseUpdatedAt <- v .:? "updated_at" + transformResponseEnabled <- v .:? "enabled" + transformResponseEnabledAt <- v .:? "enabled_at" + transformResponseDescription <- v .:? "description" + transformResponseSourceIndex <- v .: "source_index" + transformResponseDataSelectionQuery <- v .: "data_selection_query" + transformResponseTargetIndex <- v .: "target_index" + transformResponseRoles <- v .:? "roles" + transformResponsePageSize <- v .: "page_size" + transformResponseGroups <- v .:? "groups" + transformResponseAggregations <- v .:? "aggregations" + pure TransformResponse {..} + +instance ToJSON TransformResponse where + toJSON TransformResponse {..} = + -- We use 'object' (not 'omitNulls') here because @roles@ is + -- documented as a server-injected @[]@ (empty array) and must + -- round-trip as @[]@ — but 'omitNulls' drops empty arrays. + -- 'Nothing' fields serialise as JSON @null@, which round-trips + -- through 'FromJSON' cleanly. + object + [ "transform_id" .= transformResponseTransformId, + "schema_version" .= transformResponseSchemaVersion, + "continuous" .= transformResponseContinuous, + "schedule" .= transformResponseSchedule, + "metadata_id" .= transformResponseMetadataId, + "updated_at" .= transformResponseUpdatedAt, + "enabled" .= transformResponseEnabled, + "enabled_at" .= transformResponseEnabledAt, + "description" .= transformResponseDescription, + "source_index" .= transformResponseSourceIndex, + "data_selection_query" .= transformResponseDataSelectionQuery, + "target_index" .= transformResponseTargetIndex, + "roles" .= transformResponseRoles, + "page_size" .= transformResponsePageSize, + "groups" .= transformResponseGroups, + "aggregations" .= transformResponseAggregations + ] + +-- | Request-body wrapper for @PUT /_plugins/_transform/{transform_id}@ +-- (Create \/ Update) and @POST /_plugins/_transform/_preview@. The +-- server requires the 'Transform' to be nested under the top-level +-- @transform@ key, so this newtype encodes \/ decodes that envelope +-- rather than asking the caller to remember the wrapper at every +-- call site. +-- See +newtype TransformRequest = TransformRequest {transformRequestTransform :: Transform} + deriving stock (Eq, Show) + +instance FromJSON TransformRequest where + parseJSON = withObject "TransformRequest" $ \v -> + TransformRequest <$> v .: "transform" + +instance ToJSON TransformRequest where + toJSON TransformRequest {..} = + object ["transform" .= transformRequestTransform] + +-- | Response body of @PUT /_plugins/_transform/{transform_id}@ +-- (Create \/ Update) and @GET /_plugins/_transform/{transform_id}@ +-- (Get). The server wraps the persisted 'TransformResponse' in a +-- document-write envelope (@_id@, @_version@, @_seq_no@, +-- @_primary_term@) — the same shape OpenSearch uses for any persisted +-- document, and the same shape Anomaly Detection's +-- 'CreateDetectorResponse' uses. +-- See +data TransformDocumentResponse = TransformDocumentResponse + { transformDocumentResponseId :: Text, + transformDocumentResponseVersion :: Int, + transformDocumentResponseSeqNo :: Int, + transformDocumentResponsePrimaryTerm :: Int, + transformDocumentResponseTransform :: TransformResponse + } + deriving stock (Eq, Show) + +instance FromJSON TransformDocumentResponse where + parseJSON = withObject "TransformDocumentResponse" $ \v -> do + transformDocumentResponseId <- v .: "_id" + transformDocumentResponseVersion <- v .: "_version" + transformDocumentResponseSeqNo <- v .: "_seq_no" + transformDocumentResponsePrimaryTerm <- v .: "_primary_term" + transformDocumentResponseTransform <- v .: "transform" + pure TransformDocumentResponse {..} + +instance ToJSON TransformDocumentResponse where + toJSON TransformDocumentResponse {..} = + object + [ "_id" .= transformDocumentResponseId, + "_version" .= transformDocumentResponseVersion, + "_seq_no" .= transformDocumentResponseSeqNo, + "_primary_term" .= transformDocumentResponsePrimaryTerm, + "transform" .= transformDocumentResponseTransform + ] + +-- ========================================================================= +-- List query options: GET /_plugins/_transform +-- ========================================================================= + +-- | Sort direction for the list endpoint +-- (@GET /_plugins/_transform\/@). The plugin docs only document +-- @"ASC"@ and @"DESC"@ (uppercase, unlike most OpenSearch APIs which +-- use lowercase). Unknown values parse as +-- 'TransformSortDirectionCustom' so a future plugin release surfaces +-- as a parsed value rather than a decode failure. +-- See +data TransformSortDirection + = TransformSortDirectionAsc + | TransformSortDirectionDesc + | TransformSortDirectionCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'TransformSortDirection'. +transformSortDirectionText :: TransformSortDirection -> Text +transformSortDirectionText = \case + TransformSortDirectionAsc -> "ASC" + TransformSortDirectionDesc -> "DESC" + TransformSortDirectionCustom t -> t + +instance ToJSON TransformSortDirection where + toJSON = toJSON . transformSortDirectionText + +instance FromJSON TransformSortDirection where + parseJSON = withText "TransformSortDirection" $ \case + "ASC" -> pure TransformSortDirectionAsc + "DESC" -> pure TransformSortDirectionDesc + other -> pure (TransformSortDirectionCustom other) + +-- | Query-string parameters accepted by @GET /_plugins/_transform\/@ +-- (list all transforms). Every field is optional; +-- 'defaultTransformsListOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. +-- See +data TransformsListOptions = TransformsListOptions + { transformsListOptionsFrom :: Maybe Int, + transformsListOptionsSize :: Maybe Int, + transformsListOptionsSearch :: Maybe Text, + transformsListOptionsSortField :: Maybe Text, + transformsListOptionsSortDirection :: Maybe TransformSortDirection + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the +-- plain @GET /_plugins/_transform\/@ when passed to 'getTransforms'. +defaultTransformsListOptions :: TransformsListOptions +defaultTransformsListOptions = + TransformsListOptions + { transformsListOptionsFrom = Nothing, + transformsListOptionsSize = Nothing, + transformsListOptionsSearch = Nothing, + transformsListOptionsSortField = Nothing, + transformsListOptionsSortDirection = Nothing + } + +-- | Render a 'TransformsListOptions' to the query-string pairs accepted +-- by the list endpoint. Fields set to 'Nothing' are omitted (not +-- rendered with an empty value). +transformsListOptionsParams :: TransformsListOptions -> [(Text, Maybe Text)] +transformsListOptionsParams TransformsListOptions {..} = + catMaybes + [ ("from",) . Just . tshow <$> transformsListOptionsFrom, + ("size",) . Just . tshow <$> transformsListOptionsSize, + ("search",) . Just <$> transformsListOptionsSearch, + ("sortField",) . Just <$> transformsListOptionsSortField, + ("sortDirection",) . Just . transformSortDirectionText <$> transformsListOptionsSortDirection + ] + +-- ========================================================================= +-- List response: GET /_plugins/_transform +-- ========================================================================= + +-- | One entry in the @transforms@ array returned by +-- @GET /_plugins/_transform\/@. Structurally a subset of +-- 'TransformDocumentResponse': the same @transform@ payload under the +-- same document-write envelope, but the docs samples omit @_version@ on +-- list entries (the field is therefore 'Maybe' here). +-- See +data GetTransformsListEntry = GetTransformsListEntry + { getTransformsListEntryId :: Text, + getTransformsListEntryVersion :: Maybe Int, + getTransformsListEntrySeqNo :: Maybe Int, + getTransformsListEntryPrimaryTerm :: Maybe Int, + getTransformsListEntryTransform :: TransformResponse + } + deriving stock (Eq, Show) + +instance FromJSON GetTransformsListEntry where + parseJSON = withObject "GetTransformsListEntry" $ \v -> do + getTransformsListEntryId <- v .: "_id" + getTransformsListEntryVersion <- v .:? "_version" + getTransformsListEntrySeqNo <- v .:? "_seq_no" + getTransformsListEntryPrimaryTerm <- v .:? "_primary_term" + getTransformsListEntryTransform <- v .: "transform" + pure GetTransformsListEntry {..} + +instance ToJSON GetTransformsListEntry where + toJSON GetTransformsListEntry {..} = + omitNulls + [ "_id" .= getTransformsListEntryId, + "_version" .= getTransformsListEntryVersion, + "_seq_no" .= getTransformsListEntrySeqNo, + "_primary_term" .= getTransformsListEntryPrimaryTerm, + "transform" .= getTransformsListEntryTransform + ] + +-- | Envelope returned by @GET /_plugins/_transform\/@. The plugin +-- returns @total_transforms@ (the count of all transforms the caller +-- can see, independent of pagination) alongside the per-page +-- @transforms@ array — distinct from the standard search @hits@ +-- envelope. +-- See +data GetTransformsResponse = GetTransformsResponse + { getTransformsResponseTotalTransforms :: Int, + getTransformsResponseTransforms :: [GetTransformsListEntry] + } + deriving stock (Eq, Show) + +instance FromJSON GetTransformsResponse where + parseJSON = withObject "GetTransformsResponse" $ \v -> do + getTransformsResponseTotalTransforms <- v .: "total_transforms" + getTransformsResponseTransforms <- v .:? "transforms" .!= [] + pure GetTransformsResponse {..} + +instance ToJSON GetTransformsResponse where + toJSON GetTransformsResponse {..} = + object + [ "total_transforms" .= getTransformsResponseTotalTransforms, + "transforms" .= getTransformsResponseTransforms + ] + +-- ========================================================================= +-- Explain response: GET /_plugins/_transform/{id}/_explain +-- ========================================================================= + +-- | Per-transform statistics returned inside 'TransformMetadata'. +-- All fields are integers (counts or durations in milliseconds). +-- See +data TransformStats = TransformStats + { transformStatsPagesProcessed :: Maybe Int, + transformStatsDocumentsProcessed :: Maybe Int, + transformStatsDocumentsIndexed :: Maybe Int, + transformStatsIndexTimeInMillis :: Maybe Int, + transformStatsSearchTimeInMillis :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON TransformStats where + parseJSON = withObject "TransformStats" $ \v -> do + transformStatsPagesProcessed <- v .:? "pages_processed" + transformStatsDocumentsProcessed <- v .:? "documents_processed" + transformStatsDocumentsIndexed <- v .:? "documents_indexed" + transformStatsIndexTimeInMillis <- v .:? "index_time_in_millis" + transformStatsSearchTimeInMillis <- v .:? "search_time_in_millis" + pure TransformStats {..} + +instance ToJSON TransformStats where + toJSON TransformStats {..} = + omitNulls + [ "pages_processed" .= transformStatsPagesProcessed, + "documents_processed" .= transformStatsDocumentsProcessed, + "documents_indexed" .= transformStatsDocumentsIndexed, + "index_time_in_millis" .= transformStatsIndexTimeInMillis, + "search_time_in_millis" .= transformStatsSearchTimeInMillis + ] + +-- | Continuous-transform runtime state, only present on transforms +-- where 'transformContinuous' is 'True'. @last_timestamp@ is the +-- epoch-ms of the most recently processed source document; +-- @documents_behind@ maps source index names to the count of source +-- documents not yet reflected in the target. +-- See +data TransformContinuousStats = TransformContinuousStats + { transformContinuousStatsLastTimestamp :: Maybe Integer, + transformContinuousStatsDocumentsBehind :: Maybe (Map Text Int) + } + deriving stock (Eq, Show) + +instance FromJSON TransformContinuousStats where + parseJSON = withObject "TransformContinuousStats" $ \v -> do + transformContinuousStatsLastTimestamp <- v .:? "last_timestamp" + transformContinuousStatsDocumentsBehind <- v .:? "documents_behind" + pure TransformContinuousStats {..} + +instance ToJSON TransformContinuousStats where + toJSON TransformContinuousStats {..} = + omitNulls + [ "last_timestamp" .= transformContinuousStatsLastTimestamp, + "documents_behind" .= transformContinuousStatsDocumentsBehind + ] + +-- | The @transform_metadata@ sub-object of an 'TransformExplain'. +-- @status@ is a free-form 'Text' (the docs example shows @"finished"@; +-- other states like @"failed"@, @"started"@ surface without a parse +-- failure). @failure_reason@ is @null@ on success — the docs literally +-- show the JSON string @"null"@, so we keep it as 'Maybe' 'Text' and +-- rely on aeson to decode a real @null@ as 'Nothing'. +-- See +data TransformMetadata = TransformMetadata + { transformMetadataContinuousStats :: Maybe TransformContinuousStats, + transformMetadataTransformId :: Maybe Text, + transformMetadataLastUpdatedAt :: Maybe Integer, + transformMetadataStatus :: Maybe Text, + transformMetadataFailureReason :: Maybe Text, + transformMetadataStats :: Maybe TransformStats + } + deriving stock (Eq, Show) + +instance FromJSON TransformMetadata where + parseJSON = withObject "TransformMetadata" $ \v -> do + transformMetadataContinuousStats <- v .:? "continuous_stats" + transformMetadataTransformId <- v .:? "transform_id" + transformMetadataLastUpdatedAt <- v .:? "last_updated_at" + transformMetadataStatus <- v .:? "status" + transformMetadataFailureReason <- v .:? "failure_reason" + transformMetadataStats <- v .:? "stats" + pure TransformMetadata {..} + +instance ToJSON TransformMetadata where + toJSON TransformMetadata {..} = + omitNulls + [ "continuous_stats" .= transformMetadataContinuousStats, + "transform_id" .= transformMetadataTransformId, + "last_updated_at" .= transformMetadataLastUpdatedAt, + "status" .= transformMetadataStatus, + "failure_reason" .= transformMetadataFailureReason, + "stats" .= transformMetadataStats + ] + +-- | One value of the @_explain@ response. The plugin returns a top-level +-- object keyed by transform_id whose value combines the @metadata_id@ of +-- the transform's metadata document with the @transform_metadata@ +-- sub-object. The metadata sub-object is 'Maybe' because the plugin +-- omits it on a freshly-created transform that has not yet run. +-- See +data TransformExplain = TransformExplain + { transformExplainMetadataId :: Maybe Text, + transformExplainTransformMetadata :: Maybe TransformMetadata + } + deriving stock (Eq, Show) + +instance FromJSON TransformExplain where + parseJSON = withObject "TransformExplain" $ \v -> do + transformExplainMetadataId <- v .:? "metadata_id" + transformExplainTransformMetadata <- v .:? "transform_metadata" + pure TransformExplain {..} + +instance ToJSON TransformExplain where + toJSON TransformExplain {..} = + omitNulls + [ "metadata_id" .= transformExplainMetadataId, + "transform_metadata" .= transformExplainTransformMetadata + ] + +-- ========================================================================= +-- Preview: POST /_plugins/_transform/_preview +-- ========================================================================= + +-- | Response body of @POST /_plugins/_transform/_preview@. Each entry +-- of @documents@ is a transformed row whose keys are derived from the +-- caller's @groups[].target_field@ names plus @aggregations@ keys. The +-- shape is wholly caller-driven, so the entries are carried as opaque +-- 'Value's. +-- See +newtype PreviewTransformResponse = PreviewTransformResponse + { previewTransformResponseDocuments :: [Value] + } + deriving stock (Eq, Show) + +instance FromJSON PreviewTransformResponse where + parseJSON = withObject "PreviewTransformResponse" $ \v -> do + previewTransformResponseDocuments <- v .:? "documents" .!= [] + pure PreviewTransformResponse {..} + +instance ToJSON PreviewTransformResponse where + toJSON PreviewTransformResponse {..} = + object ["documents" .= previewTransformResponseDocuments] + +-- ========================================================================= +-- Helpers +-- ========================================================================= + +-- | Render the known @(Key, Value)@ pairs of a group entry (omitting +-- 'Nothing' fields), then merge any surviving keys from the +-- per-group 'other' catch-all back in so an unknown forward-compat +-- field round-trips at its original key rather than under a +-- synthesised @other@ wrapper. Known fields take precedence over the +-- catch-all on key collision (a caller hand-building both sides +-- should not be able to end up with two values for one wire key). +-- 'Nothing' known fields are filtered out before the merge so they +-- don't leak as explicit @null@s alongside the catch-all payload +-- (mirroring 'omitNulls' semantics). +mergeOther :: Maybe Value -> [(Key, Value)] -> Value +mergeOther mOther knownPairs = + case mOther of + Nothing -> omitNulls knownPairs + Just (Object otherKm) -> + let knownKm = KM.fromList (filter (not . isNullValue . snd) knownPairs) + in Object (KM.union knownKm otherKm) + Just _otherVal -> + -- An 'other' catch-all that is not an Object is unusual (the + -- decoder only ever produces @Object v@). Emit the known fields + -- (with nulls dropped) and drop the exotic 'other' value + -- rather than guessing how to merge them. + omitNulls knownPairs + +-- | Predicate matching 'omitNulls''s @notNull@: 'Null' and the empty +-- array are filtered; everything else survives. +isNullValue :: Value -> Bool +isNullValue Null = True +isNullValue (Array a) = V.null a +isNullValue _ = False diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/KnnModel.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/KnnModel.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/KnnModel.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.KnnModel + ( KnnModelState (..), + KnnModel (..), + KnnDeleteModelResponse (..), + ) +where + +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Knn (OpenSearchKnnEngine) + +-- $schema +-- +-- The k-NN plugin Get Model API +-- (, +-- @GET /_plugins/_knn/models/{model_id}@) returns a bare object describing a +-- trained model. Some native library index configurations (notably FAISS IVF +-- and HNSW with PQ) require a training step before indexing can begin; the +-- output of training is serialized into the @.opensearch-knn-models@ system +-- index and read back by this endpoint. +-- +-- Every field except @model_id@ is modelled as 'Maybe' for two reasons. First, +-- the @model_blob@ field is deliberately large (a base64 serialization of the +-- trained graph) and is routinely excluded with @?filter_path@ or +-- @_source_excludes=model_blob@, so a strict parse would reject the common +-- metadata-only read. Second, the same @filter_path@ mechanism lets a caller +-- request any subset of fields, so the parser must tolerate arbitrary +-- omissions (same defensive shape as 'ModelInfo'). +-- +-- The @engine@ field reuses the shared 'OpenSearchKnnEngine' type (also used +-- by index mappings and the search clause), so the wire vocabulary +-- (@faiss@, @nmslib@, @lucene@) is defined in one place. + +-- | The lifecycle state of a k-NN model, as reported by the @state@ field of +-- 'KnnModel'. The k-NN plugin documents exactly three values; an unknown +-- value parse-fails so a future plugin release surfaces as a deliberate +-- error rather than a silent drop. +data KnnModelState + = KnnModelStateCreated + | KnnModelStateFailed + | KnnModelStateTraining + deriving stock (Eq, Show) + +instance ToJSON KnnModelState where + toJSON = \case + KnnModelStateCreated -> "created" + KnnModelStateFailed -> "failed" + KnnModelStateTraining -> "training" + +instance FromJSON KnnModelState where + parseJSON = withText "KnnModelState" $ \case + "created" -> pure KnnModelStateCreated + "failed" -> pure KnnModelStateFailed + "training" -> pure KnnModelStateTraining + other -> fail ("Unknown KnnModelState: " <> T.unpack other) + +-- | Response of @GET /_plugins/_knn/models/{model_id}@. The body is a bare +-- object (no envelope); the server returns every metadata field it has. See +-- the module docs for why every field except @model_id@ is 'Maybe'. +-- +-- The @timestamp@ is the server-formatted creation time (e.g. +-- @2021-11-15T18:45:07.505369036Z@); it is kept as 'Text' rather than parsed +-- to a time type so the client does not couple to the plugin's sub-second +-- precision. +data KnnModel = KnnModel + { knnModelModelId :: Text, + knnModelModelBlob :: Maybe Text, + knnModelState :: Maybe KnnModelState, + knnModelTimestamp :: Maybe Text, + knnModelDescription :: Maybe Text, + knnModelError :: Maybe Text, + knnModelSpaceType :: Maybe Text, + knnModelDimension :: Maybe Int, + knnModelEngine :: Maybe OpenSearchKnnEngine + } + deriving stock (Eq, Show) + +instance FromJSON KnnModel where + parseJSON = withObject "KnnModel" $ \v -> do + knnModelModelId <- v .: "model_id" + knnModelModelBlob <- v .:? "model_blob" + knnModelState <- v .:? "state" + knnModelTimestamp <- v .:? "timestamp" + knnModelDescription <- v .:? "description" + knnModelError <- v .:? "error" + knnModelSpaceType <- v .:? "space_type" + knnModelDimension <- v .:? "dimension" + knnModelEngine <- v .:? "engine" + pure KnnModel {..} + +instance ToJSON KnnModel where + toJSON KnnModel {..} = + omitNulls + [ "model_id" .= knnModelModelId, + "model_blob" .= knnModelModelBlob, + "state" .= knnModelState, + "timestamp" .= knnModelTimestamp, + "description" .= knnModelDescription, + "error" .= knnModelError, + "space_type" .= knnModelSpaceType, + "dimension" .= knnModelDimension, + "engine" .= knnModelEngine + ] + +-- | Response of @DELETE /_plugins/_knn/models/{model_id}@. Per the k-NN +-- plugin's @DeleteModelResponse@, the body is a bare object with two +-- fields: @model_id@ (echoing the id passed in the path) and @result@ +-- (always @"deleted"@ for a successful delete). Note that this is NOT the +-- standard 'Acknowledged' envelope — the k-NN plugin returns a richer +-- response than the typical cluster-level ack, mirroring the shape of +-- 'KnnTrainResponse' rather than 'Acknowledged'. +-- +-- The @result@ field is kept as 'Text' rather than a closed enum: the +-- plugin only emits @"deleted"@ today, but a future version could add +-- @"not_found"@ or similar, and an enum would force a parse failure in +-- that case. +-- +-- /Note on the public docs:/ the k-NN API docs page +-- () +-- shows the response as @{"model_id": ..., "acknowledged": true}@, which is +-- incorrect. The authoritative shape is the one emitted by the plugin's +-- @DeleteModelResponse@ serializer +-- (), +-- i.e. @model_id@ + @result@. The type below follows the serializer, not the +-- docs. +data KnnDeleteModelResponse = KnnDeleteModelResponse + { knnDeleteModelResponseModelId :: Text, + knnDeleteModelResponseResult :: Text + } + deriving stock (Eq, Show) + +instance FromJSON KnnDeleteModelResponse where + parseJSON = withObject "KnnDeleteModelResponse" $ \v -> do + knnDeleteModelResponseModelId <- v .: "model_id" + knnDeleteModelResponseResult <- v .: "result" + pure KnnDeleteModelResponse {..} + +instance ToJSON KnnDeleteModelResponse where + toJSON KnnDeleteModelResponse {..} = + object + [ "model_id" .= knnDeleteModelResponseModelId, + "result" .= knnDeleteModelResponseResult + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/KnnStats.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/KnnStats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/KnnStats.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.KnnStats + ( KnnNodeId (..), + KnnStatName (..), + KnnStats (..), + ) +where + +import Data.Map.Strict qualified as Map +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- @ +-- { +-- "": , +-- ..., +-- "nodes": { "<22-char-node-id>": { "": , ... } } +-- } +-- @ +-- +-- The @GET /_plugins/_knn/stats@ endpoint +-- () +-- returns both cluster-level statistics (a single value for the entire +-- cluster, e.g. @total_load_time@, @hit_count@, @circuit_breaker_triggered@) +-- and node-level statistics (a single value per node, nested under the +-- literal @nodes@ key keyed by opaque node ID). The same stat name can +-- appear either as a cluster-level top-level key or nested under a +-- per-node entry, and the stat-name set is large and version-gated by the +-- plugin — each stat carries the OpenSearch version that introduced it. +-- Modelling every stat as a typed Haskell record field would lock the +-- client to one plugin version and require churn on every release, so the +-- body is kept as a flat 'Map.Map Text Value' — callers get a typed +-- envelope and navigate to the per-node map (via @'Map.lookup' \"nodes\"@) +-- or to any individual cluster stat with the aeson combinators they +-- already use elsewhere (same shape as +-- 'Database.Bloodhound.OpenSearch2.Types.MLStats'). + +-- | A node ID for the k-NN plugin's +-- @\/_plugins\/_knn\/{nodeId}\/stats@ path segment. OpenSearch uses +-- 22-character opaque node IDs (the same identifiers returned by +-- @GET \/_nodes@); we wrap 'Text' so the value round-trips through JSON as a +-- bare string but is distinct from 'NodeName' \/ 'FullNodeId' \/ 'NeuralNodeId' +-- at the type level. +newtype KnnNodeId = KnnNodeId {unKnnNodeId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A stat name filter for the +-- @\/_plugins\/_knn\/stats\/{stat}@ path segment. Each value matches one of +-- the plugin's documented @StatName@ constants (@hit_count@, @miss_count@, +-- @knn_query_cache_size@, ...); the full set changes across OpenSearch +-- releases, so this is intentionally a thin 'Text' newtype rather than a +-- closed enum. +newtype KnnStatName = KnnStatName {unKnnStatName :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Response of @GET /_plugins/_knn/stats@. The body is a JSON object whose +-- top-level keys are either cluster-level stat names (mapping to scalars) or +-- the literal key @nodes@ (mapping to a per-node map keyed by opaque node +-- ID); see the module docs for why the entries are kept as aeson 'Value's +-- rather than modelled per-stat. The 'Map.Map' round-trips a flat JSON +-- object via its aeson instances, so no custom 'ToJSON' \/ 'FromJSON' is +-- needed. To reach per-node stats, decode the @nodes@ value, e.g.: +-- +-- @ +-- case 'Map.lookup' \"nodes\" (knnStatsEntries stats) of +-- 'Just' ('Object' m) -> ... navigate m with aeson KeyMap combinators ... +-- _ -> 'Nothing' +-- @ +newtype KnnStats = KnnStats {knnStatsEntries :: Map.Map Text Value} + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/KnnTrain.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/KnnTrain.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/KnnTrain.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.KnnTrain + ( KnnTrainingMethod (..), + KnnTrainingRequest (..), + KnnTrainResponse (..), + ) +where + +import Data.Aeson +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Knn (OpenSearchKnnEngine) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( FieldName, + IndexName, + ) + +-- $schema +-- +-- The k-NN plugin Train Model API +-- (, +-- @POST /_plugins/_knn/models/{model_id}/_train@) trains a native library +-- model (FAISS IVF, IVF with PQ encoder, ...) from the vectors stored in a +-- @knn_vector@ field of a training index. Only methods that require training +-- are eligible; HNSW/Lucene do not. Training is asynchronous: the request +-- returns as soon as training is scheduled, carrying only the @model_id@; +-- the caller polls 'Database.Bloodhound.OpenSearch2.Client.getKnnModel' to +-- observe the @state@ transition from @training@ to @created@ (success) or +-- @failed@ (with the @error@ field populated). +-- +-- The request body is a flat object with four required fields +-- (@training_index@, @training_field@, @dimension@, @method@) and four +-- optional fields (@space_type@, @max_training_vector_count@, @search_size@, +-- @description@). The @method@ sub-object reuses the standard k-NN method +-- schema (@name@, @engine@, @space_type@, @parameters@); its @parameters@ +-- are deeply nested and engine-specific (e.g. @nlist@, an @encoder@ with +-- its own @parameters@), so they are kept as an opaque aeson 'Value' on the +-- Haskell side — the same passthrough strategy used for +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Knn.KnnInnerHits' and +-- @registerModelConnector@. + +-- | The @method@ sub-object of 'KnnTrainingRequest'. Names the training +-- algorithm and its native engine; @parameters@ carries the deeply nested +-- engine-specific knobs (e.g. @{"nlist": 128, "encoder": {...}}@) and is +-- therefore kept as an opaque 'Value'. The @space_type@ may be set here or +-- at the top level of 'KnnTrainingRequest'; the two are alternative +-- locations for the same field. +data KnnTrainingMethod = KnnTrainingMethod + { knnTrainingMethodName :: Text, + knnTrainingMethodEngine :: OpenSearchKnnEngine, + knnTrainingMethodSpaceType :: Maybe Text, + knnTrainingMethodParameters :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON KnnTrainingMethod where + parseJSON = withObject "KnnTrainingMethod" $ \v -> do + knnTrainingMethodName <- v .: "name" + knnTrainingMethodEngine <- v .: "engine" + knnTrainingMethodSpaceType <- v .:? "space_type" + knnTrainingMethodParameters <- v .:? "parameters" + pure KnnTrainingMethod {..} + +instance ToJSON KnnTrainingMethod where + toJSON KnnTrainingMethod {..} = + omitNulls + [ "name" .= knnTrainingMethodName, + "engine" .= knnTrainingMethodEngine, + "space_type" .= knnTrainingMethodSpaceType, + "parameters" .= knnTrainingMethodParameters + ] + +-- | Request body for @POST /_plugins/_knn/models/{model_id}/_train@. The +-- first four fields are required by the plugin and serialized unconditionally; +-- the remaining four are 'Maybe' and omitted by 'omitNulls' when 'Nothing'. +data KnnTrainingRequest = KnnTrainingRequest + { knnTrainingRequestIndex :: IndexName, + knnTrainingRequestField :: FieldName, + knnTrainingRequestDimension :: Int, + knnTrainingRequestMethod :: KnnTrainingMethod, + knnTrainingRequestSpaceType :: Maybe Text, + knnTrainingRequestMaxTrainingVectorCount :: Maybe Int, + knnTrainingRequestSearchSize :: Maybe Int, + knnTrainingRequestDescription :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON KnnTrainingRequest where + parseJSON = withObject "KnnTrainingRequest" $ \v -> do + knnTrainingRequestIndex <- v .: "training_index" + knnTrainingRequestField <- v .: "training_field" + knnTrainingRequestDimension <- v .: "dimension" + knnTrainingRequestMethod <- v .: "method" + knnTrainingRequestSpaceType <- v .:? "space_type" + knnTrainingRequestMaxTrainingVectorCount <- v .:? "max_training_vector_count" + knnTrainingRequestSearchSize <- v .:? "search_size" + knnTrainingRequestDescription <- v .:? "description" + pure KnnTrainingRequest {..} + +instance ToJSON KnnTrainingRequest where + toJSON KnnTrainingRequest {..} = + omitNulls + [ "training_index" .= knnTrainingRequestIndex, + "training_field" .= knnTrainingRequestField, + "dimension" .= knnTrainingRequestDimension, + "method" .= knnTrainingRequestMethod, + "space_type" .= knnTrainingRequestSpaceType, + "max_training_vector_count" .= knnTrainingRequestMaxTrainingVectorCount, + "search_size" .= knnTrainingRequestSearchSize, + "description" .= knnTrainingRequestDescription + ] + +-- | Response of @POST /_plugins/_knn/models/{model_id}/_train@. The body is +-- a bare object echoing the model id under which training was scheduled. +-- The field is the only one the endpoint ever returns; to observe training +-- progress, poll @GET /_plugins/_knn/models/{model_id}@ (decoded as +-- 'Database.Bloodhound.Internal.Versions.OpenSearch2.Types.KnnModel.KnnModel'). +newtype KnnTrainResponse = KnnTrainResponse + { knnTrainResponseModelId :: Text + } + deriving stock (Eq, Show) + +instance FromJSON KnnTrainResponse where + parseJSON = withObject "KnnTrainResponse" $ \v -> + KnnTrainResponse <$> v .: "model_id" + +instance ToJSON KnnTrainResponse where + toJSON KnnTrainResponse {..} = + object ["model_id" .= knnTrainResponseModelId] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLAgent.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLAgent.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLAgent.hs @@ -0,0 +1,641 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLAgent + ( AgentId (..), + AgentType (..), + LlmConfig (..), + MemoryConfig (..), + ToolConfig (..), + ToolInlineConfig (..), + RegisterAgentRequest (..), + RegisterAgentResponse (..), + ExecuteAgentRequest (..), + ExecuteAgentResponse (..), + InferenceResult (..), + ExecuteOutput (..), + AgentInfo (..), + AgentShards (..), + AgentTotal (..), + AgentTotalRelation (..), + AgentHit (..), + AgentSearchResponse (..), + emptyAgentSearchResponse, + ) +where + +import Data.Aeson.KeyMap qualified as KM +import Data.Int (Int64) +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The ML Commons agent APIs (see +-- ) +-- cover agentic orchestration on top of deployed models: an agent binds a +-- large-language model (or a routed population of sub-agents and tools) +-- behind a registered @agent_id@ that the Conversational / Agentic APIs +-- invoke. +-- +-- Unlike the model register endpoint, agent registration is +-- /synchronous/: the POST persists a single config document in the +-- @.plugins-ml-agent@ system index and returns +-- @{"agent_id": "..."}@ directly — no @task_id@ to poll. The response is +-- therefore modelled here as 'RegisterAgentResponse', not 'MLTaskAck'. +-- +-- The agent request body is intentionally permissive +-- ('RegisterAgentRequest'): the four documented agent shapes (flow, +-- conversation, router\/coordinator, template) reuse the same fields in +-- different combinations, and the plugin adds new tool @type@s across +-- releases, so 'rarLlm' \/ 'rarTools' \/ 'rarParameters' carry the +-- open-ended parts as structured-but-tolerant records or opaque 'Value's +-- rather than a closed sum. + +-- | An agent ID for the @\/_plugins\/_ml\/agents\/{agent_id}@ path segment +-- and the @agent_id@ field returned by register. The value is assigned by +-- the server. Wrapped 'Text' so it round-trips as a bare JSON string but +-- is distinct from 'ModelId' at the type level. +newtype AgentId = AgentId {unAgentId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The agent kind, as required by the @type@ field of +-- 'RegisterAgentRequest'. The spec-documented values +-- () +-- are 'AgentTypeFlow', 'AgentTypeConversational', +-- 'AgentTypeConversationalFlow' and 'AgentTypePlanExecuteAndReflect'. +-- 'AgentTypeRouter', 'AgentTypeCoordinator', 'AgentTypeTemplate' and +-- 'AgentTypeManual' cover the historically documented agent kinds that +-- older OpenSearch 2.x releases accept. Any other value decodes to +-- 'AgentTypeOther' rather than failing, so a future plugin release +-- adding a new kind (or a cluster storing the legacy misspelling +-- @\"conversation\"@) round-trips instead of throwing — matching the +-- 'AgentTotalRelation' precedent. +data AgentType + = AgentTypeFlow + | AgentTypeConversational + | AgentTypeConversationalFlow + | AgentTypePlanExecuteAndReflect + | AgentTypeRouter + | AgentTypeCoordinator + | AgentTypeTemplate + | AgentTypeManual + | AgentTypeOther Text + deriving stock (Eq, Show) + +agentTypeText :: AgentType -> Text +agentTypeText = \case + AgentTypeFlow -> "flow" + AgentTypeConversational -> "conversational" + AgentTypeConversationalFlow -> "conversational_flow" + AgentTypePlanExecuteAndReflect -> "plan_execute_and_reflect" + AgentTypeRouter -> "router" + AgentTypeCoordinator -> "coordinator" + AgentTypeTemplate -> "template" + AgentTypeManual -> "manual" + AgentTypeOther t -> t + +instance ToJSON AgentType where + toJSON = toJSON . agentTypeText + +instance FromJSON AgentType where + parseJSON = withText "AgentType" $ \t -> + pure $ + case t of + "flow" -> AgentTypeFlow + "conversational" -> AgentTypeConversational + "conversational_flow" -> AgentTypeConversationalFlow + "plan_execute_and_reflect" -> AgentTypePlanExecuteAndReflect + "router" -> AgentTypeRouter + "coordinator" -> AgentTypeCoordinator + "template" -> AgentTypeTemplate + "manual" -> AgentTypeManual + other -> AgentTypeOther other + +-- | The @llm@ binding for a flow or conversation agent. @model_id@ must +-- reference a deployed model (or a remote connector) registered via +-- @POST /_plugins/_ml/models/_register@; @parameters@ is the opaque +-- default parameter map forwarded to the model on every call (e.g. +-- @temperature@, @context_size@) — typed as 'Value' because the schema is +-- model-defined and heterogeneous across algorithms. +data LlmConfig = LlmConfig + { llmConfigModelId :: Text, + llmConfigParameters :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON LlmConfig where + parseJSON = withObject "LlmConfig" $ \v -> do + llmConfigModelId <- v .: "model_id" + llmConfigParameters <- v .:? "parameters" + pure LlmConfig {..} + +instance ToJSON LlmConfig where + toJSON LlmConfig {..} = + omitNulls + [ "model_id" .= llmConfigModelId, + "parameters" .= llmConfigParameters + ] + +-- | The @memory@ binding for a conversation agent. @type@ is currently +-- the only documented discriminator (value @conversation@); the remaining +-- configuration (e.g. @session_max_size@) is forwarded as an opaque +-- 'Value' pending wider plugin coverage. +data MemoryConfig = MemoryConfig + { memoryConfigType :: Text, + memoryConfigParameters :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON MemoryConfig where + parseJSON = withObject "MemoryConfig" $ \v -> do + memoryConfigType <- v .: "type" + memoryConfigParameters <- v .:? "parameters" + pure MemoryConfig {..} + +instance ToJSON MemoryConfig where + toJSON MemoryConfig {..} = + omitNulls + [ "type" .= memoryConfigType, + "parameters" .= memoryConfigParameters + ] + +-- | A single @tools@ entry. The ML Commons API accepts two wire shapes +-- for each element: a bare tool @type@ string (e.g. +-- @\"CatIndexTool\"@), or an inline object that adds per-invocation +-- @parameters@ and an optional @description@. Both round-trip through +-- this sum type so callers can use the shorthand for parameterless tools +-- and the full record for configured ones. +data ToolConfig + = ToolConfigNamed Text + | ToolConfigInline ToolInlineConfig + deriving stock (Eq, Show) + +instance FromJSON ToolConfig where + parseJSON = \case + String t -> pure (ToolConfigNamed t) + o@(Object _) -> ToolConfigInline <$> parseJSON o + other -> typeMismatch "ToolConfig (string or object)" other + +instance ToJSON ToolConfig where + toJSON = \case + ToolConfigNamed t -> toJSON t + ToolConfigInline c -> toJSON c + +-- | The object form of a 'ToolConfig' entry. @type@ is the tool kind +-- (e.g. @VectorDBTool@, @AgentTool@, @CatIndexTool@); @parameters@ is the +-- opaque default parameter map (typed as 'Value' because tool parameters +-- are plugin-defined and heterogeneous); @description@ is the optional +-- human-readable note surfaced in trace output. +data ToolInlineConfig = ToolInlineConfig + { toolInlineConfigType :: Text, + toolInlineConfigParameters :: Maybe Value, + toolInlineConfigDescription :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ToolInlineConfig where + parseJSON = withObject "ToolInlineConfig" $ \v -> do + toolInlineConfigType <- v .: "type" + toolInlineConfigParameters <- v .:? "parameters" + toolInlineConfigDescription <- v .:? "description" + pure ToolInlineConfig {..} + +instance ToJSON ToolInlineConfig where + toJSON ToolInlineConfig {..} = + omitNulls + [ "type" .= toolInlineConfigType, + "parameters" .= toolInlineConfigParameters, + "description" .= toolInlineConfigDescription + ] + +-- | Request body for @POST /_plugins/_ml/agents/_register@. @name@ and +-- @type@ are required; every other field is conditionally present +-- depending on the agent kind (conversation agents carry @llm@ and +-- optionally @memory@; router\/coordinator agents carry @tools@; +-- template agents carry @app_type@). The request is sent verbatim; +-- OpenSearch validates the combination and returns HTTP 400 for +-- nonsensical request shapes (e.g. a @conversation@ agent with no +-- @llm@). +data RegisterAgentRequest = RegisterAgentRequest + { registerAgentName :: Text, + registerAgentType :: AgentType, + registerAgentDescription :: Maybe Text, + registerAgentLlm :: Maybe LlmConfig, + registerAgentTools :: Maybe [ToolConfig], + registerAgentParameters :: Maybe Value, + registerAgentMemory :: Maybe MemoryConfig, + registerAgentAppType :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RegisterAgentRequest where + parseJSON = withObject "RegisterAgentRequest" $ \v -> do + registerAgentName <- v .: "name" + registerAgentType <- v .: "type" + registerAgentDescription <- v .:? "description" + registerAgentLlm <- v .:? "llm" + registerAgentTools <- v .:? "tools" + registerAgentParameters <- v .:? "parameters" + registerAgentMemory <- v .:? "memory" + registerAgentAppType <- v .:? "app_type" + pure RegisterAgentRequest {..} + +instance ToJSON RegisterAgentRequest where + toJSON RegisterAgentRequest {..} = + omitNulls + [ "name" .= registerAgentName, + "type" .= registerAgentType, + "description" .= registerAgentDescription, + "llm" .= registerAgentLlm, + "tools" .= registerAgentTools, + "parameters" .= registerAgentParameters, + "memory" .= registerAgentMemory, + "app_type" .= registerAgentAppType + ] + +-- | Response of @POST /_plugins/_ml/agents/_register@. The body is a bare +-- object carrying the server-assigned @agent_id@ of the newly +-- registered agent. Registration is synchronous, so — unlike +-- 'MLTaskAck' — there is no @task_id@ to poll: the agent is callable +-- immediately (subject to its bound model being deployed). +newtype RegisterAgentResponse = RegisterAgentResponse + { registerAgentResponseAgentId :: AgentId + } + deriving stock (Eq, Show) + +instance FromJSON RegisterAgentResponse where + parseJSON = withObject "RegisterAgentResponse" $ \v -> do + registerAgentResponseAgentId <- v .: "agent_id" + pure RegisterAgentResponse {..} + +instance ToJSON RegisterAgentResponse where + toJSON (RegisterAgentResponse agentId) = + object ["agent_id" .= agentId] + +-- | Request body for @POST /_plugins/_ml/agents/{agent_id}/_execute@ +-- (the Execute Agent API, introduced in OpenSearch 2.13 — available on +-- OpenSearch 2.x). The body is intentionally permissive: @parameters@ +-- is an opaque 'Value' map (the regular-registration method reads keys +-- like @question@, @verbose@, @memory_id@ — the set grows across +-- plugin releases and varies by agent kind), and @input@ is the +-- unified-registration entry point whose wire shape is polymorphic (a +-- plain 'String' for text, an 'Array' of content blocks for +-- multimodal, or an 'Array' of message objects for conversations). +-- Carrying both as 'Value' — rather than a closed sum — keeps the type +-- forward-compatible and matches the precedent set by 'predict' and +-- 'searchAgents'. +-- +-- Both fields are optional: a bare @{}@ body is a legal execute +-- request for an agent whose configuration supplies defaults. +-- 'omitNulls' on encode means an unset field is omitted rather than +-- sent as @null@. +data ExecuteAgentRequest = ExecuteAgentRequest + { executeAgentParameters :: Maybe Value, + executeAgentInput :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON ExecuteAgentRequest where + parseJSON = withObject "ExecuteAgentRequest" $ \v -> do + executeAgentParameters <- v .:? "parameters" + executeAgentInput <- v .:? "input" + pure ExecuteAgentRequest {..} + +instance ToJSON ExecuteAgentRequest where + toJSON ExecuteAgentRequest {..} = + omitNulls + [ "parameters" .= executeAgentParameters, + "input" .= executeAgentInput + ] + +-- | Response of @POST /_plugins/_ml/agents/{agent_id}/_execute@. The +-- body is the @inference_results@ array; each element carries an +-- @output@ list whose entries are discriminated by their @name@ field +-- (@response@, @memory_id@, @parent_interaction_id@, @token_usage@). +-- Each output carries /either/ a @result@ (a bare string, present for +-- the @response@\/@memory_id@\/@parent_interaction_id@ names) /or/ a +-- @dataAsMap@ (a structured object, present for the @response@ name on +-- @conversational_v2@ agents and for @token_usage@). The two payload +-- shapes are kept as 'Maybe' on a single record (rather than a sum +-- type) so an unknown @name@ with either shape decodes cleanly — +-- matching the 'AgentInfo' forward-compatibility precedent. +newtype ExecuteAgentResponse = ExecuteAgentResponse + { executeAgentInferenceResults :: [InferenceResult] + } + deriving stock (Eq, Show) + +instance FromJSON ExecuteAgentResponse where + parseJSON = withObject "ExecuteAgentResponse" $ \v -> do + executeAgentInferenceResults <- v .:? "inference_results" .!= [] + pure ExecuteAgentResponse {..} + +instance ToJSON ExecuteAgentResponse where + toJSON ExecuteAgentResponse {..} = + object ["inference_results" .= executeAgentInferenceResults] + +-- | A single element of @inference_results[]@. +newtype InferenceResult = InferenceResult + { inferenceResultOutput :: [ExecuteOutput] + } + deriving stock (Eq, Show) + +instance FromJSON InferenceResult where + parseJSON = withObject "InferenceResult" $ \v -> do + inferenceResultOutput <- v .:? "output" .!= [] + pure InferenceResult {..} + +instance ToJSON InferenceResult where + toJSON InferenceResult {..} = + object ["output" .= inferenceResultOutput] + +-- | A single entry in an 'InferenceResult'\'s @output@ list. The +-- @name@ discriminator ('executeOutputName') selects the payload kind; +-- @result@ is a bare string, @dataAsMap@ is a structured object. The +-- record tolerates both payloads being absent. +data ExecuteOutput = ExecuteOutput + { executeOutputName :: Maybe Text, + executeOutputResult :: Maybe Text, + executeOutputDataAsMap :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON ExecuteOutput where + parseJSON = withObject "ExecuteOutput" $ \v -> do + executeOutputName <- v .:? "name" + executeOutputResult <- v .:? "result" + executeOutputDataAsMap <- v .:? "dataAsMap" + pure ExecuteOutput {..} + +instance ToJSON ExecuteOutput where + toJSON ExecuteOutput {..} = + omitNulls + [ "name" .= executeOutputName, + "result" .= executeOutputResult, + "dataAsMap" .= executeOutputDataAsMap + ] + +-- | Response of @GET /_plugins/_ml/agents/{agent_id}@. The body is +-- the bare stored agent document (no envelope, no @_source@ wrapper). +-- Every field is 'Maybe' because the agent kind determines which +-- fields are present (a @flow@ agent carries @tools@, a +-- @conversation@ agent carries @llm@ and optionally @memory@, a +-- @template@ agent carries @app_type@). The @agent_id@ is not in the +-- body for the GET-by-id endpoint; for search hits, the @agent_id@ +-- surfaces as the hit's @_id@ rather than as a body field. +-- +-- The 'agentInfoOther' field captures the *entire* source object +-- verbatim on decode (via @pure (Object o)@). On encode, +-- 'mergeIgnoringNulls' overlays the typed fields on top of this +-- captured object, dropping @null@ values, so typed fields are +-- re-serialized under their typed form while any unknown key (forward +-- compatibility: future plugin releases adding new fields) round-trips +-- untouched. Callers constructing an 'AgentInfo' directly should set +-- 'agentInfoOther' to @Object mempty@ (or @object []@) to opt into +-- this merge behaviour; a non-'Object' value short-circuits the merge +-- and falls back to 'omitNulls' over the typed fields alone. +-- See . +data AgentInfo = AgentInfo + { agentInfoName :: Maybe Text, + agentInfoType :: Maybe AgentType, + agentInfoDescription :: Maybe Text, + agentInfoLlm :: Maybe LlmConfig, + agentInfoTools :: Maybe [ToolConfig], + agentInfoParameters :: Maybe Value, + agentInfoMemory :: Maybe MemoryConfig, + agentInfoAppType :: Maybe Text, + agentInfoCreatedTime :: Maybe Int64, + agentInfoLastUpdatedTime :: Maybe Int64, + agentInfoUser :: Maybe Value, + agentInfoOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON AgentInfo where + parseJSON = withObject "AgentInfo" $ \o -> + AgentInfo + <$> o .:? "name" + <*> o .:? "type" + <*> o .:? "description" + <*> o .:? "llm" + <*> o .:? "tools" + <*> o .:? "parameters" + <*> o .:? "memory" + <*> o .:? "app_type" + <*> o .:? "created_time" + <*> o .:? "last_updated_time" + <*> o .:? "user" + <*> pure (Object o) + +instance ToJSON AgentInfo where + toJSON a = + case agentInfoOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= agentInfoName a, + "type" .= agentInfoType a, + "description" .= agentInfoDescription a, + "llm" .= agentInfoLlm a, + "tools" .= agentInfoTools a, + "parameters" .= agentInfoParameters a, + "memory" .= agentInfoMemory a, + "app_type" .= agentInfoAppType a, + "created_time" .= agentInfoCreatedTime a, + "last_updated_time" .= agentInfoLastUpdatedTime a, + "user" .= agentInfoUser a + ] + +-- | Overlay the typed key-value pairs on top of a captured object, +-- dropping any @null@ values so partial-update round-trips stay +-- minimal. Mirrors the Security Analytics merge helper. +mergeIgnoringNulls :: [(Key, Value)] -> Object -> Object +mergeIgnoringNulls kvs o = + foldr (\(k, v) acc -> if v == Null then acc else KM.insert k v acc) o kvs + +-- | The @hits.total.relation@ discriminator on an agent search +-- response. Mirrors the Security Analytics 'SARulesTotalRelation' +-- precedent. +data AgentTotalRelation + = AgentTotalRelationEq + | AgentTotalRelationGe + | AgentTotalRelationOther Text + deriving stock (Eq, Show) + +agentTotalRelationText :: AgentTotalRelation -> Text +agentTotalRelationText = \case + AgentTotalRelationEq -> "eq" + AgentTotalRelationGe -> "ge" + AgentTotalRelationOther t -> t + +instance ToJSON AgentTotalRelation where + toJSON = toJSON . agentTotalRelationText + +instance FromJSON AgentTotalRelation where + parseJSON = withText "AgentTotalRelation" $ \t -> + pure $ + case t of + "eq" -> AgentTotalRelationEq + "ge" -> AgentTotalRelationGe + other -> AgentTotalRelationOther other + +-- | The @hits.total@ sub-object on an agent search response +-- (@{value, relation}@). +data AgentTotal = AgentTotal + { agentTotalValue :: Int64, + agentTotalRelation :: AgentTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON AgentTotal where + parseJSON = withObject "AgentTotal" $ \o -> + AgentTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON AgentTotal where + toJSON AgentTotal {..} = + object + [ "value" .= agentTotalValue, + "relation" .= agentTotalRelation + ] + +-- | The @_shards@ sub-object on an agent search response. Defined +-- locally under an @Agent@ prefix (mirroring the 'SARulesShards' and +-- 'ModelShards' precedent) rather than re-using the cluster-level +-- 'ShardsResult' envelope, which wraps the outer +-- @{\"_shards\": {...}}@ shape — one level too high for inline use +-- here. +data AgentShards = AgentShards + { agentShardsTotal :: Int, + agentShardsSuccessful :: Int, + agentShardsSkipped :: Int, + agentShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON AgentShards where + parseJSON = withObject "AgentShards" $ \o -> + AgentShards + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "skipped" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON AgentShards where + toJSON AgentShards {..} = + object + [ "total" .= agentShardsTotal, + "successful" .= agentShardsSuccessful, + "skipped" .= agentShardsSkipped, + "failed" .= agentShardsFailed + ] + +-- | A single hit in @hits.hits[]@ on an agent search response. Note: +-- the agent's @agent_id@ surfaces as the hit's @_id@, not as a field +-- inside @_source@ (see 'AgentInfo'). +data AgentHit = AgentHit + { agentHitIndex :: Maybe Text, + agentHitId :: Text, + agentHitVersion :: Maybe Int64, + agentHitSeqNo :: Maybe Int64, + agentHitPrimaryTerm :: Maybe Int64, + agentHitScore :: Maybe Double, + agentHitSource :: AgentInfo + } + deriving stock (Eq, Show) + +instance FromJSON AgentHit where + parseJSON = withObject "AgentHit" $ \o -> + AgentHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON AgentHit where + toJSON AgentHit {..} = + omitNulls + [ "_index" .= agentHitIndex, + "_id" .= agentHitId, + "_version" .= agentHitVersion, + "_seq_no" .= agentHitSeqNo, + "_primary_term" .= agentHitPrimaryTerm, + "_score" .= agentHitScore, + "_source" .= agentHitSource + ] + +-- | Response envelope for @POST /_plugins/_ml/agents/_search@. +-- Decoded verbatim from the standard OpenSearch search-response +-- shape; the paging metadata (@took@, @timed_out@, @_shards@, +-- @hits.total@, @hits.max_score@) is preserved alongside the agent +-- list so callers can drive pagination and observe shard health. +data AgentSearchResponse = AgentSearchResponse + { agentSearchResponseTook :: Int64, + agentSearchResponseTimedOut :: Bool, + agentSearchResponseShards :: AgentShards, + agentSearchResponseTotal :: AgentTotal, + agentSearchResponseMaxScore :: Maybe Double, + agentSearchResponseHits :: [AgentHit] + } + deriving stock (Eq, Show) + +instance FromJSON AgentSearchResponse where + parseJSON = withObject "AgentSearchResponse" $ \o -> do + hits <- o .: "hits" + AgentSearchResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON AgentSearchResponse where + toJSON AgentSearchResponse {..} = + object + [ "took" .= agentSearchResponseTook, + "timed_out" .= agentSearchResponseTimedOut, + "_shards" .= agentSearchResponseShards, + "hits" + .= object + [ "total" .= agentSearchResponseTotal, + "max_score" .= agentSearchResponseMaxScore, + "hits" .= agentSearchResponseHits + ] + ] + +-- | An 'AgentSearchResponse' with zero hits and neutral metadata, used +-- as the synthetic result when the @.plugins-ml-agent@ system index +-- does not yet exist (OpenSearch returns HTTP 404 +-- @index_not_found_exception@ in that case rather than an empty search +-- result). 'Database.Bloodhound.OpenSearch2.Requests.searchAgents' +-- substitutes this for such 404 responses so callers see a uniform +-- @Right emptyResult@ regardless of whether any agent has ever been +-- registered. +emptyAgentSearchResponse :: AgentSearchResponse +emptyAgentSearchResponse = + AgentSearchResponse + { agentSearchResponseTook = 0, + agentSearchResponseTimedOut = False, + agentSearchResponseShards = + AgentShards + { agentShardsTotal = 0, + agentShardsSuccessful = 0, + agentShardsSkipped = 0, + agentShardsFailed = 0 + }, + agentSearchResponseTotal = + AgentTotal + { agentTotalValue = 0, + agentTotalRelation = AgentTotalRelationEq + }, + agentSearchResponseMaxScore = Nothing, + agentSearchResponseHits = [] + } diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLConnectors.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLConnectors.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLConnectors.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLConnectors + ( ConnectorId (..), + ConnectorProtocol (..), + MLConnectorAction (..), + CreateConnectorRequest (..), + CreateConnectorResponse (..), + UpdateConnectorRequest (..), + ConnectorInfo (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value, withObject, withText, (.:), (.:?), (.=)) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) + +-- $schema +-- +-- The ML Commons connector APIs (see +-- , +-- introduced in OS 2.12) manage remote-model connectors — the bridge +-- between ML Commons and an external model service (OpenAI, Bedrock, +-- SageMaker, ...). A connector bundles default @parameters@, encrypted +-- @credential@ variables, and one or more @actions@ (HTTP request +-- templates, typically a @predict@ action). +-- +-- /Wire quirks honoured below:/ +-- +-- * @credential@ is write-only: accepted on create\/update but never +-- returned by get\/search, so it is absent from 'ConnectorInfo'. +-- * @version@ is sent as a JSON number but echoed back as a JSON string +-- on get\/search; the request uses 'Int' and the response uses 'Text'. +-- * Deletes are idempotent: a missing connector returns HTTP 200 with +-- @result = "not_found"@ rather than a 404. + +-- | A connector identifier for the +-- @\/_plugins\/_ml\/connectors\/{connector_id}@ path segment, assigned +-- by the server on create. +newtype ConnectorId = ConnectorId {unConnectorId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @protocol@ enum on a connector. The plugin currently documents +-- two values; unknown values decode to 'ConnectorProtocolOther' for +-- forward compatibility. +data ConnectorProtocol + = ConnectorProtocolHttp + | ConnectorProtocolAwsSigv4 + | ConnectorProtocolOther Text + deriving stock (Eq, Show) + +connectorProtocolText :: ConnectorProtocol -> Text +connectorProtocolText = \case + ConnectorProtocolHttp -> "http" + ConnectorProtocolAwsSigv4 -> "aws_sigv4" + ConnectorProtocolOther t -> t + +instance ToJSON ConnectorProtocol where + toJSON = toJSON . connectorProtocolText + +instance FromJSON ConnectorProtocol where + parseJSON = withText "ConnectorProtocol" $ \t -> + pure $ + case t of + "http" -> ConnectorProtocolHttp + "aws_sigv4" -> ConnectorProtocolAwsSigv4 + other -> ConnectorProtocolOther other + +-- | One entry in a connector's @actions@ array: an HTTP request template +-- (typically the @predict@ action). @url@, @headers@, and +-- @request_body@ carry @${parameters.*}@ / @${credential.*}@ template +-- references resolved by the plugin at invoke time, so they are kept as +-- opaque 'Text' \/ 'Value'. The optional @pre_process_function@ and +-- @post_process_function@ are Painless script strings run before\/after +-- the HTTP call. +data MLConnectorAction = MLConnectorAction + { mlConnectorActionType :: Text, + mlConnectorActionMethod :: Maybe Text, + mlConnectorActionUrl :: Maybe Text, + mlConnectorActionHeaders :: Maybe Value, + mlConnectorActionRequestBody :: Maybe Text, + mlConnectorActionPreProcessFunction :: Maybe Text, + mlConnectorActionPostProcessFunction :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON MLConnectorAction where + parseJSON = withObject "MLConnectorAction" $ \v -> do + mlConnectorActionType <- v .: "action_type" + mlConnectorActionMethod <- v .:? "method" + mlConnectorActionUrl <- v .:? "url" + mlConnectorActionHeaders <- v .:? "headers" + mlConnectorActionRequestBody <- v .:? "request_body" + mlConnectorActionPreProcessFunction <- v .:? "pre_process_function" + mlConnectorActionPostProcessFunction <- v .:? "post_process_function" + pure MLConnectorAction {..} + +instance ToJSON MLConnectorAction where + toJSON MLConnectorAction {..} = + omitNulls + [ "action_type" .= mlConnectorActionType, + "method" .= mlConnectorActionMethod, + "url" .= mlConnectorActionUrl, + "headers" .= mlConnectorActionHeaders, + "request_body" .= mlConnectorActionRequestBody, + "pre_process_function" .= mlConnectorActionPreProcessFunction, + "post_process_function" .= mlConnectorActionPostProcessFunction + ] + +-- | Request body for @POST /_plugins/_ml/connectors/_create@. @name@, +-- @description@, @version@, and @protocol@ are required by the plugin; +-- @parameters@ and @credential@ are opaque JSON objects (their sub-shape +-- is connector-blueprint-specific and large), and @actions@ is the list +-- of HTTP request templates. The optional access-control fields are only +-- honoured when model access control is enabled cluster-wide. +data CreateConnectorRequest = CreateConnectorRequest + { createConnectorName :: Text, + createConnectorDescription :: Maybe Text, + createConnectorVersion :: Maybe Int, + createConnectorProtocol :: Maybe ConnectorProtocol, + createConnectorParameters :: Maybe Value, + createConnectorCredential :: Maybe Value, + createConnectorActions :: Maybe [MLConnectorAction], + createConnectorBackendRoles :: Maybe [Text], + createConnectorAccessMode :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateConnectorRequest where + parseJSON = withObject "CreateConnectorRequest" $ \v -> do + createConnectorName <- v .: "name" + createConnectorDescription <- v .:? "description" + createConnectorVersion <- v .:? "version" + createConnectorProtocol <- v .:? "protocol" + createConnectorParameters <- v .:? "parameters" + createConnectorCredential <- v .:? "credential" + createConnectorActions <- v .:? "actions" + createConnectorBackendRoles <- v .:? "backend_roles" + createConnectorAccessMode <- v .:? "access_mode" + pure CreateConnectorRequest {..} + +instance ToJSON CreateConnectorRequest where + toJSON CreateConnectorRequest {..} = + omitNulls + [ "name" .= createConnectorName, + "description" .= createConnectorDescription, + "version" .= createConnectorVersion, + "protocol" .= createConnectorProtocol, + "parameters" .= createConnectorParameters, + "credential" .= createConnectorCredential, + "actions" .= createConnectorActions, + "backend_roles" .= createConnectorBackendRoles, + "access_mode" .= createConnectorAccessMode + ] + +-- | Response of @POST /_plugins/_ml/connectors/_create@: +-- @{connector_id}@. +newtype CreateConnectorResponse = CreateConnectorResponse + { createConnectorResponseId :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateConnectorResponse where + parseJSON = withObject "CreateConnectorResponse" $ \v -> do + createConnectorResponseId <- v .:? "connector_id" + pure CreateConnectorResponse {..} + +instance ToJSON CreateConnectorResponse where + toJSON (CreateConnectorResponse mId) = + omitNulls ["connector_id" .= mId] + +-- | Request body for @PUT /_plugins/_ml/connectors/{connector_id}@. All +-- fields are 'Maybe' (partial update); omitted fields are preserved. +-- All models using the connector must be undeployed before updating. +data UpdateConnectorRequest = UpdateConnectorRequest + { updateConnectorName :: Maybe Text, + updateConnectorDescription :: Maybe Text, + updateConnectorVersion :: Maybe Int, + updateConnectorProtocol :: Maybe ConnectorProtocol, + updateConnectorParameters :: Maybe Value, + updateConnectorCredential :: Maybe Value, + updateConnectorActions :: Maybe [MLConnectorAction], + updateConnectorBackendRoles :: Maybe [Text], + updateConnectorAccessMode :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON UpdateConnectorRequest where + parseJSON = withObject "UpdateConnectorRequest" $ \v -> do + updateConnectorName <- v .:? "name" + updateConnectorDescription <- v .:? "description" + updateConnectorVersion <- v .:? "version" + updateConnectorProtocol <- v .:? "protocol" + updateConnectorParameters <- v .:? "parameters" + updateConnectorCredential <- v .:? "credential" + updateConnectorActions <- v .:? "actions" + updateConnectorBackendRoles <- v .:? "backend_roles" + updateConnectorAccessMode <- v .:? "access_mode" + pure UpdateConnectorRequest {..} + +instance ToJSON UpdateConnectorRequest where + toJSON UpdateConnectorRequest {..} = + omitNulls + [ "name" .= updateConnectorName, + "description" .= updateConnectorDescription, + "version" .= updateConnectorVersion, + "protocol" .= updateConnectorProtocol, + "parameters" .= updateConnectorParameters, + "credential" .= updateConnectorCredential, + "actions" .= updateConnectorActions, + "backend_roles" .= updateConnectorBackendRoles, + "access_mode" .= updateConnectorAccessMode + ] + +-- | Response of @GET /_plugins/_ml/connectors/{connector_id}@ and the +-- per-hit @_source@ of @/_plugins/_ml/connectors/_search@. The body is +-- the bare stored connector document (no envelope); @credential@ is +-- never returned. Note @version@ comes back as a string, not a number. +-- @backend_roles@ and @access_mode@ are present when model access +-- control is enabled cluster-wide. +data ConnectorInfo = ConnectorInfo + { connectorInfoName :: Maybe Text, + connectorInfoDescription :: Maybe Text, + connectorInfoVersion :: Maybe Text, + connectorInfoProtocol :: Maybe ConnectorProtocol, + connectorInfoParameters :: Maybe Value, + connectorInfoActions :: Maybe [MLConnectorAction], + connectorInfoBackendRoles :: Maybe [Text], + connectorInfoAccessMode :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ConnectorInfo where + parseJSON = withObject "ConnectorInfo" $ \v -> do + connectorInfoName <- v .:? "name" + connectorInfoDescription <- v .:? "description" + connectorInfoVersion <- v .:? "version" + connectorInfoProtocol <- v .:? "protocol" + connectorInfoParameters <- v .:? "parameters" + connectorInfoActions <- v .:? "actions" + connectorInfoBackendRoles <- v .:? "backend_roles" + connectorInfoAccessMode <- v .:? "access_mode" + pure ConnectorInfo {..} + +instance ToJSON ConnectorInfo where + toJSON ConnectorInfo {..} = + omitNulls + [ "name" .= connectorInfoName, + "description" .= connectorInfoDescription, + "version" .= connectorInfoVersion, + "protocol" .= connectorInfoProtocol, + "parameters" .= connectorInfoParameters, + "actions" .= connectorInfoActions, + "backend_roles" .= connectorInfoBackendRoles, + "access_mode" .= connectorInfoAccessMode + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLControllers.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLControllers.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLControllers.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLControllers + ( ControllerConfig (..), + ControllerCreateResponse (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:?), (.=)) +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as M +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLModel + ( ModelRateLimiter (..), + ) + +-- $schema +-- +-- The ML Commons controller APIs (see +-- , +-- introduced in OS 2.12) enforce per-user rate limits on a deployed +-- model. A controller is keyed by the model's @model_id@ (there is no +-- separate controller id), and its body is a single @user_rate_limiter@ +-- map from username to a @{limit, unit}@ entry. The per-entry shape is +-- identical to the model-level @rate_limiter@ in +-- "Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLModel", so +-- 'ModelRateLimiter' is reused here. +-- +-- /Wire quirk:/ @limit@ is sent as a JSON number but echoed back as a +-- JSON string; the 'ModelRateLimiter' parser already tolerates both +-- shapes (its @limit@ is a stringified-double 'ModelRateLimit'). +-- +-- /Semantics:/ the effective per-user rate limit is the more restrictive +-- of the model-level limit (set via the Update Model API) and the +-- user-level limit set here. + +-- | Request body for @POST@ \/ @PUT +-- /_plugins/_ml/controllers/{model_id}@ and response body of @GET +-- /_plugins/_ml/controllers/{model_id}@. The create response wraps the +-- echoed @model_id@ and a @status@ in 'ControllerCreateResponse' instead. +-- +-- POST overwrites the entire @user_rate_limiter@ map; PUT updates +-- individual user entries, preserving others. +data ControllerConfig = ControllerConfig + { -- | Optional on the request path segment; the plugin keys the stored + -- document by @model_id@ and echoes it back on GET. Omitted when + -- building a create\/update body (the id travels in the URL). + controllerConfigModelId :: Maybe Text, + controllerConfigUserRateLimiter :: M.Map Text ModelRateLimiter + } + deriving stock (Eq, Show) + +instance FromJSON ControllerConfig where + parseJSON = withObject "ControllerConfig" $ \v -> do + controllerConfigModelId <- v .:? "model_id" + mRateLimiter <- v .:? "user_rate_limiter" + let controllerConfigUserRateLimiter = case mRateLimiter of + Nothing -> M.empty + Just o -> M.fromList [(toText k, r) | (k, r) <- KM.toList o] + pure ControllerConfig {..} + +instance ToJSON ControllerConfig where + toJSON ControllerConfig {..} = + omitNulls + [ "model_id" .= controllerConfigModelId, + "user_rate_limiter" + .= object [fromText k .= toJSON v | (k, v) <- M.toList controllerConfigUserRateLimiter] + ] + +-- | Response of @POST /_plugins/_ml/controllers/{model_id}@ (create): +-- @{model_id, status}@, where @status@ is typically @CREATED@. +data ControllerCreateResponse = ControllerCreateResponse + { controllerCreateResponseModelId :: Maybe Text, + controllerCreateResponseStatus :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ControllerCreateResponse where + parseJSON = withObject "ControllerCreateResponse" $ \v -> do + controllerCreateResponseModelId <- v .:? "model_id" + controllerCreateResponseStatus <- v .:? "status" + pure ControllerCreateResponse {..} + +instance ToJSON ControllerCreateResponse where + toJSON ControllerCreateResponse {..} = + omitNulls + [ "model_id" .= controllerCreateResponseModelId, + "status" .= controllerCreateResponseStatus + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLMemory.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLMemory.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLMemory.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLMemory + ( MemoryId (..), + MessageId (..), + Memory (..), + CreateMemoryRequest (..), + CreateMemoryResponse (..), + DeleteMemoryResponse (..), + ListMemoriesResponse (..), + MemoryMessage (..), + CreateMemoryMessageRequest (..), + CreateMemoryMessageResponse (..), + ListMemoryMessagesResponse (..), + MemoryMessageTraces (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value, withObject, (.!=), (.:?), (.=)) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) + +-- $schema +-- +-- The ML Commons memory APIs (see +-- , +-- introduced in OS 2.12) persist conversational context for ML agents: +-- each 'Memory' is a thread containing 'MemoryMessage's (a human @input@ +-- paired with an AI @response@), and each message may in turn have +-- @traces@ — diagnostic sub-messages recording the agent's intermediate +-- tool calls. +-- +-- /Wire notes honoured below:/ +-- +-- * Timestamps (@create_time@, @updated_time@) are RFC 3339 strings +-- (e.g. @2024-02-02T18:07:06.887061463Z@), not epoch milliseconds, so +-- they are kept as opaque 'Text' rather than parsed to 'UTCTime'. +-- * With the Security plugin enabled, memories and messages are always +-- private to their creator. +-- * Memory delete is /not/ idempotent: a missing memory returns HTTP +-- 404 (unlike connector \/ model-group delete). + +-- | A memory identifier for the +-- @\/_plugins\/_ml\/memory\/{memory_id}@ path segment. +newtype MemoryId = MemoryId {unMemoryId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A message identifier for the +-- @\/_plugins\/_ml\/memory\/message\/{message_id}@ path segment. +newtype MessageId = MessageId {unMessageId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A single memory record, as returned by @GET /_plugins/_ml/memory/{memory_id}@ +-- and as each entry of @GET /_plugins/_ml/memory@ (the list form) and +-- each per-hit @_source@ of @/_plugins/_ml/memory/_search@. Every field +-- is 'Maybe' because the list and search shapes omit @memory_id@ / +-- @user@ in some plugin versions. +data Memory = Memory + { memoryId :: Maybe Text, + memoryCreateTime :: Maybe Text, + memoryUpdatedTime :: Maybe Text, + memoryName :: Maybe Text, + memoryUser :: Maybe Text, + memoryApplicationType :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON Memory where + parseJSON = withObject "Memory" $ \v -> do + memoryId <- v .:? "memory_id" + memoryCreateTime <- v .:? "create_time" + memoryUpdatedTime <- v .:? "updated_time" + memoryName <- v .:? "name" + memoryUser <- v .:? "user" + memoryApplicationType <- v .:? "application_type" + pure Memory {..} + +instance ToJSON Memory where + toJSON Memory {..} = + omitNulls + [ "memory_id" .= memoryId, + "create_time" .= memoryCreateTime, + "updated_time" .= memoryUpdatedTime, + "name" .= memoryName, + "user" .= memoryUser, + "application_type" .= memoryApplicationType + ] + +-- | Request body for @POST /_plugins/_ml/memory/@. Only @name@ is +-- documented. +newtype CreateMemoryRequest = CreateMemoryRequest + { createMemoryName :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateMemoryRequest where + parseJSON = withObject "CreateMemoryRequest" $ \v -> do + createMemoryName <- v .:? "name" + pure CreateMemoryRequest {..} + +instance ToJSON CreateMemoryRequest where + toJSON (CreateMemoryRequest mName) = + omitNulls ["name" .= mName] + +-- | Response of @POST /_plugins/_ml/memory/@: @{memory_id}@. +newtype CreateMemoryResponse = CreateMemoryResponse + { createMemoryResponseId :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateMemoryResponse where + parseJSON = withObject "CreateMemoryResponse" $ \v -> do + createMemoryResponseId <- v .:? "memory_id" + pure CreateMemoryResponse {..} + +instance ToJSON CreateMemoryResponse where + toJSON (CreateMemoryResponse mId) = + omitNulls ["memory_id" .= mId] + +-- | Response of @DELETE /_plugins/_ml/memory/{memory_id}@: +-- @{success: }@. Unlike connector \/ model-group delete, memory +-- delete is /not/ idempotent — a missing memory returns HTTP 404. +newtype DeleteMemoryResponse = DeleteMemoryResponse + { deleteMemoryResponseSuccess :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON DeleteMemoryResponse where + parseJSON = withObject "DeleteMemoryResponse" $ \v -> do + deleteMemoryResponseSuccess <- v .:? "success" + pure DeleteMemoryResponse {..} + +instance ToJSON DeleteMemoryResponse where + toJSON (DeleteMemoryResponse mSuccess) = + omitNulls ["success" .= mSuccess] + +-- | Response of the list form @GET /_plugins/_ml/memory@: +-- @{"memories": [...]}@. +newtype ListMemoriesResponse = ListMemoriesResponse + { listMemoriesResponseMemories :: [Memory] + } + deriving stock (Eq, Show) + +instance FromJSON ListMemoriesResponse where + parseJSON = withObject "ListMemoriesResponse" $ \v -> do + listMemoriesResponseMemories <- v .:? "memories" .!= [] + pure ListMemoriesResponse {..} + +instance ToJSON ListMemoriesResponse where + toJSON (ListMemoriesResponse ms) = + omitNulls ["memories" .= ms] + +-- | A single message within a memory. Returned by the get-message, +-- list-messages, search-message, and trace endpoints; every field is +-- 'Maybe' because traces carry @parent_message_id@ \/ @trace_number@ +-- that ordinary messages omit, and because @input@ \/ @response@ may be +-- null when only @additional_info@ was supplied. @additional_info@ is an +-- opaque JSON object (arbitrary key/value metadata). +data MemoryMessage = MemoryMessage + { memoryMessageMemoryId :: Maybe Text, + memoryMessageId :: Maybe Text, + memoryMessageCreateTime :: Maybe Text, + memoryMessageUpdatedTime :: Maybe Text, + memoryMessageInput :: Maybe Text, + memoryMessagePromptTemplate :: Maybe Text, + memoryMessageResponse :: Maybe Text, + memoryMessageOrigin :: Maybe Text, + memoryMessageAdditionalInfo :: Maybe Value, + memoryMessageParentMessageId :: Maybe Text, + memoryMessageTraceNumber :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON MemoryMessage where + parseJSON = withObject "MemoryMessage" $ \v -> do + memoryMessageMemoryId <- v .:? "memory_id" + memoryMessageId <- v .:? "message_id" + memoryMessageCreateTime <- v .:? "create_time" + memoryMessageUpdatedTime <- v .:? "updated_time" + memoryMessageInput <- v .:? "input" + memoryMessagePromptTemplate <- v .:? "prompt_template" + memoryMessageResponse <- v .:? "response" + memoryMessageOrigin <- v .:? "origin" + memoryMessageAdditionalInfo <- v .:? "additional_info" + memoryMessageParentMessageId <- v .:? "parent_message_id" + memoryMessageTraceNumber <- v .:? "trace_number" + pure MemoryMessage {..} + +instance ToJSON MemoryMessage where + toJSON MemoryMessage {..} = + omitNulls + [ "memory_id" .= memoryMessageMemoryId, + "message_id" .= memoryMessageId, + "create_time" .= memoryMessageCreateTime, + "updated_time" .= memoryMessageUpdatedTime, + "input" .= memoryMessageInput, + "prompt_template" .= memoryMessagePromptTemplate, + "response" .= memoryMessageResponse, + "origin" .= memoryMessageOrigin, + "additional_info" .= memoryMessageAdditionalInfo, + "parent_message_id" .= memoryMessageParentMessageId, + "trace_number" .= memoryMessageTraceNumber + ] + +-- | Request body for @POST /_plugins/_ml/memory/{memory_id}/messages@. +-- At least one field must be non-null/non-empty. Only @additional_info@ +-- is updatable via the PUT form; the other fields are write-once. +data CreateMemoryMessageRequest = CreateMemoryMessageRequest + { createMemoryMessageInput :: Maybe Text, + createMemoryMessagePromptTemplate :: Maybe Text, + createMemoryMessageResponse :: Maybe Text, + createMemoryMessageOrigin :: Maybe Text, + createMemoryMessageAdditionalInfo :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON CreateMemoryMessageRequest where + parseJSON = withObject "CreateMemoryMessageRequest" $ \v -> do + createMemoryMessageInput <- v .:? "input" + createMemoryMessagePromptTemplate <- v .:? "prompt_template" + createMemoryMessageResponse <- v .:? "response" + createMemoryMessageOrigin <- v .:? "origin" + createMemoryMessageAdditionalInfo <- v .:? "additional_info" + pure CreateMemoryMessageRequest {..} + +instance ToJSON CreateMemoryMessageRequest where + toJSON CreateMemoryMessageRequest {..} = + omitNulls + [ "input" .= createMemoryMessageInput, + "prompt_template" .= createMemoryMessagePromptTemplate, + "response" .= createMemoryMessageResponse, + "origin" .= createMemoryMessageOrigin, + "additional_info" .= createMemoryMessageAdditionalInfo + ] + +-- | Response of @POST /_plugins/_ml/memory/{memory_id}/messages@: +-- @{message_id}@. +newtype CreateMemoryMessageResponse = CreateMemoryMessageResponse + { createMemoryMessageResponseId :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateMemoryMessageResponse where + parseJSON = withObject "CreateMemoryMessageResponse" $ \v -> do + createMemoryMessageResponseId <- v .:? "message_id" + pure CreateMemoryMessageResponse {..} + +instance ToJSON CreateMemoryMessageResponse where + toJSON (CreateMemoryMessageResponse mId) = + omitNulls ["message_id" .= mId] + +-- | Response of the list form +-- @GET /_plugins/_ml/memory/{memory_id}/messages@: @{"messages": [...]}@. +newtype ListMemoryMessagesResponse = ListMemoryMessagesResponse + { listMemoryMessagesResponseMessages :: [MemoryMessage] + } + deriving stock (Eq, Show) + +instance FromJSON ListMemoryMessagesResponse where + parseJSON = withObject "ListMemoryMessagesResponse" $ \v -> do + listMemoryMessagesResponseMessages <- v .:? "messages" .!= [] + pure ListMemoryMessagesResponse {..} + +instance ToJSON ListMemoryMessagesResponse where + toJSON (ListMemoryMessagesResponse ms) = + omitNulls ["messages" .= ms] + +-- | Response of @GET /_plugins/_ml/memory/message/{message_id}/traces@: +-- @{"traces": [...]}@, where each entry has the full 'MemoryMessage' +-- shape (with @parent_message_id@ and @trace_number@ populated). +newtype MemoryMessageTraces = MemoryMessageTraces + { memoryMessageTracesTraces :: [MemoryMessage] + } + deriving stock (Eq, Show) + +instance FromJSON MemoryMessageTraces where + parseJSON = withObject "MemoryMessageTraces" $ \v -> do + memoryMessageTracesTraces <- v .:? "traces" .!= [] + pure MemoryMessageTraces {..} + +instance ToJSON MemoryMessageTraces where + toJSON (MemoryMessageTraces ts) = + omitNulls ["traces" .= ts] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLModel.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLModel.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLModel.hs @@ -0,0 +1,669 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLModel + ( ModelId (..), + AlgorithmName (..), + ModelFormat (..), + ModelState (..), + ModelConfig (..), + ModelInfo (..), + RegisterModelRequest (..), + MLTaskAck (..), + DeployModelRequest (..), + UndeployModelResponse (..), + ModelNodeUndeployStats (..), + UpdateModelRequest (..), + ModelRateLimiter (..), + ModelRateLimit (..), + ModelRateLimiterUnit (..), + ModelSearchResponse (..), + ModelShards (..), + ModelTotal (..), + ModelTotalRelation (..), + ModelHit (..), + ) +where + +import Data.Aeson.KeyMap qualified as KM +import Data.Int (Int64) +import Data.Map.Strict qualified as M +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The ML Commons model APIs (see +-- ) +-- cover the lifecycle of a model: register (asynchronously store the model +-- metadata and content), deploy (load chunks into memory on ML worker +-- nodes), predict (invoke a deployed model), and get (read metadata). +-- +-- Registration and deployment are asynchronous: the POST returns a task +-- acknowledgement carrying a @task_id@ that the caller polls via the +-- separate Get ML Task API (@GET /_plugins/_ml/tasks/{task_id}@). The +-- acknowledgement shape is shared by both endpoints, modelled here as +-- 'MLTaskAck'. +-- +-- The predict request body and response are model-specific (the same +-- endpoint serves classical algorithms like kmeans and remote connectors +-- whose @parameters@ and @inference_results@ have no fixed schema), so +-- 'predict' is typed at the boundary as an opaque 'Value' and callers +-- decode the payload with their own model-specific parser. + +-- | A model ID for the @\/_plugins\/_ml\/models\/{model_id}@ path segment +-- and the @model_id@ field returned by register\/deploy. The value is +-- assigned by the server. Wrapped 'Text' so it round-trips as a bare JSON +-- string but is distinct from 'PolicyId' \/ 'IndexName' at the type level. +newtype ModelId = ModelId {unModelId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | An algorithm name for the +-- @\/_plugins\/_ml\/_predict\/{algorithm_name}\/{model_id}@ path segment +-- of the predict endpoint. Values are plugin-defined @FunctionName@ +-- constants (e.g. @kmeans@, @text_embedding@, @remote@); the set changes +-- across releases so this is a thin 'Text' newtype. +newtype AlgorithmName = AlgorithmName {unAlgorithmName :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The serialization format of a model's content. Used by the +-- @model_format@ field of 'RegisterModelRequest' and 'ModelInfo'. +-- OpenSearch currently documents two values; unknown values parse-fail so +-- a future plugin release adding a third surfaces as a deliberate error +-- rather than a silent drop. +data ModelFormat + = ModelFormatTorchScript + | ModelFormatOnnx + deriving stock (Eq, Show) + +instance ToJSON ModelFormat where + toJSON = \case + ModelFormatTorchScript -> "TORCH_SCRIPT" + ModelFormatOnnx -> "ONNX" + +instance FromJSON ModelFormat where + parseJSON = withText "ModelFormat" $ \case + "TORCH_SCRIPT" -> pure ModelFormatTorchScript + "ONNX" -> pure ModelFormatOnnx + other -> fail ("Unknown ModelFormat: " <> T.unpack other) + +-- | The lifecycle state of a model, as reported by the @model_state@ field +-- of 'ModelInfo'. The full set is documented at +-- . +data ModelState + = ModelStateRegistering + | ModelStateRegistered + | ModelStateDeploying + | ModelStateDeployed + | ModelStatePartiallyDeployed + | ModelStateUndeployed + | ModelStateDeployFailed + deriving stock (Eq, Show) + +instance ToJSON ModelState where + toJSON = \case + ModelStateRegistering -> "REGISTERING" + ModelStateRegistered -> "REGISTERED" + ModelStateDeploying -> "DEPLOYING" + ModelStateDeployed -> "DEPLOYED" + ModelStatePartiallyDeployed -> "PARTIALLY_DEPLOYED" + ModelStateUndeployed -> "UNDEPLOYED" + ModelStateDeployFailed -> "DEPLOY_FAILED" + +instance FromJSON ModelState where + parseJSON = withText "ModelState" $ \case + "REGISTERING" -> pure ModelStateRegistering + "REGISTERED" -> pure ModelStateRegistered + "DEPLOYING" -> pure ModelStateDeploying + "DEPLOYED" -> pure ModelStateDeployed + "PARTIALLY_DEPLOYED" -> pure ModelStatePartiallyDeployed + "UNDEPLOYED" -> pure ModelStateUndeployed + "DEPLOY_FAILED" -> pure ModelStateDeployFailed + other -> fail ("Unknown ModelState: " <> T.unpack other) + +-- | The @model_config@ object embedded in 'RegisterModelRequest' and +-- returned inside 'ModelInfo'. @model_type@, @embedding_dimension@, and +-- @framework_type@ are required when present; @all_config@ is a minified +-- JSON string of the upstream model config (e.g. HuggingFace +-- @config.json@); @additional_config@ is an opaque JSON object (notably +-- @space_type@ for k-NN distance metric). +data ModelConfig = ModelConfig + { modelConfigModelType :: Text, + modelConfigEmbeddingDimension :: Int, + modelConfigFrameworkType :: Text, + modelConfigAllConfig :: Maybe Text, + modelConfigAdditionalConfig :: Maybe Value, + modelConfigPoolingMode :: Maybe Text, + modelConfigNormalizeResult :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON ModelConfig where + parseJSON = withObject "ModelConfig" $ \v -> do + modelConfigModelType <- v .: "model_type" + modelConfigEmbeddingDimension <- v .: "embedding_dimension" + modelConfigFrameworkType <- v .: "framework_type" + modelConfigAllConfig <- v .:? "all_config" + modelConfigAdditionalConfig <- v .:? "additional_config" + modelConfigPoolingMode <- v .:? "pooling_mode" + modelConfigNormalizeResult <- v .:? "normalize_result" + pure ModelConfig {..} + +instance ToJSON ModelConfig where + toJSON ModelConfig {..} = + omitNulls + [ "model_type" .= modelConfigModelType, + "embedding_dimension" .= modelConfigEmbeddingDimension, + "framework_type" .= modelConfigFrameworkType, + "all_config" .= modelConfigAllConfig, + "additional_config" .= modelConfigAdditionalConfig, + "pooling_mode" .= modelConfigPoolingMode, + "normalize_result" .= modelConfigNormalizeResult + ] + +-- | Response of @GET /_plugins/_ml/models/{model_id}@. The body is a bare +-- object (no envelope); the server returns every metadata field it has. +-- Most fields beyond @name@, @algorithm@, @version@ are conditionally +-- present depending on the model source (pretrained, custom, or remote +-- connector) and lifecycle state, so they are modelled as 'Maybe'. +-- +-- Note: embedding-specific fields (@model_config@, @model_format@, +-- @model_content_*@) are typically absent for remote-connector models +-- (algorithm @remote@); callers serving remote models should not rely on +-- 'modelInfoModelConfig' being present. +data ModelInfo = ModelInfo + { modelInfoModelId :: Maybe Text, + modelInfoName :: Text, + modelInfoAlgorithm :: Text, + modelInfoVersion :: Text, + modelInfoModelFormat :: Maybe ModelFormat, + modelInfoModelState :: Maybe ModelState, + modelInfoModelContentSizeInBytes :: Maybe Int64, + modelInfoModelContentHashValue :: Maybe Text, + modelInfoModelConfig :: Maybe ModelConfig, + modelInfoIsEnabled :: Maybe Bool, + modelInfoGroupId :: Maybe Text, + modelInfoCreatedTime :: Maybe Int64, + modelInfoLastUploadedTime :: Maybe Int64, + modelInfoLastLoadedTime :: Maybe Int64, + modelInfoTotalChunks :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ModelInfo where + parseJSON = withObject "ModelInfo" $ \v -> do + modelInfoModelId <- v .:? "model_id" + modelInfoName <- v .: "name" + modelInfoAlgorithm <- v .: "algorithm" + mModelVersion <- v .:? "model_version" + modelInfoVersion <- case mModelVersion of + Just ver -> pure ver + Nothing -> v .: "version" + modelInfoModelFormat <- v .:? "model_format" + modelInfoModelState <- v .:? "model_state" + modelInfoModelContentSizeInBytes <- v .:? "model_content_size_in_bytes" + modelInfoModelContentHashValue <- v .:? "model_content_hash_value" + modelInfoModelConfig <- v .:? "model_config" + modelInfoIsEnabled <- v .:? "is_enabled" + modelInfoGroupId <- v .:? "model_group_id" + modelInfoCreatedTime <- v .:? "created_time" + modelInfoLastUploadedTime <- v .:? "last_uploaded_time" + modelInfoLastLoadedTime <- v .:? "last_loaded_time" + modelInfoTotalChunks <- v .:? "total_chunks" + pure ModelInfo {..} + +instance ToJSON ModelInfo where + toJSON ModelInfo {..} = + omitNulls + [ "model_id" .= modelInfoModelId, + "name" .= modelInfoName, + "algorithm" .= modelInfoAlgorithm, + "version" .= modelInfoVersion, + "model_format" .= modelInfoModelFormat, + "model_state" .= modelInfoModelState, + "model_content_size_in_bytes" .= modelInfoModelContentSizeInBytes, + "model_content_hash_value" .= modelInfoModelContentHashValue, + "model_config" .= modelInfoModelConfig, + "is_enabled" .= modelInfoIsEnabled, + "model_group_id" .= modelInfoGroupId, + "created_time" .= modelInfoCreatedTime, + "last_uploaded_time" .= modelInfoLastUploadedTime, + "last_loaded_time" .= modelInfoLastLoadedTime, + "total_chunks" .= modelInfoTotalChunks + ] + +-- | Request body for @POST /_plugins/_ml/models/_register@. The register +-- API documents four model-source variants (pretrained, custom local, +-- sparse, remote-connector); rather than a closed 4-way sum type that +-- would push variant selection onto the caller, this is one general +-- record whose optional fields cover every variant. The server validates +-- the combination and returns HTTP 400 for nonsensical request shapes +-- (e.g. supplying both @url@ and @connector_id@). The inline +-- @connector@ spec is opaque JSON because its sub-shape is large and +-- covered by the dedicated Connector API pages. +data RegisterModelRequest = RegisterModelRequest + { registerModelName :: Text, + registerModelVersion :: Maybe Text, + registerModelDescription :: Maybe Text, + registerModelFormat :: Maybe ModelFormat, + registerModelFunctionName :: Maybe Text, + registerModelContentHashValue :: Maybe Text, + registerModelConfig :: Maybe ModelConfig, + registerModelUrl :: Maybe Text, + registerModelGroupId :: Maybe Text, + registerModelConnectorId :: Maybe Text, + registerModelConnector :: Maybe Value, + registerModelIsEnabled :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON RegisterModelRequest where + parseJSON = withObject "RegisterModelRequest" $ \v -> do + registerModelName <- v .: "name" + registerModelVersion <- v .:? "version" + registerModelDescription <- v .:? "description" + registerModelFormat <- v .:? "model_format" + registerModelFunctionName <- v .:? "function_name" + registerModelContentHashValue <- v .:? "model_content_hash_value" + registerModelConfig <- v .:? "model_config" + registerModelUrl <- v .:? "url" + registerModelGroupId <- v .:? "model_group_id" + registerModelConnectorId <- v .:? "connector_id" + registerModelConnector <- v .:? "connector" + registerModelIsEnabled <- v .:? "is_enabled" + pure RegisterModelRequest {..} + +instance ToJSON RegisterModelRequest where + toJSON RegisterModelRequest {..} = + omitNulls + [ "name" .= registerModelName, + "version" .= registerModelVersion, + "description" .= registerModelDescription, + "model_format" .= registerModelFormat, + "function_name" .= registerModelFunctionName, + "model_content_hash_value" .= registerModelContentHashValue, + "model_config" .= registerModelConfig, + "url" .= registerModelUrl, + "model_group_id" .= registerModelGroupId, + "connector_id" .= registerModelConnectorId, + "connector" .= registerModelConnector, + "is_enabled" .= registerModelIsEnabled + ] + +-- | Shared acknowledgement returned by @POST /_plugins/_ml/models/_register@ +-- and @POST /_plugins/_ml/models/{model_id}/_deploy@. Both endpoints are +-- asynchronous: @task_id@ identifies the polling handle (passed to the +-- separate Get ML Task API), @status@ is the task status at submit time +-- (typically @CREATED@). Register additionally echoes the new @model_id@; +-- deploy instead echoes a @task_type@ (typically @DEPLOY_MODEL@). Each +-- field is 'Maybe' so the same parser covers both endpoint-specific +-- shapes without a sum type. +data MLTaskAck = MLTaskAck + { mlTaskAckTaskId :: Maybe Text, + mlTaskAckStatus :: Maybe Text, + mlTaskAckModelId :: Maybe Text, + mlTaskAckTaskType :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON MLTaskAck where + parseJSON = withObject "MLTaskAck" $ \v -> do + mlTaskAckTaskId <- v .:? "task_id" + mlTaskAckStatus <- v .:? "status" + mlTaskAckModelId <- v .:? "model_id" + mlTaskAckTaskType <- v .:? "task_type" + pure MLTaskAck {..} + +instance ToJSON MLTaskAck where + toJSON MLTaskAck {..} = + omitNulls + [ "task_id" .= mlTaskAckTaskId, + "status" .= mlTaskAckStatus, + "model_id" .= mlTaskAckModelId, + "task_type" .= mlTaskAckTaskType + ] + +-- | Optional request body for +-- @POST /_plugins/_ml/models/{model_id}/_deploy@. When 'Nothing' or when +-- 'deployModelRequestNodeIds' is @[]@ or 'Nothing', OpenSearch deploys to +-- every eligible ML worker node; supplying a non-empty list restricts +-- deployment to those node IDs. +newtype DeployModelRequest = DeployModelRequest + { deployModelRequestNodeIds :: Maybe [Text] + } + deriving stock (Eq, Show) + +instance FromJSON DeployModelRequest where + parseJSON = withObject "DeployModelRequest" $ \v -> do + deployModelRequestNodeIds <- v .:? "node_ids" + pure DeployModelRequest {..} + +instance ToJSON DeployModelRequest where + toJSON (DeployModelRequest mNodeIds) = + omitNulls ["node_ids" .= mNodeIds] + +-- | Response of @POST /_plugins/_ml/models/{model_id}/_undeploy@. Unlike +-- the other model lifecycle endpoints, undeploy is /synchronous/ and +-- returns a node-keyed stats map rather than a task ack: each ML +-- worker node that hosted chunks of the model reports the resulting +-- per-model state (typically @UNDEPLOYED@). The shape is therefore +-- @{"": {"stats": {"": "UNDEPLOYED"}}}@. +-- See . +newtype UndeployModelResponse = UndeployModelResponse + { undeployModelResponseNodes :: M.Map Text ModelNodeUndeployStats + } + deriving stock (Eq, Show) + +instance FromJSON UndeployModelResponse where + parseJSON = withObject "UndeployModelResponse" $ \o -> + UndeployModelResponse . M.fromList + <$> traverse parseNodeEntry (KM.toList o) + where + parseNodeEntry (k, v) = (\parsed -> (toText k, parsed)) <$> parseJSON v + +instance ToJSON UndeployModelResponse where + toJSON (UndeployModelResponse m) = + object [(fromText k .= toJSON v) | (k, v) <- M.toList m] + +-- | The per-node value of 'UndeployModelResponse': +-- @{"stats": {"": "UNDEPLOYED"}}@. +newtype ModelNodeUndeployStats = ModelNodeUndeployStats + { modelNodeUndeployStatsStats :: M.Map Text Text + } + deriving stock (Eq, Show) + +instance FromJSON ModelNodeUndeployStats where + parseJSON = withObject "ModelNodeUndeployStats" $ \v -> do + stats <- v .: "stats" + inner <- traverse parseModelEntry (KM.toList stats) + pure (ModelNodeUndeployStats (M.fromList inner)) + where + parseModelEntry (k, v) = (\parsed -> (toText k, parsed)) <$> parseJSON v + +instance ToJSON ModelNodeUndeployStats where + toJSON (ModelNodeUndeployStats m) = + object [("stats" .= object [(fromText k .= toJSON v) | (k, v) <- M.toList m])] + +-- | Request body for @PUT /_plugins/_ml/models/{model_id}@. Every +-- field is 'Maybe' because the update endpoint accepts a partial +-- body: only the supplied keys are written. The documented updatable +-- fields are @name@, @description@, @is_enabled@, @model_group_id@, +-- @model_config@, @connector@, @connector_id@, @rate_limiter@, +-- @guardrails@, and @interface@. The last four are opaque JSON +-- objects whose sub-shape is plugin-defined and forward-compat, so +-- they are typed as 'Value'. +-- See . +data UpdateModelRequest = UpdateModelRequest + { updateModelName :: Maybe Text, + updateModelDescription :: Maybe Text, + updateModelIsEnabled :: Maybe Bool, + updateModelGroupId :: Maybe Text, + updateModelConfig :: Maybe ModelConfig, + updateModelConnectorId :: Maybe Text, + updateModelConnector :: Maybe Value, + updateModelRateLimiter :: Maybe ModelRateLimiter, + updateModelGuardrails :: Maybe Value, + updateModelInterface :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON UpdateModelRequest where + parseJSON = withObject "UpdateModelRequest" $ \v -> do + updateModelName <- v .:? "name" + updateModelDescription <- v .:? "description" + updateModelIsEnabled <- v .:? "is_enabled" + updateModelGroupId <- v .:? "model_group_id" + updateModelConfig <- v .:? "model_config" + updateModelConnectorId <- v .:? "connector_id" + updateModelConnector <- v .:? "connector" + updateModelRateLimiter <- v .:? "rate_limiter" + updateModelGuardrails <- v .:? "guardrails" + updateModelInterface <- v .:? "interface" + pure UpdateModelRequest {..} + +instance ToJSON UpdateModelRequest where + toJSON UpdateModelRequest {..} = + omitNulls + [ "name" .= updateModelName, + "description" .= updateModelDescription, + "is_enabled" .= updateModelIsEnabled, + "model_group_id" .= updateModelGroupId, + "model_config" .= updateModelConfig, + "connector_id" .= updateModelConnectorId, + "connector" .= updateModelConnector, + "rate_limiter" .= updateModelRateLimiter, + "guardrails" .= updateModelGuardrails, + "interface" .= updateModelInterface + ] + +-- | The @unit@ enum on the @rate_limiter@ sub-object. The ML Commons +-- plugin documents seven uppercase values matching Java +-- @TimeUnit@-style names. +data ModelRateLimiterUnit + = ModelRateLimiterUnitDays + | ModelRateLimiterUnitHours + | ModelRateLimiterUnitMicroseconds + | ModelRateLimiterUnitMilliseconds + | ModelRateLimiterUnitMinutes + | ModelRateLimiterUnitNanoseconds + | ModelRateLimiterUnitSeconds + deriving stock (Eq, Show) + +instance FromJSON ModelRateLimiterUnit where + parseJSON = withText "ModelRateLimiterUnit" $ \case + "DAYS" -> pure ModelRateLimiterUnitDays + "HOURS" -> pure ModelRateLimiterUnitHours + "MICROSECONDS" -> pure ModelRateLimiterUnitMicroseconds + "MILLISECONDS" -> pure ModelRateLimiterUnitMilliseconds + "MINUTES" -> pure ModelRateLimiterUnitMinutes + "NANOSECONDS" -> pure ModelRateLimiterUnitNanoseconds + "SECONDS" -> pure ModelRateLimiterUnitSeconds + other -> fail ("unknown rate_limiter unit: " <> T.unpack other) + +instance ToJSON ModelRateLimiterUnit where + toJSON = \case + ModelRateLimiterUnitDays -> "DAYS" + ModelRateLimiterUnitHours -> "HOURS" + ModelRateLimiterUnitMicroseconds -> "MICROSECONDS" + ModelRateLimiterUnitMilliseconds -> "MILLISECONDS" + ModelRateLimiterUnitMinutes -> "MINUTES" + ModelRateLimiterUnitNanoseconds -> "NANOSECONDS" + ModelRateLimiterUnitSeconds -> "SECONDS" + +-- | The @limit@ field on the @rate_limiter@ sub-object. The spec types +-- this as a @StringifiedDouble@: the server may emit it as a JSON number +-- or as a JSON string containing the decimal representation. Decoding +-- accepts both shapes; encoding always emits a JSON number. +newtype ModelRateLimit = ModelRateLimit {unModelRateLimit :: Double} + deriving stock (Eq, Ord, Show) + +instance FromJSON ModelRateLimit where + parseJSON (Number n) = pure (ModelRateLimit (realToFrac n)) + parseJSON (String s) = case readMay (T.unpack s) of + Just d -> pure (ModelRateLimit d) + Nothing -> fail ("invalid rate_limiter limit: " <> T.unpack s) + parseJSON v = typeMismatch "ModelRateLimit" v + +instance ToJSON ModelRateLimit where + toJSON (ModelRateLimit d) = toJSON d + +-- | The @rate_limiter@ sub-object on 'UpdateModelRequest'. Documented +-- with two fields: @limit@ (number) and @unit@ (string). Both are +-- 'Maybe' so partial updates of one field round-trip cleanly. +data ModelRateLimiter = ModelRateLimiter + { modelRateLimiterLimit :: Maybe ModelRateLimit, + modelRateLimiterUnit :: Maybe ModelRateLimiterUnit + } + deriving stock (Eq, Show) + +instance FromJSON ModelRateLimiter where + parseJSON = withObject "ModelRateLimiter" $ \v -> do + modelRateLimiterLimit <- v .:? "limit" + modelRateLimiterUnit <- v .:? "unit" + pure ModelRateLimiter {..} + +instance ToJSON ModelRateLimiter where + toJSON ModelRateLimiter {..} = + omitNulls + [ "limit" .= modelRateLimiterLimit, + "unit" .= modelRateLimiterUnit + ] + +-- | The @hits.total.relation@ discriminator on a model search +-- response. Mirrors the Security Analytics 'SARulesTotalRelation' +-- precedent: known values are decoded to specific constructors, and +-- any unknown value round-trips via 'ModelTotalRelationOther' so a +-- future plugin release does not break decoding. +data ModelTotalRelation + = ModelTotalRelationEq + | ModelTotalRelationGe + | ModelTotalRelationOther Text + deriving stock (Eq, Show) + +modelTotalRelationText :: ModelTotalRelation -> Text +modelTotalRelationText = \case + ModelTotalRelationEq -> "eq" + ModelTotalRelationGe -> "ge" + ModelTotalRelationOther t -> t + +instance ToJSON ModelTotalRelation where + toJSON = toJSON . modelTotalRelationText + +instance FromJSON ModelTotalRelation where + parseJSON = withText "ModelTotalRelation" $ \t -> + pure $ + case t of + "eq" -> ModelTotalRelationEq + "ge" -> ModelTotalRelationGe + other -> ModelTotalRelationOther other + +-- | The @hits.total@ sub-object on a model search response +-- (@{value, relation}@). +data ModelTotal = ModelTotal + { modelTotalValue :: Int64, + modelTotalRelation :: ModelTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON ModelTotal where + parseJSON = withObject "ModelTotal" $ \o -> + ModelTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON ModelTotal where + toJSON ModelTotal {..} = + object + [ "value" .= modelTotalValue, + "relation" .= modelTotalRelation + ] + +-- | The @_shards@ sub-object on a model search response. Defined +-- locally under an @Model@ prefix (mirroring the 'SARulesShards' +-- precedent) rather than re-using the cluster-level 'ShardsResult' +-- envelope, which wraps the outer @{\"_shards\": {...}}@ shape — one +-- level too high for inline use here. +data ModelShards = ModelShards + { modelShardsTotal :: Int, + modelShardsSuccessful :: Int, + modelShardsSkipped :: Int, + modelShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON ModelShards where + parseJSON = withObject "ModelShards" $ \o -> + ModelShards + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "skipped" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON ModelShards where + toJSON ModelShards {..} = + object + [ "total" .= modelShardsTotal, + "successful" .= modelShardsSuccessful, + "skipped" .= modelShardsSkipped, + "failed" .= modelShardsFailed + ] + +-- | A single hit in @hits.hits[]@ on a model search response. +data ModelHit = ModelHit + { modelHitIndex :: Maybe Text, + modelHitId :: Text, + modelHitVersion :: Maybe Int64, + modelHitSeqNo :: Maybe Int64, + modelHitPrimaryTerm :: Maybe Int64, + modelHitScore :: Maybe Double, + modelHitSource :: ModelInfo + } + deriving stock (Eq, Show) + +instance FromJSON ModelHit where + parseJSON = withObject "ModelHit" $ \o -> + ModelHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON ModelHit where + toJSON ModelHit {..} = + omitNulls + [ "_index" .= modelHitIndex, + "_id" .= modelHitId, + "_version" .= modelHitVersion, + "_seq_no" .= modelHitSeqNo, + "_primary_term" .= modelHitPrimaryTerm, + "_score" .= modelHitScore, + "_source" .= modelHitSource + ] + +-- | Response envelope for @POST /_plugins/_ml/models/_search@ and +-- @POST /_plugins/_ml/models/_list@. Decoded verbatim from the +-- standard OpenSearch search-response shape; the paging metadata +-- (@took@, @timed_out@, @_shards@, @hits.total@, @hits.max_score@) +-- is preserved alongside the model list so callers can drive +-- pagination and observe shard health. +data ModelSearchResponse = ModelSearchResponse + { modelSearchResponseTook :: Int64, + modelSearchResponseTimedOut :: Bool, + modelSearchResponseShards :: ModelShards, + modelSearchResponseTotal :: ModelTotal, + modelSearchResponseMaxScore :: Maybe Double, + modelSearchResponseHits :: [ModelHit] + } + deriving stock (Eq, Show) + +instance FromJSON ModelSearchResponse where + parseJSON = withObject "ModelSearchResponse" $ \o -> do + hits <- o .: "hits" + ModelSearchResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON ModelSearchResponse where + toJSON ModelSearchResponse {..} = + object + [ "took" .= modelSearchResponseTook, + "timed_out" .= modelSearchResponseTimedOut, + "_shards" .= modelSearchResponseShards, + "hits" + .= object + [ "total" .= modelSearchResponseTotal, + "max_score" .= modelSearchResponseMaxScore, + "hits" .= modelSearchResponseHits + ] + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLModelGroups.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLModelGroups.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLModelGroups.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLModelGroups + ( ModelGroupId (..), + ModelGroupAccessMode (..), + RegisterModelGroupRequest (..), + RegisterModelGroupResponse (..), + UpdateModelGroupRequest (..), + ModelGroupInfo (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), withObject, withText, (.:), (.:?), (.=)) +import Data.Int (Int64) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) + +-- $schema +-- +-- The ML Commons model group APIs (see +-- , +-- introduced in OS 2.12) group related model versions behind a shared +-- access policy. A model group is the unit of @access_mode@ (@public@, +-- @private@, @restricted@) and @backend_roles@ for model access control. +-- +-- /Naming asymmetry:/ the request bodies use the key @access_mode@, while +-- the get\/search responses use the shorter key @access@ for the same +-- value. This is reflected in the field decoders below. + +-- | A model-group identifier for the +-- @\/_plugins\/_ml\/model_groups\/{model_group_id}@ path segment, assigned +-- by the server on register. +newtype ModelGroupId = ModelGroupId {unModelGroupId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @access_mode@ (request) \/ @access@ (response) enum. The plugin +-- emits these as lower-case strings. Unknown values decode to +-- 'ModelGroupAccessModeOther' so a future plugin release adding a mode +-- the client does not know about round-trips losslessly instead of +-- throwing. +data ModelGroupAccessMode + = ModelGroupAccessModePublic + | ModelGroupAccessModePrivate + | ModelGroupAccessModeRestricted + | ModelGroupAccessModeOther Text + deriving stock (Eq, Show) + +modelGroupAccessModeText :: ModelGroupAccessMode -> Text +modelGroupAccessModeText = \case + ModelGroupAccessModePublic -> "public" + ModelGroupAccessModePrivate -> "private" + ModelGroupAccessModeRestricted -> "restricted" + ModelGroupAccessModeOther t -> t + +instance ToJSON ModelGroupAccessMode where + toJSON = toJSON . modelGroupAccessModeText + +instance FromJSON ModelGroupAccessMode where + parseJSON = withText "ModelGroupAccessMode" $ \t -> + pure $ + case t of + "public" -> ModelGroupAccessModePublic + "private" -> ModelGroupAccessModePrivate + "restricted" -> ModelGroupAccessModeRestricted + other -> ModelGroupAccessModeOther other + +-- | Request body for @POST /_plugins/_ml/model_groups/_register@. Only +-- @name@ is required; @access_mode@, @backend_roles@, and +-- @add_all_backend_roles@ govern model access control and are only +-- honoured when the cluster has model access control enabled. Exactly +-- one of @backend_roles@ \/ @add_all_backend_roles@ is valid when +-- @access_mode = "restricted"@. +data RegisterModelGroupRequest = RegisterModelGroupRequest + { registerModelGroupName :: Text, + registerModelGroupDescription :: Maybe Text, + registerModelGroupAccessMode :: Maybe ModelGroupAccessMode, + registerModelGroupBackendRoles :: Maybe [Text], + registerModelGroupAddAllBackendRoles :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON RegisterModelGroupRequest where + parseJSON = withObject "RegisterModelGroupRequest" $ \v -> do + registerModelGroupName <- v .: "name" + registerModelGroupDescription <- v .:? "description" + registerModelGroupAccessMode <- v .:? "access_mode" + registerModelGroupBackendRoles <- v .:? "backend_roles" + registerModelGroupAddAllBackendRoles <- v .:? "add_all_backend_roles" + pure RegisterModelGroupRequest {..} + +instance ToJSON RegisterModelGroupRequest where + toJSON RegisterModelGroupRequest {..} = + omitNulls + [ "name" .= registerModelGroupName, + "description" .= registerModelGroupDescription, + "access_mode" .= registerModelGroupAccessMode, + "backend_roles" .= registerModelGroupBackendRoles, + "add_all_backend_roles" .= registerModelGroupAddAllBackendRoles + ] + +-- | Response of @POST /_plugins/_ml/model_groups/_register@: +-- @{model_group_id, status}@. +data RegisterModelGroupResponse = RegisterModelGroupResponse + { registerModelGroupResponseId :: Maybe Text, + registerModelGroupResponseStatus :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RegisterModelGroupResponse where + parseJSON = withObject "RegisterModelGroupResponse" $ \v -> do + registerModelGroupResponseId <- v .:? "model_group_id" + registerModelGroupResponseStatus <- v .:? "status" + pure RegisterModelGroupResponse {..} + +instance ToJSON RegisterModelGroupResponse where + toJSON RegisterModelGroupResponse {..} = + omitNulls + [ "model_group_id" .= registerModelGroupResponseId, + "status" .= registerModelGroupResponseStatus + ] + +-- | Request body for @PUT /_plugins/_ml/model_groups/{model_group_id}@. +-- Every field is 'Maybe' because the update endpoint accepts a partial +-- body: only the supplied keys are written. +data UpdateModelGroupRequest = UpdateModelGroupRequest + { updateModelGroupName :: Maybe Text, + updateModelGroupDescription :: Maybe Text, + updateModelGroupAccessMode :: Maybe ModelGroupAccessMode, + updateModelGroupBackendRoles :: Maybe [Text], + updateModelGroupAddAllBackendRoles :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON UpdateModelGroupRequest where + parseJSON = withObject "UpdateModelGroupRequest" $ \v -> do + updateModelGroupName <- v .:? "name" + updateModelGroupDescription <- v .:? "description" + updateModelGroupAccessMode <- v .:? "access_mode" + updateModelGroupBackendRoles <- v .:? "backend_roles" + updateModelGroupAddAllBackendRoles <- v .:? "add_all_backend_roles" + pure UpdateModelGroupRequest {..} + +instance ToJSON UpdateModelGroupRequest where + toJSON UpdateModelGroupRequest {..} = + omitNulls + [ "name" .= updateModelGroupName, + "description" .= updateModelGroupDescription, + "access_mode" .= updateModelGroupAccessMode, + "backend_roles" .= updateModelGroupBackendRoles, + "add_all_backend_roles" .= updateModelGroupAddAllBackendRoles + ] + +-- | Response of @GET /_plugins/_ml/model_groups/{model_group_id}@ and the +-- per-hit @_source@ of @/_plugins/_ml/model_groups/_search@. Note the +-- response key is @access@ (not @access_mode@). +data ModelGroupInfo = ModelGroupInfo + { modelGroupName :: Maybe Text, + modelGroupLatestVersion :: Maybe Int64, + modelGroupDescription :: Maybe Text, + modelGroupAccess :: Maybe ModelGroupAccessMode, + modelGroupBackendRoles :: Maybe [Text], + modelGroupCreatedTime :: Maybe Int64, + modelGroupLastUpdatedTime :: Maybe Int64 + } + deriving stock (Eq, Show) + +instance FromJSON ModelGroupInfo where + parseJSON = withObject "ModelGroupInfo" $ \v -> do + modelGroupName <- v .:? "name" + modelGroupLatestVersion <- v .:? "latest_version" + modelGroupDescription <- v .:? "description" + modelGroupAccess <- v .:? "access" + modelGroupBackendRoles <- v .:? "backend_roles" + modelGroupCreatedTime <- v .:? "created_time" + modelGroupLastUpdatedTime <- v .:? "last_updated_time" + pure ModelGroupInfo {..} + +instance ToJSON ModelGroupInfo where + toJSON ModelGroupInfo {..} = + omitNulls + [ "name" .= modelGroupName, + "latest_version" .= modelGroupLatestVersion, + "description" .= modelGroupDescription, + "access" .= modelGroupAccess, + "backend_roles" .= modelGroupBackendRoles, + "created_time" .= modelGroupCreatedTime, + "last_updated_time" .= modelGroupLastUpdatedTime + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLProfile.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLProfile.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLProfile.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLProfile + ( MLProfileRequest (..), + MLProfilePredictRequestStats (..), + MLProfileModel (..), + MLProfileNode (..), + MLProfileResponse (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value, object, withObject, (.:?), (.=)) +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as M +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLModel + ( ModelState (..), + ) + +-- $schema +-- +-- The ML Commons profile API (see +-- ) is a +-- single GET endpoint with five path forms that reports runtime +-- information about deployed models and ML tasks, keyed by ML worker +-- node: +-- +-- * @GET /_plugins/_ml/profile@ +-- * @GET /_plugins/_ml/profile/models@ +-- * @GET /_plugins/_ml/profile/models/{model_id}@ +-- * @GET /_plugins/_ml/profile/tasks@ +-- * @GET /_plugins/_ml/profile/tasks/{task_id}@ +-- +-- The @model_id@ \/ @task_id@ path segments accept comma-separated values +-- to fetch multiple profiles at once. The bare @_profile@ form +-- additionally accepts an optional request body (modelled here as +-- 'MLProfileRequest') to filter by node and to toggle task \/ model +-- inclusion. +-- +-- The response is a node-keyed envelope (@{\"nodes\": {...}}@); each node +-- in turn carries a model-keyed map of per-model runtime state +-- ('MLProfileModel'), including latency percentile stats +-- ('MLProfilePredictRequestStats'). By default the plugin monitors the +-- last 100 predict requests (configurable via the +-- @plugins.ml_commons.monitoring_request_count@ cluster setting). + +-- | Optional request body for the bare @GET /_plugins/_ml/profile@ form. +-- All fields are optional: @node_ids@ restricts to specific nodes, +-- @model_ids@ \/ @task_ids@ restrict to specific models \/ tasks, and +-- the two @return_all_*@ flags toggle whether task \/ model profiles are +-- included (default true for both). +data MLProfileRequest = MLProfileRequest + { mlProfileRequestNodeIds :: Maybe [Text], + mlProfileRequestModelIds :: Maybe [Text], + mlProfileRequestTaskIds :: Maybe [Text], + mlProfileRequestReturnAllTasks :: Maybe Bool, + mlProfileRequestReturnAllModels :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON MLProfileRequest where + parseJSON = withObject "MLProfileRequest" $ \v -> do + mlProfileRequestNodeIds <- v .:? "node_ids" + mlProfileRequestModelIds <- v .:? "model_ids" + mlProfileRequestTaskIds <- v .:? "task_ids" + mlProfileRequestReturnAllTasks <- v .:? "return_all_tasks" + mlProfileRequestReturnAllModels <- v .:? "return_all_models" + pure MLProfileRequest {..} + +instance ToJSON MLProfileRequest where + toJSON MLProfileRequest {..} = + omitNulls + [ "node_ids" .= mlProfileRequestNodeIds, + "model_ids" .= mlProfileRequestModelIds, + "task_ids" .= mlProfileRequestTaskIds, + "return_all_tasks" .= mlProfileRequestReturnAllTasks, + "return_all_models" .= mlProfileRequestReturnAllModels + ] + +-- | The @predict_request_stats@ sub-object on a model profile: latency +-- in milliseconds. @count@ is an integer; the percentile and aggregate +-- fields are floats. Every field is 'Maybe' because a model that has not +-- yet served a predict emits only @count = 0@ (or omits stats entirely). +data MLProfilePredictRequestStats = MLProfilePredictRequestStats + { mlProfileStatsCount :: Maybe Integer, + mlProfileStatsMax :: Maybe Double, + mlProfileStatsMin :: Maybe Double, + mlProfileStatsAverage :: Maybe Double, + mlProfileStatsP50 :: Maybe Double, + mlProfileStatsP90 :: Maybe Double, + mlProfileStatsP99 :: Maybe Double + } + deriving stock (Eq, Show) + +instance FromJSON MLProfilePredictRequestStats where + parseJSON = withObject "MLProfilePredictRequestStats" $ \v -> do + mlProfileStatsCount <- v .:? "count" + mlProfileStatsMax <- v .:? "max" + mlProfileStatsMin <- v .:? "min" + mlProfileStatsAverage <- v .:? "average" + mlProfileStatsP50 <- v .:? "p50" + mlProfileStatsP90 <- v .:? "p90" + mlProfileStatsP99 <- v .:? "p99" + pure MLProfilePredictRequestStats {..} + +instance ToJSON MLProfilePredictRequestStats where + toJSON MLProfilePredictRequestStats {..} = + omitNulls + [ "count" .= mlProfileStatsCount, + "max" .= mlProfileStatsMax, + "min" .= mlProfileStatsMin, + "average" .= mlProfileStatsAverage, + "p50" .= mlProfileStatsP50, + "p90" .= mlProfileStatsP90, + "p99" .= mlProfileStatsP99 + ] + +-- | Per-model runtime state under a node. @worker_nodes@ is the plugin's +-- routing table for the model (which nodes host chunks). @predictor@ is +-- an opaque JVM class handle string. +data MLProfileModel = MLProfileModel + { mlProfileModelModelState :: Maybe ModelState, + mlProfileModelPredictor :: Maybe Text, + mlProfileModelWorkerNodes :: Maybe [Text], + mlProfileModelPredictRequestStats :: Maybe MLProfilePredictRequestStats + } + deriving stock (Eq, Show) + +instance FromJSON MLProfileModel where + parseJSON = withObject "MLProfileModel" $ \v -> do + mlProfileModelModelState <- v .:? "model_state" + mlProfileModelPredictor <- v .:? "predictor" + mlProfileModelWorkerNodes <- v .:? "worker_nodes" + mlProfileModelPredictRequestStats <- v .:? "predict_request_stats" + pure MLProfileModel {..} + +instance ToJSON MLProfileModel where + toJSON MLProfileModel {..} = + omitNulls + [ "model_state" .= mlProfileModelModelState, + "predictor" .= mlProfileModelPredictor, + "worker_nodes" .= mlProfileModelWorkerNodes, + "predict_request_stats" .= mlProfileModelPredictRequestStats + ] + +-- | Per-node entry in the profile response. The @models@ map is keyed by +-- model id; @tasks@ is optional (present when @return_all_tasks@ is +-- true). @tasks@ is kept as an opaque 'Value' because its sub-shape is +-- plugin-version-dependent and the typed surface above only models the +-- model-profile form. +data MLProfileNode = MLProfileNode + { mlProfileNodeModels :: M.Map Text MLProfileModel, + mlProfileNodeTasks :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON MLProfileNode where + parseJSON = withObject "MLProfileNode" $ \v -> do + mModels <- v .:? "models" + let mlProfileNodeModels = case mModels of + Nothing -> M.empty + Just o -> M.fromList [(toText k, r) | (k, r) <- KM.toList o] + mlProfileNodeTasks <- v .:? "tasks" + pure MLProfileNode {..} + +instance ToJSON MLProfileNode where + toJSON MLProfileNode {..} = + omitNulls + [ "models" .= object [fromText k .= toJSON m | (k, m) <- M.toList mlProfileNodeModels], + "tasks" .= mlProfileNodeTasks + ] + +-- | Response of every @GET /_plugins/_ml/profile*@ form: +-- @{\"nodes\": {: {...}}}@. +newtype MLProfileResponse = MLProfileResponse + { mlProfileResponseNodes :: M.Map Text MLProfileNode + } + deriving stock (Eq, Show) + +instance FromJSON MLProfileResponse where + parseJSON = withObject "MLProfileResponse" $ \v -> do + mNodes <- v .:? "nodes" + let mlProfileResponseNodes = case mNodes of + Nothing -> M.empty + Just o -> M.fromList [(toText k, r) | (k, r) <- KM.toList o] + pure MLProfileResponse {..} + +instance ToJSON MLProfileResponse where + toJSON (MLProfileResponse m) = + object + [ "nodes" .= object [fromText k .= toJSON n | (k, n) <- M.toList m] + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLStats.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLStats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLStats.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLStats + ( MLNodeId (..), + MLStatName (..), + MLStats (..), + ) +where + +import Data.Map.Strict qualified as Map +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The @GET /_plugins/_ml\/stats@ endpoint (ML Commons plugin, see +-- ) returns +-- a JSON object whose top-level keys are either cluster-level stat names +-- (mapping to scalars, e.g. @ml_model_count@, @ml_connector_count@, +-- @ml_model_index_status@) or the literal key @nodes@, whose value is a +-- per-node map keyed by opaque node ID. The stat-name set is large and +-- explicitly version-gated by the plugin (each stat carries the OpenSearch +-- version that introduced it), and the cluster-level stat keys are not +-- syntactically distinguishable from the @nodes@ key (both are bare JSON +-- object keys). Modelling the body as a typed record would lock the client +-- to one plugin version and require churn on every release, so the body is +-- kept as a flat 'Map.Map Text Value' — callers get a typed envelope and +-- navigate to the per-node map (via @'Map.lookup' \"nodes\"@) or to any +-- individual cluster stat with the aeson combinators they already use +-- elsewhere. +-- +-- Unlike the Neural Search plugin's @\/_plugins\/_neural\/stats@ endpoint, +-- this endpoint is always available whenever the ML Commons plugin is +-- installed; no cluster setting needs to be enabled. + +-- | A node ID for the ML Commons plugin's +-- @\/_plugins\/_ml\/{nodeId}\/stats@ path segment. OpenSearch uses +-- 22-character opaque node IDs (the same identifiers returned by +-- @GET \/_nodes@); we wrap 'Text' so the value round-trips through JSON as a +-- bare string but is distinct from 'NodeName' \/ 'FullNodeId' / +-- 'NeuralNodeId' at the type level. +newtype MLNodeId = MLNodeId {unMLNodeId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A stat name filter for the +-- @\/_plugins\/_ml\/stats\/{stat}@ path segment. Each value matches one of +-- the plugin's stat-name constants (case-insensitive on the server); the +-- full set changes across OpenSearch releases, so this is intentionally a +-- thin 'Text' newtype rather than a closed enum. Representative values +-- include @ml_executing_task_count@, @ml_request_count@, @ml_failure_count@, +-- @ml_jvm_heap_usage@, @ml_deployed_model_count@, +-- @ml_circuit_breaker_trigger_count@ (node-level), and @ml_model_count@, +-- @ml_connector_count@, @ml_model_index_status@ (cluster-level). +newtype MLStatName = MLStatName {unMLStatName :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Response of @GET /_plugins/_ml/stats@. The body is a JSON object whose +-- top-level keys are either cluster-level stat names (mapping to scalars) or +-- the literal key @nodes@ (mapping to a per-node map keyed by opaque node +-- ID); see the module docs for why the entries are kept as aeson 'Value's +-- rather than modelled per-stat. The 'Map.Map' round-trips a flat JSON +-- object via its aeson instances, so no custom 'ToJSON' \/ 'FromJSON' is +-- needed. To reach per-node stats, decode the @nodes@ value, e.g.: +-- +-- @ +-- case 'Map.lookup' \"nodes\" (mlStatsEntries stats) of +-- 'Just' ('Object' m) -> ... navigate m with aeson KeyMap combinators ... +-- _ -> 'Nothing' +-- @ +newtype MLStats = MLStats {mlStatsEntries :: Map.Map Text Value} + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLTask.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLTask.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/MLTask.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLTask + ( MLTaskId (..), + MLTaskType (..), + MLTaskState (..), + MLTaskInfo (..), + TrainModelRequest (..), + TrainAndPredictResponse (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withObject, withText, (.:), (.:?), (.=)) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Vector (toList) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) + +-- $schema +-- +-- The @GET /_plugins/_ml/tasks/{task_id}@ endpoint +-- () +-- returns the current state of a single ML Commons task. Tasks are created by +-- the asynchronous model APIs (@POST /_plugins/_ml/models/_register@, +-- @POST /_plugins/_ml/models/{id}/_deploy@, training, ...) and survive until +-- they are cleaned up by the plugin. A caller polls 'getMLTask' with the +-- @task_id@ returned by the submit endpoint until 'mlTaskInfoState' reaches +-- 'MLTaskStateCompleted' or 'MLTaskStateFailed'. +-- +-- The response shape is small and stable, so it is modelled as a typed +-- record. Every field is 'Maybe' because the plugin emits different subsets +-- depending on the task's lifecycle state (a @CREATED@ task has no +-- @last_update_time@; a @FAILED@ task carries an @error@ string; etc.) and +-- because the @task_type@ \/ @state@ enums gain values across plugin +-- releases. The enum decoders fall through to an @Other@ constructor for +-- unknown values rather than failing, so a newer plugin emitting a task type +-- the client does not know about round-trips losslessly instead of throwing +-- — the same forward-compatibility rationale documented for the dynamic +-- bodies of 'Database.Bloodhound.OpenSearch3.Types.NeuralStats'. +-- +-- /Note/: the @worker_node@ field changed shape between OpenSearch versions. +-- OS 1.x emits a single string; OS 2.x+ emits an array of strings. The +-- 'FromJSON' instance tolerates both shapes (coercing a single string to a +-- one-element list) so the same client works against every backend version +-- without forcing a parse failure on either. + +-- | A task identifier for the ML Commons plugin's +-- @\/_plugins\/_ml\/tasks\/{task_id}@ path segment. The value is the opaque +-- string returned in the @task_id@ field of @POST /_plugins/_ml/models/_register@ +-- and friends; we wrap 'Text' so the value round-trips through JSON as a bare +-- string but is distinct from 'KnnNodeId' \/ 'NeuralNodeId' \/ the ES-core +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Task.TaskInfo' id at the +-- type level. +newtype MLTaskId = MLTaskId {unMLTaskId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @task_type@ enum reported by 'getMLTask'. The plugin emits this as an +-- upper-snake-case string (@REGISTER_MODEL@, @DEPLOY_MODEL@, ...). The set +-- grows across releases (remote / streaming / async variants landed in OS 2.x +-- and 3.x); unknown values decode to 'MLTaskTypeOther' so the client does not +-- break when polling a task whose type the library has not been taught about. +data MLTaskType + = MLTaskTypeRegisterModel + | MLTaskTypeDeployModel + | MLTaskTypeTraining + | MLTaskTypeRegisterRemoteModel + | MLTaskTypeDeployRemoteModel + | MLTaskTypeOther Text + deriving stock (Eq, Show) + +instance ToJSON MLTaskType where + toJSON = toJSON . renderMLTaskType + +instance FromJSON MLTaskType where + parseJSON = withText "MLTaskType" $ \case + "REGISTER_MODEL" -> pure MLTaskTypeRegisterModel + "DEPLOY_MODEL" -> pure MLTaskTypeDeployModel + "TRAINING" -> pure MLTaskTypeTraining + "REGISTER_REMOTE_MODEL" -> pure MLTaskTypeRegisterRemoteModel + "DEPLOY_REMOTE_MODEL" -> pure MLTaskTypeDeployRemoteModel + other -> pure (MLTaskTypeOther other) + +renderMLTaskType :: MLTaskType -> Text +renderMLTaskType = \case + MLTaskTypeRegisterModel -> "REGISTER_MODEL" + MLTaskTypeDeployModel -> "DEPLOY_MODEL" + MLTaskTypeTraining -> "TRAINING" + MLTaskTypeRegisterRemoteModel -> "REGISTER_REMOTE_MODEL" + MLTaskTypeDeployRemoteModel -> "DEPLOY_REMOTE_MODEL" + MLTaskTypeOther t -> t + +-- | The @state@ enum reported by 'getMLTask'. The lifecycle is +-- @CREATED -> RUNNING -> COMPLETED@ on success or @FAILED@ on error; the +-- plugin additionally emits @NOT_FOUND@ when the supplied task id has been +-- cleaned up. Unknown values decode to 'MLTaskStateOther' for forward +-- compatibility. +data MLTaskState + = MLTaskStateCreated + | MLTaskStateRunning + | MLTaskStateCompleted + | MLTaskStateFailed + | MLTaskStateNotFound + | MLTaskStateOther Text + deriving stock (Eq, Show) + +instance ToJSON MLTaskState where + toJSON = toJSON . renderMLTaskState + +instance FromJSON MLTaskState where + parseJSON = withText "MLTaskState" $ \case + "CREATED" -> pure MLTaskStateCreated + "RUNNING" -> pure MLTaskStateRunning + "COMPLETED" -> pure MLTaskStateCompleted + "FAILED" -> pure MLTaskStateFailed + "NOT_FOUND" -> pure MLTaskStateNotFound + other -> pure (MLTaskStateOther other) + +renderMLTaskState :: MLTaskState -> Text +renderMLTaskState = \case + MLTaskStateCreated -> "CREATED" + MLTaskStateRunning -> "RUNNING" + MLTaskStateCompleted -> "COMPLETED" + MLTaskStateFailed -> "FAILED" + MLTaskStateNotFound -> "NOT_FOUND" + MLTaskStateOther t -> t + +-- | Response of @GET /_plugins/_ml/tasks/{task_id}@. Every field is 'Maybe' +-- because the plugin emits different subsets depending on the task's +-- lifecycle state and the OpenSearch version (see the module-level docs). +data MLTaskInfo = MLTaskInfo + { mlTaskInfoTaskId :: Maybe Text, + mlTaskInfoModelId :: Maybe Text, + mlTaskInfoTaskType :: Maybe MLTaskType, + mlTaskInfoFunctionName :: Maybe Text, + mlTaskInfoState :: Maybe MLTaskState, + mlTaskInfoWorkerNode :: Maybe [Text], + mlTaskInfoCreateTime :: Maybe Int64, + mlTaskInfoLastUpdateTime :: Maybe Int64, + mlTaskInfoIsAsync :: Maybe Bool, + mlTaskInfoError :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON MLTaskInfo where + parseJSON = withObject "MLTaskInfo" $ \o -> do + mlTaskInfoTaskId <- o .:? "task_id" + mlTaskInfoModelId <- o .:? "model_id" + mlTaskInfoTaskType <- o .:? "task_type" + mlTaskInfoFunctionName <- o .:? "function_name" + mlTaskInfoState <- o .:? "state" + mWorkerNode <- o .:? "worker_node" + let mlTaskInfoWorkerNode = case mWorkerNode of + Nothing -> Nothing + Just (String s) -> Just [s] + Just (Array xs) -> Just [t | String t <- toList xs] + Just _ -> Nothing + mlTaskInfoCreateTime <- o .:? "create_time" + mlTaskInfoLastUpdateTime <- o .:? "last_update_time" + mlTaskInfoIsAsync <- o .:? "is_async" + mlTaskInfoError <- o .:? "error" + return MLTaskInfo {..} + +instance ToJSON MLTaskInfo where + toJSON MLTaskInfo {..} = + omitNulls + [ "task_id" .= mlTaskInfoTaskId, + "model_id" .= mlTaskInfoModelId, + "task_type" .= mlTaskInfoTaskType, + "function_name" .= mlTaskInfoFunctionName, + "state" .= mlTaskInfoState, + "worker_node" .= mlTaskInfoWorkerNode, + "create_time" .= mlTaskInfoCreateTime, + "last_update_time" .= mlTaskInfoLastUpdateTime, + "is_async" .= mlTaskInfoIsAsync, + "error" .= mlTaskInfoError + ] + +-- ========================================================================= +-- Train and train-predict +-- ========================================================================= + +-- $train +-- +-- The @POST /_plugins/_ml/_train/{algorithm}@ and +-- @POST /_plugins/_ml/_train_predict/{algorithm}@ endpoints (see +-- ) +-- run a classical algorithm (kmeans, RCF, ...) against either an +-- index-sourced dataset (@input_query@ + @input_index@) or inline data +-- (@input_data@). The @parameters@ object is algorithm-specific. +-- +-- /Responses:/ train is sync by default (returns @model_id@ + @status@) +-- and async when @?async=true@ is set (returns @task_id@ + @status@). +-- Both shapes are subsets of 'MLTaskAck', so the train request functions +-- reuse 'MLTaskAck' as their response type. Train-predict is always sync +-- and returns the prediction payload, modelled as +-- 'TrainAndPredictResponse'. + +-- | Request body for @POST /_plugins/_ml/_train/{algorithm}@ and +-- @POST /_plugins/_ml/_train_predict/{algorithm}@. Exactly one of +-- @input_query@+@input_index@ or @input_data@ must be supplied; the +-- plugin validates the combination. @parameters@ is required and +-- algorithm-specific, so it is an opaque 'Value'. +data TrainModelRequest = TrainModelRequest + { trainModelParameters :: Value, + trainModelInputQuery :: Maybe Value, + trainModelInputIndex :: Maybe [Text], + trainModelInputData :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON TrainModelRequest where + parseJSON = withObject "TrainModelRequest" $ \v -> do + trainModelParameters <- v .: "parameters" + trainModelInputQuery <- v .:? "input_query" + trainModelInputIndex <- v .:? "input_index" + trainModelInputData <- v .:? "input_data" + pure TrainModelRequest {..} + +instance ToJSON TrainModelRequest where + toJSON TrainModelRequest {..} = + omitNulls + [ "parameters" .= trainModelParameters, + "input_query" .= trainModelInputQuery, + "input_index" .= trainModelInputIndex, + "input_data" .= trainModelInputData + ] + +-- | Response of @POST /_plugins/_ml/_train_predict/{algorithm}@: +-- @{status, prediction_result}@. The @prediction_result@ payload carries +-- @column_metas@ and @rows@ whose shape is algorithm-specific, so it is +-- kept as an opaque 'Value'. +data TrainAndPredictResponse = TrainAndPredictResponse + { trainAndPredictResponseStatus :: Maybe Text, + trainAndPredictResponsePredictionResult :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON TrainAndPredictResponse where + parseJSON = withObject "TrainAndPredictResponse" $ \v -> do + trainAndPredictResponseStatus <- v .:? "status" + trainAndPredictResponsePredictionResult <- v .:? "prediction_result" + pure TrainAndPredictResponse {..} + +instance ToJSON TrainAndPredictResponse where + toJSON TrainAndPredictResponse {..} = + omitNulls + [ "status" .= trainAndPredictResponseStatus, + "prediction_result" .= trainAndPredictResponsePredictionResult + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/Notifications.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/Notifications.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/Notifications.hs @@ -0,0 +1,1021 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.Notifications + ( NotificationConfigType (..), + notificationConfigTypeText, + NotificationTransport (..), + NotificationConfig (..), + NotificationConfigEntry (..), + GetNotificationConfigsResponse (..), + Channel (..), + GetNotificationChannelsResponse (..), + NotificationSortOrder (..), + notificationSortOrderText, + NotificationListOptions (..), + defaultNotificationListOptions, + notificationListOptionsParams, + CreateNotificationConfigRequest (..), + CreateNotificationConfigResponse (..), + UpdateNotificationConfigRequest (..), + DeleteNotificationConfigResponse (..), + deleteResponseStatus, + deleteResponseAllOK, + NotificationFeaturesResponse (..), + TestNotificationResponse (..), + TestNotificationEventSource (..), + TestNotificationStatus (..), + TestNotificationDeliveryStatus (..), + SlackTransport (..), + ChimeTransport (..), + WebhookTransport (..), + MicrosoftTeamsTransport (..), + SnsTransport (..), + SesAccountTransport (..), + SmtpAccountTransport (..), + SmtpMethod (..), + EmailGroupTransport (..), + EmailTransport (..), + EmailRecipient (..), + NotificationTotalRelation (..), + transportConfigType, + ) +where + +import Data.Aeson.Key qualified as K (fromText) +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports +import Numeric.Natural (Natural) + +-- $schema +-- +-- The Notifications plugin (see +-- ) +-- centralizes outbound notification delivery for other OpenSearch plugins +-- (Alerting, Index State Management, Anomaly Detection, ...). A +-- 'NotificationConfig' binds a user-chosen name and description to a +-- /transport/ — the concrete delivery channel (Slack, Chime, Webhook, +-- Microsoft Teams, Amazon SNS, Amazon SES, SMTP account, email group, +-- or a fully-formed Email channel). +-- +-- The plugin is shipped with OpenSearch 2.0+; it is not present on 1.x +-- clusters, hence this module exists only for OS2 and OS3. +-- +-- The wire shape of a 'NotificationConfig' is a flat JSON object whose +-- @config_type@ field names the transport variant, and which additionally +-- embeds /exactly one/ transport object under a variant-specific key +-- (@slack@, @chime@, @webhook@, @microsoft_teams@, @sns@, @ses_account@, +-- @smtp_account@, @email_group@, @email@). The Haskell surface models +-- this as a sum type ('NotificationTransport') and derives the +-- @config_type@ tag from the chosen variant via 'transportConfigType', so +-- a 'NotificationConfig' cannot be constructed with an inconsistent +-- (config_type, transport) pair. +-- +-- The create endpoint is asynchronous and synchronous at once: the POST +-- returns as soon as the config is persisted to the +-- @.opendistro-notifications-config@ system index, echoing the new +-- @config_id@ (server-assigned unless the caller supplies one). There is +-- no task to poll. +-- +-- Doc ambiguities handled here deliberately: +-- +-- * The plugin docs show both @config_id@ and @id@ as the top-level +-- identifier on POST. We read only @config_id@; a body carrying @id@ +-- instead parses to a request with @config_id = Nothing@ (aeson +-- ignores unknown fields), so the server will generate one regardless. +-- * The @email.recipient_list@ example is shown both as +-- @[\"a\@b.com\"]\@@ (bare strings) and @[{\"recipient\":\"a\@b.com\"}]\@@ +-- (objects); the @email_group@ example is object-shaped. We accept +-- both shapes on decode (see 'EmailRecipient'); 'ToJSON' always emits +-- the object form, so a bare-string input round-trips to the object +-- form. +-- * @smtp_account.method@ values are not fully enumerated in the docs; +-- the field is typed as 'Text' (not a closed enum) so adding a new +-- method (e.g. @none@ vs @ssl@ vs @start_tls@) does not require a +-- library release. + +-- | The 9-variant @config_type@ enum documented at +-- . +-- Serialization is lower-snake to match the wire shape exactly +-- (@ses_account@, @smtp_account@, @email_group@, @microsoft_teams@). +-- Unknown values parse-fail so a future plugin release adding a tenth +-- config type surfaces as a deliberate error rather than a silent drop. +data NotificationConfigType + = NotificationConfigTypeSlack + | NotificationConfigTypeChime + | NotificationConfigTypeWebhook + | NotificationConfigTypeMicrosoftTeams + | NotificationConfigTypeSns + | NotificationConfigTypeSesAccount + | NotificationConfigTypeSmtpAccount + | NotificationConfigTypeEmailGroup + | NotificationConfigTypeEmail + deriving stock (Eq, Show) + +instance ToJSON NotificationConfigType where + toJSON = \case + NotificationConfigTypeSlack -> "slack" + NotificationConfigTypeChime -> "chime" + NotificationConfigTypeWebhook -> "webhook" + NotificationConfigTypeMicrosoftTeams -> "microsoft_teams" + NotificationConfigTypeSns -> "sns" + NotificationConfigTypeSesAccount -> "ses_account" + NotificationConfigTypeSmtpAccount -> "smtp_account" + NotificationConfigTypeEmailGroup -> "email_group" + NotificationConfigTypeEmail -> "email" + +instance FromJSON NotificationConfigType where + parseJSON = withText "NotificationConfigType" $ \case + "slack" -> pure NotificationConfigTypeSlack + "chime" -> pure NotificationConfigTypeChime + "webhook" -> pure NotificationConfigTypeWebhook + "microsoft_teams" -> pure NotificationConfigTypeMicrosoftTeams + "sns" -> pure NotificationConfigTypeSns + "ses_account" -> pure NotificationConfigTypeSesAccount + "smtp_account" -> pure NotificationConfigTypeSmtpAccount + "email_group" -> pure NotificationConfigTypeEmailGroup + "email" -> pure NotificationConfigTypeEmail + other -> fail ("Unknown NotificationConfigType: " <> T.unpack other) + +-- | The wire string for a 'NotificationConfigType' — the same mapping +-- the 'ToJSON' \/ 'FromJSON' instances use, exposed as a plain 'Text' +-- accessor for callers (e.g. 'notificationListOptionsParams') that +-- need the wire string without going through a 'Data.Aeson.Value'. +notificationConfigTypeText :: NotificationConfigType -> Text +notificationConfigTypeText = \case + NotificationConfigTypeSlack -> "slack" + NotificationConfigTypeChime -> "chime" + NotificationConfigTypeWebhook -> "webhook" + NotificationConfigTypeMicrosoftTeams -> "microsoft_teams" + NotificationConfigTypeSns -> "sns" + NotificationConfigTypeSesAccount -> "ses_account" + NotificationConfigTypeSmtpAccount -> "smtp_account" + NotificationConfigTypeEmailGroup -> "email_group" + NotificationConfigTypeEmail -> "email" + +-- | The transport sum type. Each variant corresponds to exactly one +-- 'NotificationConfigType' (see 'transportConfigType') and serializes to +-- a single wire key matching that type. Construct a +-- 'NotificationTransport' first; the surrounding 'NotificationConfig' +-- derives its @config_type@ from the variant. +data NotificationTransport + = NotificationTransportSlack SlackTransport + | NotificationTransportChime ChimeTransport + | NotificationTransportWebhook WebhookTransport + | NotificationTransportMicrosoftTeams MicrosoftTeamsTransport + | NotificationTransportSns SnsTransport + | NotificationTransportSesAccount SesAccountTransport + | NotificationTransportSmtpAccount SmtpAccountTransport + | NotificationTransportEmailGroup EmailGroupTransport + | NotificationTransportEmail EmailTransport + deriving stock (Eq, Show) + +-- | Recover the 'NotificationConfigType' tag from a 'NotificationTransport'. +-- Used by 'NotificationConfig''s 'ToJSON' to emit a @config_type@ field +-- consistent with the chosen variant, and by tests to assert cross-variant +-- invariants. +transportConfigType :: NotificationTransport -> NotificationConfigType +transportConfigType = \case + NotificationTransportSlack _ -> NotificationConfigTypeSlack + NotificationTransportChime _ -> NotificationConfigTypeChime + NotificationTransportWebhook _ -> NotificationConfigTypeWebhook + NotificationTransportMicrosoftTeams _ -> NotificationConfigTypeMicrosoftTeams + NotificationTransportSns _ -> NotificationConfigTypeSns + NotificationTransportSesAccount _ -> NotificationConfigTypeSesAccount + NotificationTransportSmtpAccount _ -> NotificationConfigTypeSmtpAccount + NotificationTransportEmailGroup _ -> NotificationConfigTypeEmailGroup + NotificationTransportEmail _ -> NotificationConfigTypeEmail + +-- | Produce the single wire key\/value pair carried by a transport variant. +transportPair :: NotificationTransport -> (Key, Value) +transportPair = \case + NotificationTransportSlack t -> ("slack", toJSON t) + NotificationTransportChime t -> ("chime", toJSON t) + NotificationTransportWebhook t -> ("webhook", toJSON t) + NotificationTransportMicrosoftTeams t -> ("microsoft_teams", toJSON t) + NotificationTransportSns t -> ("sns", toJSON t) + NotificationTransportSesAccount t -> ("ses_account", toJSON t) + NotificationTransportSmtpAccount t -> ("smtp_account", toJSON t) + NotificationTransportEmailGroup t -> ("email_group", toJSON t) + NotificationTransportEmail t -> ("email", toJSON t) + +instance ToJSON NotificationTransport where + toJSON t = object [transportPair t] + +instance FromJSON NotificationTransport where + parseJSON = withObject "NotificationTransport" $ \v -> do + -- Exactly one transport key may be present; the plugin rejects + -- multi-transport bodies server-side. We mirror that here by + -- checking which known keys are present and failing on zero or + -- multiple. This catches wire bugs (e.g. a body that accidentally + -- carries both @slack@ and @chime@) at decode time rather than + -- letting aeson silently pick the first matching variant. + let known = + [ ("slack", NotificationTransportSlack <$> v .: "slack"), + ("chime", NotificationTransportChime <$> v .: "chime"), + ("webhook", NotificationTransportWebhook <$> v .: "webhook"), + ("microsoft_teams", NotificationTransportMicrosoftTeams <$> v .: "microsoft_teams"), + ("sns", NotificationTransportSns <$> v .: "sns"), + ("ses_account", NotificationTransportSesAccount <$> v .: "ses_account"), + ("smtp_account", NotificationTransportSmtpAccount <$> v .: "smtp_account"), + ("email_group", NotificationTransportEmailGroup <$> v .: "email_group"), + ("email", NotificationTransportEmail <$> v .: "email") + ] + present = [parser | (key, parser) <- known, KM.member (K.fromText key) v] + case present of + [single] -> single + [] -> fail "NotificationTransport: no transport key present" + _ -> fail "NotificationTransport: multiple transport keys present" + +-- | Slack incoming-webhook transport. The @url@ field is the +-- @https:\/\/hooks.slack.com\/...@ webhook the plugin POSTs the message +-- payload to. +newtype SlackTransport = SlackTransport + { slackTransportUrl :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SlackTransport where + parseJSON = withObject "SlackTransport" $ \v -> + SlackTransport <$> v .: "url" + +instance ToJSON SlackTransport where + toJSON SlackTransport {..} = + object ["url" .= slackTransportUrl] + +-- | Amazon Chime incoming-webhook transport. +newtype ChimeTransport = ChimeTransport + { chimeTransportUrl :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ChimeTransport where + parseJSON = withObject "ChimeTransport" $ \v -> + ChimeTransport <$> v .: "url" + +instance ToJSON ChimeTransport where + toJSON ChimeTransport {..} = + object ["url" .= chimeTransportUrl] + +-- | Generic webhook transport (custom HTTP endpoint). +newtype WebhookTransport = WebhookTransport + { webhookTransportUrl :: Text + } + deriving stock (Eq, Show) + +instance FromJSON WebhookTransport where + parseJSON = withObject "WebhookTransport" $ \v -> + WebhookTransport <$> v .: "url" + +instance ToJSON WebhookTransport where + toJSON WebhookTransport {..} = + object ["url" .= webhookTransportUrl] + +-- | Microsoft Teams incoming-webhook transport. +newtype MicrosoftTeamsTransport = MicrosoftTeamsTransport + { microsoftTeamsTransportUrl :: Text + } + deriving stock (Eq, Show) + +instance FromJSON MicrosoftTeamsTransport where + parseJSON = withObject "MicrosoftTeamsTransport" $ \v -> + MicrosoftTeamsTransport <$> v .: "url" + +instance ToJSON MicrosoftTeamsTransport where + toJSON MicrosoftTeamsTransport {..} = + object ["url" .= microsoftTeamsTransportUrl] + +-- | Amazon SNS transport. The plugin assumes an IAM role (@role_arn@, +-- optional — the plugin falls back to the cluster's instance role when +-- absent) and publishes to the supplied SNS @topic_arn@. +data SnsTransport = SnsTransport + { snsTransportTopicArn :: Text, + snsTransportRoleArn :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SnsTransport where + parseJSON = withObject "SnsTransport" $ \v -> do + snsTransportTopicArn <- v .: "topic_arn" + snsTransportRoleArn <- v .:? "role_arn" + pure SnsTransport {..} + +instance ToJSON SnsTransport where + toJSON SnsTransport {..} = + omitNulls + [ "topic_arn" .= snsTransportTopicArn, + "role_arn" .= snsTransportRoleArn + ] + +-- | Amazon SES account configuration. Referenced by 'EmailTransport' via +-- its @email_account_id@ field. The plugin assumes the supplied IAM role +-- to send email from @from_address@ in the given AWS region. +data SesAccountTransport = SesAccountTransport + { sesAccountTransportRegion :: Text, + sesAccountTransportRoleArn :: Text, + sesAccountTransportFromAddress :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SesAccountTransport where + parseJSON = withObject "SesAccountTransport" $ \v -> do + sesAccountTransportRegion <- v .: "region" + sesAccountTransportRoleArn <- v .: "role_arn" + sesAccountTransportFromAddress <- v .: "from_address" + pure SesAccountTransport {..} + +instance ToJSON SesAccountTransport where + toJSON SesAccountTransport {..} = + object + [ "region" .= sesAccountTransportRegion, + "role_arn" .= sesAccountTransportRoleArn, + "from_address" .= sesAccountTransportFromAddress + ] + +-- | The @method@ enum on 'SmtpAccountTransport'. The Notifications +-- plugin documents three values: @none@ (plaintext), @ssl@ (implicit +-- TLS), and @start_tls@ (STARTTLS upgrade). +data SmtpMethod + = SmtpMethodNone + | SmtpMethodSsl + | SmtpMethodStartTls + deriving stock (Eq, Show) + +instance FromJSON SmtpMethod where + parseJSON = withText "SmtpMethod" $ \case + "none" -> pure SmtpMethodNone + "ssl" -> pure SmtpMethodSsl + "start_tls" -> pure SmtpMethodStartTls + other -> fail ("unknown SMTP method: " <> T.unpack other) + +instance ToJSON SmtpMethod where + toJSON = \case + SmtpMethodNone -> "none" + SmtpMethodSsl -> "ssl" + SmtpMethodStartTls -> "start_tls" + +-- | SMTP account configuration. Referenced by 'EmailTransport' via its +-- @email_account_id@ field. +data SmtpAccountTransport = SmtpAccountTransport + { smtpAccountTransportHost :: Text, + smtpAccountTransportPort :: Int, + smtpAccountTransportMethod :: SmtpMethod, + smtpAccountTransportFromAddress :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SmtpAccountTransport where + parseJSON = withObject "SmtpAccountTransport" $ \v -> do + smtpAccountTransportHost <- v .: "host" + smtpAccountTransportPort <- v .: "port" + smtpAccountTransportMethod <- v .: "method" + smtpAccountTransportFromAddress <- v .: "from_address" + pure SmtpAccountTransport {..} + +instance ToJSON SmtpAccountTransport where + toJSON SmtpAccountTransport {..} = + object + [ "host" .= smtpAccountTransportHost, + "port" .= smtpAccountTransportPort, + "method" .= smtpAccountTransportMethod, + "from_address" .= smtpAccountTransportFromAddress + ] + +-- | A single email recipient. The plugin serializes this as an object +-- @{"recipient": "..."}@ in both @email.recipient_list@ and +-- @email_group.recipient_list@. The @email.recipient_list@ docs also +-- show a bare-string variant (@"a\@b.com"@); 'FromJSON' accepts both +-- shapes, while 'ToJSON' always emits the object form. As a result a +-- bare-string input round-trips to the object form. +newtype EmailRecipient = EmailRecipient + { emailRecipientRecipient :: Text + } + deriving stock (Eq, Show) + +instance FromJSON EmailRecipient where + parseJSON (String s) = pure (EmailRecipient s) + parseJSON v = + withObject "EmailRecipient" (\o -> EmailRecipient <$> o .: "recipient") v + +instance ToJSON EmailRecipient where + toJSON EmailRecipient {..} = + object ["recipient" .= emailRecipientRecipient] + +-- | A reusable email distribution list. Other configs (notably +-- 'EmailTransport') reference an email group by its @config_id@ via the +-- @email_group_id_list@ field. +data EmailGroupTransport = EmailGroupTransport + { emailGroupTransportRecipientList :: NonEmpty EmailRecipient + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroupTransport where + parseJSON = withObject "EmailGroupTransport" $ \v -> do + recipients <- v .: "recipient_list" + emailGroupTransportRecipientList <- parseNEJSON recipients + pure EmailGroupTransport {..} + +instance ToJSON EmailGroupTransport where + toJSON EmailGroupTransport {..} = + object + [ "recipient_list" .= emailGroupTransportRecipientList + ] + +-- | An email channel bound to a 'SmtpAccountTransport' or +-- 'SesAccountTransport' config (referenced by @email_account_id@) with +-- its own recipient list and an optional set of 'EmailGroupTransport' +-- references via @email_group_id_list@. Note: because the surrounding +-- 'ToJSON' uses 'omitNulls', @'Just' []@ and @'Nothing'@ are +-- indistinguishable on the wire (both produce an absent +-- @email_group_id_list@ field) — the server treats both as "no email +-- groups referenced". Use 'Nothing' for the absent case. +data EmailTransport = EmailTransport + { emailTransportEmailAccountId :: Text, + emailTransportRecipientList :: NonEmpty EmailRecipient, + emailTransportEmailGroupIdList :: Maybe [Text] + } + deriving stock (Eq, Show) + +instance FromJSON EmailTransport where + parseJSON = withObject "EmailTransport" $ \v -> do + emailTransportEmailAccountId <- v .: "email_account_id" + recipients <- v .: "recipient_list" + emailTransportRecipientList <- parseNEJSON recipients + emailTransportEmailGroupIdList <- v .:? "email_group_id_list" + pure EmailTransport {..} + +instance ToJSON EmailTransport where + toJSON EmailTransport {..} = + omitNulls + [ "email_account_id" .= emailTransportEmailAccountId, + "recipient_list" .= emailTransportRecipientList, + "email_group_id_list" .= emailTransportEmailGroupIdList + ] + +-- | The @config@ object embedded in a 'CreateNotificationConfigRequest' +-- and returned inside a config record. The @config_type@ field is +-- /derived/ from 'notificationConfigTransport' via 'transportConfigType' +-- at encode time, so the constructor does not expose a separate +-- @config_type@ field that could disagree with the transport variant. +-- +-- The @is_enabled@ field defaults to @true@ server-side when omitted; +-- modelled as 'Maybe' so @Nothing@ produces the default and @Just False@ +-- explicitly disables the channel. +data NotificationConfig = NotificationConfig + { notificationConfigName :: Text, + notificationConfigDescription :: Maybe Text, + notificationConfigIsEnabled :: Maybe Bool, + notificationConfigTransport :: NotificationTransport + } + deriving stock (Eq, Show) + +instance FromJSON NotificationConfig where + parseJSON = withObject "NotificationConfig" $ \v -> do + notificationConfigName <- v .: "name" + notificationConfigDescription <- v .:? "description" + notificationConfigIsEnabled <- v .:? "is_enabled" + -- Parse config_type for cross-check, then look up the matching + -- transport key. A body whose config_type disagrees with the + -- embedded transport key parse-fails. + configType <- v .: "config_type" + notificationConfigTransport <- case configType of + NotificationConfigTypeSlack -> NotificationTransportSlack <$> v .: "slack" + NotificationConfigTypeChime -> NotificationTransportChime <$> v .: "chime" + NotificationConfigTypeWebhook -> NotificationTransportWebhook <$> v .: "webhook" + NotificationConfigTypeMicrosoftTeams -> + NotificationTransportMicrosoftTeams <$> v .: "microsoft_teams" + NotificationConfigTypeSns -> NotificationTransportSns <$> v .: "sns" + NotificationConfigTypeSesAccount -> + NotificationTransportSesAccount <$> v .: "ses_account" + NotificationConfigTypeSmtpAccount -> + NotificationTransportSmtpAccount <$> v .: "smtp_account" + NotificationConfigTypeEmailGroup -> + NotificationTransportEmailGroup <$> v .: "email_group" + NotificationConfigTypeEmail -> + NotificationTransportEmail <$> v .: "email" + pure NotificationConfig {..} + +instance ToJSON NotificationConfig where + toJSON NotificationConfig {..} = + omitNulls + [ "name" .= notificationConfigName, + "description" .= notificationConfigDescription, + "is_enabled" .= notificationConfigIsEnabled, + "config_type" .= transportConfigType notificationConfigTransport, + transportPair notificationConfigTransport + ] + +-- | Request body for @POST /_plugins/_notifications/configs@. The +-- optional @config_id@ lets the caller supply a stable identifier; when +-- omitted, OpenSearch generates one (and echoes it back in +-- 'CreateNotificationConfigResponse'). Supplying a @config_id@ that +-- already exists results in HTTP 409 Conflict, surfacing as an +-- 'EsError' under 'StatusDependant'. +-- +-- Note: the plugin docs inconsistently show the top-level identifier as +-- both @config_id@ (in the field table and most examples) and @id@ (in +-- one example). We serialize and parse only @config_id@; an @id@ field +-- is silently ignored on decode rather than actively rejected (aeson's +-- default), so callers who send @id@ instead of @config_id@ will see +-- the server generate one regardless. +data CreateNotificationConfigRequest = CreateNotificationConfigRequest + { createNotificationConfigRequestId :: Maybe Text, + createNotificationConfigRequestConfig :: NotificationConfig + } + deriving stock (Eq, Show) + +instance FromJSON CreateNotificationConfigRequest where + parseJSON = withObject "CreateNotificationConfigRequest" $ \v -> do + createNotificationConfigRequestId <- v .:? "config_id" + createNotificationConfigRequestConfig <- v .: "config" + pure CreateNotificationConfigRequest {..} + +instance ToJSON CreateNotificationConfigRequest where + toJSON CreateNotificationConfigRequest {..} = + omitNulls + [ "config_id" .= createNotificationConfigRequestId, + "config" .= createNotificationConfigRequestConfig + ] + +-- | Response of @POST /_plugins/_notifications/configs@. Echoes the +-- resulting @config_id@ — either the caller-supplied value or the +-- server-generated one. The sibling PUT update endpoint +-- ('updateNotificationConfig') returns the same shape. +newtype CreateNotificationConfigResponse = CreateNotificationConfigResponse + { createNotificationConfigResponseConfigId :: Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateNotificationConfigResponse where + parseJSON = withObject "CreateNotificationConfigResponse" $ \v -> + CreateNotificationConfigResponse <$> v .: "config_id" + +instance ToJSON CreateNotificationConfigResponse where + toJSON CreateNotificationConfigResponse {..} = + object ["config_id" .= createNotificationConfigResponseConfigId] + +-- | Request body for @PUT /_plugins/_notifications/configs/{config_id}@ +-- (the update endpoint). Unlike 'CreateNotificationConfigRequest', the +-- update body carries no top-level @config_id@: the identity is the +-- @config_id@ path segment of the PUT URL, and the body is just the +-- wrapped 'NotificationConfig' under the @config@ key. Wiring this as +-- its own type (rather than reusing 'CreateNotificationConfigRequest' +-- with @Nothing@) prevents a caller from accidentally round-tripping +-- a create body through the update endpoint (or vice versa). +newtype UpdateNotificationConfigRequest = UpdateNotificationConfigRequest + { updateNotificationConfigRequestConfig :: NotificationConfig + } + deriving stock (Eq, Show) + +instance FromJSON UpdateNotificationConfigRequest where + parseJSON = withObject "UpdateNotificationConfigRequest" $ \v -> + UpdateNotificationConfigRequest <$> v .: "config" + +instance ToJSON UpdateNotificationConfigRequest where + toJSON UpdateNotificationConfigRequest {..} = + object + [ "config" .= updateNotificationConfigRequestConfig + ] + +-- | Response of @DELETE /_plugins/_notifications/configs/{config_id}@ +-- (and of the sibling batch variant +-- @DELETE /_plugins/_notifications/configs/?config_id_list=id1,id2,...@ +-- exposed by 'deleteNotificationConfigs'). The plugin returns a map +-- from each requested @config_id@ to its per-id deletion status. The +-- documented success value is @"OK"@; the batch variant can carry +-- per-id failures, so the status values are typed as 'Text' rather +-- than a closed enum — see the module docs for the precedent on not +-- prematurely closing under-documented enums. +newtype DeleteNotificationConfigResponse = DeleteNotificationConfigResponse + { deleteResponseList :: Map Text Text + } + deriving stock (Eq, Show) + +instance FromJSON DeleteNotificationConfigResponse where + parseJSON = withObject "DeleteNotificationConfigResponse" $ \v -> + DeleteNotificationConfigResponse <$> v .: "delete_response_list" + +instance ToJSON DeleteNotificationConfigResponse where + toJSON DeleteNotificationConfigResponse {..} = + object ["delete_response_list" .= deleteResponseList] + +-- | Look up the deletion status of a specific @config_id@ within a +-- 'DeleteNotificationConfigResponse'. Returns 'Nothing' if the id was +-- not part of the request (e.g. a mismatched id argument). +deleteResponseStatus :: + Text -> DeleteNotificationConfigResponse -> Maybe Text +deleteResponseStatus configId DeleteNotificationConfigResponse {..} = + Map.lookup configId deleteResponseList + +-- | True iff every per-id status in the response is @"OK"@ (the +-- documented success value). Convenience for the single-id case, where +-- it reduces to "did this delete succeed?", and for the multi-id +-- @config_id_list@ variant ('deleteNotificationConfigs'), where it +-- summarises the whole batch. +deleteResponseAllOK :: DeleteNotificationConfigResponse -> Bool +deleteResponseAllOK DeleteNotificationConfigResponse {..} = + all (== "OK") deleteResponseList + +-- ========================================================================= +-- List responses: GET /_plugins/_notifications/configs +-- ========================================================================= + +-- | A single entry in the @config_list@ returned by +-- @GET /_plugins/_notifications/configs@. Wraps a 'NotificationConfig' +-- with its server-assigned identity and the bookkeeping timestamps the +-- plugin maintains. The @config_id@ is the handle passed to +-- 'deleteNotificationConfig' and to the per-id GET. +data NotificationConfigEntry = NotificationConfigEntry + { notificationConfigEntryConfigId :: Text, + notificationConfigEntryCreatedTimeMs :: Integer, + notificationConfigEntryLastUpdatedTimeMs :: Integer, + notificationConfigEntryConfig :: NotificationConfig + } + deriving stock (Eq, Show) + +instance FromJSON NotificationConfigEntry where + parseJSON = withObject "NotificationConfigEntry" $ \v -> do + notificationConfigEntryConfigId <- v .: "config_id" + notificationConfigEntryCreatedTimeMs <- v .: "created_time_ms" + notificationConfigEntryLastUpdatedTimeMs <- v .: "last_updated_time_ms" + notificationConfigEntryConfig <- v .: "config" + pure NotificationConfigEntry {..} + +instance ToJSON NotificationConfigEntry where + toJSON NotificationConfigEntry {..} = + object + [ "config_id" .= notificationConfigEntryConfigId, + "created_time_ms" .= notificationConfigEntryCreatedTimeMs, + "last_updated_time_ms" .= notificationConfigEntryLastUpdatedTimeMs, + "config" .= notificationConfigEntryConfig + ] + +-- | The @total_hit_relation@ discriminator on the list-response +-- envelopes. @"eq"@ means @total_hits@ is exact; @"gte"@ means it is a +-- lower bound (e.g. when @max_items@ truncated the result). Unknown +-- values round-trip via 'NotificationTotalRelationOther' for forward +-- compatibility. +data NotificationTotalRelation + = NotificationTotalRelationEq + | NotificationTotalRelationGte + | NotificationTotalRelationOther Text + deriving stock (Eq, Show) + +instance FromJSON NotificationTotalRelation where + parseJSON = withText "NotificationTotalRelation" $ \t -> + pure $ case t of + "eq" -> NotificationTotalRelationEq + "gte" -> NotificationTotalRelationGte + other -> NotificationTotalRelationOther other + +instance ToJSON NotificationTotalRelation where + toJSON = \case + NotificationTotalRelationEq -> "eq" + NotificationTotalRelationGte -> "gte" + NotificationTotalRelationOther t -> toJSON t + +-- | Envelope returned by @GET /_plugins/_notifications/configs@. The +-- paging fields (@start_index@, @total_hits@, @total_hit_relation@) are +-- decoded for completeness but discarded by the public +-- 'getNotificationConfigs' wrapper, which returns only the +-- @config_list@. +data GetNotificationConfigsResponse = GetNotificationConfigsResponse + { getNotificationConfigsResponseStartIndex :: Integer, + getNotificationConfigsResponseTotalHits :: Integer, + getNotificationConfigsResponseTotalHitRelation :: NotificationTotalRelation, + getNotificationConfigsResponseConfigList :: [NotificationConfigEntry] + } + deriving stock (Eq, Show) + +instance FromJSON GetNotificationConfigsResponse where + parseJSON = withObject "GetNotificationConfigsResponse" $ \v -> do + getNotificationConfigsResponseStartIndex <- v .: "start_index" + getNotificationConfigsResponseTotalHits <- v .: "total_hits" + getNotificationConfigsResponseTotalHitRelation <- v .: "total_hit_relation" + getNotificationConfigsResponseConfigList <- v .: "config_list" + pure GetNotificationConfigsResponse {..} + +instance ToJSON GetNotificationConfigsResponse where + toJSON GetNotificationConfigsResponse {..} = + object + [ "start_index" .= getNotificationConfigsResponseStartIndex, + "total_hits" .= getNotificationConfigsResponseTotalHits, + "total_hit_relation" .= getNotificationConfigsResponseTotalHitRelation, + "config_list" .= getNotificationConfigsResponseConfigList + ] + +-- ========================================================================= +-- List query options (shared by GET configs and GET channels) +-- ========================================================================= + +-- | Sort direction for the GET @configs@ \/ @channels@ endpoints. The +-- plugin docs only document @"asc"@ and @"desc"@. +data NotificationSortOrder + = NotificationSortOrderAsc + | NotificationSortOrderDesc + deriving stock (Eq, Show) + +-- | The wire string for a 'NotificationSortOrder'. +notificationSortOrderText :: NotificationSortOrder -> Text +notificationSortOrderText = \case + NotificationSortOrderAsc -> "asc" + NotificationSortOrderDesc -> "desc" + +-- | Query-string parameters accepted by both +-- @GET /_plugins/_notifications/configs@ and +-- @GET /_plugins/_notifications/channels@. Every field is optional; +-- 'defaultNotificationListOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. Per-transport filter fields +-- (e.g. @slack.url@, @email.recipient_list@) are deliberately omitted +-- — they are advanced and rarely used; callers who need them can issue +-- the request via the lower-level builder with a hand-rolled query +-- list. +data NotificationListOptions = NotificationListOptions + { notificationListOptionsFromIndex :: Maybe Natural, + notificationListOptionsMaxItems :: Maybe Natural, + notificationListOptionsSortOrder :: Maybe NotificationSortOrder, + notificationListOptionsSortField :: Maybe Text, + notificationListOptionsConfigType :: Maybe NotificationConfigType, + notificationListOptionsConfigId :: Maybe Text, + notificationListOptionsConfigIdList :: Maybe [Text], + notificationListOptionsIsEnabled :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the +-- plain @GET /_plugins/_notifications/configs@ (or @channels@) when +-- passed to 'getNotificationConfigsWith' \/ 'getNotificationChannelsWith'. +defaultNotificationListOptions :: NotificationListOptions +defaultNotificationListOptions = + NotificationListOptions + { notificationListOptionsFromIndex = Nothing, + notificationListOptionsMaxItems = Nothing, + notificationListOptionsSortOrder = Nothing, + notificationListOptionsSortField = Nothing, + notificationListOptionsConfigType = Nothing, + notificationListOptionsConfigId = Nothing, + notificationListOptionsConfigIdList = Nothing, + notificationListOptionsIsEnabled = Nothing + } + +-- | Render a 'NotificationListOptions' to the query-string pairs +-- accepted by the GET endpoints. Fields set to 'Nothing' are omitted +-- (not rendered with an empty value); @config_id_list@ is rendered as +-- a comma-separated list per the plugin docs. +notificationListOptionsParams :: NotificationListOptions -> [(Text, Maybe Text)] +notificationListOptionsParams NotificationListOptions {..} = + catMaybes + [ (("from_index",) . Just . tshow) <$> notificationListOptionsFromIndex, + (("max_items",) . Just . tshow) <$> notificationListOptionsMaxItems, + (("sort_order",) . Just . notificationSortOrderText) <$> notificationListOptionsSortOrder, + (("sort_field",) . Just) <$> notificationListOptionsSortField, + (("config_type",) . Just . notificationConfigTypeText) <$> notificationListOptionsConfigType, + (("config_id",) . Just) <$> notificationListOptionsConfigId, + (("config_id_list",) . Just . T.intercalate ",") <$> notificationListOptionsConfigIdList, + (("is_enabled",) . Just . \case True -> "true"; False -> "false") <$> notificationListOptionsIsEnabled + ] + +-- ========================================================================= +-- List responses: GET /_plugins/_notifications/channels +-- ========================================================================= + +-- | A single entry in the @channel_list@ returned by +-- @GET /_plugins/_notifications/channels@. The channels endpoint is the +-- \"runtime\" view of the configured destinations: it carries the +-- identifying metadata (@config_id@, @name@, @description@, +-- @config_type@, @is_enabled@) but omits the transport-specific details +-- (no @slack.url@, no @email.recipient_list@) that the full +-- 'NotificationConfig' exposes. Use 'getNotificationConfigs' when you +-- need the transport details; use 'getNotificationChannels' for a +-- lightweight listing. +data Channel = Channel + { channelConfigId :: Text, + channelName :: Text, + channelDescription :: Maybe Text, + channelConfigType :: NotificationConfigType, + channelIsEnabled :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON Channel where + parseJSON = withObject "Channel" $ \v -> do + channelConfigId <- v .: "config_id" + channelName <- v .: "name" + channelDescription <- v .:? "description" + channelConfigType <- v .: "config_type" + channelIsEnabled <- v .: "is_enabled" + pure Channel {..} + +instance ToJSON Channel where + toJSON Channel {..} = + omitNulls + [ "config_id" .= channelConfigId, + "name" .= channelName, + "description" .= channelDescription, + "config_type" .= channelConfigType, + "is_enabled" .= channelIsEnabled + ] + +-- | Envelope returned by @GET /_plugins/_notifications/channels@. +-- Structurally identical to 'GetNotificationConfigsResponse' except for +-- the @channel_list@ field. As with the configs envelope, the paging +-- fields are decoded for completeness but discarded by the public +-- 'getNotificationChannels' wrapper. +data GetNotificationChannelsResponse = GetNotificationChannelsResponse + { getNotificationChannelsResponseStartIndex :: Integer, + getNotificationChannelsResponseTotalHits :: Integer, + getNotificationChannelsResponseTotalHitRelation :: NotificationTotalRelation, + getNotificationChannelsResponseChannelList :: [Channel] + } + deriving stock (Eq, Show) + +instance FromJSON GetNotificationChannelsResponse where + parseJSON = withObject "GetNotificationChannelsResponse" $ \v -> do + getNotificationChannelsResponseStartIndex <- v .: "start_index" + getNotificationChannelsResponseTotalHits <- v .: "total_hits" + getNotificationChannelsResponseTotalHitRelation <- v .: "total_hit_relation" + getNotificationChannelsResponseChannelList <- v .: "channel_list" + pure GetNotificationChannelsResponse {..} + +instance ToJSON GetNotificationChannelsResponse where + toJSON GetNotificationChannelsResponse {..} = + object + [ "start_index" .= getNotificationChannelsResponseStartIndex, + "total_hits" .= getNotificationChannelsResponseTotalHits, + "total_hit_relation" .= getNotificationChannelsResponseTotalHitRelation, + "channel_list" .= getNotificationChannelsResponseChannelList + ] + +-- ========================================================================= +-- Features response: GET /_plugins/_notifications/features +-- ========================================================================= + +-- | Response of @GET /_plugins/_notifications/features@ +-- ('getNotificationFeatures'). The @allowed_config_type_list@ field is +-- the set of @config_type@ tags this cluster's Notifications plugin +-- knows how to persist (a subset of 'NotificationConfigType'; the +-- docs example for OS 2.18 lists eight of the nine variants — +-- @microsoft_teams@ is omitted from the example, but the plugin +-- accepts it on real clusters, so the list is typed as +-- @['NotificationConfigType']@ and any unknown tag parse-fails per +-- the 'NotificationConfigType' decoder's fail-loud policy). +-- +-- The @plugin_features@ map is a free-form string→string feature +-- flag set (the only documented entry is @tooltip_support@); typed +-- as 'Map' 'Text' 'Text' so a future plugin release adding a new +-- feature flag does not require a library release. +data NotificationFeaturesResponse = NotificationFeaturesResponse + { notificationFeaturesResponseAllowedConfigTypeList :: [NotificationConfigType], + notificationFeaturesResponsePluginFeatures :: Map Text Text + } + deriving stock (Eq, Show) + +instance FromJSON NotificationFeaturesResponse where + parseJSON = withObject "NotificationFeaturesResponse" $ \v -> do + notificationFeaturesResponseAllowedConfigTypeList <- v .: "allowed_config_type_list" + notificationFeaturesResponsePluginFeatures <- v .:? "plugin_features" .!= Map.empty + pure NotificationFeaturesResponse {..} + +instance ToJSON NotificationFeaturesResponse where + toJSON NotificationFeaturesResponse {..} = + object + [ "allowed_config_type_list" .= notificationFeaturesResponseAllowedConfigTypeList, + "plugin_features" .= notificationFeaturesResponsePluginFeatures + ] + +-- ========================================================================= +-- Send test notification response: GET /_plugins/_notifications/feature/test/{config_id} +-- ========================================================================= + +-- | Response of @GET /_plugins/_notifications/feature/test/{config_id}@ +-- ('sendTestNotification'). The plugin constructs an 'EventSource' +-- describing the probe it attempted, then a per-config +-- 'TestNotificationStatus' entry for each channel it tried to deliver +-- to (one entry for the requested @config_id@ in the common case). +-- +-- The @status_list@.@delivery_status@.@status_text@ field is the raw +-- upstream response body the transport returned (e.g. the HTML body +-- for a webhook), so it is typed as 'Text' rather than a closed enum. +data TestNotificationResponse = TestNotificationResponse + { testNotificationResponseEventSource :: TestNotificationEventSource, + testNotificationResponseStatusList :: [TestNotificationStatus] + } + deriving stock (Eq, Show) + +instance FromJSON TestNotificationResponse where + parseJSON = withObject "TestNotificationResponse" $ \v -> do + testNotificationResponseEventSource <- v .: "event_source" + testNotificationResponseStatusList <- v .: "status_list" + pure TestNotificationResponse {..} + +instance ToJSON TestNotificationResponse where + toJSON TestNotificationResponse {..} = + object + [ "event_source" .= testNotificationResponseEventSource, + "status_list" .= testNotificationResponseStatusList + ] + +-- | The @event_source@ object embedded in a 'TestNotificationResponse'. +-- The plugin materialises a synthetic notification with these fields +-- to drive the probe: @title@ and @reference_id@ are derived from the +-- target @config_id@, @severity@ is the documented severity tag +-- (@\"info\"@ in the docs example; the plugin also emits @\"warning\"@ +-- and @\"critical\"@, which are not fully enumerated, so the field is +-- typed as 'Text'), and @tags@ is the (possibly empty) set of +-- free-form string labels attached to the probe. +data TestNotificationEventSource = TestNotificationEventSource + { testNotificationEventSourceTitle :: Text, + testNotificationEventSourceReferenceId :: Text, + testNotificationEventSourceSeverity :: Text, + testNotificationEventSourceTags :: [Text] + } + deriving stock (Eq, Show) + +instance FromJSON TestNotificationEventSource where + parseJSON = withObject "TestNotificationEventSource" $ \v -> do + testNotificationEventSourceTitle <- v .: "title" + testNotificationEventSourceReferenceId <- v .: "reference_id" + testNotificationEventSourceSeverity <- v .: "severity" + testNotificationEventSourceTags <- v .:? "tags" .!= [] + pure TestNotificationEventSource {..} + +instance ToJSON TestNotificationEventSource where + toJSON TestNotificationEventSource {..} = + omitNulls + [ "title" .= testNotificationEventSourceTitle, + "reference_id" .= testNotificationEventSourceReferenceId, + "severity" .= testNotificationEventSourceSeverity, + "tags" .= testNotificationEventSourceTags + ] + +-- | A single per-config delivery result inside a +-- 'TestNotificationResponse'. The @config_type@ reuses +-- 'NotificationConfigType' so the closed-enum invariant is preserved; +-- an unknown @config_type@ parse-fails per the fail-loud policy +-- documented for 'NotificationConfigType'. +-- +-- The @email_recipient_status@ field is opaque +-- (@['Data.Aeson.Value']@): the docs only show it as the empty list, +-- and the Notifications plugin source does not document the +-- per-recipient status object shape on this API page, so we preserve +-- caller access to the raw JSON rather than commit to a structure we +-- would have to guess. File a feature request if you need a typed +-- projection. +data TestNotificationStatus = TestNotificationStatus + { testNotificationStatusConfigId :: Text, + testNotificationStatusConfigType :: NotificationConfigType, + testNotificationStatusConfigName :: Text, + testNotificationStatusEmailRecipientStatus :: [Value], + testNotificationStatusDeliveryStatus :: TestNotificationDeliveryStatus + } + deriving stock (Eq, Show) + +instance FromJSON TestNotificationStatus where + parseJSON = withObject "TestNotificationStatus" $ \v -> do + testNotificationStatusConfigId <- v .: "config_id" + testNotificationStatusConfigType <- v .: "config_type" + testNotificationStatusConfigName <- v .: "config_name" + testNotificationStatusEmailRecipientStatus <- v .:? "email_recipient_status" .!= [] + testNotificationStatusDeliveryStatus <- v .: "delivery_status" + pure TestNotificationStatus {..} + +instance ToJSON TestNotificationStatus where + toJSON TestNotificationStatus {..} = + omitNulls + [ "config_id" .= testNotificationStatusConfigId, + "config_type" .= testNotificationStatusConfigType, + "config_name" .= testNotificationStatusConfigName, + "email_recipient_status" .= testNotificationStatusEmailRecipientStatus, + "delivery_status" .= testNotificationStatusDeliveryStatus + ] + +-- | The @delivery_status@ object inside a 'TestNotificationStatus'. +-- @status_code@ is the HTTP-style code the upstream transport returned +-- (@\"200\"@ on success — typed as 'Text' because the plugin emits it +-- as a string, not a number) and @status_text@ is the raw upstream +-- response body (free-form: HTML for webhooks, a JSON blob for SNS, +-- an SMTP reply for email, ...). +data TestNotificationDeliveryStatus = TestNotificationDeliveryStatus + { testNotificationDeliveryStatusCode :: Text, + testNotificationDeliveryStatusText :: Text + } + deriving stock (Eq, Show) + +instance FromJSON TestNotificationDeliveryStatus where + parseJSON = withObject "TestNotificationDeliveryStatus" $ \v -> do + testNotificationDeliveryStatusCode <- v .: "status_code" + testNotificationDeliveryStatusText <- v .: "status_text" + pure TestNotificationDeliveryStatus {..} + +instance ToJSON TestNotificationDeliveryStatus where + toJSON TestNotificationDeliveryStatus {..} = + object + [ "status_code" .= testNotificationDeliveryStatusCode, + "status_text" .= testNotificationDeliveryStatusText + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/PointInTime.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/PointInTime.hs --- a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/PointInTime.hs +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/PointInTime.hs @@ -4,12 +4,17 @@ module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.PointInTime where import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.KeepAlive + ( KeepAlive, + keepAliveMilliseconds, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes (POSIXMS) import Database.Bloodhound.Internal.Versions.Common.Types.Nodes (ShardResult) data OpenPointInTimeResponse = OpenPointInTimeResponse { oos2PitId :: Text, oos2Shards :: ShardResult, - oos2CreationTime :: POSIXTime + oos2CreationTime :: POSIXMS } deriving stock (Eq, Show) @@ -31,47 +36,154 @@ openPointInTimeShardsLens :: Lens' OpenPointInTimeResponse ShardResult openPointInTimeShardsLens = lens oos2Shards (\x y -> x {oos2Shards = y}) -openPointInTimeCreationTimeLens :: Lens' OpenPointInTimeResponse POSIXTime +openPointInTimeCreationTimeLens :: Lens' OpenPointInTimeResponse POSIXMS openPointInTimeCreationTimeLens = lens oos2CreationTime (\x y -> x {oos2CreationTime = y}) +-- | Request body for the OpenSearch @DELETE /_search/point_in_time@ (Delete +-- PITs by ID) API. The wire body is an /array/ of pit ids: +-- +-- @ +-- { "pit_id": ["", "", ...] } +-- @ +-- +-- Note that OpenSearch (unlike Elasticsearch's @close@ endpoint) does not +-- accept a single @id@ field; the value is always a JSON array even for one +-- pit, so a single-pit close is encoded as @{"pit_id":[""]}@. data ClosePointInTime = ClosePointInTime - { cPitId :: Text + { cPitIds :: [Text] } deriving stock (Eq, Show) instance ToJSON ClosePointInTime where toJSON ClosePointInTime {..} = - object ["id" .= cPitId] + object ["pit_id" .= cPitIds] instance FromJSON ClosePointInTime where - parseJSON (Object o) = ClosePointInTime <$> o .: "id" + parseJSON (Object o) = ClosePointInTime <$> o .: "pit_id" parseJSON x = typeMismatch "ClosePointInTime" x -closePointInTimeIdLens :: Lens' ClosePointInTime Text -closePointInTimeIdLens = lens cPitId (\x y -> x {cPitId = y}) +closePointInTimeIdsLens :: Lens' ClosePointInTime [Text] +closePointInTimeIdsLens = lens cPitIds (\x y -> x {cPitIds = y}) +-- | Per-pit result entry inside a 'ClosePointInTimeResponse'. The OpenSearch +-- Delete-PITs-by-ID response surfaces, for each requested pit id, whether the +-- deletion succeeded and the pit id it refers to: +-- +-- @ +-- { "successful": true, "pit_id": "" } +-- @ +data ClosePointInTimeResult = ClosePointInTimeResult + { cpitSuccessful :: Bool, + cpitId :: Text + } + deriving stock (Eq, Show) + +instance ToJSON ClosePointInTimeResult where + toJSON ClosePointInTimeResult {..} = + object + [ "successful" .= cpitSuccessful, + "pit_id" .= cpitId + ] + +instance FromJSON ClosePointInTimeResult where + parseJSON (Object o) = + ClosePointInTimeResult + <$> o .: "successful" + <*> o .: "pit_id" + parseJSON x = typeMismatch "ClosePointInTimeResult" x + +closePointInTimeResultSuccessfulLens :: Lens' ClosePointInTimeResult Bool +closePointInTimeResultSuccessfulLens = + lens cpitSuccessful (\x y -> x {cpitSuccessful = y}) + +closePointInTimeResultIdLens :: Lens' ClosePointInTimeResult Text +closePointInTimeResultIdLens = + lens cpitId (\x y -> x {cpitId = y}) + +-- | Response of the OpenSearch @DELETE /_search/point_in_time@ (Delete PITs +-- by ID) API. Unlike Elasticsearch's @close@ endpoint (which returns +-- @{"succeeded", "num_freed"}@), OpenSearch returns one entry per requested +-- pit id: +-- +-- @ +-- { "pits": [ {"successful": true, "pit_id": ""}, ... ] } +-- @ data ClosePointInTimeResponse = ClosePointInTimeResponse - { succeeded :: Bool, - numFreed :: Int + { closePITs :: [ClosePointInTimeResult] } deriving stock (Eq, Show) instance ToJSON ClosePointInTimeResponse where toJSON ClosePointInTimeResponse {..} = - object - [ "succeeded" .= succeeded, - "num_freed" .= numFreed - ] + object ["pits" .= closePITs] instance FromJSON ClosePointInTimeResponse where - parseJSON (Object o) = do - succeeded' <- o .: "succeeded" - numFreed' <- o .: "num_freed" - return $ ClosePointInTimeResponse succeeded' numFreed' + parseJSON (Object o) = ClosePointInTimeResponse <$> o .: "pits" parseJSON x = typeMismatch "ClosePointInTimeResponse" x -closePointInTimeSucceededLens :: Lens' ClosePointInTimeResponse Bool -closePointInTimeSucceededLens = lens succeeded (\x y -> x {succeeded = y}) +closePointInTimesLens :: Lens' ClosePointInTimeResponse [ClosePointInTimeResult] +closePointInTimesLens = lens closePITs (\x y -> x {closePITs = y}) -closePointInTimeNumFreedLens :: Lens' ClosePointInTimeResponse Int -closePointInTimeNumFreedLens = lens numFreed (\x y -> x {numFreed = y}) +-- | Element type for the @GET /_search/point_in_time/_all@ list-all-PITs +-- response. Unlike 'OpenPointInTimeResponse' (the @POST@ create-PIT +-- response, which carries a per-entry @_shards@ summary), each list +-- entry exposes only the @pit_id@, the @creation_time@ and the remaining +-- @keep_alive@ — there is no @_shards@ key in the list response. +-- +-- The wire @keep_alive@ is a bare millisecond count (a JSON number, e.g. +-- @6000000@), not the @@ string grammar accepted on create. The +-- 'FromJSON' instance therefore parses the number via +-- 'keepAliveMilliseconds'; the 'ToJSON' round trip re-renders it as a +-- @ms@ string, so the codec is asymmetric by design (mirroring +-- 'POSIXMS'). +data PITInfo = PITInfo + { pitInfoId :: Text, + pitInfoCreationTime :: POSIXMS, + pitInfoKeepAlive :: KeepAlive + } + deriving stock (Eq, Show) + +instance ToJSON PITInfo where + toJSON PITInfo {..} = + object + [ "pit_id" .= pitInfoId, + "creation_time" .= pitInfoCreationTime, + "keep_alive" .= pitInfoKeepAlive + ] + +instance FromJSON PITInfo where + parseJSON (Object o) = + PITInfo + <$> o .: "pit_id" + <*> o .: "creation_time" + <*> (keepAliveMilliseconds <$> o .: "keep_alive") + parseJSON x = typeMismatch "PITInfo" x + +pitInfoIdLens :: Lens' PITInfo Text +pitInfoIdLens = lens pitInfoId (\x y -> x {pitInfoId = y}) + +pitInfoCreationTimeLens :: Lens' PITInfo POSIXMS +pitInfoCreationTimeLens = lens pitInfoCreationTime (\x y -> x {pitInfoCreationTime = y}) + +pitInfoKeepAliveLens :: Lens' PITInfo KeepAlive +pitInfoKeepAliveLens = lens pitInfoKeepAlive (\x y -> x {pitInfoKeepAlive = y}) + +-- | Envelope of the @GET /_search/point_in_time/_all@ response +-- (@{\"pits\":[...] }@). Each 'PITInfo' carries the pit id, +-- @creation_time@ and remaining @keep_alive@; the create-response-only +-- @_shards@ field is absent from list entries. +newtype ListPITsResponse = ListPITsResponse + { listPITs :: [PITInfo] + } + deriving stock (Eq, Show) + +instance ToJSON ListPITsResponse where + toJSON ListPITsResponse {..} = + object ["pits" .= listPITs] + +instance FromJSON ListPITsResponse where + parseJSON (Object o) = ListPITsResponse <$> o .: "pits" + parseJSON x = typeMismatch "ListPITsResponse" x + +listPITsLens :: Lens' ListPITsResponse [PITInfo] +listPITsLens = lens listPITs (\x y -> x {listPITs = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/Rollups.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/Rollups.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/Rollups.hs @@ -0,0 +1,710 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.Rollups + ( RollupId (..), + Rollup (..), + RollupWrapper (..), + RollupSchedule (..), + RollupInterval (..), + RollupIntervalUnit (..), + rollupIntervalUnitText, + RollupCron (..), + RollupDimension (..), + RollupDateHistogram (..), + RollupTerms (..), + RollupHistogram (..), + RollupMetric (..), + RollupMetricAgg (..), + rollupMetricAggText, + RollupResponse (..), + RollupResponseInner (..), + ExplainRollupResponse (..), + explainRollupResponseLookup, + explainRollupResponseToList, + ExplainRollupEntry (..), + RollupMetadata (..), + RollupStatus (..), + rollupStatusText, + RollupStats (..), + ) +where + +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The OpenSearch Index Rollups plugin +-- () +-- periodically reduces a high-granularity source index into a coarser +-- target index by aggregating documents along configurable dimensions +-- (date_histogram / terms / histogram) and computing metrics +-- (avg / sum / max / min / value_count) per bucket. A 'Rollup' binds a +-- 'rollupSourceIndex', a 'rollupTargetIndex', a 'RollupSchedule', the +-- 'rollupDimensions' to group by and the 'rollupMetrics' to compute; the +-- server persists it under @.opendistro-ism-config@ (the ISM config +-- index) and returns a 'RollupResponse' wrapping the persisted +-- 'RollupResponseInner' with server-injected bookkeeping fields +-- (@_id@, @_version@, @_seq_no@, @_primary_term@, @rollup_id@, +-- @last_updated_time@, @enabled_time@, @schema_version@, @metadata_id@). +-- +-- We split the request shape ('Rollup') from the response inner shape +-- ('RollupResponseInner') so the request cannot accidentally carry +-- server-only fields, while the response still round-trips the full +-- server payload. This mirrors the 'Detector' / 'DetectorResponse' +-- split used for the Anomaly Detection plugin. +-- +-- The plugin is shipped with OpenSearch 1.0+; it is present (and +-- wire-compatible) on OS1, OS2 and OS3, hence this module is duplicated +-- across all three versions. The @routing_field@ option is documented as +-- OS 3.7+ only, but is modelled as 'Maybe' 'Text' here on every version: +-- older clusters simply never receive it (it is omitted under +-- 'omitNulls'), so a single code path serves all three. +-- +-- Doc ambiguities handled here deliberately: +-- +-- * The @_seq_no@ / @_primary_term@ fields are emitted in snake_case on +-- the PUT response but camelCase (@_seqNo@ / @_primaryTerm@) on the GET +-- response. The 'RollupResponse' parser accepts both spellings (see +-- 'rollupKey'). +-- * The @schedule.interval.period@ field is documented with type String +-- but every documented example emits it as a bare number (@1@). We +-- type it as 'Int', matching the wire format the server actually sends. +-- * The @metadata_id@ field is JSON @null@ (not absent) when the rollup +-- has not yet executed, so it is parsed with '.:?' (tolerating both +-- @null@ and omission). +-- * The @GET /_plugins/_rollup/jobs@ (list-all) endpoint is undocumented +-- in the field tables; its response is decoded as an opaque 'Value' at +-- the 'Requests' layer rather than typed here. +-- * Each 'RollupDimension' / 'RollupMetricAgg' is encoded as a +-- single-key JSON object (e.g. @{"avg":{}}@) following the +-- aggregation-DSL convention the plugin reuses. + +-- | Identifies a rollup job in the +-- @\/_plugins\/_rollup\/jobs\/{rollup_id}@ URL path. Wraps 'Text' so it +-- round-trips through JSON as a bare string but is distinct at the +-- Haskell type level. +-- See +newtype RollupId = RollupId {unRollupId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The request body for @PUT /_plugins/_rollup/jobs/{rollup_id}@, +-- unwrapped. Required fields: @source_index@, @target_index@, +-- @schedule@, @page_size@, @dimensions@. Everything else is optional and +-- omitted on the wire when 'Nothing'. Server-only bookkeeping fields +-- (@rollup_id@, @last_updated_time@, @enabled_time@, @schema_version@, +-- @metadata_id@) are deliberately absent — they appear on the +-- 'RollupResponseInner' round-trip shape. +-- See +data Rollup = Rollup + { rollupSourceIndex :: Text, + rollupTargetIndex :: Text, + rollupTargetIndexSettings :: Maybe Value, + rollupSchedule :: RollupSchedule, + rollupDescription :: Maybe Text, + rollupEnabled :: Maybe Bool, + rollupContinuous :: Maybe Bool, + rollupPageSize :: Int, + rollupDelay :: Maybe Integer, + rollupRoles :: Maybe [Text], + rollupRoutingField :: Maybe Text, + rollupDimensions :: [RollupDimension], + rollupMetrics :: Maybe [RollupMetric], + rollupErrorNotification :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON Rollup where + parseJSON = withObject "Rollup" $ \v -> do + rollupSourceIndex <- v .: "source_index" + rollupTargetIndex <- v .: "target_index" + rollupTargetIndexSettings <- v .:? "target_index_settings" + rollupSchedule <- v .: "schedule" + rollupDescription <- v .:? "description" + rollupEnabled <- v .:? "enabled" + rollupContinuous <- v .:? "continuous" + rollupPageSize <- v .: "page_size" + rollupDelay <- v .:? "delay" + rollupRoles <- v .:? "roles" + rollupRoutingField <- v .:? "routing_field" + rollupDimensions <- v .:? "dimensions" .!= [] + rollupMetrics <- v .:? "metrics" + rollupErrorNotification <- v .:? "error_notification" + pure Rollup {..} + +instance ToJSON Rollup where + toJSON Rollup {..} = + omitNulls + [ "source_index" .= rollupSourceIndex, + "target_index" .= rollupTargetIndex, + "target_index_settings" .= rollupTargetIndexSettings, + "schedule" .= rollupSchedule, + "description" .= rollupDescription, + "enabled" .= rollupEnabled, + "continuous" .= rollupContinuous, + "page_size" .= rollupPageSize, + "delay" .= rollupDelay, + "roles" .= rollupRoles, + "routing_field" .= rollupRoutingField, + "dimensions" .= rollupDimensions, + "metrics" .= rollupMetrics, + "error_notification" .= rollupErrorNotification + ] + +-- | The @{"rollup": }@ envelope the PUT endpoint expects around +-- the 'Rollup' body. +-- See +newtype RollupWrapper = RollupWrapper {rollupWrapperRollup :: Rollup} + deriving stock (Eq, Show) + +instance ToJSON RollupWrapper where + toJSON (RollupWrapper r) = object ["rollup" .= r] + +instance FromJSON RollupWrapper where + parseJSON = withObject "RollupWrapper" $ \v -> + RollupWrapper <$> v .: "rollup" + +-- | The @schedule@ object. Currently only the @interval@ form is +-- documented; @cron@ lives one level deeper inside 'RollupInterval'. +-- See +newtype RollupSchedule = RollupSchedule {rollupScheduleInterval :: RollupInterval} + deriving stock (Eq, Show) + +instance FromJSON RollupSchedule where + parseJSON = withObject "RollupSchedule" $ \v -> + RollupSchedule <$> v .: "interval" + +instance ToJSON RollupSchedule where + toJSON (RollupSchedule interval) = object ["interval" .= interval] + +-- | The @schedule.interval@ object. Either the @period@\/@unit@ pair or a +-- @cron@ list governs execution frequency; @start_time@ and +-- @schedule_delay@ are server-populated on the response. +-- See +data RollupInterval = RollupInterval + { rollupIntervalPeriod :: Maybe Int, + rollupIntervalUnit :: Maybe RollupIntervalUnit, + rollupIntervalStartTime :: Maybe Integer, + rollupIntervalScheduleDelay :: Maybe Integer, + rollupIntervalCron :: Maybe [RollupCron] + } + deriving stock (Eq, Show) + +instance FromJSON RollupInterval where + parseJSON = withObject "RollupInterval" $ \v -> do + rollupIntervalPeriod <- v .:? "period" + rollupIntervalUnit <- v .:? "unit" + rollupIntervalStartTime <- v .:? "start_time" + rollupIntervalScheduleDelay <- v .:? "schedule_delay" + rollupIntervalCron <- v .:? "cron" + pure RollupInterval {..} + +instance ToJSON RollupInterval where + toJSON RollupInterval {..} = + omitNulls + [ "period" .= rollupIntervalPeriod, + "unit" .= rollupIntervalUnit, + "start_time" .= rollupIntervalStartTime, + "schedule_delay" .= rollupIntervalScheduleDelay, + "cron" .= rollupIntervalCron + ] + +-- | The @schedule.interval.unit@ enum. The docs only show @"Days"@ in +-- examples; the plugin source accepts the standard time units +-- enumerated here. Unknown values surface as 'RollupIntervalUnitCustom' +-- rather than failing the decode. +-- See +data RollupIntervalUnit + = RollupIntervalUnitMinutes + | RollupIntervalUnitHours + | RollupIntervalUnitDays + | RollupIntervalUnitWeeks + | RollupIntervalUnitMonths + | RollupIntervalUnitCustom Text + deriving stock (Eq, Show) + +rollupIntervalUnitText :: RollupIntervalUnit -> Text +rollupIntervalUnitText = \case + RollupIntervalUnitMinutes -> "Minutes" + RollupIntervalUnitHours -> "Hours" + RollupIntervalUnitDays -> "Days" + RollupIntervalUnitWeeks -> "Weeks" + RollupIntervalUnitMonths -> "Months" + RollupIntervalUnitCustom t -> t + +instance ToJSON RollupIntervalUnit where + toJSON = toJSON . rollupIntervalUnitText + +instance FromJSON RollupIntervalUnit where + parseJSON = withText "RollupIntervalUnit" $ \case + "Minutes" -> pure RollupIntervalUnitMinutes + "Hours" -> pure RollupIntervalUnitHours + "Days" -> pure RollupIntervalUnitDays + "Weeks" -> pure RollupIntervalUnitWeeks + "Months" -> pure RollupIntervalUnitMonths + other -> pure (RollupIntervalUnitCustom other) + +-- | A cron expression entry inside @schedule.interval.cron@. +-- See +data RollupCron = RollupCron + { rollupCronExpression :: Text, + rollupCronTimezone :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupCron where + parseJSON = withObject "RollupCron" $ \v -> do + rollupCronExpression <- v .: "expression" + rollupCronTimezone <- v .:? "timezone" + pure RollupCron {..} + +instance ToJSON RollupCron where + toJSON RollupCron {..} = + omitNulls + [ "expression" .= rollupCronExpression, + "timezone" .= rollupCronTimezone + ] + +-- | A single dimension (bucket aggregation) the rollup groups by. The +-- plugin models each as a single-key object whose key selects the +-- aggregation kind; we keep that shape on the wire. +-- See +data RollupDimension + = RollupDimensionDateHistogram RollupDateHistogram + | RollupDimensionTerms RollupTerms + | RollupDimensionHistogram RollupHistogram + deriving stock (Eq, Show) + +instance ToJSON RollupDimension where + toJSON = \case + RollupDimensionDateHistogram dh -> object ["date_histogram" .= dh] + RollupDimensionTerms t -> object ["terms" .= t] + RollupDimensionHistogram h -> object ["histogram" .= h] + +instance FromJSON RollupDimension where + parseJSON = withObject "RollupDimension" $ \v -> case KeyMap.toList v of + [("date_histogram", o)] -> RollupDimensionDateHistogram <$> parseJSON o + [("terms", o)] -> RollupDimensionTerms <$> parseJSON o + [("histogram", o)] -> RollupDimensionHistogram <$> parseJSON o + _ -> + fail + ( "RollupDimension: expected a single-key object with one of \ + \date_histogram / terms / histogram, got keys: " + <> T.unpack (T.intercalate ", " (fmap (T.pack . show) (KeyMap.keys v))) + ) + +-- | The @date_histogram@ dimension. @fixed_interval@ is the documented +-- form (e.g. @"1h"@); @calendar_interval@ is also accepted by the plugin. +-- @target_field@ is server-populated on the response (mirroring +-- @source_field@ by default) and omitted on the request. +-- See +data RollupDateHistogram = RollupDateHistogram + { rollupDateHistogramSourceField :: Text, + rollupDateHistogramFixedInterval :: Maybe Text, + rollupDateHistogramCalendarInterval :: Maybe Text, + rollupDateHistogramTimezone :: Maybe Text, + rollupDateHistogramTargetField :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupDateHistogram where + parseJSON = withObject "RollupDateHistogram" $ \v -> do + rollupDateHistogramSourceField <- v .: "source_field" + rollupDateHistogramFixedInterval <- v .:? "fixed_interval" + rollupDateHistogramCalendarInterval <- v .:? "calendar_interval" + rollupDateHistogramTimezone <- v .:? "timezone" + rollupDateHistogramTargetField <- v .:? "target_field" + pure RollupDateHistogram {..} + +instance ToJSON RollupDateHistogram where + toJSON RollupDateHistogram {..} = + omitNulls + [ "source_field" .= rollupDateHistogramSourceField, + "fixed_interval" .= rollupDateHistogramFixedInterval, + "calendar_interval" .= rollupDateHistogramCalendarInterval, + "timezone" .= rollupDateHistogramTimezone, + "target_field" .= rollupDateHistogramTargetField + ] + +-- | The @terms@ dimension. @target_field@ is server-populated on the +-- response and omitted on the request. +-- See +data RollupTerms = RollupTerms + { rollupTermsSourceField :: Text, + rollupTermsTargetField :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupTerms where + parseJSON = withObject "RollupTerms" $ \v -> do + rollupTermsSourceField <- v .: "source_field" + rollupTermsTargetField <- v .:? "target_field" + pure RollupTerms {..} + +instance ToJSON RollupTerms where + toJSON RollupTerms {..} = + omitNulls + [ "source_field" .= rollupTermsSourceField, + "target_field" .= rollupTermsTargetField + ] + +-- | The @histogram@ dimension (numeric). @target_field@ is +-- server-populated on the response and omitted on the request. +-- See +data RollupHistogram = RollupHistogram + { rollupHistogramSourceField :: Text, + rollupHistogramInterval :: Scientific, + rollupHistogramTargetField :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupHistogram where + parseJSON = withObject "RollupHistogram" $ \v -> do + rollupHistogramSourceField <- v .: "source_field" + rollupHistogramInterval <- v .: "interval" + rollupHistogramTargetField <- v .:? "target_field" + pure RollupHistogram {..} + +instance ToJSON RollupHistogram where + toJSON RollupHistogram {..} = + omitNulls + [ "source_field" .= rollupHistogramSourceField, + "interval" .= rollupHistogramInterval, + "target_field" .= rollupHistogramTargetField + ] + +-- | A field + the metrics to compute over it. Each 'RollupMetricAgg' +-- encodes as a single-key object (e.g. @{"avg":{}}@). +-- See +data RollupMetric = RollupMetric + { rollupMetricSourceField :: Text, + rollupMetricMetrics :: [RollupMetricAgg] + } + deriving stock (Eq, Show) + +instance FromJSON RollupMetric where + parseJSON = withObject "RollupMetric" $ \v -> do + rollupMetricSourceField <- v .: "source_field" + rollupMetricMetrics <- v .:? "metrics" .!= [] + pure RollupMetric {..} + +instance ToJSON RollupMetric where + toJSON RollupMetric {..} = + omitNulls + [ "source_field" .= rollupMetricSourceField, + "metrics" .= rollupMetricMetrics + ] + +-- | The supported per-field metric aggregations. Each encodes to a +-- single-key object whose value is an empty object (@{"avg":{}}@). +-- Unknown keys surface as 'RollupMetricAggCustom' rather than failing. +-- See +data RollupMetricAgg + = RollupMetricAvg + | RollupMetricSum + | RollupMetricMax + | RollupMetricMin + | RollupMetricValueCount + | RollupMetricAggCustom Text + deriving stock (Eq, Show) + +rollupMetricAggText :: RollupMetricAgg -> Text +rollupMetricAggText = \case + RollupMetricAvg -> "avg" + RollupMetricSum -> "sum" + RollupMetricMax -> "max" + RollupMetricMin -> "min" + RollupMetricValueCount -> "value_count" + RollupMetricAggCustom t -> t + +instance ToJSON RollupMetricAgg where + toJSON agg = object [fromText (rollupMetricAggText agg) .= object []] + +instance FromJSON RollupMetricAgg where + parseJSON = withObject "RollupMetricAgg" $ \v -> case KeyMap.toList v of + [(k, _)] -> pure (rollupMetricAggFromKey (toText k)) + _ -> + fail + ( "RollupMetricAgg: expected a single-key object (e.g. {\"avg\":{}}), \ + \got keys: " + <> T.unpack (T.intercalate ", " (fmap (T.pack . show) (KeyMap.keys v))) + ) + +rollupMetricAggFromKey :: Text -> RollupMetricAgg +rollupMetricAggFromKey = \case + "avg" -> RollupMetricAvg + "sum" -> RollupMetricSum + "max" -> RollupMetricMax + "min" -> RollupMetricMin + "value_count" -> RollupMetricValueCount + other -> RollupMetricAggCustom other + +-- | Parse a 'Maybe' field that may appear under either of two JSON keys. +-- Used for @_seq_no@\/@_seqNo@ and @_primary_term@\/@_primaryTerm@, which +-- the rollup plugin emits in snake_case on PUT responses and camelCase +-- on GET responses. +rollupKey :: (FromJSON a) => Object -> Key -> Key -> Parser (Maybe a) +rollupKey o snake camel = do + m <- o .:? snake + case m of + Just x -> pure (Just x) + Nothing -> o .:? camel + +-- | Response body of @PUT \/_plugins\/_rollup\/jobs\/{rollup_id}@ and +-- @GET \/_plugins\/_rollup\/jobs\/{rollup_id}@. Wraps the persisted +-- 'RollupResponseInner' in a document-write envelope (@_id@, @_version@, +-- @_seq_no@, @_primary_term@). The PUT response uses snake_case +-- (@_seq_no@\/@_primary_term@); the GET response uses camelCase +-- (@_seqNo@\/@_primaryTerm@); both are accepted via 'rollupKey'. +-- See +data RollupResponse = RollupResponse + { rollupResponseId :: Text, + rollupResponseVersion :: Maybe Int, + rollupResponseSeqNo :: Maybe Int, + rollupResponsePrimaryTerm :: Maybe Int, + rollupResponseRollup :: RollupResponseInner + } + deriving stock (Eq, Show) + +instance FromJSON RollupResponse where + parseJSON = withObject "RollupResponse" $ \v -> do + rollupResponseId <- v .: "_id" + rollupResponseVersion <- v .:? "_version" + rollupResponseSeqNo <- rollupKey v "_seq_no" "_seqNo" + rollupResponsePrimaryTerm <- rollupKey v "_primary_term" "_primaryTerm" + rollupResponseRollup <- v .: "rollup" + pure RollupResponse {..} + +instance ToJSON RollupResponse where + toJSON RollupResponse {..} = + omitNulls + [ "_id" .= rollupResponseId, + "_version" .= rollupResponseVersion, + "_seq_no" .= rollupResponseSeqNo, + "_primary_term" .= rollupResponsePrimaryTerm, + "rollup" .= rollupResponseRollup + ] + +-- | The persisted @rollup@ object returned in responses. Carries the +-- full 'Rollup' body alongside server-injected bookkeeping fields +-- (@rollup_id@, @last_updated_time@, @enabled_time@, @schema_version@, +-- @metadata_id@). The round-trip preserves everything the server sent, +-- so a Get -> Update cycle does not lose data the caller never set. +-- See +data RollupResponseInner = RollupResponseInner + { rollupResponseInnerSourceIndex :: Text, + rollupResponseInnerTargetIndex :: Text, + rollupResponseInnerTargetIndexSettings :: Maybe Value, + rollupResponseInnerSchedule :: RollupSchedule, + rollupResponseInnerDescription :: Maybe Text, + rollupResponseInnerEnabled :: Maybe Bool, + rollupResponseInnerContinuous :: Maybe Bool, + rollupResponseInnerPageSize :: Maybe Int, + rollupResponseInnerDelay :: Maybe Integer, + rollupResponseInnerRoles :: Maybe [Text], + rollupResponseInnerRoutingField :: Maybe Text, + rollupResponseInnerDimensions :: [RollupDimension], + rollupResponseInnerMetrics :: Maybe [RollupMetric], + rollupResponseInnerErrorNotification :: Maybe Value, + rollupResponseInnerRollupId :: Maybe Text, + rollupResponseInnerLastUpdatedTime :: Maybe Integer, + rollupResponseInnerEnabledTime :: Maybe Integer, + rollupResponseInnerSchemaVersion :: Maybe Int, + rollupResponseInnerMetadataId :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupResponseInner where + parseJSON = withObject "RollupResponseInner" $ \v -> do + rollupResponseInnerSourceIndex <- v .: "source_index" + rollupResponseInnerTargetIndex <- v .: "target_index" + rollupResponseInnerTargetIndexSettings <- v .:? "target_index_settings" + rollupResponseInnerSchedule <- v .: "schedule" + rollupResponseInnerDescription <- v .:? "description" + rollupResponseInnerEnabled <- v .:? "enabled" + rollupResponseInnerContinuous <- v .:? "continuous" + rollupResponseInnerPageSize <- v .:? "page_size" + rollupResponseInnerDelay <- v .:? "delay" + rollupResponseInnerRoles <- v .:? "roles" + rollupResponseInnerRoutingField <- v .:? "routing_field" + rollupResponseInnerDimensions <- v .:? "dimensions" .!= [] + rollupResponseInnerMetrics <- v .:? "metrics" + rollupResponseInnerErrorNotification <- v .:? "error_notification" + rollupResponseInnerRollupId <- v .:? "rollup_id" + rollupResponseInnerLastUpdatedTime <- v .:? "last_updated_time" + rollupResponseInnerEnabledTime <- v .:? "enabled_time" + rollupResponseInnerSchemaVersion <- v .:? "schema_version" + rollupResponseInnerMetadataId <- v .:? "metadata_id" + pure RollupResponseInner {..} + +instance ToJSON RollupResponseInner where + toJSON RollupResponseInner {..} = + omitNulls + [ "source_index" .= rollupResponseInnerSourceIndex, + "target_index" .= rollupResponseInnerTargetIndex, + "target_index_settings" .= rollupResponseInnerTargetIndexSettings, + "schedule" .= rollupResponseInnerSchedule, + "description" .= rollupResponseInnerDescription, + "enabled" .= rollupResponseInnerEnabled, + "continuous" .= rollupResponseInnerContinuous, + "page_size" .= rollupResponseInnerPageSize, + "delay" .= rollupResponseInnerDelay, + "roles" .= rollupResponseInnerRoles, + "routing_field" .= rollupResponseInnerRoutingField, + "dimensions" .= rollupResponseInnerDimensions, + "metrics" .= rollupResponseInnerMetrics, + "error_notification" .= rollupResponseInnerErrorNotification, + "rollup_id" .= rollupResponseInnerRollupId, + "last_updated_time" .= rollupResponseInnerLastUpdatedTime, + "enabled_time" .= rollupResponseInnerEnabledTime, + "schema_version" .= rollupResponseInnerSchemaVersion, + "metadata_id" .= rollupResponseInnerMetadataId + ] + +-- | Response body of @GET \/_plugins\/_rollup\/jobs\/{rollup_id}\/_explain@. +-- The plugin keys the response by the rollup job id at the top level, so +-- the body is decoded into a 'Map' from rollup id to 'ExplainRollupEntry'. +-- The caller looks up the entry for the id it requested via +-- 'explainRollupResponseLookup'. +-- See +newtype ExplainRollupResponse = ExplainRollupResponse + { explainRollupResponseMap :: Map.Map Text ExplainRollupEntry + } + deriving stock (Eq, Show) + +instance FromJSON ExplainRollupResponse where + parseJSON v = ExplainRollupResponse <$> parseJSON v + +-- | Lookup the entry for a rollup id. Returns 'Nothing' if the id is +-- absent from the response. +explainRollupResponseLookup :: Text -> ExplainRollupResponse -> Maybe ExplainRollupEntry +explainRollupResponseLookup rid = Map.lookup rid . explainRollupResponseMap + +-- | The entries of an 'ExplainRollupResponse', as an association list. +explainRollupResponseToList :: ExplainRollupResponse -> [(Text, ExplainRollupEntry)] +explainRollupResponseToList = Map.toList . explainRollupResponseMap + +-- | One entry under the explain-response top-level map. Both fields are +-- JSON @null@ (not absent) when the rollup job has not yet executed. +-- See +data ExplainRollupEntry = ExplainRollupEntry + { explainRollupEntryMetadataId :: Maybe Text, + explainRollupEntryRollupMetadata :: Maybe RollupMetadata + } + deriving stock (Eq, Show) + +instance FromJSON ExplainRollupEntry where + parseJSON = withObject "ExplainRollupEntry" $ \v -> do + explainRollupEntryMetadataId <- v .:? "metadata_id" + explainRollupEntryRollupMetadata <- v .:? "rollup_metadata" + pure ExplainRollupEntry {..} + +-- | The @rollup_metadata@ object inside an explain entry. Carries the +-- job execution status, failure reason and run statistics. @status@ is +-- a closed enum with a forward-compat escape hatch. +-- See +data RollupMetadata = RollupMetadata + { rollupMetadataRollupId :: Text, + rollupMetadataLastUpdatedTime :: Integer, + rollupMetadataStatus :: RollupStatus, + rollupMetadataFailureReason :: Maybe Text, + rollupMetadataStats :: Maybe RollupStats, + rollupMetadataNextWindowStartTime :: Maybe Integer, + rollupMetadataNextWindowEndTime :: Maybe Integer + } + deriving stock (Eq, Show) + +instance FromJSON RollupMetadata where + parseJSON = withObject "RollupMetadata" $ \v -> do + rollupMetadataRollupId <- v .: "rollup_id" + rollupMetadataLastUpdatedTime <- v .: "last_updated_time" + rollupMetadataStatus <- v .: "status" + rollupMetadataFailureReason <- v .:? "failure_reason" + rollupMetadataStats <- v .:? "stats" + rollupMetadataNextWindowStartTime <- v .:? "next_window_start_time" + rollupMetadataNextWindowEndTime <- v .:? "next_window_end_time" + pure RollupMetadata {..} + +instance ToJSON RollupMetadata where + toJSON RollupMetadata {..} = + omitNulls + [ "rollup_id" .= rollupMetadataRollupId, + "last_updated_time" .= rollupMetadataLastUpdatedTime, + "status" .= rollupMetadataStatus, + "failure_reason" .= rollupMetadataFailureReason, + "stats" .= rollupMetadataStats, + "next_window_start_time" .= rollupMetadataNextWindowStartTime, + "next_window_end_time" .= rollupMetadataNextWindowEndTime + ] + +-- | The @rollup_metadata.status@ enum. +-- See +data RollupStatus + = RollupStatusInit + | RollupStatusStarted + | RollupStatusFinished + | RollupStatusFailed + | RollupStatusStopped + | RollupStatusRetry + | RollupStatusCustom Text + deriving stock (Eq, Show) + +rollupStatusText :: RollupStatus -> Text +rollupStatusText = \case + RollupStatusInit -> "init" + RollupStatusStarted -> "started" + RollupStatusFinished -> "finished" + RollupStatusFailed -> "failed" + RollupStatusStopped -> "stopped" + RollupStatusRetry -> "retry" + RollupStatusCustom t -> t + +instance ToJSON RollupStatus where + toJSON = toJSON . rollupStatusText + +instance FromJSON RollupStatus where + parseJSON = withText "RollupStatus" $ \case + "init" -> pure RollupStatusInit + "started" -> pure RollupStatusStarted + "finished" -> pure RollupStatusFinished + "failed" -> pure RollupStatusFailed + "stopped" -> pure RollupStatusStopped + "retry" -> pure RollupStatusRetry + other -> pure (RollupStatusCustom other) + +-- | The @rollup_metadata.stats@ object. +-- See +data RollupStats = RollupStats + { rollupStatsPagesProcessed :: Int, + rollupStatsDocumentsProcessed :: Int, + rollupStatsRollupsIndexed :: Int, + rollupStatsIndexTimeInMillis :: Integer, + rollupStatsSearchTimeInMillis :: Integer + } + deriving stock (Eq, Show) + +instance FromJSON RollupStats where + parseJSON = withObject "RollupStats" $ \v -> do + rollupStatsPagesProcessed <- v .: "pages_processed" + rollupStatsDocumentsProcessed <- v .: "documents_processed" + rollupStatsRollupsIndexed <- v .: "rollups_indexed" + rollupStatsIndexTimeInMillis <- v .: "index_time_in_millis" + rollupStatsSearchTimeInMillis <- v .: "search_time_in_millis" + pure RollupStats {..} + +instance ToJSON RollupStats where + toJSON RollupStats {..} = + object + [ "pages_processed" .= rollupStatsPagesProcessed, + "documents_processed" .= rollupStatsDocumentsProcessed, + "rollups_indexed" .= rollupStatsRollupsIndexed, + "index_time_in_millis" .= rollupStatsIndexTimeInMillis, + "search_time_in_millis" .= rollupStatsSearchTimeInMillis + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/SQLPPL.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/SQLPPL.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/SQLPPL.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.SQLPPL + ( SQLRequest (..), + PPLRequest (..), + SQLParameter (..), + SQLCursor (..), + SQLCursorRequest (..), + SQLColumn (..), + SQLResult (..), + PPLResult, + SQLCloseResult (..), + ) +where + +import Data.Aeson + ( FromJSON (..), + ToJSON (..), + Value, + object, + withObject, + (.:), + (.:?), + (.=), + ) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) + +-- $schema +-- +-- The OpenSearch SQL and PPL query endpoints +-- () +-- share a single Query API surface that differs only by path +-- (@POST /_plugins/_sql@ versus @POST /_plugins/_ppl@) and by the dialect of +-- the @query@ string. The response shape (a JDBC-style rowset) is identical. +-- +-- /Pagination/ is SQL-only: when the request body includes a positive +-- @fetch_size@, the first response carries a 'SQLCursor' and subsequent pages +-- are fetched by POSTing a 'SQLCursorRequest' body (@{"cursor": "..."}@) to +-- the same @/_plugins/_sql@ endpoint. A continuation response omits the +-- @schema@, @total@, @size@ and @status@ fields, so every field of 'SQLResult' +-- except @datarows@ is 'Maybe'. The cursor is opaque (a @d:@-prefixed +-- server-generated token); release it with @POST /_plugins/_sql/close@. +-- +-- /Wire inconsistencies./ The plugin's response-field table documents the +-- row array as @data_rows@ and the HTTP status as a String; every JSON +-- example in the same docs uses @datarows@ and an integer (@200@). We trust +-- the wire (examples) over the prose: the field is @datarows@ and 'sqlResultStatus' +-- is 'Int'. +-- +-- /Format./ This module models the default @jdbc@ response format (the only +-- format whose body is the JSON shape below). The @csv@, @raw@ and @json@ +-- formats return non-JSON bodies and are out of scope; callers that need +-- them should bypass these types. + +-- | Request body for @POST /_plugins/_sql@. Only 'sqlRequestQuery' is +-- required; the rest are optional. @fetch_size@ requires the @jdbc@ +-- response format (the default) and triggers cursor pagination; a value of +-- @0@ falls back to non-paginated. @parameters@ carries prepared-statement +-- bind variables (shown in the plugin's @_explain@ examples though absent +-- from its field table). +data SQLRequest = SQLRequest + { sqlRequestQuery :: Text, + sqlRequestFilter :: Maybe Value, + sqlRequestFetchSize :: Maybe Int, + sqlRequestParameters :: Maybe [SQLParameter] + } + deriving stock (Eq, Show) + +instance ToJSON SQLRequest where + toJSON SQLRequest {..} = + omitNulls + [ "query" .= sqlRequestQuery, + "filter" .= sqlRequestFilter, + "fetch_size" .= sqlRequestFetchSize, + "parameters" .= sqlRequestParameters + ] + +instance FromJSON SQLRequest where + parseJSON = withObject "SQLRequest" $ \v -> do + sqlRequestQuery <- v .: "query" + sqlRequestFilter <- v .:? "filter" + sqlRequestFetchSize <- v .:? "fetch_size" + sqlRequestParameters <- v .:? "parameters" + pure SQLRequest {..} + +-- | Request body for @POST /_plugins/_ppl@. PPL does not support +-- @fetch_size@ / cursor pagination (the plugin documents @fetch_size@ as +-- SQL-only), so this record has no such field. +data PPLRequest = PPLRequest + { pplRequestQuery :: Text, + pplRequestFilter :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON PPLRequest where + toJSON PPLRequest {..} = + omitNulls + [ "query" .= pplRequestQuery, + "filter" .= pplRequestFilter + ] + +instance FromJSON PPLRequest where + parseJSON = withObject "PPLRequest" $ \v -> do + pplRequestQuery <- v .: "query" + pplRequestFilter <- v .:? "filter" + pure PPLRequest {..} + +-- | A prepared-statement bind variable, as documented by the plugin's +-- @_explain@ examples: @{"type": "integer", "value": 30}@. The @type@ field +-- uses an open vocabulary (@integer@, @string@, @long@, @boolean@, ...) so +-- it is kept as 'Text' rather than a closed enum. +data SQLParameter = SQLParameter + { sqlParameterType :: Text, + sqlParameterValue :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SQLParameter where + toJSON SQLParameter {..} = + object + [ "type" .= sqlParameterType, + "value" .= sqlParameterValue + ] + +instance FromJSON SQLParameter where + parseJSON = withObject "SQLParameter" $ \v -> do + sqlParameterType <- v .: "type" + sqlParameterValue <- v .: "value" + pure SQLParameter {..} + +-- | An opaque pagination cursor returned by paginated SQL responses. The +-- wire value is a @d:@-prefixed base64 blob; treat it as opaque and send it +-- back verbatim via 'SQLCursorRequest' or @POST /_plugins/_sql/close@. +newtype SQLCursor = SQLCursor {unSQLCursor :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Request body for cursor continuation and close requests +-- (@{"cursor": "..."}@). The server rejects a body that carries both +-- @query@ and @cursor@, so this is a distinct type from 'SQLRequest'. +newtype SQLCursorRequest = SQLCursorRequest {sqlCursorRequestCursor :: SQLCursor} + deriving stock (Eq, Show) + +instance ToJSON SQLCursorRequest where + toJSON SQLCursorRequest {..} = + object ["cursor" .= sqlCursorRequestCursor] + +instance FromJSON SQLCursorRequest where + parseJSON = withObject "SQLCursorRequest" $ \v -> do + sqlCursorRequestCursor <- v .: "cursor" + pure SQLCursorRequest {..} + +-- | One column descriptor from the 'SQLResult' @schema@ array. The @type@ +-- field uses an open vocabulary (@long@, @text@, @double@, @boolean@, +-- @keyword@, ...) plus user-defined types via index mappings, so it is kept +-- as 'Text' rather than a closed enum. +data SQLColumn = SQLColumn + { sqlColumnName :: Text, + sqlColumnType :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SQLColumn where + parseJSON = withObject "SQLColumn" $ \v -> do + sqlColumnName <- v .: "name" + sqlColumnType <- v .: "type" + pure SQLColumn {..} + +instance ToJSON SQLColumn where + toJSON SQLColumn {..} = + object + [ "name" .= sqlColumnName, + "type" .= sqlColumnType + ] + +-- | Response of @POST /_plugins/_sql@ and @POST /_plugins/_ppl@. Only +-- 'sqlResultDatarows' is present on every response (initial, continuation, +-- and final page); @schema@, @total@, @size@ and @status@ are dropped on +-- cursor-continuation pages and are therefore 'Maybe'. @cursor@ is present +-- on every page except the last. Each row in @datarows@ is a heterogeneous +-- JSON array whose cells line up with 'sqlResultSchema'; cells are kept as +-- aeson 'Value's because the column type governs interpretation, not the +-- Haskell type. +data SQLResult = SQLResult + { sqlResultSchema :: Maybe [SQLColumn], + sqlResultDatarows :: [[Value]], + sqlResultTotal :: Maybe Int, + sqlResultSize :: Maybe Int, + sqlResultStatus :: Maybe Int, + sqlResultCursor :: Maybe SQLCursor + } + deriving stock (Eq, Show) + +instance FromJSON SQLResult where + parseJSON = withObject "SQLResult" $ \v -> do + sqlResultSchema <- v .:? "schema" + sqlResultDatarows <- v .: "datarows" + sqlResultTotal <- v .:? "total" + sqlResultSize <- v .:? "size" + sqlResultStatus <- v .:? "status" + sqlResultCursor <- v .:? "cursor" + pure SQLResult {..} + +instance ToJSON SQLResult where + toJSON SQLResult {..} = + omitNulls + [ "schema" .= sqlResultSchema, + "datarows" .= sqlResultDatarows, + "total" .= sqlResultTotal, + "size" .= sqlResultSize, + "status" .= sqlResultStatus, + "cursor" .= sqlResultCursor + ] + +-- | PPL uses the same response shape as SQL. The alias keeps the bead's +-- acceptance signature (@pplQuery :: ... -> m PPLResult@) self-documenting +-- without duplicating aeson instances. +type PPLResult = SQLResult + +-- | Response of @POST /_plugins/_sql/close@. Always @{"succeeded": true}@ on +-- a successful cursor release. +newtype SQLCloseResult = SQLCloseResult + { sqlCloseResultSucceeded :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON SQLCloseResult where + parseJSON = withObject "SQLCloseResult" $ \v -> do + sqlCloseResultSucceeded <- v .: "succeeded" + pure SQLCloseResult {..} + +instance ToJSON SQLCloseResult where + toJSON SQLCloseResult {..} = + object ["succeeded" .= sqlCloseResultSucceeded] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/SQLStats.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/SQLStats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/SQLStats.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.SQLStats + ( SQLPluginStats (..), + ) +where + +import Data.Map.Strict qualified as Map +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The @GET /_plugins/_sql/stats@ endpoint (SQL plugin, see +-- ) +-- returns a JSON object whose keys are metric names (@request_total@, +-- @request_count@, @default_cursor_request_total@, +-- @default_cursor_request_count@, @failed_request_count_syserr@, +-- @failed_request_count_cuserr@, @failed_request_count_cb@, +-- @circuit_breaker@) and whose values are integers. The endpoint is +-- node-level only (the plugin explicitly documents that cluster-level +-- stats are not implemented), so unlike 'MLStats' there is no @nodes@ +-- sub-key and no cluster-level envelope — the body is one flat object +-- describing the node you hit. +-- +-- The metric-name set is large and grows across OpenSearch releases +-- (eight keys on 1.x; @ppl_*@, @datasource_*@, @async_query_*@, @emr_*@ +-- and @streaming_*@ keys land in later versions). Modelling the body as +-- a typed record would lock the client to one plugin version and +-- require churn on every release, so the body is kept as a flat +-- 'Map.Map Text Value' — callers get a typed envelope and navigate to +-- any individual metric with the aeson combinators they already use +-- elsewhere (e.g. @'Map.lookup' \"request_total\"@ followed by +-- @'fromJSON'@ into a 'Integer'). Every value the plugin emits today is +-- a JSON integer, but 'Value' is preferred over 'Integer' for forward +-- compatibility: if the plugin ever introduces a non-integer metric +-- (a string state, a floating-point ratio), the decoder does not need +-- to change. + +-- | Response of @GET /_plugins/_sql/stats@. The body is a flat JSON +-- object mapping metric names to integer values; see the module docs +-- for why the entries are kept as aeson 'Value's rather than modelled +-- per-metric. The 'Map.Map' round-trips a flat JSON object via its +-- aeson instances, so no custom 'ToJSON' \/ 'FromJSON' is needed. To +-- read an individual metric, decode the value with aeson, e.g.: +-- +-- @ +-- case 'Map.lookup' \"request_total\" (sqlPluginStatsEntries stats) of +-- 'Just' ('Number' n) -> ... n is a 'Scientific' ... +-- _ -> 'Nothing' +-- @ +newtype SQLPluginStats = SQLPluginStats + { sqlPluginStatsEntries :: Map.Map Text Value + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/SecurityAnalytics.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/SecurityAnalytics.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/SecurityAnalytics.hs @@ -0,0 +1,2807 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.SecurityAnalytics + ( -- * Identifiers + RuleId (..), + + -- * Discriminators + SADetectorType (..), + saDetectorTypeText, + + -- * Schedule + SASchedule (..), + SASchedulePeriod (..), + + -- * Inputs, triggers, actions + SARuleReference (..), + SADetectorInput (..), + SATrigger (..), + SAAction (..), + SAMessageTemplate (..), + SAThrottle (..), + + -- * Detector and response wrappers + SADetector (..), + SADetectorResponse (..), + + -- * Rule search + SARulesQuery (..), + defaultSARulesQuery, + SARulesTotal (..), + SARulesTotalRelation (..), + SARulesShards (..), + SARuleValue (..), + SARule (..), + SARuleHit (..), + SARulesSearchResponse (..), + saRulesSearchResponseRules, + + -- * Rule create, update, and delete + SARuleResponse (..), + DeleteSARuleResponse (..), + + -- * Detector update, delete, and search + SADetectorsSearchQuery (..), + defaultSADetectorsSearchQuery, + SADetectorsSearchResponse (..), + SADetectorHit (..), + SADetectorsTotal (..), + SADetectorsTotalRelation (..), + SADetectorsShards (..), + saDetectorsSearchResponseDetectors, + DeleteSADetectorResponse (..), + + -- * Mappings API + SAMappingProperty (..), + SAMappingsBody (..), + SAMappingsIndexBody (..), + SAMappingsViewRequest (..), + SAMappingsViewResponse (..), + SACreateMappingsRequest (..), + SAUpdateMappingsRequest (..), + SAGetMappingsResponse, + + -- * Alerts API + SAGetAlertsOptions (..), + defaultSAGetAlertsOptions, + saGetAlertsOptionsParams, + SAAlertState (..), + saAlertStateText, + SAActionExecutionResult (..), + SAAlert (..), + SAGetAlertsResponse (..), + AcknowledgeSADetectorAlertsRequest (..), + AcknowledgeSADetectorAlertsResponse (..), + + -- * Findings API + SASearchFindingsOptions (..), + defaultSASearchFindingsOptions, + saSearchFindingsOptionsParams, + SADetectionType (..), + saDetectionTypeText, + SASeverity (..), + saSeverityText, + SAFindingQuery (..), + SAFindingDocument (..), + SAFinding (..), + SASearchFindingsResponse (..), + + -- * Correlation API + SACorrelateEntry (..), + CreateSACorrelationRuleRequest (..), + SACorrelationRule (..), + CreateSACorrelationRuleResponse (..), + SACorrelationFinding (..), + GetSACorrelationsOptions (..), + defaultGetSACorrelationsOptions, + getSACorrelationsOptionsParams, + GetSACorrelationsResponse (..), + FindSACorrelationOptions (..), + defaultFindSACorrelationOptions, + findSACorrelationOptionsParams, + SACorrelationScore (..), + FindSACorrelationResponse (..), + SearchSACorrelationAlertsOptions (..), + defaultSearchSACorrelationAlertsOptions, + searchSACorrelationAlertsOptionsParams, + SACorrelationAlert (..), + SearchSACorrelationAlertsResponse (..), + AcknowledgeSACorrelationAlertsRequest (..), + AcknowledgeSACorrelationAlertsResponse (..), + + -- * Log type API + SALogTypeSource (..), + saLogTypeSourceText, + SALogTypeTags (..), + SALogType (..), + SALogTypeResponse (..), + SALogTypeSearchQuery (..), + defaultSALogTypeSearchQuery, + SALogTypeHit (..), + SALogTypesTotal (..), + SALogTypesTotalRelation (..), + SALogTypesSearchResponse (..), + saLogTypesSearchResponseLogTypes, + DeleteSALogTypeResponse (..), + ) +where + +import Data.Aeson +import Data.Aeson.Key qualified as K (fromText) +import Data.Aeson.KeyMap qualified as KM +import Data.Int (Int64) +import Data.Map.Strict (Map) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The Security Analytics plugin (see +-- ) +-- runs scheduled detectors over log indexes, evaluates them against +-- Sigma rules (pre-packaged and custom), and dispatches alert +-- notifications when trigger conditions fire. This module covers the +-- detector create\/get endpoints +-- (@POST\/GET \/\/_plugins\/_security_analytics\/detectors[\/{id}]@) and +-- the rule search endpoints +-- (@POST \/\/_plugins\/_security_analytics\/rules\/_search?pre_packaged=@). +-- +-- The wire shape of a 'SADetector' is a discriminated object: the +-- @detector_type@ field selects one of the documented log types +-- (linux, network, windows, ad_ldap, ...), the @inputs@ array carries +-- index references plus rule references, and the @triggers@ array +-- carries alert triggers with their own actions. Following the +-- pragmatic precedent set by the sibling Alerting 'Monitor' type, this +-- module types the /shell/ — the stable fields common to every +-- detector — and models the fields this library does not yet +-- interpret as opaque aeson 'Value's. Unknown top-level keys are +-- preserved verbatim in 'saDetectorOther' / 'saTriggerOther' / +-- 'saActionOther' so future plugin additions, server-injected +-- timestamps (@last_update_time@, @enabled_time@), and the +-- @rule_topic_index@ \/ @alert_index@ \/ @findings_index@ family of +-- server-managed fields round-trip cleanly. +-- +-- Wire gotchas pinned by the test suite: +-- +-- * @triggers[].severity@ is documented as an 'Int' but the wire emits +-- a string-encoded integer (e.g. @"1"@); typed as 'Text' to match +-- the wire, mirroring the Alerting 'triggerSeverity' precedent. +-- * @triggers[].actions@ is documented as an Object but is actually +-- an array of action objects on the wire; typed as @['SAAction']@. +-- * The @type@ discriminator (constant @"detector"@) and +-- @triggers[].types@ appear in the examples but are not in the +-- field table; captured as typed @Maybe 'Text'@ / @['Text']@ fields +-- rather than dropped into the catch-all. +-- * The request example encodes @detector_type@ in upper case +-- (@\"WINDOWS\"@); the response lower-cases it (@\"windows\"@). The +-- 'SADetectorType' renderer emits the lower-case form so a +-- create-then-get round-trip is byte-stable on the @detector_type@ +-- field; callers wanting the upper-case request form can use +-- 'SADetectorTypeOther'. +-- +-- The rule retrieval surface deviates from the bead's +-- @getSARules :: m [SARule]@ acceptance: the +-- @GET \/\/_plugins\/_security_analytics\/rules@ endpoint the bead +-- names does not exist on the server. Rule retrieval is via the +-- search endpoints @POST ...\/rules\/_search?pre_packaged=true|false@, +-- returning a standard OpenSearch search envelope +-- ('SARulesSearchResponse'). Two functions are shipped +-- ('searchSAPrePackagedRules' and 'searchSACustomRules'); see the +-- Haddock on those functions and the changelog entry for +-- bloodhound-04f.6.11.3 for the deviation rationale (mirrors the +-- 'deleteMonitor' / bloodhound-04f.6.7.4 precedent). + +-- | The server-assigned identifier of a rule (custom or +-- pre-packaged). Wraps 'Text' for the same reason as 'DetectorId'. +newtype RuleId = RuleId {unRuleId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @detector_type@ discriminator selecting the log type the +-- detector runs against. The eight values documented on the API page +-- are given dedicated constructors; any future log type falls through +-- to 'SADetectorTypeOther'. 'saDetectorTypeText' round-trips every +-- constructor in the lower-case form the server persists. +data SADetectorType + = SADetectorTypeLinux + | SADetectorTypeNetwork + | SADetectorTypeWindows + | SADetectorTypeAdLdap + | SADetectorTypeApacheAccess + | SADetectorTypeCloudtrail + | SADetectorTypeDns + | SADetectorTypeS3 + | SADetectorTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'SADetectorType'. Values are the lower-case +-- forms the server persists on the response; the request example in +-- the docs uses upper case (@\"WINDOWS\"@) but the server +-- normalises, so the lower-case form is emitted here for round-trip +-- stability. +saDetectorTypeText :: SADetectorType -> Text +saDetectorTypeText = \case + SADetectorTypeLinux -> "linux" + SADetectorTypeNetwork -> "network" + SADetectorTypeWindows -> "windows" + SADetectorTypeAdLdap -> "ad_ldap" + SADetectorTypeApacheAccess -> "apache_access" + SADetectorTypeCloudtrail -> "cloudtrail" + SADetectorTypeDns -> "dns" + SADetectorTypeS3 -> "s3" + SADetectorTypeOther t -> t + +instance ToJSON SADetectorType where + toJSON = toJSON . saDetectorTypeText + +instance FromJSON SADetectorType where + parseJSON = withText "SADetectorType" $ \t -> + pure $ + case T.toLower t of + "linux" -> SADetectorTypeLinux + "network" -> SADetectorTypeNetwork + "windows" -> SADetectorTypeWindows + "ad_ldap" -> SADetectorTypeAdLdap + "apache_access" -> SADetectorTypeApacheAccess + "cloudtrail" -> SADetectorTypeCloudtrail + "dns" -> SADetectorTypeDns + "s3" -> SADetectorTypeS3 + _ -> SADetectorTypeOther t + +-- | The @schedule.period@ sub-object. Deliberately mirrors the shape +-- of 'Database.Bloodhound.Internal.Versions.OpenSearch2.Types.Alerting.SchedulePeriod' +-- but is modelled locally under an @SA@-prefixed name so the two +-- plugins can evolve independently (the same precedent the codebase +-- uses for per-plugin @Shards@ types). +data SASchedulePeriod = SASchedulePeriod + { saSchedulePeriodInterval :: Int, + saSchedulePeriodUnit :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SASchedulePeriod where + toJSON SASchedulePeriod {..} = + object + [ "interval" .= saSchedulePeriodInterval, + "unit" .= saSchedulePeriodUnit + ] + +instance FromJSON SASchedulePeriod where + parseJSON = withObject "SASchedulePeriod" $ \o -> + SASchedulePeriod + <$> o .: "interval" + <*> o .: "unit" + +-- | The @schedule@ sub-object. The Security Analytics detector API +-- documents only the @period {interval, unit}@ variant; any other +-- shape is preserved verbatim via 'OtherSASchedule' so a decode +-- never drops user data (mirrors the Alerting 'Schedule' design). +data SASchedule + = PeriodSASchedule SASchedulePeriod + | OtherSASchedule Value + deriving stock (Eq, Show) + +instance ToJSON SASchedule where + toJSON = \case + PeriodSASchedule p -> object ["period" .= p] + OtherSASchedule v -> v + +instance FromJSON SASchedule where + parseJSON = withObject "SASchedule" $ \o -> + (PeriodSASchedule <$> o .: "period") + <|> pure (OtherSASchedule (Object o)) + +-- | The @{\"id\": ...}@ shape used by both @custom_rules@ and +-- @pre_packaged_rules@ in 'SADetectorInput'. The id is opaque to +-- this library — it can be a UUID or a server-assigned base64 string +-- depending on whether the rule is custom or pre-packaged. +newtype SARuleReference = SARuleReference {saRuleReferenceId :: Text} + deriving stock (Eq, Show) + +instance ToJSON SARuleReference where + toJSON (SARuleReference i) = object ["id" .= i] + +instance FromJSON SARuleReference where + parseJSON = withObject "SARuleReference" $ \o -> + SARuleReference <$> o .: "id" + +-- | The @inputs[].detector_input@ sub-object: the index list plus +-- the rule references that the detector evaluates. The docs document +-- only one input element per detector (multi-input is on the +-- roadmap); typed as a single record rather than a list-of-records +-- to match the wire. +-- +-- On the wire each @inputs[]@ element is wrapped in a constant +-- @{"detector_input": {...}}@ envelope. The 'FromJSON' instance +-- transparently descends into the wrapper so callers never see it; +-- 'ToJSON' re-injects it so a round-trip encode is lossless (mirrors +-- the Alerting 'Trigger' unwrap of @bucket_level_trigger@ / +-- @document_level_trigger@). +data SADetectorInput = SADetectorInput + { saDetectorInputDescription :: Maybe Text, + saDetectorInputIndices :: [Text], + saDetectorInputCustomRules :: [SARuleReference], + saDetectorInputPrePackagedRules :: [SARuleReference], + saDetectorInputOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SADetectorInput where + toJSON i = object ["detector_input" .= body] + where + body = + case saDetectorInputOther i of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + typed = + [ "description" .= saDetectorInputDescription i, + "indices" .= saDetectorInputIndices i, + "custom_rules" .= saDetectorInputCustomRules i, + "pre_packaged_rules" .= saDetectorInputPrePackagedRules i + ] + +instance FromJSON SADetectorInput where + parseJSON = withObject "SADetectorInput" $ \o -> do + -- The wire wraps every element in {"detector_input": {...}}. + -- Descend into the wrapper if present; otherwise parse the + -- fields directly (defensive against a future wire change that + -- drops the wrapper). + let body = case KM.lookup (K.fromText "detector_input") o of + Just (Object inner) -> inner + _ -> o + SADetectorInput + <$> body .:? "description" + <*> body .:? "indices" .!= [] + <*> body .:? "custom_rules" .!= [] + <*> body .:? "pre_packaged_rules" .!= [] + <*> pure (Object o) + +-- | The @message_template@ \/ @subject_template@ sub-object on an +-- 'SAAction'. The server injects @"lang": "mustache"@ on responses +-- even when the request omits it; both directions round-trip here. +data SAMessageTemplate = SAMessageTemplate + { saMessageTemplateSource :: Text, + saMessageTemplateLang :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON SAMessageTemplate where + toJSON SAMessageTemplate {..} = + omitNulls + [ "source" .= saMessageTemplateSource, + "lang" .= saMessageTemplateLang + ] + +instance FromJSON SAMessageTemplate where + parseJSON = withObject "SAMessageTemplate" $ \o -> + SAMessageTemplate + <$> o .: "source" + <*> o .:? "lang" + +-- | The @throttle@ sub-object on an 'SAAction' (@{value, unit}@). +data SAThrottle = SAThrottle + { saThrottleValue :: Int, + saThrottleUnit :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SAThrottle where + toJSON SAThrottle {..} = + object + [ "value" .= saThrottleValue, + "unit" .= saThrottleUnit + ] + +instance FromJSON SAThrottle where + parseJSON = withObject "SAThrottle" $ \o -> + SAThrottle + <$> o .: "value" + <*> o .: "unit" + +-- | A single action within a trigger. The typed fields are those +-- documented on the API page; any forward-compat key (or a field +-- this type does not yet model) is preserved verbatim in +-- 'saActionOther'. +data SAAction = SAAction + { saActionId :: Maybe Text, + saActionName :: Maybe Text, + saActionDestinationId :: Maybe Text, + saActionMessageTemplate :: Maybe SAMessageTemplate, + saActionSubjectTemplate :: Maybe SAMessageTemplate, + saActionThrottleEnabled :: Maybe Bool, + saActionThrottle :: Maybe SAThrottle, + saActionOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAAction where + toJSON a = + case saActionOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= saActionId a, + "name" .= saActionName a, + "destination_id" .= saActionDestinationId a, + "message_template" .= saActionMessageTemplate a, + "subject_template" .= saActionSubjectTemplate a, + "throttle_enabled" .= saActionThrottleEnabled a, + "throttle" .= saActionThrottle a + ] + +instance FromJSON SAAction where + parseJSON = withObject "SAAction" $ \o -> + SAAction + <$> o .:? "id" + <*> o .:? "name" + <*> o .:? "destination_id" + <*> o .:? "message_template" + <*> o .:? "subject_template" + <*> o .:? "throttle_enabled" + <*> o .:? "throttle" + <*> pure (Object o) + +-- | A single trigger. The typed fields cover every key documented on +-- the API page plus the @types@ key that appears in the example but +-- not the field table. The full original element is preserved in +-- 'saTriggerOther' so a round-trip encode is lossless. +-- +-- @saTriggerSeverity@ is a 'Text' rather than an 'Int' because the +-- wire emits a string-encoded integer (e.g. @"1"@) — same gotcha as +-- the sibling Alerting 'triggerSeverity' field. +data SATrigger = SATrigger + { saTriggerId :: Maybe Text, + saTriggerName :: Text, + saTriggerSeverity :: Text, + saTriggerIds :: [Text], + saTriggerTypes :: [Text], + saTriggerTags :: [Text], + saTriggerSevLevels :: [Text], + saTriggerActions :: [SAAction], + saTriggerOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SATrigger where + toJSON t = + case saTriggerOther t of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= saTriggerId t, + "name" .= saTriggerName t, + "severity" .= saTriggerSeverity t, + "ids" .= saTriggerIds t, + "types" .= saTriggerTypes t, + "tags" .= saTriggerTags t, + "sev_levels" .= saTriggerSevLevels t, + "actions" .= saTriggerActions t + ] + +instance FromJSON SATrigger where + parseJSON = withObject "SATrigger" $ \o -> + SATrigger + <$> o .:? "id" + <*> o .: "name" + <*> o .:? "severity" .!= "1" + <*> o .:? "ids" .!= [] + <*> o .:? "types" .!= [] + <*> o .:? "tags" .!= [] + <*> o .:? "sev_levels" .!= [] + <*> o .:? "actions" .!= [] + <*> pure (Object o) + +-- | The top-level 'SADetector' document. Typed fields cover every +-- key the API documents on requests and responses; the +-- server-injected timestamps (@last_update_time@, @enabled_time@) +-- and any future plugin key round-trip via 'saDetectorOther'. +-- +-- @saDetectorKind@ is the @type@ discriminator field (constant +-- @"detector"@); distinct from @saDetectorType@ which is the +-- @detector_type@ log-type enum. +data SADetector = SADetector + { saDetectorName :: Text, + saDetectorType :: SADetectorType, + saDetectorKind :: Maybe Text, + saDetectorEnabled :: Maybe Bool, + saDetectorSchedule :: SASchedule, + saDetectorInputs :: [SADetectorInput], + saDetectorTriggers :: [SATrigger], + saDetectorOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SADetector where + toJSON d = + case saDetectorOther d of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= saDetectorName d, + "detector_type" .= saDetectorType d, + "type" .= saDetectorKind d, + "enabled" .= saDetectorEnabled d, + "schedule" .= saDetectorSchedule d, + "inputs" .= saDetectorInputs d, + "triggers" .= saDetectorTriggers d + ] + +instance FromJSON SADetector where + parseJSON = withObject "SADetector" $ \o -> + SADetector + <$> o .: "name" + <*> o .: "detector_type" + <*> o .:? "type" + <*> o .:? "enabled" + <*> o .: "schedule" + <*> o .:? "inputs" .!= [] + <*> o .:? "triggers" .!= [] + <*> pure (Object o) + +-- | Response wrapper for @POST@ and the inner field of @GET@ on +-- @\/_plugins\/_security_analytics\/detectors[\/{id}]@. Carries the +-- indexing metadata (@_id@, @_version@) alongside the persisted +-- detector document. The @GET@ endpoint returns the same wrapper on +-- the wire; 'getSADetector' decodes it and projects the inner +-- 'SADetector' out so the public type matches the bead acceptance +-- (@m 'SADetector'@). Callers needing @_id@ \/ @_version@ can build +-- the underlying request directly. +data SADetectorResponse = SADetectorResponse + { saDetectorResponseId :: Text, + saDetectorResponseVersion :: Int64, + saDetectorResponseDetector :: SADetector + } + deriving stock (Eq, Show) + +instance FromJSON SADetectorResponse where + parseJSON = withObject "SADetectorResponse" $ \o -> + SADetectorResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "detector" + +instance ToJSON SADetectorResponse where + toJSON SADetectorResponse {..} = + object + [ "_id" .= saDetectorResponseId, + "_version" .= saDetectorResponseVersion, + "detector" .= saDetectorResponseDetector + ] + +-- ========================================================================= +-- Rule search +-- ========================================================================= + +-- | Optional query body for the rule search endpoints. The +-- @from@ \/ @size@ pair is the standard OpenSearch pagination cursor; +-- @query@ is the standard OpenSearch query DSL, kept opaque because +-- its shape varies by use case. Pass 'Nothing' to the request +-- builder (or 'defaultSARulesQuery' to the body renderer) for the +-- plain empty-body @{}@ POST. +data SARulesQuery = SARulesQuery + { saRulesQueryFrom :: Maybe Int, + saRulesQuerySize :: Maybe Int, + saRulesQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultSARulesQuery :: SARulesQuery +defaultSARulesQuery = SARulesQuery Nothing Nothing Nothing + +instance ToJSON SARulesQuery where + toJSON SARulesQuery {..} = + omitNulls + [ "from" .= saRulesQueryFrom, + "size" .= saRulesQuerySize, + "query" .= saRulesQueryQuery + ] + +instance FromJSON SARulesQuery where + parseJSON = withObject "SARulesQuery" $ \o -> + SARulesQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "query" + +-- | The @hits.total.relation@ discriminator on a search response. +data SARulesTotalRelation + = SARulesTotalRelationEq + | SARulesTotalRelationGe + | SARulesTotalRelationOther Text + deriving stock (Eq, Show) + +saRulesTotalRelationText :: SARulesTotalRelation -> Text +saRulesTotalRelationText = \case + SARulesTotalRelationEq -> "eq" + SARulesTotalRelationGe -> "ge" + SARulesTotalRelationOther t -> t + +instance ToJSON SARulesTotalRelation where + toJSON = toJSON . saRulesTotalRelationText + +instance FromJSON SARulesTotalRelation where + parseJSON = withText "SARulesTotalRelation" $ \t -> + pure $ + case t of + "eq" -> SARulesTotalRelationEq + "ge" -> SARulesTotalRelationGe + other -> SARulesTotalRelationOther other + +-- | The @hits.total@ sub-object on a search response +-- (@{value, relation}@). +data SARulesTotal = SARulesTotal + { saRulesTotalValue :: Int64, + saRulesTotalRelation :: SARulesTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON SARulesTotal where + parseJSON = withObject "SARulesTotal" $ \o -> + SARulesTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON SARulesTotal where + toJSON SARulesTotal {..} = + object + [ "value" .= saRulesTotalValue, + "relation" .= saRulesTotalRelation + ] + +-- | The @_shards@ sub-object on a search response. Modelled locally +-- under an @SA@-prefixed name (mirroring the Alerting +-- 'AlertingShards' precedent) rather than re-using the cluster-level +-- 'ShardsResult' envelope, which wraps the outer +-- @{\"_shards\": {...}}@ shape — one level too high for inline use +-- here. +data SARulesShards = SARulesShards + { saRulesShardsTotal :: Int, + saRulesShardsSuccessful :: Int, + saRulesShardsSkipped :: Int, + saRulesShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON SARulesShards where + parseJSON = withObject "SARulesShards" $ \o -> + SARulesShards + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "skipped" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON SARulesShards where + toJSON SARulesShards {..} = + object + [ "total" .= saRulesShardsTotal, + "successful" .= saRulesShardsSuccessful, + "skipped" .= saRulesShardsSkipped, + "failed" .= saRulesShardsFailed + ] + +-- | The @{\"value\": ...}@ wrapper used by @references@, @tags@, +-- @queries@, and @false_positives@ on a 'SARule'. Modelled once and +-- reused because all four fields share the same wire shape. +newtype SARuleValue = SARuleValue {saRuleValueValue :: Text} + deriving stock (Eq, Show) + +instance ToJSON SARuleValue where + toJSON (SARuleValue v) = object ["value" .= v] + +instance FromJSON SARuleValue where + parseJSON = withObject "SARuleValue" $ \o -> SARuleValue <$> o .: "value" + +-- | A Sigma rule document, as returned in @hits.hits[]._source@ by +-- the rule search endpoints. Typed fields cover every key observed +-- in the documented fixtures; @rule@ is kept as 'Text' (the original +-- Sigma YAML serialised to a string), and any forward-compat key +-- round-trips via 'saRuleOther'. +data SARule = SARule + { saRuleCategory :: Maybe Text, + saRuleTitle :: Maybe Text, + saRuleLogSource :: Maybe Text, + saRuleDescription :: Maybe Text, + saRuleReferences :: [SARuleValue], + saRuleTags :: [SARuleValue], + saRuleLevel :: Maybe Text, + saRuleFalsePositives :: [SARuleValue], + saRuleAuthor :: Maybe Text, + saRuleStatus :: Maybe Text, + saRuleLastUpdateTime :: Maybe Text, + saRuleQueries :: [SARuleValue], + saRuleRule :: Maybe Text, + saRuleOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SARule where + parseJSON = withObject "SARule" $ \o -> + SARule + <$> o .:? "category" + <*> o .:? "title" + <*> o .:? "log_source" + <*> o .:? "description" + <*> o .:? "references" .!= [] + <*> o .:? "tags" .!= [] + <*> o .:? "level" + <*> o .:? "false_positives" .!= [] + <*> o .:? "author" + <*> o .:? "status" + <*> o .:? "last_update_time" + <*> o .:? "queries" .!= [] + <*> o .:? "rule" + <*> pure (Object o) + +instance ToJSON SARule where + toJSON r = + case saRuleOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "category" .= saRuleCategory r, + "title" .= saRuleTitle r, + "log_source" .= saRuleLogSource r, + "description" .= saRuleDescription r, + "references" .= saRuleReferences r, + "tags" .= saRuleTags r, + "level" .= saRuleLevel r, + "false_positives" .= saRuleFalsePositives r, + "author" .= saRuleAuthor r, + "status" .= saRuleStatus r, + "last_update_time" .= saRuleLastUpdateTime r, + "queries" .= saRuleQueries r, + "rule" .= saRuleRule r + ] + +-- | A single hit in @hits.hits[]@ on a rule search response. +data SARuleHit = SARuleHit + { saRuleHitIndex :: Maybe Text, + saRuleHitId :: Text, + saRuleHitVersion :: Maybe Int64, + saRuleHitSeqNo :: Maybe Int64, + saRuleHitPrimaryTerm :: Maybe Int64, + saRuleHitScore :: Maybe Double, + saRuleHitSource :: SARule + } + deriving stock (Eq, Show) + +instance FromJSON SARuleHit where + parseJSON = withObject "SARuleHit" $ \o -> + SARuleHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON SARuleHit where + toJSON SARuleHit {..} = + omitNulls + [ "_index" .= saRuleHitIndex, + "_id" .= saRuleHitId, + "_version" .= saRuleHitVersion, + "_seq_no" .= saRuleHitSeqNo, + "_primary_term" .= saRuleHitPrimaryTerm, + "_score" .= saRuleHitScore, + "_source" .= saRuleHitSource + ] + +-- | Response envelope for the rule search endpoints. Decoded +-- verbatim from the standard OpenSearch search-response shape; the +-- paging metadata (@took@, @timed_out@, @_shards@, @hits.total@, +-- @hits.max_score@) is preserved alongside the rule list so callers +-- can drive pagination and observe shard health. +data SARulesSearchResponse = SARulesSearchResponse + { saRulesSearchResponseTook :: Int64, + saRulesSearchResponseTimedOut :: Bool, + saRulesSearchResponseShards :: SARulesShards, + saRulesSearchResponseTotal :: SARulesTotal, + saRulesSearchResponseMaxScore :: Maybe Double, + saRulesSearchResponseHits :: [SARuleHit] + } + deriving stock (Eq, Show) + +instance FromJSON SARulesSearchResponse where + parseJSON = withObject "SARulesSearchResponse" $ \o -> do + hits <- o .: "hits" + SARulesSearchResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SARulesSearchResponse where + toJSON SARulesSearchResponse {..} = + object + [ "took" .= saRulesSearchResponseTook, + "timed_out" .= saRulesSearchResponseTimedOut, + "_shards" .= saRulesSearchResponseShards, + "hits" + .= object + [ "total" .= saRulesSearchResponseTotal, + "max_score" .= saRulesSearchResponseMaxScore, + "hits" .= saRulesSearchResponseHits + ] + ] + +-- | Project the decoded 'SARule' list out of a 'SARulesSearchResponse' +-- (convenience for callers who only want the rules and not the +-- paging envelope). +saRulesSearchResponseRules :: SARulesSearchResponse -> [SARule] +saRulesSearchResponseRules = map saRuleHitSource . saRulesSearchResponseHits + +-- ========================================================================= +-- Rule create, update, and delete +-- ========================================================================= + +-- | Response wrapper for the rule create and update endpoints +-- (@POST /_plugins/_security_analytics/rules@ and +-- @PUT /_plugins/_security_analytics/rules/{id}@). Carries the +-- indexing metadata (@_id@, @_version@) alongside the persisted +-- 'SARule' document (the server parses the submitted Sigma YAML, +-- normalises it into the typed fields, and echoes the original YAML +-- back in 'saRuleRule'). Mirrors 'SADetectorResponse' (which wraps +-- @detector@ instead of @rule@). +data SARuleResponse = SARuleResponse + { saRuleResponseId :: Text, + saRuleResponseVersion :: Int64, + saRuleResponseRule :: SARule + } + deriving stock (Eq, Show) + +instance FromJSON SARuleResponse where + parseJSON = withObject "SARuleResponse" $ \o -> + SARuleResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "rule" + +instance ToJSON SARuleResponse where + toJSON SARuleResponse {..} = + object + [ "_id" .= saRuleResponseId, + "_version" .= saRuleResponseVersion, + "rule" .= saRuleResponseRule + ] + +-- | Response body for +-- @DELETE /_plugins/_security_analytics/rules/{rule_id}@. The Security +-- Analytics plugin delegates the delete to the standard OpenSearch +-- delete-document operation, so the response is the bare Elasticsearch +-- delete-document body +-- (@{_index,_id,_version,result,forced_refresh,_shards,_seq_no,_primary_term}@) +-- with NO @acknowledged@ key. Modelled here verbatim — an +-- 'Acknowledged' decoder would raise 'EsProtocolException' at runtime +-- (same deviation pattern as 'DeleteSADetectorResponse' and the +-- Alerting 'DeleteMonitorResponse'). The @_shards@ sub-object reuses +-- 'SARulesShards' (the identical @{total,successful,skipped,failed}@ +-- shape shared by every SA search\/delete response). +data DeleteSARuleResponse = DeleteSARuleResponse + { deleteSARuleResponseIndex :: Text, + deleteSARuleResponseId :: Text, + deleteSARuleResponseVersion :: Int64, + deleteSARuleResponseResult :: Text, + deleteSARuleResponseForcedRefresh :: Bool, + deleteSARuleResponseShards :: SARulesShards, + deleteSARuleResponseSeqNo :: Int64, + deleteSARuleResponsePrimaryTerm :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteSARuleResponse where + parseJSON = withObject "DeleteSARuleResponse" $ \o -> + DeleteSARuleResponse + <$> o .: "_index" + <*> o .: "_id" + <*> o .: "_version" + <*> o .: "result" + <*> o .:? "forced_refresh" .!= False + <*> o .: "_shards" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + +instance ToJSON DeleteSARuleResponse where + toJSON DeleteSARuleResponse {..} = + object + [ "_index" .= deleteSARuleResponseIndex, + "_id" .= deleteSARuleResponseId, + "_version" .= deleteSARuleResponseVersion, + "result" .= deleteSARuleResponseResult, + "forced_refresh" .= deleteSARuleResponseForcedRefresh, + "_shards" .= deleteSARuleResponseShards, + "_seq_no" .= deleteSARuleResponseSeqNo, + "_primary_term" .= deleteSARuleResponsePrimaryTerm + ] + +-- ========================================================================= +-- Detector update, delete, and search +-- ========================================================================= + +-- | Optional query body for the detector search endpoint +-- (@POST /_plugins/_security_analytics/detectors/_search@). The +-- @from@ \/ @size@ pair is the standard OpenSearch pagination cursor; +-- @query@ is the standard OpenSearch query DSL, kept opaque because +-- its shape varies by use case. Pass 'Nothing' to the request +-- builder (or 'defaultSADetectorsSearchQuery' to the body renderer) +-- for the plain empty-body @{}@ POST. Mirrors 'SARulesQuery'. +data SADetectorsSearchQuery = SADetectorsSearchQuery + { saDetectorsSearchQueryFrom :: Maybe Int, + saDetectorsSearchQuerySize :: Maybe Int, + saDetectorsSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultSADetectorsSearchQuery :: SADetectorsSearchQuery +defaultSADetectorsSearchQuery = SADetectorsSearchQuery Nothing Nothing Nothing + +instance ToJSON SADetectorsSearchQuery where + toJSON SADetectorsSearchQuery {..} = + omitNulls + [ "from" .= saDetectorsSearchQueryFrom, + "size" .= saDetectorsSearchQuerySize, + "query" .= saDetectorsSearchQueryQuery + ] + +instance FromJSON SADetectorsSearchQuery where + parseJSON = withObject "SADetectorsSearchQuery" $ \o -> + SADetectorsSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "query" + +-- | The @hits.total.relation@ discriminator on a detector search +-- response. Mirrors 'SARulesTotalRelation'. +data SADetectorsTotalRelation + = SADetectorsTotalRelationEq + | SADetectorsTotalRelationGe + | SADetectorsTotalRelationOther Text + deriving stock (Eq, Show) + +saDetectorsTotalRelationText :: SADetectorsTotalRelation -> Text +saDetectorsTotalRelationText = \case + SADetectorsTotalRelationEq -> "eq" + SADetectorsTotalRelationGe -> "ge" + SADetectorsTotalRelationOther t -> t + +instance ToJSON SADetectorsTotalRelation where + toJSON = toJSON . saDetectorsTotalRelationText + +instance FromJSON SADetectorsTotalRelation where + parseJSON = withText "SADetectorsTotalRelation" $ \t -> + pure $ + case t of + "eq" -> SADetectorsTotalRelationEq + "ge" -> SADetectorsTotalRelationGe + other -> SADetectorsTotalRelationOther other + +-- | The @hits.total@ sub-object on a detector search response +-- (@{value, relation}@). Mirrors 'SARulesTotal'. +data SADetectorsTotal = SADetectorsTotal + { saDetectorsTotalValue :: Int64, + saDetectorsTotalRelation :: SADetectorsTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON SADetectorsTotal where + parseJSON = withObject "SADetectorsTotal" $ \o -> + SADetectorsTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON SADetectorsTotal where + toJSON SADetectorsTotal {..} = + object + [ "value" .= saDetectorsTotalValue, + "relation" .= saDetectorsTotalRelation + ] + +-- | The @_shards@ sub-object on a detector search response and on +-- 'DeleteSADetectorResponse'. Modelled locally (mirroring the +-- 'SARulesShards' precedent for the rule search endpoints) rather +-- than re-using the cluster-level 'ShardsResult' envelope, which +-- wraps the outer @{\"_shards\": {...}}@ shape — one level too high +-- for inline use here. Reused across detector search and detector +-- delete (both are detector-plugin operations with the identical +-- @{total, successful, skipped, failed}@ shape). +data SADetectorsShards = SADetectorsShards + { saDetectorsShardsTotal :: Int, + saDetectorsShardsSuccessful :: Int, + saDetectorsShardsSkipped :: Int, + saDetectorsShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON SADetectorsShards where + parseJSON = withObject "SADetectorsShards" $ \o -> + SADetectorsShards + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "skipped" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON SADetectorsShards where + toJSON SADetectorsShards {..} = + object + [ "total" .= saDetectorsShardsTotal, + "successful" .= saDetectorsShardsSuccessful, + "skipped" .= saDetectorsShardsSkipped, + "failed" .= saDetectorsShardsFailed + ] + +-- | A single hit in @hits.hits[]@ on a detector search response. The +-- @_source@ field is the stored detector document, modelled as +-- 'SADetector' (its typed shell plus an opaque 'Value' catch-all for +-- server-injected @last_update_time@ \/ @enabled_time@ and any +-- forward-compat key). Mirrors 'SARuleHit'. +data SADetectorHit = SADetectorHit + { saDetectorHitIndex :: Maybe Text, + saDetectorHitId :: Text, + saDetectorHitVersion :: Maybe Int64, + saDetectorHitSeqNo :: Maybe Int64, + saDetectorHitPrimaryTerm :: Maybe Int64, + saDetectorHitScore :: Maybe Double, + saDetectorHitSource :: SADetector + } + deriving stock (Eq, Show) + +instance FromJSON SADetectorHit where + parseJSON = withObject "SADetectorHit" $ \o -> + SADetectorHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON SADetectorHit where + toJSON SADetectorHit {..} = + omitNulls + [ "_index" .= saDetectorHitIndex, + "_id" .= saDetectorHitId, + "_version" .= saDetectorHitVersion, + "_seq_no" .= saDetectorHitSeqNo, + "_primary_term" .= saDetectorHitPrimaryTerm, + "_score" .= saDetectorHitScore, + "_source" .= saDetectorHitSource + ] + +-- | Response envelope for the detector search endpoint +-- (@POST /_plugins/_security_analytics/detectors/_search@). Decoded +-- verbatim from the standard OpenSearch search-response shape; the +-- paging metadata (@took@, @timed_out@, @_shards@, @hits.total@, +-- @hits.max_score@) is preserved alongside the detector list so +-- callers can drive pagination and observe shard health. Mirrors +-- 'SARulesSearchResponse'. +-- +-- /Decode robustness/ (bloodhound-8o1): each hit's @_source@ is +-- decoded as a fully-typed 'SADetector' whose @name@, @detector_type@, +-- and @schedule@ are required. A single malformed stored detector +-- document therefore fails the ENTIRE response decode (aeson does not +-- skip bad hits). This is acceptable because the detector store is +-- plugin-managed and always writes the full schema (the GET\/create +-- paths share the same assumption); it is amplified only here because +-- search returns many documents per response. +data SADetectorsSearchResponse = SADetectorsSearchResponse + { saDetectorsSearchResponseTook :: Int64, + saDetectorsSearchResponseTimedOut :: Bool, + saDetectorsSearchResponseShards :: SADetectorsShards, + saDetectorsSearchResponseTotal :: SADetectorsTotal, + saDetectorsSearchResponseMaxScore :: Maybe Double, + saDetectorsSearchResponseHits :: [SADetectorHit] + } + deriving stock (Eq, Show) + +instance FromJSON SADetectorsSearchResponse where + parseJSON = withObject "SADetectorsSearchResponse" $ \o -> do + hits <- o .: "hits" + SADetectorsSearchResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SADetectorsSearchResponse where + toJSON SADetectorsSearchResponse {..} = + object + [ "took" .= saDetectorsSearchResponseTook, + "timed_out" .= saDetectorsSearchResponseTimedOut, + "_shards" .= saDetectorsSearchResponseShards, + "hits" + .= object + [ "total" .= saDetectorsSearchResponseTotal, + "max_score" .= saDetectorsSearchResponseMaxScore, + "hits" .= saDetectorsSearchResponseHits + ] + ] + +-- | Project the decoded 'SADetector' list out of a +-- 'SADetectorsSearchResponse' (convenience for callers who only want +-- the detectors and not the paging envelope). Mirrors +-- 'saRulesSearchResponseRules'. +saDetectorsSearchResponseDetectors :: SADetectorsSearchResponse -> [SADetector] +saDetectorsSearchResponseDetectors = map saDetectorHitSource . saDetectorsSearchResponseHits + +-- | Response body for +-- @DELETE /_plugins/_security_analytics/detectors/{detector_id}@. The +-- Security Analytics plugin delegates the delete to the standard +-- OpenSearch delete-document operation, so the body never carries an +-- @acknowledged@ key — an 'Acknowledged' decoder would raise +-- 'EsProtocolException' at runtime (same deviation pattern as the +-- Alerting 'DeleteMonitorResponse' and bloodhound-04f.3.13 rethrottle). +-- +-- The exact shape is version-dependent (live-verified in bead +-- bloodhound-z5j): +-- +-- * OS 2.x and 3.x return a minimal @_id@ + @_version@ envelope; the +-- indexing-metadata fields (@_index@, @result@, @_shards@, +-- @_seq_no@, ...) are omitted entirely. +-- * OS 1.3.x does not ship the Security Analytics plugin at all, so +-- the endpoint is unreachable there. +-- +-- Only @_id@ and @_version@ are present, so they are the sole required +-- fields; the rest are 'Maybe'. Modelled distinctly under an +-- @SA@-prefixed name so a plugin-specific response shape belongs to its +-- own type. +data DeleteSADetectorResponse = DeleteSADetectorResponse + { deleteSADetectorResponseId :: Text, + deleteSADetectorResponseVersion :: Int64, + deleteSADetectorResponseIndex :: Maybe Text, + deleteSADetectorResponseResult :: Maybe Text, + deleteSADetectorResponseForcedRefresh :: Maybe Bool, + deleteSADetectorResponseShards :: Maybe SADetectorsShards, + deleteSADetectorResponseSeqNo :: Maybe Int64, + deleteSADetectorResponsePrimaryTerm :: Maybe Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteSADetectorResponse where + parseJSON = withObject "DeleteSADetectorResponse" $ \o -> + DeleteSADetectorResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .:? "_index" + <*> o .:? "result" + <*> o .:? "forced_refresh" + <*> o .:? "_shards" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + +instance ToJSON DeleteSADetectorResponse where + toJSON DeleteSADetectorResponse {..} = + omitNulls + [ "_id" .= deleteSADetectorResponseId, + "_version" .= deleteSADetectorResponseVersion, + "_index" .= deleteSADetectorResponseIndex, + "result" .= deleteSADetectorResponseResult, + "forced_refresh" .= deleteSADetectorResponseForcedRefresh, + "_shards" .= deleteSADetectorResponseShards, + "_seq_no" .= deleteSADetectorResponseSeqNo, + "_primary_term" .= deleteSADetectorResponsePrimaryTerm + ] + +-- ========================================================================= +-- Mappings API +-- ========================================================================= + +-- | The leaf property object (@{path, type}@) carried inside the +-- @properties@ map of every Mappings API body and response. The +-- @type@ field is conventionally @"alias"@ but the server may emit +-- other type discriminators, so it is typed as 'Text' rather than an +-- enum. Any forward-compat key round-trips via +-- 'saMappingPropertyOther' (mirrors the catch-all design of +-- 'SADetector' et al.). +data SAMappingProperty = SAMappingProperty + { saMappingPropertyPath :: Maybe Text, + saMappingPropertyType :: Maybe Text, + saMappingPropertyOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAMappingProperty where + toJSON p = + case saMappingPropertyOther p of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "path" .= saMappingPropertyPath p, + "type" .= saMappingPropertyType p + ] + +instance FromJSON SAMappingProperty where + parseJSON = withObject "SAMappingProperty" $ \o -> + SAMappingProperty + <$> o .:? "path" + <*> o .:? "type" + <*> pure (Object o) + +-- | The @{properties: {...}}@ sub-object reused by the create-mappings +-- request (@alias_mappings@) and by the get-mappings \/ view-mappings +-- responses (@mappings.properties@ \/ top-level @properties@). The +-- property map is keyed by the source field name (e.g. +-- @"windows-event_data-CommandLine"@); unknown keys round-trip via +-- 'saMappingsBodyOther'. +data SAMappingsBody = SAMappingsBody + { saMappingsBodyProperties :: Map Text SAMappingProperty, + saMappingsBodyOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAMappingsBody where + toJSON b = + case saMappingsBodyOther b of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = ["properties" .= saMappingsBodyProperties b] + +instance FromJSON SAMappingsBody where + parseJSON = withObject "SAMappingsBody" $ \o -> + SAMappingsBody + <$> o .:? "properties" .!= mempty + <*> pure (Object o) + +-- | The per-index body of a get-mappings response +-- (@{mappings: {properties: {...}}}@). The outer key of a +-- 'SAGetMappingsResponse' is the index name itself. +data SAMappingsIndexBody = SAMappingsIndexBody + { saMappingsIndexBodyMappings :: SAMappingsBody, + saMappingsIndexBodyOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAMappingsIndexBody where + toJSON b = + case saMappingsIndexBodyOther b of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = ["mappings" .= saMappingsIndexBodyMappings b] + +instance FromJSON SAMappingsIndexBody where + parseJSON = withObject "SAMappingsIndexBody" $ \o -> + SAMappingsIndexBody + <$> o .: "mappings" + <*> pure (Object o) + +-- | Response body for +-- @GET /_plugins/_security_analytics/mappings?index_name={name}@, +-- keyed by index name +-- (@{: {mappings: {properties: {...}}}}@). Modelled as a +-- 'Map' so the index-name keys decode directly; the per-index value is +-- 'SAMappingsIndexBody'. +type SAGetMappingsResponse = Map Text SAMappingsIndexBody + +-- | Request body for +-- @GET /_plugins/_security_analytics/mappings/view@: the index whose +-- fields should be inspected and the log type (rule topic) whose +-- mapping view is requested. Sent as the body of a GET (the server +-- requires the parameters in the request body, not the query string). +data SAMappingsViewRequest = SAMappingsViewRequest + { saMappingsViewIndexName :: Text, + saMappingsViewRuleTopic :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SAMappingsViewRequest where + toJSON r = + object + [ "index_name" .= saMappingsViewIndexName r, + "rule_topic" .= saMappingsViewRuleTopic r + ] + +instance FromJSON SAMappingsViewRequest where + parseJSON = withObject "SAMappingsViewRequest" $ \o -> + SAMappingsViewRequest + <$> o .: "index_name" + <*> o .: "rule_topic" + +-- | Response body for +-- @GET /_plugins/_security_analytics/mappings/view@. The @properties@ +-- map pairs each candidate alias name with its @{path, type}@ leaf +-- ('SAMappingProperty'); @unmapped_index_fields@ lists the source +-- fields that have no mapping. Any forward-compat key round-trips via +-- 'saMappingsViewResponseOther'. +data SAMappingsViewResponse = SAMappingsViewResponse + { saMappingsViewResponseProperties :: Map Text SAMappingProperty, + saMappingsViewResponseUnmappedIndexFields :: [Text], + saMappingsViewResponseOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAMappingsViewResponse where + toJSON r = + case saMappingsViewResponseOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "properties" .= saMappingsViewResponseProperties r, + "unmapped_index_fields" .= saMappingsViewResponseUnmappedIndexFields r + ] + +instance FromJSON SAMappingsViewResponse where + parseJSON = withObject "SAMappingsViewResponse" $ \o -> + SAMappingsViewResponse + <$> o .:? "properties" .!= mempty + <*> o .:? "unmapped_index_fields" .!= [] + <*> pure (Object o) + +-- | Request body for +-- @POST /_plugins/_security_analytics/mappings@ (create mappings). +-- The @alias_mappings@ ('SAMappingsBody') carry the explicit +-- @{properties: {...}}@ to persist; @partial@ (when @'Just' True@) +-- allows creating a partial mapping. The server acknowledges with the +-- standard @{"acknowledged": true}@ envelope (decoded as the shared +-- 'Acknowledged' type, re-exported from +-- "Database.Bloodhound.Common.Requests"). +data SACreateMappingsRequest = SACreateMappingsRequest + { saCreateMappingsIndexName :: Text, + saCreateMappingsRuleTopic :: Text, + saCreateMappingsPartial :: Maybe Bool, + saCreateMappingsAliasMappings :: SAMappingsBody + } + deriving stock (Eq, Show) + +instance ToJSON SACreateMappingsRequest where + toJSON r = + omitNulls + [ "index_name" .= saCreateMappingsIndexName r, + "rule_topic" .= saCreateMappingsRuleTopic r, + "partial" .= saCreateMappingsPartial r, + "alias_mappings" .= saCreateMappingsAliasMappings r + ] + +instance FromJSON SACreateMappingsRequest where + parseJSON = withObject "SACreateMappingsRequest" $ \o -> + SACreateMappingsRequest + <$> o .: "index_name" + <*> o .: "rule_topic" + <*> o .:? "partial" + <*> o .: "alias_mappings" + +-- | Request body for +-- @PUT /_plugins/_security_analytics/mappings@ (update mappings): the +-- index name, the source @field@ to map, and the @alias@ name to +-- assign it. The server acknowledges with the standard +-- @{"acknowledged": true}@ envelope ('Acknowledged'). +data SAUpdateMappingsRequest = SAUpdateMappingsRequest + { saUpdateMappingsIndexName :: Text, + saUpdateMappingsField :: Text, + saUpdateMappingsAlias :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SAUpdateMappingsRequest where + toJSON r = + object + [ "index_name" .= saUpdateMappingsIndexName r, + "field" .= saUpdateMappingsField r, + "alias" .= saUpdateMappingsAlias r + ] + +instance FromJSON SAUpdateMappingsRequest where + parseJSON = withObject "SAUpdateMappingsRequest" $ \o -> + SAUpdateMappingsRequest + <$> o .: "index_name" + <*> o .: "field" + <*> o .: "alias" + +-- ========================================================================= +-- Alerts API +-- ========================================================================= +-- + +-- $alertsapi +-- +-- The Security Analytics plugin dispatches an alert document whenever a +-- detector trigger fires (see +-- ). +-- Two endpoints are modelled here: the listing endpoint +-- (@GET \/\/_plugins\/_security_analytics\/alerts@, 'SAGetAlertsOptions') +-- and the per-detector acknowledge endpoint +-- (@POST \/\/_plugins\/_security_analytics\/detectors\/{detector_id}\/_acknowledge\/alerts@, +-- 'AcknowledgeSADetectorAlertsRequest'). Both share the same per-alert +-- 'SAAlert' shape (typed shell plus an opaque 'Value' catch-all for +-- forward-compat), mirroring the design of 'SADetector' and the sibling +-- Alerting 'Alert'. +-- +-- Wire gotchas pinned by the docs: +-- +-- * The @severity@ field is typed as 'Text' because the wire emits a +-- string-encoded integer (e.g. @"1"@); sometimes @null@. Mirrors the +-- Alerting precedent and 'SATrigger' @severity@. +-- * Timestamps (@start_time@, @end_time@, @acknowledged_time@, +-- @last_notification_time@) are ISO-8601 strings or @null@; typed as +-- @'Maybe' 'Text'@ and left to the caller to parse, since the docs do +-- not commit to a single timestamp format across endpoints. +-- * The acknowledge response carries three array keys (@acknowledged@, +-- @failed@, @missing@); the @failed@ and @missing@ shapes are +-- undocumented, so they are decoded as opaque 'Value's. + +-- | The @state@ field of a Security Analytics alert document, and the +-- @alertState@ query parameter of 'SAGetAlertsOptions'. The five +-- documented values are given dedicated constructors; any future value +-- falls through to 'SAAlertStateOther' rather than parse-failing. The +-- enum matches the Alerting 'AlertState' surface but is replicated here +-- under an @SA@-prefixed name to keep plugin-specific types in their +-- own module (the Alerting and Security Analytics @state@ enums happen +-- to coincide today; they are not guaranteed to). +data SAAlertState + = SAAlertStateActive + | SAAlertStateAcknowledged + | SAAlertStateCompleted + | SAAlertStateError + | SAAlertStateDeleted + | SAAlertStateOther Text + deriving stock (Eq, Show) + +-- | Wire string for an 'SAAlertState'. +saAlertStateText :: SAAlertState -> Text +saAlertStateText = \case + SAAlertStateActive -> "ACTIVE" + SAAlertStateAcknowledged -> "ACKNOWLEDGED" + SAAlertStateCompleted -> "COMPLETED" + SAAlertStateError -> "ERROR" + SAAlertStateDeleted -> "DELETED" + SAAlertStateOther t -> t + +instance ToJSON SAAlertState where + toJSON = toJSON . saAlertStateText + +instance FromJSON SAAlertState where + parseJSON = withText "SAAlertState" $ \t -> + pure $ + case t of + "ACTIVE" -> SAAlertStateActive + "ACKNOWLEDGED" -> SAAlertStateAcknowledged + "COMPLETED" -> SAAlertStateCompleted + "ERROR" -> SAAlertStateError + "DELETED" -> SAAlertStateDeleted + other -> SAAlertStateOther other + +-- | Query-string parameters accepted by +-- @GET /_plugins/_security_analytics/alerts@. Every field is optional; +-- 'defaultSAGetAlertsOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. The server requires exactly one of +-- 'saGetAlertsOptionsDetectorId' \/ 'saGetAlertsOptionsDetectorType' to +-- be set (the docs mark each as \"optional when the other is +-- specified\"); this constraint is enforced by the server, not by this +-- type. The remaining parameters mirror the Alerting +-- 'GetAlertsOptions' surface (filtering by @alertState@ \/ +-- @severityLevel@, pagination via @size@ \/ @startIndex@, sort via +-- @sortString@ \/ @sortOrder@ \/ @missing@, free-text @searchString@), +-- but use snake_case @start_index@ instead of the Alerting plugin's +-- camelCase @startIndex@ — these are distinct plugin routes and the +-- casings genuinely differ on the wire. +data SAGetAlertsOptions = SAGetAlertsOptions + { saGetAlertsOptionsDetectorId :: Maybe Text, + saGetAlertsOptionsDetectorType :: Maybe Text, + saGetAlertsOptionsSeverityLevel :: Maybe Text, + saGetAlertsOptionsAlertState :: Maybe SAAlertState, + saGetAlertsOptionsSortString :: Maybe Text, + saGetAlertsOptionsSortOrder :: Maybe Text, + saGetAlertsOptionsMissing :: Maybe [Text], + saGetAlertsOptionsSize :: Maybe Int, + saGetAlertsOptionsStartIndex :: Maybe Int, + saGetAlertsOptionsSearchString :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the plain +-- @GET /_plugins/_security_analytics/alerts@ (server defaults apply, but +-- the server still requires a @detector_id@ or @detectorType@ — +-- 'defaultSAGetAlertsOptions' is therefore only useful when combined +-- with one of those two fields, or when the caller wires them in via +-- record update). +defaultSAGetAlertsOptions :: SAGetAlertsOptions +defaultSAGetAlertsOptions = + SAGetAlertsOptions + { saGetAlertsOptionsDetectorId = Nothing, + saGetAlertsOptionsDetectorType = Nothing, + saGetAlertsOptionsSeverityLevel = Nothing, + saGetAlertsOptionsAlertState = Nothing, + saGetAlertsOptionsSortString = Nothing, + saGetAlertsOptionsSortOrder = Nothing, + saGetAlertsOptionsMissing = Nothing, + saGetAlertsOptionsSize = Nothing, + saGetAlertsOptionsStartIndex = Nothing, + saGetAlertsOptionsSearchString = Nothing + } + +-- | Render a 'SAGetAlertsOptions' to the query-string pairs accepted by +-- the get-alerts endpoint. Fields set to 'Nothing' are omitted (not +-- rendered with an empty value). The @sortOrder@ parameter is kept as +-- raw 'Text' (the docs do not enumerate its allowed values, so no +-- closed enum is shipped — pass @"asc"@ or @"desc"@). +saGetAlertsOptionsParams :: SAGetAlertsOptions -> [(Text, Maybe Text)] +saGetAlertsOptionsParams SAGetAlertsOptions {..} = + catMaybes + [ ("detector_id",) . Just <$> saGetAlertsOptionsDetectorId, + ("detectorType",) . Just <$> saGetAlertsOptionsDetectorType, + ("severityLevel",) . Just <$> saGetAlertsOptionsSeverityLevel, + ("alertState",) . Just . saAlertStateText <$> saGetAlertsOptionsAlertState, + ("sortString",) . Just <$> saGetAlertsOptionsSortString, + ("sortOrder",) . Just <$> saGetAlertsOptionsSortOrder, + ("missing",) . Just . T.intercalate "," <$> saGetAlertsOptionsMissing, + ("size",) . Just . T.pack . show <$> saGetAlertsOptionsSize, + ("startIndex",) . Just . T.pack . show <$> saGetAlertsOptionsStartIndex, + ("searchString",) . Just <$> saGetAlertsOptionsSearchString + ] + +-- | The @action_execution_results[]@ sub-object on an alert. The three +-- documented fields are typed; any forward-compat key round-trips via +-- 'saActionExecutionResultOther'. @last_execution_time@ is an epoch-millis +-- integer on the wire. +data SAActionExecutionResult = SAActionExecutionResult + { saActionExecutionResultActionId :: Maybe Text, + saActionExecutionResultLastExecutionTime :: Maybe Int64, + saActionExecutionResultThrottledCount :: Maybe Int64, + saActionExecutionResultOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAActionExecutionResult where + toJSON r = + case saActionExecutionResultOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "action_id" .= saActionExecutionResultActionId r, + "last_execution_time" .= saActionExecutionResultLastExecutionTime r, + "throttled_count" .= saActionExecutionResultThrottledCount r + ] + +instance FromJSON SAActionExecutionResult where + parseJSON = withObject "SAActionExecutionResult" $ \o -> + SAActionExecutionResult + <$> o .:? "action_id" + <*> o .:? "last_execution_time" + <*> o .:? "throttled_count" + <*> pure (Object o) + +-- | A single Security Analytics alert document, as returned by +-- @GET /_plugins/_security_analytics/alerts@ (in the @alerts[]@ array of +-- 'SAGetAlertsResponse') and by the acknowledge endpoint (in the +-- @acknowledged[]@ array of 'AcknowledgeSADetectorAlertsResponse'). +-- +-- Typed fields cover every key documented on the get-alerts response; +-- unknown keys round-trip via 'saAlertOther'. Field-level notes: +-- +-- * @version@ is a server-managed integer (the docs example shows a +-- negative value @-3@); typed as 'Int64'. +-- * @schema_version@ is a separate integer from @version@ and is +-- @0@-@4@ depending on alert age. +-- * @severity@ is a string-encoded integer (@\"1\"@..@\"4\"@) or +-- @null@; typed as 'Text' to round-trip both. +-- * @alert_history@ is documented as an array but its element shape is +-- unspecified; decoded as an opaque 'Value'. +-- * Timestamps are ISO-8601 strings or @null@. +data SAAlert = SAAlert + { saAlertDetectorId :: Maybe Text, + saAlertId :: Maybe Text, + saAlertVersion :: Maybe Int64, + saAlertSchemaVersion :: Maybe Int64, + saAlertTriggerId :: Maybe Text, + saAlertTriggerName :: Maybe Text, + saAlertFindingIds :: Maybe [Text], + saAlertRelatedDocIds :: Maybe [Text], + saAlertState :: Maybe SAAlertState, + saAlertErrorMessage :: Maybe Text, + saAlertHistory :: Value, + saAlertSeverity :: Maybe Text, + saAlertActionExecutionResults :: Maybe [SAActionExecutionResult], + saAlertStartTime :: Maybe Text, + saAlertLastNotificationTime :: Maybe Text, + saAlertEndTime :: Maybe Text, + saAlertAcknowledgedTime :: Maybe Text, + saAlertOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAAlert where + toJSON a = + case saAlertOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "detector_id" .= saAlertDetectorId a, + "id" .= saAlertId a, + "version" .= saAlertVersion a, + "schema_version" .= saAlertSchemaVersion a, + "trigger_id" .= saAlertTriggerId a, + "trigger_name" .= saAlertTriggerName a, + "finding_ids" .= saAlertFindingIds a, + "related_doc_ids" .= saAlertRelatedDocIds a, + "state" .= saAlertState a, + "error_message" .= saAlertErrorMessage a, + "alert_history" .= saAlertHistory a, + "severity" .= saAlertSeverity a, + "action_execution_results" .= saAlertActionExecutionResults a, + "start_time" .= saAlertStartTime a, + "last_notification_time" .= saAlertLastNotificationTime a, + "end_time" .= saAlertEndTime a, + "acknowledged_time" .= saAlertAcknowledgedTime a + ] + +instance FromJSON SAAlert where + parseJSON = withObject "SAAlert" $ \o -> + SAAlert + <$> o .:? "detector_id" + <*> o .:? "id" + <*> o .:? "version" + <*> o .:? "schema_version" + <*> o .:? "trigger_id" + <*> o .:? "trigger_name" + <*> o .:? "finding_ids" + <*> o .:? "related_doc_ids" + <*> o .:? "state" + <*> o .:? "error_message" + <*> o .:? "alert_history" .!= Null + <*> o .:? "severity" + <*> o .:? "action_execution_results" + <*> o .:? "start_time" + <*> o .:? "last_notification_time" + <*> o .:? "end_time" + <*> o .:? "acknowledged_time" + <*> pure (Object o) + +-- | Response envelope for @GET /_plugins/_security_analytics/alerts@ +-- (@{alerts, total_alerts, detectorType}@). @total_alerts@ and +-- @detectorType@ are decoded leniently (they are documented but the +-- live wire has been observed to drop @detectorType@ on some builds); +-- the @alerts@ array is strict. +data SAGetAlertsResponse = SAGetAlertsResponse + { saGetAlertsResponseAlerts :: [SAAlert], + saGetAlertsResponseTotalAlerts :: Maybe Int64, + saGetAlertsResponseDetectorType :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SAGetAlertsResponse where + parseJSON = withObject "SAGetAlertsResponse" $ \o -> + SAGetAlertsResponse + <$> o .:? "alerts" .!= [] + <*> o .:? "total_alerts" + <*> o .:? "detectorType" + +instance ToJSON SAGetAlertsResponse where + toJSON r = + omitNulls + [ "alerts" .= saGetAlertsResponseAlerts r, + "total_alerts" .= saGetAlertsResponseTotalAlerts r, + "detectorType" .= saGetAlertsResponseDetectorType r + ] + +-- | Request body for +-- @POST /_plugins/_security_analytics/detectors/{detector_id}/_acknowledge/alerts@. +-- Wraps a list of alert ids; rendered on the wire as +-- @{"alerts":[id1, id2, ...]}@ (note: snake_case key @alerts@, mirroring +-- the Alerting plugin's 'AcknowledgeAlertRequest'; contrast with the +-- correlation-alerts acknowledge, which uses camelCase @alertIds@). +newtype AcknowledgeSADetectorAlertsRequest = AcknowledgeSADetectorAlertsRequest + { acknowledgeSADetectorAlertsRequestAlerts :: [Text] + } + deriving stock (Eq, Show) + +instance ToJSON AcknowledgeSADetectorAlertsRequest where + toJSON r = object ["alerts" .= acknowledgeSADetectorAlertsRequestAlerts r] + +instance FromJSON AcknowledgeSADetectorAlertsRequest where + parseJSON = withObject "AcknowledgeSADetectorAlertsRequest" $ \o -> + AcknowledgeSADetectorAlertsRequest <$> o .:? "alerts" .!= [] + +-- | Response body for the per-detector alerts acknowledge endpoint. The +-- @acknowledged@ array carries the same 'SAAlert' shape as the get-alerts +-- response; @failed@ and @missing@ are documented as arrays but their +-- element shapes are unspecified, so they are decoded as opaque 'Value's. +data AcknowledgeSADetectorAlertsResponse = AcknowledgeSADetectorAlertsResponse + { acknowledgeSADetectorAlertsResponseAcknowledged :: [SAAlert], + acknowledgeSADetectorAlertsResponseFailed :: Value, + acknowledgeSADetectorAlertsResponseMissing :: Value + } + deriving stock (Eq, Show) + +instance FromJSON AcknowledgeSADetectorAlertsResponse where + parseJSON = withObject "AcknowledgeSADetectorAlertsResponse" $ \o -> + AcknowledgeSADetectorAlertsResponse + <$> o .:? "acknowledged" .!= [] + <*> o .:? "failed" .!= Null + <*> o .:? "missing" .!= Null + +instance ToJSON AcknowledgeSADetectorAlertsResponse where + toJSON r = + omitNulls + [ "acknowledged" .= acknowledgeSADetectorAlertsResponseAcknowledged r, + "failed" .= acknowledgeSADetectorAlertsResponseFailed r, + "missing" .= acknowledgeSADetectorAlertsResponseMissing r + ] + +-- ========================================================================= +-- Findings API +-- ========================================================================= +-- + +-- $findingsapi +-- +-- A finding is the per-match record produced by a detector rule against +-- an indexed log document (see +-- ). +-- Only the listing endpoint +-- (@GET \/\/_plugins\/_security_analytics\/findings\/_search@) is +-- documented; per-id GET is not. The response envelope diverges from a +-- standard OpenSearch search response: it carries +-- @{total_findings, findings: [...]}@ with the findings inline (not +-- wrapped in @hits.hits[]._source@). +-- +-- Wire gotchas: +-- +-- * @detectorId@ is camelCase in the findings response, whereas the +-- alerts response uses snake_case @detector_id@ — these are real +-- wire-format inconsistencies, not typos. +-- * @timestamp@ is an epoch-millis integer. +-- * @document_list[].document@ is a /string/ containing JSON, not a +-- nested object; typed as 'Text'. +-- * @queries[].tags@ is an array of strings (severity + log type). + +-- | The @detectionType@ query parameter on the findings search endpoint. +-- @rule@ fetches findings produced by the detector's Sigma rule; +-- @threat@ fetches threat-intel-feed findings. Unknown values fall +-- through to 'SADetectionTypeOther' (mirrors the 'SAAlertState' design). +data SADetectionType + = SADetectionTypeRule + | SADetectionTypeThreat + | SADetectionTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'SADetectionType'. +saDetectionTypeText :: SADetectionType -> Text +saDetectionTypeText = \case + SADetectionTypeRule -> "rule" + SADetectionTypeThreat -> "threat" + SADetectionTypeOther t -> t + +instance ToJSON SADetectionType where + toJSON = toJSON . saDetectionTypeText + +instance FromJSON SADetectionType where + parseJSON = withText "SADetectionType" $ \t -> + pure $ + case t of + "rule" -> SADetectionTypeRule + "threat" -> SADetectionTypeThreat + other -> SADetectionTypeOther other + +-- | The @severity@ query parameter on the findings search endpoint. +-- Unknown values fall through to 'SASeverityOther'. +data SASeverity + = SASeverityCritical + | SASeverityHigh + | SASeverityMedium + | SASeverityLow + | SASeverityOther Text + deriving stock (Eq, Show) + +-- | Wire string for an 'SASeverity'. +saSeverityText :: SASeverity -> Text +saSeverityText = \case + SASeverityCritical -> "critical" + SASeverityHigh -> "high" + SASeverityMedium -> "medium" + SASeverityLow -> "low" + SASeverityOther t -> t + +instance ToJSON SASeverity where + toJSON = toJSON . saSeverityText + +instance FromJSON SASeverity where + parseJSON = withText "SASeverity" $ \t -> + pure $ + case t of + "critical" -> SASeverityCritical + "high" -> SASeverityHigh + "medium" -> SASeverityMedium + "low" -> SASeverityLow + other -> SASeverityOther other + +-- | Query-string parameters accepted by +-- @GET /_plugins/_security_analytics/findings/_search@. Every field is +-- optional; 'defaultSASearchFindingsOptions' produces an empty parameter +-- list (the server returns the first page of all findings). The +-- @detector_type@ filter (snake_case) takes a log type name; the +-- @detectionType@ filter (camelCase) takes a 'SADetectionType' enum +-- value — note the inconsistent casing across the two parameters on the +-- same endpoint. +data SASearchFindingsOptions = SASearchFindingsOptions + { saSearchFindingsOptionsDetectorId :: Maybe Text, + saSearchFindingsOptionsDetectorType :: Maybe Text, + saSearchFindingsOptionsSortOrder :: Maybe Text, + saSearchFindingsOptionsSize :: Maybe Int, + saSearchFindingsOptionsStartIndex :: Maybe Int, + saSearchFindingsOptionsDetectionType :: Maybe SADetectionType, + saSearchFindingsOptionsSeverity :: Maybe SASeverity + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the plain +-- @GET /_plugins/_security_analytics/findings/_search@. +defaultSASearchFindingsOptions :: SASearchFindingsOptions +defaultSASearchFindingsOptions = + SASearchFindingsOptions + { saSearchFindingsOptionsDetectorId = Nothing, + saSearchFindingsOptionsDetectorType = Nothing, + saSearchFindingsOptionsSortOrder = Nothing, + saSearchFindingsOptionsSize = Nothing, + saSearchFindingsOptionsStartIndex = Nothing, + saSearchFindingsOptionsDetectionType = Nothing, + saSearchFindingsOptionsSeverity = Nothing + } + +-- | Render a 'SASearchFindingsOptions' to the query-string pairs accepted +-- by the findings search endpoint. Fields set to 'Nothing' are omitted. +saSearchFindingsOptionsParams :: SASearchFindingsOptions -> [(Text, Maybe Text)] +saSearchFindingsOptionsParams SASearchFindingsOptions {..} = + catMaybes + [ ("detector_id",) . Just <$> saSearchFindingsOptionsDetectorId, + ("detectorType",) . Just <$> saSearchFindingsOptionsDetectorType, + ("sortOrder",) . Just <$> saSearchFindingsOptionsSortOrder, + ("size",) . Just . T.pack . show <$> saSearchFindingsOptionsSize, + ("startIndex",) . Just . T.pack . show <$> saSearchFindingsOptionsStartIndex, + ("detectionType",) . Just . saDetectionTypeText <$> saSearchFindingsOptionsDetectionType, + ("severity",) . Just . saSeverityText <$> saSearchFindingsOptionsSeverity + ] + +-- | The @queries[]@ sub-object inside a finding: the Sigma rule id, its +-- name, the matched fields, the rendered query string, and the rule +-- tags (severity + log type). Typed shell plus opaque catch-all. +data SAFindingQuery = SAFindingQuery + { saFindingQueryId :: Maybe Text, + saFindingQueryName :: Maybe Text, + saFindingQueryFields :: Maybe [Text], + saFindingQueryQuery :: Maybe Text, + saFindingQueryTags :: Maybe [Text], + saFindingQueryOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAFindingQuery where + toJSON q = + case saFindingQueryOther q of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= saFindingQueryId q, + "name" .= saFindingQueryName q, + "fields" .= saFindingQueryFields q, + "query" .= saFindingQueryQuery q, + "tags" .= saFindingQueryTags q + ] + +instance FromJSON SAFindingQuery where + parseJSON = withObject "SAFindingQuery" $ \o -> + SAFindingQuery + <$> o .:? "id" + <*> o .:? "name" + <*> o .:? "fields" + <*> o .:? "query" + <*> o .:? "tags" + <*> pure (Object o) + +-- | The @document_list[]@ sub-object inside a finding: the document's +-- index, id, found flag, and the source document serialised as a JSON +-- /string/ (NOT a nested object — the server stringifies the source). +data SAFindingDocument = SAFindingDocument + { saFindingDocumentIndex :: Maybe Text, + saFindingDocumentId :: Maybe Text, + saFindingDocumentFound :: Maybe Bool, + saFindingDocumentDocument :: Maybe Text, + saFindingDocumentOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAFindingDocument where + toJSON d = + case saFindingDocumentOther d of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "index" .= saFindingDocumentIndex d, + "id" .= saFindingDocumentId d, + "found" .= saFindingDocumentFound d, + "document" .= saFindingDocumentDocument d + ] + +instance FromJSON SAFindingDocument where + parseJSON = withObject "SAFindingDocument" $ \o -> + SAFindingDocument + <$> o .:? "index" + <*> o .:? "id" + <*> o .:? "found" + <*> o .:? "document" + <*> pure (Object o) + +-- | A single finding document, as returned in the @findings[]@ array of +-- 'SASearchFindingsResponse'. Note the camelCase @detectorId@ (the +-- alerts API uses snake_case @detector_id@ — these genuinely differ on +-- the wire). @timestamp@ is an epoch-millis integer. +data SAFinding = SAFinding + { saFindingDetectorId :: Maybe Text, + saFindingId :: Maybe Text, + saFindingRelatedDocIds :: Maybe [Text], + saFindingIndex :: Maybe Text, + saFindingQueries :: Maybe [SAFindingQuery], + saFindingTimestamp :: Maybe Int64, + saFindingDocumentList :: Maybe [SAFindingDocument], + saFindingOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAFinding where + toJSON f = + case saFindingOther f of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "detectorId" .= saFindingDetectorId f, + "id" .= saFindingId f, + "related_doc_ids" .= saFindingRelatedDocIds f, + "index" .= saFindingIndex f, + "queries" .= saFindingQueries f, + "timestamp" .= saFindingTimestamp f, + "document_list" .= saFindingDocumentList f + ] + +instance FromJSON SAFinding where + parseJSON = withObject "SAFinding" $ \o -> + SAFinding + <$> o .:? "detectorId" + <*> o .:? "id" + <*> o .:? "related_doc_ids" + <*> o .:? "index" + <*> o .:? "queries" + <*> o .:? "timestamp" + <*> o .:? "document_list" + <*> pure (Object o) + +-- | Response envelope for +-- @GET /_plugins/_security_analytics/findings/_search@ +-- (@{total_findings, findings: [...]}@). Note this is NOT the standard +-- OpenSearch search envelope (no @took@, no @hits@ wrapper); the +-- Security Analytics plugin returns the findings inline. +data SASearchFindingsResponse = SASearchFindingsResponse + { saSearchFindingsResponseTotalFindings :: Maybe Int64, + saSearchFindingsResponseFindings :: [SAFinding] + } + deriving stock (Eq, Show) + +instance FromJSON SASearchFindingsResponse where + parseJSON = withObject "SASearchFindingsResponse" $ \o -> + SASearchFindingsResponse + <$> o .:? "total_findings" + <*> o .:? "findings" .!= [] + +instance ToJSON SASearchFindingsResponse where + toJSON r = + omitNulls + [ "total_findings" .= saSearchFindingsResponseTotalFindings r, + "findings" .= saSearchFindingsResponseFindings r + ] + +-- ========================================================================= +-- Correlation API +-- ========================================================================= +-- + +-- $correlationapi +-- +-- The correlation engine correlates findings produced by different +-- detectors against different log types and dispatches correlation +-- alerts when a correlation rule matches (see +-- ). +-- Five endpoints are modelled here: +-- +-- * [@POST \/\/correlation\/rules@] 'CreateSACorrelationRuleRequest' — +-- create a correlation rule from a list of index\/query\/category +-- triples. +-- * [@GET \/\/correlations@] 'GetSACorrelationsOptions' — list finding +-- correlations within a time window (pairwise @finding1@\/@finding2@). +-- * [@GET \/\/findings\/correlate@] 'FindSACorrelationOptions' — list +-- correlated findings for a given finding id, scored by proximity. +-- * [@GET \/\/correlationAlerts@] 'SearchSACorrelationAlertsOptions' — +-- list correlation alerts, optionally filtered by correlation rule. +-- * [@POST \/\/_acknowledge\/correlationAlerts@] +-- 'AcknowledgeSACorrelationAlertsRequest' — acknowledge one or more +-- correlation alerts by id. +-- +-- Wire gotchas pinned by the docs: +-- +-- * The create endpoint is @POST \/correlation\/rules@ (singular +-- @rule@); the time-window listing endpoint is +-- @GET \/correlations@ (plural). Both are real. +-- * Acknowledge-correlation-alerts uses the path +-- @\/_acknowledge\/correlationAlerts@ (the @_acknowledge@ segment is a +-- sibling of @correlationAlerts@, not nested under it) and the +-- request body key is camelCase @alertIds@ (contrast with the +-- per-detector alerts acknowledge, which uses snake_case @alerts@). +-- * Acknowledge-correlation-alerts response has only +-- @acknowledged@ \/ @failed@ arrays (NO @missing@ key, contrast with +-- per-detector alerts acknowledge). +-- * The pairwise correlations response uses camelCase @logType1@ \/ +-- @logType2@; the find-correlation response uses snake_case +-- @detector_type@. Both are real. +-- * The correlation alerts list endpoint is declared as +-- @GET \/correlationAlerts@ in the docs, but its example request uses +-- @GET \/correlations?correlation_rule_id=...@ — an inconsistency in +-- the docs. This module ships the declared path +-- @GET \/correlationAlerts@. + +-- | A single entry in a correlation rule's @correlate@ array: the index +-- to search, the query string to apply, and the log type (category) of +-- the index. +data SACorrelateEntry = SACorrelateEntry + { saCorrelateEntryIndex :: Text, + saCorrelateEntryQuery :: Text, + saCorrelateEntryCategory :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SACorrelateEntry where + toJSON e = + object + [ "index" .= saCorrelateEntryIndex e, + "query" .= saCorrelateEntryQuery e, + "category" .= saCorrelateEntryCategory e + ] + +instance FromJSON SACorrelateEntry where + parseJSON = withObject "SACorrelateEntry" $ \o -> + SACorrelateEntry + <$> o .: "index" + <*> o .: "query" + <*> o .: "category" + +-- | Request body for @POST /_plugins/_security_analytics/correlation/rules@. +-- Carries the list of index\/query\/category triples that define the +-- correlation; rendered as @{"correlate": [...]}@. +newtype CreateSACorrelationRuleRequest = CreateSACorrelationRuleRequest + { createSACorrelationRuleRequestCorrelate :: [SACorrelateEntry] + } + deriving stock (Eq, Show) + +instance ToJSON CreateSACorrelationRuleRequest where + toJSON r = object ["correlate" .= createSACorrelationRuleRequestCorrelate r] + +instance FromJSON CreateSACorrelationRuleRequest where + parseJSON = withObject "CreateSACorrelationRuleRequest" $ \o -> + CreateSACorrelationRuleRequest <$> o .:? "correlate" .!= [] + +-- | The @rule@ sub-object in the create-correlation-rule response. +-- @name@ is documented but the docs example returns @null@; typed as +-- 'Maybe' 'Text'. Unknown keys round-trip via 'saCorrelationRuleOther'. +data SACorrelationRule = SACorrelationRule + { saCorrelationRuleName :: Maybe Text, + saCorrelationRuleCorrelate :: [SACorrelateEntry], + saCorrelationRuleOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SACorrelationRule where + parseJSON = withObject "SACorrelationRule" $ \o -> + SACorrelationRule + <$> o .:? "name" + <*> o .:? "correlate" .!= [] + <*> pure (Object o) + +instance ToJSON SACorrelationRule where + toJSON r = + case saCorrelationRuleOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= saCorrelationRuleName r, + "correlate" .= saCorrelationRuleCorrelate r + ] + +-- | Response body for @POST /_plugins/_security_analytics/correlation/rules@: +-- the server-assigned @_id@ and @_version@, plus the persisted +-- 'SACorrelationRule'. +data CreateSACorrelationRuleResponse = CreateSACorrelationRuleResponse + { createSACorrelationRuleResponseId :: Text, + createSACorrelationRuleResponseVersion :: Int64, + createSACorrelationRuleResponseRule :: SACorrelationRule + } + deriving stock (Eq, Show) + +instance FromJSON CreateSACorrelationRuleResponse where + parseJSON = withObject "CreateSACorrelationRuleResponse" $ \o -> + CreateSACorrelationRuleResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "rule" + +instance ToJSON CreateSACorrelationRuleResponse where + toJSON r = + object + [ "_id" .= createSACorrelationRuleResponseId r, + "_version" .= createSACorrelationRuleResponseVersion r, + "rule" .= createSACorrelationRuleResponseRule r + ] + +-- | A single pairwise correlation in the +-- @GET /_plugins/_security_analytics/correlations@ response +-- (@{finding1, logType1, finding2, logType2, rules}@). The wire shape is +-- fixed to exactly two findings (no generalised N-finding array). +-- Unknown keys round-trip via 'saCorrelationFindingOther'. +data SACorrelationFinding = SACorrelationFinding + { saCorrelationFindingFinding1 :: Maybe Text, + saCorrelationFindingLogType1 :: Maybe Text, + saCorrelationFindingFinding2 :: Maybe Text, + saCorrelationFindingLogType2 :: Maybe Text, + saCorrelationFindingRules :: Maybe [Text], + saCorrelationFindingOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SACorrelationFinding where + parseJSON = withObject "SACorrelationFinding" $ \o -> + SACorrelationFinding + <$> o .:? "finding1" + <*> o .:? "logType1" + <*> o .:? "finding2" + <*> o .:? "logType2" + <*> o .:? "rules" + <*> pure (Object o) + +instance ToJSON SACorrelationFinding where + toJSON r = + case saCorrelationFindingOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "finding1" .= saCorrelationFindingFinding1 r, + "logType1" .= saCorrelationFindingLogType1 r, + "finding2" .= saCorrelationFindingFinding2 r, + "logType2" .= saCorrelationFindingLogType2 r, + "rules" .= saCorrelationFindingRules r + ] + +-- | Query parameters for @GET /_plugins/_security_analytics/correlations@. +-- Both @start_timestamp@ and @end_timestamp@ are required by the server +-- (epoch-millis integers); the type does not enforce this, leaving the +-- caller to set them via record update on 'defaultGetSACorrelationsOptions'. +data GetSACorrelationsOptions = GetSACorrelationsOptions + { getSACorrelationsOptionsStartTimestamp :: Maybe Int64, + getSACorrelationsOptionsEndTimestamp :: Maybe Int64 + } + deriving stock (Eq, Show) + +-- | The empty options record — caller MUST set @start_timestamp@ and +-- @end_timestamp@ before sending (the server rejects the request +-- otherwise). +defaultGetSACorrelationsOptions :: GetSACorrelationsOptions +defaultGetSACorrelationsOptions = + GetSACorrelationsOptions + { getSACorrelationsOptionsStartTimestamp = Nothing, + getSACorrelationsOptionsEndTimestamp = Nothing + } + +-- | Render a 'GetSACorrelationsOptions' to the query-string pairs +-- accepted by the correlations endpoint. Fields set to 'Nothing' are +-- omitted; the caller is responsible for ensuring both are set. +getSACorrelationsOptionsParams :: GetSACorrelationsOptions -> [(Text, Maybe Text)] +getSACorrelationsOptionsParams GetSACorrelationsOptions {..} = + catMaybes + [ ("start_timestamp",) . Just . T.pack . show <$> getSACorrelationsOptionsStartTimestamp, + ("end_timestamp",) . Just . T.pack . show <$> getSACorrelationsOptionsEndTimestamp + ] + +-- | Response body for @GET /_plugins/_security_analytics/correlations@ +-- (@{findings: [...]}@ — note the response key is @findings@ even though +-- the endpoint is @correlations@). +newtype GetSACorrelationsResponse = GetSACorrelationsResponse + { getSACorrelationsResponseFindings :: [SACorrelationFinding] + } + deriving stock (Eq, Show) + +instance FromJSON GetSACorrelationsResponse where + parseJSON = withObject "GetSACorrelationsResponse" $ \o -> + GetSACorrelationsResponse <$> o .:? "findings" .!= [] + +instance ToJSON GetSACorrelationsResponse where + toJSON r = object ["findings" .= getSACorrelationsResponseFindings r] + +-- | Query parameters for +-- @GET /_plugins/_security_analytics/findings/correlate@. @finding@ and +-- @detector_type@ are required by the server; @nearby_findings@ and +-- @time_window@ are optional. The caller MUST set the two required +-- fields via record update on 'defaultFindSACorrelationOptions'. +data FindSACorrelationOptions = FindSACorrelationOptions + { findSACorrelationOptionsFinding :: Maybe Text, + findSACorrelationOptionsDetectorType :: Maybe Text, + findSACorrelationOptionsNearbyFindings :: Maybe Int, + findSACorrelationOptionsTimeWindow :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record — caller MUST set @finding@ and +-- @detector_type@ before sending. +defaultFindSACorrelationOptions :: FindSACorrelationOptions +defaultFindSACorrelationOptions = + FindSACorrelationOptions + { findSACorrelationOptionsFinding = Nothing, + findSACorrelationOptionsDetectorType = Nothing, + findSACorrelationOptionsNearbyFindings = Nothing, + findSACorrelationOptionsTimeWindow = Nothing + } + +-- | Render a 'FindSACorrelationOptions' to the query-string pairs +-- accepted by the find-correlation endpoint. +findSACorrelationOptionsParams :: FindSACorrelationOptions -> [(Text, Maybe Text)] +findSACorrelationOptionsParams FindSACorrelationOptions {..} = + catMaybes + [ ("finding",) . Just <$> findSACorrelationOptionsFinding, + ("detector_type",) . Just <$> findSACorrelationOptionsDetectorType, + ("nearby_findings",) . Just . T.pack . show <$> findSACorrelationOptionsNearbyFindings, + ("time_window",) . Just <$> findSACorrelationOptionsTimeWindow + ] + +-- | A single scored correlation in the find-correlation response +-- (@{finding, detector_type, score}@). @score@ is a server-computed +-- proximity score (smaller = more relevant); typed as 'Double'. +-- Unknown keys round-trip via 'saCorrelationScoreOther'. +data SACorrelationScore = SACorrelationScore + { saCorrelationScoreFinding :: Maybe Text, + saCorrelationScoreDetectorType :: Maybe Text, + saCorrelationScoreScore :: Maybe Double, + saCorrelationScoreOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SACorrelationScore where + parseJSON = withObject "SACorrelationScore" $ \o -> + SACorrelationScore + <$> o .:? "finding" + <*> o .:? "detector_type" + <*> o .:? "score" + <*> pure (Object o) + +instance ToJSON SACorrelationScore where + toJSON r = + case saCorrelationScoreOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "finding" .= saCorrelationScoreFinding r, + "detector_type" .= saCorrelationScoreDetectorType r, + "score" .= saCorrelationScoreScore r + ] + +-- | Response body for +-- @GET /_plugins/_security_analytics/findings/correlate@ +-- (@{findings: [...]}@ — the response key is @findings@ here too). +newtype FindSACorrelationResponse = FindSACorrelationResponse + { findSACorrelationResponseFindings :: [SACorrelationScore] + } + deriving stock (Eq, Show) + +instance FromJSON FindSACorrelationResponse where + parseJSON = withObject "FindSACorrelationResponse" $ \o -> + FindSACorrelationResponse <$> o .:? "findings" .!= [] + +instance ToJSON FindSACorrelationResponse where + toJSON r = object ["findings" .= findSACorrelationResponseFindings r] + +-- | Query parameters for +-- @GET /_plugins/_security_analytics/correlationAlerts@. The optional +-- @correlation_rule_id@ filters the result to alerts produced by a +-- specific correlation rule. +newtype SearchSACorrelationAlertsOptions = SearchSACorrelationAlertsOptions + { searchSACorrelationAlertsOptionsCorrelationRuleId :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record — returns all correlation alerts. +defaultSearchSACorrelationAlertsOptions :: SearchSACorrelationAlertsOptions +defaultSearchSACorrelationAlertsOptions = + SearchSACorrelationAlertsOptions + { searchSACorrelationAlertsOptionsCorrelationRuleId = Nothing + } + +-- | Render a 'SearchSACorrelationAlertsOptions' to the query-string pairs +-- accepted by the correlation alerts endpoint. +searchSACorrelationAlertsOptionsParams :: SearchSACorrelationAlertsOptions -> [(Text, Maybe Text)] +searchSACorrelationAlertsOptionsParams SearchSACorrelationAlertsOptions {..} = + catMaybes + [ ("correlation_rule_id",) . Just <$> searchSACorrelationAlertsOptionsCorrelationRuleId + ] + +-- | A single correlation alert, as returned in the @correlationAlerts[]@ +-- array of 'SearchSACorrelationAlertsResponse' and the @acknowledged[]@ +-- array of 'AcknowledgeSACorrelationAlertsResponse'. Carries the same +-- shell as 'SAAlert' (state, severity, timestamps, action execution +-- results) plus the correlation-specific @correlated_finding_ids@, +-- @correlation_rule_id@, and @correlation_rule_name@ fields. @user@ is +-- documented but the docs example returns @null@; typed as +-- 'Maybe' 'Text'. Typed shell plus opaque catch-all. +data SACorrelationAlert = SACorrelationAlert + { saCorrelationAlertCorrelatedFindingIds :: Maybe [Text], + saCorrelationAlertCorrelationRuleId :: Maybe Text, + saCorrelationAlertCorrelationRuleName :: Maybe Text, + saCorrelationAlertUser :: Maybe Text, + saCorrelationAlertId :: Maybe Text, + saCorrelationAlertVersion :: Maybe Int64, + saCorrelationAlertSchemaVersion :: Maybe Int64, + saCorrelationAlertTriggerName :: Maybe Text, + saCorrelationAlertState :: Maybe SAAlertState, + saCorrelationAlertErrorMessage :: Maybe Text, + saCorrelationAlertSeverity :: Maybe Text, + saCorrelationAlertActionExecutionResults :: Maybe [SAActionExecutionResult], + saCorrelationAlertStartTime :: Maybe Text, + saCorrelationAlertEndTime :: Maybe Text, + saCorrelationAlertAcknowledgedTime :: Maybe Text, + saCorrelationAlertOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SACorrelationAlert where + parseJSON = withObject "SACorrelationAlert" $ \o -> + SACorrelationAlert + <$> o .:? "correlated_finding_ids" + <*> o .:? "correlation_rule_id" + <*> o .:? "correlation_rule_name" + <*> o .:? "user" + <*> o .:? "id" + <*> o .:? "version" + <*> o .:? "schema_version" + <*> o .:? "trigger_name" + <*> o .:? "state" + <*> o .:? "error_message" + <*> o .:? "severity" + <*> o .:? "action_execution_results" + <*> o .:? "start_time" + <*> o .:? "end_time" + <*> o .:? "acknowledged_time" + <*> pure (Object o) + +instance ToJSON SACorrelationAlert where + toJSON a = + case saCorrelationAlertOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "correlated_finding_ids" .= saCorrelationAlertCorrelatedFindingIds a, + "correlation_rule_id" .= saCorrelationAlertCorrelationRuleId a, + "correlation_rule_name" .= saCorrelationAlertCorrelationRuleName a, + "user" .= saCorrelationAlertUser a, + "id" .= saCorrelationAlertId a, + "version" .= saCorrelationAlertVersion a, + "schema_version" .= saCorrelationAlertSchemaVersion a, + "trigger_name" .= saCorrelationAlertTriggerName a, + "state" .= saCorrelationAlertState a, + "error_message" .= saCorrelationAlertErrorMessage a, + "severity" .= saCorrelationAlertSeverity a, + "action_execution_results" .= saCorrelationAlertActionExecutionResults a, + "start_time" .= saCorrelationAlertStartTime a, + "end_time" .= saCorrelationAlertEndTime a, + "acknowledged_time" .= saCorrelationAlertAcknowledgedTime a + ] + +-- | Response envelope for +-- @GET /_plugins/_security_analytics/correlationAlerts@ +-- (@{correlationAlerts: [...], total_alerts}@). +data SearchSACorrelationAlertsResponse = SearchSACorrelationAlertsResponse + { searchSACorrelationAlertsResponseCorrelationAlerts :: [SACorrelationAlert], + searchSACorrelationAlertsResponseTotalAlerts :: Maybe Int64 + } + deriving stock (Eq, Show) + +instance FromJSON SearchSACorrelationAlertsResponse where + parseJSON = withObject "SearchSACorrelationAlertsResponse" $ \o -> + SearchSACorrelationAlertsResponse + <$> o .:? "correlationAlerts" .!= [] + <*> o .:? "total_alerts" + +instance ToJSON SearchSACorrelationAlertsResponse where + toJSON r = + omitNulls + [ "correlationAlerts" .= searchSACorrelationAlertsResponseCorrelationAlerts r, + "total_alerts" .= searchSACorrelationAlertsResponseTotalAlerts r + ] + +-- | Request body for +-- @POST /_plugins/_security_analytics/_acknowledge/correlationAlerts@. +-- Wraps a list of correlation-alert ids; rendered on the wire as +-- @{"alertIds":[id1, id2, ...]}@ (note: camelCase key @alertIds@, +-- contrast with the per-detector alerts acknowledge which uses +-- snake_case @alerts@). +newtype AcknowledgeSACorrelationAlertsRequest = AcknowledgeSACorrelationAlertsRequest + { acknowledgeSACorrelationAlertsRequestAlertIds :: [Text] + } + deriving stock (Eq, Show) + +instance ToJSON AcknowledgeSACorrelationAlertsRequest where + toJSON r = object ["alertIds" .= acknowledgeSACorrelationAlertsRequestAlertIds r] + +instance FromJSON AcknowledgeSACorrelationAlertsRequest where + parseJSON = withObject "AcknowledgeSACorrelationAlertsRequest" $ \o -> + AcknowledgeSACorrelationAlertsRequest <$> o .:? "alertIds" .!= [] + +-- | Response body for acknowledge-correlation-alerts. Note the response +-- has only @acknowledged@ and @failed@ arrays (NO @missing@ key — +-- contrast with 'AcknowledgeSADetectorAlertsResponse' which has all +-- three). +data AcknowledgeSACorrelationAlertsResponse = AcknowledgeSACorrelationAlertsResponse + { acknowledgeSACorrelationAlertsResponseAcknowledged :: [SACorrelationAlert], + acknowledgeSACorrelationAlertsResponseFailed :: Value + } + deriving stock (Eq, Show) + +instance FromJSON AcknowledgeSACorrelationAlertsResponse where + parseJSON = withObject "AcknowledgeSACorrelationAlertsResponse" $ \o -> + AcknowledgeSACorrelationAlertsResponse + <$> o .:? "acknowledged" .!= [] + <*> o .:? "failed" .!= Null + +instance ToJSON AcknowledgeSACorrelationAlertsResponse where + toJSON r = + omitNulls + [ "acknowledged" .= acknowledgeSACorrelationAlertsResponseAcknowledged r, + "failed" .= acknowledgeSACorrelationAlertsResponseFailed r + ] + +-- ========================================================================= +-- Log type API +-- ========================================================================= +-- + +-- $logtypeapi +-- +-- Log types are the categories that pair an index with a Sigma rule +-- topic (windows, network, ad_ldap, ...). The plugin ships a set of +-- built-in log types (@source: "Sigma"@); custom log types +-- (@source: "Custom"@) can be created, updated, searched, and deleted +-- (see +-- ). +-- Per-id GET is not documented, so only the four CRUD-shape endpoints +-- actually documented are shipped (create, search, update, delete). +-- +-- Wire gotchas: +-- +-- * The singular create/update response wraps the body in a @logType@ +-- key (camelCase); the URL path uses lowercase @logtype@. Both are +-- real. +-- * The search endpoint returns a standard OpenSearch search envelope +-- (@took@, @_shards@, @hits.total.{value,relation}@, +-- @hits.hits[]._source@) — the log type lives in @_source@. +-- * @tags@ is @null@ for some custom log types and an object for +-- others; the only documented sub-key is @correlation_id@ (integer). +-- * Built-in log type @_id@ equals its @name@ (e.g. @_id: "s3"@); +-- custom log type @_id@s are opaque server-assigned hashes. + +-- | The @source@ field on a log type. @"Sigma"@ marks built-in types, +-- @"Custom"@ marks user-defined types; any other value round-trips via +-- 'SALogTypeSourceOther'. +data SALogTypeSource + = SALogTypeSourceSigma + | SALogTypeSourceCustom + | SALogTypeSourceOther Text + deriving stock (Eq, Show) + +-- | Wire string for an 'SALogTypeSource'. +saLogTypeSourceText :: SALogTypeSource -> Text +saLogTypeSourceText = \case + SALogTypeSourceSigma -> "Sigma" + SALogTypeSourceCustom -> "Custom" + SALogTypeSourceOther t -> t + +instance ToJSON SALogTypeSource where + toJSON = toJSON . saLogTypeSourceText + +instance FromJSON SALogTypeSource where + parseJSON = withText "SALogTypeSource" $ \t -> + pure $ + case t of + "Sigma" -> SALogTypeSourceSigma + "Custom" -> SALogTypeSourceCustom + other -> SALogTypeSourceOther other + +-- | The @tags@ sub-object on a log type. The only documented sub-key is +-- @correlation_id@ (an integer assigned by the server); unknown keys +-- round-trip via 'saLogTypeTagsOther'. @tags@ may be @null@ on the wire +-- for some custom log types — the 'Maybe SALogTypeTags' on 'SALogType' +-- captures that. +data SALogTypeTags = SALogTypeTags + { saLogTypeTagsCorrelationId :: Maybe Int64, + saLogTypeTagsOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SALogTypeTags where + toJSON t = + case saLogTypeTagsOther t of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = ["correlation_id" .= saLogTypeTagsCorrelationId t] + +instance FromJSON SALogTypeTags where + parseJSON = withObject "SALogTypeTags" $ \o -> + SALogTypeTags + <$> o .:? "correlation_id" + <*> pure (Object o) + +-- | The log type body, reused by the create request body, the create +-- response's @logType@ sub-object, and the update request body. The +-- @name@ is required on create; @description@, @source@, and @tags@ are +-- optional (server-populated where omitted). Unknown keys round-trip +-- via 'saLogTypeOther'. +data SALogType = SALogType + { saLogTypeName :: Text, + saLogTypeDescription :: Maybe Text, + saLogTypeSource :: Maybe SALogTypeSource, + saLogTypeTags :: Maybe SALogTypeTags, + saLogTypeOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SALogType where + toJSON l = + case saLogTypeOther l of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= saLogTypeName l, + "description" .= saLogTypeDescription l, + "source" .= saLogTypeSource l, + "tags" .= saLogTypeTags l + ] + +instance FromJSON SALogType where + parseJSON = withObject "SALogType" $ \o -> + SALogType + <$> o .: "name" + <*> o .:? "description" + <*> o .:? "source" + <*> o .:? "tags" + <*> pure (Object o) + +-- | Response body for @POST /_plugins/_security_analytics/logtype@ and +-- @PUT /_plugins/_security_analytics/logtype/{log_type_id}@: the +-- server-assigned @_id@ and @_version@ plus the persisted 'SALogType' +-- (wrapped in a @logType@ key on the wire). +data SALogTypeResponse = SALogTypeResponse + { saLogTypeResponseId :: Text, + saLogTypeResponseVersion :: Int64, + saLogTypeResponseLogType :: SALogType + } + deriving stock (Eq, Show) + +instance FromJSON SALogTypeResponse where + parseJSON = withObject "SALogTypeResponse" $ \o -> + SALogTypeResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "logType" + +instance ToJSON SALogTypeResponse where + toJSON r = + object + [ "_id" .= saLogTypeResponseId r, + "_version" .= saLogTypeResponseVersion r, + "logType" .= saLogTypeResponseLogType r + ] + +-- | Optional query body for +-- @POST /_plugins/_security_analytics/logtype/_search@. The query DSL +-- is the standard OpenSearch query language; pass +-- 'defaultSALogTypeSearchQuery' for the plain @{"query": {"match_all": {}}}@ +-- that returns the first page of all log types. +data SALogTypeSearchQuery = SALogTypeSearchQuery + { saLogTypeSearchQueryQuery :: Value + } + deriving stock (Eq, Show) + +-- | The empty query: @{"query": {"match_all": {}}}@ on the wire. +defaultSALogTypeSearchQuery :: SALogTypeSearchQuery +defaultSALogTypeSearchQuery = + SALogTypeSearchQuery + { saLogTypeSearchQueryQuery = object ["match_all" .= object []] + } + +instance ToJSON SALogTypeSearchQuery where + toJSON q = object ["query" .= saLogTypeSearchQueryQuery q] + +instance FromJSON SALogTypeSearchQuery where + parseJSON = withObject "SALogTypeSearchQuery" $ \o -> + SALogTypeSearchQuery <$> o .:? "query" .!= object [] + +-- | A single hit in @hits.hits[]@ on a log type search response. The +-- 'SALogType' body lives in @_source@. +data SALogTypeHit = SALogTypeHit + { saLogTypeHitIndex :: Maybe Text, + saLogTypeHitId :: Maybe Text, + saLogTypeHitScore :: Maybe Double, + saLogTypeHitSource :: SALogType, + saLogTypeHitOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SALogTypeHit where + parseJSON = withObject "SALogTypeHit" $ \o -> + SALogTypeHit + <$> o .:? "_index" + <*> o .:? "_id" + <*> o .:? "_score" + <*> o .: "_source" + <*> pure (Object o) + +instance ToJSON SALogTypeHit where + toJSON h = + case saLogTypeHitOther h of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "_index" .= saLogTypeHitIndex h, + "_id" .= saLogTypeHitId h, + "_score" .= saLogTypeHitScore h, + "_source" .= saLogTypeHitSource h + ] + +-- | The @hits.total@ sub-object on a log type search response. Carries +-- the count (@value@) and whether it is exact (@relation@: @"eq"@ or +-- @"gte"@). Same shape as 'SARulesTotal'. +data SALogTypesTotal = SALogTypesTotal + { saLogTypesTotalValue :: Int64, + saLogTypesTotalRelation :: SALogTypesTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON SALogTypesTotal where + parseJSON = withObject "SALogTypesTotal" $ \o -> + SALogTypesTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON SALogTypesTotal where + toJSON t = + object + [ "value" .= saLogTypesTotalValue t, + "relation" .= saLogTypesTotalRelation t + ] + +-- | The @hits.total.relation@ discriminator on a log type search +-- response. Mirrors 'SARulesTotalRelation' (with an @SA@-prefixed +-- name to keep plugin-specific types in their own module) and uses +-- the spec-correct @"gte"@ wire string. Unknown values fall through +-- to 'SALogTypesTotalRelationOther'. +data SALogTypesTotalRelation + = SALogTypesTotalRelationEq + | SALogTypesTotalRelationGte + | SALogTypesTotalRelationOther Text + deriving stock (Eq, Show) + +instance FromJSON SALogTypesTotalRelation where + parseJSON = withText "SALogTypesTotalRelation" $ \t -> + pure $ + case t of + "eq" -> SALogTypesTotalRelationEq + "gte" -> SALogTypesTotalRelationGte + other -> SALogTypesTotalRelationOther other + +instance ToJSON SALogTypesTotalRelation where + toJSON SALogTypesTotalRelationEq = "eq" + toJSON SALogTypesTotalRelationGte = "gte" + toJSON (SALogTypesTotalRelationOther t) = toJSON t + +-- | Response envelope for +-- @POST /_plugins/_security_analytics/logtype/_search@. Standard +-- OpenSearch search envelope (@took@, @timed_out@, @_shards@, +-- @hits.total.{value,relation}@, @hits.hits[]@, @hits.max_score@). +-- 'saLogTypesSearchResponseLogTypes' projects out the @['SALogType']@ +-- list for convenience. +data SALogTypesSearchResponse = SALogTypesSearchResponse + { saLogTypesSearchResponseTook :: Maybe Int64, + saLogTypesSearchResponseTimedOut :: Maybe Bool, + saLogTypesSearchResponseShards :: Maybe SARulesShards, + saLogTypesSearchResponseHitsTotal :: Maybe SALogTypesTotal, + saLogTypesSearchResponseMaxScore :: Maybe Double, + saLogTypesSearchResponseHits :: [SALogTypeHit] + } + deriving stock (Eq, Show) + +instance FromJSON SALogTypesSearchResponse where + parseJSON = withObject "SALogTypesSearchResponse" $ \o -> do + hits <- o .:? "hits" .!= object [] + hitsObj <- case hits of + Object ho -> pure ho + _ -> fail "SALogTypesSearchResponse: hits is not an object" + SALogTypesSearchResponse + <$> o .:? "took" + <*> o .:? "timed_out" + <*> o .:? "_shards" + <*> hitsObj .:? "total" + <*> hitsObj .:? "max_score" + <*> hitsObj .:? "hits" .!= [] + +instance ToJSON SALogTypesSearchResponse where + toJSON r = + omitNulls + [ "took" .= saLogTypesSearchResponseTook r, + "timed_out" .= saLogTypesSearchResponseTimedOut r, + "_shards" .= saLogTypesSearchResponseShards r, + "hits" + .= omitNulls + [ "total" .= saLogTypesSearchResponseHitsTotal r, + "max_score" .= saLogTypesSearchResponseMaxScore r, + "hits" .= saLogTypesSearchResponseHits r + ] + ] + +-- | Project the decoded 'SALogType' list out of a +-- 'SALogTypesSearchResponse' (convenience for the common case where the +-- caller does not need pagination metadata). +saLogTypesSearchResponseLogTypes :: SALogTypesSearchResponse -> [SALogType] +saLogTypesSearchResponseLogTypes = map saLogTypeHitSource . saLogTypesSearchResponseHits + +-- | Response body for +-- @DELETE /_plugins/_security_analytics/logtype/{log_type_id}@. Only +-- @_id@ and @_version@ are returned. Trying to delete a built-in +-- (non-custom) log type is rejected by the server. +data DeleteSALogTypeResponse = DeleteSALogTypeResponse + { deleteSALogTypeResponseId :: Text, + deleteSALogTypeResponseVersion :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteSALogTypeResponse where + parseJSON = withObject "DeleteSALogTypeResponse" $ \o -> + DeleteSALogTypeResponse + <$> o .: "_id" + <*> o .: "_version" + +instance ToJSON DeleteSALogTypeResponse where + toJSON r = + object + [ "_id" .= deleteSALogTypeResponseId r, + "_version" .= deleteSALogTypeResponseVersion r + ] + +-- | Overlay the typed key-value pairs on top of a captured object, +-- dropping typed pairs whose value is @null@ (so optional fields +-- left 'Nothing' do not clobber a non-null value captured from the +-- wire). Mirrors the helper in +-- "Database.Bloodhound.Internal.Versions.OpenSearch2.Types.Alerting". +mergeIgnoringNulls :: [(Key, Value)] -> KM.KeyMap Value -> KM.KeyMap Value +mergeIgnoringNulls kvs o = KM.union (KM.fromList (filter notNull kvs)) o + where + notNull (_, Null) = False + notNull _ = True diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/SnapshotManagement.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/SnapshotManagement.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch2/Types/SnapshotManagement.hs @@ -0,0 +1,717 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch2.Types.SnapshotManagement where + +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- $overview +-- +-- The OpenSearch Snapshot Management (SM) plugin runs snapshot creation and +-- deletion on a schedule. Policies live under +-- @\/_plugins\/_sm\/policies\/{policy_name}@ and carry: +-- +-- 1. A user-supplied body ('SMPolicyBody') sent on @POST@\/@PUT@ — no +-- @name@, no @schema_version@, no @enabled_time@: the server injects +-- those. +-- 2. A server-augmented policy ('SMPolicy') returned on @GET@ and inside +-- the @sm_policy@ wrapper of @POST@\/@PUT@ responses — the body fields +-- plus @name@, @schema_version@, @schedule@, @enabled_time@, +-- @last_updated_time@. +-- +-- The SM plugin was introduced in OpenSearch 2.1. The path is identical +-- across OS 2.x and OS 3.x; the only behavioural delta is that @creation@ +-- becomes optional in OpenSearch 3.3+. We model it as 'Maybe' throughout. +-- +-- See + +-- ========================================================================= +-- Newtypes +-- ========================================================================= + +-- | 'SMPolicyName' identifies an SM policy in the URL path +-- @\/_plugins\/_sm\/policies\/{policy_name}@. Wraps 'Text' so it round-trips +-- through JSON as a bare string but is distinct at the Haskell type level. +newtype SMPolicyName = SMPolicyName {unSMPolicyName :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- ========================================================================= +-- Cron and schedules +-- ========================================================================= + +-- | A cron expression plus its timezone. Used inside 'SMCreation' and +-- 'SMDeletion' schedules. The timezone is a Java TimeZone ID +-- (e.g. @"UTC"@, @"America/Los_Angeles"@). +data SMCron = SMCron + { smCronExpression :: Text, + smCronTimezone :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SMCron where + parseJSON = withObject "SMCron" $ \o -> + SMCron <$> o .: "expression" <*> o .: "timezone" + +instance ToJSON SMCron where + toJSON SMCron {..} = + object + [ "expression" .= smCronExpression, + "timezone" .= smCronTimezone + ] + +-- | The user-facing schedule (a cron block). The Job Scheduler plugin also +-- emits an @interval@ form on responses ('SMJobSchedulerInterval'); the two +-- are mutually exclusive on the wire. +data SMSchedule = SMSchedule + { smScheduleCron :: Maybe SMCron, + smScheduleInterval :: Maybe SMJobSchedulerInterval + } + deriving stock (Eq, Show) + +instance FromJSON SMSchedule where + parseJSON = withObject "SMSchedule" $ \o -> do + smScheduleCron <- o .:? "cron" + smScheduleInterval <- o .:? "interval" + return SMSchedule {..} + +instance ToJSON SMSchedule where + toJSON SMSchedule {..} = + omitNulls + [ "cron" .= smScheduleCron, + "interval" .= smScheduleInterval + ] + +-- | Server-populated Job Scheduler @interval@ block, emitted in +-- 'SMPolicy'.'smPolicySchedule'. The @unit@ is a Java enum string +-- (e.g. @"Minutes"@, @"Hours"@). +data SMJobSchedulerInterval = SMJobSchedulerInterval + { smJobSchedulerIntervalStartTime :: Maybe Int, + smJobSchedulerIntervalPeriod :: Maybe Int, + smJobSchedulerIntervalUnit :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SMJobSchedulerInterval where + parseJSON = withObject "SMJobSchedulerInterval" $ \o -> do + smJobSchedulerIntervalStartTime <- o .:? "start_time" + smJobSchedulerIntervalPeriod <- o .:? "period" + smJobSchedulerIntervalUnit <- o .:? "unit" + return SMJobSchedulerInterval {..} + +instance ToJSON SMJobSchedulerInterval where + toJSON SMJobSchedulerInterval {..} = + omitNulls + [ "start_time" .= smJobSchedulerIntervalStartTime, + "period" .= smJobSchedulerIntervalPeriod, + "unit" .= smJobSchedulerIntervalUnit + ] + +-- ========================================================================= +-- Creation and deletion config +-- ========================================================================= + +-- | Snapshot creation config. @creation.schedule.cron@ is required by the +-- server on OS < 3.3 when the @creation@ block is present; @time_limit@ +-- is an optional duration like @"1h"@. +data SMCreation = SMCreation + { smCreationSchedule :: Maybe SMSchedule, + smCreationTimeLimit :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SMCreation where + parseJSON = withObject "SMCreation" $ \o -> do + smCreationSchedule <- o .:? "schedule" + smCreationTimeLimit <- o .:? "time_limit" + return SMCreation {..} + +instance ToJSON SMCreation where + toJSON SMCreation {..} = + omitNulls + [ "schedule" .= smCreationSchedule, + "time_limit" .= smCreationTimeLimit + ] + +-- | Snapshot retention conditions. @max_age@ is a duration like @"7d"@; +-- @max_count@ / @min_count@ are integers (the server defaults @min_count@ +-- to @1@ when omitted). +data SMDeleteCondition = SMDeleteCondition + { smDeleteConditionMaxAge :: Maybe Text, + smDeleteConditionMaxCount :: Maybe Int, + smDeleteConditionMinCount :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON SMDeleteCondition where + parseJSON = withObject "SMDeleteCondition" $ \o -> do + smDeleteConditionMaxAge <- o .:? "max_age" + smDeleteConditionMaxCount <- o .:? "max_count" + smDeleteConditionMinCount <- o .:? "min_count" + return SMDeleteCondition {..} + +instance ToJSON SMDeleteCondition where + toJSON SMDeleteCondition {..} = + omitNulls + [ "max_age" .= smDeleteConditionMaxAge, + "max_count" .= smDeleteConditionMaxCount, + "min_count" .= smDeleteConditionMinCount + ] + +-- | Snapshot deletion config. @deletion.schedule@ defaults to +-- 'SMCreation'.'smCreationSchedule' when omitted on the request. +data SMDeletion = SMDeletion + { smDeletionSchedule :: Maybe SMSchedule, + smDeletionTimeLimit :: Maybe Text, + smDeletionCondition :: Maybe SMDeleteCondition, + smDeletionSnapshotPattern :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SMDeletion where + parseJSON = withObject "SMDeletion" $ \o -> do + smDeletionSchedule <- o .:? "schedule" + smDeletionTimeLimit <- o .:? "time_limit" + -- See 'SMDeleteCondition': the JSON examples use the key @condition@, + -- the parameter table documents @delete_condition@. Accept both, + -- preferring @condition@ when both are present; emit @condition@ on + -- encode. We use 'KM.lookup' rather than @(.:?) <|> (.:?)@ because + -- @(.:?)@ succeeds with 'Nothing' (rather than failing) when the key + -- is absent, so the alternative would never trigger. + let mRawCondition = KM.lookup "condition" o <|> KM.lookup "delete_condition" o + smDeletionCondition <- traverse parseJSON mRawCondition + smDeletionSnapshotPattern <- o .:? "snapshot_pattern" + return SMDeletion {..} + +instance ToJSON SMDeletion where + toJSON SMDeletion {..} = + omitNulls + [ "schedule" .= smDeletionSchedule, + "time_limit" .= smDeletionTimeLimit, + "condition" .= smDeletionCondition, + "snapshot_pattern" .= smDeletionSnapshotPattern + ] + +-- ========================================================================= +-- snapshot_config (passthrough to Create Snapshot API) +-- ========================================================================= + +-- | The @snapshot_config@ block is forwarded verbatim to the snapshot +-- Create API. The SM docs document a typed subset; we model the typed +-- subset and stash any extras in 'smSnapshotConfigExtras'. +-- +-- /Documentation inconsistency:/ the docs type @ignore_unavailable@, +-- @include_global_state@, and @partial@ as Booleans, but every verbatim +-- example encodes them as the strings @"true"@ / @"false"@. We accept +-- both on decode (see 'parseLenientBool') and emit native Booleans on +-- encode. +data SMSnapshotConfig = SMSnapshotConfig + { smSnapshotConfigRepository :: Maybe Text, + smSnapshotConfigIndices :: Maybe Text, + smSnapshotConfigDateFormat :: Maybe Text, + smSnapshotConfigDateFormatTimezone :: Maybe Text, + smSnapshotConfigTimezone :: Maybe Text, + smSnapshotConfigIgnoreUnavailable :: Maybe Bool, + smSnapshotConfigIncludeGlobalState :: Maybe Bool, + smSnapshotConfigPartial :: Maybe Bool, + smSnapshotConfigMetadata :: Maybe (Map.Map Text Value), + smSnapshotConfigExtras :: Maybe (KM.KeyMap Value) + } + deriving stock (Eq, Show) + +instance FromJSON SMSnapshotConfig where + parseJSON = withObject "SMSnapshotConfig" $ \o -> do + smSnapshotConfigRepository <- o .:? "repository" + smSnapshotConfigIndices <- o .:? "indices" + smSnapshotConfigDateFormat <- o .:? "date_format" + smSnapshotConfigDateFormatTimezone <- o .:? "date_format_timezone" + smSnapshotConfigTimezone <- o .:? "timezone" + smSnapshotConfigIgnoreUnavailable <- o .:? "ignore_unavailable" >>= traverse parseLenientBool + smSnapshotConfigIncludeGlobalState <- o .:? "include_global_state" >>= traverse parseLenientBool + smSnapshotConfigPartial <- o .:? "partial" >>= traverse parseLenientBool + smSnapshotConfigMetadata <- o .:? "metadata" + let knownKeys = + [ "repository", + "indices", + "date_format", + "date_format_timezone", + "timezone", + "ignore_unavailable", + "include_global_state", + "partial", + "metadata" + ] + extras = deleteSeveral (fmap fromString knownKeys) o + smSnapshotConfigExtras <- + if null extras then pure Nothing else pure (Just extras) + return SMSnapshotConfig {..} + +instance ToJSON SMSnapshotConfig where + toJSON SMSnapshotConfig {..} = + let knownPairs = + catMaybes + [ ("repository" .=) <$> smSnapshotConfigRepository, + ("indices" .=) <$> smSnapshotConfigIndices, + ("date_format" .=) <$> smSnapshotConfigDateFormat, + ("date_format_timezone" .=) <$> smSnapshotConfigDateFormatTimezone, + ("timezone" .=) <$> smSnapshotConfigTimezone, + ("ignore_unavailable" .=) <$> smSnapshotConfigIgnoreUnavailable, + ("include_global_state" .=) <$> smSnapshotConfigIncludeGlobalState, + ("partial" .=) <$> smSnapshotConfigPartial, + ("metadata" .=) <$> smSnapshotConfigMetadata + ] + extraPairs = maybe [] KM.toList smSnapshotConfigExtras + in object (knownPairs <> extraPairs) + +-- | Parse a Bool that may arrive as a native Bool or as the strings +-- @"true"@ / @"false"@ (case-insensitive). The SM plugin's @snapshot_config@ +-- block is forwarded verbatim to the snapshot Create API, which historically +-- accepts both representations for @ignore_unavailable@, +-- @include_global_state@, and @partial@. +parseLenientBool :: Value -> Parser Bool +parseLenientBool (Bool b) = pure b +parseLenientBool (String s) + | T.toLower s == "true" = pure True + | T.toLower s == "false" = pure False +parseLenientBool v = + fail $ + "Expected Bool or \"true\"/\"false\" string, got: " <> show v + +-- ========================================================================= +-- notification +-- ========================================================================= + +data SMNotificationChannel = SMNotificationChannel + { smNotificationChannelId :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SMNotificationChannel where + parseJSON = withObject "SMNotificationChannel" $ \o -> + SMNotificationChannel <$> o .: "id" + +instance ToJSON SMNotificationChannel where + toJSON SMNotificationChannel {..} = + object ["id" .= smNotificationChannelId] + +-- | Which SM events trigger a notification. All fields default per the +-- docs: @creation@=@true@, the rest @false@. +data SMNotificationConditions = SMNotificationConditions + { smNotificationConditionsCreation :: Maybe Bool, + smNotificationConditionsDeletion :: Maybe Bool, + smNotificationConditionsFailure :: Maybe Bool, + smNotificationConditionsTimeLimitExceeded :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON SMNotificationConditions where + parseJSON = withObject "SMNotificationConditions" $ \o -> do + smNotificationConditionsCreation <- o .:? "creation" + smNotificationConditionsDeletion <- o .:? "deletion" + smNotificationConditionsFailure <- o .:? "failure" + smNotificationConditionsTimeLimitExceeded <- o .:? "time_limit_exceeded" + return SMNotificationConditions {..} + +instance ToJSON SMNotificationConditions where + toJSON SMNotificationConditions {..} = + omitNulls + [ "creation" .= smNotificationConditionsCreation, + "deletion" .= smNotificationConditionsDeletion, + "failure" .= smNotificationConditionsFailure, + "time_limit_exceeded" .= smNotificationConditionsTimeLimitExceeded + ] + +data SMNotification = SMNotification + { smNotificationChannel :: Maybe SMNotificationChannel, + smNotificationConditions :: Maybe SMNotificationConditions + } + deriving stock (Eq, Show) + +instance FromJSON SMNotification where + parseJSON = withObject "SMNotification" $ \o -> do + smNotificationChannel <- o .:? "channel" + smNotificationConditions <- o .:? "conditions" + return SMNotification {..} + +instance ToJSON SMNotification where + toJSON SMNotification {..} = + omitNulls + [ "channel" .= smNotificationChannel, + "conditions" .= smNotificationConditions + ] + +-- ========================================================================= +-- Request body and server-augmented policy +-- ========================================================================= + +-- | The user-supplied policy body sent on @POST@\/@PUT. Carries only +-- fields the client supplies; the server injects @name@, +-- @schema_version@, @schedule@, @enabled_time@, @last_updated_time@. +data SMPolicyBody = SMPolicyBody + { smPolicyBodyDescription :: Maybe Text, + smPolicyBodyEnabled :: Maybe Bool, + smPolicyBodyCreation :: Maybe SMCreation, + smPolicyBodyDeletion :: Maybe SMDeletion, + smPolicyBodySnapshotConfig :: Maybe SMSnapshotConfig, + smPolicyBodyNotification :: Maybe SMNotification + } + deriving stock (Eq, Show) + +instance FromJSON SMPolicyBody where + parseJSON = withObject "SMPolicyBody" $ \o -> do + smPolicyBodyDescription <- o .:? "description" + smPolicyBodyEnabled <- o .:? "enabled" + smPolicyBodyCreation <- o .:? "creation" + smPolicyBodyDeletion <- o .:? "deletion" + smPolicyBodySnapshotConfig <- o .:? "snapshot_config" + smPolicyBodyNotification <- o .:? "notification" + return SMPolicyBody {..} + +instance ToJSON SMPolicyBody where + toJSON SMPolicyBody {..} = + omitNulls + [ "description" .= smPolicyBodyDescription, + "enabled" .= smPolicyBodyEnabled, + "creation" .= smPolicyBodyCreation, + "deletion" .= smPolicyBodyDeletion, + "snapshot_config" .= smPolicyBodySnapshotConfig, + "notification" .= smPolicyBodyNotification + ] + +-- | A server-augmented SM policy — the body fields plus the +-- server-injected @name@, @schema_version@, @schedule@, @enabled_time@, +-- @last_updated_time@. This is the shape that lives inside the @sm_policy@ +-- wrapper of every SM response. +data SMPolicy = SMPolicy + { smPolicyBody :: SMPolicyBody, + smPolicyName :: Maybe Text, + smPolicySchemaVersion :: Maybe Int, + smPolicySchedule :: Maybe SMSchedule, + smPolicyEnabledTime :: Maybe Int, + smPolicyLastUpdatedTime :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON SMPolicy where + parseJSON v = do + body <- parseJSON v + withObject + "SMPolicy" + ( \o -> do + smPolicyName <- o .:? "name" + smPolicySchemaVersion <- o .:? "schema_version" + smPolicySchedule <- o .:? "schedule" + smPolicyEnabledTime <- o .:? "enabled_time" + smPolicyLastUpdatedTime <- o .:? "last_updated_time" + return SMPolicy {smPolicyBody = body, ..} + ) + v + +instance ToJSON SMPolicy where + toJSON SMPolicy {..} = + let bodyPairs = case toJSON smPolicyBody of + Object o -> KM.toList o + _ -> [] + serverPairs = + catMaybes + [ ("name" .=) <$> smPolicyName, + ("schema_version" .=) <$> smPolicySchemaVersion, + ("schedule" .=) <$> smPolicySchedule, + ("enabled_time" .=) <$> smPolicyEnabledTime, + ("last_updated_time" .=) <$> smPolicyLastUpdatedTime + ] + in object (serverPairs <> bodyPairs) + +-- ========================================================================= +-- Envelopes +-- ========================================================================= + +-- | Response of @POST@\/@PUT@\/@GET /_plugins/_sm/policies/{policy_name}@. +-- The standard document-write envelope (@_id@, @_version@, @_seq_no@, +-- @_primary_term@) wrapping a single @sm_policy@ object. The Create and +-- Update operations share this shape; Get returns it without modification. +data SMPolicyResponse = SMPolicyResponse + { smPolicyResponseId :: Maybe Text, + smPolicyResponseVersion :: Maybe Int, + smPolicyResponseSeqNo :: Maybe Int, + smPolicyResponsePrimaryTerm :: Maybe Int, + smPolicyResponseSMPolicy :: Maybe SMPolicy + } + deriving stock (Eq, Show) + +instance FromJSON SMPolicyResponse where + parseJSON = withObject "SMPolicyResponse" $ \o -> do + smPolicyResponseId <- o .:? "_id" + smPolicyResponseVersion <- o .:? "_version" + smPolicyResponseSeqNo <- o .:? "_seq_no" + smPolicyResponsePrimaryTerm <- o .:? "_primary_term" + rawPolicy <- o .:? "sm_policy" + smPolicyResponseSMPolicy <- traverse parseJSON rawPolicy + return SMPolicyResponse {..} + +instance ToJSON SMPolicyResponse where + toJSON SMPolicyResponse {..} = + omitNulls $ + catMaybes + [ ("_id" .=) <$> smPolicyResponseId, + ("_version" .=) <$> smPolicyResponseVersion, + ("_seq_no" .=) <$> smPolicyResponseSeqNo, + ("_primary_term" .=) <$> smPolicyResponsePrimaryTerm, + ("sm_policy" .=) <$> smPolicyResponseSMPolicy + ] + +-- | Response of @GET /_plugins/_sm/policies@. The SM docs do not give a +-- verbatim example for the list-all variant; we model the conventional +-- OpenSearch shape @\{"policies": [ ... ]\}@ where each entry is a +-- 'SMPolicy' (the same object that lives inside the single-policy +-- @sm_policy@ wrapper). Verify against a live cluster if exact-shape +-- correctness matters. +newtype GetSMPoliciesResponse = GetSMPoliciesResponse + { getSMPoliciesResponsePolicies :: [SMPolicy] + } + deriving stock (Eq, Show) + +instance FromJSON GetSMPoliciesResponse where + parseJSON = withObject "GetSMPoliciesResponse" $ \o -> + GetSMPoliciesResponse <$> (o .:? "policies" .!= []) + +instance ToJSON GetSMPoliciesResponse where + toJSON r = object ["policies" .= getSMPoliciesResponsePolicies r] + +-- | Query parameters for @GET /_plugins/_sm/policies@. +data GetSMPoliciesQuery = GetSMPoliciesQuery + { getSMPoliciesQueryFrom :: Maybe Int, + getSMPoliciesQuerySize :: Maybe Int, + getSMPoliciesQuerySortField :: Maybe Text, + getSMPoliciesQuerySortOrder :: Maybe Text, + getSMPoliciesQueryQueryString :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty query — no pagination, sort, or filter. +defaultGetSMPoliciesQuery :: GetSMPoliciesQuery +defaultGetSMPoliciesQuery = + GetSMPoliciesQuery + { getSMPoliciesQueryFrom = Nothing, + getSMPoliciesQuerySize = Nothing, + getSMPoliciesQuerySortField = Nothing, + getSMPoliciesQuerySortOrder = Nothing, + getSMPoliciesQueryQueryString = Nothing + } + +-- | Render a 'GetSMPoliciesQuery' to the query-string pairs expected by +-- @GET /_plugins/_sm/policies@. Empty fields are omitted so the default +-- query renders to no query string at all. +getSMPoliciesQueryParams :: GetSMPoliciesQuery -> [(Text, Maybe Text)] +getSMPoliciesQueryParams GetSMPoliciesQuery {..} = + catMaybes + [ ("from",) . Just . showText <$> getSMPoliciesQueryFrom, + ("size",) . Just . showText <$> getSMPoliciesQuerySize, + ("sortField",) . Just <$> getSMPoliciesQuerySortField, + ("sortOrder",) . Just <$> getSMPoliciesQuerySortOrder, + ("queryString",) . Just <$> getSMPoliciesQueryQueryString + ] + +-- | Response of @DELETE /_plugins/_sm/policies/{policy_name}@. The standard +-- OpenSearch document-delete envelope (SM policies are stored as documents +-- in @.opendistro-ism-config@). +data DeleteSMPolicyResponse = DeleteSMPolicyResponse + { deleteSMPolicyResponseIndex :: Maybe Text, + deleteSMPolicyResponseId :: Maybe Text, + deleteSMPolicyResponseVersion :: Maybe Int, + deleteSMPolicyResponseResult :: Maybe Text, + deleteSMPolicyResponseForcedRefresh :: Maybe Bool, + deleteSMPolicyResponseSeqNo :: Maybe Int, + deleteSMPolicyResponsePrimaryTerm :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON DeleteSMPolicyResponse where + parseJSON = withObject "DeleteSMPolicyResponse" $ \o -> do + deleteSMPolicyResponseIndex <- o .:? "_index" + deleteSMPolicyResponseId <- o .:? "_id" + deleteSMPolicyResponseVersion <- o .:? "_version" + deleteSMPolicyResponseResult <- o .:? "result" + deleteSMPolicyResponseForcedRefresh <- o .:? "forced_refresh" + deleteSMPolicyResponseSeqNo <- o .:? "_seq_no" + deleteSMPolicyResponsePrimaryTerm <- o .:? "_primary_term" + return DeleteSMPolicyResponse {..} + +instance ToJSON DeleteSMPolicyResponse where + toJSON DeleteSMPolicyResponse {..} = + omitNulls + [ "_index" .= deleteSMPolicyResponseIndex, + "_id" .= deleteSMPolicyResponseId, + "_version" .= deleteSMPolicyResponseVersion, + "result" .= deleteSMPolicyResponseResult, + "forced_refresh" .= deleteSMPolicyResponseForcedRefresh, + "_seq_no" .= deleteSMPolicyResponseSeqNo, + "_primary_term" .= deleteSMPolicyResponsePrimaryTerm + ] + +-- ========================================================================= +-- Explain +-- ========================================================================= + +-- | Per-execution info inside 'SMExplainWorkflow'. Only present after at +-- least one execution cycle. @status@ is one of @IN_PROGRESS@, @SUCCESS@, +-- @RETRYING@, @FAILED@, @TIME_LIMIT_EXCEEDED@. The @info.cause@ field is +-- present only on failures. +data SMExplainExecution = SMExplainExecution + { smExplainExecutionStatus :: Maybe Text, + smExplainExecutionStartTime :: Maybe Int, + smExplainExecutionEndTime :: Maybe Int, + smExplainExecutionInfoMessage :: Maybe Text, + smExplainExecutionInfoCause :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SMExplainExecution where + parseJSON = withObject "SMExplainExecution" $ \o -> do + smExplainExecutionStatus <- o .:? "status" + smExplainExecutionStartTime <- o .:? "start_time" + smExplainExecutionEndTime <- o .:? "end_time" + info <- o .:? "info" + (smExplainExecutionInfoMessage, smExplainExecutionInfoCause) <- + case info of + Nothing -> pure (Nothing, Nothing) + Just i -> + withObject + "SMExplainExecution.info" + ( \io -> do + m <- io .:? "message" + c <- io .:? "cause" + pure (m, c) + ) + i + return SMExplainExecution {..} + +instance ToJSON SMExplainExecution where + toJSON SMExplainExecution {..} = + let infoPairs = + catMaybes + [ ("message" .=) <$> smExplainExecutionInfoMessage, + ("cause" .=) <$> smExplainExecutionInfoCause + ] + infoVal = + if null infoPairs + then Nothing + else Just (object infoPairs) + in omitNulls $ + catMaybes + [ ("status" .=) <$> smExplainExecutionStatus, + ("start_time" .=) <$> smExplainExecutionStartTime, + ("end_time" .=) <$> smExplainExecutionEndTime, + ("info" .=) <$> infoVal + ] + +-- | The @trigger.time@ sub-object. @time@ is milliseconds since epoch. +newtype SMExplainTrigger = SMExplainTrigger + { smExplainTriggerTime :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON SMExplainTrigger where + parseJSON = withObject "SMExplainTrigger" $ \o -> + SMExplainTrigger <$> o .:? "time" + +instance ToJSON SMExplainTrigger where + toJSON SMExplainTrigger {..} = + omitNulls ["time" .= smExplainTriggerTime] + +-- | The @retry.count@ sub-object. +newtype SMExplainRetry = SMExplainRetry + { smExplainRetryCount :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON SMExplainRetry where + parseJSON = withObject "SMExplainRetry" $ \o -> + SMExplainRetry <$> o .:? "count" + +instance ToJSON SMExplainRetry where + toJSON SMExplainRetry {..} = + omitNulls ["count" .= smExplainRetryCount] + +-- | The state of one half (creation or deletion) of an SM policy at +-- explain time. @current_state@ is one of @CREATION_START@, +-- @CREATION_CONDITION_MET@, @CREATING@, @CREATION_FINISHED@, or the +-- @DELETION_*@ equivalents. +data SMExplainWorkflow = SMExplainWorkflow + { smExplainWorkflowCurrentState :: Maybe Text, + smExplainWorkflowTrigger :: Maybe SMExplainTrigger, + smExplainWorkflowLatestExecution :: Maybe SMExplainExecution, + smExplainWorkflowRetry :: Maybe SMExplainRetry + } + deriving stock (Eq, Show) + +instance FromJSON SMExplainWorkflow where + parseJSON = withObject "SMExplainWorkflow" $ \o -> do + smExplainWorkflowCurrentState <- o .:? "current_state" + smExplainWorkflowTrigger <- o .:? "trigger" + smExplainWorkflowLatestExecution <- o .:? "latest_execution" + smExplainWorkflowRetry <- o .:? "retry" + return SMExplainWorkflow {..} + +instance ToJSON SMExplainWorkflow where + toJSON SMExplainWorkflow {..} = + omitNulls + [ "current_state" .= smExplainWorkflowCurrentState, + "trigger" .= smExplainWorkflowTrigger, + "latest_execution" .= smExplainWorkflowLatestExecution, + "retry" .= smExplainWorkflowRetry + ] + +-- | A single entry in the @policies@ array of an 'SMExplainResponse'. +data SMExplainEntry = SMExplainEntry + { smExplainEntryName :: Maybe Text, + smExplainEntryCreation :: Maybe SMExplainWorkflow, + smExplainEntryDeletion :: Maybe SMExplainWorkflow, + smExplainEntryPolicySeqNo :: Maybe Int, + smExplainEntryPolicyPrimaryTerm :: Maybe Int, + smExplainEntryEnabled :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON SMExplainEntry where + parseJSON = withObject "SMExplainEntry" $ \o -> do + smExplainEntryName <- o .:? "name" + smExplainEntryCreation <- o .:? "creation" + smExplainEntryDeletion <- o .:? "deletion" + smExplainEntryPolicySeqNo <- o .:? "policy_seq_no" + smExplainEntryPolicyPrimaryTerm <- o .:? "policy_primary_term" + smExplainEntryEnabled <- o .:? "enabled" + return SMExplainEntry {..} + +instance ToJSON SMExplainEntry where + toJSON SMExplainEntry {..} = + omitNulls + [ "name" .= smExplainEntryName, + "creation" .= smExplainEntryCreation, + "deletion" .= smExplainEntryDeletion, + "policy_seq_no" .= smExplainEntryPolicySeqNo, + "policy_primary_term" .= smExplainEntryPolicyPrimaryTerm, + "enabled" .= smExplainEntryEnabled + ] + +-- | Response of @GET /_plugins/_sm/policies/{policy_names}/_explain@. The +-- path parameter is a comma-separated list and/or a wildcard pattern +-- (e.g. @"daily*"@). +newtype SMExplainResponse = SMExplainResponse + { smExplainResponsePolicies :: [SMExplainEntry] + } + deriving stock (Eq, Show) + +instance FromJSON SMExplainResponse where + parseJSON = withObject "SMExplainResponse" $ \o -> + SMExplainResponse <$> (o .:? "policies" .!= []) + +instance ToJSON SMExplainResponse where + toJSON r = object ["policies" .= smExplainResponsePolicies r] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/Alerting.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/Alerting.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/Alerting.hs @@ -0,0 +1,2494 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.Alerting + ( -- * Identifiers + MonitorId (..), + DestinationId (..), + + -- * Discriminators + AlertType (..), + alertTypeText, + MonitorType (..), + monitorTypeText, + + -- * Schedule + Schedule (..), + SchedulePeriod (..), + ScheduleCron (..), + + -- * Inputs, triggers, actions + MonitorInput (..), + Trigger (..), + Action (..), + MessageTemplate (..), + Throttle (..), + AlertingShards (..), + + -- * Monitor and response wrappers + Monitor (..), + MonitorResponse (..), + DeleteMonitorResponse (..), + + -- * Monitor search (POST /_plugins/_alerting/monitors/_search) + MonitorsSearchQuery (..), + defaultMonitorsSearchQuery, + MonitorHit (..), + MonitorsTotal (..), + MonitorsTotalRelation (..), + monitorsTotalRelationText, + SearchMonitorsResponse (..), + searchMonitorsResponseMonitors, + + -- * Execute monitor (POST /_plugins/_alerting/monitors/{id}/_execute) + ExecuteMonitorRequest (..), + defaultExecuteMonitorRequest, + ExecuteMonitorResponse (..), + + -- * Destinations (GET /_plugins/_alerting/destinations) + DestinationType (..), + destinationTypeText, + Destination (..), + DestinationSortOrder (..), + destinationSortOrderText, + DestinationListOptions (..), + defaultDestinationListOptions, + destinationListOptionsParams, + GetDestinationsResponse (..), + + -- * Destination lifecycle (POST/PUT/DELETE /_plugins/_alerting/destinations[/{id}]) + DestinationResponse (..), + DeleteDestinationResponse (..), + + -- * Get alerts (GET /_plugins/_alerting/monitors/alerts) + AlertSortOrder (..), + alertSortOrderText, + AlertState (..), + alertStateText, + GetAlertsOptions (..), + defaultGetAlertsOptions, + getAlertsOptionsParams, + Alert (..), + GetAlertsResponse (..), + + -- * Acknowledge alert (POST /_plugins/_alerting/monitors/{id}/_acknowledge/alerts) + AcknowledgeAlertRequest (..), + defaultAcknowledgeAlertRequest, + AcknowledgeAlertResponse (..), + + -- * Monitor stats (GET /_plugins/_alerting/stats[/...]) + MonitorStats (..), + MonitorStatsNodesCount (..), + + -- * Email account lifecycle (POST/PUT/GET/DELETE /_plugins/_alerting/destinations/email_accounts[/{id}]) + EmailAccountId (..), + EmailAccount (..), + EmailAccountResponse (..), + DeleteEmailAccountResponse (..), + + -- * Email group lifecycle (POST/PUT/GET/DELETE /_plugins/_alerting/destinations/email_groups[/{id}]) + EmailGroupId (..), + EmailGroupRecipient (..), + EmailGroup (..), + EmailGroupResponse (..), + DeleteEmailGroupResponse (..), + + -- * Email account search (POST /_plugins/_alerting/destinations/email_accounts/_search) + EmailAccountSearchQuery (..), + defaultEmailAccountSearchQuery, + EmailAccountSearchHit (..), + SearchEmailAccountsResponse (..), + + -- * Email group search (POST /_plugins/_alerting/destinations/email_groups/_search) + EmailGroupSearchQuery (..), + defaultEmailGroupSearchQuery, + EmailGroupSearchHit (..), + SearchEmailGroupsResponse (..), + + -- * Findings search (GET /_plugins/_alerting/findings/_search) + FindingsSearchOptions (..), + defaultFindingsSearchOptions, + findingsSearchOptionsParams, + SearchFindingsResponse (..), + + -- * Comments API (POST/PUT/GET/DELETE /_plugins/_alerting/comments[/{id}]) + CommentId (..), + Comment (..), + CreateCommentRequest (..), + UpdateCommentRequest (..), + CommentResponse (..), + CommentSearchQuery (..), + defaultCommentSearchQuery, + CommentSearchHit (..), + SearchCommentsResponse (..), + DeleteCommentResponse (..), + + -- * Internal helpers (re-exported for the test suite) + alertingTriggerWrapperKeys, + ) +where + +import Data.Aeson +import Data.Aeson.Key qualified as K (fromText) +import Data.Aeson.KeyMap qualified as KM +import Data.Int (Int64) +import Database.Bloodhound.Internal.Utils.Imports +import Numeric.Natural (Natural) + +-- $schema +-- +-- The Alerting plugin (see +-- ) +-- runs scheduled monitors over cluster data and dispatches actions +-- (notifications) to destinations when trigger conditions fire. This +-- module covers the monitor lifecycle endpoints +-- (@POST \/\/_plugins\/_alerting\/monitors@ etc.) for OpenSearch 3.x. +-- +-- The wire shape of a 'Monitor' is a discriminated object: the +-- @monitor_type@ field selects one of several execution models +-- (query-level, bucket-level, document-level, cluster-metrics, remote), +-- and the @inputs@ and @triggers@ arrays carry per-kind payloads whose +-- exact shape varies widely. Following the pragmatic precedent set by +-- the ML Commons @predict@ endpoint, this module types the /shell/ — +-- the stable fields common to every monitor (name, enabled, schedule, +-- trigger names\/severities, action destination ids) — and models the +-- per-kind payloads as opaque aeson 'Value's. This keeps the public +-- surface small and stable while letting callers construct and inspect +-- any monitor kind, including ones the docs page does not enumerate. +-- Unknown top-level keys are preserved verbatim in 'monitorOther' so +-- future plugin additions and the @ui_metadata@\/@metadata@ fields +-- round-trip cleanly. +-- +-- The three response wrappers are modelled distinctly because they are +-- distinct on the wire: +-- +-- * 'MonitorResponse' wraps the create\/update response +-- (@{_id,_version,_seq_no,_primary_term, monitor:{...}}@). +-- * A bare 'Monitor' is the get-monitor response body (the @monitor@ +-- field is unwrapped by the 'FromJSON' instance of the endpoint +-- wrapper — see 'getMonitor'). +-- * 'DeleteMonitorResponse' mirrors the standard Elasticsearch +-- delete-document response. It deliberately deviates from the bead's +-- @m 'Acknowledged'@ acceptance (the endpoint returns @_shards@, not +-- @acknowledged@ — see the Haddock on 'DeleteMonitorResponse' and the +-- changelog entry for bloodhound-04f.6.7.4). +-- +-- Doc-level monitors were introduced in OpenSearch 2.0, so OS 1.x +-- callers must not construct 'MonitorTypeDocLevel'; the type still +-- carries the constructor because the wire grammar is identical. + +-- | The server-assigned identifier of a monitor. Wraps 'Text' so it +-- round-trips as a bare JSON string but stays distinct from +-- 'Database.Bloodhound.Common.Types.IndexName' and friends at the type +-- level. +newtype MonitorId = MonitorId {unMonitorId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The server-assigned identifier of an alerting destination. Wraps +-- 'Text' so it round-trips as a bare JSON string but stays distinct +-- from 'MonitorId' and 'Database.Bloodhound.Common.Types.IndexName' at +-- the type level. Used by the update\/delete destination endpoints +-- (@PUT@\/@DELETE /_plugins/_alerting/destinations/{id}@). +newtype DestinationId = DestinationId {unDestinationId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The top-level @type@ field of a monitor document. Documented as the +-- constant @"monitor"@ for non-composite monitors (composite monitors +-- use @"workflow"@ and live behind a separate API not covered here). +-- Unknown values fall through to 'AlertTypeOther' rather than +-- parse-failing, because the field is informational on requests and the +-- server is the authority. +data AlertType + = AlertTypeMonitor + | AlertTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for an 'AlertType'. +alertTypeText :: AlertType -> Text +alertTypeText AlertTypeMonitor = "monitor" +alertTypeText (AlertTypeOther t) = t + +instance ToJSON AlertType where + toJSON = toJSON . alertTypeText + +instance FromJSON AlertType where + parseJSON = withText "AlertType" $ \case + "monitor" -> pure AlertTypeMonitor + other -> pure (AlertTypeOther other) + +-- | The @monitor_type@ discriminator selecting the monitor's execution +-- model. The three documented on the API page are given dedicated +-- constructors; @cluster_metrics@, @remote@, and any future kind fall +-- through to 'MonitorTypeOther'. 'monitorTypeText' round-trips every +-- constructor. +data MonitorType + = MonitorTypeQueryLevel + | MonitorTypeBucketLevel + | MonitorTypeDocLevel + | MonitorTypeClusterMetrics + | MonitorTypeRemote + | MonitorTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'MonitorType'. Values are the lower-snake forms +-- documented at +-- . +monitorTypeText :: MonitorType -> Text +monitorTypeText = \case + MonitorTypeQueryLevel -> "query_level_monitor" + MonitorTypeBucketLevel -> "bucket_level_monitor" + MonitorTypeDocLevel -> "doc_level_monitor" + MonitorTypeClusterMetrics -> "cluster_metrics_monitor" + MonitorTypeRemote -> "remote_monitor" + MonitorTypeOther t -> t + +instance ToJSON MonitorType where + toJSON = toJSON . monitorTypeText + +instance FromJSON MonitorType where + parseJSON = + withText "MonitorType" $ \t -> + pure $ + case t of + "query_level_monitor" -> MonitorTypeQueryLevel + "bucket_level_monitor" -> MonitorTypeBucketLevel + "doc_level_monitor" -> MonitorTypeDocLevel + "cluster_metrics_monitor" -> MonitorTypeClusterMetrics + "remote_monitor" -> MonitorTypeRemote + other -> MonitorTypeOther other + +-- | The @schedule@ sub-object. The API documents two variants +-- (@period {interval, unit}@ and @cron {expression, timezone}@); any +-- other shape (e.g. a future schedule kind) is preserved verbatim via +-- 'ScheduleOther' so a decode never drops user data. +data Schedule + = PeriodSchedule SchedulePeriod + | CronSchedule ScheduleCron + | OtherSchedule Value + deriving stock (Eq, Show) + +instance ToJSON Schedule where + toJSON = \case + PeriodSchedule p -> object ["period" .= p] + CronSchedule c -> object ["cron" .= c] + OtherSchedule v -> v + +instance FromJSON Schedule where + parseJSON = withObject "Schedule" $ \o -> + (PeriodSchedule <$> o .: "period") + <|> (CronSchedule <$> o .: "cron") + <|> pure (OtherSchedule (Object o)) + +-- | The @period@ schedule variant. @unit@ is an upper-case string such +-- as @"MINUTES"@; the docs only enumerate @MINUTES@ in examples, so the +-- field is typed as 'Text' (not a closed enum) to avoid a library +-- release when OpenSearch advertises another unit. +data SchedulePeriod = SchedulePeriod + { schedulePeriodInterval :: Int, + schedulePeriodUnit :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SchedulePeriod where + toJSON SchedulePeriod {..} = + object + [ "interval" .= schedulePeriodInterval, + "unit" .= schedulePeriodUnit + ] + +instance FromJSON SchedulePeriod where + parseJSON = withObject "SchedulePeriod" $ \o -> + SchedulePeriod + <$> o .: "interval" + <*> o .: "unit" + +-- | The @cron@ schedule variant. @expression@ is a cron expression, +-- @timezone@ is a Java @ZoneId@ (e.g. @"America/Los_Angeles"@). +data ScheduleCron = ScheduleCron + { scheduleCronExpression :: Text, + scheduleCronTimezone :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON ScheduleCron where + toJSON ScheduleCron {..} = + omitNulls + [ "expression" .= scheduleCronExpression, + "timezone" .= scheduleCronTimezone + ] + +instance FromJSON ScheduleCron where + parseJSON = withObject "ScheduleCron" $ \o -> + ScheduleCron + <$> o .: "expression" + <*> o .:? "timezone" + +-- | A single element of the @inputs@ array. The shape varies by monitor +-- kind (@search@ for query\/bucket-level, @doc_level_input@ for +-- document-level, @clusters@ for cluster-metrics, ...), so the payload +-- is kept as an opaque 'Value' and callers decode it with their own +-- kind-specific parser. This mirrors the ML Commons @predict@ precedent. +newtype MonitorInput = MonitorInput {unMonitorInput :: Value} + deriving stock (Eq, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A @message_template@ \/ @subject_template@ sub-object. The server +-- injects @"lang": "mustache"@ on responses even when the request omits +-- it; both directions round-trip here. +data MessageTemplate = MessageTemplate + { messageTemplateSource :: Text, + messageTemplateLang :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON MessageTemplate where + toJSON MessageTemplate {..} = + omitNulls + [ "source" .= messageTemplateSource, + "lang" .= messageTemplateLang + ] + +instance FromJSON MessageTemplate where + parseJSON = withObject "MessageTemplate" $ \o -> + MessageTemplate + <$> o .: "source" + <*> o .:? "lang" + +-- | A @throttle@ sub-object (@{value, unit}@). Present on every action +-- response regardless of the @throttle_enabled@ flag. +data Throttle = Throttle + { throttleValue :: Int, + throttleUnit :: Text + } + deriving stock (Eq, Show) + +instance ToJSON Throttle where + toJSON Throttle {..} = + object + [ "value" .= throttleValue, + "unit" .= throttleUnit + ] + +instance FromJSON Throttle where + parseJSON = withObject "Throttle" $ \o -> + Throttle + <$> o .: "value" + <*> o .: "unit" + +-- | A single action within a trigger. The typed fields are those +-- documented across every action shape; the @action_execution_policy@ +-- sub-object (whose @action_execution_scope@ varies between +-- @per_alert@\/@per_action@ and carries @actionable_alerts@ enums) is +-- kept as an opaque 'Value', as is any forward-compat key in +-- 'actionOther'. +data Action = Action + { actionName :: Text, + actionDestinationId :: Text, + actionMessageTemplate :: MessageTemplate, + actionSubjectTemplate :: Maybe MessageTemplate, + actionThrottleEnabled :: Maybe Bool, + actionThrottle :: Maybe Throttle, + actionExecutionPolicy :: Maybe Value, + actionOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON Action where + toJSON a = + case actionOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= actionName a, + "destination_id" .= actionDestinationId a, + "message_template" .= actionMessageTemplate a, + "subject_template" .= actionSubjectTemplate a, + "throttle_enabled" .= actionThrottleEnabled a, + "throttle" .= actionThrottle a, + "action_execution_policy" .= actionExecutionPolicy a + ] + +instance FromJSON Action where + parseJSON = withObject "Action" $ \o -> do + Action + <$> o .: "name" + <*> o .: "destination_id" + <*> o .: "message_template" + <*> o .:? "subject_template" + <*> o .:? "throttle_enabled" + <*> o .:? "throttle" + <*> o .:? "action_execution_policy" + <*> pure (Object o) + +-- | The set of wrapper keys the Alerting plugin uses to discriminate +-- non-query-level triggers inside the @triggers@ array. Query-level +-- triggers carry their fields directly on the element; bucket-level and +-- document-level triggers wrap them under exactly one of these keys. +-- Re-exported so the test suite can pin the set. +alertingTriggerWrapperKeys :: [Text] +alertingTriggerWrapperKeys = ["bucket_level_trigger", "document_level_trigger"] + +-- | A single trigger. The wire shape differs by monitor kind: query-level +-- triggers put the fields directly on the element, while bucket-level +-- and document-level triggers wrap them under a discriminator key (see +-- 'alertingTriggerWrapperKeys'). The 'FromJSON' instance transparently +-- descends into the wrapper when present, so the typed fields are +-- readable uniformly; the full original element (wrapper and all) is +-- preserved in 'triggerOther' so a round-trip encode is lossless. +-- +-- @triggerSeverity@ is a 'Text' rather than an 'Int' because the wire +-- emits a string-encoded integer (e.g. @"1"@); parsing it as a number +-- would silently drop real monitor documents. +-- +-- @triggerCondition@ is an opaque 'Value' because the condition body +-- varies by trigger kind (@script {source, lang}@ for query-level; +-- @buckets_path@ + @parent_bucket_path@ + @script@ for bucket-level). +data Trigger = Trigger + { triggerName :: Text, + triggerSeverity :: Text, + triggerCondition :: Value, + triggerActions :: [Action], + triggerOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON Trigger where + toJSON t = + case triggerOther t of + Object o + | (wrapperKey, Object body) : _ <- wrappedBodies o -> + -- Captured element carried a discriminator wrapper key + -- (bucket-level / document-level). Re-inject the typed fields + -- into the wrapper body so caller modifications survive a + -- round-trip, and keep the wrapper as the sole top-level key + -- (matching the wire shape). + Object (KM.insert wrapperKey (Object (mergeIgnoringNulls typed body)) (deleteSeveral [wrapperKey] o)) + | otherwise -> + -- Query-level trigger: fields live directly on the element. + -- Overlay the typed fields on the captured object. + Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= triggerName t, + "severity" .= triggerSeverity t, + "condition" .= triggerCondition t, + "actions" .= triggerActions t + ] + wrappedBodies o = + [ (wk, v) + | k <- alertingTriggerWrapperKeys, + let wk = K.fromText k, + Just v <- [KM.lookup wk o] + ] + +instance FromJSON Trigger where + parseJSON = withObject "Trigger" $ \o' -> do + let body = unwrapTrigger o' + Trigger + <$> body .: "name" + <*> body .: "severity" + <*> body .: "condition" + <*> body .:? "actions" .!= [] + <*> pure (Object o') + where + unwrapTrigger o = + case catMaybes (mapMaybeWrapper o) of + (inner : _) -> inner + [] -> o + mapMaybeWrapper o = + [ KM.lookup (K.fromText k) o >>= (\case Object ob -> Just ob; _ -> Nothing) + | k <- alertingTriggerWrapperKeys + ] + +-- | The top-level 'Monitor' document. Typed fields cover every key the +-- API documents on requests and responses; 'monitorOther' captures the +-- whole original object so @ui_metadata@, @metadata@, future plugin +-- keys, and any field this type does not yet model round-trip +-- losslessly (mirrors the 'PendingTask' precedent). +data Monitor = Monitor + { monitorName :: Text, + monitorType :: Maybe AlertType, + monitorMonitorType :: Maybe MonitorType, + monitorEnabled :: Maybe Bool, + monitorEnabledTime :: Maybe Int64, + monitorLastUpdateTime :: Maybe Int64, + monitorSchemaVersion :: Maybe Int, + monitorSchedule :: Schedule, + monitorInputs :: [MonitorInput], + monitorTriggers :: [Trigger], + monitorUser :: Maybe Value, + monitorRbacRoles :: Maybe [Text], + monitorOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON Monitor where + toJSON m = + case monitorOther m of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= monitorName m, + "type" .= monitorType m, + "monitor_type" .= monitorMonitorType m, + "enabled" .= monitorEnabled m, + "enabled_time" .= monitorEnabledTime m, + "last_update_time" .= monitorLastUpdateTime m, + "schema_version" .= monitorSchemaVersion m, + "schedule" .= monitorSchedule m, + "inputs" .= monitorInputs m, + "triggers" .= monitorTriggers m, + "user" .= monitorUser m, + "rbac_roles" .= monitorRbacRoles m + ] + +instance FromJSON Monitor where + parseJSON = withObject "Monitor" $ \o -> + Monitor + <$> o .: "name" + <*> o .:? "type" + <*> o .:? "monitor_type" + <*> o .:? "enabled" + <*> o .:? "enabled_time" + <*> o .:? "last_update_time" + <*> o .:? "schema_version" + <*> o .: "schedule" + <*> o .:? "inputs" .!= [] + <*> o .:? "triggers" .!= [] + <*> o .:? "user" + <*> o .:? "rbac_roles" + <*> pure (Object o) + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/monitors[\/{id}]@. Carries the indexing metadata +-- alongside the persisted monitor document. +data MonitorResponse = MonitorResponse + { monitorResponseId :: Text, + monitorResponseVersion :: Int64, + monitorResponseSeqNo :: Int64, + monitorResponsePrimaryTerm :: Int64, + monitorResponseMonitor :: Monitor + } + deriving stock (Eq, Show) + +instance FromJSON MonitorResponse where + parseJSON = withObject "MonitorResponse" $ \o -> + MonitorResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "monitor" + +instance ToJSON MonitorResponse where + toJSON MonitorResponse {..} = + object + [ "_id" .= monitorResponseId, + "_version" .= monitorResponseVersion, + "_seq_no" .= monitorResponseSeqNo, + "_primary_term" .= monitorResponsePrimaryTerm, + "monitor" .= monitorResponseMonitor + ] + +-- | The @_shards@ sub-object of 'DeleteMonitorResponse'. Modelled +-- locally rather than reusing +-- "Database.Bloodhound.Internal.Versions.Common.Types.Nodes".'ShardsResult' +-- because that type wraps the outer @{"_shards": {...}}@ envelope (one +-- level too high for inline use here), and keeping the local shape +-- avoids widening the export surface of the Common types for this +-- single-purpose borrow. +data AlertingShards = AlertingShards + { alertingShardsTotal :: Int, + alertingShardsSuccessful :: Int, + alertingShardsSkipped :: Int, + alertingShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON AlertingShards where + parseJSON = withObject "AlertingShards" $ \o -> + AlertingShards + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "skipped" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON AlertingShards where + toJSON AlertingShards {..} = + object + [ "total" .= alertingShardsTotal, + "successful" .= alertingShardsSuccessful, + "skipped" .= alertingShardsSkipped, + "failed" .= alertingShardsFailed + ] + +-- | Response shape for @DELETE /_plugins/_alerting/monitors/{id}@. +-- +-- Deviates from the bead's @m 'Acknowledged'@ acceptance: the body +-- never carries an @acknowledged@ key, so an 'Acknowledged' decoder +-- would raise 'EsProtocolException' at runtime (same deviation pattern +-- as bloodhound-04f.3.13 rethrottle). +-- +-- The exact shape is version-dependent (live-verified in bead +-- bloodhound-z5j on OS 1.3.19, 2.19.5 and 3.7.0): +-- +-- * OS 1.3.x returns the full bare Elasticsearch delete-document +-- response — @_index@, @_type@, @_id@, @_version@, @result@, +-- @forced_refresh@, @_shards@, @_seq_no@, @_primary_term@. +-- * OS 2.x and 3.x return a minimal @_id@ + @_version@ envelope; the +-- indexing-metadata fields (@_index@, @result@, @_shards@, +-- @_seq_no@, ...) are omitted entirely. +-- +-- Only @_id@ and @_version@ are present on every version, so they are +-- the sole required fields; the rest are 'Maybe' and decode as +-- 'Nothing' on OS 2.x\/3.x. +data DeleteMonitorResponse = DeleteMonitorResponse + { deleteMonitorResponseId :: Text, + deleteMonitorResponseVersion :: Int64, + deleteMonitorResponseIndex :: Maybe Text, + deleteMonitorResponseResult :: Maybe Text, + deleteMonitorResponseForcedRefresh :: Maybe Bool, + deleteMonitorResponseShards :: Maybe AlertingShards, + deleteMonitorResponseSeqNo :: Maybe Int64, + deleteMonitorResponsePrimaryTerm :: Maybe Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteMonitorResponse where + parseJSON = withObject "DeleteMonitorResponse" $ \o -> + DeleteMonitorResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .:? "_index" + <*> o .:? "result" + <*> o .:? "forced_refresh" + <*> o .:? "_shards" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + +instance ToJSON DeleteMonitorResponse where + toJSON DeleteMonitorResponse {..} = + omitNulls + [ "_id" .= deleteMonitorResponseId, + "_version" .= deleteMonitorResponseVersion, + "_index" .= deleteMonitorResponseIndex, + "result" .= deleteMonitorResponseResult, + "forced_refresh" .= deleteMonitorResponseForcedRefresh, + "_shards" .= deleteMonitorResponseShards, + "_seq_no" .= deleteMonitorResponseSeqNo, + "_primary_term" .= deleteMonitorResponsePrimaryTerm + ] + +-- ========================================================================= +-- Destinations: GET /_plugins/_alerting/destinations +-- ========================================================================= +-- +-- The Alerting plugin's destinations API is the legacy notification +-- surface that pre-dates the Notifications plugin (covered separately +-- in "OpenSearchN.Types.Notifications"). A destination is a typed +-- notification target: a Slack incoming webhook, a Chime webhook, a +-- custom webhook, or an email account. Monitors reference destinations +-- by id via the @destination_id@ field on each 'Action'. The +-- @GET /_plugins/_alerting/destinations@ endpoint lists configured +-- destinations; the OpenSearch docs +-- () +-- document the wire shape. +-- +-- The destination record follows the same pragmatic pattern used by +-- 'Monitor' in this module: typed shell for the stable, common fields +-- (@id@, @type@, @name@, @schema_version@, @seq_no@, @primary_term@, +-- @last_update_time@, optional @user@) plus an opaque aeson 'Value' for +-- the per-type sub-object (the @slack@ \/ @chime@ \/ @custom_webhook@ +-- \/ @email@ key whose name matches the @type@ discriminator). The +-- shape of that sub-object varies by type and the docs do not fully +-- enumerate every variant, so it is kept opaque; callers decode it +-- with their own type-specific parser. The full original object is +-- captured in 'destinationOther' so unknown top-level keys round-trip +-- losslessly (same approach as 'monitorOther'). + +-- | The @type@ discriminator of a destination. The five values +-- enumerated by the @DestinationType@ enum in the plugin source are +-- given dedicated constructors; any future value falls through to +-- 'DestinationTypeOther' rather than parse-failing, because the field +-- is informational on requests and the server is the authority. +data DestinationType + = DestinationTypeSlack + | DestinationTypeChime + | DestinationTypeCustomWebhook + | DestinationTypeEmail + | DestinationTypeTestAction + | DestinationTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'DestinationType'. +destinationTypeText :: DestinationType -> Text +destinationTypeText = \case + DestinationTypeSlack -> "slack" + DestinationTypeChime -> "chime" + DestinationTypeCustomWebhook -> "custom_webhook" + DestinationTypeEmail -> "email" + DestinationTypeTestAction -> "test_action" + DestinationTypeOther t -> t + +instance ToJSON DestinationType where + toJSON = toJSON . destinationTypeText + +instance FromJSON DestinationType where + parseJSON = withText "DestinationType" $ \t -> + pure $ + case t of + "slack" -> DestinationTypeSlack + "chime" -> DestinationTypeChime + "custom_webhook" -> DestinationTypeCustomWebhook + "email" -> DestinationTypeEmail + "test_action" -> DestinationTypeTestAction + other -> DestinationTypeOther other + +-- | A single destination record returned by +-- @GET /_plugins/_alerting/destinations@. The typed fields cover every +-- key the API documents on responses; 'destinationBody' carries the +-- per-type sub-object keyed by 'destinationTypeText' (so +-- 'DestinationTypeSlack' implies a @slack@ sub-object, +-- 'DestinationTypeEmail' implies an @email@ sub-object, etc.). The +-- @test_action@ type carries no sub-object; its 'destinationBody' is +-- 'Null' on decode and omitted on encode. 'destinationOther' captures +-- the whole original object so any forward-compat top-level key +-- round-trips losslessly (mirrors the 'monitorOther' precedent). +data Destination = Destination + { destinationId :: Text, + destinationType :: DestinationType, + destinationName :: Text, + destinationSchemaVersion :: Int, + destinationSeqNo :: Int64, + destinationPrimaryTerm :: Int64, + destinationLastUpdateTime :: Maybe Int64, + destinationUser :: Maybe Value, + destinationBody :: Value, + destinationOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON Destination where + parseJSON = withObject "Destination" $ \o -> do + destinationId <- o .: "id" + destinationType <- o .: "type" + destinationName <- o .: "name" + destinationSchemaVersion <- o .:? "schema_version" .!= 0 + destinationSeqNo <- o .:? "seq_no" .!= 0 + destinationPrimaryTerm <- o .:? "primary_term" .!= 0 + destinationLastUpdateTime <- o .:? "last_update_time" + destinationUser <- o .:? "user" + let typeKey = K.fromText (destinationTypeText destinationType) + destinationBody = maybe Null id (KM.lookup typeKey o) + pure Destination {destinationOther = Object o, ..} + +instance ToJSON Destination where + toJSON d = + case destinationOther d of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= destinationId d, + "type" .= destinationType d, + "name" .= destinationName d, + "schema_version" .= destinationSchemaVersion d, + "seq_no" .= destinationSeqNo d, + "primary_term" .= destinationPrimaryTerm d, + "last_update_time" .= destinationLastUpdateTime d, + "user" .= destinationUser d, + K.fromText (destinationTypeText (destinationType d)) .= destinationBody d + ] + +-- | Sort direction for @GET /_plugins/_alerting/destinations@. The +-- plugin docs only document @"asc"@ and @"desc"@. +data DestinationSortOrder + = DestinationSortOrderAsc + | DestinationSortOrderDesc + deriving stock (Eq, Show) + +-- | Wire string for a 'DestinationSortOrder'. +destinationSortOrderText :: DestinationSortOrder -> Text +destinationSortOrderText = \case + DestinationSortOrderAsc -> "asc" + DestinationSortOrderDesc -> "desc" + +-- | Query-string parameters accepted by +-- @GET /_plugins/_alerting/destinations@. Every field is optional; +-- 'defaultDestinationListOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. The server-side defaults when the +-- parameter is omitted are: @size=20@, @start_index=0@, +-- @sortString=destination.name.keyword@, @sortOrder=asc@, +-- @missing=null@, @searchString=""@, @destinationType=ALL@. +data DestinationListOptions = DestinationListOptions + { destinationListOptionsSize :: Maybe Natural, + destinationListOptionsStartIndex :: Maybe Natural, + destinationListOptionsSortString :: Maybe Text, + destinationListOptionsSortOrder :: Maybe DestinationSortOrder, + destinationListOptionsMissing :: Maybe Text, + destinationListOptionsSearchString :: Maybe Text, + destinationListOptionsDestinationType :: Maybe DestinationType + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the +-- plain @GET /_plugins/_alerting/destinations@ (server defaults apply) +-- when passed to 'getDestinationsWith'. +defaultDestinationListOptions :: DestinationListOptions +defaultDestinationListOptions = + DestinationListOptions + { destinationListOptionsSize = Nothing, + destinationListOptionsStartIndex = Nothing, + destinationListOptionsSortString = Nothing, + destinationListOptionsSortOrder = Nothing, + destinationListOptionsMissing = Nothing, + destinationListOptionsSearchString = Nothing, + destinationListOptionsDestinationType = Nothing + } + +-- | Render a 'DestinationListOptions' to the query-string pairs +-- accepted by the GET endpoint. Fields set to 'Nothing' are omitted +-- (not rendered with an empty value). The parameter names are +-- camelCase, matching the alerting plugin's @RestGetDestinationsAction@ +-- (note: the Notifications plugin uses snake_case for its sibling +-- parameters — these are distinct plugin surfaces and the casings +-- genuinely differ on the wire). +destinationListOptionsParams :: DestinationListOptions -> [(Text, Maybe Text)] +destinationListOptionsParams DestinationListOptions {..} = + catMaybes + [ (("size",) . Just . tshow) <$> destinationListOptionsSize, + (("start_index",) . Just . tshow) <$> destinationListOptionsStartIndex, + (("sortString",) . Just) <$> destinationListOptionsSortString, + (("sortOrder",) . Just . destinationSortOrderText) <$> destinationListOptionsSortOrder, + (("missing",) . Just) <$> destinationListOptionsMissing, + (("searchString",) . Just) <$> destinationListOptionsSearchString, + (("destinationType",) . Just . destinationTypeText) <$> destinationListOptionsDestinationType + ] + +-- | Envelope returned by @GET /_plugins/_alerting/destinations@. +-- @totalDestinations@ is the total hit count matching the query (not +-- the size of @destinations@, which is the current page constrained by +-- the @size@ \/ @start_index@ parameters); @destinations@ is the +-- current page of records. The paging metadata is decoded for +-- completeness but discarded by the public 'getDestinations' wrapper, +-- which returns only the @destinations@ list. +data GetDestinationsResponse = GetDestinationsResponse + { getDestinationsResponseTotalDestinations :: Int, + getDestinationsResponseDestinations :: [Destination] + } + deriving stock (Eq, Show) + +instance FromJSON GetDestinationsResponse where + parseJSON = withObject "GetDestinationsResponse" $ \o -> do + getDestinationsResponseTotalDestinations <- o .:? "totalDestinations" .!= 0 + getDestinationsResponseDestinations <- o .:? "destinations" .!= [] + pure GetDestinationsResponse {..} + +instance ToJSON GetDestinationsResponse where + toJSON GetDestinationsResponse {..} = + object + [ "totalDestinations" .= getDestinationsResponseTotalDestinations, + "destinations" .= getDestinationsResponseDestinations + ] + +-- ========================================================================= +-- Monitor search: POST /_plugins/_alerting/monitors/_search +-- ========================================================================= +-- +-- The Alerting plugin exposes the monitor store as a regular +-- OpenSearch index (@.opendistro-allocator-config@ \/ +-- @.opensearch-scheduled-jobs@, depending on version), so the search +-- endpoint takes the standard OpenSearch query DSL and returns the +-- standard search envelope. The 'MonitorsSearchQuery' body mirrors the +-- 'SARulesQuery' shape (opaque @query@ DSL plus @from@ \/ @size@ +-- pagination); the 'SearchMonitorsResponse' envelope mirrors +-- 'SARulesSearchResponse'. Each hit's @_source@ is a bare 'Monitor' +-- (the indexed document source — no @monitor@ wrapper, unlike the +-- create\/update response). + +-- | Optional query body for 'searchMonitors'. The @from@ \/ @size@ +-- pair is the standard OpenSearch pagination cursor; @query@ is the +-- standard OpenSearch query DSL, kept opaque because its shape varies +-- by use case (term match on @monitor.name@, range on +-- @enabled_time@, ...). Pass 'Nothing' to 'searchMonitors' (or +-- 'defaultMonitorsSearchQuery' to the body renderer) for the plain +-- empty-body @{}@ POST that returns the first page of all monitors. +data MonitorsSearchQuery = MonitorsSearchQuery + { monitorsSearchQueryFrom :: Maybe Int, + monitorsSearchQuerySize :: Maybe Int, + monitorsSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultMonitorsSearchQuery :: MonitorsSearchQuery +defaultMonitorsSearchQuery = MonitorsSearchQuery Nothing Nothing Nothing + +instance ToJSON MonitorsSearchQuery where + toJSON MonitorsSearchQuery {..} = + omitNulls + [ "from" .= monitorsSearchQueryFrom, + "size" .= monitorsSearchQuerySize, + "query" .= monitorsSearchQueryQuery + ] + +instance FromJSON MonitorsSearchQuery where + parseJSON = withObject "MonitorsSearchQuery" $ \o -> + MonitorsSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "query" + +-- | The @hits.total.relation@ discriminator on a monitor search +-- response. OpenSearch documents @"eq"@ (exact count) and @"ge"@ +-- (lower bound, when @track_total_hits@ is false); any future value +-- falls through to 'MonitorsTotalRelationOther' rather than +-- parse-failing. +data MonitorsTotalRelation + = MonitorsTotalRelationEq + | MonitorsTotalRelationGe + | MonitorsTotalRelationOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'MonitorsTotalRelation'. +monitorsTotalRelationText :: MonitorsTotalRelation -> Text +monitorsTotalRelationText = \case + MonitorsTotalRelationEq -> "eq" + MonitorsTotalRelationGe -> "ge" + MonitorsTotalRelationOther t -> t + +instance ToJSON MonitorsTotalRelation where + toJSON = toJSON . monitorsTotalRelationText + +instance FromJSON MonitorsTotalRelation where + parseJSON = withText "MonitorsTotalRelation" $ \t -> + pure $ + case t of + "eq" -> MonitorsTotalRelationEq + "ge" -> MonitorsTotalRelationGe + other -> MonitorsTotalRelationOther other + +-- | The @hits.total@ sub-object on a monitor search response +-- (@{value, relation}@). +data MonitorsTotal = MonitorsTotal + { monitorsTotalValue :: Int64, + monitorsTotalRelation :: MonitorsTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON MonitorsTotal where + parseJSON = withObject "MonitorsTotal" $ \o -> + MonitorsTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON MonitorsTotal where + toJSON MonitorsTotal {..} = + object + [ "value" .= monitorsTotalValue, + "relation" .= monitorsTotalRelation + ] + +-- | A single hit in @hits.hits[]@ on a monitor search response. The +-- typed fields mirror the standard search-hit envelope; the @_source@ +-- is decoded as a bare 'Monitor' (the indexed document source). +data MonitorHit = MonitorHit + { monitorHitIndex :: Maybe Text, + monitorHitId :: Text, + monitorHitVersion :: Maybe Int64, + monitorHitSeqNo :: Maybe Int64, + monitorHitPrimaryTerm :: Maybe Int64, + monitorHitScore :: Maybe Double, + monitorHitSource :: Monitor + } + deriving stock (Eq, Show) + +instance FromJSON MonitorHit where + parseJSON = withObject "MonitorHit" $ \o -> + MonitorHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON MonitorHit where + toJSON MonitorHit {..} = + omitNulls + [ "_index" .= monitorHitIndex, + "_id" .= monitorHitId, + "_version" .= monitorHitVersion, + "_seq_no" .= monitorHitSeqNo, + "_primary_term" .= monitorHitPrimaryTerm, + "_score" .= monitorHitScore, + "_source" .= monitorHitSource + ] + +-- | Response envelope for 'searchMonitors'. Decoded verbatim from the +-- standard OpenSearch search-response shape; the paging metadata +-- (@took@, @timed_out@, @_shards@, @hits.total@, @hits.max_score@) is +-- preserved alongside the monitor list so callers can drive pagination +-- and observe shard health. The @_shards@ sub-object reuses the local +-- 'AlertingShards' (the standard @{total,successful,skipped,failed}@ +-- shape already modelled for 'DeleteMonitorResponse'). +data SearchMonitorsResponse = SearchMonitorsResponse + { searchMonitorsResponseTook :: Int64, + searchMonitorsResponseTimedOut :: Bool, + searchMonitorsResponseShards :: AlertingShards, + searchMonitorsResponseTotal :: MonitorsTotal, + searchMonitorsResponseMaxScore :: Maybe Double, + searchMonitorsResponseHits :: [MonitorHit] + } + deriving stock (Eq, Show) + +instance FromJSON SearchMonitorsResponse where + parseJSON = withObject "SearchMonitorsResponse" $ \o -> do + hits <- o .: "hits" + SearchMonitorsResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SearchMonitorsResponse where + toJSON SearchMonitorsResponse {..} = + object + [ "took" .= searchMonitorsResponseTook, + "timed_out" .= searchMonitorsResponseTimedOut, + "_shards" .= searchMonitorsResponseShards, + "hits" + .= object + [ "total" .= searchMonitorsResponseTotal, + "max_score" .= searchMonitorsResponseMaxScore, + "hits" .= searchMonitorsResponseHits + ] + ] + +-- | Project the decoded 'Monitor' list out of a 'SearchMonitorsResponse' +-- (convenience for callers who only want the monitors and not the +-- paging envelope). +searchMonitorsResponseMonitors :: SearchMonitorsResponse -> [Monitor] +searchMonitorsResponseMonitors = map monitorHitSource . searchMonitorsResponseHits + +-- ========================================================================= +-- Execute monitor: POST /_plugins/_alerting/monitors/{id}/_execute +-- ========================================================================= +-- +-- The execute endpoint runs a monitor's inputs and triggers immediately +-- (out of schedule) and returns the per-trigger execution result. The +-- response shape varies widely by monitor kind (@trigger_results@ is a +-- map keyed by trigger name whose value differs for query-level, +-- bucket-level, and document-level triggers; @input_results@ carries +-- the search response the monitor ran against). Following the ML +-- Commons @predict@ precedent, the stable shell fields +-- (@monitor_name@, @period_start@, @period_end@, @dry_run@) are typed +-- and the variable result sub-objects are kept as opaque aeson +-- 'Value's so any monitor kind round-trips losslessly. + +-- | Optional request parameters for 'executeMonitor'. @dryrun@ (default +-- 'False' on the server) skips dispatching actions to destinations; it +-- is sent as the @?dryrun=true@ query parameter (the @_execute@ +-- endpoint takes no request body). Pass 'Nothing' to 'executeMonitor' +-- (or 'defaultExecuteMonitorRequest') for a real execution with action +-- dispatch. +data ExecuteMonitorRequest = ExecuteMonitorRequest + { executeMonitorRequestDryrun :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | The empty request: a real execution with action dispatch (no +-- @?dryrun@ query parameter). +defaultExecuteMonitorRequest :: ExecuteMonitorRequest +defaultExecuteMonitorRequest = ExecuteMonitorRequest Nothing + +instance ToJSON ExecuteMonitorRequest where + toJSON ExecuteMonitorRequest {..} = + omitNulls ["dryrun" .= executeMonitorRequestDryrun] + +instance FromJSON ExecuteMonitorRequest where + parseJSON = withObject "ExecuteMonitorRequest" $ \o -> + ExecuteMonitorRequest <$> o .:? "dryrun" + +-- | Response shape for @POST /_plugins/_alerting/monitors/{id}/_execute@. +-- The typed shell carries the stable fields every execution result +-- shares; @trigger_results@, @input_results@, and @script_actions@ are +-- kept as opaque aeson 'Value's because their shape varies by monitor +-- kind and trigger type (mirrors the ML Commons @predict@ precedent). +-- The full original object is captured in 'executeMonitorResponseOther' +-- so any forward-compat key round-trips losslessly. +data ExecuteMonitorResponse = ExecuteMonitorResponse + { executeMonitorResponseMonitorName :: Maybe Text, + executeMonitorResponsePeriodStart :: Maybe Int64, + executeMonitorResponsePeriodEnd :: Maybe Int64, + executeMonitorResponseDryRun :: Maybe Bool, + executeMonitorResponseTriggerResults :: Maybe Value, + executeMonitorResponseInputResults :: Maybe Value, + executeMonitorResponseScriptActions :: Maybe Value, + executeMonitorResponseOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON ExecuteMonitorResponse where + parseJSON = withObject "ExecuteMonitorResponse" $ \o -> + ExecuteMonitorResponse + <$> o .:? "monitor_name" + <*> o .:? "period_start" + <*> o .:? "period_end" + <*> o .:? "dry_run" + <*> o .:? "trigger_results" + <*> o .:? "input_results" + <*> o .:? "script_actions" + <*> pure (Object o) + +instance ToJSON ExecuteMonitorResponse where + toJSON r = + case executeMonitorResponseOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "monitor_name" .= executeMonitorResponseMonitorName r, + "period_start" .= executeMonitorResponsePeriodStart r, + "period_end" .= executeMonitorResponsePeriodEnd r, + "dry_run" .= executeMonitorResponseDryRun r, + "trigger_results" .= executeMonitorResponseTriggerResults r, + "input_results" .= executeMonitorResponseInputResults r, + "script_actions" .= executeMonitorResponseScriptActions r + ] + +-- ========================================================================= +-- Destination lifecycle: POST/PUT/DELETE /_plugins/_alerting/destinations[/{id}] +-- ========================================================================= +-- +-- The create and update destination endpoints take a 'Destination' as +-- the request body (the server assigns @id@, @schema_version@, +-- @seq_no@, @primary_term@ on write) and return the +-- 'DestinationResponse' wrapper (@{_id,_version,_seq_no,_primary_term, +-- destination:{...}}@) — the destination analogue of 'MonitorResponse'. +-- The delete endpoint returns the standard Elasticsearch +-- delete-document response (bare, no @acknowledged@ key, with a +-- @_shards@ report), modelled distinctly as 'DeleteDestinationResponse' +-- for the same reason as 'DeleteMonitorResponse' (an 'Acknowledged' +-- decoder would raise 'EsProtocolException' at runtime). + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/destinations[/{id}]@. Carries the indexing +-- metadata alongside the persisted destination document. Mirrors +-- 'MonitorResponse'. +data DestinationResponse = DestinationResponse + { destinationResponseId :: Text, + destinationResponseVersion :: Int64, + destinationResponseSeqNo :: Int64, + destinationResponsePrimaryTerm :: Int64, + destinationResponseDestination :: Destination + } + deriving stock (Eq, Show) + +instance FromJSON DestinationResponse where + parseJSON = withObject "DestinationResponse" $ \o -> + DestinationResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "destination" + +instance ToJSON DestinationResponse where + toJSON DestinationResponse {..} = + object + [ "_id" .= destinationResponseId, + "_version" .= destinationResponseVersion, + "_seq_no" .= destinationResponseSeqNo, + "_primary_term" .= destinationResponsePrimaryTerm, + "destination" .= destinationResponseDestination + ] + +-- | Response shape for @DELETE /_plugins/_alerting/destinations/{id}@. +-- Wire-identical to 'DeleteMonitorResponse' (the standard Elasticsearch +-- delete-document response — bare, no destination echo, no +-- @acknowledged@ key, with a @_shards@ report) but modelled as a +-- distinct type so the public API reads correctly at call sites. +-- 'AlertingShards' is reused for the @_shards@ sub-object. +data DeleteDestinationResponse = DeleteDestinationResponse + { deleteDestinationResponseIndex :: Text, + deleteDestinationResponseId :: Text, + deleteDestinationResponseVersion :: Int64, + deleteDestinationResponseResult :: Text, + deleteDestinationResponseForcedRefresh :: Bool, + deleteDestinationResponseShards :: AlertingShards, + deleteDestinationResponseSeqNo :: Int64, + deleteDestinationResponsePrimaryTerm :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteDestinationResponse where + parseJSON = withObject "DeleteDestinationResponse" $ \o -> + DeleteDestinationResponse + <$> o .: "_index" + <*> o .: "_id" + <*> o .: "_version" + <*> o .: "result" + <*> o .:? "forced_refresh" .!= False + <*> o .: "_shards" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + +instance ToJSON DeleteDestinationResponse where + toJSON DeleteDestinationResponse {..} = + object + [ "_index" .= deleteDestinationResponseIndex, + "_id" .= deleteDestinationResponseId, + "_version" .= deleteDestinationResponseVersion, + "result" .= deleteDestinationResponseResult, + "forced_refresh" .= deleteDestinationResponseForcedRefresh, + "_shards" .= deleteDestinationResponseShards, + "_seq_no" .= deleteDestinationResponseSeqNo, + "_primary_term" .= deleteDestinationResponsePrimaryTerm + ] + +-- ========================================================================= +-- Get alerts: GET /_plugins/_alerting/monitors/alerts +-- ========================================================================= +-- +-- The get-alerts endpoint returns the active alert documents for the +-- whole cluster (optionally filtered by a rich set of query-string +-- parameters). An alert document carries a large, partly variable body +-- (@monitor_user@, @alert_history@, @action_execution_results@ sub-objects +-- whose shape tracks the monitor kind and action type). Following the +-- pragmatic precedent used by 'Monitor' and 'ExecuteMonitorResponse', +-- the stable shell fields are typed and the variable sub-objects are +-- kept as opaque aeson 'Value's (captured together in 'alertOther') so +-- any alert round-trips losslessly. The OpenSearch docs +-- () +-- document the wire shape. + +-- | Sort direction for @GET /_plugins/_alerting/monitors/alerts@. The +-- plugin documents only @"asc"@ and @"desc"@. Modelled as a distinct +-- type from 'DestinationSortOrder' so the call site reads correctly, +-- even though the wire values coincide. +data AlertSortOrder + = AlertSortOrderAsc + | AlertSortOrderDesc + deriving stock (Eq, Show) + +-- | Wire string for an 'AlertSortOrder'. +alertSortOrderText :: AlertSortOrder -> Text +alertSortOrderText = \case + AlertSortOrderAsc -> "asc" + AlertSortOrderDesc -> "desc" + +instance ToJSON AlertSortOrder where + toJSON = toJSON . alertSortOrderText + +-- | The @state@ field of an alert document, and the @alertState@ query +-- parameter. The four documented states are given dedicated +-- constructors; any future value falls through to 'AlertStateOther' +-- rather than parse-failing, because the server is the authority. +data AlertState + = AlertStateActive + | AlertStateCompleted + | AlertStateError + | AlertStateAcknowledged + | AlertStateOther Text + deriving stock (Eq, Show) + +-- | Wire string for an 'AlertState'. +alertStateText :: AlertState -> Text +alertStateText = \case + AlertStateActive -> "ACTIVE" + AlertStateCompleted -> "COMPLETED" + AlertStateError -> "ERROR" + AlertStateAcknowledged -> "ACKNOWLEDGED" + AlertStateOther t -> t + +instance ToJSON AlertState where + toJSON = toJSON . alertStateText + +instance FromJSON AlertState where + parseJSON = withText "AlertState" $ \t -> + pure $ + case t of + "ACTIVE" -> AlertStateActive + "COMPLETED" -> AlertStateCompleted + "ERROR" -> AlertStateError + "ACKNOWLEDGED" -> AlertStateAcknowledged + other -> AlertStateOther other + +-- | Query-string parameters accepted by +-- @GET /_plugins/_alerting/monitors/alerts@. Every field is optional; +-- 'defaultGetAlertsOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. The server-side defaults when a +-- parameter is omitted are: @size=20@, @startIndex=0@, +-- @sortString=monitor_name.keyword@, @sortOrder=asc@, +-- @searchString=""@, @severityLevel=ALL@, @alertState=ALL@. The +-- @severityLevel@ is kept as 'Text' because the wire values are +-- string-encoded severities (@\"1\"@..@\"4\"@) plus the literal +-- @\"ALL\"@, which is awkward to model as a closed enum. The +-- @workflowIds@ parameter is documented for OpenSearch 2.9+ (comma- +-- separated workflow ids for chained-alert dashboards); it is harmlessly +-- ignored by older servers, so it is exposed uniformly across OS1\/2\/3. +data GetAlertsOptions = GetAlertsOptions + { getAlertsOptionsSortString :: Maybe Text, + getAlertsOptionsSortOrder :: Maybe AlertSortOrder, + getAlertsOptionsMissing :: Maybe Text, + getAlertsOptionsSize :: Maybe Natural, + getAlertsOptionsStartIndex :: Maybe Natural, + getAlertsOptionsSearchString :: Maybe Text, + getAlertsOptionsSeverityLevel :: Maybe Text, + getAlertsOptionsAlertState :: Maybe AlertState, + getAlertsOptionsMonitorId :: Maybe Text, + getAlertsOptionsWorkflowIds :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the plain +-- @GET /_plugins/_alerting/monitors/alerts@ (server defaults apply) when +-- passed to 'getAlertsWith'. +defaultGetAlertsOptions :: GetAlertsOptions +defaultGetAlertsOptions = + GetAlertsOptions + { getAlertsOptionsSortString = Nothing, + getAlertsOptionsSortOrder = Nothing, + getAlertsOptionsMissing = Nothing, + getAlertsOptionsSize = Nothing, + getAlertsOptionsStartIndex = Nothing, + getAlertsOptionsSearchString = Nothing, + getAlertsOptionsSeverityLevel = Nothing, + getAlertsOptionsAlertState = Nothing, + getAlertsOptionsMonitorId = Nothing, + getAlertsOptionsWorkflowIds = Nothing + } + +-- | Render a 'GetAlertsOptions' to the query-string pairs accepted by +-- the get-alerts endpoint. Fields set to 'Nothing' are omitted (not +-- rendered with an empty value). The parameter names are camelCase, +-- matching the alerting plugin's @RestGetAlertsAction@ (note: +-- @startIndex@ is camelCase here, whereas the destinations GET uses +-- snake_case @start_index@ — these are distinct plugin routes and the +-- casings genuinely differ on the wire). +getAlertsOptionsParams :: GetAlertsOptions -> [(Text, Maybe Text)] +getAlertsOptionsParams GetAlertsOptions {..} = + catMaybes + [ ("sortString",) . Just <$> getAlertsOptionsSortString, + ("sortOrder",) . Just . alertSortOrderText <$> getAlertsOptionsSortOrder, + ("missing",) . Just <$> getAlertsOptionsMissing, + ("size",) . Just . tshow <$> getAlertsOptionsSize, + ("startIndex",) . Just . tshow <$> getAlertsOptionsStartIndex, + ("searchString",) . Just <$> getAlertsOptionsSearchString, + ("severityLevel",) . Just <$> getAlertsOptionsSeverityLevel, + ("alertState",) . Just . alertStateText <$> getAlertsOptionsAlertState, + ("monitorId",) . Just <$> getAlertsOptionsMonitorId, + ("workflowIds",) . Just <$> getAlertsOptionsWorkflowIds + ] + +-- | A single alert document returned by +-- @GET /_plugins/_alerting/monitors/alerts@. The typed shell covers the +-- stable fields every alert shares; @monitor_user@, @alert_history@, and +-- @action_execution_results@ are kept as opaque aeson 'Value's (captured +-- in 'alertOther') because their shape varies by monitor kind and action +-- type. @alertSeverity@ is a 'Text' rather than an 'Int' because the +-- wire emits a string-encoded integer (e.g. @\"1\"@) — the same +-- deviation from the docs as 'triggerSeverity'. The full original +-- object is captured in 'alertOther' so any forward-compat key +-- round-trips losslessly (mirrors the 'monitorOther' precedent). +data Alert = Alert + { alertId :: Text, + alertVersion :: Int64, + alertMonitorId :: Text, + alertSchemaVersion :: Maybe Int, + alertMonitorVersion :: Maybe Int64, + alertMonitorName :: Text, + alertTriggerId :: Text, + alertTriggerName :: Text, + alertState :: AlertState, + alertSeverity :: Text, + alertErrorMessage :: Maybe Text, + alertStartTime :: Maybe Int64, + alertLastNotificationTime :: Maybe Int64, + alertEndTime :: Maybe Int64, + alertAcknowledgedTime :: Maybe Int64, + alertOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON Alert where + parseJSON = withObject "Alert" $ \o -> + Alert + <$> o .: "id" + <*> o .:? "version" .!= 0 + <*> o .: "monitor_id" + <*> o .:? "schema_version" + <*> o .:? "monitor_version" + <*> o .: "monitor_name" + <*> o .: "trigger_id" + <*> o .: "trigger_name" + <*> o .:? "state" .!= AlertStateOther "" + <*> o .:? "severity" .!= "" + <*> o .:? "error_message" + <*> o .:? "start_time" + <*> o .:? "last_notification_time" + <*> o .:? "end_time" + <*> o .:? "acknowledged_time" + <*> pure (Object o) + +instance ToJSON Alert where + toJSON a = + case alertOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= alertId a, + "version" .= alertVersion a, + "monitor_id" .= alertMonitorId a, + "schema_version" .= alertSchemaVersion a, + "monitor_version" .= alertMonitorVersion a, + "monitor_name" .= alertMonitorName a, + "trigger_id" .= alertTriggerId a, + "trigger_name" .= alertTriggerName a, + "state" .= alertState a, + "severity" .= alertSeverity a, + "error_message" .= alertErrorMessage a, + "start_time" .= alertStartTime a, + "last_notification_time" .= alertLastNotificationTime a, + "end_time" .= alertEndTime a, + "acknowledged_time" .= alertAcknowledgedTime a + ] + +-- | Envelope returned by @GET /_plugins/_alerting/monitors/alerts@. +-- @totalAlerts@ is the total hit count matching the query (not the size +-- of @alerts@, which is the current page constrained by the @size@ \/ +-- @startIndex@ parameters); @alerts@ is the current page of records. +data GetAlertsResponse = GetAlertsResponse + { getAlertsResponseAlerts :: [Alert], + getAlertsResponseTotalAlerts :: Int + } + deriving stock (Eq, Show) + +instance FromJSON GetAlertsResponse where + parseJSON = withObject "GetAlertsResponse" $ \o -> do + getAlertsResponseAlerts <- o .:? "alerts" .!= [] + getAlertsResponseTotalAlerts <- o .:? "totalAlerts" .!= 0 + pure GetAlertsResponse {..} + +instance ToJSON GetAlertsResponse where + toJSON GetAlertsResponse {..} = + object + [ "alerts" .= getAlertsResponseAlerts, + "totalAlerts" .= getAlertsResponseTotalAlerts + ] + +-- ========================================================================= +-- Acknowledge alert: POST /_plugins/_alerting/monitors/{id}/_acknowledge/alerts +-- ========================================================================= +-- +-- The acknowledge endpoint takes a list of alert ids (belonging to the +-- monitor in the path) and flips each to the @ACKNOWLEDGED@ state. Alerts +-- already in an @ERROR@, @COMPLETED@, or @ACKNOWLEDGED@ state are not +-- transitioned and are echoed back in the @failed@ array. See +-- . + +-- | Request body for 'acknowledgeAlert'. @alerts@ is the list of alert +-- ids to acknowledge. 'defaultAcknowledgeAlertRequest' renders to the +-- empty-list body @{"alerts":[]}@. +newtype AcknowledgeAlertRequest = AcknowledgeAlertRequest + { acknowledgeAlertRequestAlerts :: [Text] + } + deriving stock (Eq, Show) + +defaultAcknowledgeAlertRequest :: AcknowledgeAlertRequest +defaultAcknowledgeAlertRequest = AcknowledgeAlertRequest [] + +instance ToJSON AcknowledgeAlertRequest where + toJSON AcknowledgeAlertRequest {..} = + object ["alerts" .= acknowledgeAlertRequestAlerts] + +instance FromJSON AcknowledgeAlertRequest where + parseJSON = withObject "AcknowledgeAlertRequest" $ \o -> + AcknowledgeAlertRequest + <$> o .:? "alerts" .!= [] + +-- | Response shape for +-- @POST /_plugins/_alerting/monitors/{id}/_acknowledge/alerts@. @success@ +-- lists the alert ids that were transitioned to @ACKNOWLEDGED@; @failed@ +-- lists the alert ids that were not (already in a terminal state). +data AcknowledgeAlertResponse = AcknowledgeAlertResponse + { acknowledgeAlertResponseSuccess :: [Text], + acknowledgeAlertResponseFailed :: [Text] + } + deriving stock (Eq, Show) + +instance FromJSON AcknowledgeAlertResponse where + parseJSON = withObject "AcknowledgeAlertResponse" $ \o -> do + acknowledgeAlertResponseSuccess <- o .:? "success" .!= [] + acknowledgeAlertResponseFailed <- o .:? "failed" .!= [] + pure AcknowledgeAlertResponse {..} + +instance ToJSON AcknowledgeAlertResponse where + toJSON AcknowledgeAlertResponse {..} = + object + [ "success" .= acknowledgeAlertResponseSuccess, + "failed" .= acknowledgeAlertResponseFailed + ] + +-- ========================================================================= +-- Monitor stats: GET /_plugins/_alerting/stats[/...] +-- ========================================================================= +-- +-- The stats endpoint returns node-level alerting scheduler metrics. The +-- response is a large, deeply-nested object: a stable shell +-- (@_nodes@ count, @cluster_name@, scheduled-job index health booleans, +-- @nodes_on_schedule@ \/ @nodes_not_on_schedule@ counts) wrapping a +-- @nodes@ map keyed by node id whose value carries per-node roles, +-- schedule status, job-scheduling metrics, and a per-job @jobs_info@ +-- map. The @nodes@ sub-object's shape grows across OpenSearch releases, +-- so following the pragmatic precedent used by +-- 'ExecuteMonitorResponse', the stable shell is typed and the variable +-- @nodes@ map (plus any forward-compat key) is kept as an opaque aeson +-- 'Value' in 'monitorStatsOther'. See +-- . + +-- | The @_nodes@ sub-object of 'MonitorStats' +-- (@{total, successful, failed}@). Modelled locally (rather than reusing +-- 'AlertingShards') because the stats @_nodes@ object carries no +-- @skipped@ field and the names describe cluster-node bookkeeping, not +-- shard execution. +data MonitorStatsNodesCount = MonitorStatsNodesCount + { monitorStatsNodesCountTotal :: Int, + monitorStatsNodesCountSuccessful :: Int, + monitorStatsNodesCountFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON MonitorStatsNodesCount where + parseJSON = withObject "MonitorStatsNodesCount" $ \o -> + MonitorStatsNodesCount + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON MonitorStatsNodesCount where + toJSON MonitorStatsNodesCount {..} = + object + [ "total" .= monitorStatsNodesCountTotal, + "successful" .= monitorStatsNodesCountSuccessful, + "failed" .= monitorStatsNodesCountFailed + ] + +-- | Response shape for @GET /_plugins/_alerting/stats[/...]@. The typed +-- shell carries the stable, cluster-level fields every stats response +-- shares; the deeply-nested @nodes@ map (and any forward-compat key) is +-- captured in 'monitorStatsOther' as an opaque aeson 'Value'. Note the +-- literal dotted key @plugins.scheduled_jobs.enabled@ on the wire. +data MonitorStats = MonitorStats + { monitorStatsNodes :: Maybe MonitorStatsNodesCount, + monitorStatsClusterName :: Maybe Text, + monitorStatsScheduledJobsEnabled :: Maybe Bool, + monitorStatsScheduledJobIndexExists :: Maybe Bool, + monitorStatsScheduledJobIndexStatus :: Maybe Text, + monitorStatsNodesOnSchedule :: Maybe Int, + monitorStatsNodesNotOnSchedule :: Maybe Int, + monitorStatsOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON MonitorStats where + parseJSON = withObject "MonitorStats" $ \o -> + MonitorStats + <$> o .:? "_nodes" + <*> o .:? "cluster_name" + <*> o .:? "plugins.scheduled_jobs.enabled" + <*> o .:? "scheduled_job_index_exists" + <*> o .:? "scheduled_job_index_status" + <*> o .:? "nodes_on_schedule" + <*> o .:? "nodes_not_on_schedule" + <*> pure (Object o) + +instance ToJSON MonitorStats where + toJSON s = + case monitorStatsOther s of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "_nodes" .= monitorStatsNodes s, + "cluster_name" .= monitorStatsClusterName s, + "plugins.scheduled_jobs.enabled" .= monitorStatsScheduledJobsEnabled s, + "scheduled_job_index_exists" .= monitorStatsScheduledJobIndexExists s, + "scheduled_job_index_status" .= monitorStatsScheduledJobIndexStatus s, + "nodes_on_schedule" .= monitorStatsNodesOnSchedule s, + "nodes_not_on_schedule" .= monitorStatsNodesNotOnSchedule s + ] + +-- ========================================================================= +-- Email account lifecycle: POST/PUT/GET/DELETE /_plugins/_alerting/destinations/email_accounts[/{id}] +-- ========================================================================= +-- +-- The legacy alerting email surface (predating the Notifications +-- plugin). An email account is an SMTP sender (host, port, method, +-- credentials) referenced by id from an email 'Destination'. The +-- create\/update endpoints take an 'EmailAccount' body and return the +-- 'EmailAccountResponse' wrapper +-- (@{_id,_version,_seq_no,_primary_term, email_account:{...}}@) — the +-- email-account analogue of 'MonitorResponse'. The delete endpoint +-- returns the standard Elasticsearch delete-document response (bare, no +-- @acknowledged@ key, with a @_shards@ report), modelled distinctly as +-- 'DeleteEmailAccountResponse'. See +-- . + +-- | The server-assigned identifier of an alerting email account. Wraps +-- 'Text' so it round-trips as a bare JSON string but stays distinct from +-- 'MonitorId' and 'DestinationId' at the type level. +newtype EmailAccountId = EmailAccountId {unEmailAccountId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | An SMTP sender account. @method@ is typed as 'Text' (the docs +-- enumerate @ssl@ \/ @none@ \/ @start_tls@ \/ @ssl_tls@ but the set is +-- not pinned in the plugin schema, so a closed enum would risk a +-- library release on the next addition — same reasoning as +-- 'schedulePeriodUnit'). The full original object is captured in +-- 'emailAccountOther' so any forward-compat key round-trips losslessly. +data EmailAccount = EmailAccount + { emailAccountName :: Text, + emailAccountEmail :: Text, + emailAccountHost :: Text, + emailAccountPort :: Int, + emailAccountMethod :: Text, + emailAccountSchemaVersion :: Maybe Int, + emailAccountOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailAccount where + parseJSON = withObject "EmailAccount" $ \o -> do + emailAccountName <- o .: "name" + emailAccountEmail <- o .: "email" + emailAccountHost <- o .: "host" + emailAccountPort <- o .:? "port" .!= 0 + emailAccountMethod <- o .:? "method" .!= "" + emailAccountSchemaVersion <- o .:? "schema_version" + pure EmailAccount {emailAccountOther = Object o, ..} + +instance ToJSON EmailAccount where + toJSON a = + case emailAccountOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= emailAccountName a, + "email" .= emailAccountEmail a, + "host" .= emailAccountHost a, + "port" .= emailAccountPort a, + "method" .= emailAccountMethod a, + "schema_version" .= emailAccountSchemaVersion a + ] + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/destinations/email_accounts[/{id}]@. Carries the +-- indexing metadata alongside the persisted email account. Mirrors +-- 'MonitorResponse' \/ 'DestinationResponse'. +data EmailAccountResponse = EmailAccountResponse + { emailAccountResponseId :: Text, + emailAccountResponseVersion :: Int64, + emailAccountResponseSeqNo :: Int64, + emailAccountResponsePrimaryTerm :: Int64, + emailAccountResponseEmailAccount :: EmailAccount + } + deriving stock (Eq, Show) + +instance FromJSON EmailAccountResponse where + parseJSON = withObject "EmailAccountResponse" $ \o -> + EmailAccountResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "email_account" + +instance ToJSON EmailAccountResponse where + toJSON EmailAccountResponse {..} = + object + [ "_id" .= emailAccountResponseId, + "_version" .= emailAccountResponseVersion, + "_seq_no" .= emailAccountResponseSeqNo, + "_primary_term" .= emailAccountResponsePrimaryTerm, + "email_account" .= emailAccountResponseEmailAccount + ] + +-- | Response shape for +-- @DELETE /_plugins/_alerting/destinations/email_accounts/{id}@. +-- Wire-identical to 'DeleteDestinationResponse' (the standard +-- Elasticsearch delete-document response) but modelled as a distinct +-- type so the public API reads correctly at call sites. 'AlertingShards' +-- is reused for the @_shards@ sub-object. +data DeleteEmailAccountResponse = DeleteEmailAccountResponse + { deleteEmailAccountResponseIndex :: Text, + deleteEmailAccountResponseId :: Text, + deleteEmailAccountResponseVersion :: Int64, + deleteEmailAccountResponseResult :: Text, + deleteEmailAccountResponseForcedRefresh :: Bool, + deleteEmailAccountResponseShards :: AlertingShards, + deleteEmailAccountResponseSeqNo :: Int64, + deleteEmailAccountResponsePrimaryTerm :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteEmailAccountResponse where + parseJSON = withObject "DeleteEmailAccountResponse" $ \o -> + DeleteEmailAccountResponse + <$> o .: "_index" + <*> o .: "_id" + <*> o .: "_version" + <*> o .: "result" + <*> o .:? "forced_refresh" .!= False + <*> o .: "_shards" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + +instance ToJSON DeleteEmailAccountResponse where + toJSON DeleteEmailAccountResponse {..} = + object + [ "_index" .= deleteEmailAccountResponseIndex, + "_id" .= deleteEmailAccountResponseId, + "_version" .= deleteEmailAccountResponseVersion, + "result" .= deleteEmailAccountResponseResult, + "forced_refresh" .= deleteEmailAccountResponseForcedRefresh, + "_shards" .= deleteEmailAccountResponseShards, + "_seq_no" .= deleteEmailAccountResponseSeqNo, + "_primary_term" .= deleteEmailAccountResponsePrimaryTerm + ] + +-- ========================================================================= +-- Email group lifecycle: POST/PUT/GET/DELETE /_plugins/_alerting/destinations/email_groups[/{id}] +-- ========================================================================= +-- +-- An email group is a named list of recipients (@emails@) referenced by +-- id from an email 'Destination'. The create\/update endpoints take an +-- 'EmailGroup' body and return the 'EmailGroupResponse' wrapper +-- (@{_id,_version,_seq_no,_primary_term, email_group:{...}}@); the delete +-- endpoint returns the standard Elasticsearch delete-document response, +-- modelled as 'DeleteEmailGroupResponse'. See +-- . + +-- | The server-assigned identifier of an alerting email group. Wraps +-- 'Text' so it round-trips as a bare JSON string but stays distinct from +-- the other alerting ids at the type level. +newtype EmailGroupId = EmailGroupId {unEmailGroupId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A single recipient within an 'EmailGroup'. The wire object is +-- @{"email": "..."}@; any forward-compat key is captured in +-- 'emailGroupRecipientOther'. +data EmailGroupRecipient = EmailGroupRecipient + { emailGroupRecipientEmail :: Text, + emailGroupRecipientOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroupRecipient where + parseJSON = withObject "EmailGroupRecipient" $ \o -> do + emailGroupRecipientEmail <- o .: "email" + pure EmailGroupRecipient {emailGroupRecipientOther = Object o, ..} + +instance ToJSON EmailGroupRecipient where + toJSON r = + case emailGroupRecipientOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = ["email" .= emailGroupRecipientEmail r] + +-- | An email group document. The full original object is captured in +-- 'emailGroupOther' so any forward-compat key round-trips losslessly. +data EmailGroup = EmailGroup + { emailGroupName :: Text, + emailGroupEmails :: [EmailGroupRecipient], + emailGroupSchemaVersion :: Maybe Int, + emailGroupOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroup where + parseJSON = withObject "EmailGroup" $ \o -> do + emailGroupName <- o .: "name" + emailGroupEmails <- o .:? "emails" .!= [] + emailGroupSchemaVersion <- o .:? "schema_version" + pure EmailGroup {emailGroupOther = Object o, ..} + +instance ToJSON EmailGroup where + toJSON g = + case emailGroupOther g of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= emailGroupName g, + "emails" .= emailGroupEmails g, + "schema_version" .= emailGroupSchemaVersion g + ] + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/destinations/email_groups[/{id}]@. Carries the +-- indexing metadata alongside the persisted email group. Mirrors +-- 'MonitorResponse' \/ 'DestinationResponse' \/ 'EmailAccountResponse'. +data EmailGroupResponse = EmailGroupResponse + { emailGroupResponseId :: Text, + emailGroupResponseVersion :: Int64, + emailGroupResponseSeqNo :: Int64, + emailGroupResponsePrimaryTerm :: Int64, + emailGroupResponseEmailGroup :: EmailGroup + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroupResponse where + parseJSON = withObject "EmailGroupResponse" $ \o -> + EmailGroupResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "email_group" + +instance ToJSON EmailGroupResponse where + toJSON EmailGroupResponse {..} = + object + [ "_id" .= emailGroupResponseId, + "_version" .= emailGroupResponseVersion, + "_seq_no" .= emailGroupResponseSeqNo, + "_primary_term" .= emailGroupResponsePrimaryTerm, + "email_group" .= emailGroupResponseEmailGroup + ] + +-- | Response shape for +-- @DELETE /_plugins/_alerting/destinations/email_groups/{id}@. +-- Wire-identical to 'DeleteDestinationResponse' (the standard +-- Elasticsearch delete-document response) but modelled as a distinct +-- type so the public API reads correctly at call sites. 'AlertingShards' +-- is reused for the @_shards@ sub-object. +data DeleteEmailGroupResponse = DeleteEmailGroupResponse + { deleteEmailGroupResponseIndex :: Text, + deleteEmailGroupResponseId :: Text, + deleteEmailGroupResponseVersion :: Int64, + deleteEmailGroupResponseResult :: Text, + deleteEmailGroupResponseForcedRefresh :: Bool, + deleteEmailGroupResponseShards :: AlertingShards, + deleteEmailGroupResponseSeqNo :: Int64, + deleteEmailGroupResponsePrimaryTerm :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteEmailGroupResponse where + parseJSON = withObject "DeleteEmailGroupResponse" $ \o -> + DeleteEmailGroupResponse + <$> o .: "_index" + <*> o .: "_id" + <*> o .: "_version" + <*> o .: "result" + <*> o .:? "forced_refresh" .!= False + <*> o .: "_shards" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + +instance ToJSON DeleteEmailGroupResponse where + toJSON DeleteEmailGroupResponse {..} = + object + [ "_index" .= deleteEmailGroupResponseIndex, + "_id" .= deleteEmailGroupResponseId, + "_version" .= deleteEmailGroupResponseVersion, + "result" .= deleteEmailGroupResponseResult, + "forced_refresh" .= deleteEmailGroupResponseForcedRefresh, + "_shards" .= deleteEmailGroupResponseShards, + "_seq_no" .= deleteEmailGroupResponseSeqNo, + "_primary_term" .= deleteEmailGroupResponsePrimaryTerm + ] + +-- ========================================================================= +-- Email account search: POST /_plugins/_alerting/destinations/email_accounts/_search +-- ========================================================================= +-- +-- The email account search endpoint exposes the email-account store as a +-- standard OpenSearch index, so the search body takes the standard query +-- DSL plus @from@ \/ @size@ \/ @sort@ and returns the standard search +-- envelope. Each hit's @_source@ is a bare 'EmailAccount' (the indexed +-- document source). Mirrors the 'MonitorsSearchQuery' / +-- 'SearchMonitorsResponse' pattern but with 'EmailAccount' sources. + +-- | Optional query body for 'searchEmailAccounts'. The @from@ \/ @size@ +-- pair is the standard OpenSearch pagination cursor; @sort@ is an opaque +-- 'Value' (the docs show @{"field.keyword": "desc"}@); @query@ is the +-- standard OpenSearch query DSL. Pass 'Nothing' to 'searchEmailAccounts' +-- (or 'defaultEmailAccountSearchQuery' to the body renderer) for the plain +-- empty-body @{}@ POST that returns the first page of all email accounts. +data EmailAccountSearchQuery = EmailAccountSearchQuery + { emailAccountSearchQueryFrom :: Maybe Int, + emailAccountSearchQuerySize :: Maybe Int, + emailAccountSearchQuerySort :: Maybe Value, + emailAccountSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultEmailAccountSearchQuery :: EmailAccountSearchQuery +defaultEmailAccountSearchQuery = EmailAccountSearchQuery Nothing Nothing Nothing Nothing + +instance ToJSON EmailAccountSearchQuery where + toJSON EmailAccountSearchQuery {..} = + omitNulls + [ "from" .= emailAccountSearchQueryFrom, + "size" .= emailAccountSearchQuerySize, + "sort" .= emailAccountSearchQuerySort, + "query" .= emailAccountSearchQueryQuery + ] + +instance FromJSON EmailAccountSearchQuery where + parseJSON = withObject "EmailAccountSearchQuery" $ \o -> + EmailAccountSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "sort" + <*> o .:? "query" + +-- | A single hit in @hits.hits[]@ on an email account search response. +-- The typed fields mirror the standard search-hit envelope; the @_source@ +-- is decoded as a bare 'EmailAccount'. The @sort@ field (present when a +-- sort is supplied in the query) is preserved as an opaque 'Value' in +-- 'emailAccountSearchHitSort' so callers can drive cursor-based +-- pagination. +data EmailAccountSearchHit = EmailAccountSearchHit + { emailAccountSearchHitIndex :: Maybe Text, + emailAccountSearchHitId :: Text, + emailAccountSearchHitVersion :: Maybe Int64, + emailAccountSearchHitSeqNo :: Maybe Int64, + emailAccountSearchHitPrimaryTerm :: Maybe Int64, + emailAccountSearchHitScore :: Maybe Double, + emailAccountSearchHitSource :: EmailAccount, + emailAccountSearchHitSort :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailAccountSearchHit where + parseJSON = withObject "EmailAccountSearchHit" $ \o -> + EmailAccountSearchHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + <*> o .:? "sort" + +instance ToJSON EmailAccountSearchHit where + toJSON EmailAccountSearchHit {..} = + omitNulls + [ "_index" .= emailAccountSearchHitIndex, + "_id" .= emailAccountSearchHitId, + "_version" .= emailAccountSearchHitVersion, + "_seq_no" .= emailAccountSearchHitSeqNo, + "_primary_term" .= emailAccountSearchHitPrimaryTerm, + "_score" .= emailAccountSearchHitScore, + "_source" .= emailAccountSearchHitSource, + "sort" .= emailAccountSearchHitSort + ] + +-- | Response envelope for 'searchEmailAccounts'. Reuses 'MonitorsTotal' +-- and 'MonitorsTotalRelation' for the @hits.total@ sub-object and +-- 'AlertingShards' for the @_shards@ sub-object (same wire shapes). +data SearchEmailAccountsResponse = SearchEmailAccountsResponse + { searchEmailAccountsResponseTook :: Int64, + searchEmailAccountsResponseTimedOut :: Bool, + searchEmailAccountsResponseShards :: AlertingShards, + searchEmailAccountsResponseTotal :: MonitorsTotal, + searchEmailAccountsResponseMaxScore :: Maybe Double, + searchEmailAccountsResponseHits :: [EmailAccountSearchHit] + } + deriving stock (Eq, Show) + +instance FromJSON SearchEmailAccountsResponse where + parseJSON = withObject "SearchEmailAccountsResponse" $ \o -> do + hits <- o .: "hits" + SearchEmailAccountsResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SearchEmailAccountsResponse where + toJSON SearchEmailAccountsResponse {..} = + object + [ "took" .= searchEmailAccountsResponseTook, + "timed_out" .= searchEmailAccountsResponseTimedOut, + "_shards" .= searchEmailAccountsResponseShards, + "hits" + .= object + [ "total" .= searchEmailAccountsResponseTotal, + "max_score" .= searchEmailAccountsResponseMaxScore, + "hits" .= searchEmailAccountsResponseHits + ] + ] + +-- ========================================================================= +-- Email group search: POST /_plugins/_alerting/destinations/email_groups/_search +-- ========================================================================= +-- +-- Wire-identical in shape to the email account search; the @_source@ of +-- each hit is a bare 'EmailGroup' instead. + +-- | Optional query body for 'searchEmailGroups'. Same shape as +-- 'EmailAccountSearchQuery'. Pass 'Nothing' or +-- 'defaultEmailGroupSearchQuery' for the plain empty-body @{}@ POST. +data EmailGroupSearchQuery = EmailGroupSearchQuery + { emailGroupSearchQueryFrom :: Maybe Int, + emailGroupSearchQuerySize :: Maybe Int, + emailGroupSearchQuerySort :: Maybe Value, + emailGroupSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultEmailGroupSearchQuery :: EmailGroupSearchQuery +defaultEmailGroupSearchQuery = EmailGroupSearchQuery Nothing Nothing Nothing Nothing + +instance ToJSON EmailGroupSearchQuery where + toJSON EmailGroupSearchQuery {..} = + omitNulls + [ "from" .= emailGroupSearchQueryFrom, + "size" .= emailGroupSearchQuerySize, + "sort" .= emailGroupSearchQuerySort, + "query" .= emailGroupSearchQueryQuery + ] + +instance FromJSON EmailGroupSearchQuery where + parseJSON = withObject "EmailGroupSearchQuery" $ \o -> + EmailGroupSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "sort" + <*> o .:? "query" + +-- | A single hit in @hits.hits[]@ on an email group search response. +-- Mirrors 'EmailAccountSearchHit' but with 'EmailGroup' source. +data EmailGroupSearchHit = EmailGroupSearchHit + { emailGroupSearchHitIndex :: Maybe Text, + emailGroupSearchHitId :: Text, + emailGroupSearchHitVersion :: Maybe Int64, + emailGroupSearchHitSeqNo :: Maybe Int64, + emailGroupSearchHitPrimaryTerm :: Maybe Int64, + emailGroupSearchHitScore :: Maybe Double, + emailGroupSearchHitSource :: EmailGroup, + emailGroupSearchHitSort :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroupSearchHit where + parseJSON = withObject "EmailGroupSearchHit" $ \o -> + EmailGroupSearchHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + <*> o .:? "sort" + +instance ToJSON EmailGroupSearchHit where + toJSON EmailGroupSearchHit {..} = + omitNulls + [ "_index" .= emailGroupSearchHitIndex, + "_id" .= emailGroupSearchHitId, + "_version" .= emailGroupSearchHitVersion, + "_seq_no" .= emailGroupSearchHitSeqNo, + "_primary_term" .= emailGroupSearchHitPrimaryTerm, + "_score" .= emailGroupSearchHitScore, + "_source" .= emailGroupSearchHitSource, + "sort" .= emailGroupSearchHitSort + ] + +-- | Response envelope for 'searchEmailGroups'. Reuses 'MonitorsTotal' +-- and 'AlertingShards'. +data SearchEmailGroupsResponse = SearchEmailGroupsResponse + { searchEmailGroupsResponseTook :: Int64, + searchEmailGroupsResponseTimedOut :: Bool, + searchEmailGroupsResponseShards :: AlertingShards, + searchEmailGroupsResponseTotal :: MonitorsTotal, + searchEmailGroupsResponseMaxScore :: Maybe Double, + searchEmailGroupsResponseHits :: [EmailGroupSearchHit] + } + deriving stock (Eq, Show) + +instance FromJSON SearchEmailGroupsResponse where + parseJSON = withObject "SearchEmailGroupsResponse" $ \o -> do + hits <- o .: "hits" + SearchEmailGroupsResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SearchEmailGroupsResponse where + toJSON SearchEmailGroupsResponse {..} = + object + [ "took" .= searchEmailGroupsResponseTook, + "timed_out" .= searchEmailGroupsResponseTimedOut, + "_shards" .= searchEmailGroupsResponseShards, + "hits" + .= object + [ "total" .= searchEmailGroupsResponseTotal, + "max_score" .= searchEmailGroupsResponseMaxScore, + "hits" .= searchEmailGroupsResponseHits + ] + ] + +-- ========================================================================= +-- Findings search: GET /_plugins/_alerting/findings/_search +-- ========================================================================= +-- +-- The findings search endpoint queries the +-- @.opensearch-alerting-finding*@ index for document-level monitor +-- findings. Unlike the monitor\/email-account\/email-group search +-- endpoints (which take a POST body with the standard query DSL), the +-- findings search is a GET with query-string parameters only. The +-- response carries a @total_findings@ count and a list of finding +-- objects. The OpenSearch docs +-- () +-- document the query parameters but do not show a full finding response +-- example, so the findings list is kept as an opaque aeson 'Value' to +-- avoid guessing at an under-documented schema. + +-- | Query-string parameters accepted by +-- @GET /_plugins/_alerting/findings/_search@. Every field is optional; +-- 'defaultFindingsSearchOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET that returns all findings. The +-- server-side defaults are: @sortString=id@, @sortOrder=asc@, +-- @size=unlimited@, @startIndex=0@, @searchString=""@. +data FindingsSearchOptions = FindingsSearchOptions + { findingsSearchOptionsFindingId :: Maybe Text, + findingsSearchOptionsSortString :: Maybe Text, + findingsSearchOptionsSortOrder :: Maybe DestinationSortOrder, + findingsSearchOptionsSize :: Maybe Natural, + findingsSearchOptionsStartIndex :: Maybe Natural, + findingsSearchOptionsSearchString :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record -- no query parameters. +defaultFindingsSearchOptions :: FindingsSearchOptions +defaultFindingsSearchOptions = + FindingsSearchOptions + { findingsSearchOptionsFindingId = Nothing, + findingsSearchOptionsSortString = Nothing, + findingsSearchOptionsSortOrder = Nothing, + findingsSearchOptionsSize = Nothing, + findingsSearchOptionsStartIndex = Nothing, + findingsSearchOptionsSearchString = Nothing + } + +-- | Render a 'FindingsSearchOptions' to the query-string pairs accepted +-- by the findings search endpoint. Fields set to 'Nothing' are omitted. +findingsSearchOptionsParams :: FindingsSearchOptions -> [(Text, Maybe Text)] +findingsSearchOptionsParams FindingsSearchOptions {..} = + catMaybes + [ ("findingId",) . Just <$> findingsSearchOptionsFindingId, + ("sortString",) . Just <$> findingsSearchOptionsSortString, + ("sortOrder",) . Just . destinationSortOrderText <$> findingsSearchOptionsSortOrder, + ("size",) . Just . tshow <$> findingsSearchOptionsSize, + ("startIndex",) . Just . tshow <$> findingsSearchOptionsStartIndex, + ("searchString",) . Just <$> findingsSearchOptionsSearchString + ] + +-- | Response shape for +-- @GET /_plugins/_alerting/findings/_search@. @totalFindings@ is the +-- total hit count; @findings@ is the list of finding objects, kept as an +-- opaque aeson 'Value' because the docs do not document the full finding +-- schema. Mirrors the pragmatic-typing precedent (typed shell + opaque +-- variable payload). +data SearchFindingsResponse = SearchFindingsResponse + { searchFindingsResponseTotalFindings :: Int, + searchFindingsResponseFindings :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SearchFindingsResponse where + parseJSON = withObject "SearchFindingsResponse" $ \o -> + SearchFindingsResponse + <$> o .:? "total_findings" .!= 0 + <*> o .:? "findings" .!= Null + +instance ToJSON SearchFindingsResponse where + toJSON SearchFindingsResponse {..} = + object + [ "total_findings" .= searchFindingsResponseTotalFindings, + "findings" .= searchFindingsResponseFindings + ] + +-- ========================================================================= +-- Comments API: POST/PUT/GET/DELETE /_plugins/_alerting/comments[/{id}] +-- ========================================================================= +-- +-- The comments API provides CRUD over comment documents associated with +-- alert entities. Comments are stored in a +-- @.opensearch-alerting-comments-history-*@ index. Each comment carries +-- an @entity_id@ (the alert id), @entity_type@ (documented as @"alert"@), +-- the @content@ text, timestamps (@created_time@, +-- @last_updated_time@), and the @user@ who created it. See +-- . + +-- | The server-assigned identifier of a comment. Wraps 'Text' so it +-- round-trips as a bare JSON string but stays distinct from the other +-- alerting ids at the type level. +newtype CommentId = CommentId {unCommentId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A comment document. @entityType@ is typed as 'Text' (the docs only +-- show @"alert"@ but the field name implies extensibility). @user@ is +-- also 'Text' (the docs show a bare username string, not the rich user +-- object used by 'Destination'). The full original object is captured in +-- 'commentOther' so any forward-compat key round-trips losslessly. +data Comment = Comment + { commentEntityId :: Text, + commentEntityType :: Text, + commentContent :: Text, + commentCreatedTime :: Maybe Int64, + commentLastUpdatedTime :: Maybe Int64, + commentUser :: Maybe Text, + commentOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON Comment where + parseJSON = withObject "Comment" $ \o -> do + commentEntityId <- o .: "entity_id" + commentEntityType <- o .: "entity_type" + commentContent <- o .: "content" + commentCreatedTime <- o .:? "created_time" + commentLastUpdatedTime <- o .:? "last_updated_time" + commentUser <- o .:? "user" + pure Comment {commentOther = Object o, ..} + +instance ToJSON Comment where + toJSON c = + case commentOther c of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "entity_id" .= commentEntityId c, + "entity_type" .= commentEntityType c, + "content" .= commentContent c, + "created_time" .= commentCreatedTime c, + "last_updated_time" .= commentLastUpdatedTime c, + "user" .= commentUser c + ] + +-- | Request body for 'createComment'. @content@ is the comment text. +newtype CreateCommentRequest = CreateCommentRequest + { createCommentRequestContent :: Text + } + deriving stock (Eq, Show) + +instance ToJSON CreateCommentRequest where + toJSON CreateCommentRequest {..} = + object ["content" .= createCommentRequestContent] + +instance FromJSON CreateCommentRequest where + parseJSON = withObject "CreateCommentRequest" $ \o -> + CreateCommentRequest <$> o .: "content" + +-- | Request body for 'updateComment'. Same shape as +-- 'CreateCommentRequest'. +newtype UpdateCommentRequest = UpdateCommentRequest + { updateCommentRequestContent :: Text + } + deriving stock (Eq, Show) + +instance ToJSON UpdateCommentRequest where + toJSON UpdateCommentRequest {..} = + object ["content" .= updateCommentRequestContent] + +instance FromJSON UpdateCommentRequest where + parseJSON = withObject "UpdateCommentRequest" $ \o -> + UpdateCommentRequest <$> o .: "content" + +-- | Response wrapper for @POST@ and @PUT@ on +-- @/_plugins/_alerting/comments[/{id}]@. Carries the indexing metadata +-- alongside the persisted comment. Mirrors 'MonitorResponse' / +-- 'EmailAccountResponse' but without @_version@ (the docs do not show +-- a @_version@ field on comment responses). +data CommentResponse = CommentResponse + { commentResponseId :: Text, + commentResponseSeqNo :: Int64, + commentResponsePrimaryTerm :: Int64, + commentResponseComment :: Comment + } + deriving stock (Eq, Show) + +instance FromJSON CommentResponse where + parseJSON = withObject "CommentResponse" $ \o -> + CommentResponse + <$> o .: "_id" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + <*> o .: "comment" + +instance ToJSON CommentResponse where + toJSON CommentResponse {..} = + object + [ "_id" .= commentResponseId, + "_seq_no" .= commentResponseSeqNo, + "_primary_term" .= commentResponsePrimaryTerm, + "comment" .= commentResponseComment + ] + +-- | Optional query body for 'searchComments'. The @from@ \/ @size@ +-- pair is the standard OpenSearch pagination cursor; @sort@ is an opaque +-- 'Value'; @query@ is the standard OpenSearch query DSL. Pass 'Nothing' +-- or 'defaultCommentSearchQuery' for the plain empty-body @{}@ request. +data CommentSearchQuery = CommentSearchQuery + { commentSearchQueryFrom :: Maybe Int, + commentSearchQuerySize :: Maybe Int, + commentSearchQuerySort :: Maybe Value, + commentSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultCommentSearchQuery :: CommentSearchQuery +defaultCommentSearchQuery = CommentSearchQuery Nothing Nothing Nothing Nothing + +instance ToJSON CommentSearchQuery where + toJSON CommentSearchQuery {..} = + omitNulls + [ "from" .= commentSearchQueryFrom, + "size" .= commentSearchQuerySize, + "sort" .= commentSearchQuerySort, + "query" .= commentSearchQueryQuery + ] + +instance FromJSON CommentSearchQuery where + parseJSON = withObject "CommentSearchQuery" $ \o -> + CommentSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "sort" + <*> o .:? "query" + +-- | A single hit in @hits.hits[]@ on a comment search response. The +-- typed fields mirror the standard search-hit envelope; the @_source@ is +-- decoded as a bare 'Comment'. +data CommentSearchHit = CommentSearchHit + { commentSearchHitIndex :: Maybe Text, + commentSearchHitId :: Text, + commentSearchHitVersion :: Maybe Int64, + commentSearchHitSeqNo :: Maybe Int64, + commentSearchHitPrimaryTerm :: Maybe Int64, + commentSearchHitScore :: Maybe Double, + commentSearchHitSource :: Comment + } + deriving stock (Eq, Show) + +instance FromJSON CommentSearchHit where + parseJSON = withObject "CommentSearchHit" $ \o -> + CommentSearchHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON CommentSearchHit where + toJSON CommentSearchHit {..} = + omitNulls + [ "_index" .= commentSearchHitIndex, + "_id" .= commentSearchHitId, + "_version" .= commentSearchHitVersion, + "_seq_no" .= commentSearchHitSeqNo, + "_primary_term" .= commentSearchHitPrimaryTerm, + "_score" .= commentSearchHitScore, + "_source" .= commentSearchHitSource + ] + +-- | Response envelope for 'searchComments'. Reuses 'MonitorsTotal' and +-- 'AlertingShards'. +data SearchCommentsResponse = SearchCommentsResponse + { searchCommentsResponseTook :: Int64, + searchCommentsResponseTimedOut :: Bool, + searchCommentsResponseShards :: AlertingShards, + searchCommentsResponseTotal :: MonitorsTotal, + searchCommentsResponseMaxScore :: Maybe Double, + searchCommentsResponseHits :: [CommentSearchHit] + } + deriving stock (Eq, Show) + +instance FromJSON SearchCommentsResponse where + parseJSON = withObject "SearchCommentsResponse" $ \o -> do + hits <- o .: "hits" + SearchCommentsResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SearchCommentsResponse where + toJSON SearchCommentsResponse {..} = + object + [ "took" .= searchCommentsResponseTook, + "timed_out" .= searchCommentsResponseTimedOut, + "_shards" .= searchCommentsResponseShards, + "hits" + .= object + [ "total" .= searchCommentsResponseTotal, + "max_score" .= searchCommentsResponseMaxScore, + "hits" .= searchCommentsResponseHits + ] + ] + +-- | Response shape for @DELETE /_plugins/_alerting/comments/{id}@. +-- Minimal: just the @_id@ of the deleted comment. +newtype DeleteCommentResponse = DeleteCommentResponse + { deleteCommentResponseId :: Text + } + deriving stock (Eq, Show) + +instance FromJSON DeleteCommentResponse where + parseJSON = withObject "DeleteCommentResponse" $ \o -> + DeleteCommentResponse <$> o .: "_id" + +instance ToJSON DeleteCommentResponse where + toJSON DeleteCommentResponse {..} = + object ["_id" .= deleteCommentResponseId] + +-- | Overlay the typed key-value pairs on top of a captured object, +-- dropping typed pairs whose value is @null@ (so optional fields left +-- 'Nothing' do not clobber a non-null value captured from the wire). +-- Mirrors the helper in +-- "Database.Bloodhound.Internal.Versions.Common.Types.PendingTask". +mergeIgnoringNulls :: [(Key, Value)] -> KM.KeyMap Value -> KM.KeyMap Value +mergeIgnoringNulls kvs o = KM.union (KM.fromList (filter notNull kvs)) o + where + notNull (_, Null) = False + notNull _ = True diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/AnomalyDetection.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/AnomalyDetection.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/AnomalyDetection.hs @@ -0,0 +1,1426 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.AnomalyDetection + ( DetectorId (..), + PeriodUnit (..), + periodUnitText, + Period (..), + WindowPeriod (..), + FeatureAttribute (..), + DetectorType (..), + detectorTypeText, + User (..), + Detector (..), + DetectorResponse (..), + CreateDetectorResponse (..), + GetDetectorResponse (..), + GetDetectorParams (..), + defaultGetDetectorParams, + DetectorJob (..), + DetectorJobSchedule (..), + DetectorJobScheduleInterval (..), + DetectionTask (..), + DetectionDateRange (..), + DetectionTaskType (..), + detectionTaskTypeText, + PreviewRequest (..), + FeatureData (..), + Entity (..), + AnomalyResult (..), + PreviewResponse (..), + StartDetectorJobRequest (..), + DetectorJobAcknowledgment (..), + -- | Update / Delete detector + AnomalyShards (..), + DeleteDetectorResponse (..), + -- | Validate detector + ValidateDetectorMode (..), + validateDetectorModeSegments, + ValidateDetectorResponse (..), + -- | Search envelope (detectors / results / tasks) + AnomalySearchTotalRelation (..), + AnomalySearchTotal (..), + AnomalySearchHit (..), + AnomalySearchResponse (..), + anomalySearchResponseSources, + SearchDetectorsResponse, + SearchDetectorResultsResponse, + DeleteDetectorResultsResponse, + SearchDetectorTasksResponse, + -- | Profile / Stats + DetectorProfileResponse (..), + DetectorStatsResponse (..), + -- | Top anomalies + TopAnomaliesOrder (..), + topAnomaliesOrderText, + TopAnomaliesRequest (..), + defaultTopAnomaliesRequest, + TopAnomalyBucket (..), + TopAnomaliesResponse (..), + ) +where + +import Data.Text qualified as T +import Database.Bloodhound.Internal.Client.Doc (DocVersion) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes (DeletedDocuments) + +-- $schema +-- +-- The OpenSearch Anomaly Detection (AD) plugin +-- () +-- detects anomalies in time-series data using Random Cut Forest (RCF). A +-- 'Detector' binds a name and a target index to one or more +-- 'FeatureAttribute's (aggregations the plugin evaluates each +-- 'detectionInterval'); the server persists it under +-- @.opendistro-anomaly-detection-state@ and returns a +-- 'CreateDetectorResponse' wrapping the persisted 'DetectorResponse' with +-- server-injected bookkeeping fields (@_id@, @_version@, @_seq_no@, +-- @_primary_term@, @shingle_size@, @schema_version@, @last_update_time@, +-- @user@, @detector_type@, @rules@, @recency_emphasis@, @history@). +-- +-- We split the request shape ('Detector') from the response shape +-- ('DetectorResponse') so the request cannot accidentally carry +-- server-only fields, while the response still round-trips the full +-- server payload. This mirrors the 'ISMPolicyRequest' / +-- 'ISMPolicyResponse' split used for the ISM plugin. +-- +-- The plugin is shipped with OpenSearch 1.0+; it is present (and +-- wire-compatible) on OS1, OS2 and OS3, hence this module is duplicated +-- across all three versions. +-- +-- Doc ambiguities handled here deliberately: +-- +-- * The @period.unit@ field is documented with only @"Minutes"@ in +-- examples. The plugin source also accepts @Hours@, @Seconds@, @Days@, +-- @Weeks@ and @Months@; we type 'PeriodUnit' as a closed enum with a +-- 'PeriodUnitCustom' escape hatch so future additions surface as a +-- parsed value rather than a decode failure. +-- * The @detector_type@ field is server-derived from the presence of +-- @category_field@. The docs enumerate @"SINGLE_ENTITY"@ and +-- @"MULTI_ENTITY"@; we add 'DetectorTypeCustom' for forward +-- compatibility. +-- * The @rules@ array is server-injected as a default +-- @IGNORE_ANOMALY@ rule (observed in live responses) but is not +-- documented in the field table. We carry it as an opaque 'Value' +-- until the typed schema lands (tracked separately). +-- * The @_start@ endpoint serves double duty: with no body it starts the +-- real-time detector job, and with a 'StartDetectorJobRequest' body it +-- kicks off a one-shot historical backfill (the documented successor to +-- the legacy @_run@). The two forms share one URL and one +-- 'DetectorJobAcknowledgment' response shape but return different +-- @_id@ values (detector id vs historical batch task id). + +-- | Identifies an anomaly detector in the +-- @\/_plugins\/_anomaly_detection\/detectors\/{id}@ URL path. Wraps +-- 'Text' so it round-trips through JSON as a bare string but is distinct +-- at the Haskell type level. +-- See +newtype DetectorId = DetectorId {unDetectorId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @period.unit@ enum documented at +-- . +-- The docs only show @"Minutes"@ in examples; the plugin source accepts +-- a handful of additional values, all enumerated here. Unknown values +-- (forward compatibility) parse as 'PeriodUnitCustom'. +data PeriodUnit + = PeriodUnitMinutes + | PeriodUnitHours + | PeriodUnitSeconds + | PeriodUnitDays + | PeriodUnitWeeks + | PeriodUnitMonths + | PeriodUnitCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'PeriodUnit' — the same mapping the 'ToJSON' +-- \/ 'FromJSON' instances use, exposed as plain 'Text' for callers that +-- need the wire string without going through a 'Data.Aeson.Value'. +periodUnitText :: PeriodUnit -> Text +periodUnitText = \case + PeriodUnitMinutes -> "Minutes" + PeriodUnitHours -> "Hours" + PeriodUnitSeconds -> "Seconds" + PeriodUnitDays -> "Days" + PeriodUnitWeeks -> "Weeks" + PeriodUnitMonths -> "Months" + PeriodUnitCustom t -> t + +instance ToJSON PeriodUnit where + toJSON = toJSON . periodUnitText + +instance FromJSON PeriodUnit where + parseJSON = withText "PeriodUnit" $ \case + "Minutes" -> pure PeriodUnitMinutes + "Hours" -> pure PeriodUnitHours + "Seconds" -> pure PeriodUnitSeconds + "Days" -> pure PeriodUnitDays + "Weeks" -> pure PeriodUnitWeeks + "Months" -> pure PeriodUnitMonths + other -> pure (PeriodUnitCustom other) + +-- | The inner @{interval, unit}@ object shared by 'WindowPeriod'. The +-- @interval@ is a positive integer; @unit@ names the time unit. +-- See +data Period = Period + { periodInterval :: Int, + periodUnit :: PeriodUnit + } + deriving stock (Eq, Show) + +instance FromJSON Period where + parseJSON = withObject "Period" $ \v -> do + periodInterval <- v .: "interval" + periodUnit <- v .: "unit" + pure Period {..} + +instance ToJSON Period where + toJSON Period {..} = + object + [ "interval" .= periodInterval, + "unit" .= periodUnit + ] + +-- | The wrapper @{period: {interval, unit}}@ used by both +-- @detection_interval@ and @window_delay@. Distinct from 'Period' so the +-- two levels cannot be confused at the call site. +-- See +newtype WindowPeriod = WindowPeriod {windowPeriodPeriod :: Period} + deriving stock (Eq, Show) + +instance FromJSON WindowPeriod where + parseJSON = withObject "WindowPeriod" $ \v -> + WindowPeriod <$> v .: "period" + +instance ToJSON WindowPeriod where + toJSON WindowPeriod {..} = + object ["period" .= windowPeriodPeriod] + +-- | A feature attribute: a named aggregation the plugin evaluates each +-- detection interval. The request shape omits @feature_id@ (the server +-- generates one); the response shape fills it in via 'featureAttributeId'. +-- @aggregation_query@ is an arbitrary OpenSearch aggregations DSL body, +-- so it is carried as an opaque 'Value' (the same approach the ISM +-- module takes for untyped DSL fragments). +-- See +data FeatureAttribute = FeatureAttribute + { featureAttributeId :: Maybe Text, + featureAttributeName :: Text, + featureAttributeEnabled :: Bool, + featureAttributeAggregationQuery :: Value + } + deriving stock (Eq, Show) + +instance FromJSON FeatureAttribute where + parseJSON = withObject "FeatureAttribute" $ \v -> do + featureAttributeId <- v .:? "feature_id" + featureAttributeName <- v .: "feature_name" + featureAttributeEnabled <- v .:? "feature_enabled" .!= True + featureAttributeAggregationQuery <- v .: "aggregation_query" + pure FeatureAttribute {..} + +instance ToJSON FeatureAttribute where + toJSON FeatureAttribute {..} = + omitNulls + [ "feature_id" .= featureAttributeId, + "feature_name" .= featureAttributeName, + "feature_enabled" .= featureAttributeEnabled, + "aggregation_query" .= featureAttributeAggregationQuery + ] + +-- | The @detector_type@ enum. The docs enumerate @"SINGLE_ENTITY"@ (no +-- @category_field@ set) and @"MULTI_ENTITY"@ (@category_field@ set); +-- unknown values parse as 'DetectorTypeCustom' so future plugin +-- releases surface as a parsed value rather than a decode failure. +-- The field is server-derived; callers never need to construct it. +data DetectorType + = DetectorTypeSingleEntity + | DetectorTypeMultiEntity + | DetectorTypeCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'DetectorType' — the same mapping the +-- 'ToJSON' \/ 'FromJSON' instances use. +detectorTypeText :: DetectorType -> Text +detectorTypeText = \case + DetectorTypeSingleEntity -> "SINGLE_ENTITY" + DetectorTypeMultiEntity -> "MULTI_ENTITY" + DetectorTypeCustom t -> t + +instance ToJSON DetectorType where + toJSON = toJSON . detectorTypeText + +instance FromJSON DetectorType where + parseJSON = withText "DetectorType" $ \case + "SINGLE_ENTITY" -> pure DetectorTypeSingleEntity + "MULTI_ENTITY" -> pure DetectorTypeMultiEntity + other -> pure (DetectorTypeCustom other) + +-- | The server-injected @user@ object carried on every detector +-- response. The plugin populates it from the authenticated caller; the +-- request never supplies it. All fields are 'Maybe' because the plugin +-- docs do not enumerate which subsets may be absent for non-admin +-- callers or internal users. +-- See +data User = User + { userName :: Maybe Text, + userBackendRoles :: Maybe [Text], + userRoles :: Maybe [Text], + userCustomAttributeNames :: Maybe [Value], + userUserRequestedTenant :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON User where + parseJSON = withObject "User" $ \v -> do + userName <- v .:? "name" + userBackendRoles <- v .:? "backend_roles" + userRoles <- v .:? "roles" + userCustomAttributeNames <- v .:? "custom_attribute_names" + userUserRequestedTenant <- v .:? "user_requested_tenant" + pure User {..} + +instance ToJSON User where + toJSON User {..} = + omitNulls + [ "name" .= userName, + "backend_roles" .= userBackendRoles, + "roles" .= userRoles, + "custom_attribute_names" .= userCustomAttributeNames, + "user_requested_tenant" .= userUserRequestedTenant + ] + +-- $detectorSchema +-- +-- The 'Detector' request body carries the user-supplied fields the +-- server needs to create or update an anomaly detector. Server-only +-- fields (@shingle_size@, @schema_version@, @last_update_time@, @user@, +-- @detector_type@, @rules@, @recency_emphasis@, @history@) are +-- deliberately absent — including them would invite callers to send +-- values the server ignores or rejects. They appear on the +-- 'DetectorResponse' round-trip shape. + +-- | The request body for @POST /_plugins/_anomaly_detection/detectors@. +-- Required fields: @name@, @time_field@, @indices@, +-- @feature_attributes@, @detection_interval@. Everything else is +-- optional and omitted on the wire when 'Nothing'. +-- See +data Detector = Detector + { detectorName :: Text, + detectorDescription :: Maybe Text, + detectorTimeField :: Text, + detectorIndices :: [Text], + detectorFeatureAttributes :: [FeatureAttribute], + detectorFilterQuery :: Maybe Value, + detectorDetectionInterval :: WindowPeriod, + detectorWindowDelay :: Maybe WindowPeriod, + detectorCategoryField :: Maybe [Text], + detectorResultIndex :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON Detector where + parseJSON = withObject "Detector" $ \v -> do + detectorName <- v .: "name" + detectorDescription <- v .:? "description" + detectorTimeField <- v .: "time_field" + detectorIndices <- v .:? "indices" .!= [] + detectorFeatureAttributes <- v .:? "feature_attributes" .!= [] + detectorFilterQuery <- v .:? "filter_query" + detectorDetectionInterval <- v .: "detection_interval" + detectorWindowDelay <- v .:? "window_delay" + detectorCategoryField <- v .:? "category_field" + detectorResultIndex <- v .:? "result_index" + pure Detector {..} + +instance ToJSON Detector where + toJSON Detector {..} = + omitNulls + [ "name" .= detectorName, + "description" .= detectorDescription, + "time_field" .= detectorTimeField, + "indices" .= detectorIndices, + "feature_attributes" .= detectorFeatureAttributes, + "filter_query" .= detectorFilterQuery, + "detection_interval" .= detectorDetectionInterval, + "window_delay" .= detectorWindowDelay, + "category_field" .= detectorCategoryField, + "result_index" .= detectorResultIndex + ] + +-- | The persisted detector shape returned in responses (the inner +-- @anomaly_detector@ object of a 'CreateDetectorResponse' / +-- 'GetDetectorResponse' / 'PreviewResponse'). Carries the full +-- 'Detector' body alongside server-injected bookkeeping fields. The +-- round-trip preserves everything the server sent, so a Get → Update +-- cycle does not lose data the caller never set. +-- See +data DetectorResponse = DetectorResponse + { detectorResponseName :: Text, + detectorResponseDescription :: Maybe Text, + detectorResponseTimeField :: Text, + detectorResponseIndices :: [Text], + detectorResponseFilterQuery :: Maybe Value, + detectorResponseDetectionInterval :: WindowPeriod, + detectorResponseWindowDelay :: Maybe WindowPeriod, + detectorResponseShingleSize :: Maybe Int, + detectorResponseSchemaVersion :: Maybe Int, + detectorResponseFeatureAttributes :: [FeatureAttribute], + detectorResponseLastUpdateTime :: Maybe Integer, + detectorResponseUser :: Maybe User, + detectorResponseDetectorType :: Maybe DetectorType, + detectorResponseCategoryField :: Maybe [Text], + detectorResponseResultIndex :: Maybe Text, + -- Server-injected bookkeeping the docs do not enumerate but live + -- responses carry. Typed as 'Value' / 'Int' until a follow-up + -- promotes them (see module docs). + detectorResponseRecencyEmphasis :: Maybe Int, + detectorResponseHistory :: Maybe Int, + detectorResponseRules :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON DetectorResponse where + parseJSON = withObject "DetectorResponse" $ \v -> do + detectorResponseName <- v .: "name" + detectorResponseDescription <- v .:? "description" + detectorResponseTimeField <- v .: "time_field" + detectorResponseIndices <- v .:? "indices" .!= [] + detectorResponseFilterQuery <- v .:? "filter_query" + detectorResponseDetectionInterval <- v .: "detection_interval" + detectorResponseWindowDelay <- v .:? "window_delay" + detectorResponseShingleSize <- v .:? "shingle_size" + detectorResponseSchemaVersion <- v .:? "schema_version" + detectorResponseFeatureAttributes <- v .:? "feature_attributes" .!= [] + detectorResponseLastUpdateTime <- v .:? "last_update_time" + detectorResponseUser <- v .:? "user" + detectorResponseDetectorType <- v .:? "detector_type" + detectorResponseCategoryField <- v .:? "category_field" + detectorResponseResultIndex <- v .:? "result_index" + detectorResponseRecencyEmphasis <- v .:? "recency_emphasis" + detectorResponseHistory <- v .:? "history" + detectorResponseRules <- v .:? "rules" + pure DetectorResponse {..} + +instance ToJSON DetectorResponse where + toJSON DetectorResponse {..} = + omitNulls + [ "name" .= detectorResponseName, + "description" .= detectorResponseDescription, + "time_field" .= detectorResponseTimeField, + "indices" .= detectorResponseIndices, + "filter_query" .= detectorResponseFilterQuery, + "detection_interval" .= detectorResponseDetectionInterval, + "window_delay" .= detectorResponseWindowDelay, + "shingle_size" .= detectorResponseShingleSize, + "schema_version" .= detectorResponseSchemaVersion, + "feature_attributes" .= detectorResponseFeatureAttributes, + "last_update_time" .= detectorResponseLastUpdateTime, + "user" .= detectorResponseUser, + "detector_type" .= detectorResponseDetectorType, + "category_field" .= detectorResponseCategoryField, + "result_index" .= detectorResponseResultIndex, + "recency_emphasis" .= detectorResponseRecencyEmphasis, + "history" .= detectorResponseHistory, + "rules" .= detectorResponseRules + ] + +-- | Response body of @POST /_plugins/_anomaly_detection/detectors@. The +-- server wraps the persisted 'DetectorResponse' in a document-write +-- envelope (@_id@, @_version@, @_primary_term@, @_seq_no@) — the same +-- shape OpenSearch uses for any persisted document. +-- See +data CreateDetectorResponse = CreateDetectorResponse + { createDetectorResponseId :: Text, + createDetectorResponseVersion :: DocVersion, + createDetectorResponsePrimaryTerm :: Int, + createDetectorResponseSeqNo :: Int, + createDetectorResponseDetector :: DetectorResponse + } + deriving stock (Eq, Show) + +instance FromJSON CreateDetectorResponse where + parseJSON = withObject "CreateDetectorResponse" $ \v -> do + createDetectorResponseId <- v .: "_id" + createDetectorResponseVersion <- v .: "_version" + createDetectorResponsePrimaryTerm <- v .: "_primary_term" + createDetectorResponseSeqNo <- v .: "_seq_no" + createDetectorResponseDetector <- v .: "anomaly_detector" + pure CreateDetectorResponse {..} + +instance ToJSON CreateDetectorResponse where + toJSON CreateDetectorResponse {..} = + object + [ "_id" .= createDetectorResponseId, + "_version" .= createDetectorResponseVersion, + "_primary_term" .= createDetectorResponsePrimaryTerm, + "_seq_no" .= createDetectorResponseSeqNo, + "anomaly_detector" .= createDetectorResponseDetector + ] + +-- | Response body of @GET /_plugins/_anomaly_detection/detectors/{id}@. +-- Structurally a superset of 'CreateDetectorResponse': the same +-- document-write envelope (@_id@, @_version@, @_primary_term@, @_seq_no@) +-- around the same inner 'DetectorResponse', plus up to three optional +-- sibling objects that the server only embeds when the corresponding +-- query flag is set on the request ('GetDetectorParams'): +-- +-- * @?job=true@ adds 'getDetectorResponseJob' (@anomaly_detector_job@); +-- * @?task=true@ adds 'getDetectorResponseRealtimeTask' +-- (@realtime_detection_task@) and 'getDetectorResponseHistoricalTask' +-- (@historical_analysis_task@). +-- +-- Without either flag the three 'Maybe' fields decode as 'Nothing', so a +-- plain GET round-trips exactly like the old 'CreateDetectorResponse'. +-- See +data GetDetectorResponse = GetDetectorResponse + { getDetectorResponseId :: Text, + getDetectorResponseVersion :: DocVersion, + getDetectorResponsePrimaryTerm :: Int, + getDetectorResponseSeqNo :: Int, + getDetectorResponseDetector :: DetectorResponse, + getDetectorResponseJob :: Maybe DetectorJob, + getDetectorResponseRealtimeTask :: Maybe DetectionTask, + getDetectorResponseHistoricalTask :: Maybe DetectionTask + } + deriving stock (Eq, Show) + +instance FromJSON GetDetectorResponse where + parseJSON = withObject "GetDetectorResponse" $ \v -> do + getDetectorResponseId <- v .: "_id" + getDetectorResponseVersion <- v .: "_version" + getDetectorResponsePrimaryTerm <- v .: "_primary_term" + getDetectorResponseSeqNo <- v .: "_seq_no" + getDetectorResponseDetector <- v .: "anomaly_detector" + getDetectorResponseJob <- v .:? "anomaly_detector_job" + getDetectorResponseRealtimeTask <- v .:? "realtime_detection_task" + getDetectorResponseHistoricalTask <- v .:? "historical_analysis_task" + pure GetDetectorResponse {..} + +instance ToJSON GetDetectorResponse where + toJSON GetDetectorResponse {..} = + omitNulls + [ "_id" .= getDetectorResponseId, + "_version" .= getDetectorResponseVersion, + "_primary_term" .= getDetectorResponsePrimaryTerm, + "_seq_no" .= getDetectorResponseSeqNo, + "anomaly_detector" .= getDetectorResponseDetector, + "anomaly_detector_job" .= getDetectorResponseJob, + "realtime_detection_task" .= getDetectorResponseRealtimeTask, + "historical_analysis_task" .= getDetectorResponseHistoricalTask + ] + +-- | Optional flags for 'getDetector' that select which extra sibling +-- objects the server embeds in the 'GetDetectorResponse'. Both default +-- to 'False' via 'defaultGetDetectorParams', reproducing the bare GET. +-- See +data GetDetectorParams = GetDetectorParams + { -- | @?job=true@ — embed 'getDetectorResponseJob' (real-time job + -- schedule / state). + getDetectorParamsJob :: Bool, + -- | @?task=true@ — embed 'getDetectorResponseRealtimeTask' and + -- 'getDetectorResponseHistoricalTask' (running task records). + getDetectorParamsTask :: Bool + } + deriving stock (Eq, Show) + +-- | The all-false 'GetDetectorParams', equivalent to a bare GET. +defaultGetDetectorParams :: GetDetectorParams +defaultGetDetectorParams = GetDetectorParams {getDetectorParamsJob = False, getDetectorParamsTask = False} + +-- ========================================================================= +-- Detector job (anomaly_detector_job, returned with ?job=true) +-- ========================================================================= + +-- | The @anomaly_detector_job@ object the server embeds in a +-- 'GetDetectorResponse' when the request carries @?job=true@. The job +-- binds the real-time detector's schedule and runtime bookkeeping. +-- All fields are 'Maybe' because the docs describe the shape only by +-- example; some may be absent for internal or disabled detectors. +-- See +data DetectorJob = DetectorJob + { detectorJobName :: Maybe Text, + detectorJobSchedule :: Maybe DetectorJobSchedule, + detectorJobWindowDelay :: Maybe WindowPeriod, + detectorJobEnabled :: Maybe Bool, + detectorJobEnabledTime :: Maybe Integer, + detectorJobLastUpdateTime :: Maybe Integer, + detectorJobLockDurationSeconds :: Maybe Int, + detectorJobUser :: Maybe User + } + deriving stock (Eq, Show) + +instance FromJSON DetectorJob where + parseJSON = withObject "DetectorJob" $ \v -> do + detectorJobName <- v .:? "name" + detectorJobSchedule <- v .:? "schedule" + detectorJobWindowDelay <- v .:? "window_delay" + detectorJobEnabled <- v .:? "enabled" + detectorJobEnabledTime <- v .:? "enabled_time" + detectorJobLastUpdateTime <- v .:? "last_update_time" + detectorJobLockDurationSeconds <- v .:? "lock_duration_seconds" + detectorJobUser <- v .:? "user" + pure DetectorJob {..} + +instance ToJSON DetectorJob where + toJSON DetectorJob {..} = + omitNulls + [ "name" .= detectorJobName, + "schedule" .= detectorJobSchedule, + "window_delay" .= detectorJobWindowDelay, + "enabled" .= detectorJobEnabled, + "enabled_time" .= detectorJobEnabledTime, + "last_update_time" .= detectorJobLastUpdateTime, + "lock_duration_seconds" .= detectorJobLockDurationSeconds, + "user" .= detectorJobUser + ] + +-- | The @schedule@ object of a 'DetectorJob'. The docs only show the +-- 'DetectorJobScheduleInterval' (@{interval: {...}}@) form; other +-- schedule variants (e.g. cron) are not documented and would need a +-- follow-up to type. They surface as a decode failure today. +-- See +data DetectorJobSchedule = DetectorJobSchedule + { detectorJobScheduleInterval :: DetectorJobScheduleInterval + } + deriving stock (Eq, Show) + +instance FromJSON DetectorJobSchedule where + parseJSON = withObject "DetectorJobSchedule" $ \v -> do + detectorJobScheduleInterval <- v .: "interval" + pure DetectorJobSchedule {..} + +instance ToJSON DetectorJobSchedule where + toJSON DetectorJobSchedule {..} = + object ["interval" .= detectorJobScheduleInterval] + +-- | The @interval@ object inside a 'DetectorJobSchedule'. Mirrors the +-- 'WindowPeriod' @{interval, unit}@ pair but adds an optional +-- @start_time@ (epoch ms) the scheduler uses to stagger the first run. +-- See +data DetectorJobScheduleInterval = DetectorJobScheduleInterval + { detectorJobScheduleIntervalStartTime :: Maybe Integer, + detectorJobScheduleIntervalPeriod :: Int, + detectorJobScheduleIntervalUnit :: PeriodUnit + } + deriving stock (Eq, Show) + +instance FromJSON DetectorJobScheduleInterval where + parseJSON = withObject "DetectorJobScheduleInterval" $ \v -> do + detectorJobScheduleIntervalStartTime <- v .:? "start_time" + detectorJobScheduleIntervalPeriod <- v .: "period" + detectorJobScheduleIntervalUnit <- v .: "unit" + pure DetectorJobScheduleInterval {..} + +instance ToJSON DetectorJobScheduleInterval where + toJSON DetectorJobScheduleInterval {..} = + omitNulls + [ "start_time" .= detectorJobScheduleIntervalStartTime, + "period" .= detectorJobScheduleIntervalPeriod, + "unit" .= detectorJobScheduleIntervalUnit + ] + +-- ========================================================================= +-- Detection tasks (realtime_detection_task / historical_analysis_task, +-- returned with ?task=true) +-- ========================================================================= + +-- | The @task_type@ enum carried by a 'DetectionTask'. The docs +-- enumerate the two single-entity values (@REALTIME_SINGLE_ENTITY@, +-- @HISTORICAL_SINGLE_ENTITY@); the two multi-entity values +-- (@REALTIME_MULTI_ENTITY@, @HISTORICAL_MULTI_ENTITY@) are inferred from +-- the naming convention. Unknown values parse as +-- 'DetectionTaskTypeCustom' so future plugin releases surface as a +-- parsed value rather than a decode failure. +data DetectionTaskType + = DetectionTaskTypeRealtimeSingleEntity + | DetectionTaskTypeHistoricalSingleEntity + | DetectionTaskTypeRealtimeMultiEntity + | DetectionTaskTypeHistoricalMultiEntity + | DetectionTaskTypeCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'DetectionTaskType' — the same mapping the +-- 'ToJSON' \/ 'FromJSON' instances use. +detectionTaskTypeText :: DetectionTaskType -> Text +detectionTaskTypeText = \case + DetectionTaskTypeRealtimeSingleEntity -> "REALTIME_SINGLE_ENTITY" + DetectionTaskTypeHistoricalSingleEntity -> "HISTORICAL_SINGLE_ENTITY" + DetectionTaskTypeRealtimeMultiEntity -> "REALTIME_MULTI_ENTITY" + DetectionTaskTypeHistoricalMultiEntity -> "HISTORICAL_MULTI_ENTITY" + DetectionTaskTypeCustom t -> t + +instance ToJSON DetectionTaskType where + toJSON = toJSON . detectionTaskTypeText + +instance FromJSON DetectionTaskType where + parseJSON = withText "DetectionTaskType" $ \case + "REALTIME_SINGLE_ENTITY" -> pure DetectionTaskTypeRealtimeSingleEntity + "HISTORICAL_SINGLE_ENTITY" -> pure DetectionTaskTypeHistoricalSingleEntity + "REALTIME_MULTI_ENTITY" -> pure DetectionTaskTypeRealtimeMultiEntity + "HISTORICAL_MULTI_ENTITY" -> pure DetectionTaskTypeHistoricalMultiEntity + other -> pure (DetectionTaskTypeCustom other) + +-- | A detection task record. The server embeds one of these under +-- @realtime_detection_task@ (the running real-time job) and/or +-- @historical_analysis_task@ (a historical backfill batch) in a +-- 'GetDetectorResponse' when the request carries @?task=true@. +-- +-- The shape is the union of the two documented examples: some fields +-- appear only on the real-time variant (@estimated_minutes_left@) and +-- some only on the historical variant (@current_piece@, @worker_node@, +-- 'detectionTaskDetectionDateRange'), so every field except @task_id@ +-- is 'Maybe'. Progress fractions are 'Scientific' because the plugin +-- emits them as either an integer (@0@) or a fraction (@0.89285713@); +-- 'Scientific' round-trips both losslessly. +-- See +data DetectionTask = DetectionTask + { detectionTaskTaskId :: Text, + detectionTaskType :: Maybe DetectionTaskType, + detectionTaskState :: Maybe Text, + detectionTaskDetectorId :: Maybe DetectorId, + detectionTaskDetector :: Maybe DetectorResponse, + detectionTaskTaskProgress :: Maybe Scientific, + detectionTaskInitProgress :: Maybe Scientific, + detectionTaskIsLatest :: Maybe Bool, + detectionTaskExecutionStartTime :: Maybe Integer, + detectionTaskLastUpdateTime :: Maybe Integer, + detectionTaskCurrentPiece :: Maybe Integer, + detectionTaskDetectionDateRange :: Maybe DetectionDateRange, + detectionTaskEstimatedMinutesLeft :: Maybe Int, + detectionTaskCoordinatingNode :: Maybe Text, + detectionTaskWorkerNode :: Maybe Text, + detectionTaskStartedBy :: Maybe Text, + detectionTaskError :: Maybe Text, + detectionTaskUser :: Maybe User + } + deriving stock (Eq, Show) + +instance FromJSON DetectionTask where + parseJSON = withObject "DetectionTask" $ \v -> do + detectionTaskTaskId <- v .: "task_id" + detectionTaskType <- v .:? "task_type" + detectionTaskState <- v .:? "state" + detectionTaskDetectorId <- v .:? "detector_id" + detectionTaskDetector <- v .:? "detector" + detectionTaskTaskProgress <- v .:? "task_progress" + detectionTaskInitProgress <- v .:? "init_progress" + detectionTaskIsLatest <- v .:? "is_latest" + detectionTaskExecutionStartTime <- v .:? "execution_start_time" + detectionTaskLastUpdateTime <- v .:? "last_update_time" + detectionTaskCurrentPiece <- v .:? "current_piece" + detectionTaskDetectionDateRange <- v .:? "detection_date_range" + detectionTaskEstimatedMinutesLeft <- v .:? "estimated_minutes_left" + detectionTaskCoordinatingNode <- v .:? "coordinating_node" + detectionTaskWorkerNode <- v .:? "worker_node" + detectionTaskStartedBy <- v .:? "started_by" + detectionTaskError <- v .:? "error" + detectionTaskUser <- v .:? "user" + pure DetectionTask {..} + +instance ToJSON DetectionTask where + toJSON DetectionTask {..} = + omitNulls + [ "task_id" .= detectionTaskTaskId, + "task_type" .= detectionTaskType, + "state" .= detectionTaskState, + "detector_id" .= detectionTaskDetectorId, + "detector" .= detectionTaskDetector, + "task_progress" .= detectionTaskTaskProgress, + "init_progress" .= detectionTaskInitProgress, + "is_latest" .= detectionTaskIsLatest, + "execution_start_time" .= detectionTaskExecutionStartTime, + "last_update_time" .= detectionTaskLastUpdateTime, + "current_piece" .= detectionTaskCurrentPiece, + "detection_date_range" .= detectionTaskDetectionDateRange, + "estimated_minutes_left" .= detectionTaskEstimatedMinutesLeft, + "coordinating_node" .= detectionTaskCoordinatingNode, + "worker_node" .= detectionTaskWorkerNode, + "started_by" .= detectionTaskStartedBy, + "error" .= detectionTaskError, + "user" .= detectionTaskUser + ] + +-- | The @detection_date_range@ object carried by a historical +-- 'DetectionTask'. Bounds the historical window the batch is +-- backfilling, as epoch-ms timestamps. Absent on real-time tasks. +-- See +data DetectionDateRange = DetectionDateRange + { detectionDateRangeStartTime :: Maybe Integer, + detectionDateRangeEndTime :: Maybe Integer + } + deriving stock (Eq, Show) + +instance FromJSON DetectionDateRange where + parseJSON = withObject "DetectionDateRange" $ \v -> do + detectionDateRangeStartTime <- v .:? "start_time" + detectionDateRangeEndTime <- v .:? "end_time" + pure DetectionDateRange {..} + +instance ToJSON DetectionDateRange where + toJSON DetectionDateRange {..} = + omitNulls + [ "start_time" .= detectionDateRangeStartTime, + "end_time" .= detectionDateRangeEndTime + ] + +-- ========================================================================= +-- Preview endpoint: POST /_plugins/_anomaly_detection/detectors/_preview +-- ========================================================================= + +-- | Request body for the Anomaly Detection plugin Preview Detector API +-- (@POST /_plugins/_anomaly_detection/detectors/_preview@). The two +-- fields @period_start@ and @period_end@ are epoch-ms timestamps +-- bracketing the historical window the plugin should re-analyze. The +-- plugin requires both (a missing value yields HTTP 400 with +-- @Must set both period start and end date with epoch of milliseconds@). +-- +-- The optional 'previewRequestDetectorId' names the detector to preview +-- (set by 'previewDetector' from its path argument, or directly by the +-- caller of 'previewDetectorInline'); 'previewRequestDetector' carries a +-- full unpersisted 'Detector' config for the inline form. Both are +-- omitted from the wire payload when 'Nothing', so a periods-only body +-- round-trips as just the two timestamps. +-- See +data PreviewRequest = PreviewRequest + { previewRequestPeriodStart :: Integer, + previewRequestPeriodEnd :: Integer, + previewRequestDetector :: Maybe Detector, + previewRequestDetectorId :: Maybe DetectorId + } + deriving stock (Eq, Show) + +instance FromJSON PreviewRequest where + parseJSON = withObject "PreviewRequest" $ \v -> do + previewRequestPeriodStart <- v .: "period_start" + previewRequestPeriodEnd <- v .: "period_end" + previewRequestDetector <- v .:? "detector" + previewRequestDetectorId <- v .:? "detector_id" + pure PreviewRequest {..} + +instance ToJSON PreviewRequest where + toJSON PreviewRequest {..} = + omitNulls + [ "period_start" .= previewRequestPeriodStart, + "period_end" .= previewRequestPeriodEnd, + "detector" .= previewRequestDetector, + "detector_id" .= previewRequestDetectorId + ] + +-- | One entry in the @feature_data@ array of an 'AnomalyResult'. The +-- @feature_id@ echoes the corresponding 'FeatureAttribute' identifier; +-- @data@ is the observed feature value for the window. Both come back +-- as @0@ in fresh / sparse fixtures, so they are 'Maybe' for safety. +data FeatureData = FeatureData + { featureDataFeatureId :: Maybe Text, + featureDataFeatureName :: Text, + featureDataData :: Maybe Double + } + deriving stock (Eq, Show) + +instance FromJSON FeatureData where + parseJSON = withObject "FeatureData" $ \v -> do + featureDataFeatureId <- v .:? "feature_id" + featureDataFeatureName <- v .: "feature_name" + featureDataData <- v .:? "data" + pure FeatureData {..} + +instance ToJSON FeatureData where + toJSON FeatureData {..} = + omitNulls + [ "feature_id" .= featureDataFeatureId, + "feature_name" .= featureDataFeatureName, + "data" .= featureDataData + ] + +-- | One entry in the @entity@ array of a multi-entity 'AnomalyResult'. +-- The plugin emits @entity@ only when the detector was created with a +-- @category_field@; each entry names the categorical dimension +-- (@name@) and the value the anomaly was graded against (@value@). +-- See +data Entity = Entity + { entityName :: Text, + entityValue :: Text + } + deriving stock (Eq, Show) + +instance FromJSON Entity where + parseJSON = withObject "Entity" $ \v -> do + entityName <- v .: "name" + entityValue <- v .: "value" + pure Entity {..} + +instance ToJSON Entity where + toJSON Entity {..} = + object + [ "name" .= entityName, + "value" .= entityValue + ] + +-- | One entry in the @anomaly_result@ array of a 'PreviewResponse'. +-- Every field is 'Maybe' or has a sensible empty default because the +-- plugin emits a sparse shape early in training (zero @anomaly_grade@, +-- zero @confidence@, empty @feature_data@) and a fuller shape once the +-- model has converged. +-- See +data AnomalyResult = AnomalyResult + { anomalyResultDetectorId :: Maybe Text, + anomalyResultDataStartTime :: Integer, + anomalyResultDataEndTime :: Integer, + anomalyResultSchemaVersion :: Maybe Int, + anomalyResultFeatureData :: [FeatureData], + anomalyResultAnomalyGrade :: Maybe Double, + anomalyResultConfidence :: Maybe Double, + anomalyResultEntity :: Maybe [Entity], + anomalyResultUser :: Maybe User + } + deriving stock (Eq, Show) + +instance FromJSON AnomalyResult where + parseJSON = withObject "AnomalyResult" $ \v -> do + anomalyResultDetectorId <- v .:? "detector_id" + anomalyResultDataStartTime <- v .: "data_start_time" + anomalyResultDataEndTime <- v .: "data_end_time" + anomalyResultSchemaVersion <- v .:? "schema_version" + anomalyResultFeatureData <- v .:? "feature_data" .!= [] + anomalyResultAnomalyGrade <- v .:? "anomaly_grade" + anomalyResultConfidence <- v .:? "confidence" + anomalyResultEntity <- v .:? "entity" + anomalyResultUser <- v .:? "user" + pure AnomalyResult {..} + +instance ToJSON AnomalyResult where + toJSON AnomalyResult {..} = + omitNulls + [ "detector_id" .= anomalyResultDetectorId, + "data_start_time" .= anomalyResultDataStartTime, + "data_end_time" .= anomalyResultDataEndTime, + "schema_version" .= anomalyResultSchemaVersion, + "feature_data" .= anomalyResultFeatureData, + "anomaly_grade" .= anomalyResultAnomalyGrade, + "confidence" .= anomalyResultConfidence, + "entity" .= anomalyResultEntity, + "user" .= anomalyResultUser + ] + +-- | Response body of @_preview@: an @anomaly_result@ array plus the +-- detector snapshot the plugin graded against (the same +-- 'DetectorResponse' shape returned by create / get). +-- See +data PreviewResponse = PreviewResponse + { previewResponseAnomalyResult :: [AnomalyResult], + previewResponseAnomalyDetector :: DetectorResponse + } + deriving stock (Eq, Show) + +instance FromJSON PreviewResponse where + parseJSON = withObject "PreviewResponse" $ \v -> do + previewResponseAnomalyResult <- v .:? "anomaly_result" .!= [] + previewResponseAnomalyDetector <- v .: "anomaly_detector" + pure PreviewResponse {..} + +instance ToJSON PreviewResponse where + toJSON PreviewResponse {..} = + object + [ "anomaly_result" .= previewResponseAnomalyResult, + "anomaly_detector" .= previewResponseAnomalyDetector + ] + +-- ========================================================================= +-- Update / Delete detector +-- ========================================================================= + +-- | The standard @{total, successful, skipped, failed}@ shard-report +-- sub-object carried by AD delete and search responses. Defined locally +-- (mirroring the 'AlertingShards' pattern) rather than borrowing a +-- Common type, to keep the AD module self-contained. +data AnomalyShards = AnomalyShards + { anomalyShardsTotal :: Int, + anomalyShardsSuccessful :: Int, + anomalyShardsSkipped :: Int, + anomalyShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON AnomalyShards where + parseJSON = withObject "AnomalyShards" $ \v -> + AnomalyShards + <$> v .:? "total" .!= 0 + <*> v .:? "successful" .!= 0 + <*> v .:? "skipped" .!= 0 + <*> v .:? "failed" .!= 0 + +instance ToJSON AnomalyShards where + toJSON AnomalyShards {..} = + object + [ "total" .= anomalyShardsTotal, + "successful" .= anomalyShardsSuccessful, + "skipped" .= anomalyShardsSkipped, + "failed" .= anomalyShardsFailed + ] + +-- | Response body of @DELETE /_plugins/_anomaly_detection/detectors/{id}@. +-- The AD delete endpoint returns the bare Elasticsearch delete-document +-- envelope (@_index@, @_id@, @_version@, @result@, @forced_refresh@, +-- @_shards@, @_seq_no@, @_primary_term@) — NOT an @{acknowledged: true}@ +-- ack, so an 'Acknowledged' decoder would raise 'EsProtocolException' at +-- runtime. Modelled verbatim, mirroring the Alerting 'DeleteMonitorResponse' +-- and Security Analytics 'DeleteSADetectorResponse' precedent. +-- See +data DeleteDetectorResponse = DeleteDetectorResponse + { deleteDetectorResponseIndex :: Text, + deleteDetectorResponseId :: Text, + deleteDetectorResponseVersion :: Int, + deleteDetectorResponseResult :: Text, + deleteDetectorResponseForcedRefresh :: Bool, + deleteDetectorResponseShards :: AnomalyShards, + deleteDetectorResponseSeqNo :: Int, + deleteDetectorResponsePrimaryTerm :: Int + } + deriving stock (Eq, Show) + +instance FromJSON DeleteDetectorResponse where + parseJSON = withObject "DeleteDetectorResponse" $ \v -> + DeleteDetectorResponse + <$> v .: "_index" + <*> v .: "_id" + <*> v .: "_version" + <*> v .: "result" + <*> v .:? "forced_refresh" .!= False + <*> v .: "_shards" + <*> v .: "_seq_no" + <*> v .: "_primary_term" + +instance ToJSON DeleteDetectorResponse where + toJSON DeleteDetectorResponse {..} = + object + [ "_index" .= deleteDetectorResponseIndex, + "_id" .= deleteDetectorResponseId, + "_version" .= deleteDetectorResponseVersion, + "result" .= deleteDetectorResponseResult, + "forced_refresh" .= deleteDetectorResponseForcedRefresh, + "_shards" .= deleteDetectorResponseShards, + "_seq_no" .= deleteDetectorResponseSeqNo, + "_primary_term" .= deleteDetectorResponsePrimaryTerm + ] + +-- ========================================================================= +-- Start / Stop detector job +-- ========================================================================= + +-- | Request body for the historical-analysis form of +-- @POST /_plugins/_anomaly_detection/detectors/{id}/_start@. +-- +-- The @_start@ endpoint serves two roles: with no body it starts the +-- real-time detector job, and with a body it kicks off a one-shot +-- historical backfill over the window bounded by +-- 'startDetectorJobRequestStartTime' / 'startDetectorJobRequestEndTime' +-- (epoch milliseconds). Both @start_time@ and @end_time@ are required +-- when a body is sent; the server returns a 'DetectorJobAcknowledgment' +-- whose @_id@ is the historical batch task id (a UUID), distinct from +-- the detector id returned by the real-time form. +-- See +data StartDetectorJobRequest = StartDetectorJobRequest + { startDetectorJobRequestStartTime :: Integer, + startDetectorJobRequestEndTime :: Integer + } + deriving stock (Eq, Show) + +instance FromJSON StartDetectorJobRequest where + parseJSON = withObject "StartDetectorJobRequest" $ \v -> do + startDetectorJobRequestStartTime <- v .: "start_time" + startDetectorJobRequestEndTime <- v .: "end_time" + pure StartDetectorJobRequest {..} + +instance ToJSON StartDetectorJobRequest where + toJSON StartDetectorJobRequest {..} = + object + [ "start_time" .= startDetectorJobRequestStartTime, + "end_time" .= startDetectorJobRequestEndTime + ] + +-- | Response body of @_start@ and @_stop@. Both endpoints return the +-- same small write-acknowledgment envelope (@_id@, @_version@, +-- @_seq_no@, @_primary_term@). For @_start@, @_id@ is the real-time job +-- id (= the detector id) when no body is sent, or the historical batch +-- task id (a UUID) when a 'StartDetectorJobRequest' body is sent. For +-- @_stop@, @_version@, @_seq_no@ and @_primary_term@ are zeroed on +-- success. Note @_version@ is a plain 'Int' (not 'DocVersion') because +-- the @_stop@ response legitimately carries @0@, which is below +-- 'DocVersion'\'s @minBound@ of @1@. +-- See +-- and +data DetectorJobAcknowledgment = DetectorJobAcknowledgment + { detectorJobAcknowledgmentId :: Text, + detectorJobAcknowledgmentVersion :: Int, + detectorJobAcknowledgmentSeqNo :: Int, + detectorJobAcknowledgmentPrimaryTerm :: Int + } + deriving stock (Eq, Show) + +instance FromJSON DetectorJobAcknowledgment where + parseJSON = withObject "DetectorJobAcknowledgment" $ \v -> do + detectorJobAcknowledgmentId <- v .: "_id" + -- OS 3.x only returns @_id@ for start/stop acknowledgments; the + -- @_version@, @_seq_no@, @_primary_term@ fields are absent (older + -- docs and some patch levels emit them zeroed). Default to 0 when + -- missing so the parser tolerates both wire shapes. + detectorJobAcknowledgmentVersion <- v .:? "_version" .!= 0 + detectorJobAcknowledgmentSeqNo <- v .:? "_seq_no" .!= 0 + detectorJobAcknowledgmentPrimaryTerm <- v .:? "_primary_term" .!= 0 + pure DetectorJobAcknowledgment {..} + +instance ToJSON DetectorJobAcknowledgment where + toJSON DetectorJobAcknowledgment {..} = + object + [ "_id" .= detectorJobAcknowledgmentId, + "_version" .= detectorJobAcknowledgmentVersion, + "_seq_no" .= detectorJobAcknowledgmentSeqNo, + "_primary_term" .= detectorJobAcknowledgmentPrimaryTerm + ] + +-- ========================================================================= +-- Validate detector: POST /_plugins/_anomaly_detection/detectors/_validate[/mode] +-- ========================================================================= + +-- | Selects the validation mode (the trailing path segment). The bare +-- @\/_validate@ form is a server-side alias for @\/_validate\/detector@; +-- 'ValidateDetector' covers both. @\/_validate\/model@ validates against +-- source data and is advisory only. +-- See +data ValidateDetectorMode = ValidateDetector | ValidateModel + deriving stock (Eq, Show) + +-- | The trailing path segment(s) for 'ValidateDetectorMode' — empty for +-- the detector default (bare @\/_validate@), @["model"]@ for the model +-- advisory check. +validateDetectorModeSegments :: ValidateDetectorMode -> [Text] +validateDetectorModeSegments = \case + ValidateDetector -> [] + ValidateModel -> ["model"] + +-- | Response body of the validate endpoint. Variable by outcome: an empty +-- object @{}@ when no issues are found; @{"detector": {...}}@ for blocking +-- issues from @\/_validate\/detector@; @{"model": {...}}@ for advisory +-- issues from @\/_validate\/model@. Carried as an opaque aeson 'Value' so +-- every shape round-trips losslessly (the pragmatic-typing precedent used +-- for ML Commons @predict@). +newtype ValidateDetectorResponse = ValidateDetectorResponse + { getValidateDetectorResponse :: Value + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- ========================================================================= +-- Search envelope: detectors / results / tasks +-- ========================================================================= + +-- | The @hits.total.relation@ discriminator on an AD search response. +data AnomalySearchTotalRelation + = AnomalySearchTotalRelationEq + | AnomalySearchTotalRelationGe + | AnomalySearchTotalRelationOther Text + deriving stock (Eq, Show) + +instance FromJSON AnomalySearchTotalRelation where + parseJSON = withText "AnomalySearchTotalRelation" $ \case + "eq" -> pure AnomalySearchTotalRelationEq + "ge" -> pure AnomalySearchTotalRelationGe + other -> pure (AnomalySearchTotalRelationOther other) + +instance ToJSON AnomalySearchTotalRelation where + toJSON = \case + AnomalySearchTotalRelationEq -> "eq" + AnomalySearchTotalRelationGe -> "ge" + AnomalySearchTotalRelationOther t -> toJSON t + +-- | The @hits.total@ sub-object on an AD search response +-- (@{value, relation}@). +data AnomalySearchTotal = AnomalySearchTotal + { anomalySearchTotalValue :: Int, + anomalySearchTotalRelation :: AnomalySearchTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON AnomalySearchTotal where + parseJSON = withObject "AnomalySearchTotal" $ \v -> + AnomalySearchTotal + <$> v .: "value" + <*> v .: "relation" + +instance ToJSON AnomalySearchTotal where + toJSON AnomalySearchTotal {..} = + object + [ "value" .= anomalySearchTotalValue, + "relation" .= anomalySearchTotalRelation + ] + +-- | A single hit in @hits.hits[]@ on an AD search response. The @_source@ +-- is decoded as the @source@ type parameter: 'DetectorResponse' for the +-- detector-config index, 'Value' for the variable anomaly-result and task +-- records (pragmatic typing — the full schema lives in the separate AD +-- result-mapping doc page). +data AnomalySearchHit source = AnomalySearchHit + { anomalySearchHitIndex :: Maybe Text, + anomalySearchHitId :: Text, + anomalySearchHitVersion :: Maybe Int, + anomalySearchHitSeqNo :: Maybe Int, + anomalySearchHitPrimaryTerm :: Maybe Int, + anomalySearchHitScore :: Maybe Double, + anomalySearchHitSource :: source + } + deriving stock (Eq, Show) + +instance (FromJSON source) => FromJSON (AnomalySearchHit source) where + parseJSON = withObject "AnomalySearchHit" $ \v -> + AnomalySearchHit + <$> v .:? "_index" + <*> v .: "_id" + <*> v .:? "_version" + <*> v .:? "_seq_no" + <*> v .:? "_primary_term" + <*> v .:? "_score" + <*> v .: "_source" + +instance (ToJSON source) => ToJSON (AnomalySearchHit source) where + toJSON AnomalySearchHit {..} = + omitNulls + [ "_index" .= anomalySearchHitIndex, + "_id" .= anomalySearchHitId, + "_version" .= anomalySearchHitVersion, + "_seq_no" .= anomalySearchHitSeqNo, + "_primary_term" .= anomalySearchHitPrimaryTerm, + "_score" .= anomalySearchHitScore, + "_source" .= anomalySearchHitSource + ] + +-- | The standard OpenSearch search-response envelope +-- (@took@, @timed_out@, @_shards@, @hits.total@, @hits.max_score@, +-- @hits.hits@) parametrised by the @_source@ type. Specialised by the AD +-- search endpoints: +-- +-- * 'SearchDetectorsResponse' — @_source@ is a typed 'DetectorResponse'. +-- * 'SearchDetectorResultsResponse' / 'SearchDetectorTasksResponse' — +-- @_source@ is an opaque 'Value' (the anomaly-result and task records +-- carry many optional fields; the full mapping lives in a separate doc +-- page). +data AnomalySearchResponse source = AnomalySearchResponse + { anomalySearchResponseTook :: Int, + anomalySearchResponseTimedOut :: Bool, + anomalySearchResponseShards :: AnomalyShards, + anomalySearchResponseTotal :: AnomalySearchTotal, + anomalySearchResponseMaxScore :: Maybe Double, + anomalySearchResponseHits :: [AnomalySearchHit source] + } + deriving stock (Eq, Show) + +instance (FromJSON source) => FromJSON (AnomalySearchResponse source) where + parseJSON = withObject "AnomalySearchResponse" $ \v -> do + hits <- v .: "hits" + AnomalySearchResponse + <$> v .: "took" + <*> v .: "timed_out" + <*> v .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance (ToJSON source) => ToJSON (AnomalySearchResponse source) where + toJSON AnomalySearchResponse {..} = + object + [ "took" .= anomalySearchResponseTook, + "timed_out" .= anomalySearchResponseTimedOut, + "_shards" .= anomalySearchResponseShards, + "hits" + .= object + [ "total" .= anomalySearchResponseTotal, + "max_score" .= anomalySearchResponseMaxScore, + "hits" .= anomalySearchResponseHits + ] + ] + +-- | Project the @source@ values out of an 'AnomalySearchResponse' +-- (convenience for callers who only want the hits). +anomalySearchResponseSources :: AnomalySearchResponse source -> [source] +anomalySearchResponseSources = map anomalySearchHitSource . anomalySearchResponseHits + +-- | Response of @POST /_plugins/_anomaly_detection/detectors/_search@ — +-- a search over the detector-config index. @_source@ is a typed +-- 'DetectorResponse'. +type SearchDetectorsResponse = AnomalySearchResponse DetectorResponse + +-- | Response of @POST /_plugins/_anomaly_detection/detectors/results/_search@. +-- @_source@ is an opaque 'Value' (the anomaly-result record). +type SearchDetectorResultsResponse = AnomalySearchResponse Value + +-- | Response of @DELETE /_plugins/_anomaly_detection/detectors/results@. +-- The plugin returns the bare @_delete_by_query@ envelope, which is +-- structurally identical to the document-API 'DeletedDocuments' — we +-- alias to it rather than duplicate the type. Fork here (make a +-- dedicated AD type) if the plugin ever diverges from the document +-- envelope. +type DeleteDetectorResultsResponse = DeletedDocuments + +-- | Response of @POST /_plugins/_anomaly_detection/detectors/tasks/_search@. +-- @_source@ is an opaque 'Value' (the task record). +type SearchDetectorTasksResponse = AnomalySearchResponse Value + +-- ========================================================================= +-- Profile detector: GET /_plugins/_anomaly_detection/detectors/{id}/_profile[/types|?_all=true] +-- ========================================================================= + +-- | Response body of the profile endpoint. The shape varies widely by +-- requested profile kind (@_profile@, @_profile\/{type}@, @?_all=true@, +-- entity-filtered) and by detector kind (single-entity vs +-- high-cardinality); the docs enumerate many distinct sub-shapes. +-- Carried as an opaque aeson 'Value' so every variant round-trips +-- losslessly (pragmatic-typing precedent). +-- See +newtype DetectorProfileResponse = DetectorProfileResponse + { getDetectorProfileResponse :: Value + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- ========================================================================= +-- Detector stats: GET /_plugins/_anomaly_detection/stats[/{stat}] etc. +-- ========================================================================= + +-- | Response body of the stats endpoint. The full form returns several +-- top-level index-status keys plus a @nodes@ map; the filtered forms +-- (@\/stats\/{stat}@, @\/{node_id}\/stats@) return only a subset. +-- Carried as an opaque aeson 'Value' (pragmatic-typing precedent) so the +-- variable top-level surface round-trips losslessly. +-- See +newtype DetectorStatsResponse = DetectorStatsResponse + { getDetectorStatsResponse :: Value + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- ========================================================================= +-- Top anomalies: GET /_plugins/_anomaly_detection/detectors/{id}/results/_topAnomalies +-- ========================================================================= + +-- | The @order@ enum for 'TopAnomaliesRequest' — @severity@ (default) or +-- @occurrence@. +data TopAnomaliesOrder + = TopAnomaliesOrderSeverity + | TopAnomaliesOrderOccurrence + deriving stock (Eq, Show) + +-- | Wire string for a 'TopAnomaliesOrder'. +topAnomaliesOrderText :: TopAnomaliesOrder -> Text +topAnomaliesOrderText = \case + TopAnomaliesOrderSeverity -> "severity" + TopAnomaliesOrderOccurrence -> "occurrence" + +instance ToJSON TopAnomaliesOrder where + toJSON = toJSON . topAnomaliesOrderText + +instance FromJSON TopAnomaliesOrder where + parseJSON = withText "TopAnomaliesOrder" $ \case + "severity" -> pure TopAnomaliesOrderSeverity + "occurrence" -> pure TopAnomaliesOrderOccurrence + other -> + fail ("unknown TopAnomaliesOrder: " <> T.unpack other) + +-- | Request body for the top-anomalies endpoint (sent with the GET). +-- @start_time_ms@ and @end_time_ms@ are required epoch-ms; the rest are +-- optional. 'Nothing' for @size@ leaves the server default (10, max +-- 10000); 'Nothing' for @category_field@ defaults to all detector +-- category fields; 'Nothing' for @task_id@ is only meaningful when the +-- request is historical (ignored otherwise). +-- See +data TopAnomaliesRequest = TopAnomaliesRequest + { topAnomaliesRequestSize :: Maybe Int, + topAnomaliesRequestCategoryField :: Maybe [Text], + topAnomaliesRequestOrder :: Maybe TopAnomaliesOrder, + topAnomaliesRequestTaskId :: Maybe Text, + topAnomaliesRequestStartTimeMs :: Integer, + topAnomaliesRequestEndTimeMs :: Integer + } + deriving stock (Eq, Show) + +-- | The minimal 'TopAnomaliesRequest' carrying only the two required +-- epoch-ms timestamps; every optional field is 'Nothing' (server +-- defaults). +defaultTopAnomaliesRequest :: Integer -> Integer -> TopAnomaliesRequest +defaultTopAnomaliesRequest start end = + TopAnomaliesRequest + { topAnomaliesRequestSize = Nothing, + topAnomaliesRequestCategoryField = Nothing, + topAnomaliesRequestOrder = Nothing, + topAnomaliesRequestTaskId = Nothing, + topAnomaliesRequestStartTimeMs = start, + topAnomaliesRequestEndTimeMs = end + } + +instance ToJSON TopAnomaliesRequest where + toJSON TopAnomaliesRequest {..} = + omitNulls + [ "size" .= topAnomaliesRequestSize, + "category_field" .= topAnomaliesRequestCategoryField, + "order" .= topAnomaliesRequestOrder, + "task_id" .= topAnomaliesRequestTaskId, + "start_time_ms" .= topAnomaliesRequestStartTimeMs, + "end_time_ms" .= topAnomaliesRequestEndTimeMs + ] + +instance FromJSON TopAnomaliesRequest where + parseJSON = withObject "TopAnomaliesRequest" $ \v -> + TopAnomaliesRequest + <$> v .:? "size" + <*> v .:? "category_field" + <*> v .:? "order" + <*> v .:? "task_id" + <*> v .: "start_time_ms" + <*> v .: "end_time_ms" + +-- | One bucket in the top-anomalies response: a categorical @key@ (a map +-- from category-field name to value), the @doc_count@ of anomalies in +-- that bucket, and the @max_anomaly_grade@ observed. +data TopAnomalyBucket = TopAnomalyBucket + { topAnomalyBucketKey :: Value, + topAnomalyBucketDocCount :: Int, + topAnomalyBucketMaxAnomalyGrade :: Double + } + deriving stock (Eq, Show) + +instance FromJSON TopAnomalyBucket where + parseJSON = withObject "TopAnomalyBucket" $ \v -> + TopAnomalyBucket + <$> v .: "key" + <*> v .: "doc_count" + <*> v .: "max_anomaly_grade" + +instance ToJSON TopAnomalyBucket where + toJSON TopAnomalyBucket {..} = + object + [ "key" .= topAnomalyBucketKey, + "doc_count" .= topAnomalyBucketDocCount, + "max_anomaly_grade" .= topAnomalyBucketMaxAnomalyGrade + ] + +-- | Response body of the top-anomalies endpoint: a @buckets@ array of +-- 'TopAnomalyBucket'. +-- See +data TopAnomaliesResponse = TopAnomaliesResponse + { topAnomaliesResponseBuckets :: [TopAnomalyBucket] + } + deriving stock (Eq, Show) + +instance FromJSON TopAnomaliesResponse where + parseJSON = withObject "TopAnomaliesResponse" $ \v -> + TopAnomaliesResponse + <$> v .:? "buckets" .!= [] + +instance ToJSON TopAnomaliesResponse where + toJSON TopAnomaliesResponse {..} = + object ["buckets" .= topAnomaliesResponseBuckets] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/CCR.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/CCR.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/CCR.hs @@ -0,0 +1,573 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.CCR + ( -- * Requests + ReplicationUseRoles (..), + StartReplicationRequest (..), + UpdateReplicationSettingsRequest (..), + CreateAutoFollowPatternRequest (..), + DeleteAutoFollowPatternRequest (..), + + -- * Status + ReplicationStatus (..), + replicationStatusText, + SyncingDetails (..), + ReplicationStatusResponse (..), + ReplicationStatusOptions (..), + defaultReplicationStatusOptions, + replicationStatusOptionsParams, + + -- * Leader stats + LeaderIndexStats (..), + LeaderStatsResponse (..), + + -- * Follower stats + FollowerIndexStats (..), + FollowerStatsResponse (..), + + -- * Auto-follow stats + AutoFollowRuleStats (..), + AutoFollowStatsResponse (..), + ) +where + +import Data.Map.Strict (Map) +import Database.Bloodhound.Internal.Utils.Imports + +-- $ccrSchema +-- +-- The Cross-Cluster Replication (CCR) plugin (see +-- ) +-- replicates indexes from a /leader/ cluster to a /follower/ cluster in +-- near real-time. The follower cluster pulls changes from the leader's +-- translog; the follower index stays read-only while replication is +-- active. The plugin has shipped with OpenSearch since 1.1, hence this +-- module exists for OS1, OS2 and OS3. +-- +-- The REST surface lives under @\/_plugins\/_replication\/*@ on both +-- clusters. Follower-lifecycle operations (start\/stop\/pause\/resume\/ +-- update) and the per-index @\/_status@ are sent to the /follower/ +-- cluster; the leader cluster only serves @leader_stats@. The +-- @follower_stats@ and @autofollow_stats@ endpoints, plus the +-- auto-follow pattern create\/delete, are sent to the follower cluster. +-- +-- Most mutation endpoints return the trivial +-- @{\"acknowledged\":true}@ envelope, modelled by the shared +-- 'Database.Bloodhound.Internal.Client.BHRequest.Acknowledged' type +-- (re-exported via "Database.Bloodhound.Common.Types"). The interesting +-- wire shapes are the status and the three stats responses, modelled +-- below as dedicated records. + +-- | The @use_roles@ object embedded in 'StartReplicationRequest' and +-- 'CreateAutoFollowPatternRequest'. Required when the Security plugin is +-- enabled (the common case); the plugin uses these roles to authorize +-- cross-cluster reads on the leader and writes on the follower. +data ReplicationUseRoles = ReplicationUseRoles + { replicationUseRolesLeaderClusterRole :: Text, + replicationUseRolesFollowerClusterRole :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ReplicationUseRoles where + parseJSON = withObject "ReplicationUseRoles" $ \v -> do + replicationUseRolesLeaderClusterRole <- v .: "leader_cluster_role" + replicationUseRolesFollowerClusterRole <- v .: "follower_cluster_role" + pure ReplicationUseRoles {..} + +instance ToJSON ReplicationUseRoles where + toJSON ReplicationUseRoles {..} = + object + [ "leader_cluster_role" .= replicationUseRolesLeaderClusterRole, + "follower_cluster_role" .= replicationUseRolesFollowerClusterRole + ] + +-- | The request body for @PUT \/_plugins\/_replication\/{follower-index}\/_start@. +-- @leader_alias@ names the cross-cluster connection (configured via the +-- cluster settings @cluster.remote..seeds@), and @leader_index@ is +-- the source index on the leader cluster. +data StartReplicationRequest = StartReplicationRequest + { startReplicationRequestLeaderAlias :: Text, + startReplicationRequestLeaderIndex :: Text, + startReplicationRequestUseRoles :: Maybe ReplicationUseRoles + } + deriving stock (Eq, Show) + +instance FromJSON StartReplicationRequest where + parseJSON = withObject "StartReplicationRequest" $ \v -> do + startReplicationRequestLeaderAlias <- v .: "leader_alias" + startReplicationRequestLeaderIndex <- v .: "leader_index" + startReplicationRequestUseRoles <- v .:? "use_roles" + pure StartReplicationRequest {..} + +instance ToJSON StartReplicationRequest where + toJSON StartReplicationRequest {..} = + omitNulls + [ "leader_alias" .= startReplicationRequestLeaderAlias, + "leader_index" .= startReplicationRequestLeaderIndex, + "use_roles" .= startReplicationRequestUseRoles + ] + +-- | The request body for +-- @PUT \/_plugins\/_replication\/{follower-index}\/_update@. Carries an +-- arbitrary map of index-level settings (e.g. +-- @index.number_of_replicas@) to apply to the follower index. Values are +-- kept as aeson 'Value's because settings may be numbers, strings, or +-- booleans and the plugin forwards them verbatim. +newtype UpdateReplicationSettingsRequest = UpdateReplicationSettingsRequest + { updateReplicationSettingsRequestSettings :: Map Text Value + } + deriving stock (Eq, Show) + +instance FromJSON UpdateReplicationSettingsRequest where + parseJSON = withObject "UpdateReplicationSettingsRequest" $ \v -> do + updateReplicationSettingsRequestSettings <- v .: "settings" + pure UpdateReplicationSettingsRequest {..} + +instance ToJSON UpdateReplicationSettingsRequest where + toJSON UpdateReplicationSettingsRequest {..} = + object ["settings" .= updateReplicationSettingsRequestSettings] + +-- | The request body for @POST \/_plugins\/_replication\/_autofollow@. +-- Creates (or, re-POSTed with the same @name@, updates) an auto-follow +-- rule that automatically starts replication on any existing /and/ +-- future leader indexes whose names match @pattern@. +data CreateAutoFollowPatternRequest = CreateAutoFollowPatternRequest + { createAutoFollowPatternRequestLeaderAlias :: Text, + createAutoFollowPatternRequestName :: Text, + createAutoFollowPatternRequestPattern :: Text, + createAutoFollowPatternRequestUseRoles :: Maybe ReplicationUseRoles + } + deriving stock (Eq, Show) + +instance FromJSON CreateAutoFollowPatternRequest where + parseJSON = withObject "CreateAutoFollowPatternRequest" $ \v -> do + createAutoFollowPatternRequestLeaderAlias <- v .: "leader_alias" + createAutoFollowPatternRequestName <- v .: "name" + createAutoFollowPatternRequestPattern <- v .: "pattern" + createAutoFollowPatternRequestUseRoles <- v .:? "use_roles" + pure CreateAutoFollowPatternRequest {..} + +instance ToJSON CreateAutoFollowPatternRequest where + toJSON CreateAutoFollowPatternRequest {..} = + omitNulls + [ "leader_alias" .= createAutoFollowPatternRequestLeaderAlias, + "name" .= createAutoFollowPatternRequestName, + "pattern" .= createAutoFollowPatternRequestPattern, + "use_roles" .= createAutoFollowPatternRequestUseRoles + ] + +-- | The request body for @DELETE \/_plugins\/_replication\/_autofollow@. +-- Deletes an auto-follow rule. This prevents /new/ indexes from being +-- replicated but does /not/ stop replication already initiated by the +-- rule (stop those individually with 'stopReplication'). +data DeleteAutoFollowPatternRequest = DeleteAutoFollowPatternRequest + { deleteAutoFollowPatternRequestLeaderAlias :: Text, + deleteAutoFollowPatternRequestName :: Text + } + deriving stock (Eq, Show) + +instance FromJSON DeleteAutoFollowPatternRequest where + parseJSON = withObject "DeleteAutoFollowPatternRequest" $ \v -> do + deleteAutoFollowPatternRequestLeaderAlias <- v .: "leader_alias" + deleteAutoFollowPatternRequestName <- v .: "name" + pure DeleteAutoFollowPatternRequest {..} + +instance ToJSON DeleteAutoFollowPatternRequest where + toJSON DeleteAutoFollowPatternRequest {..} = + object + [ "leader_alias" .= deleteAutoFollowPatternRequestLeaderAlias, + "name" .= deleteAutoFollowPatternRequestName + ] + +-- | The @status@ enum reported by +-- @GET \/_plugins\/_replication\/{follower-index}\/_status@. Modelled as +-- an /open/ enum: the four documented values map to dedicated +-- constructors, and any unknown status string round-trips through +-- 'ReplicationStatusOther'. This guards against plugin releases adding a +-- fifth state (or undocumented intermediate states) surfacing as a +-- silent parse failure. Note the documented @REPLICATION NOT IN +-- PROGRESS@ value contains spaces. +data ReplicationStatus + = ReplicationStatusSyncing + | ReplicationStatusBootstrapping + | ReplicationStatusPaused + | ReplicationStatusNotInProgress + | ReplicationStatusOther Text + deriving stock (Eq, Show) + +instance FromJSON ReplicationStatus where + parseJSON = withText "ReplicationStatus" $ \t -> + pure $ case t of + "SYNCING" -> ReplicationStatusSyncing + "BOOTSTRAPPING" -> ReplicationStatusBootstrapping + "PAUSED" -> ReplicationStatusPaused + "REPLICATION NOT IN PROGRESS" -> ReplicationStatusNotInProgress + other -> ReplicationStatusOther other + +instance ToJSON ReplicationStatus where + toJSON = toJSON . replicationStatusText + +-- | The wire string for a 'ReplicationStatus', exposed as plain 'Text' +-- for callers that need the wire value without going through a +-- 'Data.Aeson.Value'. 'ReplicationStatusOther' round-trips its payload. +replicationStatusText :: ReplicationStatus -> Text +replicationStatusText = \case + ReplicationStatusSyncing -> "SYNCING" + ReplicationStatusBootstrapping -> "BOOTSTRAPPING" + ReplicationStatusPaused -> "PAUSED" + ReplicationStatusNotInProgress -> "REPLICATION NOT IN PROGRESS" + ReplicationStatusOther t -> t + +-- | The @syncing_details@ object embedded in 'ReplicationStatusResponse' +-- when the status is @SYNCING@. Checkpoints start negative (-1 per +-- shard) and increment with each change; equal leader\/follower +-- checkpoints mean the indexes are fully synced. +data SyncingDetails = SyncingDetails + { syncingDetailsLeaderCheckpoint :: Int, + syncingDetailsFollowerCheckpoint :: Int, + syncingDetailsSeqNo :: Int + } + deriving stock (Eq, Show) + +instance FromJSON SyncingDetails where + parseJSON = withObject "SyncingDetails" $ \v -> do + syncingDetailsLeaderCheckpoint <- v .: "leader_checkpoint" + syncingDetailsFollowerCheckpoint <- v .: "follower_checkpoint" + syncingDetailsSeqNo <- v .: "seq_no" + pure SyncingDetails {..} + +instance ToJSON SyncingDetails where + toJSON SyncingDetails {..} = + object + [ "leader_checkpoint" .= syncingDetailsLeaderCheckpoint, + "follower_checkpoint" .= syncingDetailsFollowerCheckpoint, + "seq_no" .= syncingDetailsSeqNo + ] + +-- | The response of +-- @GET \/_plugins\/_replication\/{follower-index}\/_status@. The +-- @syncing_details@ object is only present when @status@ is @SYNCING@; +-- it is 'Nothing' for the other states. +data ReplicationStatusResponse = ReplicationStatusResponse + { replicationStatusResponseStatus :: ReplicationStatus, + replicationStatusResponseReason :: Text, + replicationStatusResponseLeaderAlias :: Text, + replicationStatusResponseLeaderIndex :: Text, + replicationStatusResponseFollowerIndex :: Text, + replicationStatusResponseSyncingDetails :: Maybe SyncingDetails + } + deriving stock (Eq, Show) + +instance FromJSON ReplicationStatusResponse where + parseJSON = withObject "ReplicationStatusResponse" $ \v -> do + replicationStatusResponseStatus <- v .: "status" + replicationStatusResponseReason <- v .: "reason" + replicationStatusResponseLeaderAlias <- v .: "leader_alias" + replicationStatusResponseLeaderIndex <- v .: "leader_index" + replicationStatusResponseFollowerIndex <- v .: "follower_index" + replicationStatusResponseSyncingDetails <- v .:? "syncing_details" + pure ReplicationStatusResponse {..} + +instance ToJSON ReplicationStatusResponse where + toJSON ReplicationStatusResponse {..} = + omitNulls + [ "status" .= replicationStatusResponseStatus, + "reason" .= replicationStatusResponseReason, + "leader_alias" .= replicationStatusResponseLeaderAlias, + "leader_index" .= replicationStatusResponseLeaderIndex, + "follower_index" .= replicationStatusResponseFollowerIndex, + "syncing_details" .= replicationStatusResponseSyncingDetails + ] + +-- | Query-string options for +-- 'Database.Bloodhound.OpenSearch3.Requests.getReplicationStatus'. The +-- plugin documents only @verbose@: when @true@, the response includes +-- shard-level @syncing_details@; when omitted or @false@, the details +-- are absent. +data ReplicationStatusOptions = ReplicationStatusOptions + { replicationStatusOptionsVerbose :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | No query-string parameters — the plain @GET ...\/_status@. +defaultReplicationStatusOptions :: ReplicationStatusOptions +defaultReplicationStatusOptions = + ReplicationStatusOptions + { replicationStatusOptionsVerbose = Nothing + } + +-- | Render 'ReplicationStatusOptions' as query-string pairs for +-- 'withQueries'. +replicationStatusOptionsParams :: ReplicationStatusOptions -> [(Text, Maybe Text)] +replicationStatusOptionsParams ReplicationStatusOptions {..} = + catMaybes + [ (("verbose",) . Just . \case True -> "true"; False -> "false") <$> replicationStatusOptionsVerbose + ] + +-- | Per-index leader statistics, the value entries of the +-- @index_stats@ map in 'LeaderStatsResponse'. These are the read-side +-- counters the leader cluster reports for a single replicated index. +data LeaderIndexStats = LeaderIndexStats + { leaderIndexStatsOperationsRead :: Int, + leaderIndexStatsTranslogSizeBytes :: Int, + leaderIndexStatsOperationsReadLucene :: Int, + leaderIndexStatsOperationsReadTranslog :: Int, + leaderIndexStatsTotalReadTimeLuceneMillis :: Int, + leaderIndexStatsTotalReadTimeTranslogMillis :: Int, + leaderIndexStatsBytesRead :: Int + } + deriving stock (Eq, Show) + +instance FromJSON LeaderIndexStats where + parseJSON = withObject "LeaderIndexStats" $ \v -> do + leaderIndexStatsOperationsRead <- v .: "operations_read" + leaderIndexStatsTranslogSizeBytes <- v .: "translog_size_bytes" + leaderIndexStatsOperationsReadLucene <- v .: "operations_read_lucene" + leaderIndexStatsOperationsReadTranslog <- v .: "operations_read_translog" + leaderIndexStatsTotalReadTimeLuceneMillis <- v .: "total_read_time_lucene_millis" + leaderIndexStatsTotalReadTimeTranslogMillis <- v .: "total_read_time_translog_millis" + leaderIndexStatsBytesRead <- v .: "bytes_read" + pure LeaderIndexStats {..} + +instance ToJSON LeaderIndexStats where + toJSON LeaderIndexStats {..} = + object + [ "operations_read" .= leaderIndexStatsOperationsRead, + "translog_size_bytes" .= leaderIndexStatsTranslogSizeBytes, + "operations_read_lucene" .= leaderIndexStatsOperationsReadLucene, + "operations_read_translog" .= leaderIndexStatsOperationsReadTranslog, + "total_read_time_lucene_millis" .= leaderIndexStatsTotalReadTimeLuceneMillis, + "total_read_time_translog_millis" .= leaderIndexStatsTotalReadTimeTranslogMillis, + "bytes_read" .= leaderIndexStatsBytesRead + ] + +-- | The response of @GET \/_plugins\/_replication\/leader_stats@ (sent +-- to the /leader/ cluster). Aggregates read-side counters across all +-- replicated indexes, plus a per-index breakdown under @index_stats@. +-- The per-index values reuse 'LeaderIndexStats'. The @index_stats@ map +-- defaults to empty when the plugin omits it (e.g. no replication +-- configured). +data LeaderStatsResponse = LeaderStatsResponse + { leaderStatsResponseNumReplicatedIndices :: Int, + leaderStatsResponseOperationsRead :: Int, + leaderStatsResponseTranslogSizeBytes :: Int, + leaderStatsResponseOperationsReadLucene :: Int, + leaderStatsResponseOperationsReadTranslog :: Int, + leaderStatsResponseTotalReadTimeLuceneMillis :: Int, + leaderStatsResponseTotalReadTimeTranslogMillis :: Int, + leaderStatsResponseBytesRead :: Int, + leaderStatsResponseIndexStats :: Map Text LeaderIndexStats + } + deriving stock (Eq, Show) + +instance FromJSON LeaderStatsResponse where + parseJSON = withObject "LeaderStatsResponse" $ \v -> do + leaderStatsResponseNumReplicatedIndices <- v .: "num_replicated_indices" + leaderStatsResponseOperationsRead <- v .: "operations_read" + leaderStatsResponseTranslogSizeBytes <- v .: "translog_size_bytes" + leaderStatsResponseOperationsReadLucene <- v .: "operations_read_lucene" + leaderStatsResponseOperationsReadTranslog <- v .: "operations_read_translog" + leaderStatsResponseTotalReadTimeLuceneMillis <- v .: "total_read_time_lucene_millis" + leaderStatsResponseTotalReadTimeTranslogMillis <- v .: "total_read_time_translog_millis" + leaderStatsResponseBytesRead <- v .: "bytes_read" + leaderStatsResponseIndexStats <- v .:? "index_stats" .!= mempty + pure LeaderStatsResponse {..} + +instance ToJSON LeaderStatsResponse where + toJSON LeaderStatsResponse {..} = + object + [ "num_replicated_indices" .= leaderStatsResponseNumReplicatedIndices, + "operations_read" .= leaderStatsResponseOperationsRead, + "translog_size_bytes" .= leaderStatsResponseTranslogSizeBytes, + "operations_read_lucene" .= leaderStatsResponseOperationsReadLucene, + "operations_read_translog" .= leaderStatsResponseOperationsReadTranslog, + "total_read_time_lucene_millis" .= leaderStatsResponseTotalReadTimeLuceneMillis, + "total_read_time_translog_millis" .= leaderStatsResponseTotalReadTimeTranslogMillis, + "bytes_read" .= leaderStatsResponseBytesRead, + "index_stats" .= leaderStatsResponseIndexStats + ] + +-- | Per-index follower statistics, the value entries of the +-- @index_stats@ map in 'FollowerStatsResponse'. These are the write-side +-- counters the follower cluster reports for a single syncing index. +data FollowerIndexStats = FollowerIndexStats + { followerIndexStatsOperationsWritten :: Int, + followerIndexStatsOperationsRead :: Int, + followerIndexStatsFailedReadRequests :: Int, + followerIndexStatsThrottledReadRequests :: Int, + followerIndexStatsFailedWriteRequests :: Int, + followerIndexStatsThrottledWriteRequests :: Int, + followerIndexStatsFollowerCheckpoint :: Int, + followerIndexStatsLeaderCheckpoint :: Int, + followerIndexStatsTotalWriteTimeMillis :: Int + } + deriving stock (Eq, Show) + +instance FromJSON FollowerIndexStats where + parseJSON = withObject "FollowerIndexStats" $ \v -> do + followerIndexStatsOperationsWritten <- v .: "operations_written" + followerIndexStatsOperationsRead <- v .: "operations_read" + followerIndexStatsFailedReadRequests <- v .: "failed_read_requests" + followerIndexStatsThrottledReadRequests <- v .: "throttled_read_requests" + followerIndexStatsFailedWriteRequests <- v .: "failed_write_requests" + followerIndexStatsThrottledWriteRequests <- v .: "throttled_write_requests" + followerIndexStatsFollowerCheckpoint <- v .: "follower_checkpoint" + followerIndexStatsLeaderCheckpoint <- v .: "leader_checkpoint" + followerIndexStatsTotalWriteTimeMillis <- v .: "total_write_time_millis" + pure FollowerIndexStats {..} + +instance ToJSON FollowerIndexStats where + toJSON FollowerIndexStats {..} = + object + [ "operations_written" .= followerIndexStatsOperationsWritten, + "operations_read" .= followerIndexStatsOperationsRead, + "failed_read_requests" .= followerIndexStatsFailedReadRequests, + "throttled_read_requests" .= followerIndexStatsThrottledReadRequests, + "failed_write_requests" .= followerIndexStatsFailedWriteRequests, + "throttled_write_requests" .= followerIndexStatsThrottledWriteRequests, + "follower_checkpoint" .= followerIndexStatsFollowerCheckpoint, + "leader_checkpoint" .= followerIndexStatsLeaderCheckpoint, + "total_write_time_millis" .= followerIndexStatsTotalWriteTimeMillis + ] + +-- | The response of @GET \/_plugins\/_replication\/follower_stats@ (sent +-- to the /follower/ cluster). Reports counts of follower indexes by +-- state (syncing\/bootstrapping\/paused\/failed), shard- and index-level +-- task counts, and aggregate write-side throughput, plus a per-index +-- breakdown under @index_stats@. The @index_stats@ map defaults to +-- empty when the plugin omits it. +data FollowerStatsResponse = FollowerStatsResponse + { followerStatsResponseNumSyncingIndices :: Int, + followerStatsResponseNumBootstrappingIndices :: Int, + followerStatsResponseNumPausedIndices :: Int, + followerStatsResponseNumFailedIndices :: Int, + followerStatsResponseNumShardTasks :: Int, + followerStatsResponseNumIndexTasks :: Int, + followerStatsResponseOperationsWritten :: Int, + followerStatsResponseOperationsRead :: Int, + followerStatsResponseFailedReadRequests :: Int, + followerStatsResponseThrottledReadRequests :: Int, + followerStatsResponseFailedWriteRequests :: Int, + followerStatsResponseThrottledWriteRequests :: Int, + followerStatsResponseFollowerCheckpoint :: Int, + followerStatsResponseLeaderCheckpoint :: Int, + followerStatsResponseTotalWriteTimeMillis :: Int, + followerStatsResponseIndexStats :: Map Text FollowerIndexStats + } + deriving stock (Eq, Show) + +instance FromJSON FollowerStatsResponse where + parseJSON = withObject "FollowerStatsResponse" $ \v -> do + followerStatsResponseNumSyncingIndices <- v .: "num_syncing_indices" + followerStatsResponseNumBootstrappingIndices <- v .: "num_bootstrapping_indices" + followerStatsResponseNumPausedIndices <- v .: "num_paused_indices" + followerStatsResponseNumFailedIndices <- v .: "num_failed_indices" + followerStatsResponseNumShardTasks <- v .: "num_shard_tasks" + followerStatsResponseNumIndexTasks <- v .: "num_index_tasks" + followerStatsResponseOperationsWritten <- v .: "operations_written" + followerStatsResponseOperationsRead <- v .: "operations_read" + followerStatsResponseFailedReadRequests <- v .: "failed_read_requests" + followerStatsResponseThrottledReadRequests <- v .: "throttled_read_requests" + followerStatsResponseFailedWriteRequests <- v .: "failed_write_requests" + followerStatsResponseThrottledWriteRequests <- v .: "throttled_write_requests" + followerStatsResponseFollowerCheckpoint <- v .: "follower_checkpoint" + followerStatsResponseLeaderCheckpoint <- v .: "leader_checkpoint" + followerStatsResponseTotalWriteTimeMillis <- v .: "total_write_time_millis" + followerStatsResponseIndexStats <- v .:? "index_stats" .!= mempty + pure FollowerStatsResponse {..} + +instance ToJSON FollowerStatsResponse where + toJSON FollowerStatsResponse {..} = + object + [ "num_syncing_indices" .= followerStatsResponseNumSyncingIndices, + "num_bootstrapping_indices" .= followerStatsResponseNumBootstrappingIndices, + "num_paused_indices" .= followerStatsResponseNumPausedIndices, + "num_failed_indices" .= followerStatsResponseNumFailedIndices, + "num_shard_tasks" .= followerStatsResponseNumShardTasks, + "num_index_tasks" .= followerStatsResponseNumIndexTasks, + "operations_written" .= followerStatsResponseOperationsWritten, + "operations_read" .= followerStatsResponseOperationsRead, + "failed_read_requests" .= followerStatsResponseFailedReadRequests, + "throttled_read_requests" .= followerStatsResponseThrottledReadRequests, + "failed_write_requests" .= followerStatsResponseFailedWriteRequests, + "throttled_write_requests" .= followerStatsResponseThrottledWriteRequests, + "follower_checkpoint" .= followerStatsResponseFollowerCheckpoint, + "leader_checkpoint" .= followerStatsResponseLeaderCheckpoint, + "total_write_time_millis" .= followerStatsResponseTotalWriteTimeMillis, + "index_stats" .= followerStatsResponseIndexStats + ] + +-- | Per-rule auto-follow statistics, the list entries of the +-- @autofollow_stats@ array in 'AutoFollowStatsResponse'. Each entry +-- describes one auto-follow rule (its name and match pattern) and its +-- success\/failure counters. The @failed_indices@ array lists the +-- leader index names that failed to start replicating under this rule. +data AutoFollowRuleStats = AutoFollowRuleStats + { autoFollowRuleStatsName :: Text, + autoFollowRuleStatsPattern :: Text, + autoFollowRuleStatsNumSuccessStartReplication :: Int, + autoFollowRuleStatsNumFailedStartReplication :: Int, + autoFollowRuleStatsNumFailedLeaderCalls :: Int, + autoFollowRuleStatsFailedIndices :: [Text] + } + deriving stock (Eq, Show) + +instance FromJSON AutoFollowRuleStats where + parseJSON = withObject "AutoFollowRuleStats" $ \v -> do + autoFollowRuleStatsName <- v .: "name" + autoFollowRuleStatsPattern <- v .: "pattern" + autoFollowRuleStatsNumSuccessStartReplication <- v .: "num_success_start_replication" + autoFollowRuleStatsNumFailedStartReplication <- v .: "num_failed_start_replication" + autoFollowRuleStatsNumFailedLeaderCalls <- v .: "num_failed_leader_calls" + autoFollowRuleStatsFailedIndices <- v .:? "failed_indices" .!= [] + pure AutoFollowRuleStats {..} + +instance ToJSON AutoFollowRuleStats where + toJSON AutoFollowRuleStats {..} = + object + [ "name" .= autoFollowRuleStatsName, + "pattern" .= autoFollowRuleStatsPattern, + "num_success_start_replication" .= autoFollowRuleStatsNumSuccessStartReplication, + "num_failed_start_replication" .= autoFollowRuleStatsNumFailedStartReplication, + "num_failed_leader_calls" .= autoFollowRuleStatsNumFailedLeaderCalls, + "failed_indices" .= autoFollowRuleStatsFailedIndices + ] + +-- | The response of @GET \/_plugins\/_replication\/autofollow_stats@ +-- (sent to the /follower/ cluster). Aggregates auto-follow activity +-- across all rules, plus a per-rule breakdown under @autofollow_stats@. +-- The docs note there is no dedicated \"list patterns\" endpoint — this +-- stats response is the only way to discover existing auto-follow rules, +-- hence each rule carries its @name@ and @pattern@. Both @failed_indices@ +-- and @autofollow_stats@ default to empty when the plugin omits them. +data AutoFollowStatsResponse = AutoFollowStatsResponse + { autoFollowStatsResponseNumSuccessStartReplication :: Int, + autoFollowStatsResponseNumFailedStartReplication :: Int, + autoFollowStatsResponseNumFailedLeaderCalls :: Int, + autoFollowStatsResponseFailedIndices :: [Text], + autoFollowStatsResponseAutoFollowStats :: [AutoFollowRuleStats] + } + deriving stock (Eq, Show) + +instance FromJSON AutoFollowStatsResponse where + parseJSON = withObject "AutoFollowStatsResponse" $ \v -> do + autoFollowStatsResponseNumSuccessStartReplication <- v .: "num_success_start_replication" + autoFollowStatsResponseNumFailedStartReplication <- v .: "num_failed_start_replication" + autoFollowStatsResponseNumFailedLeaderCalls <- v .: "num_failed_leader_calls" + autoFollowStatsResponseFailedIndices <- v .:? "failed_indices" .!= [] + autoFollowStatsResponseAutoFollowStats <- v .:? "autofollow_stats" .!= [] + pure AutoFollowStatsResponse {..} + +instance ToJSON AutoFollowStatsResponse where + toJSON AutoFollowStatsResponse {..} = + object + [ "num_success_start_replication" .= autoFollowStatsResponseNumSuccessStartReplication, + "num_failed_start_replication" .= autoFollowStatsResponseNumFailedStartReplication, + "num_failed_leader_calls" .= autoFollowStatsResponseNumFailedLeaderCalls, + "failed_indices" .= autoFollowStatsResponseFailedIndices, + "autofollow_stats" .= autoFollowStatsResponseAutoFollowStats + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/FlowFramework.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/FlowFramework.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/FlowFramework.hs @@ -0,0 +1,1041 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.FlowFramework + ( WorkflowId (..), + WorkflowTemplate (..), + WorkflowVersion (..), + WorkflowState (..), + workflowStateText, + WorkflowEntry (..), + WorkflowNode (..), + WorkflowEdge (..), + NodeInputs (..), + nodeInputsType, + CreateConnectorUserInputs (..), + WorkflowConnectorAction (..), + RegisterRemoteModelUserInputs (..), + DeployModelUserInputs (..), + CreateIndexUserInputs (..), + CreateIngestPipelineUserInputs (..), + ResourceCreated (..), + CreateWorkflowResponse (..), + CreateWorkflowOptions (..), + defaultCreateWorkflowOptions, + createWorkflowOptionsParams, + ValidationMode (..), + validationModeText, + ProvisionOptions (..), + defaultProvisionOptions, + provisionOptionsParams, + DeleteWorkflowOptions (..), + defaultDeleteWorkflowOptions, + deleteWorkflowOptionsParams, + DeprovisionWorkflowOptions (..), + defaultDeprovisionWorkflowOptions, + deprovisionWorkflowOptionsParams, + DeprovisionWorkflowResponse (..), + WorkflowStateOptions (..), + defaultWorkflowStateOptions, + workflowStateOptionsParams, + WorkflowStateResponse (..), + WorkflowStep (..), + WorkflowStepsResponse (..), + WorkflowStepsOptions (..), + defaultWorkflowStepsOptions, + workflowStepsOptionsParams, + ) +where + +import Data.Aeson +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The Flow Framework plugin (see +-- ) +-- automates the provisioning of AI/ML workflows: a caller submits a +-- /workflow template/ describing the resources to stand up (connectors, +-- models, ingest pipelines, indices, ...) and the dependencies between +-- them, and the plugin materializes the whole graph as a single +-- operation. +-- +-- The lifecycle is: +-- +-- (1) 'createWorkflow' persists the template (returns a 'WorkflowId'). +-- (2) 'provisionWorkflow' walks the template's @provision@ entry and +-- creates the resources in dependency order. +-- (3) 'getWorkflow' reads back the stored template. +-- (4) 'deleteWorkflow' removes the stored template (resources must be +-- deprovisioned separately). +-- +-- The plugin ships 24 step @type@s registered by @WorkflowStepFactory@. +-- Five of them cover the flagship \"stand up semantic search / RAG\" +-- flow and are modelled here as typed records; the remaining 19 +-- (deprovisioning steps, rare registration paths, noop) round-trip +-- through the 'OtherInputs' escape hatch so adding a new type to the +-- plugin does not require a library release. +-- +-- Doc ambiguities handled here deliberately: +-- +-- * Status codes are nowhere documented for any of the four endpoints +-- we expose. We treat all four as 'StatusDependant' (matching the +-- 'deleteModel' / 'deleteNotificationConfig' precedent) so 4xx +-- surfaces as 'EsError' rather than throwing. Verify against a live +-- cluster if you depend on the exact codes. +-- * The delete response is the raw index-delete envelope, not +-- 'Acknowledged'. We reuse 'IndexedDocument' (matching the +-- 'deleteISMPolicy' / 'deleteModel' precedent). +-- * The @WorkflowState@ enum is under-documented (only @COMPLETED@ +-- and @PROVISIONING@ appear in the four endpoint pages). The known +-- values are modelled here as a sum type; unknown values parse into +-- the 'WorkflowStateOther' escape hatch so a future plugin release +-- adding a new state does not break decode. +-- * The @workflows@ map is documented as accepting only the +-- @provision@ key today. We type it as a 'Map' 'Text' 'WorkflowEntry' +-- so the wire shape is preserved when the plugin widens the surface. +-- * The bead acceptance for bloodhound-egf named a @retryWorkflow@ +-- endpoint (@POST .../workflow/{id}/_retry@) that does not exist +-- upstream: there is no @RestRetryWorkflowAction@ in +-- @opensearch-project/flow-framework@ and the OS docs site documents +-- no such endpoint. Intentionally not implemented; revisit if a +-- future plugin release adds it. + +-- | A workflow ID for the +-- @\/_plugins\/_flow_framework\/workflow\/{workflow_id}@ path segment +-- and the @workflow_id@ field returned by create \/ provision. The +-- value is assigned by the server. Wrapped 'Text' so it round-trips as +-- a bare JSON string but is distinct from 'ModelId' \/ 'PolicyId' at +-- the type level. +newtype WorkflowId = WorkflowId {unWorkflowId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- ========================================================================= +-- Workflow template (create request body / get response body) +-- ========================================================================= + +-- | The body of 'createWorkflow' and the payload returned by +-- 'getWorkflow'. Only @name@ is required; every other field is +-- conditionally present depending on what the workflow sets up. +-- +-- The @use_case@ body field is /distinct from/ the @use_case@ query +-- parameter accepted by the create endpoint: the body field is a +-- user-chosen tag for searching, while the query parameter names a +-- built-in template (and overrides the body when supplied). The +-- OpenSearch docs explicitly call this conflation out. +data WorkflowTemplate = WorkflowTemplate + { workflowTemplateName :: Text, + workflowTemplateDescription :: Maybe Text, + workflowTemplateUseCase :: Maybe Text, + workflowTemplateVersion :: Maybe WorkflowVersion, + workflowTemplateWorkflows :: Maybe (Map Text WorkflowEntry) + } + deriving stock (Eq, Show) + +instance FromJSON WorkflowTemplate where + parseJSON = withObject "WorkflowTemplate" $ \v -> do + workflowTemplateName <- v .: "name" + workflowTemplateDescription <- v .:? "description" + workflowTemplateUseCase <- v .:? "use_case" + workflowTemplateVersion <- v .:? "version" + workflowTemplateWorkflows <- v .:? "workflows" + pure WorkflowTemplate {..} + +instance ToJSON WorkflowTemplate where + toJSON WorkflowTemplate {..} = + omitNulls + [ "name" .= workflowTemplateName, + "description" .= workflowTemplateDescription, + "use_case" .= workflowTemplateUseCase, + "version" .= workflowTemplateVersion, + "workflows" .= workflowTemplateWorkflows + ] + +-- | The @version@ object inside a 'WorkflowTemplate'. @template@ is the +-- template-schema version (currently @1.0.0@); @compatibility@ is the +-- list of OpenSearch versions the template is known to work on. +data WorkflowVersion = WorkflowVersion + { workflowVersionTemplate :: Maybe Text, + workflowVersionCompatibility :: Maybe [Text] + } + deriving stock (Eq, Show) + +instance FromJSON WorkflowVersion where + parseJSON = withObject "WorkflowVersion" $ \v -> do + workflowVersionTemplate <- v .:? "template" + workflowVersionCompatibility <- v .:? "compatibility" + pure WorkflowVersion {..} + +instance ToJSON WorkflowVersion where + toJSON WorkflowVersion {..} = + omitNulls + [ "template" .= workflowVersionTemplate, + "compatibility" .= workflowVersionCompatibility + ] + +-- | The lifecycle state of a provision operation, as reported in the +-- @state@ field of 'CreateWorkflowResponse' (when a +-- @wait_for_completion_timeout@ is supplied) and by the separate Get +-- Workflow State API. The spec enum is @COMPLETED@, @FAILED@, +-- @NOT_STARTED@, @PROVISIONING@ (the in-flight state). Unknown values +-- parse into 'WorkflowStateOther' so a future plugin release adding a +-- state does not break decode. +data WorkflowState + = WorkflowStateNotStarted + | WorkflowStateProvisioning + | WorkflowStateCompleted + | WorkflowStateFailed + | WorkflowStateOther Text + deriving stock (Eq, Show) + +workflowStateText :: WorkflowState -> Text +workflowStateText = \case + WorkflowStateNotStarted -> "NOT_STARTED" + WorkflowStateProvisioning -> "PROVISIONING" + WorkflowStateCompleted -> "COMPLETED" + WorkflowStateFailed -> "FAILED" + WorkflowStateOther t -> t + +instance ToJSON WorkflowState where + toJSON = toJSON . workflowStateText + +instance FromJSON WorkflowState where + parseJSON = withText "WorkflowState" $ \case + "NOT_STARTED" -> pure WorkflowStateNotStarted + "PROVISIONING" -> pure WorkflowStateProvisioning + "COMPLETED" -> pure WorkflowStateCompleted + "FAILED" -> pure WorkflowStateFailed + other -> pure (WorkflowStateOther other) + +-- | A named entry inside the @workflows@ map of a 'WorkflowTemplate'. +-- Today the only documented key is @provision@; the shape is preserved +-- as a 'Map' so the surface widens without a library release. +-- @user_params@ is the optional substitution map referenced by +-- @${{ var }}@ placeholders in node @user_inputs@; @nodes@ is the +-- graph of resources to provision; @edges@ is optional and derived +-- from @previous_node_inputs@ when omitted. +data WorkflowEntry = WorkflowEntry + { workflowEntryUserParams :: Maybe Object, + workflowEntryNodes :: [WorkflowNode], + workflowEntryEdges :: Maybe [WorkflowEdge] + } + deriving stock (Eq, Show) + +instance FromJSON WorkflowEntry where + parseJSON = withObject "WorkflowEntry" $ \v -> do + workflowEntryUserParams <- v .:? "user_params" + workflowEntryNodes <- v .:? "nodes" .!= [] + workflowEntryEdges <- v .:? "edges" + pure WorkflowEntry {..} + +instance ToJSON WorkflowEntry where + toJSON WorkflowEntry {..} = + omitNulls + [ "user_params" .= workflowEntryUserParams, + "nodes" .= workflowEntryNodes, + "edges" .= workflowEntryEdges + ] + +-- | A node in a 'WorkflowEntry' graph: a single resource to create, +-- identified by a workflow-unique @id@, typed by 'nodeInputsType', and +-- optionally wired to upstream nodes via @previous_node_inputs@ (a map +-- of upstream-node-id to the output-field-name to inject). +data WorkflowNode = WorkflowNode + { workflowNodeId :: Text, + workflowNodeInputs :: NodeInputs, + workflowNodePreviousInputs :: Maybe (Map Text Text) + } + deriving stock (Eq, Show) + +instance FromJSON WorkflowNode where + parseJSON = withObject "WorkflowNode" $ \v -> do + workflowNodeId <- v .: "id" + workflowNodePreviousInputs <- v .:? "previous_node_inputs" + ty <- v .: "type" + userInputsVal <- v .:? "user_inputs" .!= emptyObject + workflowNodeInputs <- case ty of + "create_connector" -> CreateConnectorInputs <$> parseJSON userInputsVal + "register_remote_model" -> RegisterRemoteModelInputs <$> parseJSON userInputsVal + "deploy_model" -> DeployModelInputs <$> parseJSON userInputsVal + "create_index" -> CreateIndexInputs <$> parseJSON userInputsVal + "create_ingest_pipeline" -> CreateIngestPipelineInputs <$> parseJSON userInputsVal + _ -> pure (OtherInputs ty userInputsVal) + pure WorkflowNode {..} + +instance ToJSON WorkflowNode where + toJSON WorkflowNode {..} = + omitNulls $ + [ "id" .= workflowNodeId, + "type" .= nodeInputsType workflowNodeInputs, + "user_inputs" .= nodeInputsValue workflowNodeInputs + ] + <> maybe [] (\pni -> ["previous_node_inputs" .= pni]) workflowNodePreviousInputs + +-- | A directed edge in a 'WorkflowEntry' graph. Edges are optional — +-- the plugin derives them from @previous_node_inputs@ when omitted — +-- but are documented and round-tripped for completeness. +data WorkflowEdge = WorkflowEdge + { workflowEdgeSource :: Text, + workflowEdgeDest :: Text + } + deriving stock (Eq, Show) + +instance FromJSON WorkflowEdge where + parseJSON = withObject "WorkflowEdge" $ \v -> do + workflowEdgeSource <- v .: "source" + workflowEdgeDest <- v .: "dest" + pure WorkflowEdge {..} + +instance ToJSON WorkflowEdge where + toJSON WorkflowEdge {..} = + object + [ "source" .= workflowEdgeSource, + "dest" .= workflowEdgeDest + ] + +-- ========================================================================= +-- Node inputs (open sum type over 24 step types) +-- ========================================================================= + +-- | The typed payload of a 'WorkflowNode'. Five of the most common +-- step @type@s are modelled here as typed records; the remaining 19 +-- round-trip through 'OtherInputs' as an opaque 'Value'. +-- +-- Promotion candidates for future typing (in rough priority order): +-- @register_agent@, @create_tool@, @create_search_pipeline@, +-- @register_local_pretrained_model@, @register_model_group@, +-- @reindex@. They are skipped here because their @user_inputs@ +-- contain deeply nested JSON-stringified sub-objects +-- (@llm@, @tools@, @model@, @context_management@) that do not pay +-- back the modelling cost on a first pass. +data NodeInputs + = CreateConnectorInputs CreateConnectorUserInputs + | RegisterRemoteModelInputs RegisterRemoteModelUserInputs + | DeployModelInputs DeployModelUserInputs + | CreateIndexInputs CreateIndexUserInputs + | CreateIngestPipelineInputs CreateIngestPipelineUserInputs + | OtherInputs Text Value + deriving stock (Eq, Show) + +-- | The wire @type@ string a 'NodeInputs' variant serializes to. +nodeInputsType :: NodeInputs -> Text +nodeInputsType = \case + CreateConnectorInputs _ -> "create_connector" + RegisterRemoteModelInputs _ -> "register_remote_model" + DeployModelInputs _ -> "deploy_model" + CreateIndexInputs _ -> "create_index" + CreateIngestPipelineInputs _ -> "create_ingest_pipeline" + OtherInputs ty _ -> ty + +-- | The wire @user_inputs@ payload. Used by 'WorkflowNode''s +-- 'ToJSON' instance; not exported. +nodeInputsValue :: NodeInputs -> Value +nodeInputsValue = \case + CreateConnectorInputs x -> toJSON x + RegisterRemoteModelInputs x -> toJSON x + DeployModelInputs x -> toJSON x + CreateIndexInputs x -> toJSON x + CreateIngestPipelineInputs x -> toJSON x + OtherInputs _ v -> v + +-- ========================================================================= +-- create_connector +-- ========================================================================= + +-- | @user_inputs@ for the @create_connector@ step. Creates an +-- ML-Commons connector to an external model provider (OpenAI, +-- Bedrock, SageMaker, Cohere, ...). The richest of the five typed +-- shapes; the @actions@ array carries per-action HTTP templates that +-- the connector evaluates on each invocation. +data CreateConnectorUserInputs = CreateConnectorUserInputs + { createConnectorUserInputsName :: Text, + createConnectorUserInputsDescription :: Text, + createConnectorUserInputsVersion :: Text, + createConnectorUserInputsProtocol :: Text, + createConnectorUserInputsParameters :: Map Text Value, + createConnectorUserInputsCredential :: Map Text Value, + createConnectorUserInputsActions :: [WorkflowConnectorAction], + createConnectorUserInputsBackendRoles :: Maybe [Text], + createConnectorUserInputsAddAllBackendRoles :: Maybe Bool, + createConnectorUserInputsAccessMode :: Maybe Text, + createConnectorUserInputsClientConfig :: Maybe Value, + createConnectorUserInputsUrl :: Maybe Text, + createConnectorUserInputsHeaders :: Maybe (Map Text Value) + } + deriving stock (Eq, Show) + +instance FromJSON CreateConnectorUserInputs where + parseJSON = withObject "CreateConnectorUserInputs" $ \v -> do + createConnectorUserInputsName <- v .: "name" + createConnectorUserInputsDescription <- v .: "description" + createConnectorUserInputsVersion <- v .: "version" + createConnectorUserInputsProtocol <- v .: "protocol" + createConnectorUserInputsParameters <- v .: "parameters" + createConnectorUserInputsCredential <- v .: "credential" + createConnectorUserInputsActions <- v .: "actions" + createConnectorUserInputsBackendRoles <- v .:? "backend_roles" + createConnectorUserInputsAddAllBackendRoles <- v .:? "add_all_backend_roles" + createConnectorUserInputsAccessMode <- v .:? "access_mode" + createConnectorUserInputsClientConfig <- v .:? "client_config" + createConnectorUserInputsUrl <- v .:? "url" + createConnectorUserInputsHeaders <- v .:? "headers" + pure CreateConnectorUserInputs {..} + +instance ToJSON CreateConnectorUserInputs where + toJSON CreateConnectorUserInputs {..} = + omitNulls + [ "name" .= createConnectorUserInputsName, + "description" .= createConnectorUserInputsDescription, + "version" .= createConnectorUserInputsVersion, + "protocol" .= createConnectorUserInputsProtocol, + "parameters" .= createConnectorUserInputsParameters, + "credential" .= createConnectorUserInputsCredential, + "actions" .= createConnectorUserInputsActions, + "backend_roles" .= createConnectorUserInputsBackendRoles, + "add_all_backend_roles" .= createConnectorUserInputsAddAllBackendRoles, + "access_mode" .= createConnectorUserInputsAccessMode, + "client_config" .= createConnectorUserInputsClientConfig, + "url" .= createConnectorUserInputsUrl, + "headers" .= createConnectorUserInputsHeaders + ] + +-- | A single entry in the @actions@ array of a connector. The +-- connector evaluates the @request_body@ template on each invocation, +-- passing the user input through, and runs the optional +-- pre/post-process JavaScript snippets against the request/response +-- respectively. @pre_process_function@ and @post_process_function@ +-- are kept as 'Maybe' 'Text' because they are documented as +-- script strings, not structured code. +data WorkflowConnectorAction = WorkflowConnectorAction + { workflowConnectorActionType :: Text, + workflowConnectorActionMethod :: Text, + workflowConnectorActionUrl :: Text, + workflowConnectorActionHeaders :: Maybe (Map Text Value), + workflowConnectorActionRequestBody :: Maybe Value, + workflowConnectorActionPreProcessFunction :: Maybe Text, + workflowConnectorActionPostProcessFunction :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON WorkflowConnectorAction where + parseJSON = withObject "WorkflowConnectorAction" $ \v -> do + workflowConnectorActionType <- v .: "action_type" + workflowConnectorActionMethod <- v .: "method" + workflowConnectorActionUrl <- v .: "url" + workflowConnectorActionHeaders <- v .:? "headers" + workflowConnectorActionRequestBody <- v .:? "request_body" + workflowConnectorActionPreProcessFunction <- v .:? "pre_process_function" + workflowConnectorActionPostProcessFunction <- v .:? "post_process_function" + pure WorkflowConnectorAction {..} + +instance ToJSON WorkflowConnectorAction where + toJSON WorkflowConnectorAction {..} = + omitNulls + [ "action_type" .= workflowConnectorActionType, + "method" .= workflowConnectorActionMethod, + "url" .= workflowConnectorActionUrl, + "headers" .= workflowConnectorActionHeaders, + "request_body" .= workflowConnectorActionRequestBody, + "pre_process_function" .= workflowConnectorActionPreProcessFunction, + "post_process_function" .= workflowConnectorActionPostProcessFunction + ] + +-- ========================================================================= +-- register_remote_model +-- ========================================================================= + +-- | @user_inputs@ for the @register_remote_model@ step. Registers a +-- model backed by an existing connector — the @connector_id@ is +-- typically injected from a preceding @create_connector@ node via +-- 'workflowNodePreviousInputs', so the field is 'Maybe' here even +-- though the plugin marks it required at runtime (the check is on the +-- merged @previous_node_inputs + user_inputs@ set, not on the +-- authored user_inputs alone). Setting @deploy = Just True@ chains a +-- deploy inline, saving a separate @deploy_model@ node. +-- @function_name@ defaults to @remote@ server-side when omitted but +-- is exposed here because the canonical doc sample sets it +-- explicitly. +data RegisterRemoteModelUserInputs = RegisterRemoteModelUserInputs + { registerRemoteModelUserInputsName :: Text, + registerRemoteModelUserInputsConnectorId :: Maybe Text, + registerRemoteModelUserInputsFunctionName :: Maybe Text, + registerRemoteModelUserInputsModelGroupId :: Maybe Text, + registerRemoteModelUserInputsDescription :: Maybe Text, + registerRemoteModelUserInputsDeploy :: Maybe Bool, + registerRemoteModelUserInputsGuardrails :: Maybe Value, + registerRemoteModelUserInputsInterface :: Maybe Value, + registerRemoteModelUserInputsIsEnabled :: Maybe Bool, + registerRemoteModelUserInputsRateLimiter :: Maybe Value, + registerRemoteModelUserInputsDeploySetting :: Maybe Value, + registerRemoteModelUserInputsBackendRoles :: Maybe [Text], + registerRemoteModelUserInputsAddAllBackendRoles :: Maybe Bool, + registerRemoteModelUserInputsAccessMode :: Maybe Text, + registerRemoteModelUserInputsModelNodeIds :: Maybe [Text] + } + deriving stock (Eq, Show) + +instance FromJSON RegisterRemoteModelUserInputs where + parseJSON = withObject "RegisterRemoteModelUserInputs" $ \v -> do + registerRemoteModelUserInputsName <- v .: "name" + registerRemoteModelUserInputsConnectorId <- v .:? "connector_id" + registerRemoteModelUserInputsFunctionName <- v .:? "function_name" + registerRemoteModelUserInputsModelGroupId <- v .:? "model_group_id" + registerRemoteModelUserInputsDescription <- v .:? "description" + registerRemoteModelUserInputsDeploy <- v .:? "deploy" + registerRemoteModelUserInputsGuardrails <- v .:? "guardrails" + registerRemoteModelUserInputsInterface <- v .:? "interface" + registerRemoteModelUserInputsIsEnabled <- v .:? "is_enabled" + registerRemoteModelUserInputsRateLimiter <- v .:? "rate_limiter" + registerRemoteModelUserInputsDeploySetting <- v .:? "deploy_setting" + registerRemoteModelUserInputsBackendRoles <- v .:? "backend_roles" + registerRemoteModelUserInputsAddAllBackendRoles <- v .:? "add_all_backend_roles" + registerRemoteModelUserInputsAccessMode <- v .:? "access_mode" + registerRemoteModelUserInputsModelNodeIds <- v .:? "model_node_ids" + pure RegisterRemoteModelUserInputs {..} + +instance ToJSON RegisterRemoteModelUserInputs where + toJSON RegisterRemoteModelUserInputs {..} = + omitNulls + [ "name" .= registerRemoteModelUserInputsName, + "connector_id" .= registerRemoteModelUserInputsConnectorId, + "function_name" .= registerRemoteModelUserInputsFunctionName, + "model_group_id" .= registerRemoteModelUserInputsModelGroupId, + "description" .= registerRemoteModelUserInputsDescription, + "deploy" .= registerRemoteModelUserInputsDeploy, + "guardrails" .= registerRemoteModelUserInputsGuardrails, + "interface" .= registerRemoteModelUserInputsInterface, + "is_enabled" .= registerRemoteModelUserInputsIsEnabled, + "rate_limiter" .= registerRemoteModelUserInputsRateLimiter, + "deploy_setting" .= registerRemoteModelUserInputsDeploySetting, + "backend_roles" .= registerRemoteModelUserInputsBackendRoles, + "add_all_backend_roles" .= registerRemoteModelUserInputsAddAllBackendRoles, + "access_mode" .= registerRemoteModelUserInputsAccessMode, + "model_node_ids" .= registerRemoteModelUserInputsModelNodeIds + ] + +-- ========================================================================= +-- deploy_model +-- ========================================================================= + +-- | @user_inputs@ for the @deploy_model@ step. Deploys (loads into +-- memory on ML worker nodes) a previously registered model. The +-- @model_id@ is typically injected from a preceding +-- @register_remote_model@ node via 'workflowNodePreviousInputs' and +-- is therefore 'Maybe' here even though the plugin marks it required +-- at runtime (the check is on the merged @previous_node_inputs + +-- user_inputs@ set, not on the authored user_inputs alone). +newtype DeployModelUserInputs = DeployModelUserInputs + { deployModelUserInputsModelId :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON DeployModelUserInputs where + parseJSON = withObject "DeployModelUserInputs" $ \v -> do + deployModelUserInputsModelId <- v .:? "model_id" + pure DeployModelUserInputs {..} + +instance ToJSON DeployModelUserInputs where + toJSON DeployModelUserInputs {..} = + omitNulls + [ "model_id" .= deployModelUserInputsModelId + ] + +-- ========================================================================= +-- create_index +-- ========================================================================= + +-- | @user_inputs@ for the @create_index@ step. Creates an OpenSearch +-- index with the supplied settings and mappings. @configurations@ is +-- a JSON-stringified body (the plugin re-parses it server-side) — +-- typed here as 'Text' to match the wire shape. The plugin rejects +-- mappings nested under a @_doc@ type. +data CreateIndexUserInputs = CreateIndexUserInputs + { createIndexUserInputsIndexName :: Text, + createIndexUserInputsConfigurations :: Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateIndexUserInputs where + parseJSON = withObject "CreateIndexUserInputs" $ \v -> do + createIndexUserInputsIndexName <- v .: "index_name" + createIndexUserInputsConfigurations <- v .: "configurations" + pure CreateIndexUserInputs {..} + +instance ToJSON CreateIndexUserInputs where + toJSON CreateIndexUserInputs {..} = + object + [ "index_name" .= createIndexUserInputsIndexName, + "configurations" .= createIndexUserInputsConfigurations + ] + +-- ========================================================================= +-- create_ingest_pipeline +-- ========================================================================= + +-- | @user_inputs@ for the @create_ingest_pipeline@ step. Creates an +-- OpenSearch ingest pipeline (e.g. a @text_embedding@ processor +-- pipeline). @configurations@ is a JSON-stringified body — typed +-- here as 'Text' to match the wire shape. +data CreateIngestPipelineUserInputs = CreateIngestPipelineUserInputs + { createIngestPipelineUserInputsPipelineId :: Text, + createIngestPipelineUserInputsConfigurations :: Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateIngestPipelineUserInputs where + parseJSON = withObject "CreateIngestPipelineUserInputs" $ \v -> do + createIngestPipelineUserInputsPipelineId <- v .: "pipeline_id" + createIngestPipelineUserInputsConfigurations <- v .: "configurations" + pure CreateIngestPipelineUserInputs {..} + +instance ToJSON CreateIngestPipelineUserInputs where + toJSON CreateIngestPipelineUserInputs {..} = + object + [ "pipeline_id" .= createIngestPipelineUserInputsPipelineId, + "configurations" .= createIngestPipelineUserInputsConfigurations + ] + +-- ========================================================================= +-- Provision response: resources_created entry +-- ========================================================================= + +-- | A single entry in the @resources_created@ array of a +-- 'CreateWorkflowResponse' returned with a +-- @wait_for_completion_timeout@. The plugin reports the step that +-- created the resource, the resource's id, and its /type/ (the +-- output field name on the upstream step, e.g. @connector_id@, +-- @model_id@, @index_name@, @pipeline_id@). +-- +-- Doc ambiguity: examples show @workflow_step_id@ and +-- @workflow_step_name@ appearing in either order across entries — +-- the field set is stable, the ordering is not. Aeson decoding is +-- order-independent so this is harmless here. +data ResourceCreated = ResourceCreated + { resourceCreatedWorkflowStepId :: Text, + resourceCreatedWorkflowStepName :: Text, + resourceCreatedResourceId :: Text, + resourceCreatedResourceType :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ResourceCreated where + parseJSON = withObject "ResourceCreated" $ \v -> do + resourceCreatedWorkflowStepId <- v .: "workflow_step_id" + resourceCreatedWorkflowStepName <- v .: "workflow_step_name" + resourceCreatedResourceId <- v .: "resource_id" + resourceCreatedResourceType <- v .: "resource_type" + pure ResourceCreated {..} + +instance ToJSON ResourceCreated where + toJSON ResourceCreated {..} = + object + [ "workflow_step_id" .= resourceCreatedWorkflowStepId, + "workflow_step_name" .= resourceCreatedWorkflowStepName, + "resource_id" .= resourceCreatedResourceId, + "resource_type" .= resourceCreatedResourceType + ] + +-- ========================================================================= +-- Create / Provision response shape +-- ========================================================================= + +-- | The response of 'createWorkflow' and 'provisionWorkflow'. The +-- minimal fire-and-forget response carries only the @workflow_id@; +-- when @wait_for_completion_timeout@ is supplied, the plugin also +-- returns the current @state@ and the @resources_created@ list. The +-- two optional fields are decoded when present and 'Nothing' +-- otherwise, so callers can pattern-match on either shape with one +-- type. +data CreateWorkflowResponse = CreateWorkflowResponse + { createWorkflowResponseWorkflowId :: WorkflowId, + createWorkflowResponseState :: Maybe WorkflowState, + createWorkflowResponseResourcesCreated :: Maybe [ResourceCreated] + } + deriving stock (Eq, Show) + +instance FromJSON CreateWorkflowResponse where + parseJSON = withObject "CreateWorkflowResponse" $ \v -> do + createWorkflowResponseWorkflowId <- v .: "workflow_id" + createWorkflowResponseState <- v .:? "state" + createWorkflowResponseResourcesCreated <- v .:? "resources_created" + pure CreateWorkflowResponse {..} + +instance ToJSON CreateWorkflowResponse where + toJSON CreateWorkflowResponse {..} = + omitNulls + [ "workflow_id" .= createWorkflowResponseWorkflowId, + "state" .= createWorkflowResponseState, + "resources_created" .= createWorkflowResponseResourcesCreated + ] + +-- ========================================================================= +-- Create workflow options +-- ========================================================================= + +-- | Validation mode for 'createWorkflowWith'. @all@ runs the full +-- template validation (the default); @none@ skips it, letting the +-- plugin store work-in-progress templates. +data ValidationMode + = ValidationAll + | ValidationNone + deriving stock (Eq, Show) + +validationModeText :: ValidationMode -> Text +validationModeText = \case + ValidationAll -> "all" + ValidationNone -> "none" + +instance ToJSON ValidationMode where + toJSON = toJSON . validationModeText + +instance FromJSON ValidationMode where + parseJSON = withText "ValidationMode" $ \case + "all" -> pure ValidationAll + "none" -> pure ValidationNone + other -> fail ("Unknown ValidationMode: " <> T.unpack other) + +-- | Query-string parameters accepted by 'createWorkflowWith'. Every +-- field is optional; 'defaultCreateWorkflowOptions' produces an empty +-- parameter list, reproducing the plain POST. The +-- @wait_for_completion_timeout@ field is only meaningful when +-- @provision = Just True@ (or when used as PUT with +-- @reprovision = Just True@); the plugin silently ignores it +-- otherwise. +-- +-- PUT-only flags (@update_fields@, @reprovision@) are exposed here +-- for symmetry — they are no-ops on the POST path. The +-- @use_case@ field names a built-in +-- +-- and overrides the request body when supplied. +data CreateWorkflowOptions = CreateWorkflowOptions + { createWorkflowOptionsProvision :: Maybe Bool, + createWorkflowOptionsValidation :: Maybe ValidationMode, + createWorkflowOptionsUseCase :: Maybe Text, + createWorkflowOptionsWaitForCompletionTimeout :: Maybe Text, + createWorkflowOptionsUpdateFields :: Maybe Bool, + createWorkflowOptionsReprovision :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the +-- plain @POST /_plugins/_flow_framework/workflow@ when passed to +-- 'createWorkflowWith'. +defaultCreateWorkflowOptions :: CreateWorkflowOptions +defaultCreateWorkflowOptions = + CreateWorkflowOptions + { createWorkflowOptionsProvision = Nothing, + createWorkflowOptionsValidation = Nothing, + createWorkflowOptionsUseCase = Nothing, + createWorkflowOptionsWaitForCompletionTimeout = Nothing, + createWorkflowOptionsUpdateFields = Nothing, + createWorkflowOptionsReprovision = Nothing + } + +-- | Render a 'CreateWorkflowOptions' to the query-string pairs +-- accepted by the create endpoint. Fields set to 'Nothing' are +-- omitted. +createWorkflowOptionsParams :: CreateWorkflowOptions -> [(Text, Maybe Text)] +createWorkflowOptionsParams CreateWorkflowOptions {..} = + catMaybes + [ (("provision",) . Just . boolText) <$> createWorkflowOptionsProvision, + (("validation",) . Just . validationModeText) <$> createWorkflowOptionsValidation, + (("use_case",) . Just) <$> createWorkflowOptionsUseCase, + (("wait_for_completion_timeout",) . Just) <$> createWorkflowOptionsWaitForCompletionTimeout, + (("update_fields",) . Just . boolText) <$> createWorkflowOptionsUpdateFields, + (("reprovision",) . Just . boolText) <$> createWorkflowOptionsReprovision + ] + where + boolText True = "true" + boolText False = "false" + +-- ========================================================================= +-- Provision workflow options +-- ========================================================================= + +-- | Query-string and body parameters accepted by +-- 'provisionWorkflowWith'. @provisionOptionsTimeout@ is a +-- human-readable duration (e.g. @2s@, @500ms@) forwarded as +-- @wait_for_completion_timeout@; @provisionOptionsSubstitutions@ is +-- the optional substitution map forwarded both as query-string pairs +-- (the keys here) and /or/ as the request body. The two channels +-- are equivalent — pass them via whichever is more convenient. +data ProvisionOptions = ProvisionOptions + { provisionOptionsTimeout :: Maybe Text, + provisionOptionsSubstitutions :: Maybe (Map Text Text) + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters and no body. +-- Reproduces the plain fire-and-forget +-- @POST /_plugins/_flow_framework/workflow/{id}/_provision@ when +-- passed to 'provisionWorkflowWith'. +defaultProvisionOptions :: ProvisionOptions +defaultProvisionOptions = + ProvisionOptions + { provisionOptionsTimeout = Nothing, + provisionOptionsSubstitutions = Nothing + } + +-- | Render a 'ProvisionOptions' to the query-string pairs accepted by +-- the provision endpoint. Fields set to 'Nothing' are omitted. +provisionOptionsParams :: ProvisionOptions -> [(Text, Maybe Text)] +provisionOptionsParams ProvisionOptions {..} = + catMaybes + [ (("wait_for_completion_timeout",) . Just) <$> provisionOptionsTimeout + ] + <> foldMap + (map (\(k, v) -> (k, Just v)) . Map.toList) + provisionOptionsSubstitutions + +-- ========================================================================= +-- Delete workflow options +-- ========================================================================= + +-- | Query-string parameters accepted by 'deleteWorkflowWith'. The +-- single @clear_status@ flag controls whether the plugin also +-- deletes the workflow state (the separate Workflow State API +-- document) alongside the template. The plugin only honors +-- @clear_status = True@ when the provisioning state is not +-- @PROVISIONING@. +data DeleteWorkflowOptions = DeleteWorkflowOptions + { deleteWorkflowOptionsClearStatus :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the +-- plain @DELETE /_plugins/_flow_framework/workflow/{workflow_id}@ +-- when passed to 'deleteWorkflowWith'. +defaultDeleteWorkflowOptions :: DeleteWorkflowOptions +defaultDeleteWorkflowOptions = + DeleteWorkflowOptions + { deleteWorkflowOptionsClearStatus = Nothing + } + +-- | Render a 'DeleteWorkflowOptions' to the query-string pairs +-- accepted by the delete endpoint. Fields set to 'Nothing' are +-- omitted. +deleteWorkflowOptionsParams :: DeleteWorkflowOptions -> [(Text, Maybe Text)] +deleteWorkflowOptionsParams DeleteWorkflowOptions {..} = + catMaybes + [ (("clear_status",) . Just . boolText) <$> deleteWorkflowOptionsClearStatus + ] + where + boolText True = "true" + boolText False = "false" + +-- ========================================================================= +-- Deprovision workflow options + response +-- ========================================================================= + +-- | Query-string parameters accepted by 'deprovisionWorkflowWith'. The +-- single @allow_delete@ parameter is a comma-separated list of resource +-- ids that the plugin refuses to delete without explicit +-- acknowledgement — required only when the workflow provisioned +-- resources of type @index_name@ or @pipeline_id@. Omitted from the +-- query string otherwise. +-- +-- Doc ambiguity: the OpenSearch docs page mislabels @allow-delete@ as a +-- \"path parameter\"; the plugin source +-- (@RestDeprovisionWorkflowAction@) reads it via @request.param@, i.e. +-- it is a query parameter, modelled as such here. +data DeprovisionWorkflowOptions = DeprovisionWorkflowOptions + { deprovisionWorkflowOptionsAllowDelete :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the plain +-- @POST /_plugins/_flow_framework/workflow/{workflow_id}/_deprovision@ +-- when passed to 'deprovisionWorkflowWith'. +defaultDeprovisionWorkflowOptions :: DeprovisionWorkflowOptions +defaultDeprovisionWorkflowOptions = + DeprovisionWorkflowOptions + { deprovisionWorkflowOptionsAllowDelete = Nothing + } + +-- | Render a 'DeprovisionWorkflowOptions' to the query-string pairs +-- accepted by the deprovision endpoint. Fields set to 'Nothing' are +-- omitted. +deprovisionWorkflowOptionsParams :: DeprovisionWorkflowOptions -> [(Text, Maybe Text)] +deprovisionWorkflowOptionsParams DeprovisionWorkflowOptions {..} = + catMaybes + [ (("allow_delete",) . Just) <$> deprovisionWorkflowOptionsAllowDelete + ] + +-- | The success response of 'deprovisionWorkflow': echoes only the +-- @workflow_id@ (the workflow returns to the @NOT_STARTED@ state). Two +-- non-success paths surface as an 'EsError' via the 'StatusDependant' +-- decoding rather than as this type: +-- +-- * @403 FORBIDDEN@ when @allow_delete@ is required but missing — the +-- body decodes directly as 'EsError' via the non-2xx branch of +-- 'parseEsResponse'. +-- * @202 ACCEPTED@ on partial deprovisioning — the body carries an +-- @error@ field instead of @workflow_id@, so the typed decode fails +-- and 'parseEsResponse' falls back to decoding the body as 'EsError' +-- (202 is a 2xx status, but its body is not this type). +-- +-- Verify against a live cluster if you depend on the @202@ distinction. +newtype DeprovisionWorkflowResponse = DeprovisionWorkflowResponse + { deprovisionWorkflowResponseWorkflowId :: WorkflowId + } + deriving stock (Eq, Show) + +instance FromJSON DeprovisionWorkflowResponse where + parseJSON = withObject "DeprovisionWorkflowResponse" $ \v -> do + deprovisionWorkflowResponseWorkflowId <- v .: "workflow_id" + pure DeprovisionWorkflowResponse {..} + +instance ToJSON DeprovisionWorkflowResponse where + toJSON DeprovisionWorkflowResponse {..} = + object + [ "workflow_id" .= deprovisionWorkflowResponseWorkflowId + ] + +-- ========================================================================= +-- Get workflow state options + response +-- ========================================================================= + +-- | Query-string parameters accepted by 'getWorkflowStateWith'. The +-- single @all@ flag requests the full state document (adding +-- @provisioning_progress@, @provision_start_time@, +-- @provision_end_time@, @user@ and @user_outputs@); the default +-- (@all = False@) returns only @workflow_id@, @state@, @error@ and +-- @resources_created@. +data WorkflowStateOptions = WorkflowStateOptions + { workflowStateOptionsAll :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the +-- bare @GET /_plugins/_flow_framework/workflow/{workflow_id}/_status@ +-- when passed to 'getWorkflowStateWith'. +defaultWorkflowStateOptions :: WorkflowStateOptions +defaultWorkflowStateOptions = + WorkflowStateOptions + { workflowStateOptionsAll = Nothing + } + +-- | Render a 'WorkflowStateOptions' to the query-string pairs accepted +-- by the Get Workflow State endpoint. Fields set to 'Nothing' are +-- omitted. +workflowStateOptionsParams :: WorkflowStateOptions -> [(Text, Maybe Text)] +workflowStateOptionsParams WorkflowStateOptions {..} = + catMaybes + [ (("all",) . Just . boolText) <$> workflowStateOptionsAll + ] + where + boolText True = "true" + boolText False = "false" + +-- | The response of the Get Workflow State API +-- (@GET /_plugins/_flow_framework/workflow/{workflow_id}/_status@). +-- @workflow_id@ and @state@ are always present; @error@ and +-- @resources_created@ appear conditionally. The remaining fields +-- emitted only under @all = True@ (@provisioning_progress@, +-- @provision_start_time@, @provision_end_time@, @user@, +-- @user_outputs@) are preserved verbatim in +-- 'workflowStateResponseOther' for forward compatibility. This is a +-- read-only server response, so only a 'FromJSON' instance is +-- provided (mirrors the cat-endpoint @*Other@ convention). +data WorkflowStateResponse = WorkflowStateResponse + { workflowStateResponseWorkflowId :: WorkflowId, + workflowStateResponseState :: WorkflowState, + workflowStateResponseError :: Maybe Text, + workflowStateResponseResourcesCreated :: Maybe [ResourceCreated], + workflowStateResponseOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON WorkflowStateResponse where + parseJSON = withObject "WorkflowStateResponse" $ \v -> do + workflowStateResponseWorkflowId <- v .: "workflow_id" + workflowStateResponseState <- v .: "state" + workflowStateResponseError <- v .:? "error" + workflowStateResponseResourcesCreated <- v .:? "resources_created" + let workflowStateResponseOther = Object v + pure WorkflowStateResponse {..} + +-- ========================================================================= +-- Get workflow steps response + options +-- ========================================================================= + +-- | A single workflow-step descriptor returned by the Get Workflow Steps +-- API (@GET /_plugins/_flow_framework/workflow/_steps@). The plugin +-- reports the step's @inputs@ (the @user_inputs@ keys the step reads), +-- @outputs@ (the field names it injects into downstream nodes via +-- 'workflowNodePreviousInputs'), and @required_plugins@ (the plugin(s) +-- that register the step, e.g. @opensearch-ml@). The docs also promise a +-- \"default timeout value\" per step but never name or show the field, so +-- any additional keys survive verbatim in 'workflowStepOther' (mirrors the +-- 'workflowStateResponseOther' forward-compat convention). +-- +-- This is a read-only server response, so only a 'FromJSON' instance is +-- provided. +data WorkflowStep = WorkflowStep + { workflowStepInputs :: [Text], + workflowStepOutputs :: [Text], + workflowStepRequiredPlugins :: [Text], + workflowStepOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON WorkflowStep where + parseJSON = withObject "WorkflowStep" $ \v -> do + workflowStepInputs <- v .:? "inputs" .!= [] + workflowStepOutputs <- v .:? "outputs" .!= [] + workflowStepRequiredPlugins <- v .:? "required_plugins" .!= [] + let workflowStepOther = Object v + pure WorkflowStep {..} + +-- | The response of the Get Workflow Steps API: a map keyed by step name +-- (e.g. @create_connector@, @register_remote_model@) to its +-- 'WorkflowStep' descriptor. Wrapped as a newtype so the response has a +-- discoverable type name (matching the module's named-response +-- convention) while delegating (de)serialization to the underlying 'Map'. +newtype WorkflowStepsResponse = WorkflowStepsResponse + { unWorkflowStepsResponse :: Map Text WorkflowStep + } + deriving stock (Eq, Show) + +instance FromJSON WorkflowStepsResponse where + parseJSON v = WorkflowStepsResponse <$> parseJSON v + +-- | Query-string parameters accepted by 'getWorkflowStepsWith'. The single +-- @workflow_step@ field is a comma-separated list of step names to fetch +-- (e.g. @"create_connector,deploy_model"@); omitted, the endpoint returns +-- every registered step. +-- +-- Doc ambiguity: the OpenSearch docs site is internally inconsistent about +-- the query parameter name — the \"Endpoints\" section documents +-- @workflow_step@ (singular) while one sample request writes +-- @workflow_steps@ (plural). The @RestGetWorkflowStepAction@ plugin entry +-- point reads @workflow_step@, which is modelled here; revisit if a future +-- plugin release widens the surface. +data WorkflowStepsOptions = WorkflowStepsOptions + { workflowStepsStep :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the bare +-- @GET /_plugins/_flow_framework/workflow/_steps@ when passed to +-- 'getWorkflowStepsWith'. +defaultWorkflowStepsOptions :: WorkflowStepsOptions +defaultWorkflowStepsOptions = + WorkflowStepsOptions + { workflowStepsStep = Nothing + } + +-- | Render a 'WorkflowStepsOptions' to the query-string pairs accepted by +-- the Get Workflow Steps endpoint. Fields set to 'Nothing' are omitted. +workflowStepsOptionsParams :: WorkflowStepsOptions -> [(Text, Maybe Text)] +workflowStepsOptionsParams WorkflowStepsOptions {..} = + catMaybes + [ (("workflow_step",) . Just) <$> workflowStepsStep + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/ISM.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/ISM.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/ISM.hs @@ -0,0 +1,1578 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.ISM where + +import Data.Aeson.Key qualified as AKey +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Database.Bloodhound.Internal.Client.Doc (DocVersion) +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.ExpandWildcards + ( ExpandWildcards, + expandWildcardsText, + ) + +-- $policySchema +-- +-- The OpenSearch ISM policy body has two faces: +-- +-- 1. The @PUT /_plugins/_ism/policies/{id}@ request carries the user-supplied +-- policy definition (no @policy_id@, no @schema_version@, no +-- @last_updated_time@ — the server injects those). +-- 2. The @GET /_plugins/_ism/policies\/{_id}@ response (and the inner @policy@ +-- object of the @PUT@ response) carries the same body with server-injected +-- metadata mixed in. +-- +-- We split these into 'ISMPolicyRequest' and 'ISMPolicyResponse' so the +-- request shape cannot accidentally carry server-only fields and the +-- response shape can still round-trip the full server payload. +-- +-- See + +-- | The shared user-supplied policy body, used by both 'ISMPolicyRequest' and +-- 'ISMPolicyResponse'. Carries only the fields the client supplies: +-- @description@, @default_state@, @states@, optional @ism_template@, +-- optional @error_notification@, optional @user_vars@. +data ISMPolicyBody = ISMPolicyBody + { ismPolicyBodyDescription :: Maybe Text, + ismPolicyBodyDefaultState :: Text, + ismPolicyBodyStates :: [ISMState], + ismPolicyBodyIsmTemplate :: [ISMTemplate], + ismPolicyBodyErrorNotification :: Maybe ISMErrorNotification, + ismPolicyBodyUserVariables :: Maybe ISMUserVariables + } + deriving stock (Eq, Show) + +instance FromJSON ISMPolicyBody where + parseJSON = withObject "ISMPolicyBody" $ \v -> do + ismPolicyBodyDescription <- v .:? "description" + ismPolicyBodyDefaultState <- v .: "default_state" + -- 'states' is required by OpenSearch and must be non-empty; we read it + -- strictly so malformed bodies missing the key fail-fast instead of + -- silently producing a policy whose 'default_state' points at nothing. + ismPolicyBodyStates <- v .: "states" + -- The spec allows @ism_template@ as a single object, @null@, or an array + -- of objects; a policy may carry one or more templates. Normalise all + -- three forms into a list: missing/null -> [], a bare object -> [obj], + -- an array -> its elements. + rawTemplate <- v .:? "ism_template" + ismPolicyBodyIsmTemplate <- case rawTemplate of + Nothing -> pure [] + Just Null -> pure [] + Just arr@(Array _) -> parseJSON arr + Just other -> (: []) <$> parseJSON other + ismPolicyBodyErrorNotification <- v .:? "error_notification" + ismPolicyBodyUserVariables <- v .:? "user_vars" + return ISMPolicyBody {..} + +instance ToJSON ISMPolicyBody where + toJSON ISMPolicyBody {..} = + omitNulls + [ "description" .= ismPolicyBodyDescription, + "default_state" .= ismPolicyBodyDefaultState, + "states" .= ismPolicyBodyStates, + "ism_template" .= ismPolicyBodyIsmTemplate, + "error_notification" .= ismPolicyBodyErrorNotification, + "user_vars" .= ismPolicyBodyUserVariables + ] + +-- | The request body for @PUT /_plugins/_ism/policies/{id}@. OpenSearch +-- requires the user-supplied policy body to be wrapped in a top-level +-- @policy@ key, so 'ISMPolicyRequest' encodes as +-- @{"policy": {…body…}}@. The wrapper is invisible at the type level: callers +-- build an 'ISMPolicyBody', wrap it in 'ISMPolicyRequest', and the +-- 'ToJSON' instance handles the wire-level wrapping. +-- See +newtype ISMPolicyRequest = ISMPolicyRequest {unISMPolicyRequest :: ISMPolicyBody} + deriving stock (Eq, Show) + +instance FromJSON ISMPolicyRequest where + parseJSON original@(Object o) = + -- Prefer the wrapped shape @{"policy": {…}}@; fall back to a bare body + -- so hand-built fixtures that skip the wrapper still decode cleanly. + (ISMPolicyRequest <$> o .: "policy") + <|> (ISMPolicyRequest <$> parseJSON original) + parseJSON v = ISMPolicyRequest <$> parseJSON v + +instance ToJSON ISMPolicyRequest where + toJSON req = object ["policy" .= unISMPolicyRequest req] + +-- | The policy shape returned in responses (@GET /_plugins/_ism/policies@, the +-- inner @policy@ object of a @PUT@ response). Adds the three server-injected +-- fields (@policy_id@, @schema_version@, @last_updated_time@) alongside the +-- shared body fields. OpenSearch populates them inside the inner policy body +-- on @GET /_plugins/_ism/policies\/{_id}@; @PUT@ responses historically put +-- them on the outer @policy@ wrapper. 'PutISMPolicyResponse' reconciles both +-- placements by reading the inner body verbatim and falling back to the outer +-- wrapper fields when the inner doesn't carry them. +data ISMPolicyResponse = ISMPolicyResponse + { ismPolicyResponsePolicyId :: Maybe Text, + ismPolicyResponseSchemaVersion :: Maybe Int, + ismPolicyResponseLastUpdatedTime :: Maybe Int, + ismPolicyResponseBody :: ISMPolicyBody + } + deriving stock (Eq, Show) + +instance FromJSON ISMPolicyResponse where + parseJSON v = do + body <- parseJSON v + withObject + "ISMPolicyResponse" + ( \o -> do + ismPolicyResponsePolicyId <- o .:? "policy_id" + ismPolicyResponseSchemaVersion <- o .:? "schema_version" + ismPolicyResponseLastUpdatedTime <- o .:? "last_updated_time" + return ISMPolicyResponse {ismPolicyResponseBody = body, ..} + ) + v + +instance ToJSON ISMPolicyResponse where + toJSON ISMPolicyResponse {..} = + omitNulls $ + catMaybes + [ fmap ("policy_id" .=) ismPolicyResponsePolicyId, + fmap ("schema_version" .=) ismPolicyResponseSchemaVersion, + fmap ("last_updated_time" .=) ismPolicyResponseLastUpdatedTime + ] + <> bodyPairs + where + bodyPairs = + case toJSON ismPolicyResponseBody of + Object o -> KM.toList o + _ -> [] + +-- | 'PolicyId' identifies an ISM policy in the +-- @\/_plugins\/_ism\/policies\/{id}@ URL path. Wraps 'Text' so it round-trips +-- through JSON as a bare string but is distinct at the Haskell type level. +-- See +newtype PolicyId = PolicyId {unPolicyId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Response of @PUT /_plugins/_ism/policies/{id}@. The server returns the +-- standard document-write envelope (@_id@, @_version@, @_seq_no@, +-- @_primary_term@) wrapping a single @policy@ key. That @policy@ object +-- itself contains @schema_version@, @last_updated_time@ and an inner +-- @policy@ body. Different OpenSearch versions disagree on whether +-- @schema_version@ / @last_updated_time@ live on the outer wrapper or inside +-- the inner body, so the decoder merges both sources into the inner +-- 'ISMPolicyResponse'. Callers should read those fields from +-- 'putISMPolicyResponsePolicy' rather than expecting them at the outer level. +data PutISMPolicyResponse = PutISMPolicyResponse + { putISMPolicyResponseId :: Text, + putISMPolicyResponseVersion :: DocVersion, + putISMPolicyResponsePrimaryTerm :: Int, + putISMPolicyResponseSeqNo :: Int, + putISMPolicyResponsePolicy :: ISMPolicyResponse + } + deriving stock (Eq, Show) + +instance FromJSON PutISMPolicyResponse where + parseJSON = withObject "PutISMPolicyResponse" $ \v -> do + putISMPolicyResponseId <- v .: "_id" + putISMPolicyResponseVersion <- v .: "_version" + putISMPolicyResponsePrimaryTerm <- v .: "_primary_term" + putISMPolicyResponseSeqNo <- v .: "_seq_no" + envelope <- v .: "policy" + -- OpenSearch's documented shape nests the user body inside + -- policy.policy and carries schema_version/last_updated_time there + -- (and sometimes also on the outer policy wrapper). Read the inner + -- body verbatim into ISMPolicyResponse (which already picks up + -- schema_version/last_updated_time when present) and merge the outer + -- envelope fields in when the inner doesn't carry them. + innerBody <- envelope .: "policy" + outerSchemaVersion <- envelope .:? "schema_version" + outerLastUpdated <- envelope .:? "last_updated_time" + parsedInner <- parseJSON innerBody + let merged = + parsedInner + { ismPolicyResponseSchemaVersion = + ismPolicyResponseSchemaVersion parsedInner <|> outerSchemaVersion, + ismPolicyResponseLastUpdatedTime = + ismPolicyResponseLastUpdatedTime parsedInner <|> outerLastUpdated + } + return PutISMPolicyResponse {putISMPolicyResponsePolicy = merged, ..} + +instance ToJSON PutISMPolicyResponse where + toJSON PutISMPolicyResponse {..} = + omitNulls + [ "_id" .= putISMPolicyResponseId, + "_version" .= putISMPolicyResponseVersion, + "_primary_term" .= putISMPolicyResponsePrimaryTerm, + "_seq_no" .= putISMPolicyResponseSeqNo, + "policy" .= object ["policy" .= putISMPolicyResponsePolicy] + ] + +-- | A named state in the policy state machine. The managed index transitions +-- from @name@ to the next state when any of @transitions@ matches; on entry it +-- runs every @actions@ entry. Both lists default to empty so a minimal +-- @{\"name\": \"hot\"}@ state decodes cleanly. +-- See +data ISMState = ISMState + { ismStateName :: Text, + ismStateActions :: [ISMActionEntry], + ismStateTransitions :: [ISMTransition] + } + deriving stock (Eq, Show) + +instance FromJSON ISMState where + parseJSON = withObject "ISMState" $ \v -> do + ismStateName <- v .: "name" + ismStateActions <- v .:? "actions" .!= [] + ismStateTransitions <- v .:? "transitions" .!= [] + return ISMState {..} + +instance ToJSON ISMState where + toJSON ISMState {..} = + omitNulls + [ "name" .= ismStateName, + "actions" .= ismStateActions, + "transitions" .= ismStateTransitions + ] + +-- | A state transition. @stateName@ names the destination state; @conditions@ +-- is the optional guard. When @conditions@ is 'Nothing' the transition is +-- unconditional. +-- See +data ISMTransition = ISMTransition + { ismTransitionStateName :: Text, + ismTransitionConditions :: Maybe ISMCondition + } + deriving stock (Eq, Show) + +instance FromJSON ISMTransition where + parseJSON = withObject "ISMTransition" $ \v -> do + ismTransitionStateName <- v .: "state_name" + ismTransitionConditions <- v .:? "conditions" + return ISMTransition {..} + +instance ToJSON ISMTransition where + toJSON ISMTransition {..} = + omitNulls + [ "state_name" .= ismTransitionStateName, + "conditions" .= ismTransitionConditions + ] + +-- | The guard on a transition. OpenSearch accepts any subset of these +-- thresholds; all are 'Maybe' so callers can express just the ones they need. +-- See +data ISMCondition = ISMCondition + { ismConditionMinSize :: Maybe Text, + ismConditionMinDocCount :: Maybe Int, + ismConditionMinIndexAge :: Maybe Text, + ismConditionMinRolloverAge :: Maybe Text, + ismConditionCron :: Maybe ISMCron, + ismConditionDsl :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMCondition where + parseJSON = withObject "ISMCondition" $ \v -> do + ismConditionMinSize <- v .:? "min_size" + ismConditionMinDocCount <- v .:? "min_doc_count" + ismConditionMinIndexAge <- v .:? "min_index_age" + ismConditionMinRolloverAge <- v .:? "min_rollover_age" + ismConditionCron <- v .:? "cron" + ismConditionDsl <- v .:? "dsl" + return ISMCondition {..} + +instance ToJSON ISMCondition where + toJSON ISMCondition {..} = + omitNulls + [ "min_size" .= ismConditionMinSize, + "min_doc_count" .= ismConditionMinDocCount, + "min_index_age" .= ismConditionMinIndexAge, + "min_rollover_age" .= ismConditionMinRolloverAge, + "cron" .= ismConditionCron, + "dsl" .= ismConditionDsl + ] + +-- | Inner payload of a cron transition condition: the cron expression and an +-- optional timezone. See 'ISMCron' for the outer wrapper OpenSearch expects. +-- See +data ISMCronCondition = ISMCronCondition + { ismCronConditionExpression :: Text, + ismCronConditionTimezone :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMCronCondition where + parseJSON = withObject "ISMCronCondition" $ \v -> do + ismCronConditionExpression <- v .: "expression" + ismCronConditionTimezone <- v .:? "timezone" + return ISMCronCondition {..} + +instance ToJSON ISMCronCondition where + toJSON ISMCronCondition {..} = + omitNulls + [ "expression" .= ismCronConditionExpression, + "timezone" .= ismCronConditionTimezone + ] + +-- | Outer wrapper OpenSearch requires around an 'ISMCronCondition'. The +-- documented @conditions.cron@ value is an object containing a nested @cron@ +-- key: @{\"cron\":{\"cron\":{\"expression\":...,\"timezone\":...}}}@. The +-- outer 'ISMCron' models the middle layer so 'ISMCondition''s parser can +-- decode the documented shape directly. +-- See +newtype ISMCron = ISMCron {ismCronInner :: ISMCronCondition} + deriving stock (Eq, Show) + +instance FromJSON ISMCron where + parseJSON = withObject "ISMCron" $ \v -> do + inner <- v .: "cron" + return (ISMCron inner) + +instance ToJSON ISMCron where + toJSON (ISMCron inner) = + omitNulls ["cron" .= inner] + +-- | The auto-apply template that attaches this policy to newly-created indices +-- whose name matches one of @indexPatterns@. @priority@ breaks ties when +-- multiple templates match. +-- See +data ISMTemplate = ISMTemplate + { ismTemplateIndexPatterns :: [Text], + ismTemplatePriority :: Maybe Scientific + } + deriving stock (Eq, Show) + +instance FromJSON ISMTemplate where + parseJSON = withObject "ISMTemplate" $ \v -> do + ismTemplateIndexPatterns <- v .:? "index_patterns" .!= [] + ismTemplatePriority <- v .:? "priority" + return ISMTemplate {..} + +instance ToJSON ISMTemplate where + toJSON ISMTemplate {..} = + omitNulls + [ "index_patterns" .= ismTemplateIndexPatterns, + "priority" .= ismTemplatePriority + ] + +-- | The destination of an 'ISMErrorNotification'. OpenSearch's Policies doc +-- (https://docs.opensearch.org/3.7/im-plugin/ism/policies/#error-notification) +-- lists three destination kinds: @chime@, @custom_webhook@ and @slack@. +-- Unknown destination types fall through to 'ISMErrorNotificationDestinationCustom'. +data ISMErrorNotificationDestination + = ISMErrorNotificationDestinationChime (Maybe Value) + | ISMErrorNotificationDestinationCustomWebhook (Maybe Value) + | ISMErrorNotificationDestinationSlack (Maybe Value) + | ISMErrorNotificationDestinationCustom Text (Maybe Value) + deriving stock (Eq, Show) + +destinationTag :: ISMErrorNotificationDestination -> Text +destinationTag = \case + ISMErrorNotificationDestinationChime _ -> "chime" + ISMErrorNotificationDestinationCustomWebhook _ -> "custom_webhook" + ISMErrorNotificationDestinationSlack _ -> "slack" + ISMErrorNotificationDestinationCustom tag _ -> tag + +destinationConfig :: ISMErrorNotificationDestination -> Maybe Value +destinationConfig = \case + ISMErrorNotificationDestinationChime cfg -> cfg + ISMErrorNotificationDestinationCustomWebhook cfg -> cfg + ISMErrorNotificationDestinationSlack cfg -> cfg + ISMErrorNotificationDestinationCustom _ cfg -> cfg + +instance FromJSON ISMErrorNotificationDestination where + parseJSON = withObject "ISMErrorNotificationDestination" $ \o -> case KM.toList o of + [] -> fail "ISMErrorNotificationDestination: empty object" + ((k, v) : _) -> case AKey.toText k of + "chime" -> ISMErrorNotificationDestinationChime <$> parseJSON v + "custom_webhook" -> ISMErrorNotificationDestinationCustomWebhook <$> parseJSON v + "slack" -> ISMErrorNotificationDestinationSlack <$> parseJSON v + other -> ISMErrorNotificationDestinationCustom other <$> parseJSON v + +instance ToJSON ISMErrorNotificationDestination where + toJSON d = + object + [ AKey.fromText (destinationTag d) + .= maybe (object []) id (destinationConfig d) + ] + +-- | The Mustache template used to render an 'ISMErrorNotification' message. +-- OpenSearch documents only the @source@ field, but the server injects @lang@ +-- (typically @"mustache"@) on responses; we carry it as 'Maybe' so a GET → PUT +-- round-trip is lossless (mirrors the Alerting plugin's @MessageTemplate@). See +-- the @message_template@ parameter at +-- . +data ISMMessageTemplate = ISMMessageTemplate + { ismMessageTemplateSource :: Text, + ismMessageTemplateLang :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMMessageTemplate where + parseJSON = withObject "ISMMessageTemplate" $ \v -> do + ismMessageTemplateSource <- v .: "source" + ismMessageTemplateLang <- v .:? "lang" + pure ISMMessageTemplate {..} + +instance ToJSON ISMMessageTemplate where + toJSON ISMMessageTemplate {..} = + omitNulls + [ "source" .= ismMessageTemplateSource, + "lang" .= ismMessageTemplateLang + ] + +-- | Error-notification block attached to a policy: when an action fails, OS +-- notifies either a @destination@ (Slack/Chime/webhook URL) or a Notifications +-- plugin @channel@. Per the policies doc, exactly one of 'destination' / +-- 'channel' must be present (they are mutually exclusive); the parser enforces +-- that invariant. +-- See +data ISMErrorNotification = ISMErrorNotification + { ismErrorNotificationDestination :: Maybe ISMErrorNotificationDestination, + ismErrorNotificationChannelId :: Maybe Text, + ismErrorNotificationMessageTemplate :: ISMMessageTemplate + } + deriving stock (Eq, Show) + +instance FromJSON ISMErrorNotification where + parseJSON = withObject "ISMErrorNotification" $ \v -> do + ismErrorNotificationDestination <- v .:? "destination" + mChannel <- v .:? "channel" + case (ismErrorNotificationDestination, mChannel) of + (Nothing, Nothing) -> + fail "ISMErrorNotification requires either 'destination' or 'channel'" + (Just _, Just _) -> + fail "ISMErrorNotification: 'destination' and 'channel' are mutually exclusive" + _ -> pure () + ismErrorNotificationChannelId <- case mChannel of + Nothing -> pure Nothing + Just ch -> Just <$> withObject "ISMErrorNotification channel" (.: "id") ch + ismErrorNotificationMessageTemplate <- v .: "message_template" + return ISMErrorNotification {..} + +instance ToJSON ISMErrorNotification where + toJSON ISMErrorNotification {..} = + omitNulls + [ "destination" .= ismErrorNotificationDestination, + "channel" .= channelValue ismErrorNotificationChannelId, + "message_template" .= ismErrorNotificationMessageTemplate + ] + where + channelValue = \case + Nothing -> Null + Just cid -> object ["id" .= cid] + +-- | User-supplied variable substitutions, used inside Mustache templates +-- (@{{{ctx.user_vars.}}}@). OS allows arbitrary JSON here; we expose the +-- common @Map Text Text@ shape and lose anything more exotic. +-- See +newtype ISMUserVariables = ISMUserVariables {unISMUserVariables :: Map.Map Text Text} + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) + +-- $actions +-- +-- OpenSearch encodes a state @actions@ entry as a JSON object whose keys +-- are the action name plus optional @timeout@ \/ @retry@ siblings. The +-- action-name key carries that action's config (or @{}@ when there is +-- none). For example: +-- +-- @{"rollover": {"min_size": "1gb"}}@, @{"delete": {}}@, and (with meta) +-- @{"rollover": {"min_size": "1gb"}, "timeout": "1d"}@. +-- +-- 'ISMAction' models the action half (one constructor per known action +-- plus an 'ISMActionCustom' escape hatch that preserves unknown action +-- types losslessly); 'ISMActionEntry' pairs it with the optional +-- per-action meta. Only the three most common actions ('ISMActionRollover', +-- 'ISMActionForceMerge', 'ISMActionAllocation') carry typed configs today; the +-- remaining constructors carry their config as an opaque 'Value' (typing them +-- is tracked as follow-up work). + +data ISMAction + = ISMActionRollover (Maybe ISMRolloverConfig) + | ISMActionDelete + | ISMActionForceMerge (Maybe ISMForceMergeConfig) + | ISMActionAllocation (Maybe ISMAllocationConfig) + | ISMActionNotification (Maybe Value) + | ISMActionSnapshot (Maybe Value) + | ISMActionReadWrite (Maybe Value) + | ISMActionReadOnly + | ISMActionShrink (Maybe Value) + | ISMActionOpen + | ISMActionClose + | ISMActionRollup (Maybe Value) + | ISMActionIndexPriority (Maybe Value) + | ISMActionFreeze + | ISMActionUnfreeze + | ISMActionWaitFor (Maybe Value) + | ISMActionReplicaCount (Maybe ISMReplicaCountConfig) + | ISMActionAlias (Maybe ISMAliasConfig) + | ISMActionCustom Text (Maybe Value) + deriving stock (Eq, Show) + +-- | Name of the single JSON key that encodes this action (matches what OS +-- sends on the wire). +actionTagName :: ISMAction -> Text +actionTagName = \case + ISMActionRollover _ -> "rollover" + ISMActionDelete -> "delete" + ISMActionForceMerge _ -> "force_merge" + ISMActionAllocation _ -> "allocation" + ISMActionNotification _ -> "notification" + ISMActionSnapshot _ -> "snapshot" + ISMActionReadWrite _ -> "read_write" + ISMActionReadOnly -> "read_only" + ISMActionShrink _ -> "shrink" + ISMActionOpen -> "open" + ISMActionClose -> "close" + ISMActionRollup _ -> "rollup" + ISMActionIndexPriority _ -> "index_priority" + ISMActionFreeze -> "freeze" + ISMActionUnfreeze -> "unfreeze" + ISMActionWaitFor _ -> "wait_for" + ISMActionReplicaCount _ -> "replica_count" + ISMActionAlias _ -> "alias" + ISMActionCustom tag _ -> tag + +-- | Render the action's config as a 'Value'. For actions without a config this +-- is an empty object @{}@; for opaque actions it is whatever the caller put in +-- (or @{}@ if 'Nothing'). +actionConfigValue :: ISMAction -> Value +actionConfigValue = \case + ISMActionRollover cfg -> maybe (object []) toJSON cfg + ISMActionDelete -> object [] + ISMActionForceMerge cfg -> maybe (object []) toJSON cfg + ISMActionAllocation cfg -> maybe (object []) toJSON cfg + ISMActionNotification cfg -> maybe (object []) toJSON cfg + ISMActionSnapshot cfg -> maybe (object []) toJSON cfg + ISMActionReadWrite cfg -> maybe (object []) toJSON cfg + ISMActionReadOnly -> object [] + ISMActionShrink cfg -> maybe (object []) toJSON cfg + ISMActionOpen -> object [] + ISMActionClose -> object [] + ISMActionRollup cfg -> maybe (object []) toJSON cfg + ISMActionIndexPriority cfg -> maybe (object []) toJSON cfg + ISMActionFreeze -> object [] + ISMActionUnfreeze -> object [] + ISMActionWaitFor cfg -> maybe (object []) toJSON cfg + ISMActionReplicaCount cfg -> maybe (object []) toJSON cfg + ISMActionAlias cfg -> maybe (object []) toJSON cfg + ISMActionCustom _ cfg -> maybe (object []) toJSON cfg + +instance FromJSON ISMAction where + parseJSON = withObject "ISMAction" $ \o -> case KM.toList o of + [] -> fail "ISMAction: empty object" + ((k, v) : _) -> case AKey.toText k of + "rollover" -> ISMActionRollover <$> parseJSON v + "delete" -> pure ISMActionDelete + "force_merge" -> ISMActionForceMerge <$> parseJSON v + "allocation" -> ISMActionAllocation <$> parseJSON v + "notification" -> ISMActionNotification <$> parseJSON v + "snapshot" -> ISMActionSnapshot <$> parseJSON v + "read_write" -> ISMActionReadWrite <$> parseJSON v + "read_only" -> pure ISMActionReadOnly + "shrink" -> ISMActionShrink <$> parseJSON v + "open" -> pure ISMActionOpen + "close" -> pure ISMActionClose + "rollup" -> ISMActionRollup <$> parseJSON v + "index_priority" -> ISMActionIndexPriority <$> parseJSON v + "freeze" -> pure ISMActionFreeze + "unfreeze" -> pure ISMActionUnfreeze + "wait_for" -> ISMActionWaitFor <$> parseJSON v + "replica_count" -> ISMActionReplicaCount <$> parseJSON v + "alias" -> ISMActionAlias <$> parseJSON v + other -> ISMActionCustom other <$> parseJSON v + +instance ToJSON ISMAction where + toJSON a = object [AKey.fromText (actionTagName a) .= actionConfigValue a] + +-- $actionMeta +-- +-- Beyond the action-specific config, OS accepts two orthogonal parameters +-- on every action entry: @timeout@ and @retry@ +-- (). +-- These sit alongside the action key as siblings in the same JSON object, +-- e.g.: +-- +-- @ +-- { "rollover": {"min_size": "50gb"}, +-- , "timeout": "1d" +-- , "retry": {"count": 3, "backoff": "exponential", "delay": "1m"} +-- } +-- @ +-- +-- 'ISMActionEntry' pairs an 'ISMAction' with its optional meta so the +-- per-action configuration stays orthogonal to the action type itself. +-- 'mkISMActionEntry' produces an entry whose wire shape is byte-for-byte +-- identical to the legacy bare 'ISMAction' for any *known* action (no +-- @timeout@\/@retry@ keys emitted), preserving backwards compatibility +-- with existing callers. The names @"timeout"@ and @"retry"@ are +-- reserved: an 'ISMActionCustom' that reuses either as its tag would be +-- shadowed by the meta merge — see the note on 'ISMActionEntry's +-- 'ToJSON' instance. +-- +-- /Maintainer note:/ 'ISMActionEntry's codecs strip exactly +-- @["timeout", "retry"]@ before delegating to 'ISMAction'. If OS grows +-- additional per-action meta siblings in a future release, extend that +-- strip list in both 'FromJSON' and 'ToJSON' to keep the action parser +-- from mis-reading the new sibling as an 'ISMActionCustom'. + +-- | Backoff strategy used by 'ISMRetryConfig'. OS accepts exactly these +-- three values; the 'FromJSON' instance rejects anything else so a typo +-- surfaces at decode time rather than being silently dropped. +data ISMRetryBackoff + = ISMRetryBackoffExponential + | ISMRetryBackoffConstant + | ISMRetryBackoffLinear + deriving stock (Eq, Show) + +ismRetryBackoffText :: ISMRetryBackoff -> Text +ismRetryBackoffText ISMRetryBackoffExponential = "exponential" +ismRetryBackoffText ISMRetryBackoffConstant = "constant" +ismRetryBackoffText ISMRetryBackoffLinear = "linear" + +instance FromJSON ISMRetryBackoff where + parseJSON = withText "ISMRetryBackoff" $ \case + "exponential" -> pure ISMRetryBackoffExponential + "constant" -> pure ISMRetryBackoffConstant + "linear" -> pure ISMRetryBackoffLinear + other -> fail ("unknown ISM retry backoff: " <> T.unpack other) + +instance ToJSON ISMRetryBackoff where + toJSON = String . ismRetryBackoffText + +-- | Per-action retry configuration. Every field is optional; OS fills in +-- sensible defaults when omitted. +-- See +data ISMRetryConfig = ISMRetryConfig + { ismRetryConfigCount :: Maybe Int, + ismRetryConfigBackoff :: Maybe ISMRetryBackoff, + ismRetryConfigDelay :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMRetryConfig where + parseJSON = withObject "ISMRetryConfig" $ \v -> do + ismRetryConfigCount <- v .:? "count" + ismRetryConfigBackoff <- v .:? "backoff" + ismRetryConfigDelay <- v .:? "delay" + return ISMRetryConfig {..} + +instance ToJSON ISMRetryConfig where + toJSON ISMRetryConfig {..} = + omitNulls + [ "count" .= ismRetryConfigCount, + "backoff" .= ismRetryConfigBackoff, + "delay" .= ismRetryConfigDelay + ] + +-- | One entry in 'ismStateActions'. Pairs the action-specific config +-- ('ISMAction') with the orthogonal per-action meta (@timeout@, @retry@). +-- Use 'mkISMActionEntry' to construct an entry that decodes byte-for-byte +-- like the legacy bare 'ISMAction'. +data ISMActionEntry = ISMActionEntry + { ismActionEntryAction :: ISMAction, + -- | @timeout@ sibling. OS accepts time units for minutes, hours and + -- days (e.g. @"1d"@, @"60m"@). Kept as plain 'Text' so callers can + -- build any valid OS literal without the library having to model the + -- restricted grammar. + ismActionEntryTimeout :: Maybe Text, + ismActionEntryRetry :: Maybe ISMRetryConfig + } + deriving stock (Eq, Show) + +-- | Smart constructor that produces an entry with no meta. The resulting +-- wire shape is byte-for-byte identical to the bare 'ISMAction', so +-- callers migrating from the legacy @[ISMAction]@ shape can wrap each +-- element mechanically. +mkISMActionEntry :: ISMAction -> ISMActionEntry +mkISMActionEntry a = ISMActionEntry a Nothing Nothing + +instance FromJSON ISMActionEntry where + parseJSON = withObject "ISMActionEntry" $ \o -> do + -- Strip the meta keys so the remaining single-key object parses as + -- the underlying 'ISMAction' via its existing instance. + let body = Object (deleteSeveral ["timeout", "retry"] o) + ismActionEntryAction <- parseJSON body + ismActionEntryTimeout <- o .:? "timeout" + ismActionEntryRetry <- o .:? "retry" + return ISMActionEntry {..} + +instance ToJSON ISMActionEntry where + toJSON ISMActionEntry {..} = + case toJSON ismActionEntryAction of + Object inner -> + Object (deleteSeveral ["timeout", "retry"] inner <> meta) + where + meta = + KM.fromList $ + [ ("timeout", toJSON t) | Just t <- [ismActionEntryTimeout] + ] + <> [ ("retry", toJSON r) | Just r <- [ismActionEntryRetry] + ] + -- Defensive: 'ISMAction' always renders to a single-key 'Object', + -- so this branch is unreachable in practice but keeps the instance + -- total. + other -> other + +ismActionEntryActionLens :: Lens' ISMActionEntry ISMAction +ismActionEntryActionLens = lens ismActionEntryAction (\x y -> x {ismActionEntryAction = y}) + +ismActionEntryTimeoutLens :: Lens' ISMActionEntry (Maybe Text) +ismActionEntryTimeoutLens = lens ismActionEntryTimeout (\x y -> x {ismActionEntryTimeout = y}) + +ismActionEntryRetryLens :: Lens' ISMActionEntry (Maybe ISMRetryConfig) +ismActionEntryRetryLens = lens ismActionEntryRetry (\x y -> x {ismActionEntryRetry = y}) + +-- | Config for 'ISMActionRollover'. OS requires at least one threshold; we keep +-- all four 'Maybe' so callers can express any subset. Sizes/ages carry units +-- (e.g. @"1gb"@, @"1d"@) so they are 'Text', not numbers. +-- See +data ISMRolloverConfig = ISMRolloverConfig + { ismRolloverConfigMinSize :: Maybe Text, + ismRolloverConfigMinDocCount :: Maybe Int, + ismRolloverConfigMinIndexAge :: Maybe Text, + ismRolloverConfigMinPrimaryShardSize :: Maybe Text, + ismRolloverConfigCopyAlias :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON ISMRolloverConfig where + parseJSON = withObject "ISMRolloverConfig" $ \v -> do + ismRolloverConfigMinSize <- v .:? "min_size" + ismRolloverConfigMinDocCount <- v .:? "min_doc_count" + ismRolloverConfigMinIndexAge <- v .:? "min_index_age" + ismRolloverConfigMinPrimaryShardSize <- v .:? "min_primary_shard_size" + ismRolloverConfigCopyAlias <- v .:? "copy_alias" + return ISMRolloverConfig {..} + +instance ToJSON ISMRolloverConfig where + toJSON ISMRolloverConfig {..} = + omitNulls + [ "min_size" .= ismRolloverConfigMinSize, + "min_doc_count" .= ismRolloverConfigMinDocCount, + "min_index_age" .= ismRolloverConfigMinIndexAge, + "min_primary_shard_size" .= ismRolloverConfigMinPrimaryShardSize, + "copy_alias" .= ismRolloverConfigCopyAlias + ] + +-- | Config for 'ISMActionForceMerge'. +-- @max_num_segments@ is the only field documented for OS 1.3. OS 2.x added +-- @wait_for_completion@ (default @true@) and @task_execution_timeout@ (default +-- @1h@, only meaningful when @wait_for_completion@ is @false@); both are +-- optional and rendered as duration strings (e.g. @"1h"@), hence 'Text'. +-- See +data ISMForceMergeConfig = ISMForceMergeConfig + { ismForceMergeConfigMaxNumSegments :: Maybe Int, + ismForceMergeConfigWaitForCompletion :: Maybe Bool, + ismForceMergeConfigTaskExecutionTimeout :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMForceMergeConfig where + parseJSON = withObject "ISMForceMergeConfig" $ \v -> do + ismForceMergeConfigMaxNumSegments <- v .:? "max_num_segments" + ismForceMergeConfigWaitForCompletion <- v .:? "wait_for_completion" + ismForceMergeConfigTaskExecutionTimeout <- v .:? "task_execution_timeout" + return ISMForceMergeConfig {..} + +instance ToJSON ISMForceMergeConfig where + toJSON ISMForceMergeConfig {..} = + omitNulls + [ "max_num_segments" .= ismForceMergeConfigMaxNumSegments, + "wait_for_completion" .= ismForceMergeConfigWaitForCompletion, + "task_execution_timeout" .= ismForceMergeConfigTaskExecutionTimeout + ] + +-- | Config for 'ISMActionAllocation'. Each of @require@, @include@, @exclude@ +-- maps allocation attribute names to (comma-separated) values. @wait_for@ +-- gates whether the policy blocks until the reallocation completes +-- (: +-- @val waitFor: Boolean = false@). +-- See +data ISMAllocationConfig = ISMAllocationConfig + { ismAllocationConfigRequire :: Maybe (Map.Map Text Text), + ismAllocationConfigInclude :: Maybe (Map.Map Text Text), + ismAllocationConfigExclude :: Maybe (Map.Map Text Text), + ismAllocationConfigWaitFor :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON ISMAllocationConfig where + parseJSON = withObject "ISMAllocationConfig" $ \v -> do + ismAllocationConfigRequire <- v .:? "require" + ismAllocationConfigInclude <- v .:? "include" + ismAllocationConfigExclude <- v .:? "exclude" + ismAllocationConfigWaitFor <- v .:? "wait_for" + return ISMAllocationConfig {..} + +instance ToJSON ISMAllocationConfig where + toJSON ISMAllocationConfig {..} = + omitNulls + [ "require" .= ismAllocationConfigRequire, + "include" .= ismAllocationConfigInclude, + "exclude" .= ismAllocationConfigExclude, + "wait_for" .= ismAllocationConfigWaitFor + ] + +-- | Config for 'ISMActionReplicaCount'. OS requires @number_of_replicas@ to be +-- present (it has no sensible default), so the field is a strict 'Int' rather +-- than 'Maybe'. A caller who builds 'ISMActionReplicaCount' 'Nothing' encodes +-- as @{"replica_count":{}}@ which the server will reject — that path is +-- intended only for round-tripping malformed payloads. +-- See +data ISMReplicaCountConfig = ISMReplicaCountConfig + { ismReplicaCountConfigNumberOfReplicas :: Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMReplicaCountConfig where + parseJSON = withObject "ISMReplicaCountConfig" $ \v -> do + ismReplicaCountConfigNumberOfReplicas <- v .: "number_of_replicas" + return ISMReplicaCountConfig {..} + +instance ToJSON ISMReplicaCountConfig where + toJSON ISMReplicaCountConfig {..} = + object ["number_of_replicas" .= ismReplicaCountConfigNumberOfReplicas] + +-- | One sub-action inside an 'ISMAliasConfig' @actions@ array. OS supports +-- @add@ and @remove@; both carry at least the alias name. @add@ additionally +-- accepts @index@ (which index to attach) and @is_write_index@. This is the +-- minimal typed surface covering the documented example +-- (); any +-- more exotic sub-action can still be carried losslessly via +-- 'ISMActionCustom' on the outer 'ISMAction'. +data ISMAliasAction + = ISMAliasActionAdd + { ismAliasActionAddAlias :: Text, + ismAliasActionAddIndex :: Maybe Text, + ismAliasActionAddIsWriteIndex :: Maybe Bool + } + | ISMAliasActionRemove + { ismAliasActionRemoveAlias :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMAliasAction where + parseJSON = withObject "ISMAliasAction" $ \o -> case KM.toList o of + [] -> fail "ISMAliasAction: empty object" + ((k, v) : _) -> case AKey.toText k of + "add" -> + withObject + "ISMAliasActionAdd" + ( \cfg -> do + ismAliasActionAddAlias <- cfg .: "alias" + ismAliasActionAddIndex <- cfg .:? "index" + ismAliasActionAddIsWriteIndex <- cfg .:? "is_write_index" + return ISMAliasActionAdd {..} + ) + v + "remove" -> + withObject + "ISMAliasActionRemove" + ( \cfg -> do + ismAliasActionRemoveAlias <- cfg .: "alias" + return ISMAliasActionRemove {..} + ) + v + other -> fail ("ISMAliasAction: unexpected key " <> T.unpack other) + +instance ToJSON ISMAliasAction where + toJSON = \case + ISMAliasActionAdd {..} -> + object + [ AKey.fromText "add" + .= omitNulls + [ "alias" .= ismAliasActionAddAlias, + "index" .= ismAliasActionAddIndex, + "is_write_index" .= ismAliasActionAddIsWriteIndex + ] + ] + ISMAliasActionRemove {..} -> + object + [ AKey.fromText "remove" + .= object ["alias" .= ismAliasActionRemoveAlias] + ] + +-- | Config for 'ISMActionAlias'. Wraps the @actions@ array of @add@ \/ @remove@ +-- sub-actions (see 'ISMAliasAction'). +-- See +newtype ISMAliasConfig = ISMAliasConfig + { ismAliasConfigActions :: [ISMAliasAction] + } + deriving stock (Eq, Show) + +instance FromJSON ISMAliasConfig where + parseJSON = withObject "ISMAliasConfig" $ \v -> do + ismAliasConfigActions <- v .:? "actions" .!= [] + return ISMAliasConfig {..} + +instance ToJSON ISMAliasConfig where + toJSON ISMAliasConfig {..} = + object ["actions" .= ismAliasConfigActions] + +-- | One entry in the @failed_indices@ array of an 'ISMUpdatedIndicesResponse'. +-- Carries the index that rejected an ISM policy operation along with the +-- reason. @index_uuid@ is @null@ when the index does not exist. +-- See +data ISMFailedIndex = ISMFailedIndex + { ismFailedIndexName :: Text, + ismFailedIndexUuid :: Maybe Text, + ismFailedIndexReason :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMFailedIndex where + parseJSON = withObject "ISMFailedIndex" $ \v -> do + ismFailedIndexName <- v .: "index_name" + ismFailedIndexUuid <- v .:? "index_uuid" + ismFailedIndexReason <- v .: "reason" + return ISMFailedIndex {..} + +instance ToJSON ISMFailedIndex where + toJSON ISMFailedIndex {..} = + object + [ "index_name" .= ismFailedIndexName, + "index_uuid" .= ismFailedIndexUuid, + "reason" .= ismFailedIndexReason + ] + +-- | Response body shared by the ISM index-mutation endpoints +-- @POST /_plugins/_ism/add\/remove\/change_policy\/retry\/{index}@. +-- OpenSearch reports @updated_indices@, whether any @failures@ occurred, and a +-- @failed_indices@ list describing each index that rejected the operation. +-- See +data ISMUpdatedIndicesResponse = ISMUpdatedIndicesResponse + { ismUpdatedIndicesResponseUpdatedIndices :: Int, + ismUpdatedIndicesResponseFailures :: Bool, + ismUpdatedIndicesResponseFailedIndices :: [ISMFailedIndex] + } + deriving stock (Eq, Show) + +-- | Backwards-compatible alias. The @add@, @remove@, @change_policy@ and +-- @retry@ ISM endpoints all share this response shape; the type was originally +-- introduced as @AddISMPolicyResponse@ before the shared shape was recognised. +type AddISMPolicyResponse = ISMUpdatedIndicesResponse + +instance FromJSON ISMUpdatedIndicesResponse where + parseJSON = withObject "ISMUpdatedIndicesResponse" $ \v -> do + ismUpdatedIndicesResponseUpdatedIndices <- v .: "updated_indices" + ismUpdatedIndicesResponseFailures <- v .: "failures" + ismUpdatedIndicesResponseFailedIndices <- v .:? "failed_indices" .!= [] + return ISMUpdatedIndicesResponse {..} + +instance ToJSON ISMUpdatedIndicesResponse where + toJSON ISMUpdatedIndicesResponse {..} = + object + [ "updated_indices" .= ismUpdatedIndicesResponseUpdatedIndices, + "failures" .= ismUpdatedIndicesResponseFailures, + "failed_indices" .= ismUpdatedIndicesResponseFailedIndices + ] + +-- | Optional filter inside a 'ChangePolicyRequest'. Restricts the policy change +-- to managed indices currently in the given @state@. +-- See +data ISMChangePolicyInclude = ISMChangePolicyInclude + { ismChangePolicyIncludeState :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMChangePolicyInclude where + parseJSON = withObject "ISMChangePolicyInclude" $ \v -> do + ismChangePolicyIncludeState <- v .: "state" + return ISMChangePolicyInclude {..} + +instance ToJSON ISMChangePolicyInclude where + toJSON ISMChangePolicyInclude {..} = + object ["state" .= ismChangePolicyIncludeState] + +-- | Request body for @POST /_plugins/_ism/change_policy\/{index}@. +-- @policy_id@ selects the new policy; @state@ optionally names the state the +-- managed index transitions to after the change takes effect; @include@ +-- optionally filters which currently-managed indices the change applies to. +-- See +data ChangePolicyRequest = ChangePolicyRequest + { changePolicyRequestId :: PolicyId, + changePolicyRequestState :: Maybe Text, + changePolicyRequestInclude :: [ISMChangePolicyInclude] + } + deriving stock (Eq, Show) + +instance FromJSON ChangePolicyRequest where + parseJSON = withObject "ChangePolicyRequest" $ \v -> do + changePolicyRequestId <- v .: "policy_id" + changePolicyRequestState <- v .:? "state" + changePolicyRequestInclude <- v .:? "include" .!= [] + return ChangePolicyRequest {..} + +instance ToJSON ChangePolicyRequest where + toJSON ChangePolicyRequest {..} = + omitNulls + [ "policy_id" .= unPolicyId changePolicyRequestId, + "state" .= changePolicyRequestState, + "include" .= changePolicyRequestInclude + ] + +-- $explainSubshapes +-- +-- The @GET /_plugins/_ism/explain/{index}@ response is a JSON object keyed by +-- index name. Each value mixes (a) arbitrary index settings whose keys contain +-- dots (e.g. @index.plugins.index_state_management.policy_id@) with (b) a +-- fixed set of managed-index fields (@index@, @state@, @action@, ...). To stay +-- lossless for the unmanaged case, the dotted @policy_id@ settings are +-- captured explicitly; every managed-index field is 'Maybe' so the minimal +-- unmanaged body @{"index.plugins...policy_id": "p"}@ decodes cleanly. +-- +-- The full @policy@ sub-object is carried as an opaque 'Value' until the typed +-- ISM policy schema lands (tracked separately). +-- +-- See + +-- | A named ISM runtime entity (a @state@ or an @action@) with the epoch-ms +-- instant at which it became active. +data ISMExplanationNamed = ISMExplanationNamed + { ismExplanationNamedName :: Text, + ismExplanationNamedStartTime :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationNamed where + parseJSON = withObject "ISMExplanationNamed" $ \v -> do + ismExplanationNamedName <- v .: "name" + ismExplanationNamedStartTime <- v .:? "start_time" + return ISMExplanationNamed {..} + +instance ToJSON ISMExplanationNamed where + toJSON ISMExplanationNamed {..} = + omitNulls + [ "name" .= ismExplanationNamedName, + "start_time" .= ismExplanationNamedStartTime + ] + +-- | The @action@ object in an explain entry. +data ISMExplanationAction = ISMExplanationAction + { ismExplanationActionName :: Text, + ismExplanationActionStartTime :: Maybe Int, + ismExplanationActionIndex :: Maybe Int, + ismExplanationActionFailed :: Maybe Bool, + ismExplanationActionConsumedRetries :: Maybe Int, + ismExplanationActionLastRetryTime :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationAction where + parseJSON = withObject "ISMExplanationAction" $ \v -> do + ismExplanationActionName <- v .: "name" + ismExplanationActionStartTime <- v .:? "start_time" + ismExplanationActionIndex <- v .:? "index" + ismExplanationActionFailed <- v .:? "failed" + ismExplanationActionConsumedRetries <- v .:? "consumed_retries" + ismExplanationActionLastRetryTime <- v .:? "last_retry_time" + return ISMExplanationAction {..} + +instance ToJSON ISMExplanationAction where + toJSON ISMExplanationAction {..} = + omitNulls + [ "name" .= ismExplanationActionName, + "start_time" .= ismExplanationActionStartTime, + "index" .= ismExplanationActionIndex, + "failed" .= ismExplanationActionFailed, + "consumed_retries" .= ismExplanationActionConsumedRetries, + "last_retry_time" .= ismExplanationActionLastRetryTime + ] + +-- | The @step@ object in an explain entry. +data ISMExplanationStep = ISMExplanationStep + { ismExplanationStepName :: Text, + ismExplanationStepStartTime :: Maybe Int, + ismExplanationStepStepStatus :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationStep where + parseJSON = withObject "ISMExplanationStep" $ \v -> do + ismExplanationStepName <- v .: "name" + ismExplanationStepStartTime <- v .:? "start_time" + ismExplanationStepStepStatus <- v .:? "step_status" + return ISMExplanationStep {..} + +instance ToJSON ISMExplanationStep where + toJSON ISMExplanationStep {..} = + omitNulls + [ "name" .= ismExplanationStepName, + "start_time" .= ismExplanationStepStartTime, + "step_status" .= ismExplanationStepStepStatus + ] + +-- | The @retry_info@ object in an explain entry. +data ISMExplanationRetryInfo = ISMExplanationRetryInfo + { ismExplanationRetryInfoFailed :: Bool, + ismExplanationRetryInfoConsumedRetries :: Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationRetryInfo where + parseJSON = withObject "ISMExplanationRetryInfo" $ \v -> do + ismExplanationRetryInfoFailed <- v .: "failed" + ismExplanationRetryInfoConsumedRetries <- v .: "consumed_retries" + return ISMExplanationRetryInfo {..} + +instance ToJSON ISMExplanationRetryInfo where + toJSON ISMExplanationRetryInfo {..} = + object + [ "failed" .= ismExplanationRetryInfoFailed, + "consumed_retries" .= ismExplanationRetryInfoConsumedRetries + ] + +-- | The @info@ object in an explain entry. +data ISMExplanationInfo = ISMExplanationInfo + { ismExplanationInfoMessage :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationInfo where + parseJSON = withObject "ISMExplanationInfo" $ \v -> do + ismExplanationInfoMessage <- v .: "message" + return ISMExplanationInfo {..} + +instance ToJSON ISMExplanationInfo where + toJSON ISMExplanationInfo {..} = + object ["message" .= ismExplanationInfoMessage] + +-- | The @validate@ object returned when explain is called with +-- @validate_action=true@. +data ISMExplanationValidate = ISMExplanationValidate + { ismExplanationValidateValidationMessage :: Text, + ismExplanationValidateValidationStatus :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationValidate where + parseJSON = withObject "ISMExplanationValidate" $ \v -> do + ismExplanationValidateValidationMessage <- v .: "validation_message" + ismExplanationValidateValidationStatus <- v .: "validation_status" + return ISMExplanationValidate {..} + +instance ToJSON ISMExplanationValidate where + toJSON ISMExplanationValidate {..} = + object + [ "validation_message" .= ismExplanationValidateValidationMessage, + "validation_status" .= ismExplanationValidateValidationStatus + ] + +-- | Per-index value in an 'ISMExplanation'. Every field is 'Maybe' because the +-- explain response ranges from a bare settings-only object (unmanaged index) +-- to the full managed-index status. The dotted @policy_id@ settings are +-- captured explicitly so the unmanaged case is not lossy. +data ISMExplanationEntry = ISMExplanationEntry + { ismExplanationEntryIndex :: Maybe Text, + ismExplanationEntryIndexUuid :: Maybe Text, + ismExplanationEntryPolicyId :: Maybe Text, + ismExplanationEntryEnabled :: Maybe Bool, + ismExplanationEntryEnabledTime :: Maybe Int, + ismExplanationEntryPolicySeqNo :: Maybe Int, + ismExplanationEntryPolicyPrimaryTerm :: Maybe Int, + ismExplanationEntryRolledOver :: Maybe Bool, + ismExplanationEntryIndexCreationDate :: Maybe Int, + ismExplanationEntryState :: Maybe ISMExplanationNamed, + ismExplanationEntryAction :: Maybe ISMExplanationAction, + ismExplanationEntryStep :: Maybe ISMExplanationStep, + ismExplanationEntryRetryInfo :: Maybe ISMExplanationRetryInfo, + ismExplanationEntryInfo :: Maybe ISMExplanationInfo, + ismExplanationEntryPolicy :: Maybe Value, + ismExplanationEntryValidate :: Maybe ISMExplanationValidate, + ismExplanationEntryPolicyIdSetting :: Maybe Text, + ismExplanationEntryOpendistroPolicyIdSetting :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanationEntry where + parseJSON = withObject "ISMExplanationEntry" $ \v -> do + ismExplanationEntryIndex <- v .:? "index" + ismExplanationEntryIndexUuid <- v .:? "index_uuid" + ismExplanationEntryPolicyId <- v .:? "policy_id" + ismExplanationEntryEnabled <- v .:? "enabled" + ismExplanationEntryEnabledTime <- v .:? "enabled_time" + ismExplanationEntryPolicySeqNo <- v .:? "policy_seq_no" + ismExplanationEntryPolicyPrimaryTerm <- v .:? "policy_primary_term" + ismExplanationEntryRolledOver <- v .:? "rolled_over" + ismExplanationEntryIndexCreationDate <- v .:? "index_creation_date" + ismExplanationEntryState <- v .:? "state" + ismExplanationEntryAction <- v .:? "action" + ismExplanationEntryStep <- v .:? "step" + ismExplanationEntryRetryInfo <- v .:? "retry_info" + ismExplanationEntryInfo <- v .:? "info" + ismExplanationEntryPolicy <- v .:? "policy" + ismExplanationEntryValidate <- v .:? "validate" + ismExplanationEntryPolicyIdSetting <- + v .:? "index.plugins.index_state_management.policy_id" + ismExplanationEntryOpendistroPolicyIdSetting <- + v .:? "index.opendistro.index_state_management.policy_id" + return ISMExplanationEntry {..} + +instance ToJSON ISMExplanationEntry where + toJSON ISMExplanationEntry {..} = + omitNulls + [ "index" .= ismExplanationEntryIndex, + "index_uuid" .= ismExplanationEntryIndexUuid, + "policy_id" .= ismExplanationEntryPolicyId, + "enabled" .= ismExplanationEntryEnabled, + "enabled_time" .= ismExplanationEntryEnabledTime, + "policy_seq_no" .= ismExplanationEntryPolicySeqNo, + "policy_primary_term" .= ismExplanationEntryPolicyPrimaryTerm, + "rolled_over" .= ismExplanationEntryRolledOver, + "index_creation_date" .= ismExplanationEntryIndexCreationDate, + "state" .= ismExplanationEntryState, + "action" .= ismExplanationEntryAction, + "step" .= ismExplanationEntryStep, + "retry_info" .= ismExplanationEntryRetryInfo, + "info" .= ismExplanationEntryInfo, + "policy" .= ismExplanationEntryPolicy, + "validate" .= ismExplanationEntryValidate, + "index.plugins.index_state_management.policy_id" .= ismExplanationEntryPolicyIdSetting, + "index.opendistro.index_state_management.policy_id" .= ismExplanationEntryOpendistroPolicyIdSetting + ] + +-- | Response of @GET /_plugins/_ism/explain/{index}@: a map keyed by index +-- name plus an optional @total_managed_indices@ count (present when at least +-- one queried index is managed). Unknown per-index keys are ignored; the +-- dotted @policy_id@ settings are captured by 'ISMExplanationEntry'. +-- See +data ISMExplanation = ISMExplanation + { ismExplanationEntries :: Map.Map Text ISMExplanationEntry, + ismExplanationTotalManagedIndices :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ISMExplanation where + parseJSON = withObject "ISMExplanation" $ \v -> do + ismExplanationTotalManagedIndices <- v .:? "total_managed_indices" + let entryPairs = + [ (AKey.toText k, val) + | (k, val) <- KM.toList v, + k /= "total_managed_indices" + ] + ismExplanationEntries <- + Map.fromList + <$> traverse + (\(k, val) -> fmap ((,) k) (parseJSON val)) + entryPairs + return ISMExplanation {..} + +instance ToJSON ISMExplanation where + toJSON ISMExplanation {..} = + Object $ + KM.fromList $ + [ (AKey.fromText k, toJSON e) + | (k, e) <- Map.toList ismExplanationEntries + ] + <> [ (AKey.fromText "total_managed_indices", toJSON n) + | Just n <- [ismExplanationTotalManagedIndices] + ] + +-- | Filter criteria for 'explainISMIndexFiltered' +-- (@POST /_plugins/_ism/explain/{index}@, "Explain index with filtering", +-- introduced in OpenSearch 2.12). Every field is optional; 'Nothing' means +-- "any value". The server returns only indexes matching /all/ specified +-- criteria. The wire body wraps this in a @filter@ key — see +-- 'ISMExplainFilterRequest'. +-- See +data ISMExplainFilter = ISMExplainFilter + { ismExplainFilterPolicyId :: Maybe Text, + ismExplainFilterState :: Maybe Text, + ismExplainFilterActionType :: Maybe Text, + ismExplainFilterFailed :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'ISMExplainFilter' with every criterion set to 'Nothing' (no filtering). +-- Encodes to @{}@, so the resulting request body is @{"filter":{}}@. +defaultISMExplainFilter :: ISMExplainFilter +defaultISMExplainFilter = + ISMExplainFilter + { ismExplainFilterPolicyId = Nothing, + ismExplainFilterState = Nothing, + ismExplainFilterActionType = Nothing, + ismExplainFilterFailed = Nothing + } + +instance ToJSON ISMExplainFilter where + toJSON ISMExplainFilter {..} = + omitNulls + [ "policy_id" .= ismExplainFilterPolicyId, + "state" .= ismExplainFilterState, + "action_type" .= ismExplainFilterActionType, + "failed" .= ismExplainFilterFailed + ] + +-- | Request body for 'explainISMIndexFiltered'. Wraps an 'ISMExplainFilter' +-- in the @filter@ key so the encoded body matches the documented +-- @{"filter": {...}}@ shape. +data ISMExplainFilterRequest = ISMExplainFilterRequest + { ismExplainFilterRequestFilter :: ISMExplainFilter + } + deriving stock (Eq, Show) + +instance ToJSON ISMExplainFilterRequest where + toJSON ISMExplainFilterRequest {..} = + object ["filter" .= ismExplainFilterRequestFilter] + +-- | A single policy entry as returned by @GET /_plugins/_ism/policies[\/{id}]@. +-- The @policy@ sub-object is the full managed-policy wrapper (with +-- @policy_id@, @schema_version@, @states@, ...) and is carried as an opaque +-- 'Value' until the typed ISM policy schema lands (tracked separately). +-- See +data ISMPolicyInfo = ISMPolicyInfo + { ismPolicyInfoId :: Text, + ismPolicyInfoVersion :: Maybe DocVersion, + ismPolicyInfoSeqNo :: Int, + ismPolicyInfoPrimaryTerm :: Int, + ismPolicyInfoPolicy :: Value + } + deriving stock (Eq, Show) + +instance FromJSON ISMPolicyInfo where + parseJSON = withObject "ISMPolicyInfo" $ \v -> do + ismPolicyInfoId <- v .: "_id" + ismPolicyInfoVersion <- v .:? "_version" + ismPolicyInfoSeqNo <- v .: "_seq_no" + ismPolicyInfoPrimaryTerm <- v .: "_primary_term" + ismPolicyInfoPolicy <- v .: "policy" + return ISMPolicyInfo {..} + +instance ToJSON ISMPolicyInfo where + toJSON ISMPolicyInfo {..} = + omitNulls + [ "_id" .= ismPolicyInfoId, + "_version" .= ismPolicyInfoVersion, + "_seq_no" .= ismPolicyInfoSeqNo, + "_primary_term" .= ismPolicyInfoPrimaryTerm, + "policy" .= ismPolicyInfoPolicy + ] + +-- | Response of @GET /_plugins/_ism/policies@ (the list variant). +-- See +data GetISMPoliciesResponse = GetISMPoliciesResponse + { getISMPoliciesResponsePolicies :: [ISMPolicyInfo] + } + deriving stock (Eq, Show) + +instance FromJSON GetISMPoliciesResponse where + parseJSON = withObject "GetISMPoliciesResponse" $ \v -> do + getISMPoliciesResponsePolicies <- v .: "policies" + return GetISMPoliciesResponse {..} + +instance ToJSON GetISMPoliciesResponse where + toJSON GetISMPoliciesResponse {..} = + object ["policies" .= getISMPoliciesResponsePolicies] + +-- | Optional filtering / pagination parameters for 'getISMPolicies'. +-- All fields are optional; see the @Get policies@ query parameters table. +data ISMPoliciesQuery = ISMPoliciesQuery + { ismPoliciesQuerySize :: Maybe Int, + ismPoliciesQueryFrom :: Maybe Int, + ismPoliciesQuerySortField :: Maybe Text, + ismPoliciesQuerySortOrder :: Maybe Text, + ismPoliciesQueryQueryString :: Maybe Text + } + deriving stock (Eq, Show) + +-- | Render an 'ISMPoliciesQuery' as the query-string pairs accepted by the +-- @GET /_plugins/_ism/policies@ endpoint. 'Nothing' fields are omitted so the +-- request only carries the parameters the caller set. +ismPoliciesQueryToPairs :: ISMPoliciesQuery -> [(Text, Maybe Text)] +ismPoliciesQueryToPairs ISMPoliciesQuery {..} = + catMaybes + [ fmap (\n -> ("size", Just (showText n))) ismPoliciesQuerySize, + fmap (\n -> ("from", Just (showText n))) ismPoliciesQueryFrom, + fmap (\t -> ("sortField", Just t)) ismPoliciesQuerySortField, + fmap (\t -> ("sortOrder", Just t)) ismPoliciesQuerySortOrder, + fmap (\t -> ("queryString", Just t)) ismPoliciesQueryQueryString + ] + +-- | Optional parameters for 'explainISMIndexWith' +-- (@GET /_plugins/_ism/explain/{index}@). All four documented query +-- parameters are modelled: +-- +-- * @show_policy@ — returns the full managed-index policy in the response. +-- * @validate_action@ — validates the cached actions in the managed index +-- metadata. +-- * @local@ — /OpenSearch only/. Whether to return local information such +-- as the managed index metadata. Default is @false@. +-- * @expand_wildcards@ — controls wildcard index expansion (@open@, +-- @closed@, @hidden@, @all@, @none@). Reuses the 'ExpandWildcards' sum +-- type shared with the search and count endpoints; the server accepts a +-- comma-separated list so we model it as a 'NonEmpty' to encode "at +-- least one". +-- +-- See +data ISMExplainOptions = ISMExplainOptions + { ismExplainOptionsShowPolicy :: Bool, + ismExplainOptionsValidateAction :: Bool, + ismExplainOptionsLocal :: Maybe Bool, + ismExplainOptionsExpandWildcards :: Maybe (NonEmpty ExpandWildcards) + } + deriving stock (Eq, Show) + +-- | 'ISMExplainOptions' with every parameter set to its no-op value +-- (@show_policy = False@, @validate_action = False@, @local = Nothing@, +-- @expand_wildcards = Nothing@). Produces no query string, so a call made +-- with this value is byte-identical to the legacy @explainISMIndex@ wire +-- shape. +defaultISMExplainOptions :: ISMExplainOptions +defaultISMExplainOptions = + ISMExplainOptions + { ismExplainOptionsShowPolicy = False, + ismExplainOptionsValidateAction = False, + ismExplainOptionsLocal = Nothing, + ismExplainOptionsExpandWildcards = Nothing + } + +-- | Render an 'ISMExplainOptions' as the query-string pairs accepted by the +-- @GET /_plugins/_ism/explain/{index}@ endpoint. 'False' bool flags and +-- 'Nothing' fields are omitted, so 'defaultISMExplainOptions' produces an +-- empty list. The order of the returned list is stable but /unspecified/ — +-- callers (including tests) should treat it as a set and not pattern-match +-- on the head. The underlying 'withQueries' is order-insensitive. +ismExplainOptionsParams :: ISMExplainOptions -> [(Text, Maybe Text)] +ismExplainOptionsParams ISMExplainOptions {..} = + catMaybes + [ if ismExplainOptionsShowPolicy + then Just ("show_policy", Just "true") + else Nothing, + if ismExplainOptionsValidateAction + then Just ("validate_action", Just "true") + else Nothing, + fmap (\b -> ("local", Just (if b then "true" else "false"))) ismExplainOptionsLocal, + fmap (\xs -> ("expand_wildcards", Just (renderExpandWildcards xs))) ismExplainOptionsExpandWildcards + ] + where + renderExpandWildcards = T.intercalate "," . map expandWildcardsText . toList + +-- ========================================================================= +-- Simulate policy (OS 3.7+) +-- ========================================================================= + +-- | Request body for @POST /_plugins/_ism/simulate@ (OS 3.7+). Exactly +-- one of 'simulateISMPolicyRequestPolicyId' or +-- 'simulateISMPolicyRequestPolicy' must be provided; the server rejects +-- the request with a 400 if both or neither are supplied. The +-- 'simulateISMPolicyRequestIndices' list names the indexes (or wildcard +-- patterns) to simulate the policy against; patterns that match no +-- indexes are silently ignored, and concrete index names that do not +-- exist return an inline per-index @error@ in the response (NOT an HTTP +-- 404). +data SimulateISMPolicyRequest = SimulateISMPolicyRequest + { simulateISMPolicyRequestPolicyId :: Maybe Text, + simulateISMPolicyRequestPolicy :: Maybe ISMPolicyBody, + simulateISMPolicyRequestIndices :: [Text] + } + deriving stock (Eq, Show) + +instance ToJSON SimulateISMPolicyRequest where + toJSON r = + omitNulls + [ "policy_id" .= simulateISMPolicyRequestPolicyId r, + "policy" .= simulateISMPolicyRequestPolicy r, + "indices" .= simulateISMPolicyRequestIndices r + ] + +instance FromJSON SimulateISMPolicyRequest where + parseJSON = withObject "SimulateISMPolicyRequest" $ \o -> + SimulateISMPolicyRequest + <$> o .:? "policy_id" + <*> o .:? "policy" + <*> o .:? "indices" .!= [] + +-- | A single transition-condition evaluation inside a +-- 'SimulateISMPolicyResult'. When the index is in the transition phase, +-- the server evaluates each outgoing transition's conditions and reports +-- whether the condition was met. The @condition_type@ is @"unconditional"@ +-- for transitions with no conditions; in that case @current_value@ and +-- @required_value@ are omitted. +data SimulateISMTransitionEvaluation = SimulateISMTransitionEvaluation + { simulateISMTransitionEvaluationStateName :: Maybe Text, + simulateISMTransitionEvaluationConditionMet :: Maybe Bool, + simulateISMTransitionEvaluationConditionType :: Maybe Text, + simulateISMTransitionEvaluationCurrentValue :: Maybe Text, + simulateISMTransitionEvaluationRequiredValue :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SimulateISMTransitionEvaluation where + parseJSON = withObject "SimulateISMTransitionEvaluation" $ \o -> + SimulateISMTransitionEvaluation + <$> o .:? "state_name" + <*> o .:? "condition_met" + <*> o .:? "condition_type" + <*> o .:? "current_value" + <*> o .:? "required_value" + +instance ToJSON SimulateISMTransitionEvaluation where + toJSON e = + omitNulls + [ "state_name" .= simulateISMTransitionEvaluationStateName e, + "condition_met" .= simulateISMTransitionEvaluationConditionMet e, + "condition_type" .= simulateISMTransitionEvaluationConditionType e, + "current_value" .= simulateISMTransitionEvaluationCurrentValue e, + "required_value" .= simulateISMTransitionEvaluationRequiredValue e + ] + +-- | A single per-index result in the simulate-policy response. The +-- @error@ field is present only when the index does not exist or another +-- index-level error occurs; when present, @current_state@, +-- @current_action@, @transition_evaluation@, and @next_state@ are +-- omitted. The @index_uuid@ is @null@ when the index was not found. +data SimulateISMPolicyResult = SimulateISMPolicyResult + { simulateISMPolicyResultIndexName :: Maybe Text, + simulateISMPolicyResultIndexUuid :: Maybe Text, + simulateISMPolicyResultPolicyId :: Maybe Text, + simulateISMPolicyResultIsManaged :: Maybe Bool, + simulateISMPolicyResultCurrentState :: Maybe Text, + simulateISMPolicyResultCurrentAction :: Maybe Text, + simulateISMPolicyResultTransitionEvaluation :: Maybe [SimulateISMTransitionEvaluation], + simulateISMPolicyResultNextState :: Maybe Text, + simulateISMPolicyResultError :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SimulateISMPolicyResult where + parseJSON = withObject "SimulateISMPolicyResult" $ \o -> + SimulateISMPolicyResult + <$> o .:? "index_name" + <*> o .:? "index_uuid" + <*> o .:? "policy_id" + <*> o .:? "is_managed" + <*> o .:? "current_state" + <*> o .:? "current_action" + <*> o .:? "transition_evaluation" + <*> o .:? "next_state" + <*> o .:? "error" + +instance ToJSON SimulateISMPolicyResult where + toJSON r = + omitNulls + [ "index_name" .= simulateISMPolicyResultIndexName r, + "index_uuid" .= simulateISMPolicyResultIndexUuid r, + "policy_id" .= simulateISMPolicyResultPolicyId r, + "is_managed" .= simulateISMPolicyResultIsManaged r, + "current_state" .= simulateISMPolicyResultCurrentState r, + "current_action" .= simulateISMPolicyResultCurrentAction r, + "transition_evaluation" .= simulateISMPolicyResultTransitionEvaluation r, + "next_state" .= simulateISMPolicyResultNextState r, + "error" .= simulateISMPolicyResultError r + ] + +-- | Response body for @POST /_plugins/_ism/simulate@ +-- (@{simulate_results: [...]}@). +newtype SimulateISMPolicyResponse = SimulateISMPolicyResponse + { simulateISMPolicyResponseSimulateResults :: [SimulateISMPolicyResult] + } + deriving stock (Eq, Show) + +instance FromJSON SimulateISMPolicyResponse where + parseJSON = withObject "SimulateISMPolicyResponse" $ \o -> + SimulateISMPolicyResponse <$> o .:? "simulate_results" .!= [] + +instance ToJSON SimulateISMPolicyResponse where + toJSON r = object ["simulate_results" .= simulateISMPolicyResponseSimulateResults r] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/IndexTransforms.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/IndexTransforms.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/IndexTransforms.hs @@ -0,0 +1,837 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.IndexTransforms + ( TransformId (..), + TransformPeriodUnit (..), + transformPeriodUnitText, + TransformInterval (..), + TransformSchedule (..), + TransformGroup (..), + TermsGroup (..), + HistogramGroup (..), + DateHistogramGroup (..), + Transform (..), + TransformResponse (..), + TransformRequest (..), + TransformDocumentResponse (..), + TransformSortDirection (..), + transformSortDirectionText, + TransformsListOptions (..), + defaultTransformsListOptions, + transformsListOptionsParams, + GetTransformsResponse (..), + GetTransformsListEntry (..), + TransformExplain (..), + TransformMetadata (..), + TransformStats (..), + TransformContinuousStats (..), + PreviewTransformResponse (..), + ) +where + +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict (Map) +import Data.Vector qualified as V +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The OpenSearch Index Transforms plugin +-- () +-- materialises a target index from aggregations over a source index on a +-- schedule. A 'Transform' binds a 'transformSourceIndex' to a +-- 'transformTargetIndex' via either 'transformGroups' (terms \/ histogram +-- \/ date_histogram buckets) or 'transformAggregations' (sum \/ avg \/ +-- \/ max \/ min \/ value_count \/ scripted_metric \/ percentiles), +-- evaluated under 'transformDataSelectionQuery' (a query DSL filter on +-- the source). The plugin persists the transform under the +-- @.opensearch-ism-config@ system index (transforms are stored alongside +-- ISM policies) and returns the document-write envelope +-- (@_id@, @_version@, @_seq_no@, @_primary_term@) wrapping the +-- 'TransformResponse' under the @transform@ key. +-- +-- We split the request shape ('Transform') from the response shape +-- ('TransformResponse') so the request cannot accidentally carry +-- server-only fields, while the response still round-trips the full +-- server payload. This mirrors the 'ISMPolicyRequest' / +-- 'ISMPolicyResponse' split used for the ISM plugin and the +-- 'Detector' / 'DetectorResponse' split used by Anomaly Detection. +-- +-- The plugin is shipped with OpenSearch 1.0+; it is present (and +-- wire-compatible) on OS1, OS2 and OS3, hence this module is duplicated +-- across all three versions. +-- +-- Doc ambiguities handled here deliberately: +-- +-- * The @schedule.interval.unit@ field is documented with only +-- @"Minutes"@, @"Hours"@, and @"Days"@ in the examples. The plugin +-- source (the underlying job-scheduler) accepts more (e.g. @Seconds@, +-- @Weeks@, @Months@); we type 'TransformPeriodUnit' as a closed enum +-- with a 'TransformPeriodUnitCustom' escape hatch so future additions +-- surface as a parsed value rather than a decode failure. +-- * Only the @interval@ schedule variant is documented on the Transforms +-- page; the job-scheduler plugin also supports @cron@ and other +-- variants. 'TransformSchedule' is a sum type with a +-- 'TransformScheduleOther' escape hatch so unknown schedule variants +-- round-trip losslessly instead of failing decode. +-- * The @groups@ array entries are wrapped under a per-type key +-- (@terms@ \/ @histogram@ \/ @date_histogram@); we model this as a +-- 'TransformGroup' sum type so an entry cannot be constructed with an +-- inconsistent (wrapper, body) pair. The wrapped objects are +-- intentionally light (the documented fields plus an opaque 'Value' +-- catch-all) — future bucket options surface as the catch-all rather +-- than a parse failure. +-- * The @data_selection_query@ and @aggregations@ fields are arbitrary +-- OpenSearch query \/ aggregation DSL bodies, so both are carried as +-- opaque 'Value's (the same approach Anomaly Detection's +-- 'featureAttributeAggregationQuery' takes). +-- * The @_explain@ response is keyed by transform_id at the top level; +-- we decode it as @'Map' 'Text' 'TransformExplain'@. The whole +-- @transform_metadata@ sub-object is 'Maybe' because the plugin omits +-- it on a freshly-created transform that has not yet run. The +-- @continuous_stats@ sub-object only appears on continuous transforms, +-- so it is itself 'Maybe' inside 'TransformMetadata'. +-- * The @delete@ endpoint returns a bulk-response envelope (the +-- transform is stored as a doc in @.opensearch-ism-config@, so DELETE +-- surfaces through the bulk handler). The shared +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Bulk.BulkResponse' +-- matches that envelope byte-for-byte, so the request builder reuses +-- it rather than introducing a per-plugin wrapper. + +-- | Identifies a transform job in the +-- @\/_plugins\/_transform\/{transform_id}@ URL path. Wraps 'Text' so it +-- round-trips through JSON as a bare string but is distinct at the +-- Haskell type level. +-- See +newtype TransformId = TransformId {unTransformId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @schedule.interval.unit@ enum documented at +-- . +-- The Transforms docs enumerate @"Minutes"@, @"Hours"@, and @"Days"@ in +-- the examples; the underlying job-scheduler plugin accepts more values +-- (a 'TransformPeriodUnitCustom' escape hatch preserves them). +data TransformPeriodUnit + = TransformPeriodUnitMinutes + | TransformPeriodUnitHours + | TransformPeriodUnitDays + | TransformPeriodUnitSeconds + | TransformPeriodUnitWeeks + | TransformPeriodUnitMonths + | TransformPeriodUnitCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'TransformPeriodUnit' — the same mapping the +-- 'ToJSON' \/ 'FromJSON' instances use, exposed as plain 'Text' for +-- callers that need the wire string without going through a +-- 'Data.Aeson.Value'. +transformPeriodUnitText :: TransformPeriodUnit -> Text +transformPeriodUnitText = \case + TransformPeriodUnitMinutes -> "Minutes" + TransformPeriodUnitHours -> "Hours" + TransformPeriodUnitDays -> "Days" + TransformPeriodUnitSeconds -> "Seconds" + TransformPeriodUnitWeeks -> "Weeks" + TransformPeriodUnitMonths -> "Months" + TransformPeriodUnitCustom t -> t + +instance ToJSON TransformPeriodUnit where + toJSON = toJSON . transformPeriodUnitText + +instance FromJSON TransformPeriodUnit where + parseJSON = withText "TransformPeriodUnit" $ \case + "Minutes" -> pure TransformPeriodUnitMinutes + "Hours" -> pure TransformPeriodUnitHours + "Days" -> pure TransformPeriodUnitDays + "Seconds" -> pure TransformPeriodUnitSeconds + "Weeks" -> pure TransformPeriodUnitWeeks + "Months" -> pure TransformPeriodUnitMonths + other -> pure (TransformPeriodUnitCustom other) + +-- | The inner @{period, unit, start_time}@ object carried inside a +-- 'TransformSchedule'. @start_time@ is documented as a Unix epoch +-- (seconds); the docs page puts it under @interval.start_time@, which +-- is the only placement the encoder emits. +-- See +data TransformInterval = TransformInterval + { transformIntervalPeriod :: Int, + transformIntervalUnit :: TransformPeriodUnit, + transformIntervalStartTime :: Maybe Integer + } + deriving stock (Eq, Show) + +instance FromJSON TransformInterval where + parseJSON = withObject "TransformInterval" $ \v -> do + transformIntervalPeriod <- v .: "period" + transformIntervalUnit <- v .: "unit" + transformIntervalStartTime <- v .:? "start_time" + pure TransformInterval {..} + +instance ToJSON TransformInterval where + toJSON TransformInterval {..} = + omitNulls + [ "period" .= transformIntervalPeriod, + "unit" .= transformIntervalUnit, + "start_time" .= transformIntervalStartTime + ] + +-- | The @schedule@ object. The Transforms docs only document the +-- @interval@ variant; the underlying job-scheduler plugin also supports +-- @cron@ and others, so unknown schedule shapes parse as +-- 'TransformScheduleOther' and round-trip losslessly. +-- See +data TransformSchedule + = TransformScheduleInterval TransformInterval + | TransformScheduleOther Value + deriving stock (Eq, Show) + +instance FromJSON TransformSchedule where + parseJSON = withObject "TransformSchedule" $ \v -> + case KM.lookup "interval" v of + Just _ -> TransformScheduleInterval <$> v .: "interval" + Nothing -> pure (TransformScheduleOther (Object v)) + +instance ToJSON TransformSchedule where + toJSON = \case + TransformScheduleInterval i -> object ["interval" .= i] + TransformScheduleOther val -> val + +-- | A @terms@ group entry of the @groups@ array. +-- See +data TermsGroup = TermsGroup + { termsGroupSourceField :: Text, + termsGroupTargetField :: Maybe Text, + termsGroupOther :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON TermsGroup where + parseJSON = withObject "TermsGroup" $ \v -> do + termsGroupSourceField <- v .: "source_field" + termsGroupTargetField <- v .:? "target_field" + let deleted = deleteSeveral ["source_field", "target_field"] v + termsGroupOther = + if null deleted + then Nothing + else Just (Object deleted) + pure TermsGroup {..} + +instance ToJSON TermsGroup where + toJSON TermsGroup {..} = + mergeOther + termsGroupOther + [ "source_field" .= termsGroupSourceField, + "target_field" .= termsGroupTargetField + ] + +-- | A @histogram@ group entry of the @groups@ array. +-- See +data HistogramGroup = HistogramGroup + { histogramGroupSourceField :: Text, + histogramGroupTargetField :: Maybe Text, + histogramGroupInterval :: Maybe Scientific, + histogramGroupOther :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON HistogramGroup where + parseJSON = withObject "HistogramGroup" $ \v -> do + histogramGroupSourceField <- v .: "source_field" + histogramGroupTargetField <- v .:? "target_field" + histogramGroupInterval <- v .:? "interval" + let deleted = deleteSeveral ["source_field", "target_field", "interval"] v + histogramGroupOther = + if null deleted + then Nothing + else Just (Object deleted) + pure HistogramGroup {..} + +instance ToJSON HistogramGroup where + toJSON HistogramGroup {..} = + mergeOther + histogramGroupOther + [ "source_field" .= histogramGroupSourceField, + "target_field" .= histogramGroupTargetField, + "interval" .= histogramGroupInterval + ] + +-- | A @date_histogram@ group entry of the @groups@ array. +-- See +data DateHistogramGroup = DateHistogramGroup + { dateHistogramGroupSourceField :: Text, + dateHistogramGroupTargetField :: Maybe Text, + dateHistogramGroupInterval :: Maybe Text, + dateHistogramGroupFormat :: Maybe Text, + dateHistogramGroupTimeZone :: Maybe Text, + dateHistogramGroupOther :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON DateHistogramGroup where + parseJSON = withObject "DateHistogramGroup" $ \v -> do + dateHistogramGroupSourceField <- v .: "source_field" + dateHistogramGroupTargetField <- v .:? "target_field" + dateHistogramGroupInterval <- v .:? "interval" + dateHistogramGroupFormat <- v .:? "format" + dateHistogramGroupTimeZone <- v .:? "time_zone" + let deleted = + deleteSeveral + ["source_field", "target_field", "interval", "format", "time_zone"] + v + dateHistogramGroupOther = + if null deleted + then Nothing + else Just (Object deleted) + pure DateHistogramGroup {..} + +instance ToJSON DateHistogramGroup where + toJSON DateHistogramGroup {..} = + mergeOther + dateHistogramGroupOther + [ "source_field" .= dateHistogramGroupSourceField, + "target_field" .= dateHistogramGroupTargetField, + "interval" .= dateHistogramGroupInterval, + "format" .= dateHistogramGroupFormat, + "time_zone" .= dateHistogramGroupTimeZone + ] + +-- | One entry of the @groups@ array. The docs enumerate three wrapped +-- shapes — @{"terms": {...}}@, @{"histogram": {...}}@, +-- @{"date_histogram": {...}}@ — so the Haskell surface models this as +-- a sum type whose constructor determines the wrapper key. An unknown +-- future variant parses as 'TransformGroupOther' and round-trips +-- losslessly. +-- See +data TransformGroup + = TransformGroupTerms TermsGroup + | TransformGroupHistogram HistogramGroup + | TransformGroupDateHistogram DateHistogramGroup + | TransformGroupOther Value + deriving stock (Eq, Show) + +instance FromJSON TransformGroup where + parseJSON = withObject "TransformGroup" $ \v -> + case (KM.lookup "terms" v, KM.lookup "histogram" v, KM.lookup "date_histogram" v) of + (Just termsVal, Nothing, Nothing) -> + TransformGroupTerms <$> parseJSON termsVal + (Nothing, Just histogramVal, Nothing) -> + TransformGroupHistogram <$> parseJSON histogramVal + (Nothing, Nothing, Just dhVal) -> + TransformGroupDateHistogram <$> parseJSON dhVal + _ -> pure (TransformGroupOther (Object v)) + +instance ToJSON TransformGroup where + toJSON = \case + TransformGroupTerms g -> object ["terms" .= g] + TransformGroupHistogram g -> object ["histogram" .= g] + TransformGroupDateHistogram g -> object ["date_histogram" .= g] + TransformGroupOther val -> val + +-- $transformSchema +-- +-- The 'Transform' request body carries the user-supplied fields the +-- server needs to create or update a transform job. Server-only fields +-- (@schema_version@, @updated_at@, @enabled_at@, @roles@, +-- @transform_id@) are deliberately absent — including them would invite +-- callers to send values the server ignores or rejects. They appear on +-- the 'TransformResponse' round-trip shape. + +-- | The request body for @PUT /_plugins/_transform/{transform_id}@. +-- Required fields: @source_index@, @target_index@, +-- @data_selection_query@, @page_size@, and exactly one of @groups@ or +-- @aggregations@. Everything else is optional and omitted on the wire +-- when 'Nothing'. +-- See +data Transform = Transform + { transformEnabled :: Maybe Bool, + transformContinuous :: Maybe Bool, + transformSchedule :: TransformSchedule, + transformDescription :: Maybe Text, + transformMetadataId :: Maybe Text, + transformSourceIndex :: Text, + transformTargetIndex :: Text, + transformDataSelectionQuery :: Value, + transformPageSize :: Int, + transformGroups :: Maybe [TransformGroup], + transformAggregations :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON Transform where + parseJSON = withObject "Transform" $ \v -> do + transformEnabled <- v .:? "enabled" + transformContinuous <- v .:? "continuous" + transformSchedule <- v .: "schedule" + transformDescription <- v .:? "description" + transformMetadataId <- v .:? "metadata_id" + transformSourceIndex <- v .: "source_index" + transformTargetIndex <- v .: "target_index" + transformDataSelectionQuery <- v .: "data_selection_query" + transformPageSize <- v .: "page_size" + transformGroups <- v .:? "groups" + transformAggregations <- v .:? "aggregations" + pure Transform {..} + +instance ToJSON Transform where + toJSON Transform {..} = + omitNulls + [ "enabled" .= transformEnabled, + "continuous" .= transformContinuous, + "schedule" .= transformSchedule, + "description" .= transformDescription, + "metadata_id" .= transformMetadataId, + "source_index" .= transformSourceIndex, + "target_index" .= transformTargetIndex, + "data_selection_query" .= transformDataSelectionQuery, + "page_size" .= transformPageSize, + "groups" .= transformGroups, + "aggregations" .= transformAggregations + ] + +-- | The persisted transform shape returned in responses (the inner +-- @transform@ object of a 'TransformDocumentResponse'). Carries the +-- full 'Transform' body alongside server-injected bookkeeping fields. +-- The round-trip preserves everything the server sent, so a Get → +-- Update cycle does not lose data the caller never set. +-- See +data TransformResponse = TransformResponse + { transformResponseTransformId :: Maybe Text, + transformResponseSchemaVersion :: Maybe Int, + transformResponseContinuous :: Maybe Bool, + transformResponseSchedule :: TransformSchedule, + transformResponseMetadataId :: Maybe Text, + transformResponseUpdatedAt :: Maybe Integer, + transformResponseEnabled :: Maybe Bool, + transformResponseEnabledAt :: Maybe Integer, + transformResponseDescription :: Maybe Text, + transformResponseSourceIndex :: Text, + transformResponseDataSelectionQuery :: Value, + transformResponseTargetIndex :: Text, + transformResponseRoles :: Maybe [Text], + transformResponsePageSize :: Int, + transformResponseGroups :: Maybe [TransformGroup], + transformResponseAggregations :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON TransformResponse where + parseJSON = withObject "TransformResponse" $ \v -> do + transformResponseTransformId <- v .:? "transform_id" + transformResponseSchemaVersion <- v .:? "schema_version" + transformResponseContinuous <- v .:? "continuous" + transformResponseSchedule <- v .: "schedule" + transformResponseMetadataId <- v .:? "metadata_id" + transformResponseUpdatedAt <- v .:? "updated_at" + transformResponseEnabled <- v .:? "enabled" + transformResponseEnabledAt <- v .:? "enabled_at" + transformResponseDescription <- v .:? "description" + transformResponseSourceIndex <- v .: "source_index" + transformResponseDataSelectionQuery <- v .: "data_selection_query" + transformResponseTargetIndex <- v .: "target_index" + transformResponseRoles <- v .:? "roles" + transformResponsePageSize <- v .: "page_size" + transformResponseGroups <- v .:? "groups" + transformResponseAggregations <- v .:? "aggregations" + pure TransformResponse {..} + +instance ToJSON TransformResponse where + toJSON TransformResponse {..} = + -- We use 'object' (not 'omitNulls') here because @roles@ is + -- documented as a server-injected @[]@ (empty array) and must + -- round-trip as @[]@ — but 'omitNulls' drops empty arrays. + -- 'Nothing' fields serialise as JSON @null@, which round-trips + -- through 'FromJSON' cleanly. + object + [ "transform_id" .= transformResponseTransformId, + "schema_version" .= transformResponseSchemaVersion, + "continuous" .= transformResponseContinuous, + "schedule" .= transformResponseSchedule, + "metadata_id" .= transformResponseMetadataId, + "updated_at" .= transformResponseUpdatedAt, + "enabled" .= transformResponseEnabled, + "enabled_at" .= transformResponseEnabledAt, + "description" .= transformResponseDescription, + "source_index" .= transformResponseSourceIndex, + "data_selection_query" .= transformResponseDataSelectionQuery, + "target_index" .= transformResponseTargetIndex, + "roles" .= transformResponseRoles, + "page_size" .= transformResponsePageSize, + "groups" .= transformResponseGroups, + "aggregations" .= transformResponseAggregations + ] + +-- | Request-body wrapper for @PUT /_plugins/_transform/{transform_id}@ +-- (Create \/ Update) and @POST /_plugins/_transform/_preview@. The +-- server requires the 'Transform' to be nested under the top-level +-- @transform@ key, so this newtype encodes \/ decodes that envelope +-- rather than asking the caller to remember the wrapper at every +-- call site. +-- See +newtype TransformRequest = TransformRequest {transformRequestTransform :: Transform} + deriving stock (Eq, Show) + +instance FromJSON TransformRequest where + parseJSON = withObject "TransformRequest" $ \v -> + TransformRequest <$> v .: "transform" + +instance ToJSON TransformRequest where + toJSON TransformRequest {..} = + object ["transform" .= transformRequestTransform] + +-- | Response body of @PUT /_plugins/_transform/{transform_id}@ +-- (Create \/ Update) and @GET /_plugins/_transform/{transform_id}@ +-- (Get). The server wraps the persisted 'TransformResponse' in a +-- document-write envelope (@_id@, @_version@, @_seq_no@, +-- @_primary_term@) — the same shape OpenSearch uses for any persisted +-- document, and the same shape Anomaly Detection's +-- 'CreateDetectorResponse' uses. +-- See +data TransformDocumentResponse = TransformDocumentResponse + { transformDocumentResponseId :: Text, + transformDocumentResponseVersion :: Int, + transformDocumentResponseSeqNo :: Int, + transformDocumentResponsePrimaryTerm :: Int, + transformDocumentResponseTransform :: TransformResponse + } + deriving stock (Eq, Show) + +instance FromJSON TransformDocumentResponse where + parseJSON = withObject "TransformDocumentResponse" $ \v -> do + transformDocumentResponseId <- v .: "_id" + transformDocumentResponseVersion <- v .: "_version" + transformDocumentResponseSeqNo <- v .: "_seq_no" + transformDocumentResponsePrimaryTerm <- v .: "_primary_term" + transformDocumentResponseTransform <- v .: "transform" + pure TransformDocumentResponse {..} + +instance ToJSON TransformDocumentResponse where + toJSON TransformDocumentResponse {..} = + object + [ "_id" .= transformDocumentResponseId, + "_version" .= transformDocumentResponseVersion, + "_seq_no" .= transformDocumentResponseSeqNo, + "_primary_term" .= transformDocumentResponsePrimaryTerm, + "transform" .= transformDocumentResponseTransform + ] + +-- ========================================================================= +-- List query options: GET /_plugins/_transform +-- ========================================================================= + +-- | Sort direction for the list endpoint +-- (@GET /_plugins/_transform\/@). The plugin docs only document +-- @"ASC"@ and @"DESC"@ (uppercase, unlike most OpenSearch APIs which +-- use lowercase). Unknown values parse as +-- 'TransformSortDirectionCustom' so a future plugin release surfaces +-- as a parsed value rather than a decode failure. +-- See +data TransformSortDirection + = TransformSortDirectionAsc + | TransformSortDirectionDesc + | TransformSortDirectionCustom Text + deriving stock (Eq, Show) + +-- | The wire string for a 'TransformSortDirection'. +transformSortDirectionText :: TransformSortDirection -> Text +transformSortDirectionText = \case + TransformSortDirectionAsc -> "ASC" + TransformSortDirectionDesc -> "DESC" + TransformSortDirectionCustom t -> t + +instance ToJSON TransformSortDirection where + toJSON = toJSON . transformSortDirectionText + +instance FromJSON TransformSortDirection where + parseJSON = withText "TransformSortDirection" $ \case + "ASC" -> pure TransformSortDirectionAsc + "DESC" -> pure TransformSortDirectionDesc + other -> pure (TransformSortDirectionCustom other) + +-- | Query-string parameters accepted by @GET /_plugins/_transform\/@ +-- (list all transforms). Every field is optional; +-- 'defaultTransformsListOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. +-- See +data TransformsListOptions = TransformsListOptions + { transformsListOptionsFrom :: Maybe Int, + transformsListOptionsSize :: Maybe Int, + transformsListOptionsSearch :: Maybe Text, + transformsListOptionsSortField :: Maybe Text, + transformsListOptionsSortDirection :: Maybe TransformSortDirection + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the +-- plain @GET /_plugins/_transform\/@ when passed to 'getTransforms'. +defaultTransformsListOptions :: TransformsListOptions +defaultTransformsListOptions = + TransformsListOptions + { transformsListOptionsFrom = Nothing, + transformsListOptionsSize = Nothing, + transformsListOptionsSearch = Nothing, + transformsListOptionsSortField = Nothing, + transformsListOptionsSortDirection = Nothing + } + +-- | Render a 'TransformsListOptions' to the query-string pairs accepted +-- by the list endpoint. Fields set to 'Nothing' are omitted (not +-- rendered with an empty value). +transformsListOptionsParams :: TransformsListOptions -> [(Text, Maybe Text)] +transformsListOptionsParams TransformsListOptions {..} = + catMaybes + [ ("from",) . Just . tshow <$> transformsListOptionsFrom, + ("size",) . Just . tshow <$> transformsListOptionsSize, + ("search",) . Just <$> transformsListOptionsSearch, + ("sortField",) . Just <$> transformsListOptionsSortField, + ("sortDirection",) . Just . transformSortDirectionText <$> transformsListOptionsSortDirection + ] + +-- ========================================================================= +-- List response: GET /_plugins/_transform +-- ========================================================================= + +-- | One entry in the @transforms@ array returned by +-- @GET /_plugins/_transform\/@. Structurally a subset of +-- 'TransformDocumentResponse': the same @transform@ payload under the +-- same document-write envelope, but the docs samples omit @_version@ on +-- list entries (the field is therefore 'Maybe' here). +-- See +data GetTransformsListEntry = GetTransformsListEntry + { getTransformsListEntryId :: Text, + getTransformsListEntryVersion :: Maybe Int, + getTransformsListEntrySeqNo :: Maybe Int, + getTransformsListEntryPrimaryTerm :: Maybe Int, + getTransformsListEntryTransform :: TransformResponse + } + deriving stock (Eq, Show) + +instance FromJSON GetTransformsListEntry where + parseJSON = withObject "GetTransformsListEntry" $ \v -> do + getTransformsListEntryId <- v .: "_id" + getTransformsListEntryVersion <- v .:? "_version" + getTransformsListEntrySeqNo <- v .:? "_seq_no" + getTransformsListEntryPrimaryTerm <- v .:? "_primary_term" + getTransformsListEntryTransform <- v .: "transform" + pure GetTransformsListEntry {..} + +instance ToJSON GetTransformsListEntry where + toJSON GetTransformsListEntry {..} = + omitNulls + [ "_id" .= getTransformsListEntryId, + "_version" .= getTransformsListEntryVersion, + "_seq_no" .= getTransformsListEntrySeqNo, + "_primary_term" .= getTransformsListEntryPrimaryTerm, + "transform" .= getTransformsListEntryTransform + ] + +-- | Envelope returned by @GET /_plugins/_transform\/@. The plugin +-- returns @total_transforms@ (the count of all transforms the caller +-- can see, independent of pagination) alongside the per-page +-- @transforms@ array — distinct from the standard search @hits@ +-- envelope. +-- See +data GetTransformsResponse = GetTransformsResponse + { getTransformsResponseTotalTransforms :: Int, + getTransformsResponseTransforms :: [GetTransformsListEntry] + } + deriving stock (Eq, Show) + +instance FromJSON GetTransformsResponse where + parseJSON = withObject "GetTransformsResponse" $ \v -> do + getTransformsResponseTotalTransforms <- v .: "total_transforms" + getTransformsResponseTransforms <- v .:? "transforms" .!= [] + pure GetTransformsResponse {..} + +instance ToJSON GetTransformsResponse where + toJSON GetTransformsResponse {..} = + object + [ "total_transforms" .= getTransformsResponseTotalTransforms, + "transforms" .= getTransformsResponseTransforms + ] + +-- ========================================================================= +-- Explain response: GET /_plugins/_transform/{id}/_explain +-- ========================================================================= + +-- | Per-transform statistics returned inside 'TransformMetadata'. +-- All fields are integers (counts or durations in milliseconds). +-- See +data TransformStats = TransformStats + { transformStatsPagesProcessed :: Maybe Int, + transformStatsDocumentsProcessed :: Maybe Int, + transformStatsDocumentsIndexed :: Maybe Int, + transformStatsIndexTimeInMillis :: Maybe Int, + transformStatsSearchTimeInMillis :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON TransformStats where + parseJSON = withObject "TransformStats" $ \v -> do + transformStatsPagesProcessed <- v .:? "pages_processed" + transformStatsDocumentsProcessed <- v .:? "documents_processed" + transformStatsDocumentsIndexed <- v .:? "documents_indexed" + transformStatsIndexTimeInMillis <- v .:? "index_time_in_millis" + transformStatsSearchTimeInMillis <- v .:? "search_time_in_millis" + pure TransformStats {..} + +instance ToJSON TransformStats where + toJSON TransformStats {..} = + omitNulls + [ "pages_processed" .= transformStatsPagesProcessed, + "documents_processed" .= transformStatsDocumentsProcessed, + "documents_indexed" .= transformStatsDocumentsIndexed, + "index_time_in_millis" .= transformStatsIndexTimeInMillis, + "search_time_in_millis" .= transformStatsSearchTimeInMillis + ] + +-- | Continuous-transform runtime state, only present on transforms +-- where 'transformContinuous' is 'True'. @last_timestamp@ is the +-- epoch-ms of the most recently processed source document; +-- @documents_behind@ maps source index names to the count of source +-- documents not yet reflected in the target. +-- See +data TransformContinuousStats = TransformContinuousStats + { transformContinuousStatsLastTimestamp :: Maybe Integer, + transformContinuousStatsDocumentsBehind :: Maybe (Map Text Int) + } + deriving stock (Eq, Show) + +instance FromJSON TransformContinuousStats where + parseJSON = withObject "TransformContinuousStats" $ \v -> do + transformContinuousStatsLastTimestamp <- v .:? "last_timestamp" + transformContinuousStatsDocumentsBehind <- v .:? "documents_behind" + pure TransformContinuousStats {..} + +instance ToJSON TransformContinuousStats where + toJSON TransformContinuousStats {..} = + omitNulls + [ "last_timestamp" .= transformContinuousStatsLastTimestamp, + "documents_behind" .= transformContinuousStatsDocumentsBehind + ] + +-- | The @transform_metadata@ sub-object of an 'TransformExplain'. +-- @status@ is a free-form 'Text' (the docs example shows @"finished"@; +-- other states like @"failed"@, @"started"@ surface without a parse +-- failure). @failure_reason@ is @null@ on success — the docs literally +-- show the JSON string @"null"@, so we keep it as 'Maybe' 'Text' and +-- rely on aeson to decode a real @null@ as 'Nothing'. +-- See +data TransformMetadata = TransformMetadata + { transformMetadataContinuousStats :: Maybe TransformContinuousStats, + transformMetadataTransformId :: Maybe Text, + transformMetadataLastUpdatedAt :: Maybe Integer, + transformMetadataStatus :: Maybe Text, + transformMetadataFailureReason :: Maybe Text, + transformMetadataStats :: Maybe TransformStats + } + deriving stock (Eq, Show) + +instance FromJSON TransformMetadata where + parseJSON = withObject "TransformMetadata" $ \v -> do + transformMetadataContinuousStats <- v .:? "continuous_stats" + transformMetadataTransformId <- v .:? "transform_id" + transformMetadataLastUpdatedAt <- v .:? "last_updated_at" + transformMetadataStatus <- v .:? "status" + transformMetadataFailureReason <- v .:? "failure_reason" + transformMetadataStats <- v .:? "stats" + pure TransformMetadata {..} + +instance ToJSON TransformMetadata where + toJSON TransformMetadata {..} = + omitNulls + [ "continuous_stats" .= transformMetadataContinuousStats, + "transform_id" .= transformMetadataTransformId, + "last_updated_at" .= transformMetadataLastUpdatedAt, + "status" .= transformMetadataStatus, + "failure_reason" .= transformMetadataFailureReason, + "stats" .= transformMetadataStats + ] + +-- | One value of the @_explain@ response. The plugin returns a top-level +-- object keyed by transform_id whose value combines the @metadata_id@ of +-- the transform's metadata document with the @transform_metadata@ +-- sub-object. The metadata sub-object is 'Maybe' because the plugin +-- omits it on a freshly-created transform that has not yet run. +-- See +data TransformExplain = TransformExplain + { transformExplainMetadataId :: Maybe Text, + transformExplainTransformMetadata :: Maybe TransformMetadata + } + deriving stock (Eq, Show) + +instance FromJSON TransformExplain where + parseJSON = withObject "TransformExplain" $ \v -> do + transformExplainMetadataId <- v .:? "metadata_id" + transformExplainTransformMetadata <- v .:? "transform_metadata" + pure TransformExplain {..} + +instance ToJSON TransformExplain where + toJSON TransformExplain {..} = + omitNulls + [ "metadata_id" .= transformExplainMetadataId, + "transform_metadata" .= transformExplainTransformMetadata + ] + +-- ========================================================================= +-- Preview: POST /_plugins/_transform/_preview +-- ========================================================================= + +-- | Response body of @POST /_plugins/_transform/_preview@. Each entry +-- of @documents@ is a transformed row whose keys are derived from the +-- caller's @groups[].target_field@ names plus @aggregations@ keys. The +-- shape is wholly caller-driven, so the entries are carried as opaque +-- 'Value's. +-- See +newtype PreviewTransformResponse = PreviewTransformResponse + { previewTransformResponseDocuments :: [Value] + } + deriving stock (Eq, Show) + +instance FromJSON PreviewTransformResponse where + parseJSON = withObject "PreviewTransformResponse" $ \v -> do + previewTransformResponseDocuments <- v .:? "documents" .!= [] + pure PreviewTransformResponse {..} + +instance ToJSON PreviewTransformResponse where + toJSON PreviewTransformResponse {..} = + object ["documents" .= previewTransformResponseDocuments] + +-- ========================================================================= +-- Helpers +-- ========================================================================= + +-- | Render the known @(Key, Value)@ pairs of a group entry (omitting +-- 'Nothing' fields), then merge any surviving keys from the +-- per-group 'other' catch-all back in so an unknown forward-compat +-- field round-trips at its original key rather than under a +-- synthesised @other@ wrapper. Known fields take precedence over the +-- catch-all on key collision (a caller hand-building both sides +-- should not be able to end up with two values for one wire key). +-- 'Nothing' known fields are filtered out before the merge so they +-- don't leak as explicit @null@s alongside the catch-all payload +-- (mirroring 'omitNulls' semantics). +mergeOther :: Maybe Value -> [(Key, Value)] -> Value +mergeOther mOther knownPairs = + case mOther of + Nothing -> omitNulls knownPairs + Just (Object otherKm) -> + let knownKm = KM.fromList (filter (not . isNullValue . snd) knownPairs) + in Object (KM.union knownKm otherKm) + Just _otherVal -> + -- An 'other' catch-all that is not an Object is unusual (the + -- decoder only ever produces @Object v@). Emit the known fields + -- (with nulls dropped) and drop the exotic 'other' value + -- rather than guessing how to merge them. + omitNulls knownPairs + +-- | Predicate matching 'omitNulls''s @notNull@: 'Null' and the empty +-- array are filtered; everything else survives. +isNullValue :: Value -> Bool +isNullValue Null = True +isNullValue (Array a) = V.null a +isNullValue _ = False diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/JobScheduler.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/JobScheduler.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/JobScheduler.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.JobScheduler + ( LockId (..), + JobsResponse (..), + JobEntry (..), + JobSchedulerSchedule (..), + JobSchedulerCron (..), + JobSchedulerInterval (..), + LocksResponse (..), + LockEntry (..), + lookupLockEntry, + ) +where + +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Map.Strict qualified as Map +import Database.Bloodhound.Internal.Utils.Imports + +-- $overview +-- +-- The OpenSearch Job Scheduler plugin +-- () +-- is a backing plugin: it does not run on its own but provides the +-- scheduling + distributed-locking primitives that ISM, Snapshot +-- Management, Index Rollups, Index Transforms, Anomaly Detection and +-- Alerting build on top of. Its own REST surface is intentionally tiny +-- and read-only, exposing two resources under +-- @\/_plugins\/_job_scheduler\/api@: +-- +-- * @GET ...\/api\/jobs@ — list every scheduled job the scheduler is +-- tracking, returning a 'JobsResponse' +-- (@{total_jobs, jobs, failures}@). +-- * @GET ...\/api\/locks@ and @GET ...\/api\/locks\/{lock_id}@ — list +-- or look up the distributed locks the scheduler holds, returning a +-- 'LocksResponse' (@{total_locks, locks}@). The @locks@ object is a +-- 'Map' keyed by the lock's document id; each value is a 'LockEntry' +-- (@job_index_name@, @job_id@, @lock_time@, @lock_duration_seconds@, +-- @released@). +-- +-- /Availability caveat:/ the @\/api\/jobs@ and @\/api\/locks@ REST +-- handlers are only registered on OpenSearch 3.x. A 1.x or 2.x cluster +-- answers @404 no handler found@ even when the @opensearch-job-scheduler@ +-- plugin is installed (the plugin is present — it backs ISM/Alerting — +-- but the inspection endpoints were not wired up until OS 3). Bloodhound +-- ships the surface on OS1, OS2 and OS3 for API uniformity; on an older +-- cluster the request surfaces as a 'StatusDependant' 'EsError' rather +-- than throwing. +-- +-- /Shape caveat:/ the official docs do not publish field tables for this +-- backing plugin (unlike Rollups / Snapshot Management). The shapes below +-- were live-verified against an OS 3.7.0 cluster. Every field is +-- 'Maybe' and every record carries an @extras@ catch-all, so a decode +-- never fails on an unknown or missing key — the typed accessors simply +-- read 'Nothing' and the raw key lands in @extras@. This is the same +-- lenient stance the @SMSnapshotConfig@ type takes for its +-- passthrough block. +-- +-- This module is triplicated byte-for-byte across OS1, OS2 and OS3 (only +-- the module name and the doc URL above differ), mirroring the ISM / +-- Alerting / Rollups / SnapshotManagement convention. + +-- | Identifies a lock in the +-- @\/_plugins\/_job_scheduler\/api\/locks\/{lock_id}@ URL path. Wraps +-- 'Text' so it round-trips through JSON as a bare string but is distinct +-- at the Haskell type level. +-- +-- The scheduler requires the id to be in the @index-jobid@ format +-- (e.g. @.opendistro-ism-config-myjob_123@); any other shape is rejected +-- by the server with @400 illegal_argument_exception@. We do not enforce +-- the format client-side — the caller is responsible for supplying a +-- well-formed id, and a malformed one surfaces as an 'EsError' via +-- 'StatusDependant'. +newtype LockId = LockId {unLockId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- ========================================================================= +-- Jobs +-- ========================================================================= + +-- | Response body of @GET \/_plugins\/_job_scheduler\/api\/jobs@. The +-- @jobs@ array carries one 'JobEntry' per scheduled job; @failures@ lists +-- indices that could not be queried (shape undocumented, kept opaque as +-- 'Value'); @total_jobs@ is the count of @jobs@. +-- +-- See 'JobEntry' for the per-job field caveats. +data JobsResponse = JobsResponse + { jobsResponseTotalJobs :: Int, + jobsResponseJobs :: [JobEntry], + jobsResponseFailures :: [Value] + } + deriving stock (Eq, Show) + +instance FromJSON JobsResponse where + parseJSON = withObject "JobsResponse" $ \o -> do + jobsResponseTotalJobs <- o .:? "total_jobs" .!= 0 + jobsResponseJobs <- o .:? "jobs" .!= [] + jobsResponseFailures <- o .:? "failures" .!= [] + pure JobsResponse {..} + +instance ToJSON JobsResponse where + toJSON JobsResponse {..} = + object + [ "total_jobs" .= jobsResponseTotalJobs, + "jobs" .= jobsResponseJobs, + "failures" .= jobsResponseFailures + ] + +-- | One scheduled job as returned by the Jobs API. The Job Scheduler +-- plugin persists jobs as @ScheduledJobParameter@ documents in a config +-- index (@.opendistro-ism-config@, @.opendistro-anomaly-detector-jobs@, +-- ...); the API serialises those documents with the fields modelled +-- here. The official docs do not publish a field table for this shape, so +-- every field is 'Maybe' and anything unrecognised lands in +-- 'jobEntryExtras' — the decode therefore never fails on a newer / +-- plugin-specific job document. +-- +-- The decoder also accepts a search-hit wrapper (@{_source: {...}}@), so +-- it is robust if the server ever wraps the job in a hit envelope. +data JobEntry = JobEntry + { jobEntryJobId :: Maybe Text, + jobEntryName :: Maybe Text, + jobEntryEnabled :: Maybe Bool, + jobEntryEnabledTime :: Maybe Integer, + jobEntryLastUpdateTime :: Maybe Integer, + jobEntryLockDurationSeconds :: Maybe Int, + jobEntryJobType :: Maybe Text, + jobEntrySchedule :: Maybe JobSchedulerSchedule, + jobEntryExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +jobEntryKnownKeys :: [Key] +jobEntryKnownKeys = + [ "job_id", + "name", + "enabled", + "enabled_time", + "last_update_time", + "lock_duration_seconds", + "type", + "schedule" + ] + +instance FromJSON JobEntry where + parseJSON = withObject "JobEntry" $ \o0 -> do + let o = case KeyMap.lookup "_source" o0 of + Just (Object s) -> s + _ -> o0 + jobEntryJobId <- o .:? "job_id" + jobEntryName <- o .:? "name" + jobEntryEnabled <- o .:? "enabled" + jobEntryEnabledTime <- o .:? "enabled_time" + jobEntryLastUpdateTime <- o .:? "last_update_time" + jobEntryLockDurationSeconds <- o .:? "lock_duration_seconds" + jobEntryJobType <- o .:? "type" + jobEntrySchedule <- o .:? "schedule" + let extras = deleteSeveral jobEntryKnownKeys o + jobEntryExtras <- + if null extras then pure Nothing else pure (Just extras) + pure JobEntry {..} + +instance ToJSON JobEntry where + toJSON JobEntry {..} = + omitNulls + ( [ "job_id" .= jobEntryJobId, + "name" .= jobEntryName, + "enabled" .= jobEntryEnabled, + "enabled_time" .= jobEntryEnabledTime, + "last_update_time" .= jobEntryLastUpdateTime, + "lock_duration_seconds" .= jobEntryLockDurationSeconds, + "type" .= jobEntryJobType, + "schedule" .= jobEntrySchedule + ] + ++ maybe [] KeyMap.toList jobEntryExtras + ) + +-- | The @schedule@ object of a 'JobEntry'. The Job Scheduler SPI supports +-- an @interval@ form and a @cron@ form (the same two shapes the Snapshot +-- Management plugin reuses via @SMJobSchedulerInterval@ / @SMCron@); any +-- other schedule kind (e.g. plugin-provided) is preserved verbatim as +-- 'JobSchedulerScheduleCustom'. +-- +-- /Disambiguation:/ the two forms are mutually exclusive on the wire; the +-- decoder tests @interval@ first, then @cron@, then falls back to +-- 'JobSchedulerScheduleCustom'. So in the (impossible-on-real-data) case +-- where both @interval@ and @cron@ are present, @interval@ wins. +data JobSchedulerSchedule + = JobSchedulerScheduleInterval JobSchedulerInterval + | JobSchedulerScheduleCron JobSchedulerCron + | JobSchedulerScheduleCustom Value + deriving stock (Eq, Show) + +instance FromJSON JobSchedulerSchedule where + parseJSON = withObject "JobSchedulerSchedule" $ \o -> + case (KeyMap.lookup "interval" o, KeyMap.lookup "cron" o) of + (Just v, _) -> JobSchedulerScheduleInterval <$> parseJSON v + (_, Just v) -> JobSchedulerScheduleCron <$> parseJSON v + _ -> pure (JobSchedulerScheduleCustom (Object o)) + +instance ToJSON JobSchedulerSchedule where + toJSON = \case + JobSchedulerScheduleInterval i -> object ["interval" .= i] + JobSchedulerScheduleCron c -> object ["cron" .= c] + JobSchedulerScheduleCustom v -> v + +-- | The @schedule.interval@ object (@start_time@, @period@, @unit@). The +-- @unit@ is a Java time-unit enum string (@"Minutes"@, @"Hours"@, +-- @"Days"@, ...). Unknown keys land in 'jobSchedulerIntervalExtras'. +data JobSchedulerInterval = JobSchedulerInterval + { jobSchedulerIntervalStartTime :: Maybe Integer, + jobSchedulerIntervalPeriod :: Maybe Int, + jobSchedulerIntervalUnit :: Maybe Text, + jobSchedulerIntervalExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +jobSchedulerIntervalKnownKeys :: [Key] +jobSchedulerIntervalKnownKeys = ["start_time", "period", "unit"] + +instance FromJSON JobSchedulerInterval where + parseJSON = withObject "JobSchedulerInterval" $ \o -> do + jobSchedulerIntervalStartTime <- o .:? "start_time" + jobSchedulerIntervalPeriod <- o .:? "period" + jobSchedulerIntervalUnit <- o .:? "unit" + let extras = deleteSeveral jobSchedulerIntervalKnownKeys o + jobSchedulerIntervalExtras <- + if null extras then pure Nothing else pure (Just extras) + pure JobSchedulerInterval {..} + +instance ToJSON JobSchedulerInterval where + toJSON JobSchedulerInterval {..} = + omitNulls + ( [ "start_time" .= jobSchedulerIntervalStartTime, + "period" .= jobSchedulerIntervalPeriod, + "unit" .= jobSchedulerIntervalUnit + ] + ++ maybe [] KeyMap.toList jobSchedulerIntervalExtras + ) + +-- | The @schedule.cron@ object (@expression@, @timezone@). Unknown keys +-- land in 'jobSchedulerCronExtras'. +data JobSchedulerCron = JobSchedulerCron + { jobSchedulerCronExpression :: Maybe Text, + jobSchedulerCronTimezone :: Maybe Text, + jobSchedulerCronExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +jobSchedulerCronKnownKeys :: [Key] +jobSchedulerCronKnownKeys = ["expression", "timezone"] + +instance FromJSON JobSchedulerCron where + parseJSON = withObject "JobSchedulerCron" $ \o -> do + jobSchedulerCronExpression <- o .:? "expression" + jobSchedulerCronTimezone <- o .:? "timezone" + let extras = deleteSeveral jobSchedulerCronKnownKeys o + jobSchedulerCronExtras <- + if null extras then pure Nothing else pure (Just extras) + pure JobSchedulerCron {..} + +instance ToJSON JobSchedulerCron where + toJSON JobSchedulerCron {..} = + omitNulls + ( [ "expression" .= jobSchedulerCronExpression, + "timezone" .= jobSchedulerCronTimezone + ] + ++ maybe [] KeyMap.toList jobSchedulerCronExtras + ) + +-- ========================================================================= +-- Locks +-- ========================================================================= + +-- | Response body of @GET \/_plugins\/_job_scheduler\/api\/locks@ and +-- @GET \/_plugins\/_job_scheduler\/api\/locks\/{lock_id}@. Both endpoints +-- answer with the same envelope: a @total_locks@ count and a @locks@ map +-- keyed by the lock's document id. Use 'lookupLockEntry' to fetch the +-- entry for a specific id from the by-id response. +data LocksResponse = LocksResponse + { locksResponseTotalLocks :: Int, + locksResponseLocks :: Map.Map Text LockEntry + } + deriving stock (Eq, Show) + +instance FromJSON LocksResponse where + parseJSON = withObject "LocksResponse" $ \o -> do + locksResponseTotalLocks <- o .:? "total_locks" .!= 0 + locksResponseLocks <- o .:? "locks" .!= Map.empty + pure LocksResponse {..} + +instance ToJSON LocksResponse where + toJSON LocksResponse {..} = + object + [ "total_locks" .= locksResponseTotalLocks, + "locks" .= locksResponseLocks + ] + +-- | Look up the 'LockEntry' for a lock document id within a +-- 'LocksResponse'. Returns 'Nothing' when the id is absent (the by-id +-- endpoint yields @{"total_locks":0,"locks":{}}@ for a valid-format but +-- unknown id). +lookupLockEntry :: Text -> LocksResponse -> Maybe LockEntry +lookupLockEntry lockId = Map.lookup lockId . locksResponseLocks + +-- | One distributed lock as returned in the @locks@ map of a +-- 'LocksResponse'. The official docs do not publish a field table for +-- this shape, so every field is 'Maybe' and anything unrecognised lands +-- in 'lockEntryExtras' — the decode never fails. The live-verified +-- fields are @job_index_name@, @job_id@, @lock_time@ (epoch /seconds/), +-- @lock_duration_seconds@ and @released@. +data LockEntry = LockEntry + { lockEntryJobIndexName :: Maybe Text, + lockEntryJobId :: Maybe Text, + lockEntryLockTime :: Maybe Integer, + lockEntryLockDurationSeconds :: Maybe Int, + lockEntryReleased :: Maybe Bool, + lockEntryExtras :: Maybe (KeyMap.KeyMap Value) + } + deriving stock (Eq, Show) + +lockEntryKnownKeys :: [Key] +lockEntryKnownKeys = + [ "job_index_name", + "job_id", + "lock_time", + "lock_duration_seconds", + "released" + ] + +instance FromJSON LockEntry where + parseJSON = withObject "LockEntry" $ \o -> do + lockEntryJobIndexName <- o .:? "job_index_name" + lockEntryJobId <- o .:? "job_id" + lockEntryLockTime <- o .:? "lock_time" + lockEntryLockDurationSeconds <- o .:? "lock_duration_seconds" + lockEntryReleased <- o .:? "released" + let extras = deleteSeveral lockEntryKnownKeys o + lockEntryExtras <- + if null extras then pure Nothing else pure (Just extras) + pure LockEntry {..} + +instance ToJSON LockEntry where + toJSON LockEntry {..} = + omitNulls + ( [ "job_index_name" .= lockEntryJobIndexName, + "job_id" .= lockEntryJobId, + "lock_time" .= lockEntryLockTime, + "lock_duration_seconds" .= lockEntryLockDurationSeconds, + "released" .= lockEntryReleased + ] + ++ maybe [] KeyMap.toList lockEntryExtras + ) diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/KnnModel.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/KnnModel.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/KnnModel.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.KnnModel + ( KnnModelState (..), + KnnModel (..), + KnnDeleteModelResponse (..), + ) +where + +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Knn (OpenSearchKnnEngine) + +-- $schema +-- +-- The k-NN plugin Get Model API +-- (, +-- @GET /_plugins/_knn/models/{model_id}@) returns a bare object describing a +-- trained model. Some native library index configurations (notably FAISS IVF +-- and HNSW with PQ) require a training step before indexing can begin; the +-- output of training is serialized into the @.opensearch-knn-models@ system +-- index and read back by this endpoint. +-- +-- Every field except @model_id@ is modelled as 'Maybe' for two reasons. First, +-- the @model_blob@ field is deliberately large (a base64 serialization of the +-- trained graph) and is routinely excluded with @?filter_path@ or +-- @_source_excludes=model_blob@, so a strict parse would reject the common +-- metadata-only read. Second, the same @filter_path@ mechanism lets a caller +-- request any subset of fields, so the parser must tolerate arbitrary +-- omissions (same defensive shape as 'ModelInfo'). +-- +-- The @engine@ field reuses the shared 'OpenSearchKnnEngine' type (also used +-- by index mappings and the search clause), so the wire vocabulary +-- (@faiss@, @nmslib@, @lucene@) is defined in one place. + +-- | The lifecycle state of a k-NN model, as reported by the @state@ field of +-- 'KnnModel'. The k-NN plugin documents exactly three values; an unknown +-- value parse-fails so a future plugin release surfaces as a deliberate +-- error rather than a silent drop. +data KnnModelState + = KnnModelStateCreated + | KnnModelStateFailed + | KnnModelStateTraining + deriving stock (Eq, Show) + +instance ToJSON KnnModelState where + toJSON = \case + KnnModelStateCreated -> "created" + KnnModelStateFailed -> "failed" + KnnModelStateTraining -> "training" + +instance FromJSON KnnModelState where + parseJSON = withText "KnnModelState" $ \case + "created" -> pure KnnModelStateCreated + "failed" -> pure KnnModelStateFailed + "training" -> pure KnnModelStateTraining + other -> fail ("Unknown KnnModelState: " <> T.unpack other) + +-- | Response of @GET /_plugins/_knn/models/{model_id}@. The body is a bare +-- object (no envelope); the server returns every metadata field it has. See +-- the module docs for why every field except @model_id@ is 'Maybe'. +-- +-- The @timestamp@ is the server-formatted creation time (e.g. +-- @2021-11-15T18:45:07.505369036Z@); it is kept as 'Text' rather than parsed +-- to a time type so the client does not couple to the plugin's sub-second +-- precision. +data KnnModel = KnnModel + { knnModelModelId :: Text, + knnModelModelBlob :: Maybe Text, + knnModelState :: Maybe KnnModelState, + knnModelTimestamp :: Maybe Text, + knnModelDescription :: Maybe Text, + knnModelError :: Maybe Text, + knnModelSpaceType :: Maybe Text, + knnModelDimension :: Maybe Int, + knnModelEngine :: Maybe OpenSearchKnnEngine + } + deriving stock (Eq, Show) + +instance FromJSON KnnModel where + parseJSON = withObject "KnnModel" $ \v -> do + knnModelModelId <- v .: "model_id" + knnModelModelBlob <- v .:? "model_blob" + knnModelState <- v .:? "state" + knnModelTimestamp <- v .:? "timestamp" + knnModelDescription <- v .:? "description" + knnModelError <- v .:? "error" + knnModelSpaceType <- v .:? "space_type" + knnModelDimension <- v .:? "dimension" + knnModelEngine <- v .:? "engine" + pure KnnModel {..} + +instance ToJSON KnnModel where + toJSON KnnModel {..} = + omitNulls + [ "model_id" .= knnModelModelId, + "model_blob" .= knnModelModelBlob, + "state" .= knnModelState, + "timestamp" .= knnModelTimestamp, + "description" .= knnModelDescription, + "error" .= knnModelError, + "space_type" .= knnModelSpaceType, + "dimension" .= knnModelDimension, + "engine" .= knnModelEngine + ] + +-- | Response of @DELETE /_plugins/_knn/models/{model_id}@. Per the k-NN +-- plugin's @DeleteModelResponse@, the body is a bare object with two +-- fields: @model_id@ (echoing the id passed in the path) and @result@ +-- (always @"deleted"@ for a successful delete). Note that this is NOT the +-- standard 'Acknowledged' envelope — the k-NN plugin returns a richer +-- response than the typical cluster-level ack, mirroring the shape of +-- 'KnnTrainResponse' rather than 'Acknowledged'. +-- +-- The @result@ field is kept as 'Text' rather than a closed enum: the +-- plugin only emits @"deleted"@ today, but a future version could add +-- @"not_found"@ or similar, and an enum would force a parse failure in +-- that case. +-- +-- /Note on the public docs:/ the k-NN API docs page +-- () +-- shows the response as @{"model_id": ..., "acknowledged": true}@, which is +-- incorrect. The authoritative shape is the one emitted by the plugin's +-- @DeleteModelResponse@ serializer +-- (), +-- i.e. @model_id@ + @result@. The type below follows the serializer, not the +-- docs. +data KnnDeleteModelResponse = KnnDeleteModelResponse + { knnDeleteModelResponseModelId :: Text, + knnDeleteModelResponseResult :: Text + } + deriving stock (Eq, Show) + +instance FromJSON KnnDeleteModelResponse where + parseJSON = withObject "KnnDeleteModelResponse" $ \v -> do + knnDeleteModelResponseModelId <- v .: "model_id" + knnDeleteModelResponseResult <- v .: "result" + pure KnnDeleteModelResponse {..} + +instance ToJSON KnnDeleteModelResponse where + toJSON KnnDeleteModelResponse {..} = + object + [ "model_id" .= knnDeleteModelResponseModelId, + "result" .= knnDeleteModelResponseResult + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/KnnStats.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/KnnStats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/KnnStats.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.KnnStats + ( KnnNodeId (..), + KnnStatName (..), + KnnStats (..), + ) +where + +import Data.Map.Strict qualified as Map +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- @ +-- { +-- "": , +-- ..., +-- "nodes": { "<22-char-node-id>": { "": , ... } } +-- } +-- @ +-- +-- The @GET /_plugins/_knn/stats@ endpoint +-- () +-- returns both cluster-level statistics (a single value for the entire +-- cluster, e.g. @total_load_time@, @hit_count@, @circuit_breaker_triggered@) +-- and node-level statistics (a single value per node, nested under the +-- literal @nodes@ key keyed by opaque node ID). The same stat name can +-- appear either as a cluster-level top-level key or nested under a +-- per-node entry, and the stat-name set is large and version-gated by the +-- plugin — each stat carries the OpenSearch version that introduced it. +-- Modelling every stat as a typed Haskell record field would lock the +-- client to one plugin version and require churn on every release, so the +-- body is kept as a flat 'Map.Map Text Value' — callers get a typed +-- envelope and navigate to the per-node map (via @'Map.lookup' \"nodes\"@) +-- or to any individual cluster stat with the aeson combinators they +-- already use elsewhere (same shape as +-- 'Database.Bloodhound.OpenSearch3.Types.MLStats'). + +-- | A node ID for the k-NN plugin's +-- @\/_plugins\/_knn\/{nodeId}\/stats@ path segment. OpenSearch uses +-- 22-character opaque node IDs (the same identifiers returned by +-- @GET \/_nodes@); we wrap 'Text' so the value round-trips through JSON as a +-- bare string but is distinct from 'NodeName' \/ 'FullNodeId' \/ 'NeuralNodeId' +-- at the type level. +newtype KnnNodeId = KnnNodeId {unKnnNodeId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A stat name filter for the +-- @\/_plugins\/_knn\/stats\/{stat}@ path segment. Each value matches one of +-- the plugin's documented @StatName@ constants (@hit_count@, @miss_count@, +-- @knn_query_cache_size@, ...); the full set changes across OpenSearch +-- releases, so this is intentionally a thin 'Text' newtype rather than a +-- closed enum. +newtype KnnStatName = KnnStatName {unKnnStatName :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Response of @GET /_plugins/_knn/stats@. The body is a JSON object whose +-- top-level keys are either cluster-level stat names (mapping to scalars) or +-- the literal key @nodes@ (mapping to a per-node map keyed by opaque node +-- ID); see the module docs for why the entries are kept as aeson 'Value's +-- rather than modelled per-stat. The 'Map.Map' round-trips a flat JSON +-- object via its aeson instances, so no custom 'ToJSON' \/ 'FromJSON' is +-- needed. To reach per-node stats, decode the @nodes@ value, e.g.: +-- +-- @ +-- case 'Map.lookup' \"nodes\" (knnStatsEntries stats) of +-- 'Just' ('Object' m) -> ... navigate m with aeson KeyMap combinators ... +-- _ -> 'Nothing' +-- @ +newtype KnnStats = KnnStats {knnStatsEntries :: Map.Map Text Value} + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/KnnTrain.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/KnnTrain.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/KnnTrain.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.KnnTrain + ( KnnTrainingMethod (..), + KnnTrainingRequest (..), + KnnTrainResponse (..), + ) +where + +import Data.Aeson +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.Knn (OpenSearchKnnEngine) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes + ( FieldName, + IndexName, + ) + +-- $schema +-- +-- The k-NN plugin Train Model API +-- (, +-- @POST /_plugins/_knn/models/{model_id}/_train@) trains a native library +-- model (FAISS IVF, IVF with PQ encoder, ...) from the vectors stored in a +-- @knn_vector@ field of a training index. Only methods that require training +-- are eligible; HNSW/Lucene do not. Training is asynchronous: the request +-- returns as soon as training is scheduled, carrying only the @model_id@; +-- the caller polls 'Database.Bloodhound.OpenSearch3.Client.getKnnModel' to +-- observe the @state@ transition from @training@ to @created@ (success) or +-- @failed@ (with the @error@ field populated). +-- +-- The request body is a flat object with four required fields +-- (@training_index@, @training_field@, @dimension@, @method@) and four +-- optional fields (@space_type@, @max_training_vector_count@, @search_size@, +-- @description@). The @method@ sub-object reuses the standard k-NN method +-- schema (@name@, @engine@, @space_type@, @parameters@); its @parameters@ +-- are deeply nested and engine-specific (e.g. @nlist@, an @encoder@ with +-- its own @parameters@), so they are kept as an opaque aeson 'Value' on the +-- Haskell side — the same passthrough strategy used for +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Knn.KnnInnerHits' and +-- @registerModelConnector@. + +-- | The @method@ sub-object of 'KnnTrainingRequest'. Names the training +-- algorithm and its native engine; @parameters@ carries the deeply nested +-- engine-specific knobs (e.g. @{"nlist": 128, "encoder": {...}}@) and is +-- therefore kept as an opaque 'Value'. The @space_type@ may be set here or +-- at the top level of 'KnnTrainingRequest'; the two are alternative +-- locations for the same field. +data KnnTrainingMethod = KnnTrainingMethod + { knnTrainingMethodName :: Text, + knnTrainingMethodEngine :: OpenSearchKnnEngine, + knnTrainingMethodSpaceType :: Maybe Text, + knnTrainingMethodParameters :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON KnnTrainingMethod where + parseJSON = withObject "KnnTrainingMethod" $ \v -> do + knnTrainingMethodName <- v .: "name" + knnTrainingMethodEngine <- v .: "engine" + knnTrainingMethodSpaceType <- v .:? "space_type" + knnTrainingMethodParameters <- v .:? "parameters" + pure KnnTrainingMethod {..} + +instance ToJSON KnnTrainingMethod where + toJSON KnnTrainingMethod {..} = + omitNulls + [ "name" .= knnTrainingMethodName, + "engine" .= knnTrainingMethodEngine, + "space_type" .= knnTrainingMethodSpaceType, + "parameters" .= knnTrainingMethodParameters + ] + +-- | Request body for @POST /_plugins/_knn/models/{model_id}/_train@. The +-- first four fields are required by the plugin and serialized unconditionally; +-- the remaining four are 'Maybe' and omitted by 'omitNulls' when 'Nothing'. +data KnnTrainingRequest = KnnTrainingRequest + { knnTrainingRequestIndex :: IndexName, + knnTrainingRequestField :: FieldName, + knnTrainingRequestDimension :: Int, + knnTrainingRequestMethod :: KnnTrainingMethod, + knnTrainingRequestSpaceType :: Maybe Text, + knnTrainingRequestMaxTrainingVectorCount :: Maybe Int, + knnTrainingRequestSearchSize :: Maybe Int, + knnTrainingRequestDescription :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON KnnTrainingRequest where + parseJSON = withObject "KnnTrainingRequest" $ \v -> do + knnTrainingRequestIndex <- v .: "training_index" + knnTrainingRequestField <- v .: "training_field" + knnTrainingRequestDimension <- v .: "dimension" + knnTrainingRequestMethod <- v .: "method" + knnTrainingRequestSpaceType <- v .:? "space_type" + knnTrainingRequestMaxTrainingVectorCount <- v .:? "max_training_vector_count" + knnTrainingRequestSearchSize <- v .:? "search_size" + knnTrainingRequestDescription <- v .:? "description" + pure KnnTrainingRequest {..} + +instance ToJSON KnnTrainingRequest where + toJSON KnnTrainingRequest {..} = + omitNulls + [ "training_index" .= knnTrainingRequestIndex, + "training_field" .= knnTrainingRequestField, + "dimension" .= knnTrainingRequestDimension, + "method" .= knnTrainingRequestMethod, + "space_type" .= knnTrainingRequestSpaceType, + "max_training_vector_count" .= knnTrainingRequestMaxTrainingVectorCount, + "search_size" .= knnTrainingRequestSearchSize, + "description" .= knnTrainingRequestDescription + ] + +-- | Response of @POST /_plugins/_knn/models/{model_id}/_train@. The body is +-- a bare object echoing the model id under which training was scheduled. +-- The field is the only one the endpoint ever returns; to observe training +-- progress, poll @GET /_plugins/_knn/models/{model_id}@ (decoded as +-- 'Database.Bloodhound.Internal.Versions.OpenSearch3.Types.KnnModel.KnnModel'). +newtype KnnTrainResponse = KnnTrainResponse + { knnTrainResponseModelId :: Text + } + deriving stock (Eq, Show) + +instance FromJSON KnnTrainResponse where + parseJSON = withObject "KnnTrainResponse" $ \v -> + KnnTrainResponse <$> v .: "model_id" + +instance ToJSON KnnTrainResponse where + toJSON KnnTrainResponse {..} = + object ["model_id" .= knnTrainResponseModelId] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLAgent.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLAgent.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLAgent.hs @@ -0,0 +1,811 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLAgent + ( AgentId (..), + AgentType (..), + LlmConfig (..), + MemoryConfig (..), + ToolConfig (..), + ToolInlineConfig (..), + RegisterAgentRequest (..), + RegisterAgentResponse (..), + UpdateAgentRequest (..), + ExecuteAgentRequest (..), + ExecuteAgentResponse (..), + InferenceResult (..), + ExecuteOutput (..), + AgUIEvent (..), + ExecuteStreamChunk (..), + isStreamChunkLast, + AgentInfo (..), + AgentShards (..), + AgentTotal (..), + AgentTotalRelation (..), + AgentHit (..), + AgentSearchResponse (..), + emptyAgentSearchResponse, + ) +where + +import Data.Aeson.KeyMap qualified as KM +import Data.Int (Int64) +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The ML Commons agent APIs (see +-- ) +-- cover agentic orchestration on top of deployed models: an agent binds a +-- large-language model (or a routed population of sub-agents and tools) +-- behind a registered @agent_id@ that the Conversational / Agentic APIs +-- invoke. +-- +-- Unlike the model register endpoint, agent registration is +-- /synchronous/: the POST persists a single config document in the +-- @.plugins-ml-agent@ system index and returns +-- @{"agent_id": "..."}@ directly — no @task_id@ to poll. The response is +-- therefore modelled here as 'RegisterAgentResponse', not 'MLTaskAck'. +-- +-- The agent request body is intentionally permissive +-- ('RegisterAgentRequest'): the four documented agent shapes (flow, +-- conversation, router\/coordinator, template) reuse the same fields in +-- different combinations, and the plugin adds new tool @type@s across +-- releases, so 'rarLlm' \/ 'rarTools' \/ 'rarParameters' carry the +-- open-ended parts as structured-but-tolerant records or opaque 'Value's +-- rather than a closed sum. + +-- | An agent ID for the @\/_plugins\/_ml\/agents\/{agent_id}@ path segment +-- and the @agent_id@ field returned by register. The value is assigned by +-- the server. Wrapped 'Text' so it round-trips as a bare JSON string but +-- is distinct from 'ModelId' at the type level. +newtype AgentId = AgentId {unAgentId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The agent kind, as required by the @type@ field of +-- 'RegisterAgentRequest'. The spec-documented values +-- () +-- are 'AgentTypeFlow', 'AgentTypeConversational', +-- 'AgentTypeConversationalFlow' and 'AgentTypePlanExecuteAndReflect'. +-- 'AgentTypeRouter', 'AgentTypeCoordinator', 'AgentTypeTemplate' and +-- 'AgentTypeManual' cover the historically documented agent kinds that +-- older OpenSearch 2.x releases accept. Any other value decodes to +-- 'AgentTypeOther' rather than failing, so a future plugin release +-- adding a new kind (or a cluster storing the legacy misspelling +-- @\"conversation\"@) round-trips instead of throwing — matching the +-- 'AgentTotalRelation' precedent. +data AgentType + = AgentTypeFlow + | AgentTypeConversational + | AgentTypeConversationalFlow + | AgentTypePlanExecuteAndReflect + | AgentTypeRouter + | AgentTypeCoordinator + | AgentTypeTemplate + | AgentTypeManual + | AgentTypeOther Text + deriving stock (Eq, Show) + +agentTypeText :: AgentType -> Text +agentTypeText = \case + AgentTypeFlow -> "flow" + AgentTypeConversational -> "conversational" + AgentTypeConversationalFlow -> "conversational_flow" + AgentTypePlanExecuteAndReflect -> "plan_execute_and_reflect" + AgentTypeRouter -> "router" + AgentTypeCoordinator -> "coordinator" + AgentTypeTemplate -> "template" + AgentTypeManual -> "manual" + AgentTypeOther t -> t + +instance ToJSON AgentType where + toJSON = toJSON . agentTypeText + +instance FromJSON AgentType where + parseJSON = withText "AgentType" $ \t -> + pure $ + case t of + "flow" -> AgentTypeFlow + "conversational" -> AgentTypeConversational + "conversational_flow" -> AgentTypeConversationalFlow + "plan_execute_and_reflect" -> AgentTypePlanExecuteAndReflect + "router" -> AgentTypeRouter + "coordinator" -> AgentTypeCoordinator + "template" -> AgentTypeTemplate + "manual" -> AgentTypeManual + other -> AgentTypeOther other + +-- | The @llm@ binding for a flow or conversation agent. @model_id@ must +-- reference a deployed model (or a remote connector) registered via +-- @POST /_plugins/_ml/models/_register@; @parameters@ is the opaque +-- default parameter map forwarded to the model on every call (e.g. +-- @temperature@, @context_size@) — typed as 'Value' because the schema is +-- model-defined and heterogeneous across algorithms. +data LlmConfig = LlmConfig + { llmConfigModelId :: Text, + llmConfigParameters :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON LlmConfig where + parseJSON = withObject "LlmConfig" $ \v -> do + llmConfigModelId <- v .: "model_id" + llmConfigParameters <- v .:? "parameters" + pure LlmConfig {..} + +instance ToJSON LlmConfig where + toJSON LlmConfig {..} = + omitNulls + [ "model_id" .= llmConfigModelId, + "parameters" .= llmConfigParameters + ] + +-- | The @memory@ binding for a conversation agent. @type@ is currently +-- the only documented discriminator (value @conversation@); the remaining +-- configuration (e.g. @session_max_size@) is forwarded as an opaque +-- 'Value' pending wider plugin coverage. +data MemoryConfig = MemoryConfig + { memoryConfigType :: Text, + memoryConfigParameters :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON MemoryConfig where + parseJSON = withObject "MemoryConfig" $ \v -> do + memoryConfigType <- v .: "type" + memoryConfigParameters <- v .:? "parameters" + pure MemoryConfig {..} + +instance ToJSON MemoryConfig where + toJSON MemoryConfig {..} = + omitNulls + [ "type" .= memoryConfigType, + "parameters" .= memoryConfigParameters + ] + +-- | A single @tools@ entry. The ML Commons API accepts two wire shapes +-- for each element: a bare tool @type@ string (e.g. +-- @\"CatIndexTool\"@), or an inline object that adds per-invocation +-- @parameters@ and an optional @description@. Both round-trip through +-- this sum type so callers can use the shorthand for parameterless tools +-- and the full record for configured ones. +data ToolConfig + = ToolConfigNamed Text + | ToolConfigInline ToolInlineConfig + deriving stock (Eq, Show) + +instance FromJSON ToolConfig where + parseJSON = \case + String t -> pure (ToolConfigNamed t) + o@(Object _) -> ToolConfigInline <$> parseJSON o + other -> typeMismatch "ToolConfig (string or object)" other + +instance ToJSON ToolConfig where + toJSON = \case + ToolConfigNamed t -> toJSON t + ToolConfigInline c -> toJSON c + +-- | The object form of a 'ToolConfig' entry. @type@ is the tool kind +-- (e.g. @VectorDBTool@, @AgentTool@, @CatIndexTool@); @parameters@ is the +-- opaque default parameter map (typed as 'Value' because tool parameters +-- are plugin-defined and heterogeneous); @description@ is the optional +-- human-readable note surfaced in trace output. +data ToolInlineConfig = ToolInlineConfig + { toolInlineConfigType :: Text, + toolInlineConfigParameters :: Maybe Value, + toolInlineConfigDescription :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ToolInlineConfig where + parseJSON = withObject "ToolInlineConfig" $ \v -> do + toolInlineConfigType <- v .: "type" + toolInlineConfigParameters <- v .:? "parameters" + toolInlineConfigDescription <- v .:? "description" + pure ToolInlineConfig {..} + +instance ToJSON ToolInlineConfig where + toJSON ToolInlineConfig {..} = + omitNulls + [ "type" .= toolInlineConfigType, + "parameters" .= toolInlineConfigParameters, + "description" .= toolInlineConfigDescription + ] + +-- | Request body for @POST /_plugins/_ml/agents/_register@. @name@ and +-- @type@ are required; every other field is conditionally present +-- depending on the agent kind (conversation agents carry @llm@ and +-- optionally @memory@; router\/coordinator agents carry @tools@; +-- template agents carry @app_type@). The request is sent verbatim; +-- OpenSearch validates the combination and returns HTTP 400 for +-- nonsensical request shapes (e.g. a @conversation@ agent with no +-- @llm@). +data RegisterAgentRequest = RegisterAgentRequest + { registerAgentName :: Text, + registerAgentType :: AgentType, + registerAgentDescription :: Maybe Text, + registerAgentLlm :: Maybe LlmConfig, + registerAgentTools :: Maybe [ToolConfig], + registerAgentParameters :: Maybe Value, + registerAgentMemory :: Maybe MemoryConfig, + registerAgentAppType :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RegisterAgentRequest where + parseJSON = withObject "RegisterAgentRequest" $ \v -> do + registerAgentName <- v .: "name" + registerAgentType <- v .: "type" + registerAgentDescription <- v .:? "description" + registerAgentLlm <- v .:? "llm" + registerAgentTools <- v .:? "tools" + registerAgentParameters <- v .:? "parameters" + registerAgentMemory <- v .:? "memory" + registerAgentAppType <- v .:? "app_type" + pure RegisterAgentRequest {..} + +instance ToJSON RegisterAgentRequest where + toJSON RegisterAgentRequest {..} = + omitNulls + [ "name" .= registerAgentName, + "type" .= registerAgentType, + "description" .= registerAgentDescription, + "llm" .= registerAgentLlm, + "tools" .= registerAgentTools, + "parameters" .= registerAgentParameters, + "memory" .= registerAgentMemory, + "app_type" .= registerAgentAppType + ] + +-- | Response of @POST /_plugins/_ml/agents/_register@. The body is a bare +-- object carrying the server-assigned @agent_id@ of the newly +-- registered agent. Registration is synchronous, so — unlike +-- 'MLTaskAck' — there is no @task_id@ to poll: the agent is callable +-- immediately (subject to its bound model being deployed). +newtype RegisterAgentResponse = RegisterAgentResponse + { registerAgentResponseAgentId :: AgentId + } + deriving stock (Eq, Show) + +instance FromJSON RegisterAgentResponse where + parseJSON = withObject "RegisterAgentResponse" $ \v -> do + registerAgentResponseAgentId <- v .: "agent_id" + pure RegisterAgentResponse {..} + +instance ToJSON RegisterAgentResponse where + toJSON (RegisterAgentResponse agentId) = + object ["agent_id" .= agentId] + +-- | Request body for @PUT /_plugins/_ml/agents/{agent_id}@ (the Update +-- Agent API, introduced in OpenSearch 3.1). Every field is 'Maybe' +-- because the update is a partial write: only the supplied fields are +-- patched onto the stored agent document, and 'Nothing' fields are +-- dropped on encode (via 'omitNulls'). The field set is the subset of +-- 'RegisterAgentRequest' fields the docs mark as updatable +-- (): +-- @name@, @description@, @tools@, @app_type@, @memory.type@ and the +-- @llm@ binding (@llm.model_id@ and the documented @llm.parameters@ +-- keys). The @type@ field itself is /not/ updatable (an agent's kind +-- is fixed at registration time), so this record has no +-- @updateAgentType@. +-- +-- The @tools@ / @memory@ / @llm@ sub-objects reuse the registration +-- types ('ToolConfig', 'MemoryConfig', 'LlmConfig') verbatim: the +-- update wire shape for each is identical to its registration +-- counterpart, so callers can build the partial update with the same +-- constructors. +data UpdateAgentRequest = UpdateAgentRequest + { updateAgentName :: Maybe Text, + updateAgentDescription :: Maybe Text, + updateAgentTools :: Maybe [ToolConfig], + updateAgentAppType :: Maybe Text, + updateAgentMemory :: Maybe MemoryConfig, + updateAgentLlm :: Maybe LlmConfig + } + deriving stock (Eq, Show) + +instance FromJSON UpdateAgentRequest where + parseJSON = withObject "UpdateAgentRequest" $ \v -> do + updateAgentName <- v .:? "name" + updateAgentDescription <- v .:? "description" + updateAgentTools <- v .:? "tools" + updateAgentAppType <- v .:? "app_type" + updateAgentMemory <- v .:? "memory" + updateAgentLlm <- v .:? "llm" + pure UpdateAgentRequest {..} + +instance ToJSON UpdateAgentRequest where + toJSON UpdateAgentRequest {..} = + omitNulls + [ "name" .= updateAgentName, + "description" .= updateAgentDescription, + "tools" .= updateAgentTools, + "app_type" .= updateAgentAppType, + "memory" .= updateAgentMemory, + "llm" .= updateAgentLlm + ] + +-- | Request body for @POST /_plugins/_ml/agents/{agent_id}/_execute@ +-- (the Execute Agent API, introduced in OpenSearch 2.13). The body is +-- intentionally permissive: @parameters@ is an opaque 'Value' map (the +-- regular-registration method reads keys like @question@, @verbose@, +-- @memory_id@, @memory_container_id@, @include_token_usage@ — the set +-- grows across plugin releases and varies by agent kind), and @input@ +-- is the unified-registration entry point whose wire shape is +-- polymorphic (a plain 'String' for text, an 'Array' of content blocks +-- for multimodal, or an 'Array' of message objects for +-- conversations). Carrying both as 'Value' — rather than a closed sum +-- — keeps the type forward-compatible with future plugin releases and +-- matches the precedent set by 'predict' and 'searchAgents'. +-- +-- Both fields are optional: a bare @{}@ body is a legal execute +-- request for an agent whose configuration supplies defaults. +-- 'omitNulls' on encode means an unset field is omitted rather than +-- sent as @null@. +data ExecuteAgentRequest = ExecuteAgentRequest + { executeAgentParameters :: Maybe Value, + executeAgentInput :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON ExecuteAgentRequest where + parseJSON = withObject "ExecuteAgentRequest" $ \v -> do + executeAgentParameters <- v .:? "parameters" + executeAgentInput <- v .:? "input" + pure ExecuteAgentRequest {..} + +instance ToJSON ExecuteAgentRequest where + toJSON ExecuteAgentRequest {..} = + omitNulls + [ "parameters" .= executeAgentParameters, + "input" .= executeAgentInput + ] + +-- | Response of @POST /_plugins/_ml/agents/{agent_id}/_execute@. The +-- body is the @inference_results@ array; each element carries an +-- @output@ list whose entries are discriminated by their @name@ field +-- (@response@, @memory_id@, @parent_interaction_id@, @token_usage@). +-- Each output carries /either/ a @result@ (a bare string, present for +-- the @response@\/@memory_id@\/@parent_interaction_id@ names) /or/ a +-- @dataAsMap@ (a structured object, present for the @response@ name on +-- @conversational_v2@ agents and for @token_usage@). The two payload +-- shapes are kept as 'Maybe' on a single record (rather than a sum +-- type) so an unknown @name@ with either shape decodes cleanly — +-- matching the 'AgentInfo' forward-compatibility precedent. +-- See . +newtype ExecuteAgentResponse = ExecuteAgentResponse + { executeAgentInferenceResults :: [InferenceResult] + } + deriving stock (Eq, Show) + +instance FromJSON ExecuteAgentResponse where + parseJSON = withObject "ExecuteAgentResponse" $ \v -> do + executeAgentInferenceResults <- v .:? "inference_results" .!= [] + pure ExecuteAgentResponse {..} + +instance ToJSON ExecuteAgentResponse where + toJSON ExecuteAgentResponse {..} = + object ["inference_results" .= executeAgentInferenceResults] + +-- | A single element of @inference_results[]@. The wire object only +-- ever carries the @output@ array; future plugin releases adding keys +-- here would be dropped on round-trip (acceptable — the typed surface +-- is the @output@ list). +newtype InferenceResult = InferenceResult + { inferenceResultOutput :: [ExecuteOutput] + } + deriving stock (Eq, Show) + +instance FromJSON InferenceResult where + parseJSON = withObject "InferenceResult" $ \v -> do + inferenceResultOutput <- v .:? "output" .!= [] + pure InferenceResult {..} + +instance ToJSON InferenceResult where + toJSON InferenceResult {..} = + object ["output" .= inferenceResultOutput] + +-- | A single entry in an 'InferenceResult'\'s @output@ list. The +-- @name@ discriminator ('executeOutputName') selects the payload kind: +-- +-- [@response@] either a 'executeOutputResult' string (regular and +-- message-based agents) or an 'executeOutputDataAsMap' object +-- (@conversational_v2@ agents, where it carries @stop_reason@, +-- @message@, @memory_id@, @metrics@). +-- [@memory_id@ \/ @parent_interaction_id@] always a +-- 'executeOutputResult' string. +-- [@token_usage@] an 'executeOutputDataAsMap' object (per-turn and +-- per-model token usage arrays), emitted only when the request set +-- @include_token_usage: true@. +-- +-- The record tolerates both payloads being absent (an output with +-- neither key decodes to 'Nothing' \/ 'Nothing'), and both being +-- present (the server does not do this, but the decoder does not +-- enforce mutual exclusion). +data ExecuteOutput = ExecuteOutput + { executeOutputName :: Maybe Text, + executeOutputResult :: Maybe Text, + executeOutputDataAsMap :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON ExecuteOutput where + parseJSON = withObject "ExecuteOutput" $ \v -> do + executeOutputName <- v .:? "name" + executeOutputResult <- v .:? "result" + executeOutputDataAsMap <- v .:? "dataAsMap" + pure ExecuteOutput {..} + +instance ToJSON ExecuteOutput where + toJSON ExecuteOutput {..} = + omitNulls + [ "name" .= executeOutputName, + "result" .= executeOutputResult, + "dataAsMap" .= executeOutputDataAsMap + ] + +-- ========================================================================= +-- Execute Stream Agent (POST .../{id}/_execute/stream, OS 3.3+) +-- ========================================================================= +-- +-- The streaming endpoint emits one Server-Sent Event per chunk. The +-- per-chunk JSON shape depends on the agent family: +-- +-- [@conversational@ agents] each chunk is the same +-- 'ExecuteAgentResponse' envelope (@inference_results.output[]@) +-- alongside a per-chunk @response.dataAsMap.is_last@ flag. The +-- stream terminates when a chunk carries @is_last: true@. +-- +-- [@AG-UI@ agents (3.5+)] each chunk is a flat object discriminated +-- by a @type@ field (@RUN_STARTED@, @TEXT_MESSAGE_START@, ..., +-- @RUN_FINISHED@). The stream terminates on @RUN_FINISHED@. +-- +-- See . + +-- | A decoded chunk of the conversational-agent stream. This is the +-- regular 'ExecuteAgentResponse' payload paired with the per-chunk +-- @is_last@ flag (extracted from the @response@ output's +-- @dataAsMap@). Use 'isStreamChunkLast' to test for the terminator. +data ExecuteStreamChunk = ExecuteStreamChunk + { executeStreamChunkPayload :: ExecuteAgentResponse, + executeStreamChunkIsLast :: Bool + } + deriving stock (Eq, Show) + +-- | 'True' when the chunk is the terminal one for its stream (the +-- conversational agent emits a final empty-content chunk with +-- @is_last: true@). The streaming source stops after yielding a chunk +-- for which this is 'True'. +isStreamChunkLast :: ExecuteStreamChunk -> Bool +isStreamChunkLast = executeStreamChunkIsLast + +-- | One event of the AG-UI protocol stream. The documented event set +-- is @RUN_STARTED@, @TEXT_MESSAGE_START@, @TEXT_MESSAGE_CONTENT@, +-- @TEXT_MESSAGE_END@, @RUN_FINISHED@; the 'AgUIOther' constructor is +-- an escape hatch for event types the plugin adds in future releases +-- (mirroring the 'AgentTypeOther'\/'AgentTotalRelationOther' +-- precedent), carrying the raw @type@ string and the verbatim JSON +-- object so unknown events round-trip rather than throwing. +-- See +-- and the AG-UI protocol spec. +data AgUIEvent + = AgUIRunStarted {agUIRunStartedTimestamp :: Int64, agUIRunStartedThreadId :: Text, agUIRunStartedRunId :: Text} + | AgUITextMessageStart {agUITextMessageStartTimestamp :: Int64, agUITextMessageStartMessageId :: Text, agUITextMessageStartRole :: Text} + | AgUITextMessageContent {agUITextMessageContentTimestamp :: Int64, agUITextMessageContentMessageId :: Text, agUITextMessageContentDelta :: Text} + | AgUITextMessageEnd {agUITextMessageEndTimestamp :: Int64, agUITextMessageEndMessageId :: Text} + | AgUIRunFinished {agUIRunFinishedTimestamp :: Int64, agUIRunFinishedThreadId :: Text, agUIRunFinishedRunId :: Text} + | AgUIOther {agUIEventType :: Text, agUIEventFields :: Value} + deriving stock (Eq, Show) + +instance FromJSON AgUIEvent where + parseJSON = withObject "AgUIEvent" $ \v -> do + typ <- v .: "type" + case typ :: Text of + "RUN_STARTED" -> + AgUIRunStarted + <$> v .: "timestamp" + <*> v .: "threadId" + <*> v .: "runId" + "TEXT_MESSAGE_START" -> + AgUITextMessageStart + <$> v .: "timestamp" + <*> v .: "messageId" + <*> v .:? "role" .!= "assistant" + "TEXT_MESSAGE_CONTENT" -> + AgUITextMessageContent + <$> v .: "timestamp" + <*> v .: "messageId" + <*> v .: "delta" + "TEXT_MESSAGE_END" -> + AgUITextMessageEnd + <$> v .: "timestamp" + <*> v .: "messageId" + "RUN_FINISHED" -> + AgUIRunFinished + <$> v .: "timestamp" + <*> v .: "threadId" + <*> v .: "runId" + _ -> pure (AgUIOther typ (Object v)) + +instance ToJSON AgUIEvent where + toJSON = \case + AgUIRunStarted ts tid rid -> + object ["type" .= ("RUN_STARTED" :: Text), "timestamp" .= ts, "threadId" .= tid, "runId" .= rid] + AgUITextMessageStart ts mid role -> + object ["type" .= ("TEXT_MESSAGE_START" :: Text), "timestamp" .= ts, "messageId" .= mid, "role" .= role] + AgUITextMessageContent ts mid delta -> + object ["type" .= ("TEXT_MESSAGE_CONTENT" :: Text), "timestamp" .= ts, "messageId" .= mid, "delta" .= delta] + AgUITextMessageEnd ts mid -> + object ["type" .= ("TEXT_MESSAGE_END" :: Text), "timestamp" .= ts, "messageId" .= mid] + AgUIRunFinished ts tid rid -> + object ["type" .= ("RUN_FINISHED" :: Text), "timestamp" .= ts, "threadId" .= tid, "runId" .= rid] + AgUIOther typ fields -> + case fields of + Object o -> Object (KM.insert "type" (toJSON typ) o) + _ -> object ["type" .= typ, "fields" .= fields] + +-- | Response of @GET /_plugins/_ml/agents/{agent_id}@. The body is +-- the bare stored agent document (no envelope, no @_source@ wrapper). +-- Every field is 'Maybe' because the agent kind determines which +-- fields are present (a @flow@ agent carries @tools@, a +-- @conversation@ agent carries @llm@ and optionally @memory@, a +-- @template@ agent carries @app_type@). The @agent_id@ is not in the +-- body for the GET-by-id endpoint; for search hits, the @agent_id@ +-- surfaces as the hit's @_id@ rather than as a body field. +-- +-- The 'agentInfoOther' field captures the *entire* source object +-- verbatim on decode (via @pure (Object o)@). On encode, +-- 'mergeIgnoringNulls' overlays the typed fields on top of this +-- captured object, dropping @null@ values, so typed fields are +-- re-serialized under their typed form while any unknown key (forward +-- compatibility: future plugin releases adding new fields) round-trips +-- untouched. Callers constructing an 'AgentInfo' directly should set +-- 'agentInfoOther' to @Object mempty@ (or @object []@) to opt into +-- this merge behaviour; a non-'Object' value short-circuits the merge +-- and falls back to 'omitNulls' over the typed fields alone. +-- See . +data AgentInfo = AgentInfo + { agentInfoName :: Maybe Text, + agentInfoType :: Maybe AgentType, + agentInfoDescription :: Maybe Text, + agentInfoLlm :: Maybe LlmConfig, + agentInfoTools :: Maybe [ToolConfig], + agentInfoParameters :: Maybe Value, + agentInfoMemory :: Maybe MemoryConfig, + agentInfoAppType :: Maybe Text, + agentInfoCreatedTime :: Maybe Int64, + agentInfoLastUpdatedTime :: Maybe Int64, + agentInfoUser :: Maybe Value, + agentInfoOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON AgentInfo where + parseJSON = withObject "AgentInfo" $ \o -> + AgentInfo + <$> o .:? "name" + <*> o .:? "type" + <*> o .:? "description" + <*> o .:? "llm" + <*> o .:? "tools" + <*> o .:? "parameters" + <*> o .:? "memory" + <*> o .:? "app_type" + <*> o .:? "created_time" + <*> o .:? "last_updated_time" + <*> o .:? "user" + <*> pure (Object o) + +instance ToJSON AgentInfo where + toJSON a = + case agentInfoOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= agentInfoName a, + "type" .= agentInfoType a, + "description" .= agentInfoDescription a, + "llm" .= agentInfoLlm a, + "tools" .= agentInfoTools a, + "parameters" .= agentInfoParameters a, + "memory" .= agentInfoMemory a, + "app_type" .= agentInfoAppType a, + "created_time" .= agentInfoCreatedTime a, + "last_updated_time" .= agentInfoLastUpdatedTime a, + "user" .= agentInfoUser a + ] + +-- | Overlay the typed key-value pairs on top of a captured object, +-- dropping any @null@ values so partial-update round-trips stay +-- minimal. Mirrors the Security Analytics merge helper. +mergeIgnoringNulls :: [(Key, Value)] -> Object -> Object +mergeIgnoringNulls kvs o = + foldr (\(k, v) acc -> if v == Null then acc else KM.insert k v acc) o kvs + +-- | The @hits.total.relation@ discriminator on an agent search +-- response. Mirrors the Security Analytics 'SARulesTotalRelation' +-- precedent. +data AgentTotalRelation + = AgentTotalRelationEq + | AgentTotalRelationGe + | AgentTotalRelationOther Text + deriving stock (Eq, Show) + +agentTotalRelationText :: AgentTotalRelation -> Text +agentTotalRelationText = \case + AgentTotalRelationEq -> "eq" + AgentTotalRelationGe -> "ge" + AgentTotalRelationOther t -> t + +instance ToJSON AgentTotalRelation where + toJSON = toJSON . agentTotalRelationText + +instance FromJSON AgentTotalRelation where + parseJSON = withText "AgentTotalRelation" $ \t -> + pure $ + case t of + "eq" -> AgentTotalRelationEq + "ge" -> AgentTotalRelationGe + other -> AgentTotalRelationOther other + +-- | The @hits.total@ sub-object on an agent search response +-- (@{value, relation}@). +data AgentTotal = AgentTotal + { agentTotalValue :: Int64, + agentTotalRelation :: AgentTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON AgentTotal where + parseJSON = withObject "AgentTotal" $ \o -> + AgentTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON AgentTotal where + toJSON AgentTotal {..} = + object + [ "value" .= agentTotalValue, + "relation" .= agentTotalRelation + ] + +-- | The @_shards@ sub-object on an agent search response. Defined +-- locally under an @Agent@ prefix (mirroring the 'SARulesShards' and +-- 'ModelShards' precedent) rather than re-using the cluster-level +-- 'ShardsResult' envelope, which wraps the outer +-- @{\"_shards\": {...}}@ shape — one level too high for inline use +-- here. +data AgentShards = AgentShards + { agentShardsTotal :: Int, + agentShardsSuccessful :: Int, + agentShardsSkipped :: Int, + agentShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON AgentShards where + parseJSON = withObject "AgentShards" $ \o -> + AgentShards + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "skipped" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON AgentShards where + toJSON AgentShards {..} = + object + [ "total" .= agentShardsTotal, + "successful" .= agentShardsSuccessful, + "skipped" .= agentShardsSkipped, + "failed" .= agentShardsFailed + ] + +-- | A single hit in @hits.hits[]@ on an agent search response. Note: +-- the agent's @agent_id@ surfaces as the hit's @_id@, not as a field +-- inside @_source@ (see 'AgentInfo'). +data AgentHit = AgentHit + { agentHitIndex :: Maybe Text, + agentHitId :: Text, + agentHitVersion :: Maybe Int64, + agentHitSeqNo :: Maybe Int64, + agentHitPrimaryTerm :: Maybe Int64, + agentHitScore :: Maybe Double, + agentHitSource :: AgentInfo + } + deriving stock (Eq, Show) + +instance FromJSON AgentHit where + parseJSON = withObject "AgentHit" $ \o -> + AgentHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON AgentHit where + toJSON AgentHit {..} = + omitNulls + [ "_index" .= agentHitIndex, + "_id" .= agentHitId, + "_version" .= agentHitVersion, + "_seq_no" .= agentHitSeqNo, + "_primary_term" .= agentHitPrimaryTerm, + "_score" .= agentHitScore, + "_source" .= agentHitSource + ] + +-- | Response envelope for @POST /_plugins/_ml/agents/_search@. +-- Decoded verbatim from the standard OpenSearch search-response +-- shape; the paging metadata (@took@, @timed_out@, @_shards@, +-- @hits.total@, @hits.max_score@) is preserved alongside the agent +-- list so callers can drive pagination and observe shard health. +data AgentSearchResponse = AgentSearchResponse + { agentSearchResponseTook :: Int64, + agentSearchResponseTimedOut :: Bool, + agentSearchResponseShards :: AgentShards, + agentSearchResponseTotal :: AgentTotal, + agentSearchResponseMaxScore :: Maybe Double, + agentSearchResponseHits :: [AgentHit] + } + deriving stock (Eq, Show) + +instance FromJSON AgentSearchResponse where + parseJSON = withObject "AgentSearchResponse" $ \o -> do + hits <- o .: "hits" + AgentSearchResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON AgentSearchResponse where + toJSON AgentSearchResponse {..} = + object + [ "took" .= agentSearchResponseTook, + "timed_out" .= agentSearchResponseTimedOut, + "_shards" .= agentSearchResponseShards, + "hits" + .= object + [ "total" .= agentSearchResponseTotal, + "max_score" .= agentSearchResponseMaxScore, + "hits" .= agentSearchResponseHits + ] + ] + +-- | An 'AgentSearchResponse' with zero hits and neutral metadata, used +-- as the synthetic result when the @.plugins-ml-agent@ system index +-- does not yet exist (OpenSearch returns HTTP 404 +-- @index_not_found_exception@ in that case rather than an empty search +-- result). 'Database.Bloodhound.OpenSearch3.Requests.searchAgents' +-- substitutes this for such 404 responses so callers see a uniform +-- @Right emptyResult@ regardless of whether any agent has ever been +-- registered. +emptyAgentSearchResponse :: AgentSearchResponse +emptyAgentSearchResponse = + AgentSearchResponse + { agentSearchResponseTook = 0, + agentSearchResponseTimedOut = False, + agentSearchResponseShards = + AgentShards + { agentShardsTotal = 0, + agentShardsSuccessful = 0, + agentShardsSkipped = 0, + agentShardsFailed = 0 + }, + agentSearchResponseTotal = + AgentTotal + { agentTotalValue = 0, + agentTotalRelation = AgentTotalRelationEq + }, + agentSearchResponseMaxScore = Nothing, + agentSearchResponseHits = [] + } diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLConnectors.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLConnectors.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLConnectors.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLConnectors + ( ConnectorId (..), + ConnectorProtocol (..), + MLConnectorAction (..), + CreateConnectorRequest (..), + CreateConnectorResponse (..), + UpdateConnectorRequest (..), + ConnectorInfo (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value, withObject, withText, (.:), (.:?), (.=)) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) + +-- $schema +-- +-- The ML Commons connector APIs (see +-- , +-- introduced in OS 2.12) manage remote-model connectors — the bridge +-- between ML Commons and an external model service (OpenAI, Bedrock, +-- SageMaker, ...). A connector bundles default @parameters@, encrypted +-- @credential@ variables, and one or more @actions@ (HTTP request +-- templates, typically a @predict@ action). +-- +-- /Wire quirks honoured below:/ +-- +-- * @credential@ is write-only: accepted on create\/update but never +-- returned by get\/search, so it is absent from 'ConnectorInfo'. +-- * @version@ is sent as a JSON number but echoed back as a JSON string +-- on get\/search; the request uses 'Int' and the response uses 'Text'. +-- * Deletes are idempotent: a missing connector returns HTTP 200 with +-- @result = "not_found"@ rather than a 404. + +-- | A connector identifier for the +-- @\/_plugins\/_ml\/connectors\/{connector_id}@ path segment, assigned +-- by the server on create. +newtype ConnectorId = ConnectorId {unConnectorId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @protocol@ enum on a connector. The plugin currently documents +-- two values; unknown values decode to 'ConnectorProtocolOther' for +-- forward compatibility. +data ConnectorProtocol + = ConnectorProtocolHttp + | ConnectorProtocolAwsSigv4 + | ConnectorProtocolOther Text + deriving stock (Eq, Show) + +connectorProtocolText :: ConnectorProtocol -> Text +connectorProtocolText = \case + ConnectorProtocolHttp -> "http" + ConnectorProtocolAwsSigv4 -> "aws_sigv4" + ConnectorProtocolOther t -> t + +instance ToJSON ConnectorProtocol where + toJSON = toJSON . connectorProtocolText + +instance FromJSON ConnectorProtocol where + parseJSON = withText "ConnectorProtocol" $ \t -> + pure $ + case t of + "http" -> ConnectorProtocolHttp + "aws_sigv4" -> ConnectorProtocolAwsSigv4 + other -> ConnectorProtocolOther other + +-- | One entry in a connector's @actions@ array: an HTTP request template +-- (typically the @predict@ action). @url@, @headers@, and +-- @request_body@ carry @${parameters.*}@ / @${credential.*}@ template +-- references resolved by the plugin at invoke time, so they are kept as +-- opaque 'Text' \/ 'Value'. The optional @pre_process_function@ and +-- @post_process_function@ are Painless script strings run before\/after +-- the HTTP call. +data MLConnectorAction = MLConnectorAction + { mlConnectorActionType :: Text, + mlConnectorActionMethod :: Maybe Text, + mlConnectorActionUrl :: Maybe Text, + mlConnectorActionHeaders :: Maybe Value, + mlConnectorActionRequestBody :: Maybe Text, + mlConnectorActionPreProcessFunction :: Maybe Text, + mlConnectorActionPostProcessFunction :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON MLConnectorAction where + parseJSON = withObject "MLConnectorAction" $ \v -> do + mlConnectorActionType <- v .: "action_type" + mlConnectorActionMethod <- v .:? "method" + mlConnectorActionUrl <- v .:? "url" + mlConnectorActionHeaders <- v .:? "headers" + mlConnectorActionRequestBody <- v .:? "request_body" + mlConnectorActionPreProcessFunction <- v .:? "pre_process_function" + mlConnectorActionPostProcessFunction <- v .:? "post_process_function" + pure MLConnectorAction {..} + +instance ToJSON MLConnectorAction where + toJSON MLConnectorAction {..} = + omitNulls + [ "action_type" .= mlConnectorActionType, + "method" .= mlConnectorActionMethod, + "url" .= mlConnectorActionUrl, + "headers" .= mlConnectorActionHeaders, + "request_body" .= mlConnectorActionRequestBody, + "pre_process_function" .= mlConnectorActionPreProcessFunction, + "post_process_function" .= mlConnectorActionPostProcessFunction + ] + +-- | Request body for @POST /_plugins/_ml/connectors/_create@. @name@, +-- @description@, @version@, and @protocol@ are required by the plugin; +-- @parameters@ and @credential@ are opaque JSON objects (their sub-shape +-- is connector-blueprint-specific and large), and @actions@ is the list +-- of HTTP request templates. The optional access-control fields are only +-- honoured when model access control is enabled cluster-wide. +data CreateConnectorRequest = CreateConnectorRequest + { createConnectorName :: Text, + createConnectorDescription :: Maybe Text, + createConnectorVersion :: Maybe Int, + createConnectorProtocol :: Maybe ConnectorProtocol, + createConnectorParameters :: Maybe Value, + createConnectorCredential :: Maybe Value, + createConnectorActions :: Maybe [MLConnectorAction], + createConnectorBackendRoles :: Maybe [Text], + createConnectorAccessMode :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateConnectorRequest where + parseJSON = withObject "CreateConnectorRequest" $ \v -> do + createConnectorName <- v .: "name" + createConnectorDescription <- v .:? "description" + createConnectorVersion <- v .:? "version" + createConnectorProtocol <- v .:? "protocol" + createConnectorParameters <- v .:? "parameters" + createConnectorCredential <- v .:? "credential" + createConnectorActions <- v .:? "actions" + createConnectorBackendRoles <- v .:? "backend_roles" + createConnectorAccessMode <- v .:? "access_mode" + pure CreateConnectorRequest {..} + +instance ToJSON CreateConnectorRequest where + toJSON CreateConnectorRequest {..} = + omitNulls + [ "name" .= createConnectorName, + "description" .= createConnectorDescription, + "version" .= createConnectorVersion, + "protocol" .= createConnectorProtocol, + "parameters" .= createConnectorParameters, + "credential" .= createConnectorCredential, + "actions" .= createConnectorActions, + "backend_roles" .= createConnectorBackendRoles, + "access_mode" .= createConnectorAccessMode + ] + +-- | Response of @POST /_plugins/_ml/connectors/_create@: +-- @{connector_id}@. +newtype CreateConnectorResponse = CreateConnectorResponse + { createConnectorResponseId :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateConnectorResponse where + parseJSON = withObject "CreateConnectorResponse" $ \v -> do + createConnectorResponseId <- v .:? "connector_id" + pure CreateConnectorResponse {..} + +instance ToJSON CreateConnectorResponse where + toJSON (CreateConnectorResponse mId) = + omitNulls ["connector_id" .= mId] + +-- | Request body for @PUT /_plugins/_ml/connectors/{connector_id}@. All +-- fields are 'Maybe' (partial update); omitted fields are preserved. +-- All models using the connector must be undeployed before updating. +data UpdateConnectorRequest = UpdateConnectorRequest + { updateConnectorName :: Maybe Text, + updateConnectorDescription :: Maybe Text, + updateConnectorVersion :: Maybe Int, + updateConnectorProtocol :: Maybe ConnectorProtocol, + updateConnectorParameters :: Maybe Value, + updateConnectorCredential :: Maybe Value, + updateConnectorActions :: Maybe [MLConnectorAction], + updateConnectorBackendRoles :: Maybe [Text], + updateConnectorAccessMode :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON UpdateConnectorRequest where + parseJSON = withObject "UpdateConnectorRequest" $ \v -> do + updateConnectorName <- v .:? "name" + updateConnectorDescription <- v .:? "description" + updateConnectorVersion <- v .:? "version" + updateConnectorProtocol <- v .:? "protocol" + updateConnectorParameters <- v .:? "parameters" + updateConnectorCredential <- v .:? "credential" + updateConnectorActions <- v .:? "actions" + updateConnectorBackendRoles <- v .:? "backend_roles" + updateConnectorAccessMode <- v .:? "access_mode" + pure UpdateConnectorRequest {..} + +instance ToJSON UpdateConnectorRequest where + toJSON UpdateConnectorRequest {..} = + omitNulls + [ "name" .= updateConnectorName, + "description" .= updateConnectorDescription, + "version" .= updateConnectorVersion, + "protocol" .= updateConnectorProtocol, + "parameters" .= updateConnectorParameters, + "credential" .= updateConnectorCredential, + "actions" .= updateConnectorActions, + "backend_roles" .= updateConnectorBackendRoles, + "access_mode" .= updateConnectorAccessMode + ] + +-- | Response of @GET /_plugins/_ml/connectors/{connector_id}@ and the +-- per-hit @_source@ of @/_plugins/_ml/connectors/_search@. The body is +-- the bare stored connector document (no envelope); @credential@ is +-- never returned. Note @version@ comes back as a string, not a number. +-- @backend_roles@ and @access_mode@ are present when model access +-- control is enabled cluster-wide. +data ConnectorInfo = ConnectorInfo + { connectorInfoName :: Maybe Text, + connectorInfoDescription :: Maybe Text, + connectorInfoVersion :: Maybe Text, + connectorInfoProtocol :: Maybe ConnectorProtocol, + connectorInfoParameters :: Maybe Value, + connectorInfoActions :: Maybe [MLConnectorAction], + connectorInfoBackendRoles :: Maybe [Text], + connectorInfoAccessMode :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ConnectorInfo where + parseJSON = withObject "ConnectorInfo" $ \v -> do + connectorInfoName <- v .:? "name" + connectorInfoDescription <- v .:? "description" + connectorInfoVersion <- v .:? "version" + connectorInfoProtocol <- v .:? "protocol" + connectorInfoParameters <- v .:? "parameters" + connectorInfoActions <- v .:? "actions" + connectorInfoBackendRoles <- v .:? "backend_roles" + connectorInfoAccessMode <- v .:? "access_mode" + pure ConnectorInfo {..} + +instance ToJSON ConnectorInfo where + toJSON ConnectorInfo {..} = + omitNulls + [ "name" .= connectorInfoName, + "description" .= connectorInfoDescription, + "version" .= connectorInfoVersion, + "protocol" .= connectorInfoProtocol, + "parameters" .= connectorInfoParameters, + "actions" .= connectorInfoActions, + "backend_roles" .= connectorInfoBackendRoles, + "access_mode" .= connectorInfoAccessMode + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLControllers.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLControllers.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLControllers.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLControllers + ( ControllerConfig (..), + ControllerCreateResponse (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:?), (.=)) +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as M +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLModel + ( ModelRateLimiter (..), + ) + +-- $schema +-- +-- The ML Commons controller APIs (see +-- , +-- introduced in OS 2.12) enforce per-user rate limits on a deployed +-- model. A controller is keyed by the model's @model_id@ (there is no +-- separate controller id), and its body is a single @user_rate_limiter@ +-- map from username to a @{limit, unit}@ entry. The per-entry shape is +-- identical to the model-level @rate_limiter@ in +-- "Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLModel", so +-- 'ModelRateLimiter' is reused here. +-- +-- /Wire quirk:/ @limit@ is sent as a JSON number but echoed back as a +-- JSON string; the 'ModelRateLimiter' parser already tolerates both +-- shapes (its @limit@ is a stringified-double 'ModelRateLimit'). +-- +-- /Semantics:/ the effective per-user rate limit is the more restrictive +-- of the model-level limit (set via the Update Model API) and the +-- user-level limit set here. + +-- | Request body for @POST@ \/ @PUT +-- /_plugins/_ml/controllers/{model_id}@ and response body of @GET +-- /_plugins/_ml/controllers/{model_id}@. The create response wraps the +-- echoed @model_id@ and a @status@ in 'ControllerCreateResponse' instead. +-- +-- POST overwrites the entire @user_rate_limiter@ map; PUT updates +-- individual user entries, preserving others. +data ControllerConfig = ControllerConfig + { -- | Optional on the request path segment; the plugin keys the stored + -- document by @model_id@ and echoes it back on GET. Omitted when + -- building a create\/update body (the id travels in the URL). + controllerConfigModelId :: Maybe Text, + controllerConfigUserRateLimiter :: M.Map Text ModelRateLimiter + } + deriving stock (Eq, Show) + +instance FromJSON ControllerConfig where + parseJSON = withObject "ControllerConfig" $ \v -> do + controllerConfigModelId <- v .:? "model_id" + mRateLimiter <- v .:? "user_rate_limiter" + let controllerConfigUserRateLimiter = case mRateLimiter of + Nothing -> M.empty + Just o -> M.fromList [(toText k, r) | (k, r) <- KM.toList o] + pure ControllerConfig {..} + +instance ToJSON ControllerConfig where + toJSON ControllerConfig {..} = + omitNulls + [ "model_id" .= controllerConfigModelId, + "user_rate_limiter" + .= object [fromText k .= toJSON v | (k, v) <- M.toList controllerConfigUserRateLimiter] + ] + +-- | Response of @POST /_plugins/_ml/controllers/{model_id}@ (create): +-- @{model_id, status}@, where @status@ is typically @CREATED@. +data ControllerCreateResponse = ControllerCreateResponse + { controllerCreateResponseModelId :: Maybe Text, + controllerCreateResponseStatus :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON ControllerCreateResponse where + parseJSON = withObject "ControllerCreateResponse" $ \v -> do + controllerCreateResponseModelId <- v .:? "model_id" + controllerCreateResponseStatus <- v .:? "status" + pure ControllerCreateResponse {..} + +instance ToJSON ControllerCreateResponse where + toJSON ControllerCreateResponse {..} = + omitNulls + [ "model_id" .= controllerCreateResponseModelId, + "status" .= controllerCreateResponseStatus + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLMemory.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLMemory.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLMemory.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLMemory + ( MemoryId (..), + MessageId (..), + Memory (..), + CreateMemoryRequest (..), + CreateMemoryResponse (..), + DeleteMemoryResponse (..), + ListMemoriesResponse (..), + MemoryMessage (..), + CreateMemoryMessageRequest (..), + CreateMemoryMessageResponse (..), + ListMemoryMessagesResponse (..), + MemoryMessageTraces (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value, withObject, (.!=), (.:?), (.=)) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) + +-- $schema +-- +-- The ML Commons memory APIs (see +-- , +-- introduced in OS 2.12) persist conversational context for ML agents: +-- each 'Memory' is a thread containing 'MemoryMessage's (a human @input@ +-- paired with an AI @response@), and each message may in turn have +-- @traces@ — diagnostic sub-messages recording the agent's intermediate +-- tool calls. +-- +-- /Wire notes honoured below:/ +-- +-- * Timestamps (@create_time@, @updated_time@) are RFC 3339 strings +-- (e.g. @2024-02-02T18:07:06.887061463Z@), not epoch milliseconds, so +-- they are kept as opaque 'Text' rather than parsed to 'UTCTime'. +-- * With the Security plugin enabled, memories and messages are always +-- private to their creator. +-- * Memory delete is /not/ idempotent: a missing memory returns HTTP +-- 404 (unlike connector \/ model-group delete). + +-- | A memory identifier for the +-- @\/_plugins\/_ml\/memory\/{memory_id}@ path segment. +newtype MemoryId = MemoryId {unMemoryId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A message identifier for the +-- @\/_plugins\/_ml\/memory\/message\/{message_id}@ path segment. +newtype MessageId = MessageId {unMessageId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A single memory record, as returned by @GET /_plugins/_ml/memory/{memory_id}@ +-- and as each entry of @GET /_plugins/_ml/memory@ (the list form) and +-- each per-hit @_source@ of @/_plugins/_ml/memory/_search@. Every field +-- is 'Maybe' because the list and search shapes omit @memory_id@ / +-- @user@ in some plugin versions. +data Memory = Memory + { memoryId :: Maybe Text, + memoryCreateTime :: Maybe Text, + memoryUpdatedTime :: Maybe Text, + memoryName :: Maybe Text, + memoryUser :: Maybe Text, + memoryApplicationType :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON Memory where + parseJSON = withObject "Memory" $ \v -> do + memoryId <- v .:? "memory_id" + memoryCreateTime <- v .:? "create_time" + memoryUpdatedTime <- v .:? "updated_time" + memoryName <- v .:? "name" + memoryUser <- v .:? "user" + memoryApplicationType <- v .:? "application_type" + pure Memory {..} + +instance ToJSON Memory where + toJSON Memory {..} = + omitNulls + [ "memory_id" .= memoryId, + "create_time" .= memoryCreateTime, + "updated_time" .= memoryUpdatedTime, + "name" .= memoryName, + "user" .= memoryUser, + "application_type" .= memoryApplicationType + ] + +-- | Request body for @POST /_plugins/_ml/memory/@. Only @name@ is +-- documented. +newtype CreateMemoryRequest = CreateMemoryRequest + { createMemoryName :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateMemoryRequest where + parseJSON = withObject "CreateMemoryRequest" $ \v -> do + createMemoryName <- v .:? "name" + pure CreateMemoryRequest {..} + +instance ToJSON CreateMemoryRequest where + toJSON (CreateMemoryRequest mName) = + omitNulls ["name" .= mName] + +-- | Response of @POST /_plugins/_ml/memory/@: @{memory_id}@. +newtype CreateMemoryResponse = CreateMemoryResponse + { createMemoryResponseId :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateMemoryResponse where + parseJSON = withObject "CreateMemoryResponse" $ \v -> do + createMemoryResponseId <- v .:? "memory_id" + pure CreateMemoryResponse {..} + +instance ToJSON CreateMemoryResponse where + toJSON (CreateMemoryResponse mId) = + omitNulls ["memory_id" .= mId] + +-- | Response of @DELETE /_plugins/_ml/memory/{memory_id}@: +-- @{success: }@. Unlike connector \/ model-group delete, memory +-- delete is /not/ idempotent — a missing memory returns HTTP 404. +newtype DeleteMemoryResponse = DeleteMemoryResponse + { deleteMemoryResponseSuccess :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON DeleteMemoryResponse where + parseJSON = withObject "DeleteMemoryResponse" $ \v -> do + deleteMemoryResponseSuccess <- v .:? "success" + pure DeleteMemoryResponse {..} + +instance ToJSON DeleteMemoryResponse where + toJSON (DeleteMemoryResponse mSuccess) = + omitNulls ["success" .= mSuccess] + +-- | Response of the list form @GET /_plugins/_ml/memory@: +-- @{"memories": [...]}@. +newtype ListMemoriesResponse = ListMemoriesResponse + { listMemoriesResponseMemories :: [Memory] + } + deriving stock (Eq, Show) + +instance FromJSON ListMemoriesResponse where + parseJSON = withObject "ListMemoriesResponse" $ \v -> do + listMemoriesResponseMemories <- v .:? "memories" .!= [] + pure ListMemoriesResponse {..} + +instance ToJSON ListMemoriesResponse where + toJSON (ListMemoriesResponse ms) = + omitNulls ["memories" .= ms] + +-- | A single message within a memory. Returned by the get-message, +-- list-messages, search-message, and trace endpoints; every field is +-- 'Maybe' because traces carry @parent_message_id@ \/ @trace_number@ +-- that ordinary messages omit, and because @input@ \/ @response@ may be +-- null when only @additional_info@ was supplied. @additional_info@ is an +-- opaque JSON object (arbitrary key/value metadata). +data MemoryMessage = MemoryMessage + { memoryMessageMemoryId :: Maybe Text, + memoryMessageId :: Maybe Text, + memoryMessageCreateTime :: Maybe Text, + memoryMessageUpdatedTime :: Maybe Text, + memoryMessageInput :: Maybe Text, + memoryMessagePromptTemplate :: Maybe Text, + memoryMessageResponse :: Maybe Text, + memoryMessageOrigin :: Maybe Text, + memoryMessageAdditionalInfo :: Maybe Value, + memoryMessageParentMessageId :: Maybe Text, + memoryMessageTraceNumber :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON MemoryMessage where + parseJSON = withObject "MemoryMessage" $ \v -> do + memoryMessageMemoryId <- v .:? "memory_id" + memoryMessageId <- v .:? "message_id" + memoryMessageCreateTime <- v .:? "create_time" + memoryMessageUpdatedTime <- v .:? "updated_time" + memoryMessageInput <- v .:? "input" + memoryMessagePromptTemplate <- v .:? "prompt_template" + memoryMessageResponse <- v .:? "response" + memoryMessageOrigin <- v .:? "origin" + memoryMessageAdditionalInfo <- v .:? "additional_info" + memoryMessageParentMessageId <- v .:? "parent_message_id" + memoryMessageTraceNumber <- v .:? "trace_number" + pure MemoryMessage {..} + +instance ToJSON MemoryMessage where + toJSON MemoryMessage {..} = + omitNulls + [ "memory_id" .= memoryMessageMemoryId, + "message_id" .= memoryMessageId, + "create_time" .= memoryMessageCreateTime, + "updated_time" .= memoryMessageUpdatedTime, + "input" .= memoryMessageInput, + "prompt_template" .= memoryMessagePromptTemplate, + "response" .= memoryMessageResponse, + "origin" .= memoryMessageOrigin, + "additional_info" .= memoryMessageAdditionalInfo, + "parent_message_id" .= memoryMessageParentMessageId, + "trace_number" .= memoryMessageTraceNumber + ] + +-- | Request body for @POST /_plugins/_ml/memory/{memory_id}/messages@. +-- At least one field must be non-null/non-empty. Only @additional_info@ +-- is updatable via the PUT form; the other fields are write-once. +data CreateMemoryMessageRequest = CreateMemoryMessageRequest + { createMemoryMessageInput :: Maybe Text, + createMemoryMessagePromptTemplate :: Maybe Text, + createMemoryMessageResponse :: Maybe Text, + createMemoryMessageOrigin :: Maybe Text, + createMemoryMessageAdditionalInfo :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON CreateMemoryMessageRequest where + parseJSON = withObject "CreateMemoryMessageRequest" $ \v -> do + createMemoryMessageInput <- v .:? "input" + createMemoryMessagePromptTemplate <- v .:? "prompt_template" + createMemoryMessageResponse <- v .:? "response" + createMemoryMessageOrigin <- v .:? "origin" + createMemoryMessageAdditionalInfo <- v .:? "additional_info" + pure CreateMemoryMessageRequest {..} + +instance ToJSON CreateMemoryMessageRequest where + toJSON CreateMemoryMessageRequest {..} = + omitNulls + [ "input" .= createMemoryMessageInput, + "prompt_template" .= createMemoryMessagePromptTemplate, + "response" .= createMemoryMessageResponse, + "origin" .= createMemoryMessageOrigin, + "additional_info" .= createMemoryMessageAdditionalInfo + ] + +-- | Response of @POST /_plugins/_ml/memory/{memory_id}/messages@: +-- @{message_id}@. +newtype CreateMemoryMessageResponse = CreateMemoryMessageResponse + { createMemoryMessageResponseId :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateMemoryMessageResponse where + parseJSON = withObject "CreateMemoryMessageResponse" $ \v -> do + createMemoryMessageResponseId <- v .:? "message_id" + pure CreateMemoryMessageResponse {..} + +instance ToJSON CreateMemoryMessageResponse where + toJSON (CreateMemoryMessageResponse mId) = + omitNulls ["message_id" .= mId] + +-- | Response of the list form +-- @GET /_plugins/_ml/memory/{memory_id}/messages@: @{"messages": [...]}@. +newtype ListMemoryMessagesResponse = ListMemoryMessagesResponse + { listMemoryMessagesResponseMessages :: [MemoryMessage] + } + deriving stock (Eq, Show) + +instance FromJSON ListMemoryMessagesResponse where + parseJSON = withObject "ListMemoryMessagesResponse" $ \v -> do + listMemoryMessagesResponseMessages <- v .:? "messages" .!= [] + pure ListMemoryMessagesResponse {..} + +instance ToJSON ListMemoryMessagesResponse where + toJSON (ListMemoryMessagesResponse ms) = + omitNulls ["messages" .= ms] + +-- | Response of @GET /_plugins/_ml/memory/message/{message_id}/traces@: +-- @{"traces": [...]}@, where each entry has the full 'MemoryMessage' +-- shape (with @parent_message_id@ and @trace_number@ populated). +newtype MemoryMessageTraces = MemoryMessageTraces + { memoryMessageTracesTraces :: [MemoryMessage] + } + deriving stock (Eq, Show) + +instance FromJSON MemoryMessageTraces where + parseJSON = withObject "MemoryMessageTraces" $ \v -> do + memoryMessageTracesTraces <- v .:? "traces" .!= [] + pure MemoryMessageTraces {..} + +instance ToJSON MemoryMessageTraces where + toJSON (MemoryMessageTraces ts) = + omitNulls ["traces" .= ts] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLModel.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLModel.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLModel.hs @@ -0,0 +1,672 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLModel + ( ModelId (..), + AlgorithmName (..), + ModelFormat (..), + ModelState (..), + ModelConfig (..), + ModelInfo (..), + RegisterModelRequest (..), + MLTaskAck (..), + DeployModelRequest (..), + UndeployModelResponse (..), + ModelNodeUndeployStats (..), + UpdateModelRequest (..), + ModelRateLimiter (..), + ModelRateLimit (..), + ModelRateLimiterUnit (..), + ModelSearchResponse (..), + ModelShards (..), + ModelTotal (..), + ModelTotalRelation (..), + ModelHit (..), + ) +where + +import Data.Aeson.KeyMap qualified as KM +import Data.Int (Int64) +import Data.Map.Strict qualified as M +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The ML Commons model APIs (see +-- ) +-- cover the lifecycle of a model: register (asynchronously store the model +-- metadata and content), deploy (load chunks into memory on ML worker +-- nodes), predict (invoke a deployed model), and get (read metadata). +-- +-- Registration and deployment are asynchronous: the POST returns a task +-- acknowledgement carrying a @task_id@ that the caller polls via the +-- separate Get ML Task API (@GET /_plugins/_ml/tasks/{task_id}@). The +-- acknowledgement shape is shared by both endpoints, modelled here as +-- 'MLTaskAck'. +-- +-- The predict request body and response are model-specific (the same +-- endpoint serves classical algorithms like kmeans and remote connectors +-- whose @parameters@ and @inference_results@ have no fixed schema), so +-- 'predict' is typed at the boundary as an opaque 'Value' and callers +-- decode the payload with their own model-specific parser. + +-- | A model ID for the @\/_plugins\/_ml\/models\/{model_id}@ path segment +-- and the @model_id@ field returned by register\/deploy. The value is +-- assigned by the server. Wrapped 'Text' so it round-trips as a bare JSON +-- string but is distinct from 'PolicyId' \/ 'IndexName' at the type level. +newtype ModelId = ModelId {unModelId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | An algorithm name for the +-- @\/_plugins\/_ml\/_predict\/{algorithm_name}\/{model_id}@ path segment +-- of the predict endpoint. Values are plugin-defined @FunctionName@ +-- constants (e.g. @kmeans@, @text_embedding@, @remote@); the set changes +-- across releases so this is a thin 'Text' newtype. +newtype AlgorithmName = AlgorithmName {unAlgorithmName :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The serialization format of a model's content. Used by the +-- @model_format@ field of 'RegisterModelRequest' and 'ModelInfo'. +-- OpenSearch currently documents two values; unknown values parse-fail so +-- a future plugin release adding a third surfaces as a deliberate error +-- rather than a silent drop. +data ModelFormat + = ModelFormatTorchScript + | ModelFormatOnnx + deriving stock (Eq, Show) + +instance ToJSON ModelFormat where + toJSON = \case + ModelFormatTorchScript -> "TORCH_SCRIPT" + ModelFormatOnnx -> "ONNX" + +instance FromJSON ModelFormat where + parseJSON = withText "ModelFormat" $ \case + "TORCH_SCRIPT" -> pure ModelFormatTorchScript + "ONNX" -> pure ModelFormatOnnx + other -> fail ("Unknown ModelFormat: " <> T.unpack other) + +-- | The lifecycle state of a model, as reported by the @model_state@ field +-- of 'ModelInfo'. The full set is documented at +-- . +data ModelState + = ModelStateRegistering + | ModelStateRegistered + | ModelStateDeploying + | ModelStateDeployed + | ModelStatePartiallyDeployed + | ModelStateUndeployed + | ModelStateDeployFailed + deriving stock (Eq, Show) + +instance ToJSON ModelState where + toJSON = \case + ModelStateRegistering -> "REGISTERING" + ModelStateRegistered -> "REGISTERED" + ModelStateDeploying -> "DEPLOYING" + ModelStateDeployed -> "DEPLOYED" + ModelStatePartiallyDeployed -> "PARTIALLY_DEPLOYED" + ModelStateUndeployed -> "UNDEPLOYED" + ModelStateDeployFailed -> "DEPLOY_FAILED" + +instance FromJSON ModelState where + parseJSON = withText "ModelState" $ \case + "REGISTERING" -> pure ModelStateRegistering + "REGISTERED" -> pure ModelStateRegistered + "DEPLOYING" -> pure ModelStateDeploying + "DEPLOYED" -> pure ModelStateDeployed + "PARTIALLY_DEPLOYED" -> pure ModelStatePartiallyDeployed + "UNDEPLOYED" -> pure ModelStateUndeployed + "DEPLOY_FAILED" -> pure ModelStateDeployFailed + other -> fail ("Unknown ModelState: " <> T.unpack other) + +-- | The @model_config@ object embedded in 'RegisterModelRequest' and +-- returned inside 'ModelInfo'. @model_type@, @embedding_dimension@, and +-- @framework_type@ are required when present; @all_config@ is a minified +-- JSON string of the upstream model config (e.g. HuggingFace +-- @config.json@); @additional_config@ is an opaque JSON object (notably +-- @space_type@ for k-NN distance metric). +data ModelConfig = ModelConfig + { modelConfigModelType :: Text, + modelConfigEmbeddingDimension :: Int, + modelConfigFrameworkType :: Text, + modelConfigAllConfig :: Maybe Text, + modelConfigAdditionalConfig :: Maybe Value, + modelConfigPoolingMode :: Maybe Text, + modelConfigNormalizeResult :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON ModelConfig where + parseJSON = withObject "ModelConfig" $ \v -> do + modelConfigModelType <- v .: "model_type" + modelConfigEmbeddingDimension <- v .: "embedding_dimension" + modelConfigFrameworkType <- v .: "framework_type" + modelConfigAllConfig <- v .:? "all_config" + modelConfigAdditionalConfig <- v .:? "additional_config" + modelConfigPoolingMode <- v .:? "pooling_mode" + modelConfigNormalizeResult <- v .:? "normalize_result" + pure ModelConfig {..} + +instance ToJSON ModelConfig where + toJSON ModelConfig {..} = + omitNulls + [ "model_type" .= modelConfigModelType, + "embedding_dimension" .= modelConfigEmbeddingDimension, + "framework_type" .= modelConfigFrameworkType, + "all_config" .= modelConfigAllConfig, + "additional_config" .= modelConfigAdditionalConfig, + "pooling_mode" .= modelConfigPoolingMode, + "normalize_result" .= modelConfigNormalizeResult + ] + +-- | Response of @GET /_plugins/_ml/models/{model_id}@. The body is a bare +-- object (no envelope); the server returns every metadata field it has. +-- Most fields beyond @name@, @algorithm@, @version@ are conditionally +-- present depending on the model source (pretrained, custom, or remote +-- connector) and lifecycle state, so they are modelled as 'Maybe'. +-- +-- Note: embedding-specific fields (@model_config@, @model_format@, +-- @model_content_*@) are typically absent for remote-connector models +-- (algorithm @remote@); callers serving remote models should not rely on +-- 'modelInfoModelConfig' being present. +data ModelInfo = ModelInfo + { modelInfoModelId :: Maybe Text, + modelInfoName :: Text, + modelInfoAlgorithm :: Text, + modelInfoVersion :: Text, + modelInfoModelFormat :: Maybe ModelFormat, + modelInfoModelState :: Maybe ModelState, + modelInfoModelContentSizeInBytes :: Maybe Int64, + modelInfoModelContentHashValue :: Maybe Text, + modelInfoModelConfig :: Maybe ModelConfig, + modelInfoIsEnabled :: Maybe Bool, + modelInfoGroupId :: Maybe Text, + modelInfoCreatedTime :: Maybe Int64, + modelInfoLastUploadedTime :: Maybe Int64, + modelInfoLastLoadedTime :: Maybe Int64, + modelInfoTotalChunks :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON ModelInfo where + parseJSON = withObject "ModelInfo" $ \v -> do + modelInfoModelId <- v .:? "model_id" + modelInfoName <- v .: "name" + modelInfoAlgorithm <- v .: "algorithm" + mModelVersion <- v .:? "model_version" + modelInfoVersion <- case mModelVersion of + Just ver -> pure ver + Nothing -> v .: "version" + modelInfoModelFormat <- v .:? "model_format" + modelInfoModelState <- v .:? "model_state" + modelInfoModelContentSizeInBytes <- v .:? "model_content_size_in_bytes" + modelInfoModelContentHashValue <- v .:? "model_content_hash_value" + modelInfoModelConfig <- v .:? "model_config" + modelInfoIsEnabled <- v .:? "is_enabled" + modelInfoGroupId <- v .:? "model_group_id" + modelInfoCreatedTime <- v .:? "created_time" + modelInfoLastUploadedTime <- v .:? "last_uploaded_time" + modelInfoLastLoadedTime <- v .:? "last_loaded_time" + modelInfoTotalChunks <- v .:? "total_chunks" + pure ModelInfo {..} + +instance ToJSON ModelInfo where + toJSON ModelInfo {..} = + omitNulls + [ "model_id" .= modelInfoModelId, + "name" .= modelInfoName, + "algorithm" .= modelInfoAlgorithm, + "version" .= modelInfoVersion, + "model_format" .= modelInfoModelFormat, + "model_state" .= modelInfoModelState, + "model_content_size_in_bytes" .= modelInfoModelContentSizeInBytes, + "model_content_hash_value" .= modelInfoModelContentHashValue, + "model_config" .= modelInfoModelConfig, + "is_enabled" .= modelInfoIsEnabled, + "model_group_id" .= modelInfoGroupId, + "created_time" .= modelInfoCreatedTime, + "last_uploaded_time" .= modelInfoLastUploadedTime, + "last_loaded_time" .= modelInfoLastLoadedTime, + "total_chunks" .= modelInfoTotalChunks + ] + +-- | Request body for @POST /_plugins/_ml/models/_register@. The register +-- API documents four model-source variants (pretrained, custom local, +-- sparse, remote-connector); rather than a closed 4-way sum type that +-- would push variant selection onto the caller, this is one general +-- record whose optional fields cover every variant. The server validates +-- the combination and returns HTTP 400 for nonsensical request shapes +-- (e.g. supplying both @url@ and @connector_id@). The inline +-- @connector@ spec is opaque JSON because its sub-shape is large and +-- covered by the dedicated Connector API pages. +data RegisterModelRequest = RegisterModelRequest + { registerModelName :: Text, + registerModelVersion :: Maybe Text, + registerModelDescription :: Maybe Text, + registerModelFormat :: Maybe ModelFormat, + registerModelFunctionName :: Maybe Text, + registerModelContentHashValue :: Maybe Text, + registerModelConfig :: Maybe ModelConfig, + registerModelUrl :: Maybe Text, + registerModelGroupId :: Maybe Text, + registerModelConnectorId :: Maybe Text, + registerModelConnector :: Maybe Value, + registerModelIsEnabled :: Maybe Bool, + registerModelProvisionedBy :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RegisterModelRequest where + parseJSON = withObject "RegisterModelRequest" $ \v -> do + registerModelName <- v .: "name" + registerModelVersion <- v .:? "version" + registerModelDescription <- v .:? "description" + registerModelFormat <- v .:? "model_format" + registerModelFunctionName <- v .:? "function_name" + registerModelContentHashValue <- v .:? "model_content_hash_value" + registerModelConfig <- v .:? "model_config" + registerModelUrl <- v .:? "url" + registerModelGroupId <- v .:? "model_group_id" + registerModelConnectorId <- v .:? "connector_id" + registerModelConnector <- v .:? "connector" + registerModelIsEnabled <- v .:? "is_enabled" + registerModelProvisionedBy <- v .:? "provisioned_by" + pure RegisterModelRequest {..} + +instance ToJSON RegisterModelRequest where + toJSON RegisterModelRequest {..} = + omitNulls + [ "name" .= registerModelName, + "version" .= registerModelVersion, + "description" .= registerModelDescription, + "model_format" .= registerModelFormat, + "function_name" .= registerModelFunctionName, + "model_content_hash_value" .= registerModelContentHashValue, + "model_config" .= registerModelConfig, + "url" .= registerModelUrl, + "model_group_id" .= registerModelGroupId, + "connector_id" .= registerModelConnectorId, + "connector" .= registerModelConnector, + "is_enabled" .= registerModelIsEnabled, + "provisioned_by" .= registerModelProvisionedBy + ] + +-- | Shared acknowledgement returned by @POST /_plugins/_ml/models/_register@ +-- and @POST /_plugins/_ml/models/{model_id}/_deploy@. Both endpoints are +-- asynchronous: @task_id@ identifies the polling handle (passed to the +-- separate Get ML Task API), @status@ is the task status at submit time +-- (typically @CREATED@). Register additionally echoes the new @model_id@; +-- deploy instead echoes a @task_type@ (typically @DEPLOY_MODEL@). Each +-- field is 'Maybe' so the same parser covers both endpoint-specific +-- shapes without a sum type. +data MLTaskAck = MLTaskAck + { mlTaskAckTaskId :: Maybe Text, + mlTaskAckStatus :: Maybe Text, + mlTaskAckModelId :: Maybe Text, + mlTaskAckTaskType :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON MLTaskAck where + parseJSON = withObject "MLTaskAck" $ \v -> do + mlTaskAckTaskId <- v .:? "task_id" + mlTaskAckStatus <- v .:? "status" + mlTaskAckModelId <- v .:? "model_id" + mlTaskAckTaskType <- v .:? "task_type" + pure MLTaskAck {..} + +instance ToJSON MLTaskAck where + toJSON MLTaskAck {..} = + omitNulls + [ "task_id" .= mlTaskAckTaskId, + "status" .= mlTaskAckStatus, + "model_id" .= mlTaskAckModelId, + "task_type" .= mlTaskAckTaskType + ] + +-- | Optional request body for +-- @POST /_plugins/_ml/models/{model_id}/_deploy@. When 'Nothing' or when +-- 'deployModelRequestNodeIds' is @[]@ or 'Nothing', OpenSearch deploys to +-- every eligible ML worker node; supplying a non-empty list restricts +-- deployment to those node IDs. +newtype DeployModelRequest = DeployModelRequest + { deployModelRequestNodeIds :: Maybe [Text] + } + deriving stock (Eq, Show) + +instance FromJSON DeployModelRequest where + parseJSON = withObject "DeployModelRequest" $ \v -> do + deployModelRequestNodeIds <- v .:? "node_ids" + pure DeployModelRequest {..} + +instance ToJSON DeployModelRequest where + toJSON (DeployModelRequest mNodeIds) = + omitNulls ["node_ids" .= mNodeIds] + +-- | Response of @POST /_plugins/_ml/models/{model_id}/_undeploy@. Unlike +-- the other model lifecycle endpoints, undeploy is /synchronous/ and +-- returns a node-keyed stats map rather than a task ack: each ML +-- worker node that hosted chunks of the model reports the resulting +-- per-model state (typically @UNDEPLOYED@). The shape is therefore +-- @{"": {"stats": {"": "UNDEPLOYED"}}}@. +-- See . +newtype UndeployModelResponse = UndeployModelResponse + { undeployModelResponseNodes :: M.Map Text ModelNodeUndeployStats + } + deriving stock (Eq, Show) + +instance FromJSON UndeployModelResponse where + parseJSON = withObject "UndeployModelResponse" $ \o -> + UndeployModelResponse . M.fromList + <$> traverse parseNodeEntry (KM.toList o) + where + parseNodeEntry (k, v) = (\parsed -> (toText k, parsed)) <$> parseJSON v + +instance ToJSON UndeployModelResponse where + toJSON (UndeployModelResponse m) = + object [(fromText k .= toJSON v) | (k, v) <- M.toList m] + +-- | The per-node value of 'UndeployModelResponse': +-- @{"stats": {"": "UNDEPLOYED"}}@. +newtype ModelNodeUndeployStats = ModelNodeUndeployStats + { modelNodeUndeployStatsStats :: M.Map Text Text + } + deriving stock (Eq, Show) + +instance FromJSON ModelNodeUndeployStats where + parseJSON = withObject "ModelNodeUndeployStats" $ \v -> do + stats <- v .: "stats" + inner <- traverse parseModelEntry (KM.toList stats) + pure (ModelNodeUndeployStats (M.fromList inner)) + where + parseModelEntry (k, v) = (\parsed -> (toText k, parsed)) <$> parseJSON v + +instance ToJSON ModelNodeUndeployStats where + toJSON (ModelNodeUndeployStats m) = + object [("stats" .= object [(fromText k .= toJSON v) | (k, v) <- M.toList m])] + +-- | Request body for @PUT /_plugins/_ml/models/{model_id}@. Every +-- field is 'Maybe' because the update endpoint accepts a partial +-- body: only the supplied keys are written. The documented updatable +-- fields are @name@, @description@, @is_enabled@, @model_group_id@, +-- @model_config@, @connector@, @connector_id@, @rate_limiter@, +-- @guardrails@, and @interface@. The last four are opaque JSON +-- objects whose sub-shape is plugin-defined and forward-compat, so +-- they are typed as 'Value'. +-- See . +data UpdateModelRequest = UpdateModelRequest + { updateModelName :: Maybe Text, + updateModelDescription :: Maybe Text, + updateModelIsEnabled :: Maybe Bool, + updateModelGroupId :: Maybe Text, + updateModelConfig :: Maybe ModelConfig, + updateModelConnectorId :: Maybe Text, + updateModelConnector :: Maybe Value, + updateModelRateLimiter :: Maybe ModelRateLimiter, + updateModelGuardrails :: Maybe Value, + updateModelInterface :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON UpdateModelRequest where + parseJSON = withObject "UpdateModelRequest" $ \v -> do + updateModelName <- v .:? "name" + updateModelDescription <- v .:? "description" + updateModelIsEnabled <- v .:? "is_enabled" + updateModelGroupId <- v .:? "model_group_id" + updateModelConfig <- v .:? "model_config" + updateModelConnectorId <- v .:? "connector_id" + updateModelConnector <- v .:? "connector" + updateModelRateLimiter <- v .:? "rate_limiter" + updateModelGuardrails <- v .:? "guardrails" + updateModelInterface <- v .:? "interface" + pure UpdateModelRequest {..} + +instance ToJSON UpdateModelRequest where + toJSON UpdateModelRequest {..} = + omitNulls + [ "name" .= updateModelName, + "description" .= updateModelDescription, + "is_enabled" .= updateModelIsEnabled, + "model_group_id" .= updateModelGroupId, + "model_config" .= updateModelConfig, + "connector_id" .= updateModelConnectorId, + "connector" .= updateModelConnector, + "rate_limiter" .= updateModelRateLimiter, + "guardrails" .= updateModelGuardrails, + "interface" .= updateModelInterface + ] + +-- | The @unit@ enum on the @rate_limiter@ sub-object. The ML Commons +-- plugin documents seven uppercase values matching Java +-- @TimeUnit@-style names. +data ModelRateLimiterUnit + = ModelRateLimiterUnitDays + | ModelRateLimiterUnitHours + | ModelRateLimiterUnitMicroseconds + | ModelRateLimiterUnitMilliseconds + | ModelRateLimiterUnitMinutes + | ModelRateLimiterUnitNanoseconds + | ModelRateLimiterUnitSeconds + deriving stock (Eq, Show) + +instance FromJSON ModelRateLimiterUnit where + parseJSON = withText "ModelRateLimiterUnit" $ \case + "DAYS" -> pure ModelRateLimiterUnitDays + "HOURS" -> pure ModelRateLimiterUnitHours + "MICROSECONDS" -> pure ModelRateLimiterUnitMicroseconds + "MILLISECONDS" -> pure ModelRateLimiterUnitMilliseconds + "MINUTES" -> pure ModelRateLimiterUnitMinutes + "NANOSECONDS" -> pure ModelRateLimiterUnitNanoseconds + "SECONDS" -> pure ModelRateLimiterUnitSeconds + other -> fail ("unknown rate_limiter unit: " <> T.unpack other) + +instance ToJSON ModelRateLimiterUnit where + toJSON = \case + ModelRateLimiterUnitDays -> "DAYS" + ModelRateLimiterUnitHours -> "HOURS" + ModelRateLimiterUnitMicroseconds -> "MICROSECONDS" + ModelRateLimiterUnitMilliseconds -> "MILLISECONDS" + ModelRateLimiterUnitMinutes -> "MINUTES" + ModelRateLimiterUnitNanoseconds -> "NANOSECONDS" + ModelRateLimiterUnitSeconds -> "SECONDS" + +-- | The @limit@ field on the @rate_limiter@ sub-object. The spec types +-- this as a @StringifiedDouble@: the server may emit it as a JSON number +-- or as a JSON string containing the decimal representation. Decoding +-- accepts both shapes; encoding always emits a JSON number. +newtype ModelRateLimit = ModelRateLimit {unModelRateLimit :: Double} + deriving stock (Eq, Ord, Show) + +instance FromJSON ModelRateLimit where + parseJSON (Number n) = pure (ModelRateLimit (realToFrac n)) + parseJSON (String s) = case readMay (T.unpack s) of + Just d -> pure (ModelRateLimit d) + Nothing -> fail ("invalid rate_limiter limit: " <> T.unpack s) + parseJSON v = typeMismatch "ModelRateLimit" v + +instance ToJSON ModelRateLimit where + toJSON (ModelRateLimit d) = toJSON d + +-- | The @rate_limiter@ sub-object on 'UpdateModelRequest'. Documented +-- with two fields: @limit@ (number) and @unit@ (string). Both are +-- 'Maybe' so partial updates of one field round-trip cleanly. +data ModelRateLimiter = ModelRateLimiter + { modelRateLimiterLimit :: Maybe ModelRateLimit, + modelRateLimiterUnit :: Maybe ModelRateLimiterUnit + } + deriving stock (Eq, Show) + +instance FromJSON ModelRateLimiter where + parseJSON = withObject "ModelRateLimiter" $ \v -> do + modelRateLimiterLimit <- v .:? "limit" + modelRateLimiterUnit <- v .:? "unit" + pure ModelRateLimiter {..} + +instance ToJSON ModelRateLimiter where + toJSON ModelRateLimiter {..} = + omitNulls + [ "limit" .= modelRateLimiterLimit, + "unit" .= modelRateLimiterUnit + ] + +-- | The @hits.total.relation@ discriminator on a model search +-- response. Mirrors the Security Analytics 'SARulesTotalRelation' +-- precedent: known values are decoded to specific constructors, and +-- any unknown value round-trips via 'ModelTotalRelationOther' so a +-- future plugin release does not break decoding. +data ModelTotalRelation + = ModelTotalRelationEq + | ModelTotalRelationGe + | ModelTotalRelationOther Text + deriving stock (Eq, Show) + +modelTotalRelationText :: ModelTotalRelation -> Text +modelTotalRelationText = \case + ModelTotalRelationEq -> "eq" + ModelTotalRelationGe -> "ge" + ModelTotalRelationOther t -> t + +instance ToJSON ModelTotalRelation where + toJSON = toJSON . modelTotalRelationText + +instance FromJSON ModelTotalRelation where + parseJSON = withText "ModelTotalRelation" $ \t -> + pure $ + case t of + "eq" -> ModelTotalRelationEq + "ge" -> ModelTotalRelationGe + other -> ModelTotalRelationOther other + +-- | The @hits.total@ sub-object on a model search response +-- (@{value, relation}@). +data ModelTotal = ModelTotal + { modelTotalValue :: Int64, + modelTotalRelation :: ModelTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON ModelTotal where + parseJSON = withObject "ModelTotal" $ \o -> + ModelTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON ModelTotal where + toJSON ModelTotal {..} = + object + [ "value" .= modelTotalValue, + "relation" .= modelTotalRelation + ] + +-- | The @_shards@ sub-object on a model search response. Defined +-- locally under an @Model@ prefix (mirroring the 'SARulesShards' +-- precedent) rather than re-using the cluster-level 'ShardsResult' +-- envelope, which wraps the outer @{\"_shards\": {...}}@ shape — one +-- level too high for inline use here. +data ModelShards = ModelShards + { modelShardsTotal :: Int, + modelShardsSuccessful :: Int, + modelShardsSkipped :: Int, + modelShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON ModelShards where + parseJSON = withObject "ModelShards" $ \o -> + ModelShards + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "skipped" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON ModelShards where + toJSON ModelShards {..} = + object + [ "total" .= modelShardsTotal, + "successful" .= modelShardsSuccessful, + "skipped" .= modelShardsSkipped, + "failed" .= modelShardsFailed + ] + +-- | A single hit in @hits.hits[]@ on a model search response. +data ModelHit = ModelHit + { modelHitIndex :: Maybe Text, + modelHitId :: Text, + modelHitVersion :: Maybe Int64, + modelHitSeqNo :: Maybe Int64, + modelHitPrimaryTerm :: Maybe Int64, + modelHitScore :: Maybe Double, + modelHitSource :: ModelInfo + } + deriving stock (Eq, Show) + +instance FromJSON ModelHit where + parseJSON = withObject "ModelHit" $ \o -> + ModelHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON ModelHit where + toJSON ModelHit {..} = + omitNulls + [ "_index" .= modelHitIndex, + "_id" .= modelHitId, + "_version" .= modelHitVersion, + "_seq_no" .= modelHitSeqNo, + "_primary_term" .= modelHitPrimaryTerm, + "_score" .= modelHitScore, + "_source" .= modelHitSource + ] + +-- | Response envelope for @POST /_plugins/_ml/models/_search@ and +-- @POST /_plugins/_ml/models/_list@. Decoded verbatim from the +-- standard OpenSearch search-response shape; the paging metadata +-- (@took@, @timed_out@, @_shards@, @hits.total@, @hits.max_score@) +-- is preserved alongside the model list so callers can drive +-- pagination and observe shard health. +data ModelSearchResponse = ModelSearchResponse + { modelSearchResponseTook :: Int64, + modelSearchResponseTimedOut :: Bool, + modelSearchResponseShards :: ModelShards, + modelSearchResponseTotal :: ModelTotal, + modelSearchResponseMaxScore :: Maybe Double, + modelSearchResponseHits :: [ModelHit] + } + deriving stock (Eq, Show) + +instance FromJSON ModelSearchResponse where + parseJSON = withObject "ModelSearchResponse" $ \o -> do + hits <- o .: "hits" + ModelSearchResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON ModelSearchResponse where + toJSON ModelSearchResponse {..} = + object + [ "took" .= modelSearchResponseTook, + "timed_out" .= modelSearchResponseTimedOut, + "_shards" .= modelSearchResponseShards, + "hits" + .= object + [ "total" .= modelSearchResponseTotal, + "max_score" .= modelSearchResponseMaxScore, + "hits" .= modelSearchResponseHits + ] + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLModelGroups.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLModelGroups.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLModelGroups.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLModelGroups + ( ModelGroupId (..), + ModelGroupAccessMode (..), + RegisterModelGroupRequest (..), + RegisterModelGroupResponse (..), + UpdateModelGroupRequest (..), + ModelGroupInfo (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), withObject, withText, (.:), (.:?), (.=)) +import Data.Int (Int64) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) + +-- $schema +-- +-- The ML Commons model group APIs (see +-- , +-- introduced in OS 2.12) group related model versions behind a shared +-- access policy. A model group is the unit of @access_mode@ (@public@, +-- @private@, @restricted@) and @backend_roles@ for model access control. +-- +-- /Naming asymmetry:/ the request bodies use the key @access_mode@, while +-- the get\/search responses use the shorter key @access@ for the same +-- value. This is reflected in the field decoders below. + +-- | A model-group identifier for the +-- @\/_plugins\/_ml\/model_groups\/{model_group_id}@ path segment, assigned +-- by the server on register. +newtype ModelGroupId = ModelGroupId {unModelGroupId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @access_mode@ (request) \/ @access@ (response) enum. The plugin +-- emits these as lower-case strings. Unknown values decode to +-- 'ModelGroupAccessModeOther' so a future plugin release adding a mode +-- the client does not know about round-trips losslessly instead of +-- throwing. +data ModelGroupAccessMode + = ModelGroupAccessModePublic + | ModelGroupAccessModePrivate + | ModelGroupAccessModeRestricted + | ModelGroupAccessModeOther Text + deriving stock (Eq, Show) + +modelGroupAccessModeText :: ModelGroupAccessMode -> Text +modelGroupAccessModeText = \case + ModelGroupAccessModePublic -> "public" + ModelGroupAccessModePrivate -> "private" + ModelGroupAccessModeRestricted -> "restricted" + ModelGroupAccessModeOther t -> t + +instance ToJSON ModelGroupAccessMode where + toJSON = toJSON . modelGroupAccessModeText + +instance FromJSON ModelGroupAccessMode where + parseJSON = withText "ModelGroupAccessMode" $ \t -> + pure $ + case t of + "public" -> ModelGroupAccessModePublic + "private" -> ModelGroupAccessModePrivate + "restricted" -> ModelGroupAccessModeRestricted + other -> ModelGroupAccessModeOther other + +-- | Request body for @POST /_plugins/_ml/model_groups/_register@. Only +-- @name@ is required; @access_mode@, @backend_roles@, and +-- @add_all_backend_roles@ govern model access control and are only +-- honoured when the cluster has model access control enabled. Exactly +-- one of @backend_roles@ \/ @add_all_backend_roles@ is valid when +-- @access_mode = "restricted"@. +data RegisterModelGroupRequest = RegisterModelGroupRequest + { registerModelGroupName :: Text, + registerModelGroupDescription :: Maybe Text, + registerModelGroupAccessMode :: Maybe ModelGroupAccessMode, + registerModelGroupBackendRoles :: Maybe [Text], + registerModelGroupAddAllBackendRoles :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON RegisterModelGroupRequest where + parseJSON = withObject "RegisterModelGroupRequest" $ \v -> do + registerModelGroupName <- v .: "name" + registerModelGroupDescription <- v .:? "description" + registerModelGroupAccessMode <- v .:? "access_mode" + registerModelGroupBackendRoles <- v .:? "backend_roles" + registerModelGroupAddAllBackendRoles <- v .:? "add_all_backend_roles" + pure RegisterModelGroupRequest {..} + +instance ToJSON RegisterModelGroupRequest where + toJSON RegisterModelGroupRequest {..} = + omitNulls + [ "name" .= registerModelGroupName, + "description" .= registerModelGroupDescription, + "access_mode" .= registerModelGroupAccessMode, + "backend_roles" .= registerModelGroupBackendRoles, + "add_all_backend_roles" .= registerModelGroupAddAllBackendRoles + ] + +-- | Response of @POST /_plugins/_ml/model_groups/_register@: +-- @{model_group_id, status}@. +data RegisterModelGroupResponse = RegisterModelGroupResponse + { registerModelGroupResponseId :: Maybe Text, + registerModelGroupResponseStatus :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RegisterModelGroupResponse where + parseJSON = withObject "RegisterModelGroupResponse" $ \v -> do + registerModelGroupResponseId <- v .:? "model_group_id" + registerModelGroupResponseStatus <- v .:? "status" + pure RegisterModelGroupResponse {..} + +instance ToJSON RegisterModelGroupResponse where + toJSON RegisterModelGroupResponse {..} = + omitNulls + [ "model_group_id" .= registerModelGroupResponseId, + "status" .= registerModelGroupResponseStatus + ] + +-- | Request body for @PUT /_plugins/_ml/model_groups/{model_group_id}@. +-- Every field is 'Maybe' because the update endpoint accepts a partial +-- body: only the supplied keys are written. +data UpdateModelGroupRequest = UpdateModelGroupRequest + { updateModelGroupName :: Maybe Text, + updateModelGroupDescription :: Maybe Text, + updateModelGroupAccessMode :: Maybe ModelGroupAccessMode, + updateModelGroupBackendRoles :: Maybe [Text], + updateModelGroupAddAllBackendRoles :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON UpdateModelGroupRequest where + parseJSON = withObject "UpdateModelGroupRequest" $ \v -> do + updateModelGroupName <- v .:? "name" + updateModelGroupDescription <- v .:? "description" + updateModelGroupAccessMode <- v .:? "access_mode" + updateModelGroupBackendRoles <- v .:? "backend_roles" + updateModelGroupAddAllBackendRoles <- v .:? "add_all_backend_roles" + pure UpdateModelGroupRequest {..} + +instance ToJSON UpdateModelGroupRequest where + toJSON UpdateModelGroupRequest {..} = + omitNulls + [ "name" .= updateModelGroupName, + "description" .= updateModelGroupDescription, + "access_mode" .= updateModelGroupAccessMode, + "backend_roles" .= updateModelGroupBackendRoles, + "add_all_backend_roles" .= updateModelGroupAddAllBackendRoles + ] + +-- | Response of @GET /_plugins/_ml/model_groups/{model_group_id}@ and the +-- per-hit @_source@ of @/_plugins/_ml/model_groups/_search@. Note the +-- response key is @access@ (not @access_mode@). +data ModelGroupInfo = ModelGroupInfo + { modelGroupName :: Maybe Text, + modelGroupLatestVersion :: Maybe Int64, + modelGroupDescription :: Maybe Text, + modelGroupAccess :: Maybe ModelGroupAccessMode, + modelGroupBackendRoles :: Maybe [Text], + modelGroupCreatedTime :: Maybe Int64, + modelGroupLastUpdatedTime :: Maybe Int64 + } + deriving stock (Eq, Show) + +instance FromJSON ModelGroupInfo where + parseJSON = withObject "ModelGroupInfo" $ \v -> do + modelGroupName <- v .:? "name" + modelGroupLatestVersion <- v .:? "latest_version" + modelGroupDescription <- v .:? "description" + modelGroupAccess <- v .:? "access" + modelGroupBackendRoles <- v .:? "backend_roles" + modelGroupCreatedTime <- v .:? "created_time" + modelGroupLastUpdatedTime <- v .:? "last_updated_time" + pure ModelGroupInfo {..} + +instance ToJSON ModelGroupInfo where + toJSON ModelGroupInfo {..} = + omitNulls + [ "name" .= modelGroupName, + "latest_version" .= modelGroupLatestVersion, + "description" .= modelGroupDescription, + "access" .= modelGroupAccess, + "backend_roles" .= modelGroupBackendRoles, + "created_time" .= modelGroupCreatedTime, + "last_updated_time" .= modelGroupLastUpdatedTime + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLProfile.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLProfile.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLProfile.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLProfile + ( MLProfileRequest (..), + MLProfilePredictRequestStats (..), + MLProfileModel (..), + MLProfileNode (..), + MLProfileResponse (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value, object, withObject, (.:?), (.=)) +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as M +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLModel + ( ModelState (..), + ) + +-- $schema +-- +-- The ML Commons profile API (see +-- ) is a +-- single GET endpoint with five path forms that reports runtime +-- information about deployed models and ML tasks, keyed by ML worker +-- node: +-- +-- * @GET /_plugins/_ml/profile@ +-- * @GET /_plugins/_ml/profile/models@ +-- * @GET /_plugins/_ml/profile/models/{model_id}@ +-- * @GET /_plugins/_ml/profile/tasks@ +-- * @GET /_plugins/_ml/profile/tasks/{task_id}@ +-- +-- The @model_id@ \/ @task_id@ path segments accept comma-separated values +-- to fetch multiple profiles at once. The bare @_profile@ form +-- additionally accepts an optional request body (modelled here as +-- 'MLProfileRequest') to filter by node and to toggle task \/ model +-- inclusion. +-- +-- The response is a node-keyed envelope (@{\"nodes\": {...}}@); each node +-- in turn carries a model-keyed map of per-model runtime state +-- ('MLProfileModel'), including latency percentile stats +-- ('MLProfilePredictRequestStats'). By default the plugin monitors the +-- last 100 predict requests (configurable via the +-- @plugins.ml_commons.monitoring_request_count@ cluster setting). + +-- | Optional request body for the bare @GET /_plugins/_ml/profile@ form. +-- All fields are optional: @node_ids@ restricts to specific nodes, +-- @model_ids@ \/ @task_ids@ restrict to specific models \/ tasks, and +-- the two @return_all_*@ flags toggle whether task \/ model profiles are +-- included (default true for both). +data MLProfileRequest = MLProfileRequest + { mlProfileRequestNodeIds :: Maybe [Text], + mlProfileRequestModelIds :: Maybe [Text], + mlProfileRequestTaskIds :: Maybe [Text], + mlProfileRequestReturnAllTasks :: Maybe Bool, + mlProfileRequestReturnAllModels :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON MLProfileRequest where + parseJSON = withObject "MLProfileRequest" $ \v -> do + mlProfileRequestNodeIds <- v .:? "node_ids" + mlProfileRequestModelIds <- v .:? "model_ids" + mlProfileRequestTaskIds <- v .:? "task_ids" + mlProfileRequestReturnAllTasks <- v .:? "return_all_tasks" + mlProfileRequestReturnAllModels <- v .:? "return_all_models" + pure MLProfileRequest {..} + +instance ToJSON MLProfileRequest where + toJSON MLProfileRequest {..} = + omitNulls + [ "node_ids" .= mlProfileRequestNodeIds, + "model_ids" .= mlProfileRequestModelIds, + "task_ids" .= mlProfileRequestTaskIds, + "return_all_tasks" .= mlProfileRequestReturnAllTasks, + "return_all_models" .= mlProfileRequestReturnAllModels + ] + +-- | The @predict_request_stats@ sub-object on a model profile: latency +-- in milliseconds. @count@ is an integer; the percentile and aggregate +-- fields are floats. Every field is 'Maybe' because a model that has not +-- yet served a predict emits only @count = 0@ (or omits stats entirely). +data MLProfilePredictRequestStats = MLProfilePredictRequestStats + { mlProfileStatsCount :: Maybe Integer, + mlProfileStatsMax :: Maybe Double, + mlProfileStatsMin :: Maybe Double, + mlProfileStatsAverage :: Maybe Double, + mlProfileStatsP50 :: Maybe Double, + mlProfileStatsP90 :: Maybe Double, + mlProfileStatsP99 :: Maybe Double + } + deriving stock (Eq, Show) + +instance FromJSON MLProfilePredictRequestStats where + parseJSON = withObject "MLProfilePredictRequestStats" $ \v -> do + mlProfileStatsCount <- v .:? "count" + mlProfileStatsMax <- v .:? "max" + mlProfileStatsMin <- v .:? "min" + mlProfileStatsAverage <- v .:? "average" + mlProfileStatsP50 <- v .:? "p50" + mlProfileStatsP90 <- v .:? "p90" + mlProfileStatsP99 <- v .:? "p99" + pure MLProfilePredictRequestStats {..} + +instance ToJSON MLProfilePredictRequestStats where + toJSON MLProfilePredictRequestStats {..} = + omitNulls + [ "count" .= mlProfileStatsCount, + "max" .= mlProfileStatsMax, + "min" .= mlProfileStatsMin, + "average" .= mlProfileStatsAverage, + "p50" .= mlProfileStatsP50, + "p90" .= mlProfileStatsP90, + "p99" .= mlProfileStatsP99 + ] + +-- | Per-model runtime state under a node. @worker_nodes@ is the plugin's +-- routing table for the model (which nodes host chunks). @predictor@ is +-- an opaque JVM class handle string. +data MLProfileModel = MLProfileModel + { mlProfileModelModelState :: Maybe ModelState, + mlProfileModelPredictor :: Maybe Text, + mlProfileModelWorkerNodes :: Maybe [Text], + mlProfileModelPredictRequestStats :: Maybe MLProfilePredictRequestStats + } + deriving stock (Eq, Show) + +instance FromJSON MLProfileModel where + parseJSON = withObject "MLProfileModel" $ \v -> do + mlProfileModelModelState <- v .:? "model_state" + mlProfileModelPredictor <- v .:? "predictor" + mlProfileModelWorkerNodes <- v .:? "worker_nodes" + mlProfileModelPredictRequestStats <- v .:? "predict_request_stats" + pure MLProfileModel {..} + +instance ToJSON MLProfileModel where + toJSON MLProfileModel {..} = + omitNulls + [ "model_state" .= mlProfileModelModelState, + "predictor" .= mlProfileModelPredictor, + "worker_nodes" .= mlProfileModelWorkerNodes, + "predict_request_stats" .= mlProfileModelPredictRequestStats + ] + +-- | Per-node entry in the profile response. The @models@ map is keyed by +-- model id; @tasks@ is optional (present when @return_all_tasks@ is +-- true). @tasks@ is kept as an opaque 'Value' because its sub-shape is +-- plugin-version-dependent and the typed surface above only models the +-- model-profile form. +data MLProfileNode = MLProfileNode + { mlProfileNodeModels :: M.Map Text MLProfileModel, + mlProfileNodeTasks :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON MLProfileNode where + parseJSON = withObject "MLProfileNode" $ \v -> do + mModels <- v .:? "models" + let mlProfileNodeModels = case mModels of + Nothing -> M.empty + Just o -> M.fromList [(toText k, r) | (k, r) <- KM.toList o] + mlProfileNodeTasks <- v .:? "tasks" + pure MLProfileNode {..} + +instance ToJSON MLProfileNode where + toJSON MLProfileNode {..} = + omitNulls + [ "models" .= object [fromText k .= toJSON m | (k, m) <- M.toList mlProfileNodeModels], + "tasks" .= mlProfileNodeTasks + ] + +-- | Response of every @GET /_plugins/_ml/profile*@ form: +-- @{\"nodes\": {: {...}}}@. +newtype MLProfileResponse = MLProfileResponse + { mlProfileResponseNodes :: M.Map Text MLProfileNode + } + deriving stock (Eq, Show) + +instance FromJSON MLProfileResponse where + parseJSON = withObject "MLProfileResponse" $ \v -> do + mNodes <- v .:? "nodes" + let mlProfileResponseNodes = case mNodes of + Nothing -> M.empty + Just o -> M.fromList [(toText k, r) | (k, r) <- KM.toList o] + pure MLProfileResponse {..} + +instance ToJSON MLProfileResponse where + toJSON (MLProfileResponse m) = + object + [ "nodes" .= object [fromText k .= toJSON n | (k, n) <- M.toList m] + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLStats.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLStats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLStats.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLStats + ( MLNodeId (..), + MLStatName (..), + MLStats (..), + ) +where + +import Data.Map.Strict qualified as Map +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The @GET /_plugins/_ml\/stats@ endpoint (ML Commons plugin, see +-- ) returns +-- a JSON object whose top-level keys are either cluster-level stat names +-- (mapping to scalars, e.g. @ml_model_count@, @ml_connector_count@, +-- @ml_model_index_status@) or the literal key @nodes@, whose value is a +-- per-node map keyed by opaque node ID. The stat-name set is large and +-- explicitly version-gated by the plugin (each stat carries the OpenSearch +-- version that introduced it), and the cluster-level stat keys are not +-- syntactically distinguishable from the @nodes@ key (both are bare JSON +-- object keys). Modelling the body as a typed record would lock the client +-- to one plugin version and require churn on every release, so the body is +-- kept as a flat 'Map.Map Text Value' — callers get a typed envelope and +-- navigate to the per-node map (via @'Map.lookup' \"nodes\"@) or to any +-- individual cluster stat with the aeson combinators they already use +-- elsewhere. +-- +-- Unlike the Neural Search plugin's @\/_plugins\/_neural\/stats@ endpoint, +-- this endpoint is always available whenever the ML Commons plugin is +-- installed; no cluster setting needs to be enabled. + +-- | A node ID for the ML Commons plugin's +-- @\/_plugins\/_ml\/{nodeId}\/stats@ path segment. OpenSearch uses +-- 22-character opaque node IDs (the same identifiers returned by +-- @GET \/_nodes@); we wrap 'Text' so the value round-trips through JSON as a +-- bare string but is distinct from 'NodeName' \/ 'FullNodeId' / +-- 'NeuralNodeId' at the type level. +newtype MLNodeId = MLNodeId {unMLNodeId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A stat name filter for the +-- @\/_plugins\/_ml\/stats\/{stat}@ path segment. Each value matches one of +-- the plugin's stat-name constants (case-insensitive on the server); the +-- full set changes across OpenSearch releases, so this is intentionally a +-- thin 'Text' newtype rather than a closed enum. Representative values +-- include @ml_executing_task_count@, @ml_request_count@, @ml_failure_count@, +-- @ml_jvm_heap_usage@, @ml_deployed_model_count@, +-- @ml_circuit_breaker_trigger_count@ (node-level), and @ml_model_count@, +-- @ml_connector_count@, @ml_model_index_status@ (cluster-level). +newtype MLStatName = MLStatName {unMLStatName :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Response of @GET /_plugins/_ml/stats@. The body is a JSON object whose +-- top-level keys are either cluster-level stat names (mapping to scalars) or +-- the literal key @nodes@ (mapping to a per-node map keyed by opaque node +-- ID); see the module docs for why the entries are kept as aeson 'Value's +-- rather than modelled per-stat. The 'Map.Map' round-trips a flat JSON +-- object via its aeson instances, so no custom 'ToJSON' \/ 'FromJSON' is +-- needed. To reach per-node stats, decode the @nodes@ value, e.g.: +-- +-- @ +-- case 'Map.lookup' \"nodes\" (mlStatsEntries stats) of +-- 'Just' ('Object' m) -> ... navigate m with aeson KeyMap combinators ... +-- _ -> 'Nothing' +-- @ +newtype MLStats = MLStats {mlStatsEntries :: Map.Map Text Value} + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLTask.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLTask.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/MLTask.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLTask + ( MLTaskId (..), + MLTaskType (..), + MLTaskState (..), + MLTaskInfo (..), + TrainModelRequest (..), + TrainAndPredictResponse (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withObject, withText, (.:), (.:?), (.=)) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Vector (toList) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) + +-- $schema +-- +-- The @GET /_plugins/_ml/tasks/{task_id}@ endpoint +-- () +-- returns the current state of a single ML Commons task. Tasks are created by +-- the asynchronous model APIs (@POST /_plugins/_ml/models/_register@, +-- @POST /_plugins/_ml/models/{id}/_deploy@, training, ...) and survive until +-- they are cleaned up by the plugin. A caller polls 'getMLTask' with the +-- @task_id@ returned by the submit endpoint until 'mlTaskInfoState' reaches +-- 'MLTaskStateCompleted' or 'MLTaskStateFailed'. +-- +-- The response shape is small and stable, so it is modelled as a typed +-- record. Every field is 'Maybe' because the plugin emits different subsets +-- depending on the task's lifecycle state (a @CREATED@ task has no +-- @last_update_time@; a @FAILED@ task carries an @error@ string; etc.) and +-- because the @task_type@ \/ @state@ enums gain values across plugin +-- releases. The enum decoders fall through to an @Other@ constructor for +-- unknown values rather than failing, so a newer plugin emitting a task type +-- the client does not know about round-trips losslessly instead of throwing +-- — the same forward-compatibility rationale documented for the dynamic +-- bodies of 'Database.Bloodhound.OpenSearch3.Types.NeuralStats'. +-- +-- /Note/: the @worker_node@ field changed shape between OpenSearch versions. +-- OS 1.x emits a single string; OS 2.x+ emits an array of strings. The +-- 'FromJSON' instance tolerates both shapes (coercing a single string to a +-- one-element list) so the same client works against every backend version +-- without forcing a parse failure on either. + +-- | A task identifier for the ML Commons plugin's +-- @\/_plugins\/_ml\/tasks\/{task_id}@ path segment. The value is the opaque +-- string returned in the @task_id@ field of @POST /_plugins/_ml/models/_register@ +-- and friends; we wrap 'Text' so the value round-trips through JSON as a bare +-- string but is distinct from 'KnnNodeId' \/ 'NeuralNodeId' \/ the ES-core +-- 'Database.Bloodhound.Internal.Versions.Common.Types.Task.TaskInfo' id at the +-- type level. +newtype MLTaskId = MLTaskId {unMLTaskId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @task_type@ enum reported by 'getMLTask'. The plugin emits this as an +-- upper-snake-case string (@REGISTER_MODEL@, @DEPLOY_MODEL@, ...). The set +-- grows across releases (remote / streaming / async variants landed in OS 2.x +-- and 3.x); unknown values decode to 'MLTaskTypeOther' so the client does not +-- break when polling a task whose type the library has not been taught about. +data MLTaskType + = MLTaskTypeRegisterModel + | MLTaskTypeDeployModel + | MLTaskTypeTraining + | MLTaskTypeRegisterRemoteModel + | MLTaskTypeDeployRemoteModel + | MLTaskTypeOther Text + deriving stock (Eq, Show) + +instance ToJSON MLTaskType where + toJSON = toJSON . renderMLTaskType + +instance FromJSON MLTaskType where + parseJSON = withText "MLTaskType" $ \case + "REGISTER_MODEL" -> pure MLTaskTypeRegisterModel + "DEPLOY_MODEL" -> pure MLTaskTypeDeployModel + "TRAINING" -> pure MLTaskTypeTraining + "REGISTER_REMOTE_MODEL" -> pure MLTaskTypeRegisterRemoteModel + "DEPLOY_REMOTE_MODEL" -> pure MLTaskTypeDeployRemoteModel + other -> pure (MLTaskTypeOther other) + +renderMLTaskType :: MLTaskType -> Text +renderMLTaskType = \case + MLTaskTypeRegisterModel -> "REGISTER_MODEL" + MLTaskTypeDeployModel -> "DEPLOY_MODEL" + MLTaskTypeTraining -> "TRAINING" + MLTaskTypeRegisterRemoteModel -> "REGISTER_REMOTE_MODEL" + MLTaskTypeDeployRemoteModel -> "DEPLOY_REMOTE_MODEL" + MLTaskTypeOther t -> t + +-- | The @state@ enum reported by 'getMLTask'. The lifecycle is +-- @CREATED -> RUNNING -> COMPLETED@ on success or @FAILED@ on error; the +-- plugin additionally emits @NOT_FOUND@ when the supplied task id has been +-- cleaned up. Unknown values decode to 'MLTaskStateOther' for forward +-- compatibility. +data MLTaskState + = MLTaskStateCreated + | MLTaskStateRunning + | MLTaskStateCompleted + | MLTaskStateFailed + | MLTaskStateNotFound + | MLTaskStateOther Text + deriving stock (Eq, Show) + +instance ToJSON MLTaskState where + toJSON = toJSON . renderMLTaskState + +instance FromJSON MLTaskState where + parseJSON = withText "MLTaskState" $ \case + "CREATED" -> pure MLTaskStateCreated + "RUNNING" -> pure MLTaskStateRunning + "COMPLETED" -> pure MLTaskStateCompleted + "FAILED" -> pure MLTaskStateFailed + "NOT_FOUND" -> pure MLTaskStateNotFound + other -> pure (MLTaskStateOther other) + +renderMLTaskState :: MLTaskState -> Text +renderMLTaskState = \case + MLTaskStateCreated -> "CREATED" + MLTaskStateRunning -> "RUNNING" + MLTaskStateCompleted -> "COMPLETED" + MLTaskStateFailed -> "FAILED" + MLTaskStateNotFound -> "NOT_FOUND" + MLTaskStateOther t -> t + +-- | Response of @GET /_plugins/_ml/tasks/{task_id}@. Every field is 'Maybe' +-- because the plugin emits different subsets depending on the task's +-- lifecycle state and the OpenSearch version (see the module-level docs). +data MLTaskInfo = MLTaskInfo + { mlTaskInfoTaskId :: Maybe Text, + mlTaskInfoModelId :: Maybe Text, + mlTaskInfoTaskType :: Maybe MLTaskType, + mlTaskInfoFunctionName :: Maybe Text, + mlTaskInfoState :: Maybe MLTaskState, + mlTaskInfoWorkerNode :: Maybe [Text], + mlTaskInfoCreateTime :: Maybe Int64, + mlTaskInfoLastUpdateTime :: Maybe Int64, + mlTaskInfoIsAsync :: Maybe Bool, + mlTaskInfoError :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON MLTaskInfo where + parseJSON = withObject "MLTaskInfo" $ \o -> do + mlTaskInfoTaskId <- o .:? "task_id" + mlTaskInfoModelId <- o .:? "model_id" + mlTaskInfoTaskType <- o .:? "task_type" + mlTaskInfoFunctionName <- o .:? "function_name" + mlTaskInfoState <- o .:? "state" + mWorkerNode <- o .:? "worker_node" + let mlTaskInfoWorkerNode = case mWorkerNode of + Nothing -> Nothing + Just (String s) -> Just [s] + Just (Array xs) -> Just [t | String t <- toList xs] + Just _ -> Nothing + mlTaskInfoCreateTime <- o .:? "create_time" + mlTaskInfoLastUpdateTime <- o .:? "last_update_time" + mlTaskInfoIsAsync <- o .:? "is_async" + mlTaskInfoError <- o .:? "error" + return MLTaskInfo {..} + +instance ToJSON MLTaskInfo where + toJSON MLTaskInfo {..} = + omitNulls + [ "task_id" .= mlTaskInfoTaskId, + "model_id" .= mlTaskInfoModelId, + "task_type" .= mlTaskInfoTaskType, + "function_name" .= mlTaskInfoFunctionName, + "state" .= mlTaskInfoState, + "worker_node" .= mlTaskInfoWorkerNode, + "create_time" .= mlTaskInfoCreateTime, + "last_update_time" .= mlTaskInfoLastUpdateTime, + "is_async" .= mlTaskInfoIsAsync, + "error" .= mlTaskInfoError + ] + +-- ========================================================================= +-- Train and train-predict +-- ========================================================================= + +-- $train +-- +-- The @POST /_plugins/_ml/_train/{algorithm}@ and +-- @POST /_plugins/_ml/_train_predict/{algorithm}@ endpoints (see +-- ) +-- run a classical algorithm (kmeans, RCF, ...) against either an +-- index-sourced dataset (@input_query@ + @input_index@) or inline data +-- (@input_data@). The @parameters@ object is algorithm-specific. +-- +-- /Responses:/ train is sync by default (returns @model_id@ + @status@) +-- and async when @?async=true@ is set (returns @task_id@ + @status@). +-- Both shapes are subsets of 'MLTaskAck', so the train request functions +-- reuse 'MLTaskAck' as their response type. Train-predict is always sync +-- and returns the prediction payload, modelled as +-- 'TrainAndPredictResponse'. + +-- | Request body for @POST /_plugins/_ml/_train/{algorithm}@ and +-- @POST /_plugins/_ml/_train_predict/{algorithm}@. Exactly one of +-- @input_query@+@input_index@ or @input_data@ must be supplied; the +-- plugin validates the combination. @parameters@ is required and +-- algorithm-specific, so it is an opaque 'Value'. +data TrainModelRequest = TrainModelRequest + { trainModelParameters :: Value, + trainModelInputQuery :: Maybe Value, + trainModelInputIndex :: Maybe [Text], + trainModelInputData :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON TrainModelRequest where + parseJSON = withObject "TrainModelRequest" $ \v -> do + trainModelParameters <- v .: "parameters" + trainModelInputQuery <- v .:? "input_query" + trainModelInputIndex <- v .:? "input_index" + trainModelInputData <- v .:? "input_data" + pure TrainModelRequest {..} + +instance ToJSON TrainModelRequest where + toJSON TrainModelRequest {..} = + omitNulls + [ "parameters" .= trainModelParameters, + "input_query" .= trainModelInputQuery, + "input_index" .= trainModelInputIndex, + "input_data" .= trainModelInputData + ] + +-- | Response of @POST /_plugins/_ml/_train_predict/{algorithm}@: +-- @{status, prediction_result}@. The @prediction_result@ payload carries +-- @column_metas@ and @rows@ whose shape is algorithm-specific, so it is +-- kept as an opaque 'Value'. +data TrainAndPredictResponse = TrainAndPredictResponse + { trainAndPredictResponseStatus :: Maybe Text, + trainAndPredictResponsePredictionResult :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON TrainAndPredictResponse where + parseJSON = withObject "TrainAndPredictResponse" $ \v -> do + trainAndPredictResponseStatus <- v .:? "status" + trainAndPredictResponsePredictionResult <- v .:? "prediction_result" + pure TrainAndPredictResponse {..} + +instance ToJSON TrainAndPredictResponse where + toJSON TrainAndPredictResponse {..} = + omitNulls + [ "status" .= trainAndPredictResponseStatus, + "prediction_result" .= trainAndPredictResponsePredictionResult + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/NeuralStats.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/NeuralStats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/NeuralStats.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.NeuralStats + ( NeuralNodeId (..), + NeuralStatName (..), + NeuralStats (..), + + -- * URI parameters + NeuralStatsOptions (..), + defaultNeuralStatsOptions, + neuralStatsOptionsParams, + + -- * Optics + nsoIncludeInfoLens, + nsoIncludeAllNodesLens, + nsoIncludeIndividualNodesLens, + ) +where + +import Data.Map.Strict qualified as Map +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The @GET /_plugins/_neural\/stats@ endpoint +-- () returns a body with +-- up to three top-level sections, each individually optional and toggled by +-- the @include_info@, @include_all_nodes@ and @include_individual_nodes@ +-- query parameters: +-- +-- @ +-- { +-- "info": { ... cluster-wide info stats ... }, +-- "all_nodes": { ... event/metric stats aggregated across nodes ... }, +-- "nodes": { "<22-char-node-id>": { ... same shape as all_nodes ... } } +-- } +-- @ +-- +-- The stat-name set is large (50+ entries as of OS 3.5) and explicitly +-- version-gated by the plugin (each stat carries the OpenSearch version that +-- introduced it). Modelling each stat as a typed Haskell record would lock +-- the client to one plugin version and require churn on every release, so +-- the section bodies are intentionally kept as aeson 'Value's — callers get +-- a typed envelope and navigate the dynamic stat body with the aeson +-- combinators they already use elsewhere. +-- +-- The endpoint is disabled by default and returns HTTP 403 (plain-text body +-- @Stats endpoint is disabled@) until the cluster setting +-- @plugins.neural_search.stats_enabled@ is set to @true@. The route and the +-- three-section wire shape are live-verified on OS 3.7.0 (bead +-- bloodhound-6py); the OpenSearch docs site does not document this endpoint. +-- A live response also prepends an @_nodes@ \/ @cluster_name@ envelope that +-- the 'NeuralStats' decoder ignores. + +-- | A node ID for the Neural Search plugin's +-- @\/_plugins\/_neural\/{nodeId}\/stats@ path segment. OpenSearch uses +-- 22-character opaque node IDs (the same identifiers returned by +-- @GET \/_nodes@); we wrap 'Text' so the value round-trips through JSON as a +-- bare string but is distinct from 'NodeName' \/ 'FullNodeId' at the type +-- level. +newtype NeuralNodeId = NeuralNodeId {unNeuralNodeId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | A stat name filter for the +-- @\/_plugins\/_neural\/stats\/{stat}@ path segment. Each value matches one +-- of the plugin's @StatName@ constants (case-insensitive); the full set +-- changes across OpenSearch releases, so this is intentionally a thin +-- 'Text' newtype rather than a closed enum. +newtype NeuralStatName = NeuralStatName {unNeuralStatName :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Response of @GET /_plugins/_neural/stats@. Each section is optional +-- because the request's @include_*@ query parameters control which sections +-- the server emits; absent sections decode as 'Nothing' rather than failing. +data NeuralStats = NeuralStats + { neuralStatsInfo :: Maybe Value, + neuralStatsAllNodes :: Maybe Value, + neuralStatsNodes :: Maybe (Map.Map Text Value) + } + deriving stock (Eq, Show) + +instance FromJSON NeuralStats where + parseJSON = withObject "NeuralStats" $ \o -> do + neuralStatsInfo <- o .:? "info" + neuralStatsAllNodes <- o .:? "all_nodes" + neuralStatsNodes <- o .:? "nodes" + return NeuralStats {..} + +instance ToJSON NeuralStats where + toJSON NeuralStats {..} = + omitNulls + [ "info" .= neuralStatsInfo, + "all_nodes" .= neuralStatsAllNodes, + "nodes" .= neuralStatsNodes + ] + +-- | URI parameters accepted by the Neural Search plugin Stats API +-- (@GET /_plugins/_neural\/[\/{nodeId}]\/stats[\/{stat}]@). Each field maps +-- 1:1 to one of the three documented @include_*@ query parameters that +-- toggle which top-level sections (@info@, @all_nodes@, @nodes@) the server +-- emits in the response. +-- +-- The fields are tri-state: 'Nothing' (the default) omits the parameter so +-- the server applies its own defaults; 'Just' 'True' emits +-- @include_X=true@ and 'Just' 'False' emits @include_X=false@, letting the +-- caller explicitly request or suppress each section. See +-- (RestNeuralStatsAction). +data NeuralStatsOptions = NeuralStatsOptions + { -- | @include_info@ — toggles the cluster-wide @info@ section. + nsoIncludeInfo :: Maybe Bool, + -- | @include_all_nodes@ — toggles the aggregated @all_nodes@ section. + nsoIncludeAllNodes :: Maybe Bool, + -- | @include_individual_nodes@ — toggles the per-node @nodes@ map. + nsoIncludeIndividualNodes :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | 'NeuralStatsOptions' with every parameter set to 'Nothing'. Produces no +-- query string, so a call made with this value is byte-identical to the +-- legacy 'Database.Bloodhound.OpenSearch3.Requests.getNeuralStats' wire +-- shape (no @include_*@ parameters). +defaultNeuralStatsOptions :: NeuralStatsOptions +defaultNeuralStatsOptions = + NeuralStatsOptions + { nsoIncludeInfo = Nothing, + nsoIncludeAllNodes = Nothing, + nsoIncludeIndividualNodes = Nothing + } + +nsoIncludeInfoLens :: Lens' NeuralStatsOptions (Maybe Bool) +nsoIncludeInfoLens = lens nsoIncludeInfo (\x y -> x {nsoIncludeInfo = y}) + +nsoIncludeAllNodesLens :: Lens' NeuralStatsOptions (Maybe Bool) +nsoIncludeAllNodesLens = lens nsoIncludeAllNodes (\x y -> x {nsoIncludeAllNodes = y}) + +nsoIncludeIndividualNodesLens :: Lens' NeuralStatsOptions (Maybe Bool) +nsoIncludeIndividualNodesLens = + lens nsoIncludeIndividualNodes (\x y -> x {nsoIncludeIndividualNodes = y}) + +-- | Render a 'NeuralStatsOptions' as the query-string pairs accepted by the +-- Neural Search Stats API. 'Nothing' fields are omitted, so +-- 'defaultNeuralStatsOptions' produces an empty list. The order of the +-- returned list is stable but /unspecified/ — callers (including tests) +-- should treat it as a set and not pattern-match on the head. The +-- underlying 'withQueries' is order-insensitive. +neuralStatsOptionsParams :: NeuralStatsOptions -> [(Text, Maybe Text)] +neuralStatsOptionsParams NeuralStatsOptions {..} = + catMaybes + [ flag "include_info" nsoIncludeInfo, + flag "include_all_nodes" nsoIncludeAllNodes, + flag "include_individual_nodes" nsoIncludeIndividualNodes + ] + where + flag k (Just b) = Just (k, Just (if b then "true" else "false")) + flag _ Nothing = Nothing diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/Notifications.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/Notifications.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/Notifications.hs @@ -0,0 +1,1021 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.Notifications + ( NotificationConfigType (..), + notificationConfigTypeText, + NotificationTransport (..), + NotificationConfig (..), + NotificationConfigEntry (..), + GetNotificationConfigsResponse (..), + Channel (..), + GetNotificationChannelsResponse (..), + NotificationSortOrder (..), + notificationSortOrderText, + NotificationListOptions (..), + defaultNotificationListOptions, + notificationListOptionsParams, + CreateNotificationConfigRequest (..), + CreateNotificationConfigResponse (..), + UpdateNotificationConfigRequest (..), + DeleteNotificationConfigResponse (..), + deleteResponseStatus, + deleteResponseAllOK, + NotificationFeaturesResponse (..), + TestNotificationResponse (..), + TestNotificationEventSource (..), + TestNotificationStatus (..), + TestNotificationDeliveryStatus (..), + SlackTransport (..), + ChimeTransport (..), + WebhookTransport (..), + MicrosoftTeamsTransport (..), + SnsTransport (..), + SesAccountTransport (..), + SmtpAccountTransport (..), + SmtpMethod (..), + EmailGroupTransport (..), + EmailTransport (..), + EmailRecipient (..), + NotificationTotalRelation (..), + transportConfigType, + ) +where + +import Data.Aeson.Key qualified as K (fromText) +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports +import Numeric.Natural (Natural) + +-- $schema +-- +-- The Notifications plugin (see +-- ) +-- centralizes outbound notification delivery for other OpenSearch plugins +-- (Alerting, Index State Management, Anomaly Detection, ...). A +-- 'NotificationConfig' binds a user-chosen name and description to a +-- /transport/ — the concrete delivery channel (Slack, Chime, Webhook, +-- Microsoft Teams, Amazon SNS, Amazon SES, SMTP account, email group, +-- or a fully-formed Email channel). +-- +-- The plugin is shipped with OpenSearch 2.0+; it is not present on 1.x +-- clusters, hence this module exists only for OS2 and OS3. +-- +-- The wire shape of a 'NotificationConfig' is a flat JSON object whose +-- @config_type@ field names the transport variant, and which additionally +-- embeds /exactly one/ transport object under a variant-specific key +-- (@slack@, @chime@, @webhook@, @microsoft_teams@, @sns@, @ses_account@, +-- @smtp_account@, @email_group@, @email@). The Haskell surface models +-- this as a sum type ('NotificationTransport') and derives the +-- @config_type@ tag from the chosen variant via 'transportConfigType', so +-- a 'NotificationConfig' cannot be constructed with an inconsistent +-- (config_type, transport) pair. +-- +-- The create endpoint is asynchronous and synchronous at once: the POST +-- returns as soon as the config is persisted to the +-- @.opendistro-notifications-config@ system index, echoing the new +-- @config_id@ (server-assigned unless the caller supplies one). There is +-- no task to poll. +-- +-- Doc ambiguities handled here deliberately: +-- +-- * The plugin docs show both @config_id@ and @id@ as the top-level +-- identifier on POST. We read only @config_id@; a body carrying @id@ +-- instead parses to a request with @config_id = Nothing@ (aeson +-- ignores unknown fields), so the server will generate one regardless. +-- * The @email.recipient_list@ example is shown both as +-- @[\"a\@b.com\"]\@@ (bare strings) and @[{\"recipient\":\"a\@b.com\"}]\@@ +-- (objects); the @email_group@ example is object-shaped. We accept +-- both shapes on decode (see 'EmailRecipient'); 'ToJSON' always emits +-- the object form, so a bare-string input round-trips to the object +-- form. +-- * @smtp_account.method@ values are not fully enumerated in the docs; +-- the field is typed as 'Text' (not a closed enum) so adding a new +-- method (e.g. @none@ vs @ssl@ vs @start_tls@) does not require a +-- library release. + +-- | The 9-variant @config_type@ enum documented at +-- . +-- Serialization is lower-snake to match the wire shape exactly +-- (@ses_account@, @smtp_account@, @email_group@, @microsoft_teams@). +-- Unknown values parse-fail so a future plugin release adding a tenth +-- config type surfaces as a deliberate error rather than a silent drop. +data NotificationConfigType + = NotificationConfigTypeSlack + | NotificationConfigTypeChime + | NotificationConfigTypeWebhook + | NotificationConfigTypeMicrosoftTeams + | NotificationConfigTypeSns + | NotificationConfigTypeSesAccount + | NotificationConfigTypeSmtpAccount + | NotificationConfigTypeEmailGroup + | NotificationConfigTypeEmail + deriving stock (Eq, Show) + +instance ToJSON NotificationConfigType where + toJSON = \case + NotificationConfigTypeSlack -> "slack" + NotificationConfigTypeChime -> "chime" + NotificationConfigTypeWebhook -> "webhook" + NotificationConfigTypeMicrosoftTeams -> "microsoft_teams" + NotificationConfigTypeSns -> "sns" + NotificationConfigTypeSesAccount -> "ses_account" + NotificationConfigTypeSmtpAccount -> "smtp_account" + NotificationConfigTypeEmailGroup -> "email_group" + NotificationConfigTypeEmail -> "email" + +instance FromJSON NotificationConfigType where + parseJSON = withText "NotificationConfigType" $ \case + "slack" -> pure NotificationConfigTypeSlack + "chime" -> pure NotificationConfigTypeChime + "webhook" -> pure NotificationConfigTypeWebhook + "microsoft_teams" -> pure NotificationConfigTypeMicrosoftTeams + "sns" -> pure NotificationConfigTypeSns + "ses_account" -> pure NotificationConfigTypeSesAccount + "smtp_account" -> pure NotificationConfigTypeSmtpAccount + "email_group" -> pure NotificationConfigTypeEmailGroup + "email" -> pure NotificationConfigTypeEmail + other -> fail ("Unknown NotificationConfigType: " <> T.unpack other) + +-- | The wire string for a 'NotificationConfigType' — the same mapping +-- the 'ToJSON' \/ 'FromJSON' instances use, exposed as a plain 'Text' +-- accessor for callers (e.g. 'notificationListOptionsParams') that +-- need the wire string without going through a 'Data.Aeson.Value'. +notificationConfigTypeText :: NotificationConfigType -> Text +notificationConfigTypeText = \case + NotificationConfigTypeSlack -> "slack" + NotificationConfigTypeChime -> "chime" + NotificationConfigTypeWebhook -> "webhook" + NotificationConfigTypeMicrosoftTeams -> "microsoft_teams" + NotificationConfigTypeSns -> "sns" + NotificationConfigTypeSesAccount -> "ses_account" + NotificationConfigTypeSmtpAccount -> "smtp_account" + NotificationConfigTypeEmailGroup -> "email_group" + NotificationConfigTypeEmail -> "email" + +-- | The transport sum type. Each variant corresponds to exactly one +-- 'NotificationConfigType' (see 'transportConfigType') and serializes to +-- a single wire key matching that type. Construct a +-- 'NotificationTransport' first; the surrounding 'NotificationConfig' +-- derives its @config_type@ from the variant. +data NotificationTransport + = NotificationTransportSlack SlackTransport + | NotificationTransportChime ChimeTransport + | NotificationTransportWebhook WebhookTransport + | NotificationTransportMicrosoftTeams MicrosoftTeamsTransport + | NotificationTransportSns SnsTransport + | NotificationTransportSesAccount SesAccountTransport + | NotificationTransportSmtpAccount SmtpAccountTransport + | NotificationTransportEmailGroup EmailGroupTransport + | NotificationTransportEmail EmailTransport + deriving stock (Eq, Show) + +-- | Recover the 'NotificationConfigType' tag from a 'NotificationTransport'. +-- Used by 'NotificationConfig''s 'ToJSON' to emit a @config_type@ field +-- consistent with the chosen variant, and by tests to assert cross-variant +-- invariants. +transportConfigType :: NotificationTransport -> NotificationConfigType +transportConfigType = \case + NotificationTransportSlack _ -> NotificationConfigTypeSlack + NotificationTransportChime _ -> NotificationConfigTypeChime + NotificationTransportWebhook _ -> NotificationConfigTypeWebhook + NotificationTransportMicrosoftTeams _ -> NotificationConfigTypeMicrosoftTeams + NotificationTransportSns _ -> NotificationConfigTypeSns + NotificationTransportSesAccount _ -> NotificationConfigTypeSesAccount + NotificationTransportSmtpAccount _ -> NotificationConfigTypeSmtpAccount + NotificationTransportEmailGroup _ -> NotificationConfigTypeEmailGroup + NotificationTransportEmail _ -> NotificationConfigTypeEmail + +-- | Produce the single wire key\/value pair carried by a transport variant. +transportPair :: NotificationTransport -> (Key, Value) +transportPair = \case + NotificationTransportSlack t -> ("slack", toJSON t) + NotificationTransportChime t -> ("chime", toJSON t) + NotificationTransportWebhook t -> ("webhook", toJSON t) + NotificationTransportMicrosoftTeams t -> ("microsoft_teams", toJSON t) + NotificationTransportSns t -> ("sns", toJSON t) + NotificationTransportSesAccount t -> ("ses_account", toJSON t) + NotificationTransportSmtpAccount t -> ("smtp_account", toJSON t) + NotificationTransportEmailGroup t -> ("email_group", toJSON t) + NotificationTransportEmail t -> ("email", toJSON t) + +instance ToJSON NotificationTransport where + toJSON t = object [transportPair t] + +instance FromJSON NotificationTransport where + parseJSON = withObject "NotificationTransport" $ \v -> do + -- Exactly one transport key may be present; the plugin rejects + -- multi-transport bodies server-side. We mirror that here by + -- checking which known keys are present and failing on zero or + -- multiple. This catches wire bugs (e.g. a body that accidentally + -- carries both @slack@ and @chime@) at decode time rather than + -- letting aeson silently pick the first matching variant. + let known = + [ ("slack", NotificationTransportSlack <$> v .: "slack"), + ("chime", NotificationTransportChime <$> v .: "chime"), + ("webhook", NotificationTransportWebhook <$> v .: "webhook"), + ("microsoft_teams", NotificationTransportMicrosoftTeams <$> v .: "microsoft_teams"), + ("sns", NotificationTransportSns <$> v .: "sns"), + ("ses_account", NotificationTransportSesAccount <$> v .: "ses_account"), + ("smtp_account", NotificationTransportSmtpAccount <$> v .: "smtp_account"), + ("email_group", NotificationTransportEmailGroup <$> v .: "email_group"), + ("email", NotificationTransportEmail <$> v .: "email") + ] + present = [parser | (key, parser) <- known, KM.member (K.fromText key) v] + case present of + [single] -> single + [] -> fail "NotificationTransport: no transport key present" + _ -> fail "NotificationTransport: multiple transport keys present" + +-- | Slack incoming-webhook transport. The @url@ field is the +-- @https:\/\/hooks.slack.com\/...@ webhook the plugin POSTs the message +-- payload to. +newtype SlackTransport = SlackTransport + { slackTransportUrl :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SlackTransport where + parseJSON = withObject "SlackTransport" $ \v -> + SlackTransport <$> v .: "url" + +instance ToJSON SlackTransport where + toJSON SlackTransport {..} = + object ["url" .= slackTransportUrl] + +-- | Amazon Chime incoming-webhook transport. +newtype ChimeTransport = ChimeTransport + { chimeTransportUrl :: Text + } + deriving stock (Eq, Show) + +instance FromJSON ChimeTransport where + parseJSON = withObject "ChimeTransport" $ \v -> + ChimeTransport <$> v .: "url" + +instance ToJSON ChimeTransport where + toJSON ChimeTransport {..} = + object ["url" .= chimeTransportUrl] + +-- | Generic webhook transport (custom HTTP endpoint). +newtype WebhookTransport = WebhookTransport + { webhookTransportUrl :: Text + } + deriving stock (Eq, Show) + +instance FromJSON WebhookTransport where + parseJSON = withObject "WebhookTransport" $ \v -> + WebhookTransport <$> v .: "url" + +instance ToJSON WebhookTransport where + toJSON WebhookTransport {..} = + object ["url" .= webhookTransportUrl] + +-- | Microsoft Teams incoming-webhook transport. +newtype MicrosoftTeamsTransport = MicrosoftTeamsTransport + { microsoftTeamsTransportUrl :: Text + } + deriving stock (Eq, Show) + +instance FromJSON MicrosoftTeamsTransport where + parseJSON = withObject "MicrosoftTeamsTransport" $ \v -> + MicrosoftTeamsTransport <$> v .: "url" + +instance ToJSON MicrosoftTeamsTransport where + toJSON MicrosoftTeamsTransport {..} = + object ["url" .= microsoftTeamsTransportUrl] + +-- | Amazon SNS transport. The plugin assumes an IAM role (@role_arn@, +-- optional — the plugin falls back to the cluster's instance role when +-- absent) and publishes to the supplied SNS @topic_arn@. +data SnsTransport = SnsTransport + { snsTransportTopicArn :: Text, + snsTransportRoleArn :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SnsTransport where + parseJSON = withObject "SnsTransport" $ \v -> do + snsTransportTopicArn <- v .: "topic_arn" + snsTransportRoleArn <- v .:? "role_arn" + pure SnsTransport {..} + +instance ToJSON SnsTransport where + toJSON SnsTransport {..} = + omitNulls + [ "topic_arn" .= snsTransportTopicArn, + "role_arn" .= snsTransportRoleArn + ] + +-- | Amazon SES account configuration. Referenced by 'EmailTransport' via +-- its @email_account_id@ field. The plugin assumes the supplied IAM role +-- to send email from @from_address@ in the given AWS region. +data SesAccountTransport = SesAccountTransport + { sesAccountTransportRegion :: Text, + sesAccountTransportRoleArn :: Text, + sesAccountTransportFromAddress :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SesAccountTransport where + parseJSON = withObject "SesAccountTransport" $ \v -> do + sesAccountTransportRegion <- v .: "region" + sesAccountTransportRoleArn <- v .: "role_arn" + sesAccountTransportFromAddress <- v .: "from_address" + pure SesAccountTransport {..} + +instance ToJSON SesAccountTransport where + toJSON SesAccountTransport {..} = + object + [ "region" .= sesAccountTransportRegion, + "role_arn" .= sesAccountTransportRoleArn, + "from_address" .= sesAccountTransportFromAddress + ] + +-- | The @method@ enum on 'SmtpAccountTransport'. The Notifications +-- plugin documents three values: @none@ (plaintext), @ssl@ (implicit +-- TLS), and @start_tls@ (STARTTLS upgrade). +data SmtpMethod + = SmtpMethodNone + | SmtpMethodSsl + | SmtpMethodStartTls + deriving stock (Eq, Show) + +instance FromJSON SmtpMethod where + parseJSON = withText "SmtpMethod" $ \case + "none" -> pure SmtpMethodNone + "ssl" -> pure SmtpMethodSsl + "start_tls" -> pure SmtpMethodStartTls + other -> fail ("unknown SMTP method: " <> T.unpack other) + +instance ToJSON SmtpMethod where + toJSON = \case + SmtpMethodNone -> "none" + SmtpMethodSsl -> "ssl" + SmtpMethodStartTls -> "start_tls" + +-- | SMTP account configuration. Referenced by 'EmailTransport' via its +-- @email_account_id@ field. +data SmtpAccountTransport = SmtpAccountTransport + { smtpAccountTransportHost :: Text, + smtpAccountTransportPort :: Int, + smtpAccountTransportMethod :: SmtpMethod, + smtpAccountTransportFromAddress :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SmtpAccountTransport where + parseJSON = withObject "SmtpAccountTransport" $ \v -> do + smtpAccountTransportHost <- v .: "host" + smtpAccountTransportPort <- v .: "port" + smtpAccountTransportMethod <- v .: "method" + smtpAccountTransportFromAddress <- v .: "from_address" + pure SmtpAccountTransport {..} + +instance ToJSON SmtpAccountTransport where + toJSON SmtpAccountTransport {..} = + object + [ "host" .= smtpAccountTransportHost, + "port" .= smtpAccountTransportPort, + "method" .= smtpAccountTransportMethod, + "from_address" .= smtpAccountTransportFromAddress + ] + +-- | A single email recipient. The plugin serializes this as an object +-- @{"recipient": "..."}@ in both @email.recipient_list@ and +-- @email_group.recipient_list@. The @email.recipient_list@ docs also +-- show a bare-string variant (@"a\@b.com"@); 'FromJSON' accepts both +-- shapes, while 'ToJSON' always emits the object form. As a result a +-- bare-string input round-trips to the object form. +newtype EmailRecipient = EmailRecipient + { emailRecipientRecipient :: Text + } + deriving stock (Eq, Show) + +instance FromJSON EmailRecipient where + parseJSON (String s) = pure (EmailRecipient s) + parseJSON v = + withObject "EmailRecipient" (\o -> EmailRecipient <$> o .: "recipient") v + +instance ToJSON EmailRecipient where + toJSON EmailRecipient {..} = + object ["recipient" .= emailRecipientRecipient] + +-- | A reusable email distribution list. Other configs (notably +-- 'EmailTransport') reference an email group by its @config_id@ via the +-- @email_group_id_list@ field. +data EmailGroupTransport = EmailGroupTransport + { emailGroupTransportRecipientList :: NonEmpty EmailRecipient + } + deriving stock (Eq, Show) + +instance FromJSON EmailGroupTransport where + parseJSON = withObject "EmailGroupTransport" $ \v -> do + recipients <- v .: "recipient_list" + emailGroupTransportRecipientList <- parseNEJSON recipients + pure EmailGroupTransport {..} + +instance ToJSON EmailGroupTransport where + toJSON EmailGroupTransport {..} = + object + [ "recipient_list" .= emailGroupTransportRecipientList + ] + +-- | An email channel bound to a 'SmtpAccountTransport' or +-- 'SesAccountTransport' config (referenced by @email_account_id@) with +-- its own recipient list and an optional set of 'EmailGroupTransport' +-- references via @email_group_id_list@. Note: because the surrounding +-- 'ToJSON' uses 'omitNulls', @'Just' []@ and @'Nothing'@ are +-- indistinguishable on the wire (both produce an absent +-- @email_group_id_list@ field) — the server treats both as "no email +-- groups referenced". Use 'Nothing' for the absent case. +data EmailTransport = EmailTransport + { emailTransportEmailAccountId :: Text, + emailTransportRecipientList :: NonEmpty EmailRecipient, + emailTransportEmailGroupIdList :: Maybe [Text] + } + deriving stock (Eq, Show) + +instance FromJSON EmailTransport where + parseJSON = withObject "EmailTransport" $ \v -> do + emailTransportEmailAccountId <- v .: "email_account_id" + recipients <- v .: "recipient_list" + emailTransportRecipientList <- parseNEJSON recipients + emailTransportEmailGroupIdList <- v .:? "email_group_id_list" + pure EmailTransport {..} + +instance ToJSON EmailTransport where + toJSON EmailTransport {..} = + omitNulls + [ "email_account_id" .= emailTransportEmailAccountId, + "recipient_list" .= emailTransportRecipientList, + "email_group_id_list" .= emailTransportEmailGroupIdList + ] + +-- | The @config@ object embedded in a 'CreateNotificationConfigRequest' +-- and returned inside a config record. The @config_type@ field is +-- /derived/ from 'notificationConfigTransport' via 'transportConfigType' +-- at encode time, so the constructor does not expose a separate +-- @config_type@ field that could disagree with the transport variant. +-- +-- The @is_enabled@ field defaults to @true@ server-side when omitted; +-- modelled as 'Maybe' so @Nothing@ produces the default and @Just False@ +-- explicitly disables the channel. +data NotificationConfig = NotificationConfig + { notificationConfigName :: Text, + notificationConfigDescription :: Maybe Text, + notificationConfigIsEnabled :: Maybe Bool, + notificationConfigTransport :: NotificationTransport + } + deriving stock (Eq, Show) + +instance FromJSON NotificationConfig where + parseJSON = withObject "NotificationConfig" $ \v -> do + notificationConfigName <- v .: "name" + notificationConfigDescription <- v .:? "description" + notificationConfigIsEnabled <- v .:? "is_enabled" + -- Parse config_type for cross-check, then look up the matching + -- transport key. A body whose config_type disagrees with the + -- embedded transport key parse-fails. + configType <- v .: "config_type" + notificationConfigTransport <- case configType of + NotificationConfigTypeSlack -> NotificationTransportSlack <$> v .: "slack" + NotificationConfigTypeChime -> NotificationTransportChime <$> v .: "chime" + NotificationConfigTypeWebhook -> NotificationTransportWebhook <$> v .: "webhook" + NotificationConfigTypeMicrosoftTeams -> + NotificationTransportMicrosoftTeams <$> v .: "microsoft_teams" + NotificationConfigTypeSns -> NotificationTransportSns <$> v .: "sns" + NotificationConfigTypeSesAccount -> + NotificationTransportSesAccount <$> v .: "ses_account" + NotificationConfigTypeSmtpAccount -> + NotificationTransportSmtpAccount <$> v .: "smtp_account" + NotificationConfigTypeEmailGroup -> + NotificationTransportEmailGroup <$> v .: "email_group" + NotificationConfigTypeEmail -> + NotificationTransportEmail <$> v .: "email" + pure NotificationConfig {..} + +instance ToJSON NotificationConfig where + toJSON NotificationConfig {..} = + omitNulls + [ "name" .= notificationConfigName, + "description" .= notificationConfigDescription, + "is_enabled" .= notificationConfigIsEnabled, + "config_type" .= transportConfigType notificationConfigTransport, + transportPair notificationConfigTransport + ] + +-- | Request body for @POST /_plugins/_notifications/configs@. The +-- optional @config_id@ lets the caller supply a stable identifier; when +-- omitted, OpenSearch generates one (and echoes it back in +-- 'CreateNotificationConfigResponse'). Supplying a @config_id@ that +-- already exists results in HTTP 409 Conflict, surfacing as an +-- 'EsError' under 'StatusDependant'. +-- +-- Note: the plugin docs inconsistently show the top-level identifier as +-- both @config_id@ (in the field table and most examples) and @id@ (in +-- one example). We serialize and parse only @config_id@; an @id@ field +-- is silently ignored on decode rather than actively rejected (aeson's +-- default), so callers who send @id@ instead of @config_id@ will see +-- the server generate one regardless. +data CreateNotificationConfigRequest = CreateNotificationConfigRequest + { createNotificationConfigRequestId :: Maybe Text, + createNotificationConfigRequestConfig :: NotificationConfig + } + deriving stock (Eq, Show) + +instance FromJSON CreateNotificationConfigRequest where + parseJSON = withObject "CreateNotificationConfigRequest" $ \v -> do + createNotificationConfigRequestId <- v .:? "config_id" + createNotificationConfigRequestConfig <- v .: "config" + pure CreateNotificationConfigRequest {..} + +instance ToJSON CreateNotificationConfigRequest where + toJSON CreateNotificationConfigRequest {..} = + omitNulls + [ "config_id" .= createNotificationConfigRequestId, + "config" .= createNotificationConfigRequestConfig + ] + +-- | Response of @POST /_plugins/_notifications/configs@. Echoes the +-- resulting @config_id@ — either the caller-supplied value or the +-- server-generated one. The sibling PUT update endpoint +-- ('updateNotificationConfig') returns the same shape. +newtype CreateNotificationConfigResponse = CreateNotificationConfigResponse + { createNotificationConfigResponseConfigId :: Text + } + deriving stock (Eq, Show) + +instance FromJSON CreateNotificationConfigResponse where + parseJSON = withObject "CreateNotificationConfigResponse" $ \v -> + CreateNotificationConfigResponse <$> v .: "config_id" + +instance ToJSON CreateNotificationConfigResponse where + toJSON CreateNotificationConfigResponse {..} = + object ["config_id" .= createNotificationConfigResponseConfigId] + +-- | Request body for @PUT /_plugins/_notifications/configs/{config_id}@ +-- (the update endpoint). Unlike 'CreateNotificationConfigRequest', the +-- update body carries no top-level @config_id@: the identity is the +-- @config_id@ path segment of the PUT URL, and the body is just the +-- wrapped 'NotificationConfig' under the @config@ key. Wiring this as +-- its own type (rather than reusing 'CreateNotificationConfigRequest' +-- with @Nothing@) prevents a caller from accidentally round-tripping +-- a create body through the update endpoint (or vice versa). +newtype UpdateNotificationConfigRequest = UpdateNotificationConfigRequest + { updateNotificationConfigRequestConfig :: NotificationConfig + } + deriving stock (Eq, Show) + +instance FromJSON UpdateNotificationConfigRequest where + parseJSON = withObject "UpdateNotificationConfigRequest" $ \v -> + UpdateNotificationConfigRequest <$> v .: "config" + +instance ToJSON UpdateNotificationConfigRequest where + toJSON UpdateNotificationConfigRequest {..} = + object + [ "config" .= updateNotificationConfigRequestConfig + ] + +-- | Response of @DELETE /_plugins/_notifications/configs/{config_id}@ +-- (and of the sibling batch variant +-- @DELETE /_plugins/_notifications/configs/?config_id_list=id1,id2,...@ +-- exposed by 'deleteNotificationConfigs'). The plugin returns a map +-- from each requested @config_id@ to its per-id deletion status. The +-- documented success value is @"OK"@; the batch variant can carry +-- per-id failures, so the status values are typed as 'Text' rather +-- than a closed enum — see the module docs for the precedent on not +-- prematurely closing under-documented enums. +newtype DeleteNotificationConfigResponse = DeleteNotificationConfigResponse + { deleteResponseList :: Map Text Text + } + deriving stock (Eq, Show) + +instance FromJSON DeleteNotificationConfigResponse where + parseJSON = withObject "DeleteNotificationConfigResponse" $ \v -> + DeleteNotificationConfigResponse <$> v .: "delete_response_list" + +instance ToJSON DeleteNotificationConfigResponse where + toJSON DeleteNotificationConfigResponse {..} = + object ["delete_response_list" .= deleteResponseList] + +-- | Look up the deletion status of a specific @config_id@ within a +-- 'DeleteNotificationConfigResponse'. Returns 'Nothing' if the id was +-- not part of the request (e.g. a mismatched id argument). +deleteResponseStatus :: + Text -> DeleteNotificationConfigResponse -> Maybe Text +deleteResponseStatus configId DeleteNotificationConfigResponse {..} = + Map.lookup configId deleteResponseList + +-- | True iff every per-id status in the response is @"OK"@ (the +-- documented success value). Convenience for the single-id case, where +-- it reduces to "did this delete succeed?", and for the multi-id +-- @config_id_list@ variant ('deleteNotificationConfigs'), where it +-- summarises the whole batch. +deleteResponseAllOK :: DeleteNotificationConfigResponse -> Bool +deleteResponseAllOK DeleteNotificationConfigResponse {..} = + all (== "OK") deleteResponseList + +-- ========================================================================= +-- List responses: GET /_plugins/_notifications/configs +-- ========================================================================= + +-- | A single entry in the @config_list@ returned by +-- @GET /_plugins/_notifications/configs@. Wraps a 'NotificationConfig' +-- with its server-assigned identity and the bookkeeping timestamps the +-- plugin maintains. The @config_id@ is the handle passed to +-- 'deleteNotificationConfig' and to the per-id GET. +data NotificationConfigEntry = NotificationConfigEntry + { notificationConfigEntryConfigId :: Text, + notificationConfigEntryCreatedTimeMs :: Integer, + notificationConfigEntryLastUpdatedTimeMs :: Integer, + notificationConfigEntryConfig :: NotificationConfig + } + deriving stock (Eq, Show) + +instance FromJSON NotificationConfigEntry where + parseJSON = withObject "NotificationConfigEntry" $ \v -> do + notificationConfigEntryConfigId <- v .: "config_id" + notificationConfigEntryCreatedTimeMs <- v .: "created_time_ms" + notificationConfigEntryLastUpdatedTimeMs <- v .: "last_updated_time_ms" + notificationConfigEntryConfig <- v .: "config" + pure NotificationConfigEntry {..} + +instance ToJSON NotificationConfigEntry where + toJSON NotificationConfigEntry {..} = + object + [ "config_id" .= notificationConfigEntryConfigId, + "created_time_ms" .= notificationConfigEntryCreatedTimeMs, + "last_updated_time_ms" .= notificationConfigEntryLastUpdatedTimeMs, + "config" .= notificationConfigEntryConfig + ] + +-- | The @total_hit_relation@ discriminator on the list-response +-- envelopes. @"eq"@ means @total_hits@ is exact; @"gte"@ means it is a +-- lower bound (e.g. when @max_items@ truncated the result). Unknown +-- values round-trip via 'NotificationTotalRelationOther' for forward +-- compatibility. +data NotificationTotalRelation + = NotificationTotalRelationEq + | NotificationTotalRelationGte + | NotificationTotalRelationOther Text + deriving stock (Eq, Show) + +instance FromJSON NotificationTotalRelation where + parseJSON = withText "NotificationTotalRelation" $ \t -> + pure $ case t of + "eq" -> NotificationTotalRelationEq + "gte" -> NotificationTotalRelationGte + other -> NotificationTotalRelationOther other + +instance ToJSON NotificationTotalRelation where + toJSON = \case + NotificationTotalRelationEq -> "eq" + NotificationTotalRelationGte -> "gte" + NotificationTotalRelationOther t -> toJSON t + +-- | Envelope returned by @GET /_plugins/_notifications/configs@. The +-- paging fields (@start_index@, @total_hits@, @total_hit_relation@) are +-- decoded for completeness but discarded by the public +-- 'getNotificationConfigs' wrapper, which returns only the +-- @config_list@. +data GetNotificationConfigsResponse = GetNotificationConfigsResponse + { getNotificationConfigsResponseStartIndex :: Integer, + getNotificationConfigsResponseTotalHits :: Integer, + getNotificationConfigsResponseTotalHitRelation :: NotificationTotalRelation, + getNotificationConfigsResponseConfigList :: [NotificationConfigEntry] + } + deriving stock (Eq, Show) + +instance FromJSON GetNotificationConfigsResponse where + parseJSON = withObject "GetNotificationConfigsResponse" $ \v -> do + getNotificationConfigsResponseStartIndex <- v .: "start_index" + getNotificationConfigsResponseTotalHits <- v .: "total_hits" + getNotificationConfigsResponseTotalHitRelation <- v .: "total_hit_relation" + getNotificationConfigsResponseConfigList <- v .: "config_list" + pure GetNotificationConfigsResponse {..} + +instance ToJSON GetNotificationConfigsResponse where + toJSON GetNotificationConfigsResponse {..} = + object + [ "start_index" .= getNotificationConfigsResponseStartIndex, + "total_hits" .= getNotificationConfigsResponseTotalHits, + "total_hit_relation" .= getNotificationConfigsResponseTotalHitRelation, + "config_list" .= getNotificationConfigsResponseConfigList + ] + +-- ========================================================================= +-- List query options (shared by GET configs and GET channels) +-- ========================================================================= + +-- | Sort direction for the GET @configs@ \/ @channels@ endpoints. The +-- plugin docs only document @"asc"@ and @"desc"@. +data NotificationSortOrder + = NotificationSortOrderAsc + | NotificationSortOrderDesc + deriving stock (Eq, Show) + +-- | The wire string for a 'NotificationSortOrder'. +notificationSortOrderText :: NotificationSortOrder -> Text +notificationSortOrderText = \case + NotificationSortOrderAsc -> "asc" + NotificationSortOrderDesc -> "desc" + +-- | Query-string parameters accepted by both +-- @GET /_plugins/_notifications/configs@ and +-- @GET /_plugins/_notifications/channels@. Every field is optional; +-- 'defaultNotificationListOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. Per-transport filter fields +-- (e.g. @slack.url@, @email.recipient_list@) are deliberately omitted +-- — they are advanced and rarely used; callers who need them can issue +-- the request via the lower-level builder with a hand-rolled query +-- list. +data NotificationListOptions = NotificationListOptions + { notificationListOptionsFromIndex :: Maybe Natural, + notificationListOptionsMaxItems :: Maybe Natural, + notificationListOptionsSortOrder :: Maybe NotificationSortOrder, + notificationListOptionsSortField :: Maybe Text, + notificationListOptionsConfigType :: Maybe NotificationConfigType, + notificationListOptionsConfigId :: Maybe Text, + notificationListOptionsConfigIdList :: Maybe [Text], + notificationListOptionsIsEnabled :: Maybe Bool + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the +-- plain @GET /_plugins/_notifications/configs@ (or @channels@) when +-- passed to 'getNotificationConfigsWith' \/ 'getNotificationChannelsWith'. +defaultNotificationListOptions :: NotificationListOptions +defaultNotificationListOptions = + NotificationListOptions + { notificationListOptionsFromIndex = Nothing, + notificationListOptionsMaxItems = Nothing, + notificationListOptionsSortOrder = Nothing, + notificationListOptionsSortField = Nothing, + notificationListOptionsConfigType = Nothing, + notificationListOptionsConfigId = Nothing, + notificationListOptionsConfigIdList = Nothing, + notificationListOptionsIsEnabled = Nothing + } + +-- | Render a 'NotificationListOptions' to the query-string pairs +-- accepted by the GET endpoints. Fields set to 'Nothing' are omitted +-- (not rendered with an empty value); @config_id_list@ is rendered as +-- a comma-separated list per the plugin docs. +notificationListOptionsParams :: NotificationListOptions -> [(Text, Maybe Text)] +notificationListOptionsParams NotificationListOptions {..} = + catMaybes + [ (("from_index",) . Just . tshow) <$> notificationListOptionsFromIndex, + (("max_items",) . Just . tshow) <$> notificationListOptionsMaxItems, + (("sort_order",) . Just . notificationSortOrderText) <$> notificationListOptionsSortOrder, + (("sort_field",) . Just) <$> notificationListOptionsSortField, + (("config_type",) . Just . notificationConfigTypeText) <$> notificationListOptionsConfigType, + (("config_id",) . Just) <$> notificationListOptionsConfigId, + (("config_id_list",) . Just . T.intercalate ",") <$> notificationListOptionsConfigIdList, + (("is_enabled",) . Just . \case True -> "true"; False -> "false") <$> notificationListOptionsIsEnabled + ] + +-- ========================================================================= +-- List responses: GET /_plugins/_notifications/channels +-- ========================================================================= + +-- | A single entry in the @channel_list@ returned by +-- @GET /_plugins/_notifications/channels@. The channels endpoint is the +-- \"runtime\" view of the configured destinations: it carries the +-- identifying metadata (@config_id@, @name@, @description@, +-- @config_type@, @is_enabled@) but omits the transport-specific details +-- (no @slack.url@, no @email.recipient_list@) that the full +-- 'NotificationConfig' exposes. Use 'getNotificationConfigs' when you +-- need the transport details; use 'getNotificationChannels' for a +-- lightweight listing. +data Channel = Channel + { channelConfigId :: Text, + channelName :: Text, + channelDescription :: Maybe Text, + channelConfigType :: NotificationConfigType, + channelIsEnabled :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON Channel where + parseJSON = withObject "Channel" $ \v -> do + channelConfigId <- v .: "config_id" + channelName <- v .: "name" + channelDescription <- v .:? "description" + channelConfigType <- v .: "config_type" + channelIsEnabled <- v .: "is_enabled" + pure Channel {..} + +instance ToJSON Channel where + toJSON Channel {..} = + omitNulls + [ "config_id" .= channelConfigId, + "name" .= channelName, + "description" .= channelDescription, + "config_type" .= channelConfigType, + "is_enabled" .= channelIsEnabled + ] + +-- | Envelope returned by @GET /_plugins/_notifications/channels@. +-- Structurally identical to 'GetNotificationConfigsResponse' except for +-- the @channel_list@ field. As with the configs envelope, the paging +-- fields are decoded for completeness but discarded by the public +-- 'getNotificationChannels' wrapper. +data GetNotificationChannelsResponse = GetNotificationChannelsResponse + { getNotificationChannelsResponseStartIndex :: Integer, + getNotificationChannelsResponseTotalHits :: Integer, + getNotificationChannelsResponseTotalHitRelation :: NotificationTotalRelation, + getNotificationChannelsResponseChannelList :: [Channel] + } + deriving stock (Eq, Show) + +instance FromJSON GetNotificationChannelsResponse where + parseJSON = withObject "GetNotificationChannelsResponse" $ \v -> do + getNotificationChannelsResponseStartIndex <- v .: "start_index" + getNotificationChannelsResponseTotalHits <- v .: "total_hits" + getNotificationChannelsResponseTotalHitRelation <- v .: "total_hit_relation" + getNotificationChannelsResponseChannelList <- v .: "channel_list" + pure GetNotificationChannelsResponse {..} + +instance ToJSON GetNotificationChannelsResponse where + toJSON GetNotificationChannelsResponse {..} = + object + [ "start_index" .= getNotificationChannelsResponseStartIndex, + "total_hits" .= getNotificationChannelsResponseTotalHits, + "total_hit_relation" .= getNotificationChannelsResponseTotalHitRelation, + "channel_list" .= getNotificationChannelsResponseChannelList + ] + +-- ========================================================================= +-- Features response: GET /_plugins/_notifications/features +-- ========================================================================= + +-- | Response of @GET /_plugins/_notifications/features@ +-- ('getNotificationFeatures'). The @allowed_config_type_list@ field is +-- the set of @config_type@ tags this cluster's Notifications plugin +-- knows how to persist (a subset of 'NotificationConfigType'; the +-- docs example for OS 2.18 lists eight of the nine variants — +-- @microsoft_teams@ is omitted from the example, but the plugin +-- accepts it on real clusters, so the list is typed as +-- @['NotificationConfigType']@ and any unknown tag parse-fails per +-- the 'NotificationConfigType' decoder's fail-loud policy). +-- +-- The @plugin_features@ map is a free-form string→string feature +-- flag set (the only documented entry is @tooltip_support@); typed +-- as 'Map' 'Text' 'Text' so a future plugin release adding a new +-- feature flag does not require a library release. +data NotificationFeaturesResponse = NotificationFeaturesResponse + { notificationFeaturesResponseAllowedConfigTypeList :: [NotificationConfigType], + notificationFeaturesResponsePluginFeatures :: Map Text Text + } + deriving stock (Eq, Show) + +instance FromJSON NotificationFeaturesResponse where + parseJSON = withObject "NotificationFeaturesResponse" $ \v -> do + notificationFeaturesResponseAllowedConfigTypeList <- v .: "allowed_config_type_list" + notificationFeaturesResponsePluginFeatures <- v .:? "plugin_features" .!= Map.empty + pure NotificationFeaturesResponse {..} + +instance ToJSON NotificationFeaturesResponse where + toJSON NotificationFeaturesResponse {..} = + object + [ "allowed_config_type_list" .= notificationFeaturesResponseAllowedConfigTypeList, + "plugin_features" .= notificationFeaturesResponsePluginFeatures + ] + +-- ========================================================================= +-- Send test notification response: GET /_plugins/_notifications/feature/test/{config_id} +-- ========================================================================= + +-- | Response of @GET /_plugins/_notifications/feature/test/{config_id}@ +-- ('sendTestNotification'). The plugin constructs an 'EventSource' +-- describing the probe it attempted, then a per-config +-- 'TestNotificationStatus' entry for each channel it tried to deliver +-- to (one entry for the requested @config_id@ in the common case). +-- +-- The @status_list@.@delivery_status@.@status_text@ field is the raw +-- upstream response body the transport returned (e.g. the HTML body +-- for a webhook), so it is typed as 'Text' rather than a closed enum. +data TestNotificationResponse = TestNotificationResponse + { testNotificationResponseEventSource :: TestNotificationEventSource, + testNotificationResponseStatusList :: [TestNotificationStatus] + } + deriving stock (Eq, Show) + +instance FromJSON TestNotificationResponse where + parseJSON = withObject "TestNotificationResponse" $ \v -> do + testNotificationResponseEventSource <- v .: "event_source" + testNotificationResponseStatusList <- v .: "status_list" + pure TestNotificationResponse {..} + +instance ToJSON TestNotificationResponse where + toJSON TestNotificationResponse {..} = + object + [ "event_source" .= testNotificationResponseEventSource, + "status_list" .= testNotificationResponseStatusList + ] + +-- | The @event_source@ object embedded in a 'TestNotificationResponse'. +-- The plugin materialises a synthetic notification with these fields +-- to drive the probe: @title@ and @reference_id@ are derived from the +-- target @config_id@, @severity@ is the documented severity tag +-- (@\"info\"@ in the docs example; the plugin also emits @\"warning\"@ +-- and @\"critical\"@, which are not fully enumerated, so the field is +-- typed as 'Text'), and @tags@ is the (possibly empty) set of +-- free-form string labels attached to the probe. +data TestNotificationEventSource = TestNotificationEventSource + { testNotificationEventSourceTitle :: Text, + testNotificationEventSourceReferenceId :: Text, + testNotificationEventSourceSeverity :: Text, + testNotificationEventSourceTags :: [Text] + } + deriving stock (Eq, Show) + +instance FromJSON TestNotificationEventSource where + parseJSON = withObject "TestNotificationEventSource" $ \v -> do + testNotificationEventSourceTitle <- v .: "title" + testNotificationEventSourceReferenceId <- v .: "reference_id" + testNotificationEventSourceSeverity <- v .: "severity" + testNotificationEventSourceTags <- v .:? "tags" .!= [] + pure TestNotificationEventSource {..} + +instance ToJSON TestNotificationEventSource where + toJSON TestNotificationEventSource {..} = + omitNulls + [ "title" .= testNotificationEventSourceTitle, + "reference_id" .= testNotificationEventSourceReferenceId, + "severity" .= testNotificationEventSourceSeverity, + "tags" .= testNotificationEventSourceTags + ] + +-- | A single per-config delivery result inside a +-- 'TestNotificationResponse'. The @config_type@ reuses +-- 'NotificationConfigType' so the closed-enum invariant is preserved; +-- an unknown @config_type@ parse-fails per the fail-loud policy +-- documented for 'NotificationConfigType'. +-- +-- The @email_recipient_status@ field is opaque +-- (@['Data.Aeson.Value']@): the docs only show it as the empty list, +-- and the Notifications plugin source does not document the +-- per-recipient status object shape on this API page, so we preserve +-- caller access to the raw JSON rather than commit to a structure we +-- would have to guess. File a feature request if you need a typed +-- projection. +data TestNotificationStatus = TestNotificationStatus + { testNotificationStatusConfigId :: Text, + testNotificationStatusConfigType :: NotificationConfigType, + testNotificationStatusConfigName :: Text, + testNotificationStatusEmailRecipientStatus :: [Value], + testNotificationStatusDeliveryStatus :: TestNotificationDeliveryStatus + } + deriving stock (Eq, Show) + +instance FromJSON TestNotificationStatus where + parseJSON = withObject "TestNotificationStatus" $ \v -> do + testNotificationStatusConfigId <- v .: "config_id" + testNotificationStatusConfigType <- v .: "config_type" + testNotificationStatusConfigName <- v .: "config_name" + testNotificationStatusEmailRecipientStatus <- v .:? "email_recipient_status" .!= [] + testNotificationStatusDeliveryStatus <- v .: "delivery_status" + pure TestNotificationStatus {..} + +instance ToJSON TestNotificationStatus where + toJSON TestNotificationStatus {..} = + omitNulls + [ "config_id" .= testNotificationStatusConfigId, + "config_type" .= testNotificationStatusConfigType, + "config_name" .= testNotificationStatusConfigName, + "email_recipient_status" .= testNotificationStatusEmailRecipientStatus, + "delivery_status" .= testNotificationStatusDeliveryStatus + ] + +-- | The @delivery_status@ object inside a 'TestNotificationStatus'. +-- @status_code@ is the HTTP-style code the upstream transport returned +-- (@\"200\"@ on success — typed as 'Text' because the plugin emits it +-- as a string, not a number) and @status_text@ is the raw upstream +-- response body (free-form: HTML for webhooks, a JSON blob for SNS, +-- an SMTP reply for email, ...). +data TestNotificationDeliveryStatus = TestNotificationDeliveryStatus + { testNotificationDeliveryStatusCode :: Text, + testNotificationDeliveryStatusText :: Text + } + deriving stock (Eq, Show) + +instance FromJSON TestNotificationDeliveryStatus where + parseJSON = withObject "TestNotificationDeliveryStatus" $ \v -> do + testNotificationDeliveryStatusCode <- v .: "status_code" + testNotificationDeliveryStatusText <- v .: "status_text" + pure TestNotificationDeliveryStatus {..} + +instance ToJSON TestNotificationDeliveryStatus where + toJSON TestNotificationDeliveryStatus {..} = + object + [ "status_code" .= testNotificationDeliveryStatusCode, + "status_text" .= testNotificationDeliveryStatusText + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/PointInTime.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/PointInTime.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/PointInTime.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.PointInTime where + +import Database.Bloodhound.Internal.Utils.Imports +import Database.Bloodhound.Internal.Versions.Common.Types.KeepAlive + ( KeepAlive, + keepAliveMilliseconds, + ) +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes (POSIXMS) +import Database.Bloodhound.Internal.Versions.Common.Types.Nodes (ShardResult) + +data OpenPointInTimeResponse = OpenPointInTimeResponse + { oos3PitId :: Text, + oos3Shards :: ShardResult, + oos3CreationTime :: POSIXMS + } + deriving stock (Eq, Show) + +instance ToJSON OpenPointInTimeResponse where + toJSON OpenPointInTimeResponse {..} = + object ["pit_id" .= oos3PitId, "_shards" .= oos3Shards, "creation_time" .= oos3CreationTime] + +instance FromJSON OpenPointInTimeResponse where + parseJSON (Object o) = + OpenPointInTimeResponse + <$> o .: "pit_id" + <*> o .: "_shards" + <*> o .: "creation_time" + parseJSON x = typeMismatch "OpenPointInTimeResponse" x + +openPointInTimeIdLens :: Lens' OpenPointInTimeResponse Text +openPointInTimeIdLens = lens oos3PitId (\x y -> x {oos3PitId = y}) + +openPointInTimeShardsLens :: Lens' OpenPointInTimeResponse ShardResult +openPointInTimeShardsLens = lens oos3Shards (\x y -> x {oos3Shards = y}) + +openPointInTimeCreationTimeLens :: Lens' OpenPointInTimeResponse POSIXMS +openPointInTimeCreationTimeLens = lens oos3CreationTime (\x y -> x {oos3CreationTime = y}) + +-- | Request body for the OpenSearch @DELETE /_search/point_in_time@ (Delete +-- PITs by ID) API. The wire body is an /array/ of pit ids: +-- +-- @ +-- { "pit_id": ["", "", ...] } +-- @ +-- +-- Note that OpenSearch (unlike Elasticsearch's @close@ endpoint) does not +-- accept a single @id@ field; the value is always a JSON array even for one +-- pit, so a single-pit close is encoded as @{"pit_id":[""]}@. +data ClosePointInTime = ClosePointInTime + { cPitIds :: [Text] + } + deriving stock (Eq, Show) + +instance ToJSON ClosePointInTime where + toJSON ClosePointInTime {..} = + object ["pit_id" .= cPitIds] + +instance FromJSON ClosePointInTime where + parseJSON (Object o) = ClosePointInTime <$> o .: "pit_id" + parseJSON x = typeMismatch "ClosePointInTime" x + +closePointInTimeIdsLens :: Lens' ClosePointInTime [Text] +closePointInTimeIdsLens = lens cPitIds (\x y -> x {cPitIds = y}) + +-- | Per-pit result entry inside a 'ClosePointInTimeResponse'. The OpenSearch +-- Delete-PITs-by-ID response surfaces, for each requested pit id, whether the +-- deletion succeeded and the pit id it refers to: +-- +-- @ +-- { "successful": true, "pit_id": "" } +-- @ +data ClosePointInTimeResult = ClosePointInTimeResult + { cpitSuccessful :: Bool, + cpitId :: Text + } + deriving stock (Eq, Show) + +instance ToJSON ClosePointInTimeResult where + toJSON ClosePointInTimeResult {..} = + object + [ "successful" .= cpitSuccessful, + "pit_id" .= cpitId + ] + +instance FromJSON ClosePointInTimeResult where + parseJSON (Object o) = + ClosePointInTimeResult + <$> o .: "successful" + <*> o .: "pit_id" + parseJSON x = typeMismatch "ClosePointInTimeResult" x + +closePointInTimeResultSuccessfulLens :: Lens' ClosePointInTimeResult Bool +closePointInTimeResultSuccessfulLens = + lens cpitSuccessful (\x y -> x {cpitSuccessful = y}) + +closePointInTimeResultIdLens :: Lens' ClosePointInTimeResult Text +closePointInTimeResultIdLens = + lens cpitId (\x y -> x {cpitId = y}) + +-- | Response of the OpenSearch @DELETE /_search/point_in_time@ (Delete PITs +-- by ID) API. Unlike Elasticsearch's @close@ endpoint (which returns +-- @{"succeeded", "num_freed"}@), OpenSearch returns one entry per requested +-- pit id: +-- +-- @ +-- { "pits": [ {"successful": true, "pit_id": ""}, ... ] } +-- @ +data ClosePointInTimeResponse = ClosePointInTimeResponse + { closePITs :: [ClosePointInTimeResult] + } + deriving stock (Eq, Show) + +instance ToJSON ClosePointInTimeResponse where + toJSON ClosePointInTimeResponse {..} = + object ["pits" .= closePITs] + +instance FromJSON ClosePointInTimeResponse where + parseJSON (Object o) = ClosePointInTimeResponse <$> o .: "pits" + parseJSON x = typeMismatch "ClosePointInTimeResponse" x + +closePointInTimesLens :: Lens' ClosePointInTimeResponse [ClosePointInTimeResult] +closePointInTimesLens = lens closePITs (\x y -> x {closePITs = y}) + +-- | Element type for the @GET /_search/point_in_time/_all@ list-all-PITs +-- response. Unlike 'OpenPointInTimeResponse' (the @POST@ create-PIT +-- response, which carries a per-entry @_shards@ summary), each list +-- entry exposes only the @pit_id@, the @creation_time@ and the remaining +-- @keep_alive@ — there is no @_shards@ key in the list response. +-- +-- The wire @keep_alive@ is a bare millisecond count (a JSON number, e.g. +-- @6000000@), not the @@ string grammar accepted on create. The +-- 'FromJSON' instance therefore parses the number via +-- 'keepAliveMilliseconds'; the 'ToJSON' round trip re-renders it as a +-- @ms@ string, so the codec is asymmetric by design (mirroring +-- 'POSIXMS'). +data PITInfo = PITInfo + { pitInfoId :: Text, + pitInfoCreationTime :: POSIXMS, + pitInfoKeepAlive :: KeepAlive + } + deriving stock (Eq, Show) + +instance ToJSON PITInfo where + toJSON PITInfo {..} = + object + [ "pit_id" .= pitInfoId, + "creation_time" .= pitInfoCreationTime, + "keep_alive" .= pitInfoKeepAlive + ] + +instance FromJSON PITInfo where + parseJSON (Object o) = + PITInfo + <$> o .: "pit_id" + <*> o .: "creation_time" + <*> (keepAliveMilliseconds <$> o .: "keep_alive") + parseJSON x = typeMismatch "PITInfo" x + +pitInfoIdLens :: Lens' PITInfo Text +pitInfoIdLens = lens pitInfoId (\x y -> x {pitInfoId = y}) + +pitInfoCreationTimeLens :: Lens' PITInfo POSIXMS +pitInfoCreationTimeLens = lens pitInfoCreationTime (\x y -> x {pitInfoCreationTime = y}) + +pitInfoKeepAliveLens :: Lens' PITInfo KeepAlive +pitInfoKeepAliveLens = lens pitInfoKeepAlive (\x y -> x {pitInfoKeepAlive = y}) + +-- | Envelope of the @GET /_search/point_in_time/_all@ response +-- (@{\"pits\":[...] }@). Each 'PITInfo' carries the pit id, +-- @creation_time@ and remaining @keep_alive@; the create-response-only +-- @_shards@ field is absent from list entries. +newtype ListPITsResponse = ListPITsResponse + { listPITs :: [PITInfo] + } + deriving stock (Eq, Show) + +instance ToJSON ListPITsResponse where + toJSON ListPITsResponse {..} = + object ["pits" .= listPITs] + +instance FromJSON ListPITsResponse where + parseJSON (Object o) = ListPITsResponse <$> o .: "pits" + parseJSON x = typeMismatch "ListPITsResponse" x + +listPITsLens :: Lens' ListPITsResponse [PITInfo] +listPITsLens = lens listPITs (\x y -> x {listPITs = y}) diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/Rollups.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/Rollups.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/Rollups.hs @@ -0,0 +1,710 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.Rollups + ( RollupId (..), + Rollup (..), + RollupWrapper (..), + RollupSchedule (..), + RollupInterval (..), + RollupIntervalUnit (..), + rollupIntervalUnitText, + RollupCron (..), + RollupDimension (..), + RollupDateHistogram (..), + RollupTerms (..), + RollupHistogram (..), + RollupMetric (..), + RollupMetricAgg (..), + rollupMetricAggText, + RollupResponse (..), + RollupResponseInner (..), + ExplainRollupResponse (..), + explainRollupResponseLookup, + explainRollupResponseToList, + ExplainRollupEntry (..), + RollupMetadata (..), + RollupStatus (..), + rollupStatusText, + RollupStats (..), + ) +where + +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The OpenSearch Index Rollups plugin +-- () +-- periodically reduces a high-granularity source index into a coarser +-- target index by aggregating documents along configurable dimensions +-- (date_histogram / terms / histogram) and computing metrics +-- (avg / sum / max / min / value_count) per bucket. A 'Rollup' binds a +-- 'rollupSourceIndex', a 'rollupTargetIndex', a 'RollupSchedule', the +-- 'rollupDimensions' to group by and the 'rollupMetrics' to compute; the +-- server persists it under @.opendistro-ism-config@ (the ISM config +-- index) and returns a 'RollupResponse' wrapping the persisted +-- 'RollupResponseInner' with server-injected bookkeeping fields +-- (@_id@, @_version@, @_seq_no@, @_primary_term@, @rollup_id@, +-- @last_updated_time@, @enabled_time@, @schema_version@, @metadata_id@). +-- +-- We split the request shape ('Rollup') from the response inner shape +-- ('RollupResponseInner') so the request cannot accidentally carry +-- server-only fields, while the response still round-trips the full +-- server payload. This mirrors the 'Detector' / 'DetectorResponse' +-- split used for the Anomaly Detection plugin. +-- +-- The plugin is shipped with OpenSearch 1.0+; it is present (and +-- wire-compatible) on OS1, OS2 and OS3, hence this module is duplicated +-- across all three versions. The @routing_field@ option is documented as +-- OS 3.7+ only, but is modelled as 'Maybe' 'Text' here on every version: +-- older clusters simply never receive it (it is omitted under +-- 'omitNulls'), so a single code path serves all three. +-- +-- Doc ambiguities handled here deliberately: +-- +-- * The @_seq_no@ / @_primary_term@ fields are emitted in snake_case on +-- the PUT response but camelCase (@_seqNo@ / @_primaryTerm@) on the GET +-- response. The 'RollupResponse' parser accepts both spellings (see +-- 'rollupKey'). +-- * The @schedule.interval.period@ field is documented with type String +-- but every documented example emits it as a bare number (@1@). We +-- type it as 'Int', matching the wire format the server actually sends. +-- * The @metadata_id@ field is JSON @null@ (not absent) when the rollup +-- has not yet executed, so it is parsed with '.:?' (tolerating both +-- @null@ and omission). +-- * The @GET /_plugins/_rollup/jobs@ (list-all) endpoint is undocumented +-- in the field tables; its response is decoded as an opaque 'Value' at +-- the 'Requests' layer rather than typed here. +-- * Each 'RollupDimension' / 'RollupMetricAgg' is encoded as a +-- single-key JSON object (e.g. @{"avg":{}}@) following the +-- aggregation-DSL convention the plugin reuses. + +-- | Identifies a rollup job in the +-- @\/_plugins\/_rollup\/jobs\/{rollup_id}@ URL path. Wraps 'Text' so it +-- round-trips through JSON as a bare string but is distinct at the +-- Haskell type level. +-- See +newtype RollupId = RollupId {unRollupId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The request body for @PUT /_plugins/_rollup/jobs/{rollup_id}@, +-- unwrapped. Required fields: @source_index@, @target_index@, +-- @schedule@, @page_size@, @dimensions@. Everything else is optional and +-- omitted on the wire when 'Nothing'. Server-only bookkeeping fields +-- (@rollup_id@, @last_updated_time@, @enabled_time@, @schema_version@, +-- @metadata_id@) are deliberately absent — they appear on the +-- 'RollupResponseInner' round-trip shape. +-- See +data Rollup = Rollup + { rollupSourceIndex :: Text, + rollupTargetIndex :: Text, + rollupTargetIndexSettings :: Maybe Value, + rollupSchedule :: RollupSchedule, + rollupDescription :: Maybe Text, + rollupEnabled :: Maybe Bool, + rollupContinuous :: Maybe Bool, + rollupPageSize :: Int, + rollupDelay :: Maybe Integer, + rollupRoles :: Maybe [Text], + rollupRoutingField :: Maybe Text, + rollupDimensions :: [RollupDimension], + rollupMetrics :: Maybe [RollupMetric], + rollupErrorNotification :: Maybe Value + } + deriving stock (Eq, Show) + +instance FromJSON Rollup where + parseJSON = withObject "Rollup" $ \v -> do + rollupSourceIndex <- v .: "source_index" + rollupTargetIndex <- v .: "target_index" + rollupTargetIndexSettings <- v .:? "target_index_settings" + rollupSchedule <- v .: "schedule" + rollupDescription <- v .:? "description" + rollupEnabled <- v .:? "enabled" + rollupContinuous <- v .:? "continuous" + rollupPageSize <- v .: "page_size" + rollupDelay <- v .:? "delay" + rollupRoles <- v .:? "roles" + rollupRoutingField <- v .:? "routing_field" + rollupDimensions <- v .:? "dimensions" .!= [] + rollupMetrics <- v .:? "metrics" + rollupErrorNotification <- v .:? "error_notification" + pure Rollup {..} + +instance ToJSON Rollup where + toJSON Rollup {..} = + omitNulls + [ "source_index" .= rollupSourceIndex, + "target_index" .= rollupTargetIndex, + "target_index_settings" .= rollupTargetIndexSettings, + "schedule" .= rollupSchedule, + "description" .= rollupDescription, + "enabled" .= rollupEnabled, + "continuous" .= rollupContinuous, + "page_size" .= rollupPageSize, + "delay" .= rollupDelay, + "roles" .= rollupRoles, + "routing_field" .= rollupRoutingField, + "dimensions" .= rollupDimensions, + "metrics" .= rollupMetrics, + "error_notification" .= rollupErrorNotification + ] + +-- | The @{"rollup": }@ envelope the PUT endpoint expects around +-- the 'Rollup' body. +-- See +newtype RollupWrapper = RollupWrapper {rollupWrapperRollup :: Rollup} + deriving stock (Eq, Show) + +instance ToJSON RollupWrapper where + toJSON (RollupWrapper r) = object ["rollup" .= r] + +instance FromJSON RollupWrapper where + parseJSON = withObject "RollupWrapper" $ \v -> + RollupWrapper <$> v .: "rollup" + +-- | The @schedule@ object. Currently only the @interval@ form is +-- documented; @cron@ lives one level deeper inside 'RollupInterval'. +-- See +newtype RollupSchedule = RollupSchedule {rollupScheduleInterval :: RollupInterval} + deriving stock (Eq, Show) + +instance FromJSON RollupSchedule where + parseJSON = withObject "RollupSchedule" $ \v -> + RollupSchedule <$> v .: "interval" + +instance ToJSON RollupSchedule where + toJSON (RollupSchedule interval) = object ["interval" .= interval] + +-- | The @schedule.interval@ object. Either the @period@\/@unit@ pair or a +-- @cron@ list governs execution frequency; @start_time@ and +-- @schedule_delay@ are server-populated on the response. +-- See +data RollupInterval = RollupInterval + { rollupIntervalPeriod :: Maybe Int, + rollupIntervalUnit :: Maybe RollupIntervalUnit, + rollupIntervalStartTime :: Maybe Integer, + rollupIntervalScheduleDelay :: Maybe Integer, + rollupIntervalCron :: Maybe [RollupCron] + } + deriving stock (Eq, Show) + +instance FromJSON RollupInterval where + parseJSON = withObject "RollupInterval" $ \v -> do + rollupIntervalPeriod <- v .:? "period" + rollupIntervalUnit <- v .:? "unit" + rollupIntervalStartTime <- v .:? "start_time" + rollupIntervalScheduleDelay <- v .:? "schedule_delay" + rollupIntervalCron <- v .:? "cron" + pure RollupInterval {..} + +instance ToJSON RollupInterval where + toJSON RollupInterval {..} = + omitNulls + [ "period" .= rollupIntervalPeriod, + "unit" .= rollupIntervalUnit, + "start_time" .= rollupIntervalStartTime, + "schedule_delay" .= rollupIntervalScheduleDelay, + "cron" .= rollupIntervalCron + ] + +-- | The @schedule.interval.unit@ enum. The docs only show @"Days"@ in +-- examples; the plugin source accepts the standard time units +-- enumerated here. Unknown values surface as 'RollupIntervalUnitCustom' +-- rather than failing the decode. +-- See +data RollupIntervalUnit + = RollupIntervalUnitMinutes + | RollupIntervalUnitHours + | RollupIntervalUnitDays + | RollupIntervalUnitWeeks + | RollupIntervalUnitMonths + | RollupIntervalUnitCustom Text + deriving stock (Eq, Show) + +rollupIntervalUnitText :: RollupIntervalUnit -> Text +rollupIntervalUnitText = \case + RollupIntervalUnitMinutes -> "Minutes" + RollupIntervalUnitHours -> "Hours" + RollupIntervalUnitDays -> "Days" + RollupIntervalUnitWeeks -> "Weeks" + RollupIntervalUnitMonths -> "Months" + RollupIntervalUnitCustom t -> t + +instance ToJSON RollupIntervalUnit where + toJSON = toJSON . rollupIntervalUnitText + +instance FromJSON RollupIntervalUnit where + parseJSON = withText "RollupIntervalUnit" $ \case + "Minutes" -> pure RollupIntervalUnitMinutes + "Hours" -> pure RollupIntervalUnitHours + "Days" -> pure RollupIntervalUnitDays + "Weeks" -> pure RollupIntervalUnitWeeks + "Months" -> pure RollupIntervalUnitMonths + other -> pure (RollupIntervalUnitCustom other) + +-- | A cron expression entry inside @schedule.interval.cron@. +-- See +data RollupCron = RollupCron + { rollupCronExpression :: Text, + rollupCronTimezone :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupCron where + parseJSON = withObject "RollupCron" $ \v -> do + rollupCronExpression <- v .: "expression" + rollupCronTimezone <- v .:? "timezone" + pure RollupCron {..} + +instance ToJSON RollupCron where + toJSON RollupCron {..} = + omitNulls + [ "expression" .= rollupCronExpression, + "timezone" .= rollupCronTimezone + ] + +-- | A single dimension (bucket aggregation) the rollup groups by. The +-- plugin models each as a single-key object whose key selects the +-- aggregation kind; we keep that shape on the wire. +-- See +data RollupDimension + = RollupDimensionDateHistogram RollupDateHistogram + | RollupDimensionTerms RollupTerms + | RollupDimensionHistogram RollupHistogram + deriving stock (Eq, Show) + +instance ToJSON RollupDimension where + toJSON = \case + RollupDimensionDateHistogram dh -> object ["date_histogram" .= dh] + RollupDimensionTerms t -> object ["terms" .= t] + RollupDimensionHistogram h -> object ["histogram" .= h] + +instance FromJSON RollupDimension where + parseJSON = withObject "RollupDimension" $ \v -> case KeyMap.toList v of + [("date_histogram", o)] -> RollupDimensionDateHistogram <$> parseJSON o + [("terms", o)] -> RollupDimensionTerms <$> parseJSON o + [("histogram", o)] -> RollupDimensionHistogram <$> parseJSON o + _ -> + fail + ( "RollupDimension: expected a single-key object with one of \ + \date_histogram / terms / histogram, got keys: " + <> T.unpack (T.intercalate ", " (fmap (T.pack . show) (KeyMap.keys v))) + ) + +-- | The @date_histogram@ dimension. @fixed_interval@ is the documented +-- form (e.g. @"1h"@); @calendar_interval@ is also accepted by the plugin. +-- @target_field@ is server-populated on the response (mirroring +-- @source_field@ by default) and omitted on the request. +-- See +data RollupDateHistogram = RollupDateHistogram + { rollupDateHistogramSourceField :: Text, + rollupDateHistogramFixedInterval :: Maybe Text, + rollupDateHistogramCalendarInterval :: Maybe Text, + rollupDateHistogramTimezone :: Maybe Text, + rollupDateHistogramTargetField :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupDateHistogram where + parseJSON = withObject "RollupDateHistogram" $ \v -> do + rollupDateHistogramSourceField <- v .: "source_field" + rollupDateHistogramFixedInterval <- v .:? "fixed_interval" + rollupDateHistogramCalendarInterval <- v .:? "calendar_interval" + rollupDateHistogramTimezone <- v .:? "timezone" + rollupDateHistogramTargetField <- v .:? "target_field" + pure RollupDateHistogram {..} + +instance ToJSON RollupDateHistogram where + toJSON RollupDateHistogram {..} = + omitNulls + [ "source_field" .= rollupDateHistogramSourceField, + "fixed_interval" .= rollupDateHistogramFixedInterval, + "calendar_interval" .= rollupDateHistogramCalendarInterval, + "timezone" .= rollupDateHistogramTimezone, + "target_field" .= rollupDateHistogramTargetField + ] + +-- | The @terms@ dimension. @target_field@ is server-populated on the +-- response and omitted on the request. +-- See +data RollupTerms = RollupTerms + { rollupTermsSourceField :: Text, + rollupTermsTargetField :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupTerms where + parseJSON = withObject "RollupTerms" $ \v -> do + rollupTermsSourceField <- v .: "source_field" + rollupTermsTargetField <- v .:? "target_field" + pure RollupTerms {..} + +instance ToJSON RollupTerms where + toJSON RollupTerms {..} = + omitNulls + [ "source_field" .= rollupTermsSourceField, + "target_field" .= rollupTermsTargetField + ] + +-- | The @histogram@ dimension (numeric). @target_field@ is +-- server-populated on the response and omitted on the request. +-- See +data RollupHistogram = RollupHistogram + { rollupHistogramSourceField :: Text, + rollupHistogramInterval :: Scientific, + rollupHistogramTargetField :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupHistogram where + parseJSON = withObject "RollupHistogram" $ \v -> do + rollupHistogramSourceField <- v .: "source_field" + rollupHistogramInterval <- v .: "interval" + rollupHistogramTargetField <- v .:? "target_field" + pure RollupHistogram {..} + +instance ToJSON RollupHistogram where + toJSON RollupHistogram {..} = + omitNulls + [ "source_field" .= rollupHistogramSourceField, + "interval" .= rollupHistogramInterval, + "target_field" .= rollupHistogramTargetField + ] + +-- | A field + the metrics to compute over it. Each 'RollupMetricAgg' +-- encodes as a single-key object (e.g. @{"avg":{}}@). +-- See +data RollupMetric = RollupMetric + { rollupMetricSourceField :: Text, + rollupMetricMetrics :: [RollupMetricAgg] + } + deriving stock (Eq, Show) + +instance FromJSON RollupMetric where + parseJSON = withObject "RollupMetric" $ \v -> do + rollupMetricSourceField <- v .: "source_field" + rollupMetricMetrics <- v .:? "metrics" .!= [] + pure RollupMetric {..} + +instance ToJSON RollupMetric where + toJSON RollupMetric {..} = + omitNulls + [ "source_field" .= rollupMetricSourceField, + "metrics" .= rollupMetricMetrics + ] + +-- | The supported per-field metric aggregations. Each encodes to a +-- single-key object whose value is an empty object (@{"avg":{}}@). +-- Unknown keys surface as 'RollupMetricAggCustom' rather than failing. +-- See +data RollupMetricAgg + = RollupMetricAvg + | RollupMetricSum + | RollupMetricMax + | RollupMetricMin + | RollupMetricValueCount + | RollupMetricAggCustom Text + deriving stock (Eq, Show) + +rollupMetricAggText :: RollupMetricAgg -> Text +rollupMetricAggText = \case + RollupMetricAvg -> "avg" + RollupMetricSum -> "sum" + RollupMetricMax -> "max" + RollupMetricMin -> "min" + RollupMetricValueCount -> "value_count" + RollupMetricAggCustom t -> t + +instance ToJSON RollupMetricAgg where + toJSON agg = object [fromText (rollupMetricAggText agg) .= object []] + +instance FromJSON RollupMetricAgg where + parseJSON = withObject "RollupMetricAgg" $ \v -> case KeyMap.toList v of + [(k, _)] -> pure (rollupMetricAggFromKey (toText k)) + _ -> + fail + ( "RollupMetricAgg: expected a single-key object (e.g. {\"avg\":{}}), \ + \got keys: " + <> T.unpack (T.intercalate ", " (fmap (T.pack . show) (KeyMap.keys v))) + ) + +rollupMetricAggFromKey :: Text -> RollupMetricAgg +rollupMetricAggFromKey = \case + "avg" -> RollupMetricAvg + "sum" -> RollupMetricSum + "max" -> RollupMetricMax + "min" -> RollupMetricMin + "value_count" -> RollupMetricValueCount + other -> RollupMetricAggCustom other + +-- | Parse a 'Maybe' field that may appear under either of two JSON keys. +-- Used for @_seq_no@\/@_seqNo@ and @_primary_term@\/@_primaryTerm@, which +-- the rollup plugin emits in snake_case on PUT responses and camelCase +-- on GET responses. +rollupKey :: (FromJSON a) => Object -> Key -> Key -> Parser (Maybe a) +rollupKey o snake camel = do + m <- o .:? snake + case m of + Just x -> pure (Just x) + Nothing -> o .:? camel + +-- | Response body of @PUT \/_plugins\/_rollup\/jobs\/{rollup_id}@ and +-- @GET \/_plugins\/_rollup\/jobs\/{rollup_id}@. Wraps the persisted +-- 'RollupResponseInner' in a document-write envelope (@_id@, @_version@, +-- @_seq_no@, @_primary_term@). The PUT response uses snake_case +-- (@_seq_no@\/@_primary_term@); the GET response uses camelCase +-- (@_seqNo@\/@_primaryTerm@); both are accepted via 'rollupKey'. +-- See +data RollupResponse = RollupResponse + { rollupResponseId :: Text, + rollupResponseVersion :: Maybe Int, + rollupResponseSeqNo :: Maybe Int, + rollupResponsePrimaryTerm :: Maybe Int, + rollupResponseRollup :: RollupResponseInner + } + deriving stock (Eq, Show) + +instance FromJSON RollupResponse where + parseJSON = withObject "RollupResponse" $ \v -> do + rollupResponseId <- v .: "_id" + rollupResponseVersion <- v .:? "_version" + rollupResponseSeqNo <- rollupKey v "_seq_no" "_seqNo" + rollupResponsePrimaryTerm <- rollupKey v "_primary_term" "_primaryTerm" + rollupResponseRollup <- v .: "rollup" + pure RollupResponse {..} + +instance ToJSON RollupResponse where + toJSON RollupResponse {..} = + omitNulls + [ "_id" .= rollupResponseId, + "_version" .= rollupResponseVersion, + "_seq_no" .= rollupResponseSeqNo, + "_primary_term" .= rollupResponsePrimaryTerm, + "rollup" .= rollupResponseRollup + ] + +-- | The persisted @rollup@ object returned in responses. Carries the +-- full 'Rollup' body alongside server-injected bookkeeping fields +-- (@rollup_id@, @last_updated_time@, @enabled_time@, @schema_version@, +-- @metadata_id@). The round-trip preserves everything the server sent, +-- so a Get -> Update cycle does not lose data the caller never set. +-- See +data RollupResponseInner = RollupResponseInner + { rollupResponseInnerSourceIndex :: Text, + rollupResponseInnerTargetIndex :: Text, + rollupResponseInnerTargetIndexSettings :: Maybe Value, + rollupResponseInnerSchedule :: RollupSchedule, + rollupResponseInnerDescription :: Maybe Text, + rollupResponseInnerEnabled :: Maybe Bool, + rollupResponseInnerContinuous :: Maybe Bool, + rollupResponseInnerPageSize :: Maybe Int, + rollupResponseInnerDelay :: Maybe Integer, + rollupResponseInnerRoles :: Maybe [Text], + rollupResponseInnerRoutingField :: Maybe Text, + rollupResponseInnerDimensions :: [RollupDimension], + rollupResponseInnerMetrics :: Maybe [RollupMetric], + rollupResponseInnerErrorNotification :: Maybe Value, + rollupResponseInnerRollupId :: Maybe Text, + rollupResponseInnerLastUpdatedTime :: Maybe Integer, + rollupResponseInnerEnabledTime :: Maybe Integer, + rollupResponseInnerSchemaVersion :: Maybe Int, + rollupResponseInnerMetadataId :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON RollupResponseInner where + parseJSON = withObject "RollupResponseInner" $ \v -> do + rollupResponseInnerSourceIndex <- v .: "source_index" + rollupResponseInnerTargetIndex <- v .: "target_index" + rollupResponseInnerTargetIndexSettings <- v .:? "target_index_settings" + rollupResponseInnerSchedule <- v .: "schedule" + rollupResponseInnerDescription <- v .:? "description" + rollupResponseInnerEnabled <- v .:? "enabled" + rollupResponseInnerContinuous <- v .:? "continuous" + rollupResponseInnerPageSize <- v .:? "page_size" + rollupResponseInnerDelay <- v .:? "delay" + rollupResponseInnerRoles <- v .:? "roles" + rollupResponseInnerRoutingField <- v .:? "routing_field" + rollupResponseInnerDimensions <- v .:? "dimensions" .!= [] + rollupResponseInnerMetrics <- v .:? "metrics" + rollupResponseInnerErrorNotification <- v .:? "error_notification" + rollupResponseInnerRollupId <- v .:? "rollup_id" + rollupResponseInnerLastUpdatedTime <- v .:? "last_updated_time" + rollupResponseInnerEnabledTime <- v .:? "enabled_time" + rollupResponseInnerSchemaVersion <- v .:? "schema_version" + rollupResponseInnerMetadataId <- v .:? "metadata_id" + pure RollupResponseInner {..} + +instance ToJSON RollupResponseInner where + toJSON RollupResponseInner {..} = + omitNulls + [ "source_index" .= rollupResponseInnerSourceIndex, + "target_index" .= rollupResponseInnerTargetIndex, + "target_index_settings" .= rollupResponseInnerTargetIndexSettings, + "schedule" .= rollupResponseInnerSchedule, + "description" .= rollupResponseInnerDescription, + "enabled" .= rollupResponseInnerEnabled, + "continuous" .= rollupResponseInnerContinuous, + "page_size" .= rollupResponseInnerPageSize, + "delay" .= rollupResponseInnerDelay, + "roles" .= rollupResponseInnerRoles, + "routing_field" .= rollupResponseInnerRoutingField, + "dimensions" .= rollupResponseInnerDimensions, + "metrics" .= rollupResponseInnerMetrics, + "error_notification" .= rollupResponseInnerErrorNotification, + "rollup_id" .= rollupResponseInnerRollupId, + "last_updated_time" .= rollupResponseInnerLastUpdatedTime, + "enabled_time" .= rollupResponseInnerEnabledTime, + "schema_version" .= rollupResponseInnerSchemaVersion, + "metadata_id" .= rollupResponseInnerMetadataId + ] + +-- | Response body of @GET \/_plugins\/_rollup\/jobs\/{rollup_id}\/_explain@. +-- The plugin keys the response by the rollup job id at the top level, so +-- the body is decoded into a 'Map' from rollup id to 'ExplainRollupEntry'. +-- The caller looks up the entry for the id it requested via +-- 'explainRollupResponseLookup'. +-- See +newtype ExplainRollupResponse = ExplainRollupResponse + { explainRollupResponseMap :: Map.Map Text ExplainRollupEntry + } + deriving stock (Eq, Show) + +instance FromJSON ExplainRollupResponse where + parseJSON v = ExplainRollupResponse <$> parseJSON v + +-- | Lookup the entry for a rollup id. Returns 'Nothing' if the id is +-- absent from the response. +explainRollupResponseLookup :: Text -> ExplainRollupResponse -> Maybe ExplainRollupEntry +explainRollupResponseLookup rid = Map.lookup rid . explainRollupResponseMap + +-- | The entries of an 'ExplainRollupResponse', as an association list. +explainRollupResponseToList :: ExplainRollupResponse -> [(Text, ExplainRollupEntry)] +explainRollupResponseToList = Map.toList . explainRollupResponseMap + +-- | One entry under the explain-response top-level map. Both fields are +-- JSON @null@ (not absent) when the rollup job has not yet executed. +-- See +data ExplainRollupEntry = ExplainRollupEntry + { explainRollupEntryMetadataId :: Maybe Text, + explainRollupEntryRollupMetadata :: Maybe RollupMetadata + } + deriving stock (Eq, Show) + +instance FromJSON ExplainRollupEntry where + parseJSON = withObject "ExplainRollupEntry" $ \v -> do + explainRollupEntryMetadataId <- v .:? "metadata_id" + explainRollupEntryRollupMetadata <- v .:? "rollup_metadata" + pure ExplainRollupEntry {..} + +-- | The @rollup_metadata@ object inside an explain entry. Carries the +-- job execution status, failure reason and run statistics. @status@ is +-- a closed enum with a forward-compat escape hatch. +-- See +data RollupMetadata = RollupMetadata + { rollupMetadataRollupId :: Text, + rollupMetadataLastUpdatedTime :: Integer, + rollupMetadataStatus :: RollupStatus, + rollupMetadataFailureReason :: Maybe Text, + rollupMetadataStats :: Maybe RollupStats, + rollupMetadataNextWindowStartTime :: Maybe Integer, + rollupMetadataNextWindowEndTime :: Maybe Integer + } + deriving stock (Eq, Show) + +instance FromJSON RollupMetadata where + parseJSON = withObject "RollupMetadata" $ \v -> do + rollupMetadataRollupId <- v .: "rollup_id" + rollupMetadataLastUpdatedTime <- v .: "last_updated_time" + rollupMetadataStatus <- v .: "status" + rollupMetadataFailureReason <- v .:? "failure_reason" + rollupMetadataStats <- v .:? "stats" + rollupMetadataNextWindowStartTime <- v .:? "next_window_start_time" + rollupMetadataNextWindowEndTime <- v .:? "next_window_end_time" + pure RollupMetadata {..} + +instance ToJSON RollupMetadata where + toJSON RollupMetadata {..} = + omitNulls + [ "rollup_id" .= rollupMetadataRollupId, + "last_updated_time" .= rollupMetadataLastUpdatedTime, + "status" .= rollupMetadataStatus, + "failure_reason" .= rollupMetadataFailureReason, + "stats" .= rollupMetadataStats, + "next_window_start_time" .= rollupMetadataNextWindowStartTime, + "next_window_end_time" .= rollupMetadataNextWindowEndTime + ] + +-- | The @rollup_metadata.status@ enum. +-- See +data RollupStatus + = RollupStatusInit + | RollupStatusStarted + | RollupStatusFinished + | RollupStatusFailed + | RollupStatusStopped + | RollupStatusRetry + | RollupStatusCustom Text + deriving stock (Eq, Show) + +rollupStatusText :: RollupStatus -> Text +rollupStatusText = \case + RollupStatusInit -> "init" + RollupStatusStarted -> "started" + RollupStatusFinished -> "finished" + RollupStatusFailed -> "failed" + RollupStatusStopped -> "stopped" + RollupStatusRetry -> "retry" + RollupStatusCustom t -> t + +instance ToJSON RollupStatus where + toJSON = toJSON . rollupStatusText + +instance FromJSON RollupStatus where + parseJSON = withText "RollupStatus" $ \case + "init" -> pure RollupStatusInit + "started" -> pure RollupStatusStarted + "finished" -> pure RollupStatusFinished + "failed" -> pure RollupStatusFailed + "stopped" -> pure RollupStatusStopped + "retry" -> pure RollupStatusRetry + other -> pure (RollupStatusCustom other) + +-- | The @rollup_metadata.stats@ object. +-- See +data RollupStats = RollupStats + { rollupStatsPagesProcessed :: Int, + rollupStatsDocumentsProcessed :: Int, + rollupStatsRollupsIndexed :: Int, + rollupStatsIndexTimeInMillis :: Integer, + rollupStatsSearchTimeInMillis :: Integer + } + deriving stock (Eq, Show) + +instance FromJSON RollupStats where + parseJSON = withObject "RollupStats" $ \v -> do + rollupStatsPagesProcessed <- v .: "pages_processed" + rollupStatsDocumentsProcessed <- v .: "documents_processed" + rollupStatsRollupsIndexed <- v .: "rollups_indexed" + rollupStatsIndexTimeInMillis <- v .: "index_time_in_millis" + rollupStatsSearchTimeInMillis <- v .: "search_time_in_millis" + pure RollupStats {..} + +instance ToJSON RollupStats where + toJSON RollupStats {..} = + object + [ "pages_processed" .= rollupStatsPagesProcessed, + "documents_processed" .= rollupStatsDocumentsProcessed, + "rollups_indexed" .= rollupStatsRollupsIndexed, + "index_time_in_millis" .= rollupStatsIndexTimeInMillis, + "search_time_in_millis" .= rollupStatsSearchTimeInMillis + ] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/SQLPPL.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/SQLPPL.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/SQLPPL.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.SQLPPL + ( SQLRequest (..), + PPLRequest (..), + SQLParameter (..), + SQLCursor (..), + SQLCursorRequest (..), + SQLColumn (..), + SQLResult (..), + PPLResult, + SQLCloseResult (..), + ) +where + +import Data.Aeson + ( FromJSON (..), + ToJSON (..), + Value, + object, + withObject, + (.:), + (.:?), + (.=), + ) +import Data.Text (Text) +import Database.Bloodhound.Internal.Utils.Imports (omitNulls) + +-- $schema +-- +-- The OpenSearch SQL and PPL query endpoints +-- () +-- share a single Query API surface that differs only by path +-- (@POST /_plugins/_sql@ versus @POST /_plugins/_ppl@) and by the dialect of +-- the @query@ string. The response shape (a JDBC-style rowset) is identical. +-- +-- /Pagination/ is SQL-only: when the request body includes a positive +-- @fetch_size@, the first response carries a 'SQLCursor' and subsequent pages +-- are fetched by POSTing a 'SQLCursorRequest' body (@{"cursor": "..."}@) to +-- the same @/_plugins/_sql@ endpoint. A continuation response omits the +-- @schema@, @total@, @size@ and @status@ fields, so every field of 'SQLResult' +-- except @datarows@ is 'Maybe'. The cursor is opaque (a @d:@-prefixed +-- server-generated token); release it with @POST /_plugins/_sql/close@. +-- +-- /Wire inconsistencies./ The plugin's response-field table documents the +-- row array as @data_rows@ and the HTTP status as a String; every JSON +-- example in the same docs uses @datarows@ and an integer (@200@). We trust +-- the wire (examples) over the prose: the field is @datarows@ and 'sqlResultStatus' +-- is 'Int'. +-- +-- /Format./ This module models the default @jdbc@ response format (the only +-- format whose body is the JSON shape below). The @csv@, @raw@ and @json@ +-- formats return non-JSON bodies and are out of scope; callers that need +-- them should bypass these types. + +-- | Request body for @POST /_plugins/_sql@. Only 'sqlRequestQuery' is +-- required; the rest are optional. @fetch_size@ requires the @jdbc@ +-- response format (the default) and triggers cursor pagination; a value of +-- @0@ falls back to non-paginated. @parameters@ carries prepared-statement +-- bind variables (shown in the plugin's @_explain@ examples though absent +-- from its field table). +data SQLRequest = SQLRequest + { sqlRequestQuery :: Text, + sqlRequestFilter :: Maybe Value, + sqlRequestFetchSize :: Maybe Int, + sqlRequestParameters :: Maybe [SQLParameter] + } + deriving stock (Eq, Show) + +instance ToJSON SQLRequest where + toJSON SQLRequest {..} = + omitNulls + [ "query" .= sqlRequestQuery, + "filter" .= sqlRequestFilter, + "fetch_size" .= sqlRequestFetchSize, + "parameters" .= sqlRequestParameters + ] + +instance FromJSON SQLRequest where + parseJSON = withObject "SQLRequest" $ \v -> do + sqlRequestQuery <- v .: "query" + sqlRequestFilter <- v .:? "filter" + sqlRequestFetchSize <- v .:? "fetch_size" + sqlRequestParameters <- v .:? "parameters" + pure SQLRequest {..} + +-- | Request body for @POST /_plugins/_ppl@. PPL does not support +-- @fetch_size@ / cursor pagination (the plugin documents @fetch_size@ as +-- SQL-only), so this record has no such field. +data PPLRequest = PPLRequest + { pplRequestQuery :: Text, + pplRequestFilter :: Maybe Value + } + deriving stock (Eq, Show) + +instance ToJSON PPLRequest where + toJSON PPLRequest {..} = + omitNulls + [ "query" .= pplRequestQuery, + "filter" .= pplRequestFilter + ] + +instance FromJSON PPLRequest where + parseJSON = withObject "PPLRequest" $ \v -> do + pplRequestQuery <- v .: "query" + pplRequestFilter <- v .:? "filter" + pure PPLRequest {..} + +-- | A prepared-statement bind variable, as documented by the plugin's +-- @_explain@ examples: @{"type": "integer", "value": 30}@. The @type@ field +-- uses an open vocabulary (@integer@, @string@, @long@, @boolean@, ...) so +-- it is kept as 'Text' rather than a closed enum. +data SQLParameter = SQLParameter + { sqlParameterType :: Text, + sqlParameterValue :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SQLParameter where + toJSON SQLParameter {..} = + object + [ "type" .= sqlParameterType, + "value" .= sqlParameterValue + ] + +instance FromJSON SQLParameter where + parseJSON = withObject "SQLParameter" $ \v -> do + sqlParameterType <- v .: "type" + sqlParameterValue <- v .: "value" + pure SQLParameter {..} + +-- | An opaque pagination cursor returned by paginated SQL responses. The +-- wire value is a @d:@-prefixed base64 blob; treat it as opaque and send it +-- back verbatim via 'SQLCursorRequest' or @POST /_plugins/_sql/close@. +newtype SQLCursor = SQLCursor {unSQLCursor :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | Request body for cursor continuation and close requests +-- (@{"cursor": "..."}@). The server rejects a body that carries both +-- @query@ and @cursor@, so this is a distinct type from 'SQLRequest'. +newtype SQLCursorRequest = SQLCursorRequest {sqlCursorRequestCursor :: SQLCursor} + deriving stock (Eq, Show) + +instance ToJSON SQLCursorRequest where + toJSON SQLCursorRequest {..} = + object ["cursor" .= sqlCursorRequestCursor] + +instance FromJSON SQLCursorRequest where + parseJSON = withObject "SQLCursorRequest" $ \v -> do + sqlCursorRequestCursor <- v .: "cursor" + pure SQLCursorRequest {..} + +-- | One column descriptor from the 'SQLResult' @schema@ array. The @type@ +-- field uses an open vocabulary (@long@, @text@, @double@, @boolean@, +-- @keyword@, ...) plus user-defined types via index mappings, so it is kept +-- as 'Text' rather than a closed enum. +data SQLColumn = SQLColumn + { sqlColumnName :: Text, + sqlColumnType :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SQLColumn where + parseJSON = withObject "SQLColumn" $ \v -> do + sqlColumnName <- v .: "name" + sqlColumnType <- v .: "type" + pure SQLColumn {..} + +instance ToJSON SQLColumn where + toJSON SQLColumn {..} = + object + [ "name" .= sqlColumnName, + "type" .= sqlColumnType + ] + +-- | Response of @POST /_plugins/_sql@ and @POST /_plugins/_ppl@. Only +-- 'sqlResultDatarows' is present on every response (initial, continuation, +-- and final page); @schema@, @total@, @size@ and @status@ are dropped on +-- cursor-continuation pages and are therefore 'Maybe'. @cursor@ is present +-- on every page except the last. Each row in @datarows@ is a heterogeneous +-- JSON array whose cells line up with 'sqlResultSchema'; cells are kept as +-- aeson 'Value's because the column type governs interpretation, not the +-- Haskell type. +data SQLResult = SQLResult + { sqlResultSchema :: Maybe [SQLColumn], + sqlResultDatarows :: [[Value]], + sqlResultTotal :: Maybe Int, + sqlResultSize :: Maybe Int, + sqlResultStatus :: Maybe Int, + sqlResultCursor :: Maybe SQLCursor + } + deriving stock (Eq, Show) + +instance FromJSON SQLResult where + parseJSON = withObject "SQLResult" $ \v -> do + sqlResultSchema <- v .:? "schema" + sqlResultDatarows <- v .: "datarows" + sqlResultTotal <- v .:? "total" + sqlResultSize <- v .:? "size" + sqlResultStatus <- v .:? "status" + sqlResultCursor <- v .:? "cursor" + pure SQLResult {..} + +instance ToJSON SQLResult where + toJSON SQLResult {..} = + omitNulls + [ "schema" .= sqlResultSchema, + "datarows" .= sqlResultDatarows, + "total" .= sqlResultTotal, + "size" .= sqlResultSize, + "status" .= sqlResultStatus, + "cursor" .= sqlResultCursor + ] + +-- | PPL uses the same response shape as SQL. The alias keeps the bead's +-- acceptance signature (@pplQuery :: ... -> m PPLResult@) self-documenting +-- without duplicating aeson instances. +type PPLResult = SQLResult + +-- | Response of @POST /_plugins/_sql/close@. Always @{"succeeded": true}@ on +-- a successful cursor release. +newtype SQLCloseResult = SQLCloseResult + { sqlCloseResultSucceeded :: Bool + } + deriving stock (Eq, Show) + +instance FromJSON SQLCloseResult where + parseJSON = withObject "SQLCloseResult" $ \v -> do + sqlCloseResultSucceeded <- v .: "succeeded" + pure SQLCloseResult {..} + +instance ToJSON SQLCloseResult where + toJSON SQLCloseResult {..} = + object ["succeeded" .= sqlCloseResultSucceeded] diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/SQLStats.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/SQLStats.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/SQLStats.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DerivingStrategies #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.SQLStats + ( SQLPluginStats (..), + ) +where + +import Data.Map.Strict qualified as Map +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The @GET /_plugins/_sql/stats@ endpoint (SQL plugin, see +-- ) +-- returns a JSON object whose keys are metric names (@request_total@, +-- @request_count@, @default_cursor_request_total@, +-- @default_cursor_request_count@, @failed_request_count_syserr@, +-- @failed_request_count_cuserr@, @failed_request_count_cb@, +-- @circuit_breaker@) and whose values are integers. The endpoint is +-- node-level only (the plugin explicitly documents that cluster-level +-- stats are not implemented), so unlike 'MLStats' there is no @nodes@ +-- sub-key and no cluster-level envelope — the body is one flat object +-- describing the node you hit. +-- +-- The metric-name set is large and grows across OpenSearch releases +-- (eight keys on 1.x; @ppl_*@, @datasource_*@, @async_query_*@, @emr_*@ +-- and @streaming_*@ keys land in later versions). Modelling the body as +-- a typed record would lock the client to one plugin version and +-- require churn on every release, so the body is kept as a flat +-- 'Map.Map Text Value' — callers get a typed envelope and navigate to +-- any individual metric with the aeson combinators they already use +-- elsewhere (e.g. @'Map.lookup' \"request_total\"@ followed by +-- @'fromJSON'@ into a 'Integer'). Every value the plugin emits today is +-- a JSON integer, but 'Value' is preferred over 'Integer' for forward +-- compatibility: if the plugin ever introduces a non-integer metric +-- (a string state, a floating-point ratio), the decoder does not need +-- to change. + +-- | Response of @GET /_plugins/_sql/stats@. The body is a flat JSON +-- object mapping metric names to integer values; see the module docs +-- for why the entries are kept as aeson 'Value's rather than modelled +-- per-metric. The 'Map.Map' round-trips a flat JSON object via its +-- aeson instances, so no custom 'ToJSON' \/ 'FromJSON' is needed. To +-- read an individual metric, decode the value with aeson, e.g.: +-- +-- @ +-- case 'Map.lookup' \"request_total\" (sqlPluginStatsEntries stats) of +-- 'Just' ('Number' n) -> ... n is a 'Scientific' ... +-- _ -> 'Nothing' +-- @ +newtype SQLPluginStats = SQLPluginStats + { sqlPluginStatsEntries :: Map.Map Text Value + } + deriving stock (Eq, Show) + deriving newtype (FromJSON, ToJSON) diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/SecurityAnalytics.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/SecurityAnalytics.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/SecurityAnalytics.hs @@ -0,0 +1,2807 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.SecurityAnalytics + ( -- * Identifiers + RuleId (..), + + -- * Discriminators + SADetectorType (..), + saDetectorTypeText, + + -- * Schedule + SASchedule (..), + SASchedulePeriod (..), + + -- * Inputs, triggers, actions + SARuleReference (..), + SADetectorInput (..), + SATrigger (..), + SAAction (..), + SAMessageTemplate (..), + SAThrottle (..), + + -- * Detector and response wrappers + SADetector (..), + SADetectorResponse (..), + + -- * Rule search + SARulesQuery (..), + defaultSARulesQuery, + SARulesTotal (..), + SARulesTotalRelation (..), + SARulesShards (..), + SARuleValue (..), + SARule (..), + SARuleHit (..), + SARulesSearchResponse (..), + saRulesSearchResponseRules, + + -- * Rule create, update, and delete + SARuleResponse (..), + DeleteSARuleResponse (..), + + -- * Detector update, delete, and search + SADetectorsSearchQuery (..), + defaultSADetectorsSearchQuery, + SADetectorsSearchResponse (..), + SADetectorHit (..), + SADetectorsTotal (..), + SADetectorsTotalRelation (..), + SADetectorsShards (..), + saDetectorsSearchResponseDetectors, + DeleteSADetectorResponse (..), + + -- * Mappings API + SAMappingProperty (..), + SAMappingsBody (..), + SAMappingsIndexBody (..), + SAMappingsViewRequest (..), + SAMappingsViewResponse (..), + SACreateMappingsRequest (..), + SAUpdateMappingsRequest (..), + SAGetMappingsResponse, + + -- * Alerts API + SAGetAlertsOptions (..), + defaultSAGetAlertsOptions, + saGetAlertsOptionsParams, + SAAlertState (..), + saAlertStateText, + SAActionExecutionResult (..), + SAAlert (..), + SAGetAlertsResponse (..), + AcknowledgeSADetectorAlertsRequest (..), + AcknowledgeSADetectorAlertsResponse (..), + + -- * Findings API + SASearchFindingsOptions (..), + defaultSASearchFindingsOptions, + saSearchFindingsOptionsParams, + SADetectionType (..), + saDetectionTypeText, + SASeverity (..), + saSeverityText, + SAFindingQuery (..), + SAFindingDocument (..), + SAFinding (..), + SASearchFindingsResponse (..), + + -- * Correlation API + SACorrelateEntry (..), + CreateSACorrelationRuleRequest (..), + SACorrelationRule (..), + CreateSACorrelationRuleResponse (..), + SACorrelationFinding (..), + GetSACorrelationsOptions (..), + defaultGetSACorrelationsOptions, + getSACorrelationsOptionsParams, + GetSACorrelationsResponse (..), + FindSACorrelationOptions (..), + defaultFindSACorrelationOptions, + findSACorrelationOptionsParams, + SACorrelationScore (..), + FindSACorrelationResponse (..), + SearchSACorrelationAlertsOptions (..), + defaultSearchSACorrelationAlertsOptions, + searchSACorrelationAlertsOptionsParams, + SACorrelationAlert (..), + SearchSACorrelationAlertsResponse (..), + AcknowledgeSACorrelationAlertsRequest (..), + AcknowledgeSACorrelationAlertsResponse (..), + + -- * Log type API + SALogTypeSource (..), + saLogTypeSourceText, + SALogTypeTags (..), + SALogType (..), + SALogTypeResponse (..), + SALogTypeSearchQuery (..), + defaultSALogTypeSearchQuery, + SALogTypeHit (..), + SALogTypesTotal (..), + SALogTypesTotalRelation (..), + SALogTypesSearchResponse (..), + saLogTypesSearchResponseLogTypes, + DeleteSALogTypeResponse (..), + ) +where + +import Data.Aeson +import Data.Aeson.Key qualified as K (fromText) +import Data.Aeson.KeyMap qualified as KM +import Data.Int (Int64) +import Data.Map.Strict (Map) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- $schema +-- +-- The Security Analytics plugin (see +-- ) +-- runs scheduled detectors over log indexes, evaluates them against +-- Sigma rules (pre-packaged and custom), and dispatches alert +-- notifications when trigger conditions fire. This module covers the +-- detector create\/get endpoints +-- (@POST\/GET \/\/_plugins\/_security_analytics\/detectors[\/{id}]@) and +-- the rule search endpoints +-- (@POST \/\/_plugins\/_security_analytics\/rules\/_search?pre_packaged=@). +-- +-- The wire shape of a 'SADetector' is a discriminated object: the +-- @detector_type@ field selects one of the documented log types +-- (linux, network, windows, ad_ldap, ...), the @inputs@ array carries +-- index references plus rule references, and the @triggers@ array +-- carries alert triggers with their own actions. Following the +-- pragmatic precedent set by the sibling Alerting 'Monitor' type, this +-- module types the /shell/ — the stable fields common to every +-- detector — and models the fields this library does not yet +-- interpret as opaque aeson 'Value's. Unknown top-level keys are +-- preserved verbatim in 'saDetectorOther' / 'saTriggerOther' / +-- 'saActionOther' so future plugin additions, server-injected +-- timestamps (@last_update_time@, @enabled_time@), and the +-- @rule_topic_index@ \/ @alert_index@ \/ @findings_index@ family of +-- server-managed fields round-trip cleanly. +-- +-- Wire gotchas pinned by the test suite: +-- +-- * @triggers[].severity@ is documented as an 'Int' but the wire emits +-- a string-encoded integer (e.g. @"1"@); typed as 'Text' to match +-- the wire, mirroring the Alerting 'triggerSeverity' precedent. +-- * @triggers[].actions@ is documented as an Object but is actually +-- an array of action objects on the wire; typed as @['SAAction']@. +-- * The @type@ discriminator (constant @"detector"@) and +-- @triggers[].types@ appear in the examples but are not in the +-- field table; captured as typed @Maybe 'Text'@ / @['Text']@ fields +-- rather than dropped into the catch-all. +-- * The request example encodes @detector_type@ in upper case +-- (@\"WINDOWS\"@); the response lower-cases it (@\"windows\"@). The +-- 'SADetectorType' renderer emits the lower-case form so a +-- create-then-get round-trip is byte-stable on the @detector_type@ +-- field; callers wanting the upper-case request form can use +-- 'SADetectorTypeOther'. +-- +-- The rule retrieval surface deviates from the bead's +-- @getSARules :: m [SARule]@ acceptance: the +-- @GET \/\/_plugins\/_security_analytics\/rules@ endpoint the bead +-- names does not exist on the server. Rule retrieval is via the +-- search endpoints @POST ...\/rules\/_search?pre_packaged=true|false@, +-- returning a standard OpenSearch search envelope +-- ('SARulesSearchResponse'). Two functions are shipped +-- ('searchSAPrePackagedRules' and 'searchSACustomRules'); see the +-- Haddock on those functions and the changelog entry for +-- bloodhound-04f.6.11.3 for the deviation rationale (mirrors the +-- 'deleteMonitor' / bloodhound-04f.6.7.4 precedent). + +-- | The server-assigned identifier of a rule (custom or +-- pre-packaged). Wraps 'Text' for the same reason as 'DetectorId'. +newtype RuleId = RuleId {unRuleId :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- | The @detector_type@ discriminator selecting the log type the +-- detector runs against. The eight values documented on the API page +-- are given dedicated constructors; any future log type falls through +-- to 'SADetectorTypeOther'. 'saDetectorTypeText' round-trips every +-- constructor in the lower-case form the server persists. +data SADetectorType + = SADetectorTypeLinux + | SADetectorTypeNetwork + | SADetectorTypeWindows + | SADetectorTypeAdLdap + | SADetectorTypeApacheAccess + | SADetectorTypeCloudtrail + | SADetectorTypeDns + | SADetectorTypeS3 + | SADetectorTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'SADetectorType'. Values are the lower-case +-- forms the server persists on the response; the request example in +-- the docs uses upper case (@\"WINDOWS\"@) but the server +-- normalises, so the lower-case form is emitted here for round-trip +-- stability. +saDetectorTypeText :: SADetectorType -> Text +saDetectorTypeText = \case + SADetectorTypeLinux -> "linux" + SADetectorTypeNetwork -> "network" + SADetectorTypeWindows -> "windows" + SADetectorTypeAdLdap -> "ad_ldap" + SADetectorTypeApacheAccess -> "apache_access" + SADetectorTypeCloudtrail -> "cloudtrail" + SADetectorTypeDns -> "dns" + SADetectorTypeS3 -> "s3" + SADetectorTypeOther t -> t + +instance ToJSON SADetectorType where + toJSON = toJSON . saDetectorTypeText + +instance FromJSON SADetectorType where + parseJSON = withText "SADetectorType" $ \t -> + pure $ + case T.toLower t of + "linux" -> SADetectorTypeLinux + "network" -> SADetectorTypeNetwork + "windows" -> SADetectorTypeWindows + "ad_ldap" -> SADetectorTypeAdLdap + "apache_access" -> SADetectorTypeApacheAccess + "cloudtrail" -> SADetectorTypeCloudtrail + "dns" -> SADetectorTypeDns + "s3" -> SADetectorTypeS3 + _ -> SADetectorTypeOther t + +-- | The @schedule.period@ sub-object. Deliberately mirrors the shape +-- of 'Database.Bloodhound.Internal.Versions.OpenSearch3.Types.Alerting.SchedulePeriod' +-- but is modelled locally under an @SA@-prefixed name so the two +-- plugins can evolve independently (the same precedent the codebase +-- uses for per-plugin @Shards@ types). +data SASchedulePeriod = SASchedulePeriod + { saSchedulePeriodInterval :: Int, + saSchedulePeriodUnit :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SASchedulePeriod where + toJSON SASchedulePeriod {..} = + object + [ "interval" .= saSchedulePeriodInterval, + "unit" .= saSchedulePeriodUnit + ] + +instance FromJSON SASchedulePeriod where + parseJSON = withObject "SASchedulePeriod" $ \o -> + SASchedulePeriod + <$> o .: "interval" + <*> o .: "unit" + +-- | The @schedule@ sub-object. The Security Analytics detector API +-- documents only the @period {interval, unit}@ variant; any other +-- shape is preserved verbatim via 'OtherSASchedule' so a decode +-- never drops user data (mirrors the Alerting 'Schedule' design). +data SASchedule + = PeriodSASchedule SASchedulePeriod + | OtherSASchedule Value + deriving stock (Eq, Show) + +instance ToJSON SASchedule where + toJSON = \case + PeriodSASchedule p -> object ["period" .= p] + OtherSASchedule v -> v + +instance FromJSON SASchedule where + parseJSON = withObject "SASchedule" $ \o -> + (PeriodSASchedule <$> o .: "period") + <|> pure (OtherSASchedule (Object o)) + +-- | The @{\"id\": ...}@ shape used by both @custom_rules@ and +-- @pre_packaged_rules@ in 'SADetectorInput'. The id is opaque to +-- this library — it can be a UUID or a server-assigned base64 string +-- depending on whether the rule is custom or pre-packaged. +newtype SARuleReference = SARuleReference {saRuleReferenceId :: Text} + deriving stock (Eq, Show) + +instance ToJSON SARuleReference where + toJSON (SARuleReference i) = object ["id" .= i] + +instance FromJSON SARuleReference where + parseJSON = withObject "SARuleReference" $ \o -> + SARuleReference <$> o .: "id" + +-- | The @inputs[].detector_input@ sub-object: the index list plus +-- the rule references that the detector evaluates. The docs document +-- only one input element per detector (multi-input is on the +-- roadmap); typed as a single record rather than a list-of-records +-- to match the wire. +-- +-- On the wire each @inputs[]@ element is wrapped in a constant +-- @{"detector_input": {...}}@ envelope. The 'FromJSON' instance +-- transparently descends into the wrapper so callers never see it; +-- 'ToJSON' re-injects it so a round-trip encode is lossless (mirrors +-- the Alerting 'Trigger' unwrap of @bucket_level_trigger@ / +-- @document_level_trigger@). +data SADetectorInput = SADetectorInput + { saDetectorInputDescription :: Maybe Text, + saDetectorInputIndices :: [Text], + saDetectorInputCustomRules :: [SARuleReference], + saDetectorInputPrePackagedRules :: [SARuleReference], + saDetectorInputOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SADetectorInput where + toJSON i = object ["detector_input" .= body] + where + body = + case saDetectorInputOther i of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + typed = + [ "description" .= saDetectorInputDescription i, + "indices" .= saDetectorInputIndices i, + "custom_rules" .= saDetectorInputCustomRules i, + "pre_packaged_rules" .= saDetectorInputPrePackagedRules i + ] + +instance FromJSON SADetectorInput where + parseJSON = withObject "SADetectorInput" $ \o -> do + -- The wire wraps every element in {"detector_input": {...}}. + -- Descend into the wrapper if present; otherwise parse the + -- fields directly (defensive against a future wire change that + -- drops the wrapper). + let body = case KM.lookup (K.fromText "detector_input") o of + Just (Object inner) -> inner + _ -> o + SADetectorInput + <$> body .:? "description" + <*> body .:? "indices" .!= [] + <*> body .:? "custom_rules" .!= [] + <*> body .:? "pre_packaged_rules" .!= [] + <*> pure (Object o) + +-- | The @message_template@ \/ @subject_template@ sub-object on an +-- 'SAAction'. The server injects @"lang": "mustache"@ on responses +-- even when the request omits it; both directions round-trip here. +data SAMessageTemplate = SAMessageTemplate + { saMessageTemplateSource :: Text, + saMessageTemplateLang :: Maybe Text + } + deriving stock (Eq, Show) + +instance ToJSON SAMessageTemplate where + toJSON SAMessageTemplate {..} = + omitNulls + [ "source" .= saMessageTemplateSource, + "lang" .= saMessageTemplateLang + ] + +instance FromJSON SAMessageTemplate where + parseJSON = withObject "SAMessageTemplate" $ \o -> + SAMessageTemplate + <$> o .: "source" + <*> o .:? "lang" + +-- | The @throttle@ sub-object on an 'SAAction' (@{value, unit}@). +data SAThrottle = SAThrottle + { saThrottleValue :: Int, + saThrottleUnit :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SAThrottle where + toJSON SAThrottle {..} = + object + [ "value" .= saThrottleValue, + "unit" .= saThrottleUnit + ] + +instance FromJSON SAThrottle where + parseJSON = withObject "SAThrottle" $ \o -> + SAThrottle + <$> o .: "value" + <*> o .: "unit" + +-- | A single action within a trigger. The typed fields are those +-- documented on the API page; any forward-compat key (or a field +-- this type does not yet model) is preserved verbatim in +-- 'saActionOther'. +data SAAction = SAAction + { saActionId :: Maybe Text, + saActionName :: Maybe Text, + saActionDestinationId :: Maybe Text, + saActionMessageTemplate :: Maybe SAMessageTemplate, + saActionSubjectTemplate :: Maybe SAMessageTemplate, + saActionThrottleEnabled :: Maybe Bool, + saActionThrottle :: Maybe SAThrottle, + saActionOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAAction where + toJSON a = + case saActionOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= saActionId a, + "name" .= saActionName a, + "destination_id" .= saActionDestinationId a, + "message_template" .= saActionMessageTemplate a, + "subject_template" .= saActionSubjectTemplate a, + "throttle_enabled" .= saActionThrottleEnabled a, + "throttle" .= saActionThrottle a + ] + +instance FromJSON SAAction where + parseJSON = withObject "SAAction" $ \o -> + SAAction + <$> o .:? "id" + <*> o .:? "name" + <*> o .:? "destination_id" + <*> o .:? "message_template" + <*> o .:? "subject_template" + <*> o .:? "throttle_enabled" + <*> o .:? "throttle" + <*> pure (Object o) + +-- | A single trigger. The typed fields cover every key documented on +-- the API page plus the @types@ key that appears in the example but +-- not the field table. The full original element is preserved in +-- 'saTriggerOther' so a round-trip encode is lossless. +-- +-- @saTriggerSeverity@ is a 'Text' rather than an 'Int' because the +-- wire emits a string-encoded integer (e.g. @"1"@) — same gotcha as +-- the sibling Alerting 'triggerSeverity' field. +data SATrigger = SATrigger + { saTriggerId :: Maybe Text, + saTriggerName :: Text, + saTriggerSeverity :: Text, + saTriggerIds :: [Text], + saTriggerTypes :: [Text], + saTriggerTags :: [Text], + saTriggerSevLevels :: [Text], + saTriggerActions :: [SAAction], + saTriggerOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SATrigger where + toJSON t = + case saTriggerOther t of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= saTriggerId t, + "name" .= saTriggerName t, + "severity" .= saTriggerSeverity t, + "ids" .= saTriggerIds t, + "types" .= saTriggerTypes t, + "tags" .= saTriggerTags t, + "sev_levels" .= saTriggerSevLevels t, + "actions" .= saTriggerActions t + ] + +instance FromJSON SATrigger where + parseJSON = withObject "SATrigger" $ \o -> + SATrigger + <$> o .:? "id" + <*> o .: "name" + <*> o .:? "severity" .!= "1" + <*> o .:? "ids" .!= [] + <*> o .:? "types" .!= [] + <*> o .:? "tags" .!= [] + <*> o .:? "sev_levels" .!= [] + <*> o .:? "actions" .!= [] + <*> pure (Object o) + +-- | The top-level 'SADetector' document. Typed fields cover every +-- key the API documents on requests and responses; the +-- server-injected timestamps (@last_update_time@, @enabled_time@) +-- and any future plugin key round-trip via 'saDetectorOther'. +-- +-- @saDetectorKind@ is the @type@ discriminator field (constant +-- @"detector"@); distinct from @saDetectorType@ which is the +-- @detector_type@ log-type enum. +data SADetector = SADetector + { saDetectorName :: Text, + saDetectorType :: SADetectorType, + saDetectorKind :: Maybe Text, + saDetectorEnabled :: Maybe Bool, + saDetectorSchedule :: SASchedule, + saDetectorInputs :: [SADetectorInput], + saDetectorTriggers :: [SATrigger], + saDetectorOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SADetector where + toJSON d = + case saDetectorOther d of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= saDetectorName d, + "detector_type" .= saDetectorType d, + "type" .= saDetectorKind d, + "enabled" .= saDetectorEnabled d, + "schedule" .= saDetectorSchedule d, + "inputs" .= saDetectorInputs d, + "triggers" .= saDetectorTriggers d + ] + +instance FromJSON SADetector where + parseJSON = withObject "SADetector" $ \o -> + SADetector + <$> o .: "name" + <*> o .: "detector_type" + <*> o .:? "type" + <*> o .:? "enabled" + <*> o .: "schedule" + <*> o .:? "inputs" .!= [] + <*> o .:? "triggers" .!= [] + <*> pure (Object o) + +-- | Response wrapper for @POST@ and the inner field of @GET@ on +-- @\/_plugins\/_security_analytics\/detectors[\/{id}]@. Carries the +-- indexing metadata (@_id@, @_version@) alongside the persisted +-- detector document. The @GET@ endpoint returns the same wrapper on +-- the wire; 'getSADetector' decodes it and projects the inner +-- 'SADetector' out so the public type matches the bead acceptance +-- (@m 'SADetector'@). Callers needing @_id@ \/ @_version@ can build +-- the underlying request directly. +data SADetectorResponse = SADetectorResponse + { saDetectorResponseId :: Text, + saDetectorResponseVersion :: Int64, + saDetectorResponseDetector :: SADetector + } + deriving stock (Eq, Show) + +instance FromJSON SADetectorResponse where + parseJSON = withObject "SADetectorResponse" $ \o -> + SADetectorResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "detector" + +instance ToJSON SADetectorResponse where + toJSON SADetectorResponse {..} = + object + [ "_id" .= saDetectorResponseId, + "_version" .= saDetectorResponseVersion, + "detector" .= saDetectorResponseDetector + ] + +-- ========================================================================= +-- Rule search +-- ========================================================================= + +-- | Optional query body for the rule search endpoints. The +-- @from@ \/ @size@ pair is the standard OpenSearch pagination cursor; +-- @query@ is the standard OpenSearch query DSL, kept opaque because +-- its shape varies by use case. Pass 'Nothing' to the request +-- builder (or 'defaultSARulesQuery' to the body renderer) for the +-- plain empty-body @{}@ POST. +data SARulesQuery = SARulesQuery + { saRulesQueryFrom :: Maybe Int, + saRulesQuerySize :: Maybe Int, + saRulesQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultSARulesQuery :: SARulesQuery +defaultSARulesQuery = SARulesQuery Nothing Nothing Nothing + +instance ToJSON SARulesQuery where + toJSON SARulesQuery {..} = + omitNulls + [ "from" .= saRulesQueryFrom, + "size" .= saRulesQuerySize, + "query" .= saRulesQueryQuery + ] + +instance FromJSON SARulesQuery where + parseJSON = withObject "SARulesQuery" $ \o -> + SARulesQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "query" + +-- | The @hits.total.relation@ discriminator on a search response. +data SARulesTotalRelation + = SARulesTotalRelationEq + | SARulesTotalRelationGe + | SARulesTotalRelationOther Text + deriving stock (Eq, Show) + +saRulesTotalRelationText :: SARulesTotalRelation -> Text +saRulesTotalRelationText = \case + SARulesTotalRelationEq -> "eq" + SARulesTotalRelationGe -> "ge" + SARulesTotalRelationOther t -> t + +instance ToJSON SARulesTotalRelation where + toJSON = toJSON . saRulesTotalRelationText + +instance FromJSON SARulesTotalRelation where + parseJSON = withText "SARulesTotalRelation" $ \t -> + pure $ + case t of + "eq" -> SARulesTotalRelationEq + "ge" -> SARulesTotalRelationGe + other -> SARulesTotalRelationOther other + +-- | The @hits.total@ sub-object on a search response +-- (@{value, relation}@). +data SARulesTotal = SARulesTotal + { saRulesTotalValue :: Int64, + saRulesTotalRelation :: SARulesTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON SARulesTotal where + parseJSON = withObject "SARulesTotal" $ \o -> + SARulesTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON SARulesTotal where + toJSON SARulesTotal {..} = + object + [ "value" .= saRulesTotalValue, + "relation" .= saRulesTotalRelation + ] + +-- | The @_shards@ sub-object on a search response. Modelled locally +-- under an @SA@-prefixed name (mirroring the Alerting +-- 'AlertingShards' precedent) rather than re-using the cluster-level +-- 'ShardsResult' envelope, which wraps the outer +-- @{\"_shards\": {...}}@ shape — one level too high for inline use +-- here. +data SARulesShards = SARulesShards + { saRulesShardsTotal :: Int, + saRulesShardsSuccessful :: Int, + saRulesShardsSkipped :: Int, + saRulesShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON SARulesShards where + parseJSON = withObject "SARulesShards" $ \o -> + SARulesShards + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "skipped" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON SARulesShards where + toJSON SARulesShards {..} = + object + [ "total" .= saRulesShardsTotal, + "successful" .= saRulesShardsSuccessful, + "skipped" .= saRulesShardsSkipped, + "failed" .= saRulesShardsFailed + ] + +-- | The @{\"value\": ...}@ wrapper used by @references@, @tags@, +-- @queries@, and @false_positives@ on a 'SARule'. Modelled once and +-- reused because all four fields share the same wire shape. +newtype SARuleValue = SARuleValue {saRuleValueValue :: Text} + deriving stock (Eq, Show) + +instance ToJSON SARuleValue where + toJSON (SARuleValue v) = object ["value" .= v] + +instance FromJSON SARuleValue where + parseJSON = withObject "SARuleValue" $ \o -> SARuleValue <$> o .: "value" + +-- | A Sigma rule document, as returned in @hits.hits[]._source@ by +-- the rule search endpoints. Typed fields cover every key observed +-- in the documented fixtures; @rule@ is kept as 'Text' (the original +-- Sigma YAML serialised to a string), and any forward-compat key +-- round-trips via 'saRuleOther'. +data SARule = SARule + { saRuleCategory :: Maybe Text, + saRuleTitle :: Maybe Text, + saRuleLogSource :: Maybe Text, + saRuleDescription :: Maybe Text, + saRuleReferences :: [SARuleValue], + saRuleTags :: [SARuleValue], + saRuleLevel :: Maybe Text, + saRuleFalsePositives :: [SARuleValue], + saRuleAuthor :: Maybe Text, + saRuleStatus :: Maybe Text, + saRuleLastUpdateTime :: Maybe Text, + saRuleQueries :: [SARuleValue], + saRuleRule :: Maybe Text, + saRuleOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SARule where + parseJSON = withObject "SARule" $ \o -> + SARule + <$> o .:? "category" + <*> o .:? "title" + <*> o .:? "log_source" + <*> o .:? "description" + <*> o .:? "references" .!= [] + <*> o .:? "tags" .!= [] + <*> o .:? "level" + <*> o .:? "false_positives" .!= [] + <*> o .:? "author" + <*> o .:? "status" + <*> o .:? "last_update_time" + <*> o .:? "queries" .!= [] + <*> o .:? "rule" + <*> pure (Object o) + +instance ToJSON SARule where + toJSON r = + case saRuleOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "category" .= saRuleCategory r, + "title" .= saRuleTitle r, + "log_source" .= saRuleLogSource r, + "description" .= saRuleDescription r, + "references" .= saRuleReferences r, + "tags" .= saRuleTags r, + "level" .= saRuleLevel r, + "false_positives" .= saRuleFalsePositives r, + "author" .= saRuleAuthor r, + "status" .= saRuleStatus r, + "last_update_time" .= saRuleLastUpdateTime r, + "queries" .= saRuleQueries r, + "rule" .= saRuleRule r + ] + +-- | A single hit in @hits.hits[]@ on a rule search response. +data SARuleHit = SARuleHit + { saRuleHitIndex :: Maybe Text, + saRuleHitId :: Text, + saRuleHitVersion :: Maybe Int64, + saRuleHitSeqNo :: Maybe Int64, + saRuleHitPrimaryTerm :: Maybe Int64, + saRuleHitScore :: Maybe Double, + saRuleHitSource :: SARule + } + deriving stock (Eq, Show) + +instance FromJSON SARuleHit where + parseJSON = withObject "SARuleHit" $ \o -> + SARuleHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON SARuleHit where + toJSON SARuleHit {..} = + omitNulls + [ "_index" .= saRuleHitIndex, + "_id" .= saRuleHitId, + "_version" .= saRuleHitVersion, + "_seq_no" .= saRuleHitSeqNo, + "_primary_term" .= saRuleHitPrimaryTerm, + "_score" .= saRuleHitScore, + "_source" .= saRuleHitSource + ] + +-- | Response envelope for the rule search endpoints. Decoded +-- verbatim from the standard OpenSearch search-response shape; the +-- paging metadata (@took@, @timed_out@, @_shards@, @hits.total@, +-- @hits.max_score@) is preserved alongside the rule list so callers +-- can drive pagination and observe shard health. +data SARulesSearchResponse = SARulesSearchResponse + { saRulesSearchResponseTook :: Int64, + saRulesSearchResponseTimedOut :: Bool, + saRulesSearchResponseShards :: SARulesShards, + saRulesSearchResponseTotal :: SARulesTotal, + saRulesSearchResponseMaxScore :: Maybe Double, + saRulesSearchResponseHits :: [SARuleHit] + } + deriving stock (Eq, Show) + +instance FromJSON SARulesSearchResponse where + parseJSON = withObject "SARulesSearchResponse" $ \o -> do + hits <- o .: "hits" + SARulesSearchResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SARulesSearchResponse where + toJSON SARulesSearchResponse {..} = + object + [ "took" .= saRulesSearchResponseTook, + "timed_out" .= saRulesSearchResponseTimedOut, + "_shards" .= saRulesSearchResponseShards, + "hits" + .= object + [ "total" .= saRulesSearchResponseTotal, + "max_score" .= saRulesSearchResponseMaxScore, + "hits" .= saRulesSearchResponseHits + ] + ] + +-- | Project the decoded 'SARule' list out of a 'SARulesSearchResponse' +-- (convenience for callers who only want the rules and not the +-- paging envelope). +saRulesSearchResponseRules :: SARulesSearchResponse -> [SARule] +saRulesSearchResponseRules = map saRuleHitSource . saRulesSearchResponseHits + +-- ========================================================================= +-- Rule create, update, and delete +-- ========================================================================= + +-- | Response wrapper for the rule create and update endpoints +-- (@POST /_plugins/_security_analytics/rules@ and +-- @PUT /_plugins/_security_analytics/rules/{id}@). Carries the +-- indexing metadata (@_id@, @_version@) alongside the persisted +-- 'SARule' document (the server parses the submitted Sigma YAML, +-- normalises it into the typed fields, and echoes the original YAML +-- back in 'saRuleRule'). Mirrors 'SADetectorResponse' (which wraps +-- @detector@ instead of @rule@). +data SARuleResponse = SARuleResponse + { saRuleResponseId :: Text, + saRuleResponseVersion :: Int64, + saRuleResponseRule :: SARule + } + deriving stock (Eq, Show) + +instance FromJSON SARuleResponse where + parseJSON = withObject "SARuleResponse" $ \o -> + SARuleResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "rule" + +instance ToJSON SARuleResponse where + toJSON SARuleResponse {..} = + object + [ "_id" .= saRuleResponseId, + "_version" .= saRuleResponseVersion, + "rule" .= saRuleResponseRule + ] + +-- | Response body for +-- @DELETE /_plugins/_security_analytics/rules/{rule_id}@. The Security +-- Analytics plugin delegates the delete to the standard OpenSearch +-- delete-document operation, so the response is the bare Elasticsearch +-- delete-document body +-- (@{_index,_id,_version,result,forced_refresh,_shards,_seq_no,_primary_term}@) +-- with NO @acknowledged@ key. Modelled here verbatim — an +-- 'Acknowledged' decoder would raise 'EsProtocolException' at runtime +-- (same deviation pattern as 'DeleteSADetectorResponse' and the +-- Alerting 'DeleteMonitorResponse'). The @_shards@ sub-object reuses +-- 'SARulesShards' (the identical @{total,successful,skipped,failed}@ +-- shape shared by every SA search\/delete response). +data DeleteSARuleResponse = DeleteSARuleResponse + { deleteSARuleResponseIndex :: Text, + deleteSARuleResponseId :: Text, + deleteSARuleResponseVersion :: Int64, + deleteSARuleResponseResult :: Text, + deleteSARuleResponseForcedRefresh :: Bool, + deleteSARuleResponseShards :: SARulesShards, + deleteSARuleResponseSeqNo :: Int64, + deleteSARuleResponsePrimaryTerm :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteSARuleResponse where + parseJSON = withObject "DeleteSARuleResponse" $ \o -> + DeleteSARuleResponse + <$> o .: "_index" + <*> o .: "_id" + <*> o .: "_version" + <*> o .: "result" + <*> o .:? "forced_refresh" .!= False + <*> o .: "_shards" + <*> o .: "_seq_no" + <*> o .: "_primary_term" + +instance ToJSON DeleteSARuleResponse where + toJSON DeleteSARuleResponse {..} = + object + [ "_index" .= deleteSARuleResponseIndex, + "_id" .= deleteSARuleResponseId, + "_version" .= deleteSARuleResponseVersion, + "result" .= deleteSARuleResponseResult, + "forced_refresh" .= deleteSARuleResponseForcedRefresh, + "_shards" .= deleteSARuleResponseShards, + "_seq_no" .= deleteSARuleResponseSeqNo, + "_primary_term" .= deleteSARuleResponsePrimaryTerm + ] + +-- ========================================================================= +-- Detector update, delete, and search +-- ========================================================================= + +-- | Optional query body for the detector search endpoint +-- (@POST /_plugins/_security_analytics/detectors/_search@). The +-- @from@ \/ @size@ pair is the standard OpenSearch pagination cursor; +-- @query@ is the standard OpenSearch query DSL, kept opaque because +-- its shape varies by use case. Pass 'Nothing' to the request +-- builder (or 'defaultSADetectorsSearchQuery' to the body renderer) +-- for the plain empty-body @{}@ POST. Mirrors 'SARulesQuery'. +data SADetectorsSearchQuery = SADetectorsSearchQuery + { saDetectorsSearchQueryFrom :: Maybe Int, + saDetectorsSearchQuerySize :: Maybe Int, + saDetectorsSearchQueryQuery :: Maybe Value + } + deriving stock (Eq, Show) + +-- | The empty query: renders to @{}@ on the wire. +defaultSADetectorsSearchQuery :: SADetectorsSearchQuery +defaultSADetectorsSearchQuery = SADetectorsSearchQuery Nothing Nothing Nothing + +instance ToJSON SADetectorsSearchQuery where + toJSON SADetectorsSearchQuery {..} = + omitNulls + [ "from" .= saDetectorsSearchQueryFrom, + "size" .= saDetectorsSearchQuerySize, + "query" .= saDetectorsSearchQueryQuery + ] + +instance FromJSON SADetectorsSearchQuery where + parseJSON = withObject "SADetectorsSearchQuery" $ \o -> + SADetectorsSearchQuery + <$> o .:? "from" + <*> o .:? "size" + <*> o .:? "query" + +-- | The @hits.total.relation@ discriminator on a detector search +-- response. Mirrors 'SARulesTotalRelation'. +data SADetectorsTotalRelation + = SADetectorsTotalRelationEq + | SADetectorsTotalRelationGe + | SADetectorsTotalRelationOther Text + deriving stock (Eq, Show) + +saDetectorsTotalRelationText :: SADetectorsTotalRelation -> Text +saDetectorsTotalRelationText = \case + SADetectorsTotalRelationEq -> "eq" + SADetectorsTotalRelationGe -> "ge" + SADetectorsTotalRelationOther t -> t + +instance ToJSON SADetectorsTotalRelation where + toJSON = toJSON . saDetectorsTotalRelationText + +instance FromJSON SADetectorsTotalRelation where + parseJSON = withText "SADetectorsTotalRelation" $ \t -> + pure $ + case t of + "eq" -> SADetectorsTotalRelationEq + "ge" -> SADetectorsTotalRelationGe + other -> SADetectorsTotalRelationOther other + +-- | The @hits.total@ sub-object on a detector search response +-- (@{value, relation}@). Mirrors 'SARulesTotal'. +data SADetectorsTotal = SADetectorsTotal + { saDetectorsTotalValue :: Int64, + saDetectorsTotalRelation :: SADetectorsTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON SADetectorsTotal where + parseJSON = withObject "SADetectorsTotal" $ \o -> + SADetectorsTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON SADetectorsTotal where + toJSON SADetectorsTotal {..} = + object + [ "value" .= saDetectorsTotalValue, + "relation" .= saDetectorsTotalRelation + ] + +-- | The @_shards@ sub-object on a detector search response and on +-- 'DeleteSADetectorResponse'. Modelled locally (mirroring the +-- 'SARulesShards' precedent for the rule search endpoints) rather +-- than re-using the cluster-level 'ShardsResult' envelope, which +-- wraps the outer @{\"_shards\": {...}}@ shape — one level too high +-- for inline use here. Reused across detector search and detector +-- delete (both are detector-plugin operations with the identical +-- @{total, successful, skipped, failed}@ shape). +data SADetectorsShards = SADetectorsShards + { saDetectorsShardsTotal :: Int, + saDetectorsShardsSuccessful :: Int, + saDetectorsShardsSkipped :: Int, + saDetectorsShardsFailed :: Int + } + deriving stock (Eq, Show) + +instance FromJSON SADetectorsShards where + parseJSON = withObject "SADetectorsShards" $ \o -> + SADetectorsShards + <$> o .:? "total" .!= 0 + <*> o .:? "successful" .!= 0 + <*> o .:? "skipped" .!= 0 + <*> o .:? "failed" .!= 0 + +instance ToJSON SADetectorsShards where + toJSON SADetectorsShards {..} = + object + [ "total" .= saDetectorsShardsTotal, + "successful" .= saDetectorsShardsSuccessful, + "skipped" .= saDetectorsShardsSkipped, + "failed" .= saDetectorsShardsFailed + ] + +-- | A single hit in @hits.hits[]@ on a detector search response. The +-- @_source@ field is the stored detector document, modelled as +-- 'SADetector' (its typed shell plus an opaque 'Value' catch-all for +-- server-injected @last_update_time@ \/ @enabled_time@ and any +-- forward-compat key). Mirrors 'SARuleHit'. +data SADetectorHit = SADetectorHit + { saDetectorHitIndex :: Maybe Text, + saDetectorHitId :: Text, + saDetectorHitVersion :: Maybe Int64, + saDetectorHitSeqNo :: Maybe Int64, + saDetectorHitPrimaryTerm :: Maybe Int64, + saDetectorHitScore :: Maybe Double, + saDetectorHitSource :: SADetector + } + deriving stock (Eq, Show) + +instance FromJSON SADetectorHit where + parseJSON = withObject "SADetectorHit" $ \o -> + SADetectorHit + <$> o .:? "_index" + <*> o .: "_id" + <*> o .:? "_version" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + <*> o .:? "_score" + <*> o .: "_source" + +instance ToJSON SADetectorHit where + toJSON SADetectorHit {..} = + omitNulls + [ "_index" .= saDetectorHitIndex, + "_id" .= saDetectorHitId, + "_version" .= saDetectorHitVersion, + "_seq_no" .= saDetectorHitSeqNo, + "_primary_term" .= saDetectorHitPrimaryTerm, + "_score" .= saDetectorHitScore, + "_source" .= saDetectorHitSource + ] + +-- | Response envelope for the detector search endpoint +-- (@POST /_plugins/_security_analytics/detectors/_search@). Decoded +-- verbatim from the standard OpenSearch search-response shape; the +-- paging metadata (@took@, @timed_out@, @_shards@, @hits.total@, +-- @hits.max_score@) is preserved alongside the detector list so +-- callers can drive pagination and observe shard health. Mirrors +-- 'SARulesSearchResponse'. +-- +-- /Decode robustness/ (bloodhound-8o1): each hit's @_source@ is +-- decoded as a fully-typed 'SADetector' whose @name@, @detector_type@, +-- and @schedule@ are required. A single malformed stored detector +-- document therefore fails the ENTIRE response decode (aeson does not +-- skip bad hits). This is acceptable because the detector store is +-- plugin-managed and always writes the full schema (the GET\/create +-- paths share the same assumption); it is amplified only here because +-- search returns many documents per response. +data SADetectorsSearchResponse = SADetectorsSearchResponse + { saDetectorsSearchResponseTook :: Int64, + saDetectorsSearchResponseTimedOut :: Bool, + saDetectorsSearchResponseShards :: SADetectorsShards, + saDetectorsSearchResponseTotal :: SADetectorsTotal, + saDetectorsSearchResponseMaxScore :: Maybe Double, + saDetectorsSearchResponseHits :: [SADetectorHit] + } + deriving stock (Eq, Show) + +instance FromJSON SADetectorsSearchResponse where + parseJSON = withObject "SADetectorsSearchResponse" $ \o -> do + hits <- o .: "hits" + SADetectorsSearchResponse + <$> o .: "took" + <*> o .: "timed_out" + <*> o .: "_shards" + <*> hits .: "total" + <*> hits .:? "max_score" + <*> hits .:? "hits" .!= [] + +instance ToJSON SADetectorsSearchResponse where + toJSON SADetectorsSearchResponse {..} = + object + [ "took" .= saDetectorsSearchResponseTook, + "timed_out" .= saDetectorsSearchResponseTimedOut, + "_shards" .= saDetectorsSearchResponseShards, + "hits" + .= object + [ "total" .= saDetectorsSearchResponseTotal, + "max_score" .= saDetectorsSearchResponseMaxScore, + "hits" .= saDetectorsSearchResponseHits + ] + ] + +-- | Project the decoded 'SADetector' list out of a +-- 'SADetectorsSearchResponse' (convenience for callers who only want +-- the detectors and not the paging envelope). Mirrors +-- 'saRulesSearchResponseRules'. +saDetectorsSearchResponseDetectors :: SADetectorsSearchResponse -> [SADetector] +saDetectorsSearchResponseDetectors = map saDetectorHitSource . saDetectorsSearchResponseHits + +-- | Response body for +-- @DELETE /_plugins/_security_analytics/detectors/{detector_id}@. The +-- Security Analytics plugin delegates the delete to the standard +-- OpenSearch delete-document operation, so the body never carries an +-- @acknowledged@ key — an 'Acknowledged' decoder would raise +-- 'EsProtocolException' at runtime (same deviation pattern as the +-- Alerting 'DeleteMonitorResponse' and bloodhound-04f.3.13 rethrottle). +-- +-- The exact shape is version-dependent (live-verified in bead +-- bloodhound-z5j): +-- +-- * OS 2.x and 3.x return a minimal @_id@ + @_version@ envelope; the +-- indexing-metadata fields (@_index@, @result@, @_shards@, +-- @_seq_no@, ...) are omitted entirely. +-- * OS 1.3.x does not ship the Security Analytics plugin at all, so +-- the endpoint is unreachable there. +-- +-- Only @_id@ and @_version@ are present, so they are the sole required +-- fields; the rest are 'Maybe'. Modelled distinctly under an +-- @SA@-prefixed name so a plugin-specific response shape belongs to its +-- own type. +data DeleteSADetectorResponse = DeleteSADetectorResponse + { deleteSADetectorResponseId :: Text, + deleteSADetectorResponseVersion :: Int64, + deleteSADetectorResponseIndex :: Maybe Text, + deleteSADetectorResponseResult :: Maybe Text, + deleteSADetectorResponseForcedRefresh :: Maybe Bool, + deleteSADetectorResponseShards :: Maybe SADetectorsShards, + deleteSADetectorResponseSeqNo :: Maybe Int64, + deleteSADetectorResponsePrimaryTerm :: Maybe Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteSADetectorResponse where + parseJSON = withObject "DeleteSADetectorResponse" $ \o -> + DeleteSADetectorResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .:? "_index" + <*> o .:? "result" + <*> o .:? "forced_refresh" + <*> o .:? "_shards" + <*> o .:? "_seq_no" + <*> o .:? "_primary_term" + +instance ToJSON DeleteSADetectorResponse where + toJSON DeleteSADetectorResponse {..} = + omitNulls + [ "_id" .= deleteSADetectorResponseId, + "_version" .= deleteSADetectorResponseVersion, + "_index" .= deleteSADetectorResponseIndex, + "result" .= deleteSADetectorResponseResult, + "forced_refresh" .= deleteSADetectorResponseForcedRefresh, + "_shards" .= deleteSADetectorResponseShards, + "_seq_no" .= deleteSADetectorResponseSeqNo, + "_primary_term" .= deleteSADetectorResponsePrimaryTerm + ] + +-- ========================================================================= +-- Mappings API +-- ========================================================================= + +-- | The leaf property object (@{path, type}@) carried inside the +-- @properties@ map of every Mappings API body and response. The +-- @type@ field is conventionally @"alias"@ but the server may emit +-- other type discriminators, so it is typed as 'Text' rather than an +-- enum. Any forward-compat key round-trips via +-- 'saMappingPropertyOther' (mirrors the catch-all design of +-- 'SADetector' et al.). +data SAMappingProperty = SAMappingProperty + { saMappingPropertyPath :: Maybe Text, + saMappingPropertyType :: Maybe Text, + saMappingPropertyOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAMappingProperty where + toJSON p = + case saMappingPropertyOther p of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "path" .= saMappingPropertyPath p, + "type" .= saMappingPropertyType p + ] + +instance FromJSON SAMappingProperty where + parseJSON = withObject "SAMappingProperty" $ \o -> + SAMappingProperty + <$> o .:? "path" + <*> o .:? "type" + <*> pure (Object o) + +-- | The @{properties: {...}}@ sub-object reused by the create-mappings +-- request (@alias_mappings@) and by the get-mappings \/ view-mappings +-- responses (@mappings.properties@ \/ top-level @properties@). The +-- property map is keyed by the source field name (e.g. +-- @"windows-event_data-CommandLine"@); unknown keys round-trip via +-- 'saMappingsBodyOther'. +data SAMappingsBody = SAMappingsBody + { saMappingsBodyProperties :: Map Text SAMappingProperty, + saMappingsBodyOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAMappingsBody where + toJSON b = + case saMappingsBodyOther b of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = ["properties" .= saMappingsBodyProperties b] + +instance FromJSON SAMappingsBody where + parseJSON = withObject "SAMappingsBody" $ \o -> + SAMappingsBody + <$> o .:? "properties" .!= mempty + <*> pure (Object o) + +-- | The per-index body of a get-mappings response +-- (@{mappings: {properties: {...}}}@). The outer key of a +-- 'SAGetMappingsResponse' is the index name itself. +data SAMappingsIndexBody = SAMappingsIndexBody + { saMappingsIndexBodyMappings :: SAMappingsBody, + saMappingsIndexBodyOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAMappingsIndexBody where + toJSON b = + case saMappingsIndexBodyOther b of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = ["mappings" .= saMappingsIndexBodyMappings b] + +instance FromJSON SAMappingsIndexBody where + parseJSON = withObject "SAMappingsIndexBody" $ \o -> + SAMappingsIndexBody + <$> o .: "mappings" + <*> pure (Object o) + +-- | Response body for +-- @GET /_plugins/_security_analytics/mappings?index_name={name}@, +-- keyed by index name +-- (@{: {mappings: {properties: {...}}}}@). Modelled as a +-- 'Map' so the index-name keys decode directly; the per-index value is +-- 'SAMappingsIndexBody'. +type SAGetMappingsResponse = Map Text SAMappingsIndexBody + +-- | Request body for +-- @GET /_plugins/_security_analytics/mappings/view@: the index whose +-- fields should be inspected and the log type (rule topic) whose +-- mapping view is requested. Sent as the body of a GET (the server +-- requires the parameters in the request body, not the query string). +data SAMappingsViewRequest = SAMappingsViewRequest + { saMappingsViewIndexName :: Text, + saMappingsViewRuleTopic :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SAMappingsViewRequest where + toJSON r = + object + [ "index_name" .= saMappingsViewIndexName r, + "rule_topic" .= saMappingsViewRuleTopic r + ] + +instance FromJSON SAMappingsViewRequest where + parseJSON = withObject "SAMappingsViewRequest" $ \o -> + SAMappingsViewRequest + <$> o .: "index_name" + <*> o .: "rule_topic" + +-- | Response body for +-- @GET /_plugins/_security_analytics/mappings/view@. The @properties@ +-- map pairs each candidate alias name with its @{path, type}@ leaf +-- ('SAMappingProperty'); @unmapped_index_fields@ lists the source +-- fields that have no mapping. Any forward-compat key round-trips via +-- 'saMappingsViewResponseOther'. +data SAMappingsViewResponse = SAMappingsViewResponse + { saMappingsViewResponseProperties :: Map Text SAMappingProperty, + saMappingsViewResponseUnmappedIndexFields :: [Text], + saMappingsViewResponseOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAMappingsViewResponse where + toJSON r = + case saMappingsViewResponseOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "properties" .= saMappingsViewResponseProperties r, + "unmapped_index_fields" .= saMappingsViewResponseUnmappedIndexFields r + ] + +instance FromJSON SAMappingsViewResponse where + parseJSON = withObject "SAMappingsViewResponse" $ \o -> + SAMappingsViewResponse + <$> o .:? "properties" .!= mempty + <*> o .:? "unmapped_index_fields" .!= [] + <*> pure (Object o) + +-- | Request body for +-- @POST /_plugins/_security_analytics/mappings@ (create mappings). +-- The @alias_mappings@ ('SAMappingsBody') carry the explicit +-- @{properties: {...}}@ to persist; @partial@ (when @'Just' True@) +-- allows creating a partial mapping. The server acknowledges with the +-- standard @{"acknowledged": true}@ envelope (decoded as the shared +-- 'Acknowledged' type, re-exported from +-- "Database.Bloodhound.Common.Requests"). +data SACreateMappingsRequest = SACreateMappingsRequest + { saCreateMappingsIndexName :: Text, + saCreateMappingsRuleTopic :: Text, + saCreateMappingsPartial :: Maybe Bool, + saCreateMappingsAliasMappings :: SAMappingsBody + } + deriving stock (Eq, Show) + +instance ToJSON SACreateMappingsRequest where + toJSON r = + omitNulls + [ "index_name" .= saCreateMappingsIndexName r, + "rule_topic" .= saCreateMappingsRuleTopic r, + "partial" .= saCreateMappingsPartial r, + "alias_mappings" .= saCreateMappingsAliasMappings r + ] + +instance FromJSON SACreateMappingsRequest where + parseJSON = withObject "SACreateMappingsRequest" $ \o -> + SACreateMappingsRequest + <$> o .: "index_name" + <*> o .: "rule_topic" + <*> o .:? "partial" + <*> o .: "alias_mappings" + +-- | Request body for +-- @PUT /_plugins/_security_analytics/mappings@ (update mappings): the +-- index name, the source @field@ to map, and the @alias@ name to +-- assign it. The server acknowledges with the standard +-- @{"acknowledged": true}@ envelope ('Acknowledged'). +data SAUpdateMappingsRequest = SAUpdateMappingsRequest + { saUpdateMappingsIndexName :: Text, + saUpdateMappingsField :: Text, + saUpdateMappingsAlias :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SAUpdateMappingsRequest where + toJSON r = + object + [ "index_name" .= saUpdateMappingsIndexName r, + "field" .= saUpdateMappingsField r, + "alias" .= saUpdateMappingsAlias r + ] + +instance FromJSON SAUpdateMappingsRequest where + parseJSON = withObject "SAUpdateMappingsRequest" $ \o -> + SAUpdateMappingsRequest + <$> o .: "index_name" + <*> o .: "field" + <*> o .: "alias" + +-- ========================================================================= +-- Alerts API +-- ========================================================================= +-- + +-- $alertsapi +-- +-- The Security Analytics plugin dispatches an alert document whenever a +-- detector trigger fires (see +-- ). +-- Two endpoints are modelled here: the listing endpoint +-- (@GET \/\/_plugins\/_security_analytics\/alerts@, 'SAGetAlertsOptions') +-- and the per-detector acknowledge endpoint +-- (@POST \/\/_plugins\/_security_analytics\/detectors\/{detector_id}\/_acknowledge\/alerts@, +-- 'AcknowledgeSADetectorAlertsRequest'). Both share the same per-alert +-- 'SAAlert' shape (typed shell plus an opaque 'Value' catch-all for +-- forward-compat), mirroring the design of 'SADetector' and the sibling +-- Alerting 'Alert'. +-- +-- Wire gotchas pinned by the docs: +-- +-- * The @severity@ field is typed as 'Text' because the wire emits a +-- string-encoded integer (e.g. @"1"@); sometimes @null@. Mirrors the +-- Alerting precedent and 'SATrigger' @severity@. +-- * Timestamps (@start_time@, @end_time@, @acknowledged_time@, +-- @last_notification_time@) are ISO-8601 strings or @null@; typed as +-- @'Maybe' 'Text'@ and left to the caller to parse, since the docs do +-- not commit to a single timestamp format across endpoints. +-- * The acknowledge response carries three array keys (@acknowledged@, +-- @failed@, @missing@); the @failed@ and @missing@ shapes are +-- undocumented, so they are decoded as opaque 'Value's. + +-- | The @state@ field of a Security Analytics alert document, and the +-- @alertState@ query parameter of 'SAGetAlertsOptions'. The five +-- documented values are given dedicated constructors; any future value +-- falls through to 'SAAlertStateOther' rather than parse-failing. The +-- enum matches the Alerting 'AlertState' surface but is replicated here +-- under an @SA@-prefixed name to keep plugin-specific types in their +-- own module (the Alerting and Security Analytics @state@ enums happen +-- to coincide today; they are not guaranteed to). +data SAAlertState + = SAAlertStateActive + | SAAlertStateAcknowledged + | SAAlertStateCompleted + | SAAlertStateError + | SAAlertStateDeleted + | SAAlertStateOther Text + deriving stock (Eq, Show) + +-- | Wire string for an 'SAAlertState'. +saAlertStateText :: SAAlertState -> Text +saAlertStateText = \case + SAAlertStateActive -> "ACTIVE" + SAAlertStateAcknowledged -> "ACKNOWLEDGED" + SAAlertStateCompleted -> "COMPLETED" + SAAlertStateError -> "ERROR" + SAAlertStateDeleted -> "DELETED" + SAAlertStateOther t -> t + +instance ToJSON SAAlertState where + toJSON = toJSON . saAlertStateText + +instance FromJSON SAAlertState where + parseJSON = withText "SAAlertState" $ \t -> + pure $ + case t of + "ACTIVE" -> SAAlertStateActive + "ACKNOWLEDGED" -> SAAlertStateAcknowledged + "COMPLETED" -> SAAlertStateCompleted + "ERROR" -> SAAlertStateError + "DELETED" -> SAAlertStateDeleted + other -> SAAlertStateOther other + +-- | Query-string parameters accepted by +-- @GET /_plugins/_security_analytics/alerts@. Every field is optional; +-- 'defaultSAGetAlertsOptions' produces an empty parameter list, +-- reproducing the plain no-arg GET. The server requires exactly one of +-- 'saGetAlertsOptionsDetectorId' \/ 'saGetAlertsOptionsDetectorType' to +-- be set (the docs mark each as \"optional when the other is +-- specified\"); this constraint is enforced by the server, not by this +-- type. The remaining parameters mirror the Alerting +-- 'GetAlertsOptions' surface (filtering by @alertState@ \/ +-- @severityLevel@, pagination via @size@ \/ @startIndex@, sort via +-- @sortString@ \/ @sortOrder@ \/ @missing@, free-text @searchString@), +-- but use snake_case @start_index@ instead of the Alerting plugin's +-- camelCase @startIndex@ — these are distinct plugin routes and the +-- casings genuinely differ on the wire. +data SAGetAlertsOptions = SAGetAlertsOptions + { saGetAlertsOptionsDetectorId :: Maybe Text, + saGetAlertsOptionsDetectorType :: Maybe Text, + saGetAlertsOptionsSeverityLevel :: Maybe Text, + saGetAlertsOptionsAlertState :: Maybe SAAlertState, + saGetAlertsOptionsSortString :: Maybe Text, + saGetAlertsOptionsSortOrder :: Maybe Text, + saGetAlertsOptionsMissing :: Maybe [Text], + saGetAlertsOptionsSize :: Maybe Int, + saGetAlertsOptionsStartIndex :: Maybe Int, + saGetAlertsOptionsSearchString :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the plain +-- @GET /_plugins/_security_analytics/alerts@ (server defaults apply, but +-- the server still requires a @detector_id@ or @detectorType@ — +-- 'defaultSAGetAlertsOptions' is therefore only useful when combined +-- with one of those two fields, or when the caller wires them in via +-- record update). +defaultSAGetAlertsOptions :: SAGetAlertsOptions +defaultSAGetAlertsOptions = + SAGetAlertsOptions + { saGetAlertsOptionsDetectorId = Nothing, + saGetAlertsOptionsDetectorType = Nothing, + saGetAlertsOptionsSeverityLevel = Nothing, + saGetAlertsOptionsAlertState = Nothing, + saGetAlertsOptionsSortString = Nothing, + saGetAlertsOptionsSortOrder = Nothing, + saGetAlertsOptionsMissing = Nothing, + saGetAlertsOptionsSize = Nothing, + saGetAlertsOptionsStartIndex = Nothing, + saGetAlertsOptionsSearchString = Nothing + } + +-- | Render a 'SAGetAlertsOptions' to the query-string pairs accepted by +-- the get-alerts endpoint. Fields set to 'Nothing' are omitted (not +-- rendered with an empty value). The @sortOrder@ parameter is kept as +-- raw 'Text' (the docs do not enumerate its allowed values, so no +-- closed enum is shipped — pass @"asc"@ or @"desc"@). +saGetAlertsOptionsParams :: SAGetAlertsOptions -> [(Text, Maybe Text)] +saGetAlertsOptionsParams SAGetAlertsOptions {..} = + catMaybes + [ ("detector_id",) . Just <$> saGetAlertsOptionsDetectorId, + ("detectorType",) . Just <$> saGetAlertsOptionsDetectorType, + ("severityLevel",) . Just <$> saGetAlertsOptionsSeverityLevel, + ("alertState",) . Just . saAlertStateText <$> saGetAlertsOptionsAlertState, + ("sortString",) . Just <$> saGetAlertsOptionsSortString, + ("sortOrder",) . Just <$> saGetAlertsOptionsSortOrder, + ("missing",) . Just . T.intercalate "," <$> saGetAlertsOptionsMissing, + ("size",) . Just . T.pack . show <$> saGetAlertsOptionsSize, + ("startIndex",) . Just . T.pack . show <$> saGetAlertsOptionsStartIndex, + ("searchString",) . Just <$> saGetAlertsOptionsSearchString + ] + +-- | The @action_execution_results[]@ sub-object on an alert. The three +-- documented fields are typed; any forward-compat key round-trips via +-- 'saActionExecutionResultOther'. @last_execution_time@ is an epoch-millis +-- integer on the wire. +data SAActionExecutionResult = SAActionExecutionResult + { saActionExecutionResultActionId :: Maybe Text, + saActionExecutionResultLastExecutionTime :: Maybe Int64, + saActionExecutionResultThrottledCount :: Maybe Int64, + saActionExecutionResultOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAActionExecutionResult where + toJSON r = + case saActionExecutionResultOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "action_id" .= saActionExecutionResultActionId r, + "last_execution_time" .= saActionExecutionResultLastExecutionTime r, + "throttled_count" .= saActionExecutionResultThrottledCount r + ] + +instance FromJSON SAActionExecutionResult where + parseJSON = withObject "SAActionExecutionResult" $ \o -> + SAActionExecutionResult + <$> o .:? "action_id" + <*> o .:? "last_execution_time" + <*> o .:? "throttled_count" + <*> pure (Object o) + +-- | A single Security Analytics alert document, as returned by +-- @GET /_plugins/_security_analytics/alerts@ (in the @alerts[]@ array of +-- 'SAGetAlertsResponse') and by the acknowledge endpoint (in the +-- @acknowledged[]@ array of 'AcknowledgeSADetectorAlertsResponse'). +-- +-- Typed fields cover every key documented on the get-alerts response; +-- unknown keys round-trip via 'saAlertOther'. Field-level notes: +-- +-- * @version@ is a server-managed integer (the docs example shows a +-- negative value @-3@); typed as 'Int64'. +-- * @schema_version@ is a separate integer from @version@ and is +-- @0@-@4@ depending on alert age. +-- * @severity@ is a string-encoded integer (@\"1\"@..@\"4\"@) or +-- @null@; typed as 'Text' to round-trip both. +-- * @alert_history@ is documented as an array but its element shape is +-- unspecified; decoded as an opaque 'Value'. +-- * Timestamps are ISO-8601 strings or @null@. +data SAAlert = SAAlert + { saAlertDetectorId :: Maybe Text, + saAlertId :: Maybe Text, + saAlertVersion :: Maybe Int64, + saAlertSchemaVersion :: Maybe Int64, + saAlertTriggerId :: Maybe Text, + saAlertTriggerName :: Maybe Text, + saAlertFindingIds :: Maybe [Text], + saAlertRelatedDocIds :: Maybe [Text], + saAlertState :: Maybe SAAlertState, + saAlertErrorMessage :: Maybe Text, + saAlertHistory :: Value, + saAlertSeverity :: Maybe Text, + saAlertActionExecutionResults :: Maybe [SAActionExecutionResult], + saAlertStartTime :: Maybe Text, + saAlertLastNotificationTime :: Maybe Text, + saAlertEndTime :: Maybe Text, + saAlertAcknowledgedTime :: Maybe Text, + saAlertOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAAlert where + toJSON a = + case saAlertOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "detector_id" .= saAlertDetectorId a, + "id" .= saAlertId a, + "version" .= saAlertVersion a, + "schema_version" .= saAlertSchemaVersion a, + "trigger_id" .= saAlertTriggerId a, + "trigger_name" .= saAlertTriggerName a, + "finding_ids" .= saAlertFindingIds a, + "related_doc_ids" .= saAlertRelatedDocIds a, + "state" .= saAlertState a, + "error_message" .= saAlertErrorMessage a, + "alert_history" .= saAlertHistory a, + "severity" .= saAlertSeverity a, + "action_execution_results" .= saAlertActionExecutionResults a, + "start_time" .= saAlertStartTime a, + "last_notification_time" .= saAlertLastNotificationTime a, + "end_time" .= saAlertEndTime a, + "acknowledged_time" .= saAlertAcknowledgedTime a + ] + +instance FromJSON SAAlert where + parseJSON = withObject "SAAlert" $ \o -> + SAAlert + <$> o .:? "detector_id" + <*> o .:? "id" + <*> o .:? "version" + <*> o .:? "schema_version" + <*> o .:? "trigger_id" + <*> o .:? "trigger_name" + <*> o .:? "finding_ids" + <*> o .:? "related_doc_ids" + <*> o .:? "state" + <*> o .:? "error_message" + <*> o .:? "alert_history" .!= Null + <*> o .:? "severity" + <*> o .:? "action_execution_results" + <*> o .:? "start_time" + <*> o .:? "last_notification_time" + <*> o .:? "end_time" + <*> o .:? "acknowledged_time" + <*> pure (Object o) + +-- | Response envelope for @GET /_plugins/_security_analytics/alerts@ +-- (@{alerts, total_alerts, detectorType}@). @total_alerts@ and +-- @detectorType@ are decoded leniently (they are documented but the +-- live wire has been observed to drop @detectorType@ on some builds); +-- the @alerts@ array is strict. +data SAGetAlertsResponse = SAGetAlertsResponse + { saGetAlertsResponseAlerts :: [SAAlert], + saGetAlertsResponseTotalAlerts :: Maybe Int64, + saGetAlertsResponseDetectorType :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SAGetAlertsResponse where + parseJSON = withObject "SAGetAlertsResponse" $ \o -> + SAGetAlertsResponse + <$> o .:? "alerts" .!= [] + <*> o .:? "total_alerts" + <*> o .:? "detectorType" + +instance ToJSON SAGetAlertsResponse where + toJSON r = + omitNulls + [ "alerts" .= saGetAlertsResponseAlerts r, + "total_alerts" .= saGetAlertsResponseTotalAlerts r, + "detectorType" .= saGetAlertsResponseDetectorType r + ] + +-- | Request body for +-- @POST /_plugins/_security_analytics/detectors/{detector_id}/_acknowledge/alerts@. +-- Wraps a list of alert ids; rendered on the wire as +-- @{"alerts":[id1, id2, ...]}@ (note: snake_case key @alerts@, mirroring +-- the Alerting plugin's 'AcknowledgeAlertRequest'; contrast with the +-- correlation-alerts acknowledge, which uses camelCase @alertIds@). +newtype AcknowledgeSADetectorAlertsRequest = AcknowledgeSADetectorAlertsRequest + { acknowledgeSADetectorAlertsRequestAlerts :: [Text] + } + deriving stock (Eq, Show) + +instance ToJSON AcknowledgeSADetectorAlertsRequest where + toJSON r = object ["alerts" .= acknowledgeSADetectorAlertsRequestAlerts r] + +instance FromJSON AcknowledgeSADetectorAlertsRequest where + parseJSON = withObject "AcknowledgeSADetectorAlertsRequest" $ \o -> + AcknowledgeSADetectorAlertsRequest <$> o .:? "alerts" .!= [] + +-- | Response body for the per-detector alerts acknowledge endpoint. The +-- @acknowledged@ array carries the same 'SAAlert' shape as the get-alerts +-- response; @failed@ and @missing@ are documented as arrays but their +-- element shapes are unspecified, so they are decoded as opaque 'Value's. +data AcknowledgeSADetectorAlertsResponse = AcknowledgeSADetectorAlertsResponse + { acknowledgeSADetectorAlertsResponseAcknowledged :: [SAAlert], + acknowledgeSADetectorAlertsResponseFailed :: Value, + acknowledgeSADetectorAlertsResponseMissing :: Value + } + deriving stock (Eq, Show) + +instance FromJSON AcknowledgeSADetectorAlertsResponse where + parseJSON = withObject "AcknowledgeSADetectorAlertsResponse" $ \o -> + AcknowledgeSADetectorAlertsResponse + <$> o .:? "acknowledged" .!= [] + <*> o .:? "failed" .!= Null + <*> o .:? "missing" .!= Null + +instance ToJSON AcknowledgeSADetectorAlertsResponse where + toJSON r = + omitNulls + [ "acknowledged" .= acknowledgeSADetectorAlertsResponseAcknowledged r, + "failed" .= acknowledgeSADetectorAlertsResponseFailed r, + "missing" .= acknowledgeSADetectorAlertsResponseMissing r + ] + +-- ========================================================================= +-- Findings API +-- ========================================================================= +-- + +-- $findingsapi +-- +-- A finding is the per-match record produced by a detector rule against +-- an indexed log document (see +-- ). +-- Only the listing endpoint +-- (@GET \/\/_plugins\/_security_analytics\/findings\/_search@) is +-- documented; per-id GET is not. The response envelope diverges from a +-- standard OpenSearch search response: it carries +-- @{total_findings, findings: [...]}@ with the findings inline (not +-- wrapped in @hits.hits[]._source@). +-- +-- Wire gotchas: +-- +-- * @detectorId@ is camelCase in the findings response, whereas the +-- alerts response uses snake_case @detector_id@ — these are real +-- wire-format inconsistencies, not typos. +-- * @timestamp@ is an epoch-millis integer. +-- * @document_list[].document@ is a /string/ containing JSON, not a +-- nested object; typed as 'Text'. +-- * @queries[].tags@ is an array of strings (severity + log type). + +-- | The @detectionType@ query parameter on the findings search endpoint. +-- @rule@ fetches findings produced by the detector's Sigma rule; +-- @threat@ fetches threat-intel-feed findings. Unknown values fall +-- through to 'SADetectionTypeOther' (mirrors the 'SAAlertState' design). +data SADetectionType + = SADetectionTypeRule + | SADetectionTypeThreat + | SADetectionTypeOther Text + deriving stock (Eq, Show) + +-- | Wire string for a 'SADetectionType'. +saDetectionTypeText :: SADetectionType -> Text +saDetectionTypeText = \case + SADetectionTypeRule -> "rule" + SADetectionTypeThreat -> "threat" + SADetectionTypeOther t -> t + +instance ToJSON SADetectionType where + toJSON = toJSON . saDetectionTypeText + +instance FromJSON SADetectionType where + parseJSON = withText "SADetectionType" $ \t -> + pure $ + case t of + "rule" -> SADetectionTypeRule + "threat" -> SADetectionTypeThreat + other -> SADetectionTypeOther other + +-- | The @severity@ query parameter on the findings search endpoint. +-- Unknown values fall through to 'SASeverityOther'. +data SASeverity + = SASeverityCritical + | SASeverityHigh + | SASeverityMedium + | SASeverityLow + | SASeverityOther Text + deriving stock (Eq, Show) + +-- | Wire string for an 'SASeverity'. +saSeverityText :: SASeverity -> Text +saSeverityText = \case + SASeverityCritical -> "critical" + SASeverityHigh -> "high" + SASeverityMedium -> "medium" + SASeverityLow -> "low" + SASeverityOther t -> t + +instance ToJSON SASeverity where + toJSON = toJSON . saSeverityText + +instance FromJSON SASeverity where + parseJSON = withText "SASeverity" $ \t -> + pure $ + case t of + "critical" -> SASeverityCritical + "high" -> SASeverityHigh + "medium" -> SASeverityMedium + "low" -> SASeverityLow + other -> SASeverityOther other + +-- | Query-string parameters accepted by +-- @GET /_plugins/_security_analytics/findings/_search@. Every field is +-- optional; 'defaultSASearchFindingsOptions' produces an empty parameter +-- list (the server returns the first page of all findings). The +-- @detector_type@ filter (snake_case) takes a log type name; the +-- @detectionType@ filter (camelCase) takes a 'SADetectionType' enum +-- value — note the inconsistent casing across the two parameters on the +-- same endpoint. +data SASearchFindingsOptions = SASearchFindingsOptions + { saSearchFindingsOptionsDetectorId :: Maybe Text, + saSearchFindingsOptionsDetectorType :: Maybe Text, + saSearchFindingsOptionsSortOrder :: Maybe Text, + saSearchFindingsOptionsSize :: Maybe Int, + saSearchFindingsOptionsStartIndex :: Maybe Int, + saSearchFindingsOptionsDetectionType :: Maybe SADetectionType, + saSearchFindingsOptionsSeverity :: Maybe SASeverity + } + deriving stock (Eq, Show) + +-- | The empty options record — no query parameters. Reproduces the plain +-- @GET /_plugins/_security_analytics/findings/_search@. +defaultSASearchFindingsOptions :: SASearchFindingsOptions +defaultSASearchFindingsOptions = + SASearchFindingsOptions + { saSearchFindingsOptionsDetectorId = Nothing, + saSearchFindingsOptionsDetectorType = Nothing, + saSearchFindingsOptionsSortOrder = Nothing, + saSearchFindingsOptionsSize = Nothing, + saSearchFindingsOptionsStartIndex = Nothing, + saSearchFindingsOptionsDetectionType = Nothing, + saSearchFindingsOptionsSeverity = Nothing + } + +-- | Render a 'SASearchFindingsOptions' to the query-string pairs accepted +-- by the findings search endpoint. Fields set to 'Nothing' are omitted. +saSearchFindingsOptionsParams :: SASearchFindingsOptions -> [(Text, Maybe Text)] +saSearchFindingsOptionsParams SASearchFindingsOptions {..} = + catMaybes + [ ("detector_id",) . Just <$> saSearchFindingsOptionsDetectorId, + ("detectorType",) . Just <$> saSearchFindingsOptionsDetectorType, + ("sortOrder",) . Just <$> saSearchFindingsOptionsSortOrder, + ("size",) . Just . T.pack . show <$> saSearchFindingsOptionsSize, + ("startIndex",) . Just . T.pack . show <$> saSearchFindingsOptionsStartIndex, + ("detectionType",) . Just . saDetectionTypeText <$> saSearchFindingsOptionsDetectionType, + ("severity",) . Just . saSeverityText <$> saSearchFindingsOptionsSeverity + ] + +-- | The @queries[]@ sub-object inside a finding: the Sigma rule id, its +-- name, the matched fields, the rendered query string, and the rule +-- tags (severity + log type). Typed shell plus opaque catch-all. +data SAFindingQuery = SAFindingQuery + { saFindingQueryId :: Maybe Text, + saFindingQueryName :: Maybe Text, + saFindingQueryFields :: Maybe [Text], + saFindingQueryQuery :: Maybe Text, + saFindingQueryTags :: Maybe [Text], + saFindingQueryOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAFindingQuery where + toJSON q = + case saFindingQueryOther q of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "id" .= saFindingQueryId q, + "name" .= saFindingQueryName q, + "fields" .= saFindingQueryFields q, + "query" .= saFindingQueryQuery q, + "tags" .= saFindingQueryTags q + ] + +instance FromJSON SAFindingQuery where + parseJSON = withObject "SAFindingQuery" $ \o -> + SAFindingQuery + <$> o .:? "id" + <*> o .:? "name" + <*> o .:? "fields" + <*> o .:? "query" + <*> o .:? "tags" + <*> pure (Object o) + +-- | The @document_list[]@ sub-object inside a finding: the document's +-- index, id, found flag, and the source document serialised as a JSON +-- /string/ (NOT a nested object — the server stringifies the source). +data SAFindingDocument = SAFindingDocument + { saFindingDocumentIndex :: Maybe Text, + saFindingDocumentId :: Maybe Text, + saFindingDocumentFound :: Maybe Bool, + saFindingDocumentDocument :: Maybe Text, + saFindingDocumentOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAFindingDocument where + toJSON d = + case saFindingDocumentOther d of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "index" .= saFindingDocumentIndex d, + "id" .= saFindingDocumentId d, + "found" .= saFindingDocumentFound d, + "document" .= saFindingDocumentDocument d + ] + +instance FromJSON SAFindingDocument where + parseJSON = withObject "SAFindingDocument" $ \o -> + SAFindingDocument + <$> o .:? "index" + <*> o .:? "id" + <*> o .:? "found" + <*> o .:? "document" + <*> pure (Object o) + +-- | A single finding document, as returned in the @findings[]@ array of +-- 'SASearchFindingsResponse'. Note the camelCase @detectorId@ (the +-- alerts API uses snake_case @detector_id@ — these genuinely differ on +-- the wire). @timestamp@ is an epoch-millis integer. +data SAFinding = SAFinding + { saFindingDetectorId :: Maybe Text, + saFindingId :: Maybe Text, + saFindingRelatedDocIds :: Maybe [Text], + saFindingIndex :: Maybe Text, + saFindingQueries :: Maybe [SAFindingQuery], + saFindingTimestamp :: Maybe Int64, + saFindingDocumentList :: Maybe [SAFindingDocument], + saFindingOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SAFinding where + toJSON f = + case saFindingOther f of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "detectorId" .= saFindingDetectorId f, + "id" .= saFindingId f, + "related_doc_ids" .= saFindingRelatedDocIds f, + "index" .= saFindingIndex f, + "queries" .= saFindingQueries f, + "timestamp" .= saFindingTimestamp f, + "document_list" .= saFindingDocumentList f + ] + +instance FromJSON SAFinding where + parseJSON = withObject "SAFinding" $ \o -> + SAFinding + <$> o .:? "detectorId" + <*> o .:? "id" + <*> o .:? "related_doc_ids" + <*> o .:? "index" + <*> o .:? "queries" + <*> o .:? "timestamp" + <*> o .:? "document_list" + <*> pure (Object o) + +-- | Response envelope for +-- @GET /_plugins/_security_analytics/findings/_search@ +-- (@{total_findings, findings: [...]}@). Note this is NOT the standard +-- OpenSearch search envelope (no @took@, no @hits@ wrapper); the +-- Security Analytics plugin returns the findings inline. +data SASearchFindingsResponse = SASearchFindingsResponse + { saSearchFindingsResponseTotalFindings :: Maybe Int64, + saSearchFindingsResponseFindings :: [SAFinding] + } + deriving stock (Eq, Show) + +instance FromJSON SASearchFindingsResponse where + parseJSON = withObject "SASearchFindingsResponse" $ \o -> + SASearchFindingsResponse + <$> o .:? "total_findings" + <*> o .:? "findings" .!= [] + +instance ToJSON SASearchFindingsResponse where + toJSON r = + omitNulls + [ "total_findings" .= saSearchFindingsResponseTotalFindings r, + "findings" .= saSearchFindingsResponseFindings r + ] + +-- ========================================================================= +-- Correlation API +-- ========================================================================= +-- + +-- $correlationapi +-- +-- The correlation engine correlates findings produced by different +-- detectors against different log types and dispatches correlation +-- alerts when a correlation rule matches (see +-- ). +-- Five endpoints are modelled here: +-- +-- * [@POST \/\/correlation\/rules@] 'CreateSACorrelationRuleRequest' — +-- create a correlation rule from a list of index\/query\/category +-- triples. +-- * [@GET \/\/correlations@] 'GetSACorrelationsOptions' — list finding +-- correlations within a time window (pairwise @finding1@\/@finding2@). +-- * [@GET \/\/findings\/correlate@] 'FindSACorrelationOptions' — list +-- correlated findings for a given finding id, scored by proximity. +-- * [@GET \/\/correlationAlerts@] 'SearchSACorrelationAlertsOptions' — +-- list correlation alerts, optionally filtered by correlation rule. +-- * [@POST \/\/_acknowledge\/correlationAlerts@] +-- 'AcknowledgeSACorrelationAlertsRequest' — acknowledge one or more +-- correlation alerts by id. +-- +-- Wire gotchas pinned by the docs: +-- +-- * The create endpoint is @POST \/correlation\/rules@ (singular +-- @rule@); the time-window listing endpoint is +-- @GET \/correlations@ (plural). Both are real. +-- * Acknowledge-correlation-alerts uses the path +-- @\/_acknowledge\/correlationAlerts@ (the @_acknowledge@ segment is a +-- sibling of @correlationAlerts@, not nested under it) and the +-- request body key is camelCase @alertIds@ (contrast with the +-- per-detector alerts acknowledge, which uses snake_case @alerts@). +-- * Acknowledge-correlation-alerts response has only +-- @acknowledged@ \/ @failed@ arrays (NO @missing@ key, contrast with +-- per-detector alerts acknowledge). +-- * The pairwise correlations response uses camelCase @logType1@ \/ +-- @logType2@; the find-correlation response uses snake_case +-- @detector_type@. Both are real. +-- * The correlation alerts list endpoint is declared as +-- @GET \/correlationAlerts@ in the docs, but its example request uses +-- @GET \/correlations?correlation_rule_id=...@ — an inconsistency in +-- the docs. This module ships the declared path +-- @GET \/correlationAlerts@. + +-- | A single entry in a correlation rule's @correlate@ array: the index +-- to search, the query string to apply, and the log type (category) of +-- the index. +data SACorrelateEntry = SACorrelateEntry + { saCorrelateEntryIndex :: Text, + saCorrelateEntryQuery :: Text, + saCorrelateEntryCategory :: Text + } + deriving stock (Eq, Show) + +instance ToJSON SACorrelateEntry where + toJSON e = + object + [ "index" .= saCorrelateEntryIndex e, + "query" .= saCorrelateEntryQuery e, + "category" .= saCorrelateEntryCategory e + ] + +instance FromJSON SACorrelateEntry where + parseJSON = withObject "SACorrelateEntry" $ \o -> + SACorrelateEntry + <$> o .: "index" + <*> o .: "query" + <*> o .: "category" + +-- | Request body for @POST /_plugins/_security_analytics/correlation/rules@. +-- Carries the list of index\/query\/category triples that define the +-- correlation; rendered as @{"correlate": [...]}@. +newtype CreateSACorrelationRuleRequest = CreateSACorrelationRuleRequest + { createSACorrelationRuleRequestCorrelate :: [SACorrelateEntry] + } + deriving stock (Eq, Show) + +instance ToJSON CreateSACorrelationRuleRequest where + toJSON r = object ["correlate" .= createSACorrelationRuleRequestCorrelate r] + +instance FromJSON CreateSACorrelationRuleRequest where + parseJSON = withObject "CreateSACorrelationRuleRequest" $ \o -> + CreateSACorrelationRuleRequest <$> o .:? "correlate" .!= [] + +-- | The @rule@ sub-object in the create-correlation-rule response. +-- @name@ is documented but the docs example returns @null@; typed as +-- 'Maybe' 'Text'. Unknown keys round-trip via 'saCorrelationRuleOther'. +data SACorrelationRule = SACorrelationRule + { saCorrelationRuleName :: Maybe Text, + saCorrelationRuleCorrelate :: [SACorrelateEntry], + saCorrelationRuleOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SACorrelationRule where + parseJSON = withObject "SACorrelationRule" $ \o -> + SACorrelationRule + <$> o .:? "name" + <*> o .:? "correlate" .!= [] + <*> pure (Object o) + +instance ToJSON SACorrelationRule where + toJSON r = + case saCorrelationRuleOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= saCorrelationRuleName r, + "correlate" .= saCorrelationRuleCorrelate r + ] + +-- | Response body for @POST /_plugins/_security_analytics/correlation/rules@: +-- the server-assigned @_id@ and @_version@, plus the persisted +-- 'SACorrelationRule'. +data CreateSACorrelationRuleResponse = CreateSACorrelationRuleResponse + { createSACorrelationRuleResponseId :: Text, + createSACorrelationRuleResponseVersion :: Int64, + createSACorrelationRuleResponseRule :: SACorrelationRule + } + deriving stock (Eq, Show) + +instance FromJSON CreateSACorrelationRuleResponse where + parseJSON = withObject "CreateSACorrelationRuleResponse" $ \o -> + CreateSACorrelationRuleResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "rule" + +instance ToJSON CreateSACorrelationRuleResponse where + toJSON r = + object + [ "_id" .= createSACorrelationRuleResponseId r, + "_version" .= createSACorrelationRuleResponseVersion r, + "rule" .= createSACorrelationRuleResponseRule r + ] + +-- | A single pairwise correlation in the +-- @GET /_plugins/_security_analytics/correlations@ response +-- (@{finding1, logType1, finding2, logType2, rules}@). The wire shape is +-- fixed to exactly two findings (no generalised N-finding array). +-- Unknown keys round-trip via 'saCorrelationFindingOther'. +data SACorrelationFinding = SACorrelationFinding + { saCorrelationFindingFinding1 :: Maybe Text, + saCorrelationFindingLogType1 :: Maybe Text, + saCorrelationFindingFinding2 :: Maybe Text, + saCorrelationFindingLogType2 :: Maybe Text, + saCorrelationFindingRules :: Maybe [Text], + saCorrelationFindingOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SACorrelationFinding where + parseJSON = withObject "SACorrelationFinding" $ \o -> + SACorrelationFinding + <$> o .:? "finding1" + <*> o .:? "logType1" + <*> o .:? "finding2" + <*> o .:? "logType2" + <*> o .:? "rules" + <*> pure (Object o) + +instance ToJSON SACorrelationFinding where + toJSON r = + case saCorrelationFindingOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "finding1" .= saCorrelationFindingFinding1 r, + "logType1" .= saCorrelationFindingLogType1 r, + "finding2" .= saCorrelationFindingFinding2 r, + "logType2" .= saCorrelationFindingLogType2 r, + "rules" .= saCorrelationFindingRules r + ] + +-- | Query parameters for @GET /_plugins/_security_analytics/correlations@. +-- Both @start_timestamp@ and @end_timestamp@ are required by the server +-- (epoch-millis integers); the type does not enforce this, leaving the +-- caller to set them via record update on 'defaultGetSACorrelationsOptions'. +data GetSACorrelationsOptions = GetSACorrelationsOptions + { getSACorrelationsOptionsStartTimestamp :: Maybe Int64, + getSACorrelationsOptionsEndTimestamp :: Maybe Int64 + } + deriving stock (Eq, Show) + +-- | The empty options record — caller MUST set @start_timestamp@ and +-- @end_timestamp@ before sending (the server rejects the request +-- otherwise). +defaultGetSACorrelationsOptions :: GetSACorrelationsOptions +defaultGetSACorrelationsOptions = + GetSACorrelationsOptions + { getSACorrelationsOptionsStartTimestamp = Nothing, + getSACorrelationsOptionsEndTimestamp = Nothing + } + +-- | Render a 'GetSACorrelationsOptions' to the query-string pairs +-- accepted by the correlations endpoint. Fields set to 'Nothing' are +-- omitted; the caller is responsible for ensuring both are set. +getSACorrelationsOptionsParams :: GetSACorrelationsOptions -> [(Text, Maybe Text)] +getSACorrelationsOptionsParams GetSACorrelationsOptions {..} = + catMaybes + [ ("start_timestamp",) . Just . T.pack . show <$> getSACorrelationsOptionsStartTimestamp, + ("end_timestamp",) . Just . T.pack . show <$> getSACorrelationsOptionsEndTimestamp + ] + +-- | Response body for @GET /_plugins/_security_analytics/correlations@ +-- (@{findings: [...]}@ — note the response key is @findings@ even though +-- the endpoint is @correlations@). +newtype GetSACorrelationsResponse = GetSACorrelationsResponse + { getSACorrelationsResponseFindings :: [SACorrelationFinding] + } + deriving stock (Eq, Show) + +instance FromJSON GetSACorrelationsResponse where + parseJSON = withObject "GetSACorrelationsResponse" $ \o -> + GetSACorrelationsResponse <$> o .:? "findings" .!= [] + +instance ToJSON GetSACorrelationsResponse where + toJSON r = object ["findings" .= getSACorrelationsResponseFindings r] + +-- | Query parameters for +-- @GET /_plugins/_security_analytics/findings/correlate@. @finding@ and +-- @detector_type@ are required by the server; @nearby_findings@ and +-- @time_window@ are optional. The caller MUST set the two required +-- fields via record update on 'defaultFindSACorrelationOptions'. +data FindSACorrelationOptions = FindSACorrelationOptions + { findSACorrelationOptionsFinding :: Maybe Text, + findSACorrelationOptionsDetectorType :: Maybe Text, + findSACorrelationOptionsNearbyFindings :: Maybe Int, + findSACorrelationOptionsTimeWindow :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record — caller MUST set @finding@ and +-- @detector_type@ before sending. +defaultFindSACorrelationOptions :: FindSACorrelationOptions +defaultFindSACorrelationOptions = + FindSACorrelationOptions + { findSACorrelationOptionsFinding = Nothing, + findSACorrelationOptionsDetectorType = Nothing, + findSACorrelationOptionsNearbyFindings = Nothing, + findSACorrelationOptionsTimeWindow = Nothing + } + +-- | Render a 'FindSACorrelationOptions' to the query-string pairs +-- accepted by the find-correlation endpoint. +findSACorrelationOptionsParams :: FindSACorrelationOptions -> [(Text, Maybe Text)] +findSACorrelationOptionsParams FindSACorrelationOptions {..} = + catMaybes + [ ("finding",) . Just <$> findSACorrelationOptionsFinding, + ("detector_type",) . Just <$> findSACorrelationOptionsDetectorType, + ("nearby_findings",) . Just . T.pack . show <$> findSACorrelationOptionsNearbyFindings, + ("time_window",) . Just <$> findSACorrelationOptionsTimeWindow + ] + +-- | A single scored correlation in the find-correlation response +-- (@{finding, detector_type, score}@). @score@ is a server-computed +-- proximity score (smaller = more relevant); typed as 'Double'. +-- Unknown keys round-trip via 'saCorrelationScoreOther'. +data SACorrelationScore = SACorrelationScore + { saCorrelationScoreFinding :: Maybe Text, + saCorrelationScoreDetectorType :: Maybe Text, + saCorrelationScoreScore :: Maybe Double, + saCorrelationScoreOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SACorrelationScore where + parseJSON = withObject "SACorrelationScore" $ \o -> + SACorrelationScore + <$> o .:? "finding" + <*> o .:? "detector_type" + <*> o .:? "score" + <*> pure (Object o) + +instance ToJSON SACorrelationScore where + toJSON r = + case saCorrelationScoreOther r of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "finding" .= saCorrelationScoreFinding r, + "detector_type" .= saCorrelationScoreDetectorType r, + "score" .= saCorrelationScoreScore r + ] + +-- | Response body for +-- @GET /_plugins/_security_analytics/findings/correlate@ +-- (@{findings: [...]}@ — the response key is @findings@ here too). +newtype FindSACorrelationResponse = FindSACorrelationResponse + { findSACorrelationResponseFindings :: [SACorrelationScore] + } + deriving stock (Eq, Show) + +instance FromJSON FindSACorrelationResponse where + parseJSON = withObject "FindSACorrelationResponse" $ \o -> + FindSACorrelationResponse <$> o .:? "findings" .!= [] + +instance ToJSON FindSACorrelationResponse where + toJSON r = object ["findings" .= findSACorrelationResponseFindings r] + +-- | Query parameters for +-- @GET /_plugins/_security_analytics/correlationAlerts@. The optional +-- @correlation_rule_id@ filters the result to alerts produced by a +-- specific correlation rule. +newtype SearchSACorrelationAlertsOptions = SearchSACorrelationAlertsOptions + { searchSACorrelationAlertsOptionsCorrelationRuleId :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty options record — returns all correlation alerts. +defaultSearchSACorrelationAlertsOptions :: SearchSACorrelationAlertsOptions +defaultSearchSACorrelationAlertsOptions = + SearchSACorrelationAlertsOptions + { searchSACorrelationAlertsOptionsCorrelationRuleId = Nothing + } + +-- | Render a 'SearchSACorrelationAlertsOptions' to the query-string pairs +-- accepted by the correlation alerts endpoint. +searchSACorrelationAlertsOptionsParams :: SearchSACorrelationAlertsOptions -> [(Text, Maybe Text)] +searchSACorrelationAlertsOptionsParams SearchSACorrelationAlertsOptions {..} = + catMaybes + [ ("correlation_rule_id",) . Just <$> searchSACorrelationAlertsOptionsCorrelationRuleId + ] + +-- | A single correlation alert, as returned in the @correlationAlerts[]@ +-- array of 'SearchSACorrelationAlertsResponse' and the @acknowledged[]@ +-- array of 'AcknowledgeSACorrelationAlertsResponse'. Carries the same +-- shell as 'SAAlert' (state, severity, timestamps, action execution +-- results) plus the correlation-specific @correlated_finding_ids@, +-- @correlation_rule_id@, and @correlation_rule_name@ fields. @user@ is +-- documented but the docs example returns @null@; typed as +-- 'Maybe' 'Text'. Typed shell plus opaque catch-all. +data SACorrelationAlert = SACorrelationAlert + { saCorrelationAlertCorrelatedFindingIds :: Maybe [Text], + saCorrelationAlertCorrelationRuleId :: Maybe Text, + saCorrelationAlertCorrelationRuleName :: Maybe Text, + saCorrelationAlertUser :: Maybe Text, + saCorrelationAlertId :: Maybe Text, + saCorrelationAlertVersion :: Maybe Int64, + saCorrelationAlertSchemaVersion :: Maybe Int64, + saCorrelationAlertTriggerName :: Maybe Text, + saCorrelationAlertState :: Maybe SAAlertState, + saCorrelationAlertErrorMessage :: Maybe Text, + saCorrelationAlertSeverity :: Maybe Text, + saCorrelationAlertActionExecutionResults :: Maybe [SAActionExecutionResult], + saCorrelationAlertStartTime :: Maybe Text, + saCorrelationAlertEndTime :: Maybe Text, + saCorrelationAlertAcknowledgedTime :: Maybe Text, + saCorrelationAlertOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SACorrelationAlert where + parseJSON = withObject "SACorrelationAlert" $ \o -> + SACorrelationAlert + <$> o .:? "correlated_finding_ids" + <*> o .:? "correlation_rule_id" + <*> o .:? "correlation_rule_name" + <*> o .:? "user" + <*> o .:? "id" + <*> o .:? "version" + <*> o .:? "schema_version" + <*> o .:? "trigger_name" + <*> o .:? "state" + <*> o .:? "error_message" + <*> o .:? "severity" + <*> o .:? "action_execution_results" + <*> o .:? "start_time" + <*> o .:? "end_time" + <*> o .:? "acknowledged_time" + <*> pure (Object o) + +instance ToJSON SACorrelationAlert where + toJSON a = + case saCorrelationAlertOther a of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "correlated_finding_ids" .= saCorrelationAlertCorrelatedFindingIds a, + "correlation_rule_id" .= saCorrelationAlertCorrelationRuleId a, + "correlation_rule_name" .= saCorrelationAlertCorrelationRuleName a, + "user" .= saCorrelationAlertUser a, + "id" .= saCorrelationAlertId a, + "version" .= saCorrelationAlertVersion a, + "schema_version" .= saCorrelationAlertSchemaVersion a, + "trigger_name" .= saCorrelationAlertTriggerName a, + "state" .= saCorrelationAlertState a, + "error_message" .= saCorrelationAlertErrorMessage a, + "severity" .= saCorrelationAlertSeverity a, + "action_execution_results" .= saCorrelationAlertActionExecutionResults a, + "start_time" .= saCorrelationAlertStartTime a, + "end_time" .= saCorrelationAlertEndTime a, + "acknowledged_time" .= saCorrelationAlertAcknowledgedTime a + ] + +-- | Response envelope for +-- @GET /_plugins/_security_analytics/correlationAlerts@ +-- (@{correlationAlerts: [...], total_alerts}@). +data SearchSACorrelationAlertsResponse = SearchSACorrelationAlertsResponse + { searchSACorrelationAlertsResponseCorrelationAlerts :: [SACorrelationAlert], + searchSACorrelationAlertsResponseTotalAlerts :: Maybe Int64 + } + deriving stock (Eq, Show) + +instance FromJSON SearchSACorrelationAlertsResponse where + parseJSON = withObject "SearchSACorrelationAlertsResponse" $ \o -> + SearchSACorrelationAlertsResponse + <$> o .:? "correlationAlerts" .!= [] + <*> o .:? "total_alerts" + +instance ToJSON SearchSACorrelationAlertsResponse where + toJSON r = + omitNulls + [ "correlationAlerts" .= searchSACorrelationAlertsResponseCorrelationAlerts r, + "total_alerts" .= searchSACorrelationAlertsResponseTotalAlerts r + ] + +-- | Request body for +-- @POST /_plugins/_security_analytics/_acknowledge/correlationAlerts@. +-- Wraps a list of correlation-alert ids; rendered on the wire as +-- @{"alertIds":[id1, id2, ...]}@ (note: camelCase key @alertIds@, +-- contrast with the per-detector alerts acknowledge which uses +-- snake_case @alerts@). +newtype AcknowledgeSACorrelationAlertsRequest = AcknowledgeSACorrelationAlertsRequest + { acknowledgeSACorrelationAlertsRequestAlertIds :: [Text] + } + deriving stock (Eq, Show) + +instance ToJSON AcknowledgeSACorrelationAlertsRequest where + toJSON r = object ["alertIds" .= acknowledgeSACorrelationAlertsRequestAlertIds r] + +instance FromJSON AcknowledgeSACorrelationAlertsRequest where + parseJSON = withObject "AcknowledgeSACorrelationAlertsRequest" $ \o -> + AcknowledgeSACorrelationAlertsRequest <$> o .:? "alertIds" .!= [] + +-- | Response body for acknowledge-correlation-alerts. Note the response +-- has only @acknowledged@ and @failed@ arrays (NO @missing@ key — +-- contrast with 'AcknowledgeSADetectorAlertsResponse' which has all +-- three). +data AcknowledgeSACorrelationAlertsResponse = AcknowledgeSACorrelationAlertsResponse + { acknowledgeSACorrelationAlertsResponseAcknowledged :: [SACorrelationAlert], + acknowledgeSACorrelationAlertsResponseFailed :: Value + } + deriving stock (Eq, Show) + +instance FromJSON AcknowledgeSACorrelationAlertsResponse where + parseJSON = withObject "AcknowledgeSACorrelationAlertsResponse" $ \o -> + AcknowledgeSACorrelationAlertsResponse + <$> o .:? "acknowledged" .!= [] + <*> o .:? "failed" .!= Null + +instance ToJSON AcknowledgeSACorrelationAlertsResponse where + toJSON r = + omitNulls + [ "acknowledged" .= acknowledgeSACorrelationAlertsResponseAcknowledged r, + "failed" .= acknowledgeSACorrelationAlertsResponseFailed r + ] + +-- ========================================================================= +-- Log type API +-- ========================================================================= +-- + +-- $logtypeapi +-- +-- Log types are the categories that pair an index with a Sigma rule +-- topic (windows, network, ad_ldap, ...). The plugin ships a set of +-- built-in log types (@source: "Sigma"@); custom log types +-- (@source: "Custom"@) can be created, updated, searched, and deleted +-- (see +-- ). +-- Per-id GET is not documented, so only the four CRUD-shape endpoints +-- actually documented are shipped (create, search, update, delete). +-- +-- Wire gotchas: +-- +-- * The singular create/update response wraps the body in a @logType@ +-- key (camelCase); the URL path uses lowercase @logtype@. Both are +-- real. +-- * The search endpoint returns a standard OpenSearch search envelope +-- (@took@, @_shards@, @hits.total.{value,relation}@, +-- @hits.hits[]._source@) — the log type lives in @_source@. +-- * @tags@ is @null@ for some custom log types and an object for +-- others; the only documented sub-key is @correlation_id@ (integer). +-- * Built-in log type @_id@ equals its @name@ (e.g. @_id: "s3"@); +-- custom log type @_id@s are opaque server-assigned hashes. + +-- | The @source@ field on a log type. @"Sigma"@ marks built-in types, +-- @"Custom"@ marks user-defined types; any other value round-trips via +-- 'SALogTypeSourceOther'. +data SALogTypeSource + = SALogTypeSourceSigma + | SALogTypeSourceCustom + | SALogTypeSourceOther Text + deriving stock (Eq, Show) + +-- | Wire string for an 'SALogTypeSource'. +saLogTypeSourceText :: SALogTypeSource -> Text +saLogTypeSourceText = \case + SALogTypeSourceSigma -> "Sigma" + SALogTypeSourceCustom -> "Custom" + SALogTypeSourceOther t -> t + +instance ToJSON SALogTypeSource where + toJSON = toJSON . saLogTypeSourceText + +instance FromJSON SALogTypeSource where + parseJSON = withText "SALogTypeSource" $ \t -> + pure $ + case t of + "Sigma" -> SALogTypeSourceSigma + "Custom" -> SALogTypeSourceCustom + other -> SALogTypeSourceOther other + +-- | The @tags@ sub-object on a log type. The only documented sub-key is +-- @correlation_id@ (an integer assigned by the server); unknown keys +-- round-trip via 'saLogTypeTagsOther'. @tags@ may be @null@ on the wire +-- for some custom log types — the 'Maybe SALogTypeTags' on 'SALogType' +-- captures that. +data SALogTypeTags = SALogTypeTags + { saLogTypeTagsCorrelationId :: Maybe Int64, + saLogTypeTagsOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SALogTypeTags where + toJSON t = + case saLogTypeTagsOther t of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = ["correlation_id" .= saLogTypeTagsCorrelationId t] + +instance FromJSON SALogTypeTags where + parseJSON = withObject "SALogTypeTags" $ \o -> + SALogTypeTags + <$> o .:? "correlation_id" + <*> pure (Object o) + +-- | The log type body, reused by the create request body, the create +-- response's @logType@ sub-object, and the update request body. The +-- @name@ is required on create; @description@, @source@, and @tags@ are +-- optional (server-populated where omitted). Unknown keys round-trip +-- via 'saLogTypeOther'. +data SALogType = SALogType + { saLogTypeName :: Text, + saLogTypeDescription :: Maybe Text, + saLogTypeSource :: Maybe SALogTypeSource, + saLogTypeTags :: Maybe SALogTypeTags, + saLogTypeOther :: Value + } + deriving stock (Eq, Show) + +instance ToJSON SALogType where + toJSON l = + case saLogTypeOther l of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "name" .= saLogTypeName l, + "description" .= saLogTypeDescription l, + "source" .= saLogTypeSource l, + "tags" .= saLogTypeTags l + ] + +instance FromJSON SALogType where + parseJSON = withObject "SALogType" $ \o -> + SALogType + <$> o .: "name" + <*> o .:? "description" + <*> o .:? "source" + <*> o .:? "tags" + <*> pure (Object o) + +-- | Response body for @POST /_plugins/_security_analytics/logtype@ and +-- @PUT /_plugins/_security_analytics/logtype/{log_type_id}@: the +-- server-assigned @_id@ and @_version@ plus the persisted 'SALogType' +-- (wrapped in a @logType@ key on the wire). +data SALogTypeResponse = SALogTypeResponse + { saLogTypeResponseId :: Text, + saLogTypeResponseVersion :: Int64, + saLogTypeResponseLogType :: SALogType + } + deriving stock (Eq, Show) + +instance FromJSON SALogTypeResponse where + parseJSON = withObject "SALogTypeResponse" $ \o -> + SALogTypeResponse + <$> o .: "_id" + <*> o .: "_version" + <*> o .: "logType" + +instance ToJSON SALogTypeResponse where + toJSON r = + object + [ "_id" .= saLogTypeResponseId r, + "_version" .= saLogTypeResponseVersion r, + "logType" .= saLogTypeResponseLogType r + ] + +-- | Optional query body for +-- @POST /_plugins/_security_analytics/logtype/_search@. The query DSL +-- is the standard OpenSearch query language; pass +-- 'defaultSALogTypeSearchQuery' for the plain @{"query": {"match_all": {}}}@ +-- that returns the first page of all log types. +data SALogTypeSearchQuery = SALogTypeSearchQuery + { saLogTypeSearchQueryQuery :: Value + } + deriving stock (Eq, Show) + +-- | The empty query: @{"query": {"match_all": {}}}@ on the wire. +defaultSALogTypeSearchQuery :: SALogTypeSearchQuery +defaultSALogTypeSearchQuery = + SALogTypeSearchQuery + { saLogTypeSearchQueryQuery = object ["match_all" .= object []] + } + +instance ToJSON SALogTypeSearchQuery where + toJSON q = object ["query" .= saLogTypeSearchQueryQuery q] + +instance FromJSON SALogTypeSearchQuery where + parseJSON = withObject "SALogTypeSearchQuery" $ \o -> + SALogTypeSearchQuery <$> o .:? "query" .!= object [] + +-- | A single hit in @hits.hits[]@ on a log type search response. The +-- 'SALogType' body lives in @_source@. +data SALogTypeHit = SALogTypeHit + { saLogTypeHitIndex :: Maybe Text, + saLogTypeHitId :: Maybe Text, + saLogTypeHitScore :: Maybe Double, + saLogTypeHitSource :: SALogType, + saLogTypeHitOther :: Value + } + deriving stock (Eq, Show) + +instance FromJSON SALogTypeHit where + parseJSON = withObject "SALogTypeHit" $ \o -> + SALogTypeHit + <$> o .:? "_index" + <*> o .:? "_id" + <*> o .:? "_score" + <*> o .: "_source" + <*> pure (Object o) + +instance ToJSON SALogTypeHit where + toJSON h = + case saLogTypeHitOther h of + Object o -> Object (mergeIgnoringNulls typed o) + _ -> omitNulls typed + where + typed = + [ "_index" .= saLogTypeHitIndex h, + "_id" .= saLogTypeHitId h, + "_score" .= saLogTypeHitScore h, + "_source" .= saLogTypeHitSource h + ] + +-- | The @hits.total@ sub-object on a log type search response. Carries +-- the count (@value@) and whether it is exact (@relation@: @"eq"@ or +-- @"gte"@). Same shape as 'SARulesTotal'. +data SALogTypesTotal = SALogTypesTotal + { saLogTypesTotalValue :: Int64, + saLogTypesTotalRelation :: SALogTypesTotalRelation + } + deriving stock (Eq, Show) + +instance FromJSON SALogTypesTotal where + parseJSON = withObject "SALogTypesTotal" $ \o -> + SALogTypesTotal + <$> o .: "value" + <*> o .: "relation" + +instance ToJSON SALogTypesTotal where + toJSON t = + object + [ "value" .= saLogTypesTotalValue t, + "relation" .= saLogTypesTotalRelation t + ] + +-- | The @hits.total.relation@ discriminator on a log type search +-- response. Mirrors 'SARulesTotalRelation' (with an @SA@-prefixed +-- name to keep plugin-specific types in their own module) and uses +-- the spec-correct @"gte"@ wire string. Unknown values fall through +-- to 'SALogTypesTotalRelationOther'. +data SALogTypesTotalRelation + = SALogTypesTotalRelationEq + | SALogTypesTotalRelationGte + | SALogTypesTotalRelationOther Text + deriving stock (Eq, Show) + +instance FromJSON SALogTypesTotalRelation where + parseJSON = withText "SALogTypesTotalRelation" $ \t -> + pure $ + case t of + "eq" -> SALogTypesTotalRelationEq + "gte" -> SALogTypesTotalRelationGte + other -> SALogTypesTotalRelationOther other + +instance ToJSON SALogTypesTotalRelation where + toJSON SALogTypesTotalRelationEq = "eq" + toJSON SALogTypesTotalRelationGte = "gte" + toJSON (SALogTypesTotalRelationOther t) = toJSON t + +-- | Response envelope for +-- @POST /_plugins/_security_analytics/logtype/_search@. Standard +-- OpenSearch search envelope (@took@, @timed_out@, @_shards@, +-- @hits.total.{value,relation}@, @hits.hits[]@, @hits.max_score@). +-- 'saLogTypesSearchResponseLogTypes' projects out the @['SALogType']@ +-- list for convenience. +data SALogTypesSearchResponse = SALogTypesSearchResponse + { saLogTypesSearchResponseTook :: Maybe Int64, + saLogTypesSearchResponseTimedOut :: Maybe Bool, + saLogTypesSearchResponseShards :: Maybe SARulesShards, + saLogTypesSearchResponseHitsTotal :: Maybe SALogTypesTotal, + saLogTypesSearchResponseMaxScore :: Maybe Double, + saLogTypesSearchResponseHits :: [SALogTypeHit] + } + deriving stock (Eq, Show) + +instance FromJSON SALogTypesSearchResponse where + parseJSON = withObject "SALogTypesSearchResponse" $ \o -> do + hits <- o .:? "hits" .!= object [] + hitsObj <- case hits of + Object ho -> pure ho + _ -> fail "SALogTypesSearchResponse: hits is not an object" + SALogTypesSearchResponse + <$> o .:? "took" + <*> o .:? "timed_out" + <*> o .:? "_shards" + <*> hitsObj .:? "total" + <*> hitsObj .:? "max_score" + <*> hitsObj .:? "hits" .!= [] + +instance ToJSON SALogTypesSearchResponse where + toJSON r = + omitNulls + [ "took" .= saLogTypesSearchResponseTook r, + "timed_out" .= saLogTypesSearchResponseTimedOut r, + "_shards" .= saLogTypesSearchResponseShards r, + "hits" + .= omitNulls + [ "total" .= saLogTypesSearchResponseHitsTotal r, + "max_score" .= saLogTypesSearchResponseMaxScore r, + "hits" .= saLogTypesSearchResponseHits r + ] + ] + +-- | Project the decoded 'SALogType' list out of a +-- 'SALogTypesSearchResponse' (convenience for the common case where the +-- caller does not need pagination metadata). +saLogTypesSearchResponseLogTypes :: SALogTypesSearchResponse -> [SALogType] +saLogTypesSearchResponseLogTypes = map saLogTypeHitSource . saLogTypesSearchResponseHits + +-- | Response body for +-- @DELETE /_plugins/_security_analytics/logtype/{log_type_id}@. Only +-- @_id@ and @_version@ are returned. Trying to delete a built-in +-- (non-custom) log type is rejected by the server. +data DeleteSALogTypeResponse = DeleteSALogTypeResponse + { deleteSALogTypeResponseId :: Text, + deleteSALogTypeResponseVersion :: Int64 + } + deriving stock (Eq, Show) + +instance FromJSON DeleteSALogTypeResponse where + parseJSON = withObject "DeleteSALogTypeResponse" $ \o -> + DeleteSALogTypeResponse + <$> o .: "_id" + <*> o .: "_version" + +instance ToJSON DeleteSALogTypeResponse where + toJSON r = + object + [ "_id" .= deleteSALogTypeResponseId r, + "_version" .= deleteSALogTypeResponseVersion r + ] + +-- | Overlay the typed key-value pairs on top of a captured object, +-- dropping typed pairs whose value is @null@ (so optional fields +-- left 'Nothing' do not clobber a non-null value captured from the +-- wire). Mirrors the helper in +-- "Database.Bloodhound.Internal.Versions.OpenSearch3.Types.Alerting". +mergeIgnoringNulls :: [(Key, Value)] -> KM.KeyMap Value -> KM.KeyMap Value +mergeIgnoringNulls kvs o = KM.union (KM.fromList (filter notNull kvs)) o + where + notNull (_, Null) = False + notNull _ = True diff --git a/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/SnapshotManagement.hs b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/SnapshotManagement.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/Internal/Versions/OpenSearch3/Types/SnapshotManagement.hs @@ -0,0 +1,717 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Database.Bloodhound.Internal.Versions.OpenSearch3.Types.SnapshotManagement where + +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.Imports + +-- $overview +-- +-- The OpenSearch Snapshot Management (SM) plugin runs snapshot creation and +-- deletion on a schedule. Policies live under +-- @\/_plugins\/_sm\/policies\/{policy_name}@ and carry: +-- +-- 1. A user-supplied body ('SMPolicyBody') sent on @POST@\/@PUT@ — no +-- @name@, no @schema_version@, no @enabled_time@: the server injects +-- those. +-- 2. A server-augmented policy ('SMPolicy') returned on @GET@ and inside +-- the @sm_policy@ wrapper of @POST@\/@PUT@ responses — the body fields +-- plus @name@, @schema_version@, @schedule@, @enabled_time@, +-- @last_updated_time@. +-- +-- The SM plugin was introduced in OpenSearch 2.1. The path is identical +-- across OS 2.x and OS 3.x; the only behavioural delta is that @creation@ +-- becomes optional in OpenSearch 3.3+. We model it as 'Maybe' throughout. +-- +-- See + +-- ========================================================================= +-- Newtypes +-- ========================================================================= + +-- | 'SMPolicyName' identifies an SM policy in the URL path +-- @\/_plugins\/_sm\/policies\/{policy_name}@. Wraps 'Text' so it round-trips +-- through JSON as a bare string but is distinct at the Haskell type level. +newtype SMPolicyName = SMPolicyName {unSMPolicyName :: Text} + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON) + +-- ========================================================================= +-- Cron and schedules +-- ========================================================================= + +-- | A cron expression plus its timezone. Used inside 'SMCreation' and +-- 'SMDeletion' schedules. The timezone is a Java TimeZone ID +-- (e.g. @"UTC"@, @"America/Los_Angeles"@). +data SMCron = SMCron + { smCronExpression :: Text, + smCronTimezone :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SMCron where + parseJSON = withObject "SMCron" $ \o -> + SMCron <$> o .: "expression" <*> o .: "timezone" + +instance ToJSON SMCron where + toJSON SMCron {..} = + object + [ "expression" .= smCronExpression, + "timezone" .= smCronTimezone + ] + +-- | The user-facing schedule (a cron block). The Job Scheduler plugin also +-- emits an @interval@ form on responses ('SMJobSchedulerInterval'); the two +-- are mutually exclusive on the wire. +data SMSchedule = SMSchedule + { smScheduleCron :: Maybe SMCron, + smScheduleInterval :: Maybe SMJobSchedulerInterval + } + deriving stock (Eq, Show) + +instance FromJSON SMSchedule where + parseJSON = withObject "SMSchedule" $ \o -> do + smScheduleCron <- o .:? "cron" + smScheduleInterval <- o .:? "interval" + return SMSchedule {..} + +instance ToJSON SMSchedule where + toJSON SMSchedule {..} = + omitNulls + [ "cron" .= smScheduleCron, + "interval" .= smScheduleInterval + ] + +-- | Server-populated Job Scheduler @interval@ block, emitted in +-- 'SMPolicy'.'smPolicySchedule'. The @unit@ is a Java enum string +-- (e.g. @"Minutes"@, @"Hours"@). +data SMJobSchedulerInterval = SMJobSchedulerInterval + { smJobSchedulerIntervalStartTime :: Maybe Int, + smJobSchedulerIntervalPeriod :: Maybe Int, + smJobSchedulerIntervalUnit :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SMJobSchedulerInterval where + parseJSON = withObject "SMJobSchedulerInterval" $ \o -> do + smJobSchedulerIntervalStartTime <- o .:? "start_time" + smJobSchedulerIntervalPeriod <- o .:? "period" + smJobSchedulerIntervalUnit <- o .:? "unit" + return SMJobSchedulerInterval {..} + +instance ToJSON SMJobSchedulerInterval where + toJSON SMJobSchedulerInterval {..} = + omitNulls + [ "start_time" .= smJobSchedulerIntervalStartTime, + "period" .= smJobSchedulerIntervalPeriod, + "unit" .= smJobSchedulerIntervalUnit + ] + +-- ========================================================================= +-- Creation and deletion config +-- ========================================================================= + +-- | Snapshot creation config. @creation.schedule.cron@ is required by the +-- server on OS < 3.3 when the @creation@ block is present; @time_limit@ +-- is an optional duration like @"1h"@. +data SMCreation = SMCreation + { smCreationSchedule :: Maybe SMSchedule, + smCreationTimeLimit :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SMCreation where + parseJSON = withObject "SMCreation" $ \o -> do + smCreationSchedule <- o .:? "schedule" + smCreationTimeLimit <- o .:? "time_limit" + return SMCreation {..} + +instance ToJSON SMCreation where + toJSON SMCreation {..} = + omitNulls + [ "schedule" .= smCreationSchedule, + "time_limit" .= smCreationTimeLimit + ] + +-- | Snapshot retention conditions. @max_age@ is a duration like @"7d"@; +-- @max_count@ / @min_count@ are integers (the server defaults @min_count@ +-- to @1@ when omitted). +data SMDeleteCondition = SMDeleteCondition + { smDeleteConditionMaxAge :: Maybe Text, + smDeleteConditionMaxCount :: Maybe Int, + smDeleteConditionMinCount :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON SMDeleteCondition where + parseJSON = withObject "SMDeleteCondition" $ \o -> do + smDeleteConditionMaxAge <- o .:? "max_age" + smDeleteConditionMaxCount <- o .:? "max_count" + smDeleteConditionMinCount <- o .:? "min_count" + return SMDeleteCondition {..} + +instance ToJSON SMDeleteCondition where + toJSON SMDeleteCondition {..} = + omitNulls + [ "max_age" .= smDeleteConditionMaxAge, + "max_count" .= smDeleteConditionMaxCount, + "min_count" .= smDeleteConditionMinCount + ] + +-- | Snapshot deletion config. @deletion.schedule@ defaults to +-- 'SMCreation'.'smCreationSchedule' when omitted on the request. +data SMDeletion = SMDeletion + { smDeletionSchedule :: Maybe SMSchedule, + smDeletionTimeLimit :: Maybe Text, + smDeletionCondition :: Maybe SMDeleteCondition, + smDeletionSnapshotPattern :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SMDeletion where + parseJSON = withObject "SMDeletion" $ \o -> do + smDeletionSchedule <- o .:? "schedule" + smDeletionTimeLimit <- o .:? "time_limit" + -- See 'SMDeleteCondition': the JSON examples use the key @condition@, + -- the parameter table documents @delete_condition@. Accept both, + -- preferring @condition@ when both are present; emit @condition@ on + -- encode. We use 'KM.lookup' rather than @(.:?) <|> (.:?)@ because + -- @(.:?)@ succeeds with 'Nothing' (rather than failing) when the key + -- is absent, so the alternative would never trigger. + let mRawCondition = KM.lookup "condition" o <|> KM.lookup "delete_condition" o + smDeletionCondition <- traverse parseJSON mRawCondition + smDeletionSnapshotPattern <- o .:? "snapshot_pattern" + return SMDeletion {..} + +instance ToJSON SMDeletion where + toJSON SMDeletion {..} = + omitNulls + [ "schedule" .= smDeletionSchedule, + "time_limit" .= smDeletionTimeLimit, + "condition" .= smDeletionCondition, + "snapshot_pattern" .= smDeletionSnapshotPattern + ] + +-- ========================================================================= +-- snapshot_config (passthrough to Create Snapshot API) +-- ========================================================================= + +-- | The @snapshot_config@ block is forwarded verbatim to the snapshot +-- Create API. The SM docs document a typed subset; we model the typed +-- subset and stash any extras in 'smSnapshotConfigExtras'. +-- +-- /Documentation inconsistency:/ the docs type @ignore_unavailable@, +-- @include_global_state@, and @partial@ as Booleans, but every verbatim +-- example encodes them as the strings @"true"@ / @"false"@. We accept +-- both on decode (see 'parseLenientBool') and emit native Booleans on +-- encode. +data SMSnapshotConfig = SMSnapshotConfig + { smSnapshotConfigRepository :: Maybe Text, + smSnapshotConfigIndices :: Maybe Text, + smSnapshotConfigDateFormat :: Maybe Text, + smSnapshotConfigDateFormatTimezone :: Maybe Text, + smSnapshotConfigTimezone :: Maybe Text, + smSnapshotConfigIgnoreUnavailable :: Maybe Bool, + smSnapshotConfigIncludeGlobalState :: Maybe Bool, + smSnapshotConfigPartial :: Maybe Bool, + smSnapshotConfigMetadata :: Maybe (Map.Map Text Value), + smSnapshotConfigExtras :: Maybe (KM.KeyMap Value) + } + deriving stock (Eq, Show) + +instance FromJSON SMSnapshotConfig where + parseJSON = withObject "SMSnapshotConfig" $ \o -> do + smSnapshotConfigRepository <- o .:? "repository" + smSnapshotConfigIndices <- o .:? "indices" + smSnapshotConfigDateFormat <- o .:? "date_format" + smSnapshotConfigDateFormatTimezone <- o .:? "date_format_timezone" + smSnapshotConfigTimezone <- o .:? "timezone" + smSnapshotConfigIgnoreUnavailable <- o .:? "ignore_unavailable" >>= traverse parseLenientBool + smSnapshotConfigIncludeGlobalState <- o .:? "include_global_state" >>= traverse parseLenientBool + smSnapshotConfigPartial <- o .:? "partial" >>= traverse parseLenientBool + smSnapshotConfigMetadata <- o .:? "metadata" + let knownKeys = + [ "repository", + "indices", + "date_format", + "date_format_timezone", + "timezone", + "ignore_unavailable", + "include_global_state", + "partial", + "metadata" + ] + extras = deleteSeveral (fmap fromString knownKeys) o + smSnapshotConfigExtras <- + if null extras then pure Nothing else pure (Just extras) + return SMSnapshotConfig {..} + +instance ToJSON SMSnapshotConfig where + toJSON SMSnapshotConfig {..} = + let knownPairs = + catMaybes + [ ("repository" .=) <$> smSnapshotConfigRepository, + ("indices" .=) <$> smSnapshotConfigIndices, + ("date_format" .=) <$> smSnapshotConfigDateFormat, + ("date_format_timezone" .=) <$> smSnapshotConfigDateFormatTimezone, + ("timezone" .=) <$> smSnapshotConfigTimezone, + ("ignore_unavailable" .=) <$> smSnapshotConfigIgnoreUnavailable, + ("include_global_state" .=) <$> smSnapshotConfigIncludeGlobalState, + ("partial" .=) <$> smSnapshotConfigPartial, + ("metadata" .=) <$> smSnapshotConfigMetadata + ] + extraPairs = maybe [] KM.toList smSnapshotConfigExtras + in object (knownPairs <> extraPairs) + +-- | Parse a Bool that may arrive as a native Bool or as the strings +-- @"true"@ / @"false"@ (case-insensitive). The SM plugin's @snapshot_config@ +-- block is forwarded verbatim to the snapshot Create API, which historically +-- accepts both representations for @ignore_unavailable@, +-- @include_global_state@, and @partial@. +parseLenientBool :: Value -> Parser Bool +parseLenientBool (Bool b) = pure b +parseLenientBool (String s) + | T.toLower s == "true" = pure True + | T.toLower s == "false" = pure False +parseLenientBool v = + fail $ + "Expected Bool or \"true\"/\"false\" string, got: " <> show v + +-- ========================================================================= +-- notification +-- ========================================================================= + +data SMNotificationChannel = SMNotificationChannel + { smNotificationChannelId :: Text + } + deriving stock (Eq, Show) + +instance FromJSON SMNotificationChannel where + parseJSON = withObject "SMNotificationChannel" $ \o -> + SMNotificationChannel <$> o .: "id" + +instance ToJSON SMNotificationChannel where + toJSON SMNotificationChannel {..} = + object ["id" .= smNotificationChannelId] + +-- | Which SM events trigger a notification. All fields default per the +-- docs: @creation@=@true@, the rest @false@. +data SMNotificationConditions = SMNotificationConditions + { smNotificationConditionsCreation :: Maybe Bool, + smNotificationConditionsDeletion :: Maybe Bool, + smNotificationConditionsFailure :: Maybe Bool, + smNotificationConditionsTimeLimitExceeded :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON SMNotificationConditions where + parseJSON = withObject "SMNotificationConditions" $ \o -> do + smNotificationConditionsCreation <- o .:? "creation" + smNotificationConditionsDeletion <- o .:? "deletion" + smNotificationConditionsFailure <- o .:? "failure" + smNotificationConditionsTimeLimitExceeded <- o .:? "time_limit_exceeded" + return SMNotificationConditions {..} + +instance ToJSON SMNotificationConditions where + toJSON SMNotificationConditions {..} = + omitNulls + [ "creation" .= smNotificationConditionsCreation, + "deletion" .= smNotificationConditionsDeletion, + "failure" .= smNotificationConditionsFailure, + "time_limit_exceeded" .= smNotificationConditionsTimeLimitExceeded + ] + +data SMNotification = SMNotification + { smNotificationChannel :: Maybe SMNotificationChannel, + smNotificationConditions :: Maybe SMNotificationConditions + } + deriving stock (Eq, Show) + +instance FromJSON SMNotification where + parseJSON = withObject "SMNotification" $ \o -> do + smNotificationChannel <- o .:? "channel" + smNotificationConditions <- o .:? "conditions" + return SMNotification {..} + +instance ToJSON SMNotification where + toJSON SMNotification {..} = + omitNulls + [ "channel" .= smNotificationChannel, + "conditions" .= smNotificationConditions + ] + +-- ========================================================================= +-- Request body and server-augmented policy +-- ========================================================================= + +-- | The user-supplied policy body sent on @POST@\/@PUT. Carries only +-- fields the client supplies; the server injects @name@, +-- @schema_version@, @schedule@, @enabled_time@, @last_updated_time@. +data SMPolicyBody = SMPolicyBody + { smPolicyBodyDescription :: Maybe Text, + smPolicyBodyEnabled :: Maybe Bool, + smPolicyBodyCreation :: Maybe SMCreation, + smPolicyBodyDeletion :: Maybe SMDeletion, + smPolicyBodySnapshotConfig :: Maybe SMSnapshotConfig, + smPolicyBodyNotification :: Maybe SMNotification + } + deriving stock (Eq, Show) + +instance FromJSON SMPolicyBody where + parseJSON = withObject "SMPolicyBody" $ \o -> do + smPolicyBodyDescription <- o .:? "description" + smPolicyBodyEnabled <- o .:? "enabled" + smPolicyBodyCreation <- o .:? "creation" + smPolicyBodyDeletion <- o .:? "deletion" + smPolicyBodySnapshotConfig <- o .:? "snapshot_config" + smPolicyBodyNotification <- o .:? "notification" + return SMPolicyBody {..} + +instance ToJSON SMPolicyBody where + toJSON SMPolicyBody {..} = + omitNulls + [ "description" .= smPolicyBodyDescription, + "enabled" .= smPolicyBodyEnabled, + "creation" .= smPolicyBodyCreation, + "deletion" .= smPolicyBodyDeletion, + "snapshot_config" .= smPolicyBodySnapshotConfig, + "notification" .= smPolicyBodyNotification + ] + +-- | A server-augmented SM policy — the body fields plus the +-- server-injected @name@, @schema_version@, @schedule@, @enabled_time@, +-- @last_updated_time@. This is the shape that lives inside the @sm_policy@ +-- wrapper of every SM response. +data SMPolicy = SMPolicy + { smPolicyBody :: SMPolicyBody, + smPolicyName :: Maybe Text, + smPolicySchemaVersion :: Maybe Int, + smPolicySchedule :: Maybe SMSchedule, + smPolicyEnabledTime :: Maybe Int, + smPolicyLastUpdatedTime :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON SMPolicy where + parseJSON v = do + body <- parseJSON v + withObject + "SMPolicy" + ( \o -> do + smPolicyName <- o .:? "name" + smPolicySchemaVersion <- o .:? "schema_version" + smPolicySchedule <- o .:? "schedule" + smPolicyEnabledTime <- o .:? "enabled_time" + smPolicyLastUpdatedTime <- o .:? "last_updated_time" + return SMPolicy {smPolicyBody = body, ..} + ) + v + +instance ToJSON SMPolicy where + toJSON SMPolicy {..} = + let bodyPairs = case toJSON smPolicyBody of + Object o -> KM.toList o + _ -> [] + serverPairs = + catMaybes + [ ("name" .=) <$> smPolicyName, + ("schema_version" .=) <$> smPolicySchemaVersion, + ("schedule" .=) <$> smPolicySchedule, + ("enabled_time" .=) <$> smPolicyEnabledTime, + ("last_updated_time" .=) <$> smPolicyLastUpdatedTime + ] + in object (serverPairs <> bodyPairs) + +-- ========================================================================= +-- Envelopes +-- ========================================================================= + +-- | Response of @POST@\/@PUT@\/@GET /_plugins/_sm/policies/{policy_name}@. +-- The standard document-write envelope (@_id@, @_version@, @_seq_no@, +-- @_primary_term@) wrapping a single @sm_policy@ object. The Create and +-- Update operations share this shape; Get returns it without modification. +data SMPolicyResponse = SMPolicyResponse + { smPolicyResponseId :: Maybe Text, + smPolicyResponseVersion :: Maybe Int, + smPolicyResponseSeqNo :: Maybe Int, + smPolicyResponsePrimaryTerm :: Maybe Int, + smPolicyResponseSMPolicy :: Maybe SMPolicy + } + deriving stock (Eq, Show) + +instance FromJSON SMPolicyResponse where + parseJSON = withObject "SMPolicyResponse" $ \o -> do + smPolicyResponseId <- o .:? "_id" + smPolicyResponseVersion <- o .:? "_version" + smPolicyResponseSeqNo <- o .:? "_seq_no" + smPolicyResponsePrimaryTerm <- o .:? "_primary_term" + rawPolicy <- o .:? "sm_policy" + smPolicyResponseSMPolicy <- traverse parseJSON rawPolicy + return SMPolicyResponse {..} + +instance ToJSON SMPolicyResponse where + toJSON SMPolicyResponse {..} = + omitNulls $ + catMaybes + [ ("_id" .=) <$> smPolicyResponseId, + ("_version" .=) <$> smPolicyResponseVersion, + ("_seq_no" .=) <$> smPolicyResponseSeqNo, + ("_primary_term" .=) <$> smPolicyResponsePrimaryTerm, + ("sm_policy" .=) <$> smPolicyResponseSMPolicy + ] + +-- | Response of @GET /_plugins/_sm/policies@. The SM docs do not give a +-- verbatim example for the list-all variant; we model the conventional +-- OpenSearch shape @\{"policies": [ ... ]\}@ where each entry is a +-- 'SMPolicy' (the same object that lives inside the single-policy +-- @sm_policy@ wrapper). Verify against a live cluster if exact-shape +-- correctness matters. +newtype GetSMPoliciesResponse = GetSMPoliciesResponse + { getSMPoliciesResponsePolicies :: [SMPolicy] + } + deriving stock (Eq, Show) + +instance FromJSON GetSMPoliciesResponse where + parseJSON = withObject "GetSMPoliciesResponse" $ \o -> + GetSMPoliciesResponse <$> (o .:? "policies" .!= []) + +instance ToJSON GetSMPoliciesResponse where + toJSON r = object ["policies" .= getSMPoliciesResponsePolicies r] + +-- | Query parameters for @GET /_plugins/_sm/policies@. +data GetSMPoliciesQuery = GetSMPoliciesQuery + { getSMPoliciesQueryFrom :: Maybe Int, + getSMPoliciesQuerySize :: Maybe Int, + getSMPoliciesQuerySortField :: Maybe Text, + getSMPoliciesQuerySortOrder :: Maybe Text, + getSMPoliciesQueryQueryString :: Maybe Text + } + deriving stock (Eq, Show) + +-- | The empty query — no pagination, sort, or filter. +defaultGetSMPoliciesQuery :: GetSMPoliciesQuery +defaultGetSMPoliciesQuery = + GetSMPoliciesQuery + { getSMPoliciesQueryFrom = Nothing, + getSMPoliciesQuerySize = Nothing, + getSMPoliciesQuerySortField = Nothing, + getSMPoliciesQuerySortOrder = Nothing, + getSMPoliciesQueryQueryString = Nothing + } + +-- | Render a 'GetSMPoliciesQuery' to the query-string pairs expected by +-- @GET /_plugins/_sm/policies@. Empty fields are omitted so the default +-- query renders to no query string at all. +getSMPoliciesQueryParams :: GetSMPoliciesQuery -> [(Text, Maybe Text)] +getSMPoliciesQueryParams GetSMPoliciesQuery {..} = + catMaybes + [ ("from",) . Just . showText <$> getSMPoliciesQueryFrom, + ("size",) . Just . showText <$> getSMPoliciesQuerySize, + ("sortField",) . Just <$> getSMPoliciesQuerySortField, + ("sortOrder",) . Just <$> getSMPoliciesQuerySortOrder, + ("queryString",) . Just <$> getSMPoliciesQueryQueryString + ] + +-- | Response of @DELETE /_plugins/_sm/policies/{policy_name}@. The standard +-- OpenSearch document-delete envelope (SM policies are stored as documents +-- in @.opendistro-ism-config@). +data DeleteSMPolicyResponse = DeleteSMPolicyResponse + { deleteSMPolicyResponseIndex :: Maybe Text, + deleteSMPolicyResponseId :: Maybe Text, + deleteSMPolicyResponseVersion :: Maybe Int, + deleteSMPolicyResponseResult :: Maybe Text, + deleteSMPolicyResponseForcedRefresh :: Maybe Bool, + deleteSMPolicyResponseSeqNo :: Maybe Int, + deleteSMPolicyResponsePrimaryTerm :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON DeleteSMPolicyResponse where + parseJSON = withObject "DeleteSMPolicyResponse" $ \o -> do + deleteSMPolicyResponseIndex <- o .:? "_index" + deleteSMPolicyResponseId <- o .:? "_id" + deleteSMPolicyResponseVersion <- o .:? "_version" + deleteSMPolicyResponseResult <- o .:? "result" + deleteSMPolicyResponseForcedRefresh <- o .:? "forced_refresh" + deleteSMPolicyResponseSeqNo <- o .:? "_seq_no" + deleteSMPolicyResponsePrimaryTerm <- o .:? "_primary_term" + return DeleteSMPolicyResponse {..} + +instance ToJSON DeleteSMPolicyResponse where + toJSON DeleteSMPolicyResponse {..} = + omitNulls + [ "_index" .= deleteSMPolicyResponseIndex, + "_id" .= deleteSMPolicyResponseId, + "_version" .= deleteSMPolicyResponseVersion, + "result" .= deleteSMPolicyResponseResult, + "forced_refresh" .= deleteSMPolicyResponseForcedRefresh, + "_seq_no" .= deleteSMPolicyResponseSeqNo, + "_primary_term" .= deleteSMPolicyResponsePrimaryTerm + ] + +-- ========================================================================= +-- Explain +-- ========================================================================= + +-- | Per-execution info inside 'SMExplainWorkflow'. Only present after at +-- least one execution cycle. @status@ is one of @IN_PROGRESS@, @SUCCESS@, +-- @RETRYING@, @FAILED@, @TIME_LIMIT_EXCEEDED@. The @info.cause@ field is +-- present only on failures. +data SMExplainExecution = SMExplainExecution + { smExplainExecutionStatus :: Maybe Text, + smExplainExecutionStartTime :: Maybe Int, + smExplainExecutionEndTime :: Maybe Int, + smExplainExecutionInfoMessage :: Maybe Text, + smExplainExecutionInfoCause :: Maybe Text + } + deriving stock (Eq, Show) + +instance FromJSON SMExplainExecution where + parseJSON = withObject "SMExplainExecution" $ \o -> do + smExplainExecutionStatus <- o .:? "status" + smExplainExecutionStartTime <- o .:? "start_time" + smExplainExecutionEndTime <- o .:? "end_time" + info <- o .:? "info" + (smExplainExecutionInfoMessage, smExplainExecutionInfoCause) <- + case info of + Nothing -> pure (Nothing, Nothing) + Just i -> + withObject + "SMExplainExecution.info" + ( \io -> do + m <- io .:? "message" + c <- io .:? "cause" + pure (m, c) + ) + i + return SMExplainExecution {..} + +instance ToJSON SMExplainExecution where + toJSON SMExplainExecution {..} = + let infoPairs = + catMaybes + [ ("message" .=) <$> smExplainExecutionInfoMessage, + ("cause" .=) <$> smExplainExecutionInfoCause + ] + infoVal = + if null infoPairs + then Nothing + else Just (object infoPairs) + in omitNulls $ + catMaybes + [ ("status" .=) <$> smExplainExecutionStatus, + ("start_time" .=) <$> smExplainExecutionStartTime, + ("end_time" .=) <$> smExplainExecutionEndTime, + ("info" .=) <$> infoVal + ] + +-- | The @trigger.time@ sub-object. @time@ is milliseconds since epoch. +newtype SMExplainTrigger = SMExplainTrigger + { smExplainTriggerTime :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON SMExplainTrigger where + parseJSON = withObject "SMExplainTrigger" $ \o -> + SMExplainTrigger <$> o .:? "time" + +instance ToJSON SMExplainTrigger where + toJSON SMExplainTrigger {..} = + omitNulls ["time" .= smExplainTriggerTime] + +-- | The @retry.count@ sub-object. +newtype SMExplainRetry = SMExplainRetry + { smExplainRetryCount :: Maybe Int + } + deriving stock (Eq, Show) + +instance FromJSON SMExplainRetry where + parseJSON = withObject "SMExplainRetry" $ \o -> + SMExplainRetry <$> o .:? "count" + +instance ToJSON SMExplainRetry where + toJSON SMExplainRetry {..} = + omitNulls ["count" .= smExplainRetryCount] + +-- | The state of one half (creation or deletion) of an SM policy at +-- explain time. @current_state@ is one of @CREATION_START@, +-- @CREATION_CONDITION_MET@, @CREATING@, @CREATION_FINISHED@, or the +-- @DELETION_*@ equivalents. +data SMExplainWorkflow = SMExplainWorkflow + { smExplainWorkflowCurrentState :: Maybe Text, + smExplainWorkflowTrigger :: Maybe SMExplainTrigger, + smExplainWorkflowLatestExecution :: Maybe SMExplainExecution, + smExplainWorkflowRetry :: Maybe SMExplainRetry + } + deriving stock (Eq, Show) + +instance FromJSON SMExplainWorkflow where + parseJSON = withObject "SMExplainWorkflow" $ \o -> do + smExplainWorkflowCurrentState <- o .:? "current_state" + smExplainWorkflowTrigger <- o .:? "trigger" + smExplainWorkflowLatestExecution <- o .:? "latest_execution" + smExplainWorkflowRetry <- o .:? "retry" + return SMExplainWorkflow {..} + +instance ToJSON SMExplainWorkflow where + toJSON SMExplainWorkflow {..} = + omitNulls + [ "current_state" .= smExplainWorkflowCurrentState, + "trigger" .= smExplainWorkflowTrigger, + "latest_execution" .= smExplainWorkflowLatestExecution, + "retry" .= smExplainWorkflowRetry + ] + +-- | A single entry in the @policies@ array of an 'SMExplainResponse'. +data SMExplainEntry = SMExplainEntry + { smExplainEntryName :: Maybe Text, + smExplainEntryCreation :: Maybe SMExplainWorkflow, + smExplainEntryDeletion :: Maybe SMExplainWorkflow, + smExplainEntryPolicySeqNo :: Maybe Int, + smExplainEntryPolicyPrimaryTerm :: Maybe Int, + smExplainEntryEnabled :: Maybe Bool + } + deriving stock (Eq, Show) + +instance FromJSON SMExplainEntry where + parseJSON = withObject "SMExplainEntry" $ \o -> do + smExplainEntryName <- o .:? "name" + smExplainEntryCreation <- o .:? "creation" + smExplainEntryDeletion <- o .:? "deletion" + smExplainEntryPolicySeqNo <- o .:? "policy_seq_no" + smExplainEntryPolicyPrimaryTerm <- o .:? "policy_primary_term" + smExplainEntryEnabled <- o .:? "enabled" + return SMExplainEntry {..} + +instance ToJSON SMExplainEntry where + toJSON SMExplainEntry {..} = + omitNulls + [ "name" .= smExplainEntryName, + "creation" .= smExplainEntryCreation, + "deletion" .= smExplainEntryDeletion, + "policy_seq_no" .= smExplainEntryPolicySeqNo, + "policy_primary_term" .= smExplainEntryPolicyPrimaryTerm, + "enabled" .= smExplainEntryEnabled + ] + +-- | Response of @GET /_plugins/_sm/policies/{policy_names}/_explain@. The +-- path parameter is a comma-separated list and/or a wildcard pattern +-- (e.g. @"daily*"@). +newtype SMExplainResponse = SMExplainResponse + { smExplainResponsePolicies :: [SMExplainEntry] + } + deriving stock (Eq, Show) + +instance FromJSON SMExplainResponse where + parseJSON = withObject "SMExplainResponse" $ \o -> + SMExplainResponse <$> (o .:? "policies" .!= []) + +instance ToJSON SMExplainResponse where + toJSON r = object ["policies" .= smExplainResponsePolicies r] diff --git a/src/Database/Bloodhound/OpenSearch1/Client.hs b/src/Database/Bloodhound/OpenSearch1/Client.hs --- a/src/Database/Bloodhound/OpenSearch1/Client.hs +++ b/src/Database/Bloodhound/OpenSearch1/Client.hs @@ -1,6 +1,1394 @@ -module Database.Bloodhound.OpenSearch1.Client - ( module Reexport, - ) -where - -import Database.Bloodhound.Common.Client as Reexport +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Database.Bloodhound.OpenSearch1.Client +-- Description : OpenSearch 1 client (re-exports Common + OpenSearch 1 plugins) +-- +-- The OpenSearch 1 client. Re-exports the version-agnostic "Database.Bloodhound.Common.Client" +-- surface and adds OpenSearch 1 plugins: Index State Management (ISM), ML commons +-- models, neural/kNN cache warmup, asynchronous search, SQL and PPL, and the +-- alerting/monitors framework with destinations and notification email +-- accounts/groups. +module Database.Bloodhound.OpenSearch1.Client + ( module Reexport, + deleteISMPolicy, + addISMPolicy, + getMLTask, + putISMPolicy, + putISMPolicyWith, + removeISMPolicy, + changeISMPolicy, + retryISMIndex, + explainISMIndex, + explainISMIndexWith, + getISMPolicy, + getISMPolicies, + getMLStats, + getModel, + searchModels, + listModels, + deleteModel, + predict, + warmupKnnIndex, + warmupKnnIndices, + getKnnStats, + getKnnModel, + trainKnnModel, + trainKnnModelWith, + deleteKnnModel, + searchKnnModels, + submitOSAsyncSearch, + submitOSAsyncSearchWith, + getOSAsyncSearch, + deleteOSAsyncSearch, + getOSAsyncSearchStats, + sqlQuery, + sqlQueryNextPage, + closeSqlCursor, + explainSQL, + pplQuery, + explainPPL, + getSQLStats, + createMonitor, + getMonitor, + updateMonitor, + updateMonitorWith, + deleteMonitor, + searchMonitors, + executeMonitor, + getDestinations, + getDestinationsWith, + createDestination, + updateDestination, + deleteDestination, + getAlertsWith, + getAlerts, + acknowledgeAlert, + getMonitorStats, + createEmailAccount, + getEmailAccount, + updateEmailAccount, + updateEmailAccountWith, + deleteEmailAccount, + createEmailGroup, + getEmailGroup, + updateEmailGroup, + updateEmailGroupWith, + deleteEmailGroup, + getDestination, + searchEmailAccounts, + searchEmailGroups, + createDetector, + getDetector, + previewDetector, + previewDetectorInline, + startDetector, + stopDetector, + updateDetector, + updateDetectorWith, + deleteDetector, + validateDetector, + searchDetectors, + profileDetector, + getDetectorStats, + searchDetectorResults, + deleteDetectorResults, + searchDetectorTasks, + topAnomalies, + createRollup, + createRollupWith, + getRollup, + getAllRollups, + deleteRollup, + startRollup, + stopRollup, + explainRollup, + startReplication, + stopReplication, + pauseReplication, + resumeReplication, + updateReplicationSettings, + getReplicationStatus, + getReplicationStatusWith, + getLeaderStats, + getFollowerStats, + getAutoFollowStats, + createAutoFollowPattern, + deleteAutoFollowPattern, + createTransform, + updateTransform, + updateTransformWith, + getTransform, + getTransforms, + startTransform, + stopTransform, + explainTransform, + previewTransform, + deleteTransform, + ) +where + +import Data.Aeson (FromJSON, Value) +import Data.Text (Text) +import Data.Word (Word64) +import Database.Bloodhound.Client.Cluster as Cluster +import Database.Bloodhound.Common.Client as Reexport hiding + ( PreviewTransformResponse, + TransformId, + TransformStats, + deleteTransform, + explainTransform, + getTransforms, + previewTransform, + startTransform, + stopTransform, + unTransformId, + updateTransform, + updateTransformWith, + ) +import Database.Bloodhound.OpenSearch1.Requests qualified as Requests +import Database.Bloodhound.OpenSearch1.Types + +-- | 'putISMPolicy' creates or updates an ISM policy. +-- See +putISMPolicy :: + (MonadBH m, WithBackend OpenSearch1 m) => + PolicyId -> + ISMPolicyRequest -> + m (ParsedEsResponse PutISMPolicyResponse) +putISMPolicy policyId policy = performBHRequest $ Requests.putISMPolicy policyId policy + +-- | 'putISMPolicyWith' creates or updates an ISM policy with an optional +-- optimistic-concurrency guard (@if_seq_no@ / @if_primary_term@). See +-- 'Requests.putISMPolicyWith' for semantics. +-- See +putISMPolicyWith :: + (MonadBH m, WithBackend OpenSearch1 m) => + PolicyId -> + ISMPolicyRequest -> + Maybe (Word64, Word64) -> + m (ParsedEsResponse PutISMPolicyResponse) +putISMPolicyWith policyId policy mOcc = + performBHRequest $ Requests.putISMPolicyWith policyId policy mOcc + +-- | 'addISMPolicy' applies an existing ISM policy to an index. +-- See +addISMPolicy :: + (MonadBH m, WithBackend OpenSearch1 m) => + PolicyId -> + IndexName -> + m (ParsedEsResponse ISMUpdatedIndicesResponse) +addISMPolicy policyId indexName = performBHRequest $ Requests.addISMPolicy policyId indexName + +-- | 'removeISMPolicy' detaches any ISM policy from the given index. +-- See +removeISMPolicy :: + (MonadBH m, WithBackend OpenSearch1 m) => + IndexName -> + m (ParsedEsResponse ISMUpdatedIndicesResponse) +removeISMPolicy indexName = performBHRequest $ Requests.removeISMPolicy indexName + +-- | 'changeISMPolicy' updates the managed-index policy attached to an index. +-- See +changeISMPolicy :: + (MonadBH m, WithBackend OpenSearch1 m) => + IndexName -> + ChangePolicyRequest -> + m (ParsedEsResponse ISMUpdatedIndicesResponse) +changeISMPolicy indexName req = performBHRequest $ Requests.changeISMPolicy indexName req + +-- | 'retryISMIndex' retries the failed ISM action for an index. Pass +-- @Just state@ to retry into a specific state, or 'Nothing' for the current one. +-- See +retryISMIndex :: + (MonadBH m, WithBackend OpenSearch1 m) => + IndexName -> + Maybe Text -> + m (ParsedEsResponse ISMUpdatedIndicesResponse) +retryISMIndex indexName mState = performBHRequest $ Requests.retryISMIndex indexName mState + +-- | 'explainISMIndex' returns the ISM state of an index. +-- See +explainISMIndex :: + (MonadBH m, WithBackend OpenSearch1 m) => + IndexName -> + m (ParsedEsResponse ISMExplanation) +explainISMIndex indexName = performBHRequest $ Requests.explainISMIndex indexName + +-- | 'explainISMIndexWith' returns the ISM state of an index with optional +-- @show_policy@, @validate_action@, @local@ and @expand_wildcards@ query +-- parameters. +-- See +explainISMIndexWith :: + (MonadBH m, WithBackend OpenSearch1 m) => + IndexName -> + ISMExplainOptions -> + m (ParsedEsResponse ISMExplanation) +explainISMIndexWith indexName opts = + performBHRequest $ Requests.explainISMIndexWith indexName opts + +-- | 'getISMPolicy' fetches a single policy by id. +-- See +getISMPolicy :: + (MonadBH m, WithBackend OpenSearch1 m) => + PolicyId -> + m (ParsedEsResponse ISMPolicyInfo) +getISMPolicy policyId = performBHRequest $ Requests.getISMPolicy policyId + +-- | 'getISMPolicies' lists policies, optionally filtered / paginated. +-- See +getISMPolicies :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe ISMPoliciesQuery -> + m (ParsedEsResponse GetISMPoliciesResponse) +getISMPolicies mQuery = performBHRequest $ Requests.getISMPolicies mQuery + +-- | 'deleteISMPolicy' deletes an ISM policy by id. +-- OpenSearch stores policies as documents in @.opendistro-ism-config@, so the +-- response is the standard document-delete envelope (parsed here as +-- 'IndexedDocument'), not an 'Acknowledged' ack. +-- See +deleteISMPolicy :: + (MonadBH m, WithBackend OpenSearch1 m) => + PolicyId -> + m (ParsedEsResponse IndexedDocument) +deleteISMPolicy policyId = performBHRequest $ Requests.deleteISMPolicy policyId + +-- | 'getMLStats' fetches ML Commons plugin statistics. Both arguments are +-- optional: 'Nothing' for the node ID queries every node; 'Nothing' for the +-- stat name returns every stat. The endpoint is available whenever the ML +-- Commons plugin is installed (no cluster setting needs to be enabled). +-- +-- For more information see +-- . +getMLStats :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe MLNodeId -> + Maybe MLStatName -> + m (ParsedEsResponse MLStats) +getMLStats mNodeId mStatName = performBHRequest $ Requests.getMLStats mNodeId mStatName + +-- | 'getModel' fetches full metadata for a registered model by its +-- 'ModelId'. +-- +-- For more information see +-- . +getModel :: + (MonadBH m, WithBackend OpenSearch1 m) => + ModelId -> + m (ParsedEsResponse ModelInfo) +getModel modelId = performBHRequest $ Requests.getModel modelId + +-- | 'searchModels' searches the model index. +-- See +searchModels :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe Value -> + m (ParsedEsResponse ModelSearchResponse) +searchModels = performBHRequest . Requests.searchModels + +-- | 'listModels' lists models via @POST /_plugins/_ml/models/_search@. +-- Shape-identical to 'searchModels'. +-- See +listModels :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe Value -> + m (ParsedEsResponse ModelSearchResponse) +listModels = performBHRequest . Requests.listModels + +-- | 'deleteModel' deletes a registered model by id. OpenSearch stores +-- models as documents in @.plugins-ml-model@, so the response is the +-- standard document-delete envelope (parsed here as 'IndexedDocument'), +-- not an 'Acknowledged' ack — identical to 'deleteISMPolicy'. A +-- deployed model must be undeployed before it can be deleted, otherwise +-- the server returns an error which surfaces as an 'EsError'. +-- See +deleteModel :: + (MonadBH m, WithBackend OpenSearch1 m) => + ModelId -> + m (ParsedEsResponse IndexedDocument) +deleteModel modelId = performBHRequest $ Requests.deleteModel modelId + +-- | 'predict' invokes a deployed model. The request body and response are +-- model-specific, so both are opaque 'Value's. +-- +-- For more information see +-- . +predict :: + (MonadBH m, WithBackend OpenSearch1 m) => + AlgorithmName -> + ModelId -> + Value -> + m (ParsedEsResponse Value) +predict algo modelId body = performBHRequest $ Requests.predict algo modelId body + +-- | 'warmupKnnIndices' loads the k-NN native library indices for the given +-- indices into memory on the data nodes, so the first k-NN search against +-- each index does not pay the native-engine load latency. Maps to +-- @GET /_plugins/_knn/warmup/{index}@ (the index segment is rendered as a +-- comma-separated list, matching the OpenSearch multi-target syntax) and +-- returns 'ShardsResult' (the @{\"_shards\":{...}}@ envelope, +-- live-verified against OS 2.19.5 and 3.7.0) on success. The warmup is +-- asynchronous — the response is returned as soon as the load is +-- scheduled. +-- +-- For more information see +-- . +warmupKnnIndices :: + (MonadBH m, WithBackend OpenSearch1 m) => + [IndexName] -> + m ShardsResult +warmupKnnIndices indexNames = performBHRequest $ Requests.warmupKnnIndex indexNames + +-- | 'warmupKnnIndex' is a convenience wrapper around 'warmupKnnIndices' +-- for the common single-index case. See 'warmupKnnIndices' for the +-- multi-index variant. +warmupKnnIndex :: + (MonadBH m, WithBackend OpenSearch1 m) => + IndexName -> + m ShardsResult +warmupKnnIndex indexName = warmupKnnIndices [indexName] + +-- | 'getKnnStats' fetches k-NN plugin statistics (Stats API introduced in +-- OpenSearch 1.0). Both arguments are optional: 'Nothing' for the node ID +-- queries every node; 'Nothing' for the stat name returns every stat. The +-- response is a flat 'KnnStats' envelope (cluster-level scalars plus a +-- @nodes@ per-node map); navigate it via 'knnStatsEntries'. +-- +-- For more information see +-- . +getKnnStats :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe KnnNodeId -> + Maybe KnnStatName -> + m (ParsedEsResponse KnnStats) +getKnnStats mNodeId mStatName = performBHRequest $ Requests.getKnnStats mNodeId mStatName + +-- | 'getKnnModel' fetches metadata for a trained k-NN model by its +-- 'ModelId' (model APIs introduced in OpenSearch 1.2). Maps to +-- @GET /_plugins/_knn/models/{model_id}@. The response is a bare object +-- (no envelope), decoded into 'KnnModel'; the 'knnModelModelBlob' field is +-- large and may be absent when the caller has excluded it via +-- @?filter_path@. +-- +-- For more information see +-- . +getKnnModel :: + (MonadBH m, WithBackend OpenSearch1 m) => + ModelId -> + m (ParsedEsResponse KnnModel) +getKnnModel modelId = performBHRequest $ Requests.getKnnModel modelId + +-- | 'trainKnnModel' schedules asynchronous training of a k-NN native library +-- model (e.g. FAISS IVF) from the vectors in a training index's +-- @knn_vector@ field (model APIs introduced in OpenSearch 1.2). Maps to +-- @POST /_plugins/_knn/models/{model_id}/_train@. The request returns as +-- soon as training is scheduled; the 'KnnTrainResponse' echoes the +-- @model_id@ under which training was scheduled. To observe progress, poll +-- 'getKnnModel' and watch 'knnModelState' transition from @training@ to +-- @created@ (success) or @failed@ (consult 'knnModelError' for the cause). +-- +-- Equivalent to 'trainKnnModelWith' with @Nothing@ (no node preference). +-- +-- For more information see +-- . +trainKnnModel :: + (MonadBH m, WithBackend OpenSearch1 m) => + ModelId -> + KnnTrainingRequest -> + m (ParsedEsResponse KnnTrainResponse) +trainKnnModel = trainKnnModelWith Nothing + +-- | 'trainKnnModelWith' extends 'trainKnnModel' with an optional +-- @?preference@ query parameter. Supplying 'Just' a 'KnnNodeId' pins the +-- asynchronous training task to the specified data node, sent on the wire +-- as @?preference={node_id}@; 'Nothing' lets OpenSearch choose the training +-- node. The pinned node must already host a shard of the training index, +-- otherwise OpenSearch rejects the request. +-- +-- For more information see +-- . +trainKnnModelWith :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe KnnNodeId -> + ModelId -> + KnnTrainingRequest -> + m (ParsedEsResponse KnnTrainResponse) +trainKnnModelWith mNodeId modelId req = + performBHRequest $ Requests.trainKnnModelWith mNodeId modelId req + +-- | 'deleteKnnModel' removes a trained k-NN model by its 'ModelId' (model +-- APIs introduced in OpenSearch 1.2). Maps to +-- @DELETE /_plugins/_knn/models/{model_id}@ and returns a +-- 'KnnDeleteModelResponse' echoing the @model_id@ and reporting +-- @result = "deleted"@. Note this is NOT the standard 'Acknowledged' +-- envelope (the k-NN plugin returns a richer response than the typical +-- cluster-level ack). A missing model id surfaces as an 'EsError' via +-- 'StatusDependant', matching 'getKnnModel' and the ML Commons +-- 'deleteModel' precedent. +-- +-- For more information see +-- . +deleteKnnModel :: + (MonadBH m, WithBackend OpenSearch1 m) => + ModelId -> + m (ParsedEsResponse KnnDeleteModelResponse) +deleteKnnModel modelId = performBHRequest $ Requests.deleteKnnModel modelId + +-- | 'searchKnnModels' searches the @.opensearch-knn-models@ system index +-- via @POST /_plugins/_knn/models/_search@ (model APIs introduced in +-- OpenSearch 1.2). The caller drives the query through the standard +-- 'Search' DSL (paginate with @from@\/@size@, filter with 'queryBody', and +-- exclude the large 'knnModelModelBlob' via the 'source' projection). +-- Returns the standard search envelope as a 'SearchResult' whose hits +-- carry a 'KnnModel' in each @_source@. +-- +-- For more information see +-- . +searchKnnModels :: + (MonadBH m, WithBackend OpenSearch1 m) => + Search -> + m (SearchResult KnnModel) +searchKnnModels search = performBHRequest $ Requests.searchKnnModels search + +-- | 'getMLTask' fetches the current state of an ML Commons asynchronous task +-- (model registration, deployment, training, ...). Poll this with the +-- @task_id@ returned by the submit endpoint until 'mlTaskInfoState' reaches +-- 'MLTaskStateCompleted' or 'MLTaskStateFailed'. +-- +-- For more information see +-- . +getMLTask :: + (MonadBH m, WithBackend OpenSearch1 m) => + MLTaskId -> + m (ParsedEsResponse MLTaskInfo) +getMLTask mlTaskId = performBHRequest $ Requests.getMLTask mlTaskId + +-- | 'submitOSAsyncSearch' submits a 'Search' for asynchronous execution via +-- the OpenSearch async search plugin (@POST /_plugins/_asynchronous_search@), +-- returning immediately with an id and partial results. This is the +-- OpenSearch-plugin-path analogue of the Elasticsearch 'submitAsyncSearch'; +-- poll the returned id with 'getOSAsyncSearch' until 'asyncSearchIsRunning' +-- is @False@. +-- +-- For more information see +-- . +submitOSAsyncSearch :: + (FromJSON a, MonadBH m, WithBackend OpenSearch1 m) => + Search -> + m (AsyncSearchResult a) +submitOSAsyncSearch = performBHRequest . Requests.submitOSAsyncSearch + +-- | Like 'submitOSAsyncSearch' but accepts 'AsyncSearchSubmitOptions' +-- carrying the URI parameters documented for +-- @POST /_plugins/_asynchronous_search@ (@wait_for_completion@, +-- @keep_on_completion@, @keep_alive@). The Elasticsearch-only +-- 'assoBatchedReduceSize' and 'assoCcsMinimizeRoundtrips' are silently +-- dropped. 'defaultAsyncSearchSubmitOptions' makes this byte-for-byte +-- equivalent to 'submitOSAsyncSearch'. +-- +-- For more information see +-- . +submitOSAsyncSearchWith :: + (FromJSON a, MonadBH m, WithBackend OpenSearch1 m) => + AsyncSearchSubmitOptions -> + Search -> + m (AsyncSearchResult a) +submitOSAsyncSearchWith opts = performBHRequest . Requests.submitOSAsyncSearchWith opts + +-- | 'getOSAsyncSearch' polls an OpenSearch async search by id, returning its +-- current state and (partial or final) results. Maps to +-- @GET /_plugins/_asynchronous_search/{id}@. +-- +-- For more information see +-- . +getOSAsyncSearch :: + (FromJSON a, MonadBH m, WithBackend OpenSearch1 m) => + AsyncSearchId -> + m (AsyncSearchResult a) +getOSAsyncSearch = performBHRequest . Requests.getOSAsyncSearch + +-- | 'deleteOSAsyncSearch' deletes an OpenSearch async search result and its +-- context by id. Maps to @DELETE /_plugins/_asynchronous_search/{id}@ and returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteOSAsyncSearch :: + (MonadBH m, WithBackend OpenSearch1 m) => + AsyncSearchId -> + m Acknowledged +deleteOSAsyncSearch = performBHRequest . Requests.deleteOSAsyncSearch + +-- | 'getOSAsyncSearchStats' fetches cluster-wide async-search statistics. +-- See 'Database.Bloodhound.OpenSearch1.Requests.getOSAsyncSearchStats'. +getOSAsyncSearchStats :: + (MonadBH m, WithBackend OpenSearch1 m) => + m AsyncSearchStatsResponse +getOSAsyncSearchStats = performBHRequest Requests.getOSAsyncSearchStats + +-- | 'sqlQuery' executes a SQL query via the OpenSearch SQL plugin +-- (@POST /_plugins/_sql@). Returns a JDBC-style rowset ('SQLResult'). Use +-- 'sqlRequestFetchSize' to opt into cursor pagination, then walk subsequent +-- pages with 'sqlQueryNextPage' and release an unfinished cursor with +-- 'closeSqlCursor'. +-- +-- For more information see +-- . +sqlQuery :: + (MonadBH m, WithBackend OpenSearch1 m) => + SQLRequest -> + m (ParsedEsResponse SQLResult) +sqlQuery = performBHRequest . Requests.sqlQuery + +-- | 'sqlQueryNextPage' fetches the next page of a paginated SQL result by +-- POSTing the opaque 'SQLCursor' returned by a previous 'sqlQuery' or +-- 'sqlQueryNextPage' call. The server drops @schema@, @total@, @size@ and +-- @status@ from continuation responses, so every 'SQLResult' field except +-- 'sqlResultDatarows' is 'Maybe'. +-- +-- For more information see +-- . +sqlQueryNextPage :: + (MonadBH m, WithBackend OpenSearch1 m) => + SQLCursor -> + m (ParsedEsResponse SQLResult) +sqlQueryNextPage = performBHRequest . Requests.sqlQueryNextPage + +-- | 'closeSqlCursor' releases the server-side context held by a SQL +-- pagination cursor (@POST /_plugins/_sql/close@). Call this when you stop +-- reading before the cursor is naturally exhausted. +-- +-- For more information see +-- . +closeSqlCursor :: + (MonadBH m, WithBackend OpenSearch1 m) => + SQLCursor -> + m (ParsedEsResponse SQLCloseResult) +closeSqlCursor = performBHRequest . Requests.closeSqlCursor + +-- | 'explainSQL' translates a SQL query into the underlying query DSL without +-- executing it (@POST /_plugins/_sql/_explain@). The response shape varies by +-- query and plugin version, so it is returned as an opaque 'Value'. +-- +-- For more information see +-- . +explainSQL :: + (MonadBH m, WithBackend OpenSearch1 m) => + SQLRequest -> + m (ParsedEsResponse Value) +explainSQL = performBHRequest . Requests.explainSQL + +-- | 'pplQuery' executes a PPL (Piped Processing Language) query via the +-- OpenSearch SQL plugin's PPL endpoint (@POST /_plugins/_ppl@). Returns the +-- same JDBC-style rowset shape as 'sqlQuery' (typed as 'PPLResult'). PPL +-- does not support cursor pagination. +-- +-- For more information see +-- . +pplQuery :: + (MonadBH m, WithBackend OpenSearch1 m) => + PPLRequest -> + m (ParsedEsResponse PPLResult) +pplQuery = performBHRequest . Requests.pplQuery + +-- | 'explainPPL' translates a PPL query into the underlying query DSL without +-- executing it (@POST /_plugins/_ppl/_explain@). The response shape varies by +-- query and plugin version, so it is returned as an opaque 'Value'. +-- +-- For more information see +-- . +explainPPL :: + (MonadBH m, WithBackend OpenSearch1 m) => + PPLRequest -> + m (ParsedEsResponse Value) +explainPPL = performBHRequest . Requests.explainPPL + +-- | 'getSQLStats' fetches SQL plugin statistics +-- (@GET /_plugins/_sql/stats@). The endpoint is node-level only (the +-- plugin documents that cluster-level stats are not implemented), so the +-- response describes only the node you hit; there is no @nodes@ sub-key +-- to navigate. The body is decoded as a flat 'SQLPluginStats' map keyed +-- by metric name because the metric-name set grows across OpenSearch +-- releases. +-- +-- For more information see +-- . +getSQLStats :: + (MonadBH m, WithBackend OpenSearch1 m) => + m (ParsedEsResponse SQLPluginStats) +getSQLStats = performBHRequest Requests.getSQLStats + +-- ========================================================================= +-- Alerting plugin +-- ========================================================================= + +-- | 'createMonitor' creates an alerting monitor. See +-- 'Database.Bloodhound.OpenSearch1.Requests.createMonitor' for the +-- underlying request and the wire-shape details. +createMonitor :: + (MonadBH m, WithBackend OpenSearch1 m) => + Monitor -> + m MonitorResponse +createMonitor monitor = performBHRequest $ Requests.createMonitor monitor + +-- | 'getMonitor' fetches a monitor by id. See +-- 'Database.Bloodhound.OpenSearch1.Requests.getMonitor'. +getMonitor :: + (MonadBH m, WithBackend OpenSearch1 m) => + MonitorId -> + m Monitor +getMonitor monitorId = performBHRequest $ Requests.getMonitor monitorId + +-- | 'updateMonitor' replaces a monitor. See +-- 'Database.Bloodhound.OpenSearch1.Requests.updateMonitor'. +updateMonitor :: + (MonadBH m, WithBackend OpenSearch1 m) => + MonitorId -> + Monitor -> + m MonitorResponse +updateMonitor monitorId monitor = performBHRequest $ Requests.updateMonitor monitorId monitor + +-- | 'updateMonitorWith' replaces a monitor with an optional +-- optimistic-concurrency guard (@if_seq_no@ \/ @if_primary_term@). See +-- 'Database.Bloodhound.OpenSearch1.Requests.updateMonitorWith'. +updateMonitorWith :: + (MonadBH m, WithBackend OpenSearch1 m) => + MonitorId -> + Monitor -> + Maybe (Word64, Word64) -> + m MonitorResponse +updateMonitorWith monitorId monitor mOcc = + performBHRequest $ Requests.updateMonitorWith monitorId monitor mOcc + +-- | 'deleteMonitor' deletes a monitor by id. Returns the bare +-- Elasticsearch delete-document response (see 'DeleteMonitorResponse' for +-- why this deviates from @m 'Acknowledged'@). +deleteMonitor :: + (MonadBH m, WithBackend OpenSearch1 m) => + MonitorId -> + m DeleteMonitorResponse +deleteMonitor monitorId = performBHRequest $ Requests.deleteMonitor monitorId + +-- | 'searchMonitors' searches the monitor store. See +-- 'Database.Bloodhound.OpenSearch1.Requests.searchMonitors'. +searchMonitors :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe MonitorsSearchQuery -> + m (ParsedEsResponse SearchMonitorsResponse) +searchMonitors = performBHRequest . Requests.searchMonitors + +-- | 'executeMonitor' runs a monitor immediately (out of schedule). See +-- 'Database.Bloodhound.OpenSearch1.Requests.executeMonitor'. +executeMonitor :: + (MonadBH m, WithBackend OpenSearch1 m) => + MonitorId -> + Maybe ExecuteMonitorRequest -> + m (ParsedEsResponse ExecuteMonitorResponse) +executeMonitor monitorId mRequest = + performBHRequest $ Requests.executeMonitor monitorId mRequest + +-- | 'getDestinations' lists every configured alerting destination. +-- Returns the bare 'Destination' list (the paging envelope is +-- discarded). See +-- 'Database.Bloodhound.OpenSearch1.Requests.getDestinations' for the +-- underlying request and the wire-shape details. +getDestinations :: + (MonadBH m, WithBackend OpenSearch1 m) => + m [Destination] +getDestinations = performBHRequest Requests.getDestinations + +-- | 'getDestinationsWith' is the parameterized variant of +-- 'getDestinations'. Returns the full 'GetDestinationsResponse' +-- envelope (including @totalDestinations@). See +-- 'Database.Bloodhound.OpenSearch1.Requests.getDestinationsWith'. +getDestinationsWith :: + (MonadBH m, WithBackend OpenSearch1 m) => + DestinationListOptions -> + m GetDestinationsResponse +getDestinationsWith opts = + performBHRequest $ Requests.getDestinationsWith opts + +-- | 'createDestination' creates an alerting destination. See +-- 'Database.Bloodhound.OpenSearch1.Requests.createDestination' for the +-- underlying request and the wire-shape details. +createDestination :: + (MonadBH m, WithBackend OpenSearch1 m) => + Destination -> + m DestinationResponse +createDestination destination = + performBHRequest $ Requests.createDestination destination + +-- | 'updateDestination' replaces a destination. See +-- 'Database.Bloodhound.OpenSearch1.Requests.updateDestination'. +updateDestination :: + (MonadBH m, WithBackend OpenSearch1 m) => + DestinationId -> + Destination -> + m DestinationResponse +updateDestination destId destination = + performBHRequest $ Requests.updateDestination destId destination + +-- | 'deleteDestination' deletes a destination by id. Returns the bare +-- Elasticsearch delete-document response (see 'DeleteDestinationResponse' +-- for why this deviates from @m 'Acknowledged'@). +deleteDestination :: + (MonadBH m, WithBackend OpenSearch1 m) => + DestinationId -> + m DeleteDestinationResponse +deleteDestination destId = + performBHRequest $ Requests.deleteDestination destId + +-- | 'getAlertsWith' lists alert documents, returning the full +-- 'GetAlertsResponse' envelope (including @totalAlerts@). See +-- 'Database.Bloodhound.OpenSearch1.Requests.getAlertsWith'. +getAlertsWith :: + (MonadBH m, WithBackend OpenSearch1 m) => + GetAlertsOptions -> + m GetAlertsResponse +getAlertsWith opts = performBHRequest $ Requests.getAlertsWith opts + +-- | 'getAlerts' lists every active alert, projecting out the bare +-- @['Alert']@ list. See +-- 'Database.Bloodhound.OpenSearch1.Requests.getAlerts'. +getAlerts :: + (MonadBH m, WithBackend OpenSearch1 m) => + m [Alert] +getAlerts = performBHRequest Requests.getAlerts + +-- | 'acknowledgeAlert' acknowledges one or more active alerts of a +-- monitor. See +-- 'Database.Bloodhound.OpenSearch1.Requests.acknowledgeAlert'. +acknowledgeAlert :: + (MonadBH m, WithBackend OpenSearch1 m) => + MonitorId -> + [Text] -> + m AcknowledgeAlertResponse +acknowledgeAlert monitorId alertIds = + performBHRequest $ Requests.acknowledgeAlert monitorId alertIds + +-- | 'getMonitorStats' fetches alerting scheduler statistics. See +-- 'Database.Bloodhound.OpenSearch1.Requests.getMonitorStats'. +getMonitorStats :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe Text -> + Maybe Text -> + m (ParsedEsResponse MonitorStats) +getMonitorStats mNodeId mMetric = + performBHRequest $ Requests.getMonitorStats mNodeId mMetric + +-- | 'createEmailAccount' creates a legacy alerting email account. See +-- 'Database.Bloodhound.OpenSearch1.Requests.createEmailAccount'. +createEmailAccount :: + (MonadBH m, WithBackend OpenSearch1 m) => + EmailAccount -> + m EmailAccountResponse +createEmailAccount account = + performBHRequest $ Requests.createEmailAccount account + +-- | 'getEmailAccount' fetches an email account by id. See +-- 'Database.Bloodhound.OpenSearch1.Requests.getEmailAccount'. +getEmailAccount :: + (MonadBH m, WithBackend OpenSearch1 m) => + EmailAccountId -> + m EmailAccount +getEmailAccount emailAccountId = + performBHRequest $ Requests.getEmailAccount emailAccountId + +-- | 'updateEmailAccount' replaces an email account. See +-- 'Database.Bloodhound.OpenSearch1.Requests.updateEmailAccount'. +updateEmailAccount :: + (MonadBH m, WithBackend OpenSearch1 m) => + EmailAccountId -> + EmailAccount -> + m EmailAccountResponse +updateEmailAccount emailAccountId account = + performBHRequest $ Requests.updateEmailAccount emailAccountId account + +-- | 'updateEmailAccountWith' replaces an email account with an optional +-- optimistic-concurrency guard. See +-- 'Database.Bloodhound.OpenSearch1.Requests.updateEmailAccountWith'. +updateEmailAccountWith :: + (MonadBH m, WithBackend OpenSearch1 m) => + EmailAccountId -> + EmailAccount -> + Maybe (Word64, Word64) -> + m EmailAccountResponse +updateEmailAccountWith emailAccountId account mOcc = + performBHRequest $ Requests.updateEmailAccountWith emailAccountId account mOcc + +-- | 'deleteEmailAccount' deletes an email account by id. Returns the +-- bare Elasticsearch delete-document response (see +-- 'DeleteEmailAccountResponse'). +deleteEmailAccount :: + (MonadBH m, WithBackend OpenSearch1 m) => + EmailAccountId -> + m DeleteEmailAccountResponse +deleteEmailAccount emailAccountId = + performBHRequest $ Requests.deleteEmailAccount emailAccountId + +-- | 'createEmailGroup' creates a legacy alerting email group. See +-- 'Database.Bloodhound.OpenSearch1.Requests.createEmailGroup'. +createEmailGroup :: + (MonadBH m, WithBackend OpenSearch1 m) => + EmailGroup -> + m EmailGroupResponse +createEmailGroup group = + performBHRequest $ Requests.createEmailGroup group + +-- | 'getEmailGroup' fetches an email group by id. See +-- 'Database.Bloodhound.OpenSearch1.Requests.getEmailGroup'. +getEmailGroup :: + (MonadBH m, WithBackend OpenSearch1 m) => + EmailGroupId -> + m EmailGroup +getEmailGroup emailGroupId = + performBHRequest $ Requests.getEmailGroup emailGroupId + +-- | 'updateEmailGroup' replaces an email group. See +-- 'Database.Bloodhound.OpenSearch1.Requests.updateEmailGroup'. +updateEmailGroup :: + (MonadBH m, WithBackend OpenSearch1 m) => + EmailGroupId -> + EmailGroup -> + m EmailGroupResponse +updateEmailGroup emailGroupId group = + performBHRequest $ Requests.updateEmailGroup emailGroupId group + +-- | 'updateEmailGroupWith' replaces an email group with an optional +-- optimistic-concurrency guard. See +-- 'Database.Bloodhound.OpenSearch1.Requests.updateEmailGroupWith'. +updateEmailGroupWith :: + (MonadBH m, WithBackend OpenSearch1 m) => + EmailGroupId -> + EmailGroup -> + Maybe (Word64, Word64) -> + m EmailGroupResponse +updateEmailGroupWith emailGroupId group mOcc = + performBHRequest $ Requests.updateEmailGroupWith emailGroupId group mOcc + +-- | 'deleteEmailGroup' deletes an email group by id. Returns the bare +-- Elasticsearch delete-document response (see 'DeleteEmailGroupResponse'). +deleteEmailGroup :: + (MonadBH m, WithBackend OpenSearch1 m) => + EmailGroupId -> + m DeleteEmailGroupResponse +deleteEmailGroup emailGroupId = + performBHRequest $ Requests.deleteEmailGroup emailGroupId + +-- | 'getDestination' fetches a single destination by id. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getDestination'. +getDestination :: + (MonadBH m, WithBackend OpenSearch1 m) => + DestinationId -> + m GetDestinationsResponse +getDestination destId = + performBHRequest $ Requests.getDestination destId + +-- | 'searchEmailAccounts' searches the email account store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchEmailAccounts'. +searchEmailAccounts :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe EmailAccountSearchQuery -> + m (ParsedEsResponse SearchEmailAccountsResponse) +searchEmailAccounts mQuery = + performBHRequest $ Requests.searchEmailAccounts mQuery + +-- | 'searchEmailGroups' searches the email group store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchEmailGroups'. +searchEmailGroups :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe EmailGroupSearchQuery -> + m (ParsedEsResponse SearchEmailGroupsResponse) +searchEmailGroups mQuery = + performBHRequest $ Requests.searchEmailGroups mQuery + +-- ========================================================================= +-- Anomaly Detection plugin +-- ========================================================================= + +-- | 'createDetector' creates an anomaly detector. See +-- 'Requests.createDetector' for semantics. +-- See +createDetector :: + (MonadBH m, WithBackend OpenSearch1 m) => + Detector -> + m (ParsedEsResponse CreateDetectorResponse) +createDetector = performBHRequest . Requests.createDetector + +-- | 'getDetector' fetches a detector by id. See 'Requests.getDetector' for +-- semantics. +-- See +getDetector :: + (MonadBH m, WithBackend OpenSearch1 m) => + DetectorId -> + GetDetectorParams -> + m (ParsedEsResponse GetDetectorResponse) +getDetector detectorId params = + performBHRequest $ Requests.getDetector detectorId params + +-- | 'previewDetector' previews a detector on historical data. See +-- 'Requests.previewDetector' for semantics. +-- See +previewDetector :: + (MonadBH m, WithBackend OpenSearch1 m) => + DetectorId -> + PreviewRequest -> + m (ParsedEsResponse PreviewResponse) +previewDetector detectorId req = + performBHRequest $ Requests.previewDetector detectorId req + +-- | 'previewDetectorInline' previews an unpersisted or body-referenced +-- detector. See 'Requests.previewDetectorInline' for semantics. +-- See +previewDetectorInline :: + (MonadBH m, WithBackend OpenSearch1 m) => + PreviewRequest -> + m (ParsedEsResponse PreviewResponse) +previewDetectorInline req = + performBHRequest $ Requests.previewDetectorInline req + +-- | 'startDetector' starts a detector job. See +-- 'Requests.startDetector' for semantics. +-- See +startDetector :: + (MonadBH m, WithBackend OpenSearch1 m) => + DetectorId -> + Maybe StartDetectorJobRequest -> + m (ParsedEsResponse DetectorJobAcknowledgment) +startDetector detectorId mReq = + performBHRequest $ Requests.startDetector detectorId mReq + +-- | 'stopDetector' stops a detector job. See 'Requests.stopDetector' +-- for semantics. +-- See +stopDetector :: + (MonadBH m, WithBackend OpenSearch1 m) => + DetectorId -> + Bool -> + m (ParsedEsResponse DetectorJobAcknowledgment) +stopDetector detectorId historical = + performBHRequest $ Requests.stopDetector detectorId historical + +-- | 'updateDetector' replaces a detector. See +-- 'Requests.updateDetector' for semantics. +-- See +updateDetector :: + (MonadBH m, WithBackend OpenSearch1 m) => + DetectorId -> + Detector -> + m (ParsedEsResponse CreateDetectorResponse) +updateDetector detectorId detector = + performBHRequest $ Requests.updateDetector detectorId detector + +-- | 'updateDetectorWith' replaces a detector with an optional +-- optimistic-concurrency guard. See 'Requests.updateDetectorWith'. +-- See +updateDetectorWith :: + (MonadBH m, WithBackend OpenSearch1 m) => + DetectorId -> + Detector -> + Maybe (Word64, Word64) -> + m (ParsedEsResponse CreateDetectorResponse) +updateDetectorWith detectorId detector mOcc = + performBHRequest $ Requests.updateDetectorWith detectorId detector mOcc + +-- | 'deleteDetector' deletes a detector by id. See 'Requests.deleteDetector'. +-- See +deleteDetector :: + (MonadBH m, WithBackend OpenSearch1 m) => + DetectorId -> + m (ParsedEsResponse DeleteDetectorResponse) +deleteDetector detectorId = + performBHRequest $ Requests.deleteDetector detectorId + +-- | 'validateDetector' validates a detector configuration. See +-- 'Requests.validateDetector'. +-- See +validateDetector :: + (MonadBH m, WithBackend OpenSearch1 m) => + ValidateDetectorMode -> + Detector -> + m (ParsedEsResponse ValidateDetectorResponse) +validateDetector mode detector = + performBHRequest $ Requests.validateDetector mode detector + +-- | 'searchDetectors' searches the detector-config index. See +-- 'Requests.searchDetectors'. +-- See +searchDetectors :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe Value -> + m (ParsedEsResponse SearchDetectorsResponse) +searchDetectors mQuery = + performBHRequest $ Requests.searchDetectors mQuery + +-- | 'profileDetector' profiles a detector. See 'Requests.profileDetector'. +-- See +profileDetector :: + (MonadBH m, WithBackend OpenSearch1 m) => + DetectorId -> + [Text] -> + Bool -> + Maybe [Entity] -> + m (ParsedEsResponse DetectorProfileResponse) +profileDetector detectorId types allFlag mEntities = + performBHRequest $ Requests.profileDetector detectorId types allFlag mEntities + +-- | 'getDetectorStats' fetches plugin statistics. See +-- 'Requests.getDetectorStats'. +-- See +getDetectorStats :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe Text -> + Maybe Text -> + m (ParsedEsResponse DetectorStatsResponse) +getDetectorStats mNodeId mStat = + performBHRequest $ Requests.getDetectorStats mNodeId mStat + +-- | 'searchDetectorResults' searches the anomaly-result index. See +-- 'Requests.searchDetectorResults'. +-- See +searchDetectorResults :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe Text -> + Maybe Bool -> + Maybe Value -> + m (ParsedEsResponse SearchDetectorResultsResponse) +searchDetectorResults mCustomResultIndex mOnlyCustom mQuery = + performBHRequest $ Requests.searchDetectorResults mCustomResultIndex mOnlyCustom mQuery + +-- | 'deleteDetectorResults' deletes anomaly-result documents by query. +-- See 'Requests.deleteDetectorResults'. +-- See +deleteDetectorResults :: + (MonadBH m, WithBackend OpenSearch1 m) => + Value -> + m (ParsedEsResponse DeleteDetectorResultsResponse) +deleteDetectorResults query = + performBHRequest $ Requests.deleteDetectorResults query + +-- | 'searchDetectorTasks' searches the detection-state index. See +-- 'Requests.searchDetectorTasks'. +-- See +searchDetectorTasks :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe Value -> + m (ParsedEsResponse SearchDetectorTasksResponse) +searchDetectorTasks mQuery = + performBHRequest $ Requests.searchDetectorTasks mQuery + +-- | 'topAnomalies' returns the top anomaly results for a +-- high-cardinality detector. See 'Requests.topAnomalies'. +-- See +topAnomalies :: + (MonadBH m, WithBackend OpenSearch1 m) => + DetectorId -> + Bool -> + TopAnomaliesRequest -> + m (ParsedEsResponse TopAnomaliesResponse) +topAnomalies detectorId historical req = + performBHRequest $ Requests.topAnomalies detectorId historical req + +-- ---------------------------------------------------------------------------- +-- Index Rollups plugin +-- +-- ---------------------------------------------------------------------------- + +-- | 'createRollup' creates or replaces an index rollup job. See +-- 'Requests.createRollup'. +-- See +createRollup :: + (MonadBH m, WithBackend OpenSearch1 m) => + RollupId -> + Rollup -> + m (ParsedEsResponse RollupResponse) +createRollup rollupId rollup = + performBHRequest $ Requests.createRollup rollupId rollup + +-- | 'createRollupWith' creates or replaces an index rollup job with an +-- optional optimistic-concurrency guard. See 'Requests.createRollupWith'. +-- See +createRollupWith :: + (MonadBH m, WithBackend OpenSearch1 m) => + RollupId -> + Rollup -> + Maybe (Word64, Word64) -> + m (ParsedEsResponse RollupResponse) +createRollupWith rollupId rollup mOcc = + performBHRequest $ Requests.createRollupWith rollupId rollup mOcc + +-- | 'getRollup' fetches a rollup job by id. See 'Requests.getRollup'. +-- See +getRollup :: + (MonadBH m, WithBackend OpenSearch1 m) => + RollupId -> + m (ParsedEsResponse RollupResponse) +getRollup rollupId = + performBHRequest $ Requests.getRollup rollupId + +-- | 'getAllRollups' lists every rollup job. See 'Requests.getAllRollups'. +-- See +getAllRollups :: + (MonadBH m, WithBackend OpenSearch1 m) => + m (ParsedEsResponse Value) +getAllRollups = + performBHRequest $ Requests.getAllRollups + +-- | 'deleteRollup' deletes a rollup job by id. See 'Requests.deleteRollup'. +-- See +deleteRollup :: + (MonadBH m, WithBackend OpenSearch1 m) => + RollupId -> + m (ParsedEsResponse Value) +deleteRollup rollupId = + performBHRequest $ Requests.deleteRollup rollupId + +-- | 'startRollup' starts a rollup job by id. See 'Requests.startRollup'. +-- See +startRollup :: + (MonadBH m, WithBackend OpenSearch1 m) => + RollupId -> + m (ParsedEsResponse Acknowledged) +startRollup rollupId = + performBHRequest $ Requests.startRollup rollupId + +-- | 'stopRollup' stops a rollup job by id. See 'Requests.stopRollup'. +-- See +stopRollup :: + (MonadBH m, WithBackend OpenSearch1 m) => + RollupId -> + m (ParsedEsResponse Acknowledged) +stopRollup rollupId = + performBHRequest $ Requests.stopRollup rollupId + +-- | 'explainRollup' returns execution metadata for a rollup job by id. +-- See 'Requests.explainRollup'. +-- See +explainRollup :: + (MonadBH m, WithBackend OpenSearch1 m) => + RollupId -> + m (ParsedEsResponse ExplainRollupResponse) +explainRollup rollupId = + performBHRequest $ Requests.explainRollup rollupId + +-- ========================================================================= +-- Cross-Cluster Replication (CCR) plugin +-- ========================================================================= + +-- | 'startReplication' begins replicating a leader index into a follower +-- index on the /follower/ cluster. See +-- 'Database.Bloodhound.OpenSearch1.Requests.startReplication'. +startReplication :: + (MonadBH m, WithBackend OpenSearch1 m) => + Text -> + StartReplicationRequest -> + m (ParsedEsResponse Acknowledged) +startReplication followerIndex req = + performBHRequest $ Requests.startReplication followerIndex req + +-- | 'stopReplication' terminates replication and converts the follower +-- index into a standard writable index. See +-- 'Database.Bloodhound.OpenSearch1.Requests.stopReplication'. +stopReplication :: + (MonadBH m, WithBackend OpenSearch1 m) => + Text -> + m (ParsedEsResponse Acknowledged) +stopReplication = performBHRequest . Requests.stopReplication + +-- | 'pauseReplication' pauses replication of the leader index. See +-- 'Database.Bloodhound.OpenSearch1.Requests.pauseReplication'. +pauseReplication :: + (MonadBH m, WithBackend OpenSearch1 m) => + Text -> + m (ParsedEsResponse Acknowledged) +pauseReplication = performBHRequest . Requests.pauseReplication + +-- | 'resumeReplication' resumes replication after a pause. See +-- 'Database.Bloodhound.OpenSearch1.Requests.resumeReplication'. +resumeReplication :: + (MonadBH m, WithBackend OpenSearch1 m) => + Text -> + m (ParsedEsResponse Acknowledged) +resumeReplication = performBHRequest . Requests.resumeReplication + +-- | 'updateReplicationSettings' applies index-level settings to the +-- follower index. See +-- 'Database.Bloodhound.OpenSearch1.Requests.updateReplicationSettings'. +updateReplicationSettings :: + (MonadBH m, WithBackend OpenSearch1 m) => + Text -> + UpdateReplicationSettingsRequest -> + m (ParsedEsResponse Acknowledged) +updateReplicationSettings followerIndex req = + performBHRequest $ Requests.updateReplicationSettings followerIndex req + +-- | 'getReplicationStatus' fetches the replication state of a follower +-- index without the @verbose@ flag. See +-- 'Database.Bloodhound.OpenSearch1.Requests.getReplicationStatus'. +getReplicationStatus :: + (MonadBH m, WithBackend OpenSearch1 m) => + Text -> + m (ParsedEsResponse ReplicationStatusResponse) +getReplicationStatus = performBHRequest . Requests.getReplicationStatus + +-- | 'getReplicationStatusWith' is the parameterized variant of +-- 'getReplicationStatus'. See +-- 'Database.Bloodhound.OpenSearch1.Requests.getReplicationStatusWith'. +getReplicationStatusWith :: + (MonadBH m, WithBackend OpenSearch1 m) => + ReplicationStatusOptions -> + Text -> + m (ParsedEsResponse ReplicationStatusResponse) +getReplicationStatusWith opts followerIndex = + performBHRequest $ Requests.getReplicationStatusWith opts followerIndex + +-- | 'getLeaderStats' fetches aggregate and per-index read-side counters +-- from the /leader/ cluster. See +-- 'Database.Bloodhound.OpenSearch1.Requests.getLeaderStats'. +getLeaderStats :: + (MonadBH m, WithBackend OpenSearch1 m) => + m (ParsedEsResponse LeaderStatsResponse) +getLeaderStats = performBHRequest Requests.getLeaderStats + +-- | 'getFollowerStats' fetches follower index state counts and write-side +-- throughput from the /follower/ cluster. See +-- 'Database.Bloodhound.OpenSearch1.Requests.getFollowerStats'. +getFollowerStats :: + (MonadBH m, WithBackend OpenSearch1 m) => + m (ParsedEsResponse FollowerStatsResponse) +getFollowerStats = performBHRequest Requests.getFollowerStats + +-- | 'getAutoFollowStats' fetches auto-follow activity and the configured +-- replication rules. See +-- 'Database.Bloodhound.OpenSearch1.Requests.getAutoFollowStats'. +getAutoFollowStats :: + (MonadBH m, WithBackend OpenSearch1 m) => + m (ParsedEsResponse AutoFollowStatsResponse) +getAutoFollowStats = performBHRequest Requests.getAutoFollowStats + +-- | 'createAutoFollowPattern' creates or updates an auto-follow rule. +-- See +-- 'Database.Bloodhound.OpenSearch1.Requests.createAutoFollowPattern'. +createAutoFollowPattern :: + (MonadBH m, WithBackend OpenSearch1 m) => + CreateAutoFollowPatternRequest -> + m (ParsedEsResponse Acknowledged) +createAutoFollowPattern = + performBHRequest . Requests.createAutoFollowPattern + +-- | 'deleteAutoFollowPattern' deletes an auto-follow rule. See +-- 'Database.Bloodhound.OpenSearch1.Requests.deleteAutoFollowPattern'. +deleteAutoFollowPattern :: + (MonadBH m, WithBackend OpenSearch1 m) => + DeleteAutoFollowPatternRequest -> + m (ParsedEsResponse Acknowledged) +deleteAutoFollowPattern = + performBHRequest . Requests.deleteAutoFollowPattern + +-- ========================================================================= +-- Index Transforms plugin +-- ========================================================================= + +-- | 'createTransform' creates or replaces a transform job. See +-- 'Requests.createTransform' for semantics. +-- See +createTransform :: + (MonadBH m, WithBackend OpenSearch1 m) => + TransformId -> + Transform -> + m (ParsedEsResponse TransformDocumentResponse) +createTransform transformId transform = + performBHRequest $ Requests.createTransform transformId transform + +-- | 'updateTransform' replaces a transform job (unconditional). See +-- 'Requests.updateTransform' for semantics. +-- See +updateTransform :: + (MonadBH m, WithBackend OpenSearch1 m) => + TransformId -> + Transform -> + m (ParsedEsResponse TransformDocumentResponse) +updateTransform transformId transform = + performBHRequest $ Requests.updateTransform transformId transform + +-- | 'updateTransformWith' replaces a transform job with an optional +-- optimistic-concurrency guard. See 'Requests.updateTransformWith'. +-- See +updateTransformWith :: + (MonadBH m, WithBackend OpenSearch1 m) => + TransformId -> + Transform -> + Maybe (Word64, Word64) -> + m (ParsedEsResponse TransformDocumentResponse) +updateTransformWith transformId transform mOcc = + performBHRequest $ Requests.updateTransformWith transformId transform mOcc + +-- | 'getTransform' fetches a single transform job by id. See +-- 'Requests.getTransform'. +-- See +getTransform :: + (MonadBH m, WithBackend OpenSearch1 m) => + TransformId -> + m (ParsedEsResponse TransformDocumentResponse) +getTransform transformId = + performBHRequest $ Requests.getTransform transformId + +-- | 'getTransforms' lists transform jobs, optionally filtered / +-- paginated. See 'Requests.getTransforms'. +-- See +getTransforms :: + (MonadBH m, WithBackend OpenSearch1 m) => + Maybe TransformsListOptions -> + m (ParsedEsResponse GetTransformsResponse) +getTransforms mOpts = + performBHRequest $ Requests.getTransforms mOpts + +-- | 'startTransform' starts a transform job. See +-- 'Requests.startTransform'. +-- See +startTransform :: + (MonadBH m, WithBackend OpenSearch1 m) => + TransformId -> + m (ParsedEsResponse Acknowledged) +startTransform transformId = + performBHRequest $ Requests.startTransform transformId + +-- | 'stopTransform' stops a transform job. See 'Requests.stopTransform'. +-- See +stopTransform :: + (MonadBH m, WithBackend OpenSearch1 m) => + TransformId -> + m (ParsedEsResponse Acknowledged) +stopTransform transformId = + performBHRequest $ Requests.stopTransform transformId + +-- | 'explainTransform' returns the runtime status and statistics of a +-- transform job. See 'Requests.explainTransform'. +-- See +explainTransform :: + (MonadBH m, WithBackend OpenSearch1 m) => + TransformId -> + m (ParsedEsResponse (Maybe TransformExplain)) +explainTransform transformId = + performBHRequest $ Requests.explainTransform transformId + +-- | 'previewTransform' previews what the transformed target index would +-- look like. See 'Requests.previewTransform'. +-- See +previewTransform :: + (MonadBH m, WithBackend OpenSearch1 m) => + Transform -> + m (ParsedEsResponse PreviewTransformResponse) +previewTransform transform = + performBHRequest $ Requests.previewTransform transform + +-- | 'deleteTransform' deletes a transform job by id. See +-- 'Requests.deleteTransform'. +-- See +deleteTransform :: + (MonadBH m, WithBackend OpenSearch1 m) => + TransformId -> + m (ParsedEsResponse BulkResponse) +deleteTransform transformId = + performBHRequest $ Requests.deleteTransform transformId diff --git a/src/Database/Bloodhound/OpenSearch1/Requests.hs b/src/Database/Bloodhound/OpenSearch1/Requests.hs --- a/src/Database/Bloodhound/OpenSearch1/Requests.hs +++ b/src/Database/Bloodhound/OpenSearch1/Requests.hs @@ -1,6 +1,2630 @@ -module Database.Bloodhound.OpenSearch1.Requests - ( module Reexport, - ) -where - -import Database.Bloodhound.Common.Requests as Reexport +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Database.Bloodhound.OpenSearch1.Requests + ( module Reexport, + deleteISMPolicy, + addISMPolicy, + getMLTask, + putISMPolicy, + putISMPolicyWith, + removeISMPolicy, + changeISMPolicy, + retryISMIndex, + explainISMIndex, + explainISMIndexWith, + getISMPolicy, + getISMPolicies, + getMLStats, + getModel, + searchModels, + listModels, + deleteModel, + predict, + warmupKnnIndex, + getKnnStats, + getKnnModel, + trainKnnModel, + trainKnnModelWith, + deleteKnnModel, + searchKnnModels, + submitOSAsyncSearch, + submitOSAsyncSearchWith, + getOSAsyncSearch, + deleteOSAsyncSearch, + getOSAsyncSearchStats, + sqlQuery, + sqlQueryNextPage, + closeSqlCursor, + explainSQL, + pplQuery, + explainPPL, + getSQLStats, + createMonitor, + getMonitor, + updateMonitor, + updateMonitorWith, + deleteMonitor, + searchMonitors, + executeMonitor, + getDestinations, + getDestinationsWith, + createDestination, + updateDestination, + deleteDestination, + getAlertsWith, + getAlerts, + acknowledgeAlert, + getMonitorStats, + createEmailAccount, + getEmailAccount, + updateEmailAccount, + updateEmailAccountWith, + deleteEmailAccount, + createEmailGroup, + getEmailGroup, + updateEmailGroup, + updateEmailGroupWith, + deleteEmailGroup, + getDestination, + searchEmailAccounts, + searchEmailGroups, + createDetector, + getDetector, + previewDetector, + previewDetectorInline, + startDetector, + stopDetector, + updateDetector, + updateDetectorWith, + deleteDetector, + validateDetector, + searchDetectors, + profileDetector, + getDetectorStats, + searchDetectorResults, + deleteDetectorResults, + searchDetectorTasks, + topAnomalies, + createRollup, + createRollupWith, + getRollup, + getAllRollups, + deleteRollup, + startRollup, + stopRollup, + explainRollup, + startReplication, + stopReplication, + pauseReplication, + resumeReplication, + updateReplicationSettings, + getReplicationStatus, + getReplicationStatusWith, + getLeaderStats, + getFollowerStats, + getAutoFollowStats, + createAutoFollowPattern, + deleteAutoFollowPattern, + createTransform, + updateTransform, + updateTransformWith, + getTransform, + getTransforms, + startTransform, + stopTransform, + explainTransform, + previewTransform, + deleteTransform, + ) +where + +import Data.Aeson (FromJSON, Value (..), encode, object, toJSON, (.=)) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word64) +import Database.Bloodhound.Client.Cluster (emptyBody) +import Database.Bloodhound.Common.Requests as Reexport hiding + ( deleteTransform, + explainTransform, + getTransforms, + previewTransform, + startTransform, + stopTransform, + updateTransform, + updateTransformWith, + ) +import Database.Bloodhound.Internal.Client.BHRequest +import Database.Bloodhound.Internal.Utils.Imports (deleteSeveral, showText) +import Database.Bloodhound.Internal.Utils.Requests (delete, deleteWithBody, get, getWithBody, post, postNoBody, put) +import Database.Bloodhound.OpenSearch1.Types + +-- | 'putISMPolicy' creates or updates an ISM policy. Equivalent to +-- 'putISMPolicyWith' with 'Nothing' (no optimistic-concurrency guard), so +-- concurrent updates to the same policy id silently clobber each other. +-- See +putISMPolicy :: + PolicyId -> + ISMPolicyRequest -> + BHRequest StatusDependant (ParsedEsResponse PutISMPolicyResponse) +putISMPolicy policyId policy = putISMPolicyWith policyId policy Nothing + +-- | 'putISMPolicyWith' creates or updates an ISM policy with an optional +-- optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ — both +-- values read from a prior 'PutISMPolicyResponse' — to make the PUT +-- conditional on the policy being unchanged since you last read it; a stale +-- pair causes OpenSearch to respond with HTTP 409 instead of silently +-- overwriting. Pass 'Nothing' for the unconditional semantics of +-- 'putISMPolicy'. The two values must be supplied together: OpenSearch +-- rejects a partial pair with HTTP 400 (mirroring the document-write +-- @if_seq_no@ / @if_primary_term@ semantics). +-- See +putISMPolicyWith :: + PolicyId -> + ISMPolicyRequest -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant (ParsedEsResponse PutISMPolicyResponse) +putISMPolicyWith policyId policy mOcc = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode policy) + where + baseEndpoint = mkEndpoint ["_plugins", "_ism", "policies", unPolicyId policyId] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries baseEndpoint $ + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'addISMPolicy' applies an existing ISM policy to one or more indices. +-- The @policy_id@ in the body identifies the policy to attach. Indices that +-- already have a policy attached (or reject the operation for other reasons) +-- appear in the @failed_indices@ field of the response. +-- See +addISMPolicy :: + PolicyId -> + IndexName -> + BHRequest StatusDependant (ParsedEsResponse ISMUpdatedIndicesResponse) +addISMPolicy policyId indexName = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_plugins", "_ism", "add", unIndexName indexName] + body = object ["policy_id" .= unPolicyId policyId] + +-- | 'removeISMPolicy' detaches any ISM policy from the given index. The +-- response reports how many indices were updated (OpenSearch returns the same +-- @updated_indices\/failures\/failed_indices@ shape as 'addISMPolicy', not a +-- bare @acknowledged@ flag). +-- See +removeISMPolicy :: + IndexName -> + BHRequest StatusDependant (ParsedEsResponse ISMUpdatedIndicesResponse) +removeISMPolicy indexName = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_ism", "remove", unIndexName indexName] + +-- | 'changeISMPolicy' updates the managed-index policy attached to @index@ to +-- the policy named in the 'ChangePolicyRequest'. The change is asynchronous. +-- See +changeISMPolicy :: + IndexName -> + ChangePolicyRequest -> + BHRequest StatusDependant (ParsedEsResponse ISMUpdatedIndicesResponse) +changeISMPolicy indexName req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ism", "change_policy", unIndexName indexName] + +-- | 'retryISMIndex' retries the failed ISM action for an index. Pass +-- @Just state@ to retry into a specific state, or 'Nothing' to retry the +-- current one. The index must be managed by ISM and in a failed state. +-- See +retryISMIndex :: + IndexName -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse ISMUpdatedIndicesResponse) +retryISMIndex indexName mState = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ism", "retry", unIndexName indexName] + body = case mState of + Nothing -> encode (object []) + Just st -> encode (object ["state" .= st]) + +-- | 'explainISMIndex' returns the ISM state of @index@. Equivalent to +-- 'explainISMIndexWith' with 'defaultISMExplainOptions' (no query +-- parameters). +-- See +explainISMIndex :: + IndexName -> + BHRequest StatusDependant (ParsedEsResponse ISMExplanation) +explainISMIndex indexName = explainISMIndexWith indexName defaultISMExplainOptions + +-- | 'explainISMIndexWith' returns the ISM state of @index@, forwarding the +-- supplied 'ISMExplainOptions' as query-string parameters. All four +-- documented parameters are emitted (@show_policy@, @validate_action@, +-- @local@, @expand_wildcards@); 'Nothing' \/ 'False' fields are omitted so +-- 'defaultISMExplainOptions' reproduces the wire shape of 'explainISMIndex'. +-- See +explainISMIndexWith :: + IndexName -> + ISMExplainOptions -> + BHRequest StatusDependant (ParsedEsResponse ISMExplanation) +explainISMIndexWith indexName opts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_ism", "explain", unIndexName indexName] + endpoint = withQueries baseEndpoint (ismExplainOptionsParams opts) + +-- | 'getISMPolicy' fetches a single policy by id. The response is the bare +-- policy object (no @policies@ wrapper). +-- See +getISMPolicy :: + PolicyId -> + BHRequest StatusDependant (ParsedEsResponse ISMPolicyInfo) +getISMPolicy policyId = + withBHResponseParsedEsResponse $ + get @StatusDependant (mkEndpoint ["_plugins", "_ism", "policies", unPolicyId policyId]) + +-- | 'getISMPolicies' lists policies, optionally filtered / paginated via an +-- 'ISMPoliciesQuery'. +-- See +getISMPolicies :: + Maybe ISMPoliciesQuery -> + BHRequest StatusDependant (ParsedEsResponse GetISMPoliciesResponse) +getISMPolicies mQuery = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_ism", "policies"] + endpoint = case mQuery of + Nothing -> baseEndpoint + Just query -> withQueries baseEndpoint (ismPoliciesQueryToPairs query) + +-- | 'deleteISMPolicy' deletes an ISM policy by id. +-- OpenSearch stores policies as documents in @.opendistro-ism-config@, so the +-- response is the standard document-delete envelope (parsed here as +-- 'IndexedDocument'), not an 'Acknowledged' ack. +-- See +deleteISMPolicy :: + PolicyId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteISMPolicy policyId = + withBHResponseParsedEsResponse $ + delete @StatusDependant (mkEndpoint ["_plugins", "_ism", "policies", unPolicyId policyId]) + +-- | 'getMLStats' calls the ML Commons plugin Stats API +-- (@GET /_plugins/_ml/[{nodeId}/]stats[/{stat}]@). Both arguments are +-- optional and select, respectively, which node(s) to query (defaults to all) +-- and which stat(s) to return (defaults to all). The ML Commons stats +-- endpoint is always available whenever the plugin is installed — no cluster +-- setting needs to be enabled. +-- +-- The response body is a JSON object whose top-level keys are either +-- cluster-level stat names (mapping to scalars) or the literal key @nodes@ +-- (mapping to a per-node map keyed by opaque node ID); see the module docs +-- of 'MLStats' for why the entries are kept as aeson 'Value's rather than +-- modelled per-stat. +-- +-- For more information see +-- . +getMLStats :: + Maybe MLNodeId -> + Maybe MLStatName -> + BHRequest StatusDependant (ParsedEsResponse MLStats) +getMLStats mNodeId mStatName = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint segments + segments = + ["_plugins", "_ml"] + <> foldMap (pure . unMLNodeId) mNodeId + <> ["stats"] + <> foldMap (pure . unMLStatName) mStatName + +-- ========================================================================= +-- ML Commons model APIs +-- ========================================================================= + +-- | 'getModel' calls the ML Commons Get Model API +-- (@GET /_plugins/_ml/models/{model_id}@). Returns the model's full metadata. +-- +-- For more information see +-- . +getModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse ModelInfo) +getModel modelId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", unModelId modelId] + +-- | 'deleteModel' deletes a registered model by id. OpenSearch stores +-- models as documents in @.plugins-ml-model@, so the response is the +-- standard document-delete envelope (parsed here as 'IndexedDocument'), +-- not an 'Acknowledged' ack — identical to 'deleteISMPolicy'. A +-- deployed model must be undeployed before it can be deleted, otherwise +-- the server returns an error which surfaces as an 'EsError' under +-- 'StatusDependant'. +-- See +deleteModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteModel modelId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", unModelId modelId] + +-- | 'searchModels' searches the model index via +-- @POST /_plugins/_ml/models/_search@. Pass 'Nothing' for the plain +-- empty-body @{}@ POST; pass @'Just' query@ to filter, paginate, or +-- sort using the standard OpenSearch query DSL carried opaquely as a +-- 'Value'. +-- See +searchModels :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse ModelSearchResponse) +searchModels = searchModelsOn "_search" + +-- | 'listModels' lists models via @POST /_plugins/_ml/models/_search@. +-- Historically this hit an @_list@ path, but that path is not documented +-- for ML Commons in any OS version (and OS 2.x removed POST from it, +-- returning 405). The supported, documented listing endpoint is @_search@ +-- — the same one 'searchModels' uses. Kept as a separate function rather +-- than aliased to 'searchModels' so callers and telemetry can distinguish +-- the two call sites. +-- See +listModels :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse ModelSearchResponse) +listModels = searchModelsOn "_search" + +-- | Shared body of 'searchModels' and 'listModels'. +searchModelsOn :: + Text -> + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse ModelSearchResponse) +searchModelsOn suffix mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", suffix] + body = encode (maybe (object []) id mQuery) + +-- | 'predict' invokes a deployed model. The path carries an +-- @algorithm_name@ and a @model_id@; the request body and the response are +-- model-specific, so both are typed as opaque 'Value's. +-- +-- For more information see +-- . +predict :: + AlgorithmName -> + ModelId -> + Value -> + BHRequest StatusDependant (ParsedEsResponse Value) +predict algo modelId body = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint + ["_plugins", "_ml", "_predict", unAlgorithmName algo, unModelId modelId] + +-- ========================================================================= +-- k-NN plugin +-- ========================================================================= + +-- | 'warmupKnnIndex' calls the k-NN plugin Warmup API +-- (@GET /_plugins/_knn/warmup/{index}@). Loads the k-NN native library +-- indices for the supplied indices into memory on the data nodes so the +-- first k-NN search against each index does not pay the native-engine +-- load latency. The request carries no body; the response is a +-- 'ShardsResult' (@{\"_shards\":{...}}@ envelope) reporting how many +-- shards scheduled the load. +-- +-- The @index@ path segment follows the OpenSearch multi-target syntax: the +-- supplied list is rendered as a single comma-separated segment +-- (e.g. @[i1, i2]@ becomes @i1,i2@). An empty list renders an empty +-- segment and the server will respond with an error. +-- +-- The warmup is asynchronous: the response is returned as soon as the +-- load is scheduled, not when it completes. +-- +-- For more information see +-- . +warmupKnnIndex :: + [IndexName] -> + BHRequest StatusIndependant ShardsResult +warmupKnnIndex indexNames = + get endpoint + where + endpoint = mkEndpoint ["_plugins", "_knn", "warmup", T.intercalate "," (map unIndexName indexNames)] + +-- | 'getKnnStats' calls the k-NN plugin Stats API +-- (@GET /_plugins/_knn/[{nodeId}/]stats[/{stat}]@), introduced in +-- OpenSearch 1.0. Both arguments are optional and select, respectively, +-- which node(s) to query (defaults to all) and which stat(s) to return +-- (defaults to all). +-- +-- The response body is a typed envelope ('KnnStats') — a flat +-- 'Map.Map Text Value' whose top-level keys are either cluster-level +-- stat names (mapping to scalars) or the literal @nodes@ key (mapping to +-- a per-node map keyed by opaque node ID); see the module docs of +-- 'KnnStats' for why the entries are kept as aeson 'Value's rather than +-- modelled per-stat, and for how to navigate to a given node or cluster +-- value. +-- +-- For more information see +-- . +getKnnStats :: + Maybe KnnNodeId -> + Maybe KnnStatName -> + BHRequest StatusDependant (ParsedEsResponse KnnStats) +getKnnStats mNodeId mStatName = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint segments + segments = + ["_plugins", "_knn"] + <> foldMap (pure . unKnnNodeId) mNodeId + <> ["stats"] + <> foldMap (pure . unKnnStatName) mStatName + +-- | 'getKnnModel' calls the k-NN plugin Get Model API +-- (@GET /_plugins/_knn/models/{model_id}@), introduced in OpenSearch 1.2. +-- Returns the model's metadata, including its lifecycle 'KnnModelState', +-- the base64-serialized 'knnModelModelBlob' (large, often excluded +-- server-side via @?filter_path@), the vector 'knnModelDimension' and +-- distance 'knnModelSpaceType', and the native 'knnModelEngine' (@faiss@ +-- or deprecated @nmslib@). The response is a bare object (no envelope), +-- decoded into 'KnnModel'. +-- +-- For more information see +-- . +getKnnModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse KnnModel) +getKnnModel modelId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_knn", "models", unModelId modelId] + +-- | 'trainKnnModel' calls the k-NN plugin Train Model API +-- (@POST /_plugins/_knn/models/{model_id}/_train@), introduced in +-- OpenSearch 1.2. Schedules asynchronous training of a native library +-- model (FAISS IVF and friends) from the @knn_vector@ field of a training +-- index. The request returns as soon as training is scheduled, carrying +-- only the @model_id@ in 'KnnTrainResponse'; the model enters the +-- @training@ state. Poll 'getKnnModel' to observe the transition to +-- @created@ (success) or @failed@ (with the @error@ field populated). +-- +-- Equivalent to 'trainKnnModelWith' with @Nothing@ (no node preference). +-- +-- For more information see +-- . +trainKnnModel :: + ModelId -> + KnnTrainingRequest -> + BHRequest StatusDependant (ParsedEsResponse KnnTrainResponse) +trainKnnModel = trainKnnModelWith Nothing + +-- | 'trainKnnModelWith' extends 'trainKnnModel' with an optional +-- @?preference@ query parameter. Supplying 'Just' a 'KnnNodeId' pins the +-- asynchronous training task to the specified data node, sent on the wire +-- as @?preference={node_id}@; 'Nothing' lets OpenSearch choose the training +-- node. The pinned node must already host a shard of the training index, +-- otherwise OpenSearch rejects the request. +-- +-- For more information see +-- . +trainKnnModelWith :: + Maybe KnnNodeId -> + ModelId -> + KnnTrainingRequest -> + BHRequest StatusDependant (ParsedEsResponse KnnTrainResponse) +trainKnnModelWith mNodeId modelId req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + baseEndpoint = mkEndpoint ["_plugins", "_knn", "models", unModelId modelId, "_train"] + endpoint = case mNodeId of + Nothing -> baseEndpoint + Just nodeId -> withQueries baseEndpoint [("preference", Just (unKnnNodeId nodeId))] + +-- | 'deleteKnnModel' calls the k-NN plugin Delete Model API +-- (@DELETE /_plugins/_knn/models/{model_id}@), introduced in OpenSearch +-- 1.2. Removes a trained model from the cluster's +-- @.opensearch-knn-models@ system index. The response is a +-- 'KnnDeleteModelResponse' echoing the @model_id@ and reporting +-- @result = "deleted"@ — note this is NOT the standard 'Acknowledged' +-- envelope (the k-NN plugin returns a richer response than the typical +-- cluster-level ack). A 404 for a missing model id surfaces as an +-- 'EsError' under 'StatusDependant', matching 'getKnnModel' and the ML +-- Commons 'deleteModel' precedent. +-- +-- For more information see +-- . +deleteKnnModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse KnnDeleteModelResponse) +deleteKnnModel modelId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_knn", "models", unModelId modelId] + +-- | 'searchKnnModels' searches the @.opensearch-knn-models@ system index +-- via @POST /_plugins/_knn/models/_search@ (k-NN plugin Search Models +-- API, introduced in OpenSearch 1.2). The caller drives the query +-- entirely through the standard bloodhound 'Search' DSL — pagination +-- (@from@\/@size@), filtering, sorting, and @_source@ projection (use +-- 'source' to exclude the large 'knnModelModelBlob', mirroring the docs' +-- @_source_excludes=model_blob@ example). +-- +-- The response is the standard OpenSearch search envelope, decoded as +-- 'SearchResult' whose hits carry a 'KnnModel' in each @_source@. The +-- 'KnnModel' parser tolerates any field except @model_id@ being absent, +-- so a blob-excluding @_source@ projection decodes cleanly. +-- +-- Surfaced as 'StatusDependant' so a non-2xx response is parsed as an +-- 'EsError' and thrown by 'performBHRequest' — matching the vanilla +-- search envelope rather than 'getKnnModel' and 'deleteKnnModel', which +-- capture the error as a value via 'ParsedEsResponse'. +-- +-- For more information see +-- . +searchKnnModels :: + Search -> + BHRequest StatusDependant (SearchResult KnnModel) +searchKnnModels search = + post @StatusDependant endpoint (encode search) + where + endpoint = mkEndpoint ["_plugins", "_knn", "models", "_search"] + +-- ========================================================================= +-- Async Search plugin +-- ========================================================================= + +-- | 'submitOSAsyncSearch' submits a 'Search' for asynchronous execution via +-- the OpenSearch async search plugin (@POST /_plugins/_asynchronous_search@). It +-- returns immediately with an id and partial results; poll the returned id +-- with 'getOSAsyncSearch' until 'asyncSearchIsRunning' is @False@. +-- +-- The OpenSearch async search response is shaped exactly like Elasticsearch's +-- (the plugin was forked from ES 7.7's async search), so the result is decoded +-- into the shared 'AsyncSearchResult' — no OpenSearch-specific type is needed. +-- +-- Equivalent to @'submitOSAsyncSearchWith' 'defaultAsyncSearchSubmitOptions'@ +-- — it forwards no URI parameters. +-- +-- For more information see +-- . +submitOSAsyncSearch :: + (FromJSON a) => + Search -> + BHRequest StatusDependant (AsyncSearchResult a) +submitOSAsyncSearch = submitOSAsyncSearchWith defaultAsyncSearchSubmitOptions + +-- | Like 'submitOSAsyncSearch' but accepts 'AsyncSearchSubmitOptions' +-- carrying the URI parameters documented for +-- @POST /_plugins/_asynchronous_search@. OpenSearch documents only the +-- @wait_for_completion@, @keep_on_completion@ and @keep_alive@ parameters; +-- the Elasticsearch-only 'assoBatchedReduceSize' and +-- 'assoCcsMinimizeRoundtrips' are silently dropped by the underlying +-- 'osAsyncSearchSubmitOptionsParams' renderer. 'defaultAsyncSearchSubmitOptions' +-- makes this byte-for-byte equivalent to 'submitOSAsyncSearch'. +-- +-- For more information see +-- . +submitOSAsyncSearchWith :: + (FromJSON a) => + AsyncSearchSubmitOptions -> + Search -> + BHRequest StatusDependant (AsyncSearchResult a) +submitOSAsyncSearchWith opts search = + post + (mkEndpoint ["_plugins", "_asynchronous_search"] `withQueries` osAsyncSearchSubmitOptionsParams opts) + (encode search) + +-- | 'getOSAsyncSearch' retrieves the current state and (partial or final) +-- results of an OpenSearch async search by id +-- (@GET /_plugins/_asynchronous_search/{id}@). +-- +-- For more information see +-- . +getOSAsyncSearch :: + (FromJSON a) => + AsyncSearchId -> + BHRequest StatusDependant (AsyncSearchResult a) +getOSAsyncSearch (AsyncSearchId searchId) = + get (mkEndpoint ["_plugins", "_asynchronous_search", searchId]) + +-- | 'deleteOSAsyncSearch' deletes an OpenSearch async search result and its +-- context by id (@DELETE /_plugins/_asynchronous_search/{id}@) and returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteOSAsyncSearch :: + AsyncSearchId -> + BHRequest StatusIndependant Acknowledged +deleteOSAsyncSearch (AsyncSearchId searchId) = + delete (mkEndpoint ["_plugins", "_asynchronous_search", searchId]) + +-- | 'getOSAsyncSearchStats' fetches cluster-wide async-search statistics +-- via @GET /_plugins/_asynchronous_search/stats@. Returns per-node +-- counters for the nine documented async-search lifecycle events. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getOSAsyncSearchStats :: + BHRequest StatusDependant AsyncSearchStatsResponse +getOSAsyncSearchStats = + get (mkEndpoint ["_plugins", "_asynchronous_search", "stats"]) + +-- | 'getMLTask' calls the ML Commons plugin Get Task API +-- (@GET /_plugins/_ml/tasks/{task_id}@). The plugin returns the current state +-- of a single asynchronous task created by @POST /_plugins/_ml/models/_register@, +-- @POST /_plugins/_ml/models/{id}/_deploy@, training, and friends. Callers +-- poll this endpoint with the @task_id@ returned by the submit call until +-- 'mlTaskInfoState' reaches 'MLTaskStateCompleted' or 'MLTaskStateFailed'. +-- +-- For more information see +-- . +getMLTask :: + MLTaskId -> + BHRequest StatusDependant (ParsedEsResponse MLTaskInfo) +getMLTask mlTaskId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "tasks", unMLTaskId mlTaskId] + +-- ========================================================================= +-- SQL & PPL plugin +-- ========================================================================= + +-- | 'sqlQuery' calls the SQL plugin Query API +-- (@POST /_plugins/_sql@). Executes a SQL query against the cluster and +-- returns a JDBC-style rowset ('SQLResult'). Pagination is opt-in: pass a +-- positive 'sqlRequestFetchSize' to receive a 'SQLResult' carrying a +-- 'sqlResultCursor' and then use 'sqlQueryNextPage' to walk subsequent +-- pages. Release an unfinished cursor with 'closeSqlCursor' to free the +-- server-side context. +-- +-- Surfaced as 'StatusDependant' so a 4xx error (bad SQL, missing index) +-- decodes as 'EsError' rather than throwing. +-- +-- For more information see +-- . +sqlQuery :: + SQLRequest -> + BHRequest StatusDependant (ParsedEsResponse SQLResult) +sqlQuery req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_sql"] + +-- | 'sqlQueryNextPage' fetches the next page of a paginated SQL result by +-- POSTing a cursor body (@{"cursor": ...}@) to @/_plugins/_sql@. Use the +-- 'sqlResultCursor' returned by the previous 'sqlQuery' or +-- 'sqlQueryNextPage' call. Continuation responses carry only 'sqlResultDatarows' +-- and a new 'sqlResultCursor'; @schema@, @total@, @size@ and @status@ are +-- dropped by the server, so every other 'SQLResult' field is 'Maybe'. +-- +-- When the response no longer carries a 'sqlResultCursor' the last page has +-- been consumed and the server-side context is released automatically; no +-- 'closeSqlCursor' call is needed in that case. +-- +-- For more information see +-- . +sqlQueryNextPage :: + SQLCursor -> + BHRequest StatusDependant (ParsedEsResponse SQLResult) +sqlQueryNextPage cursor = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (SQLCursorRequest cursor)) + where + endpoint = mkEndpoint ["_plugins", "_sql"] + +-- | 'closeSqlCursor' releases the server-side context held by a SQL +-- pagination cursor (@POST /_plugins/_sql/close@). Call this to free the +-- context when you stop reading before the cursor is naturally exhausted +-- (i.e. before 'sqlResultCursor' disappears from a 'sqlQueryNextPage' +-- response). Closing an already-released cursor is a no-op server-side. +-- +-- For more information see +-- . +closeSqlCursor :: + SQLCursor -> + BHRequest StatusDependant (ParsedEsResponse SQLCloseResult) +closeSqlCursor cursor = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (SQLCursorRequest cursor)) + where + endpoint = mkEndpoint ["_plugins", "_sql", "close"] + +-- | 'explainSQL' calls the SQL plugin Explain API +-- (@POST /_plugins/_sql/_explain@). Translates a SQL query into the underlying +-- Elasticsearch query DSL without executing it. The request body is the same +-- 'SQLRequest' shape accepted by 'sqlQuery'. The response is a free-form JSON +-- object whose structure tracks the translated DSL (and varies by query and +-- plugin version), so it is returned as an opaque aeson 'Value'. +-- +-- Surfaced as 'StatusDependant' so a 4xx error (bad SQL, missing index) +-- decodes as 'EsError' rather than throwing. +-- +-- For more information see +-- . +explainSQL :: + SQLRequest -> + BHRequest StatusDependant (ParsedEsResponse Value) +explainSQL req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_sql", "_explain"] + +-- | 'pplQuery' calls the PPL plugin Query API +-- (@POST /_plugins/_ppl@). Executes a PPL (Piped Processing Language) query +-- against the cluster and returns the same JDBC-style rowset shape as +-- 'sqlQuery' (typed here as 'PPLResult', an alias of 'SQLResult'). PPL does +-- not support cursor pagination (the plugin documents 'fetch_size' as +-- SQL-only), so 'sqlResultCursor' will always be 'Nothing' on a PPL +-- response. +-- +-- Surfaced as 'StatusDependant' so a 4xx error decodes as 'EsError'. +-- +-- For more information see +-- . +pplQuery :: + PPLRequest -> + BHRequest StatusDependant (ParsedEsResponse PPLResult) +pplQuery req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ppl"] + +-- | 'explainPPL' calls the PPL plugin Explain API +-- (@POST /_plugins/_ppl/_explain@). Translates a PPL query into the underlying +-- Elasticsearch query DSL without executing it. The request body is the same +-- 'PPLRequest' shape accepted by 'pplQuery'. The response is a free-form JSON +-- object whose structure tracks the translated DSL (and varies by query and +-- plugin version), so it is returned as an opaque aeson 'Value'. +-- +-- Surfaced as 'StatusDependant' so a 4xx error decodes as 'EsError'. +-- +-- For more information see +-- . +explainPPL :: + PPLRequest -> + BHRequest StatusDependant (ParsedEsResponse Value) +explainPPL req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ppl", "_explain"] + +-- | 'getSQLStats' calls the SQL plugin Stats API +-- (@GET /_plugins/_sql/stats@). Returns node-level plugin metrics as a flat +-- 'SQLPluginStats' map (cluster-level stats are not implemented by the +-- plugin; the response describes only the node you hit). The metric-name +-- set is large and grows across OpenSearch releases (eight keys on 1.x; +-- @ppl_*@, @datasource_*@, @async_query_*@, @emr_*@ and @streaming_*@ +-- keys land later), so the body is decoded as 'Data.Aeson.Value' entries +-- keyed by metric name. +-- +-- Surfaced as 'StatusDependant' so a 404 (SQL plugin not installed) +-- decodes as 'EsError' rather than throwing. +-- +-- For more information see +-- . +getSQLStats :: + BHRequest StatusDependant (ParsedEsResponse SQLPluginStats) +getSQLStats = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_sql", "stats"] + +-- ========================================================================= +-- Alerting plugin +-- ========================================================================= + +-- | 'createMonitor' creates an alerting monitor via the Alerting plugin +-- (@POST /_plugins/_alerting/monitors@). The body is the encoded +-- 'Monitor'; the response is the 'MonitorResponse' wrapper carrying the +-- server-assigned @_id@, @_version@, @_seq_no@, @_primary_term@, and the +-- persisted monitor document. +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (invalid monitor body, +-- plugin not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +createMonitor :: + Monitor -> + BHRequest StatusDependant MonitorResponse +createMonitor monitor = + post (mkEndpoint ["_plugins", "_alerting", "monitors"]) (encode monitor) + +-- | 'getMonitor' fetches a single monitor by id via +-- @GET /_plugins/_alerting/monitors/{monitor_id}@. The endpoint returns +-- the 'MonitorResponse' wrapper on the wire +-- (@{_id,_version,_seq_no,_primary_term, monitor:{...}}@); the wrapper +-- is decoded and the 'Monitor' is projected out so the public type +-- matches the bead acceptance (@m 'Monitor'@). Callers needing the +-- indexing metadata can build the underlying request directly. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing monitor id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getMonitor :: + MonitorId -> + BHRequest StatusDependant Monitor +getMonitor (MonitorId mid) = + monitorResponseMonitor <$> get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_alerting", "monitors", mid] + +-- | 'updateMonitor' replaces a monitor via +-- @PUT /_plugins/_alerting/monitors/{monitor_id}@. The body is the +-- encoded 'Monitor'; the response is the same 'MonitorResponse' wrapper +-- as 'createMonitor' (with the incremented @_version@ and @_seq_no@). +-- Equivalent to 'updateMonitorWith' with 'Nothing' (no +-- optimistic-concurrency guard), so concurrent updates to the same +-- monitor id silently clobber each other. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing monitor id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateMonitor :: + MonitorId -> + Monitor -> + BHRequest StatusDependant MonitorResponse +updateMonitor monitorId monitor = updateMonitorWith monitorId monitor Nothing + +-- | 'updateMonitorWith' replaces a monitor via +-- @PUT /_plugins/_alerting/monitors/{monitor_id}@ with an optional +-- optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ — +-- both values read from a prior 'MonitorResponse' — to make the PUT +-- conditional on the monitor being unchanged since you last read it; a +-- stale pair causes OpenSearch to respond with HTTP 409 instead of +-- silently overwriting. Pass 'Nothing' for the unconditional semantics +-- of 'updateMonitor'. The two values must be supplied together: +-- OpenSearch rejects a partial pair with HTTP 400 (mirroring the +-- document-write @if_seq_no@ \/ @if_primary_term@ semantics). Mirrors +-- the 'putISMPolicyWith' precedent. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing monitor id (or a +-- 409 on a sequence-number mismatch) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +updateMonitorWith :: + MonitorId -> + Monitor -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant MonitorResponse +updateMonitorWith (MonitorId mid) monitor mOcc = + put @StatusDependant endpoint (encode monitor) + where + baseEndpoint = mkEndpoint ["_plugins", "_alerting", "monitors", mid] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries baseEndpoint $ + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'deleteMonitor' deletes a monitor by id via +-- @DELETE /_plugins/_alerting/monitors/{monitor_id}@. +-- +-- The return type 'DeleteMonitorResponse' deviates from the bead's +-- @m 'Acknowledged'@ acceptance: the body never carries an +-- @acknowledged@ key, so an 'Acknowledged' decoder would raise +-- 'EsProtocolException' at runtime (same deviation pattern as +-- bloodhound-04f.3.13 rethrottle). The exact shape is version-dependent +-- and live-verified on OS 1.3.19, 2.19.5 and 3.7.0 (bead +-- bloodhound-z5j): OS 1.3.x returns the full bare Elasticsearch +-- delete-document response; OS 2.x/3.x return only @_id@ + @_version@. +-- See the Haddock on 'DeleteMonitorResponse' for the field-level detail. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing monitor id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteMonitor :: + MonitorId -> + BHRequest StatusDependant DeleteMonitorResponse +deleteMonitor (MonitorId mid) = + delete (mkEndpoint ["_plugins", "_alerting", "monitors", mid]) + +-- | 'searchMonitors' searches the monitor store via +-- @GET /_plugins/_alerting/monitors/_search@. Pass 'Nothing' for the +-- plain empty-body @{}@ request that returns the first page of all +-- monitors; pass @'Just' query@ to paginate (@from@\/@size@) or filter +-- by name, type, enabled state, ... using the standard OpenSearch +-- query DSL carried opaquely in 'monitorsSearchQueryQuery'. +-- +-- The endpoint is documented as GET but, like the core search API, +-- carries the query DSL in the request body; 'getWithBody' sends a +-- GET with a body (mirrors the @GET /_render/template@ precedent). +-- +-- Returns the full search envelope 'SearchMonitorsResponse' so callers +-- can drive pagination and inspect @_shards@ health; use +-- 'searchMonitorsResponseMonitors' to project out just the @['Monitor']@ +-- list. Mirrors the Security Analytics 'searchSAPrePackagedRules' +-- precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchMonitors :: + Maybe MonitorsSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SearchMonitorsResponse) +searchMonitors mQuery = + withBHResponseParsedEsResponse $ + getWithBody @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_alerting", "monitors", "_search"] + body = encode (maybe defaultMonitorsSearchQuery id mQuery) + +-- | 'executeMonitor' runs a monitor's inputs and triggers immediately +-- (out of schedule) via +-- @POST /_plugins/_alerting/monitors/{monitor_id}/_execute@. The +-- endpoint takes no request body; a dry run (which exercises the +-- triggers without dispatching actions to destinations) is requested +-- with the @?dryrun=true@ query parameter, so pass @'Just' +-- ('ExecuteMonitorRequest' {dryrun = Just True})@ to set it. Pass +-- 'Nothing' for a real execution with action dispatch. +-- +-- Returns 'ExecuteMonitorResponse' (typed shell + opaque aeson +-- 'Value's for the per-kind @trigger_results@ \/ @input_results@ \/ +-- @script_actions@ sub-objects). Mirrors the ML Commons @predict@ +-- pragmatic-typing precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid monitor id, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +executeMonitor :: + MonitorId -> + Maybe ExecuteMonitorRequest -> + BHRequest StatusDependant (ParsedEsResponse ExecuteMonitorResponse) +executeMonitor (MonitorId mid) mRequest = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_alerting", "monitors", mid, "_execute"] + `withQueries` dryrunQuery + dryrunQuery = + case mRequest >>= executeMonitorRequestDryrun of + Just True -> [("dryrun", Just "true")] + _ -> [] + +-- | 'getDestinations' lists every configured alerting destination via +-- @GET /_plugins/_alerting/destinations@. The endpoint returns a +-- paging envelope (@{totalDestinations, destinations}@); this wrapper +-- projects out the bare 'Destination' list so the public type matches +-- the bead acceptance (@m [Destination]@). Equivalent to +-- 'getDestinationsWith' with 'defaultDestinationListOptions' (server +-- defaults: @size=20@, @start_index=0@, +-- @sortString=destination.name.keyword@, @sortOrder=asc@). Callers +-- needing paging metadata (@totalDestinations@) or custom filtering +-- should use 'getDestinationsWith'. +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (plugin not installed, +-- RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getDestinations :: + BHRequest StatusDependant [Destination] +getDestinations = + getDestinationsResponseDestinations + <$> getDestinationsWith defaultDestinationListOptions + +-- | 'getDestinationsWith' is the parameterized variant of +-- 'getDestinations': the supplied 'DestinationListOptions' are +-- forwarded as query-string parameters (filtering by +-- 'DestinationListOptions''s @destinationType@, pagination via +-- @size@ \/ @start_index@, sort via @sortString@ \/ @sortOrder@ \/ +-- @missing@, and free-text @searchString@). Pass +-- 'defaultDestinationListOptions' for the plain no-arg GET. Returns +-- the full 'GetDestinationsResponse' envelope so callers can read +-- @totalDestinations@ (the total hit count, which differs from the +-- page size when @size@ truncates the result). +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (plugin not installed, +-- RBAC denial, or the documented HTTP 405 when multi-tenancy is +-- enabled) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getDestinationsWith :: + DestinationListOptions -> + BHRequest StatusDependant GetDestinationsResponse +getDestinationsWith opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_alerting", "destinations"] + `withQueries` destinationListOptionsParams opts + +-- | The Alerting server assigns @id@, @schema_version@, @seq_no@, and +-- @primary_term@ when a destination is first written, so the documented +-- 'createDestination' request body omits them (a caller-supplied @id@ +-- is ignored; @seq_no@\/@primary_term@ are meaningless on a create). +-- This drops those keys from the encoded 'Destination' so the create +-- body matches the documented shape. It is local to the create path: +-- 'updateDestination' and the 'Destination' round-trip keep the full +-- document (server-assigned fields and all). +stripDestinationCreateKeys :: Value -> Value +stripDestinationCreateKeys (Object o) = + Object (deleteSeveral ["id", "schema_version", "seq_no", "primary_term"] o) +stripDestinationCreateKeys v = v + +-- | 'createDestination' creates an alerting destination via the +-- Alerting plugin (@POST /_plugins/_alerting/destinations@). The body +-- is the encoded 'Destination' with the server-assigned @id@, +-- @schema_version@, @seq_no@, and @primary_term@ stripped +-- ('stripDestinationCreateKeys') so it matches the documented +-- create-request shape; the response is the 'DestinationResponse' +-- wrapper carrying the server-assigned indexing metadata and the +-- persisted destination document. +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (invalid destination +-- body, plugin not installed, RBAC denial) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +createDestination :: + Destination -> + BHRequest StatusDependant DestinationResponse +createDestination destination = + post (mkEndpoint ["_plugins", "_alerting", "destinations"]) body + where + body = encode (stripDestinationCreateKeys (toJSON destination)) + +-- | 'updateDestination' replaces a destination via +-- @PUT /_plugins/_alerting/destinations/{destination_id}@. The body is +-- the encoded 'Destination'; the response is the same +-- 'DestinationResponse' wrapper as 'createDestination' (with the +-- incremented @_version@ and @_seq_no@). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing destination id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateDestination :: + DestinationId -> + Destination -> + BHRequest StatusDependant DestinationResponse +updateDestination (DestinationId did) destination = + put (mkEndpoint ["_plugins", "_alerting", "destinations", did]) (encode destination) + +-- | 'deleteDestination' deletes a destination by id via +-- @DELETE /_plugins/_alerting/destinations/{destination_id}@. +-- +-- The return type 'DeleteDestinationResponse' deviates from a naive +-- @m 'Acknowledged'@ acceptance for the same reason as 'deleteMonitor': +-- the OpenSearch alerting delete endpoint returns the standard +-- Elasticsearch delete-document response (bare, with a @_shards@ +-- report, NO @acknowledged@ key), so an 'Acknowledged' decoder would +-- raise 'EsProtocolException' at runtime. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing destination id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteDestination :: + DestinationId -> + BHRequest StatusDependant DeleteDestinationResponse +deleteDestination (DestinationId did) = + delete (mkEndpoint ["_plugins", "_alerting", "destinations", did]) + +-- ========================================================================= +-- Alerting plugin: alerts, acknowledge, stats, email accounts/groups +-- ========================================================================= + +-- | 'getAlertsWith' lists alert documents via +-- @GET /_plugins/_alerting/monitors/alerts@, forwarding the supplied +-- 'GetAlertsOptions' as query-string parameters (filtering by +-- @alertState@ \/ @severityLevel@ \/ @monitorId@, pagination via +-- @size@ \/ @startIndex@, sort via @sortString@ \/ @sortOrder@ \/ +-- @missing@, free-text @searchString@, and @workflowIds@ for chained +-- alerts on OpenSearch 2.9+). Pass 'defaultGetAlertsOptions' for the +-- plain no-arg GET. Returns the full 'GetAlertsResponse' envelope so +-- callers can read @totalAlerts@ (the total hit count, which differs +-- from the page size when @size@ truncates the result). Mirrors the +-- 'getDestinationsWith' precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getAlertsWith :: + GetAlertsOptions -> + BHRequest StatusDependant GetAlertsResponse +getAlertsWith opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_alerting", "monitors", "alerts"] + `withQueries` getAlertsOptionsParams opts + +-- | 'getAlerts' lists every active alert. Equivalent to 'getAlertsWith' +-- with 'defaultGetAlertsOptions' (server defaults apply) and projects +-- out the bare @['Alert']@ list (the paging envelope is discarded). +-- Callers needing @totalAlerts@ or custom filtering should use +-- 'getAlertsWith'. Mirrors the 'getDestinations' precedent. +getAlerts :: + BHRequest StatusDependant [Alert] +getAlerts = + getAlertsResponseAlerts <$> getAlertsWith defaultGetAlertsOptions + +-- | 'acknowledgeAlert' acknowledges one or more active alerts of a +-- monitor via +-- @POST /_plugins/_alerting/monitors/{monitor_id}/_acknowledge/alerts@. +-- Alerts already in an @ERROR@, @COMPLETED@, or @ACKNOWLEDGED@ state are +-- not transitioned and are echoed in the @failed@ array of the +-- 'AcknowledgeAlertResponse'. The request body is the encoded +-- 'AcknowledgeAlertRequest' (@{"alerts":[ids]}@). +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid monitor id, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +acknowledgeAlert :: + MonitorId -> + [Text] -> + BHRequest StatusDependant AcknowledgeAlertResponse +acknowledgeAlert (MonitorId mid) alertIds = + post + (mkEndpoint ["_plugins", "_alerting", "monitors", mid, "_acknowledge", "alerts"]) + (encode (AcknowledgeAlertRequest alertIds)) + +-- | 'getMonitorStats' fetches alerting scheduler statistics via +-- @GET /_plugins/_alerting/stats[/...]@. The four documented forms are +-- selected by the two optional arguments: +-- +-- * @Nothing Nothing@ — @GET /_plugins/_alerting/stats@ (cluster-wide) +-- * @'Nothing' metric@ — @GET /_plugins/_alerting/stats/{metric}@ +-- * @nodeId 'Nothing'@ — @GET /_plugins/_alerting/{node-id}/stats@ +-- * @nodeId metric@ — @GET /_plugins/_alerting/{node-id}/stats/{metric}@ +-- +-- The response is large and partly node-specific; the stable shell is +-- decoded into 'MonitorStats' and the variable @nodes@ map is kept as +-- an opaque aeson 'Value' (see 'monitorStatsOther'). Mirrors the +-- 'getSQLStats' pragmatic-typing precedent. +-- +-- Surfaced as 'StatusDependant' so a 404 (Alerting plugin disabled +-- \/ unknown metric \/ unknown node id) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +getMonitorStats :: + Maybe Text -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse MonitorStats) +getMonitorStats mNodeId mMetric = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = case mNodeId of + Nothing -> + case mMetric of + Nothing -> mkEndpoint ["_plugins", "_alerting", "stats"] + Just metric -> mkEndpoint ["_plugins", "_alerting", "stats", metric] + Just nodeId -> + case mMetric of + Nothing -> mkEndpoint ["_plugins", "_alerting", nodeId, "stats"] + Just metric -> mkEndpoint ["_plugins", "_alerting", nodeId, "stats", metric] + +-- | 'createEmailAccount' creates a legacy alerting email account via +-- @POST /_plugins/_alerting/destinations/email_accounts@. The body is +-- the encoded 'EmailAccount' (the server assigns @_id@, @_version@, +-- @_seq_no@, @_primary_term@, and @schema_version@ on write); the +-- response is the 'EmailAccountResponse' wrapper. Mirrors +-- 'createDestination'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createEmailAccount :: + EmailAccount -> + BHRequest StatusDependant EmailAccountResponse +createEmailAccount account = + post (mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts"]) (encode account) + +-- | 'getEmailAccount' fetches a single email account by id via +-- @GET /_plugins/_alerting/destinations/email_accounts/{id}@. The +-- endpoint returns the 'EmailAccountResponse' wrapper on the wire +-- (@{_id,_version,_seq_no,_primary_term, email_account:{...}}@); the +-- wrapper is decoded and the 'EmailAccount' is projected out so the +-- public type matches the 'getMonitor' precedent. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing id decodes as +-- an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getEmailAccount :: + EmailAccountId -> + BHRequest StatusDependant EmailAccount +getEmailAccount (EmailAccountId eid) = + emailAccountResponseEmailAccount <$> get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts", eid] + +-- | 'updateEmailAccount' replaces an email account via +-- @PUT /_plugins/_alerting/destinations/email_accounts/{id}@. +-- Equivalent to 'updateEmailAccountWith' with 'Nothing' (no +-- optimistic-concurrency guard). Mirrors 'updateDestination'. +-- +-- For more information see +-- . +updateEmailAccount :: + EmailAccountId -> + EmailAccount -> + BHRequest StatusDependant EmailAccountResponse +updateEmailAccount emailAccountId account = + updateEmailAccountWith emailAccountId account Nothing + +-- | 'updateEmailAccountWith' replaces an email account with an optional +-- optimistic-concurrency guard (@if_seq_no@ \/ @if_primary_term@). See +-- 'updateMonitorWith' for the guard semantics. Mirrors the +-- 'updateMonitorWith' precedent. +-- +-- Surfaced as 'StatusDependant' so a 404 (or a 409 on a sequence-number +-- mismatch) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateEmailAccountWith :: + EmailAccountId -> + EmailAccount -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant EmailAccountResponse +updateEmailAccountWith (EmailAccountId eid) account mOcc = + put @StatusDependant endpoint (encode account) + where + baseEndpoint = + mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts", eid] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries + baseEndpoint + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'deleteEmailAccount' deletes an email account by id via +-- @DELETE /_plugins/_alerting/destinations/email_accounts/{id}@. Returns +-- the bare Elasticsearch delete-document response (see +-- 'DeleteEmailAccountResponse' for why this deviates from +-- @m 'Acknowledged'@). Mirrors 'deleteDestination'. +-- +-- For more information see +-- . +deleteEmailAccount :: + EmailAccountId -> + BHRequest StatusDependant DeleteEmailAccountResponse +deleteEmailAccount (EmailAccountId eid) = + delete (mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts", eid]) + +-- | 'createEmailGroup' creates a legacy alerting email group via +-- @POST /_plugins/_alerting/destinations/email_groups@. Mirrors +-- 'createEmailAccount'. +-- +-- For more information see +-- . +createEmailGroup :: + EmailGroup -> + BHRequest StatusDependant EmailGroupResponse +createEmailGroup group = + post (mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups"]) (encode group) + +-- | 'getEmailGroup' fetches a single email group by id via +-- @GET /_plugins/_alerting/destinations/email_groups/{id}@, projecting +-- out the 'EmailGroup'. Mirrors 'getEmailAccount'. +-- +-- For more information see +-- . +getEmailGroup :: + EmailGroupId -> + BHRequest StatusDependant EmailGroup +getEmailGroup (EmailGroupId gid) = + emailGroupResponseEmailGroup <$> get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups", gid] + +-- | 'updateEmailGroup' replaces an email group. Equivalent to +-- 'updateEmailGroupWith' with 'Nothing'. Mirrors 'updateEmailAccount'. +-- +-- For more information see +-- . +updateEmailGroup :: + EmailGroupId -> + EmailGroup -> + BHRequest StatusDependant EmailGroupResponse +updateEmailGroup emailGroupId group = + updateEmailGroupWith emailGroupId group Nothing + +-- | 'updateEmailGroupWith' replaces an email group with an optional +-- optimistic-concurrency guard. Mirrors 'updateEmailAccountWith'. +-- +-- For more information see +-- . +updateEmailGroupWith :: + EmailGroupId -> + EmailGroup -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant EmailGroupResponse +updateEmailGroupWith (EmailGroupId gid) group mOcc = + put @StatusDependant endpoint (encode group) + where + baseEndpoint = + mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups", gid] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries + baseEndpoint + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'deleteEmailGroup' deletes an email group by id via +-- @DELETE /_plugins/_alerting/destinations/email_groups/{id}@. Mirrors +-- 'deleteEmailAccount'. +-- +-- For more information see +-- . +deleteEmailGroup :: + EmailGroupId -> + BHRequest StatusDependant DeleteEmailGroupResponse +deleteEmailGroup (EmailGroupId gid) = + delete (mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups", gid]) + +-- | 'getDestination' fetches a single destination by id via +-- @GET /_plugins/_alerting/destinations/{id}@. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getDestination' for details. +getDestination :: + DestinationId -> + BHRequest StatusDependant GetDestinationsResponse +getDestination (DestinationId did) = + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", did] + +-- | 'searchEmailAccounts' searches the email account store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchEmailAccounts'. +searchEmailAccounts :: + Maybe EmailAccountSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SearchEmailAccountsResponse) +searchEmailAccounts mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts", "_search"] + body = encode (maybe defaultEmailAccountSearchQuery id mQuery) + +-- | 'searchEmailGroups' searches the email group store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchEmailGroups'. +searchEmailGroups :: + Maybe EmailGroupSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SearchEmailGroupsResponse) +searchEmailGroups mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups", "_search"] + body = encode (maybe defaultEmailGroupSearchQuery id mQuery) + +-- ========================================================================= +-- Anomaly Detection plugin +-- ========================================================================= + +-- | 'createDetector' calls the Anomaly Detection plugin Create Detector API +-- (@POST /_plugins/_anomaly_detection/detectors@). Persists a new +-- detector (single-entity or, when @category_field@ is set, +-- high-cardinality multi-entity) to the +-- @.opendistro-anomaly-detection-state@ system index and returns the +-- standard document-write envelope (@_id@, @_version@, @_primary_term@, +-- @_seq_no@) wrapping the persisted detector under @anomaly_detector@. +-- +-- The target index must already contain at least one document, otherwise +-- the plugin rejects the request with HTTP 400 (@Can't create anomaly +-- detector as no document is found in the indices: [...]@). Surfaced as +-- 'StatusDependant' so that 400 (and a 404 for the plugin-not-installed +-- case) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createDetector :: + Detector -> + BHRequest StatusDependant (ParsedEsResponse CreateDetectorResponse) +createDetector detector = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode detector) + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors"] + +-- | 'getDetector' calls the Anomaly Detection plugin Get Detector API +-- (@GET /_plugins/_anomaly_detection/detectors/{detector_id}@). Returns +-- the full detector record — the same shape 'createDetector' returns — +-- plus, when the corresponding 'GetDetectorParams' flag is set, the +-- real-time job (@?job=true@) and/or the running task records +-- (@?task=true@) embedded as siblings of @anomaly_detector@. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @detector_id@ or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getDetector :: + DetectorId -> + GetDetectorParams -> + BHRequest StatusDependant (ParsedEsResponse GetDetectorResponse) +getDetector detectorId params = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId] + endpoint = withQueries baseEndpoint (getDetectorParamsPairs params) + +-- | Renders the 'GetDetectorParams' flags as the @?job@ \/ @?task@ query +-- pairs the plugin expects. A 'False' flag contributes no pair, so the +-- default ('defaultGetDetectorParams') produces a bare GET. Uses '(<>)' +-- rather than @concat [..]@ because OS2\/OS3 Requests enable +-- @OverloadedLists@, which would otherwise leave the outer list literal +-- passed to 'concat' (which is @Foldable@-polymorphic) ambiguous. +getDetectorParamsPairs :: GetDetectorParams -> [(Text, Maybe Text)] +getDetectorParamsPairs params = + [("job", Just "true") | getDetectorParamsJob params] + <> [("task", Just "true") | getDetectorParamsTask params] + +-- | 'previewDetector' calls the Anomaly Detection plugin Preview Detector +-- API (@POST /_plugins/_anomaly_detection/detectors/_preview@). Runs the +-- detector's feature aggregations and RCF model over the historical +-- window bounded by 'previewRequestPeriodStart' / +-- 'previewRequestPeriodEnd' (epoch milliseconds) and returns the +-- resulting anomaly grades alongside a snapshot of the detector. No +-- state is persisted. +-- +-- The 'DetectorId' is sent in the request body (@detector_id@) rather +-- than the URL path, matching the documented canonical @_plugins@ form; +-- the path-param form is only documented under the legacy @_opendistro@ +-- prefix. The plugin requires both endpoints of the window; a missing +-- field surfaces as HTTP 400 with @Must set both period start and end +-- date with epoch of milliseconds@. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @detector_id@ or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +previewDetector :: + DetectorId -> + PreviewRequest -> + BHRequest StatusDependant (ParsedEsResponse PreviewResponse) +previewDetector detectorId req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = + mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "_preview"] + body = + encode $ + object + [ "detector_id" .= unDetectorId detectorId, + "period_start" .= previewRequestPeriodStart req, + "period_end" .= previewRequestPeriodEnd req + ] + +-- | 'previewDetectorInline' previews a detector whose identity is carried +-- entirely in the request body rather than as a separate 'DetectorId' +-- argument — the variant 'previewDetector' does not expose. Use it for an +-- unpersisted detector by setting 'previewRequestDetector' to the full +-- inline 'Detector' config, or to preview a persisted detector by +-- reference via 'previewRequestDetectorId'. The endpoint +-- (@POST /_plugins/_anomaly_detection/detectors/_preview@) and the rest +-- of the semantics match 'previewDetector'; no state is persisted. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown +-- 'previewRequestDetectorId' or plugin not installed) decodes as an +-- 'EsError' rather than throwing. +-- +-- For more information see +-- . +previewDetectorInline :: + PreviewRequest -> + BHRequest StatusDependant (ParsedEsResponse PreviewResponse) +previewDetectorInline req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "_preview"] + +-- | 'startDetector' starts an Anomaly Detection detector job via the +-- documented Start Detector Job API +-- (@POST /_plugins/_anomaly_detection/detectors/{detector_id}/_start@). +-- +-- Pass 'Nothing' to start the real-time detector job; pass @'Just' req@ +-- to kick off a one-shot historical backfill over the window bounded by +-- 'startDetectorJobRequestStartTime' / 'startDetectorJobRequestEndTime'. +-- The server returns a 'DetectorJobAcknowledgment' whose @_id@ is the +-- real-time job id (= the detector id) for the no-body form, or the +-- historical batch task id (a UUID) for the body form. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @detector_id@ or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +startDetector :: + DetectorId -> + Maybe StartDetectorJobRequest -> + BHRequest StatusDependant (ParsedEsResponse DetectorJobAcknowledgment) +startDetector detectorId mReq = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (maybe emptyBody encode mReq) + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId, "_start"] + +-- | 'stopDetector' stops an Anomaly Detection detector job via the +-- documented Stop Detector Job API +-- (@POST /_plugins/_anomaly_detection/detectors/{detector_id}/_stop@). +-- +-- Pass 'False' to stop the real-time detector job; pass 'True' to stop +-- the historical analysis, which adds the @?historical=true@ query +-- parameter. The server returns a 'DetectorJobAcknowledgment' with +-- zeroed @_version@ / @_seq_no@ / @_primary_term@ on success. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @detector_id@ or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +stopDetector :: + DetectorId -> + Bool -> + BHRequest StatusDependant (ParsedEsResponse DetectorJobAcknowledgment) +stopDetector detectorId historical = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint emptyBody + where + endpoint = + mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId, "_stop"] + `withQueries` [("historical", Just "true") | historical] + +-- | 'updateDetector' replaces a detector via +-- @PUT /_plugins/_anomaly_detection/detectors/{detector_id}@. The body +-- is the encoded 'Detector' (you cannot update @category_field@, and the +-- server requires both the real-time and historical jobs to be stopped +-- first); the response is the same 'CreateDetectorResponse' envelope as +-- 'createDetector' (with the incremented @_version@ / @_seq_no@). +-- Equivalent to 'updateDetectorWith' with 'Nothing' (no +-- optimistic-concurrency guard), so concurrent updates to the same +-- detector id silently clobber each other. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateDetector :: + DetectorId -> + Detector -> + BHRequest StatusDependant (ParsedEsResponse CreateDetectorResponse) +updateDetector detectorId detector = updateDetectorWith detectorId detector Nothing + +-- | 'updateDetectorWith' replaces a detector via +-- @PUT /_plugins/_anomaly_detection/detectors/{detector_id}@ with an +-- optional optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ +-- — both values read from a prior 'CreateDetectorResponse' — to make the +-- PUT conditional on the detector being unchanged since you last read it; +-- a stale pair causes OpenSearch to respond with HTTP 409 instead of +-- silently overwriting. Pass 'Nothing' for the unconditional semantics of +-- 'updateDetector'. The two values must be supplied together (mirroring +-- the 'updateMonitorWith' / 'putISMPolicyWith' precedent). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id (or a +-- 409 on a sequence-number mismatch) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +updateDetectorWith :: + DetectorId -> + Detector -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant (ParsedEsResponse CreateDetectorResponse) +updateDetectorWith detectorId detector mOcc = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode detector) + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries + baseEndpoint + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'deleteDetector' deletes a detector by id via +-- @DELETE /_plugins/_anomaly_detection/detectors/{detector_id}@. +-- +-- The return type 'DeleteDetectorResponse' deviates from an +-- @m 'Acknowledged'@ acceptance for the same reason as the Alerting +-- 'deleteMonitor' and Security Analytics 'deleteSADetector': the AD +-- delete endpoint returns the bare Elasticsearch delete-document response +-- (@_index@, @_id@, @_version@, @result@, @forced_refresh@, @_shards@, +-- @_seq_no@, @_primary_term@, NO @acknowledged@ key), so an +-- 'Acknowledged' decoder would raise 'EsProtocolException' at runtime. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteDetector :: + DetectorId -> + BHRequest StatusDependant (ParsedEsResponse DeleteDetectorResponse) +deleteDetector detectorId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId] + +-- | 'validateDetector' validates a detector configuration via +-- @POST /_plugins/_anomaly_detection/detectors/_validate[/mode]@. The +-- 'ValidateDetectorMode' argument selects the validation mode: +-- 'ValidateDetector' (the bare @\/_validate@ alias, which finds issues +-- that would block creation) or 'ValidateModel' (the @\/_validate\/model@ +-- advisory check that estimates the likelihood of successful model +-- training). The body is the encoded 'Detector'. The response is an +-- opaque 'ValidateDetectorResponse' (@{}@ on success; a @detector@ / +-- @model@ sub-object carrying the issues otherwise). +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid detector body, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +validateDetector :: + ValidateDetectorMode -> + Detector -> + BHRequest StatusDependant (ParsedEsResponse ValidateDetectorResponse) +validateDetector mode detector = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode detector) + where + endpoint = + mkEndpoint $ + ["_plugins", "_anomaly_detection", "detectors", "_validate"] + <> validateDetectorModeSegments mode + +-- | 'searchDetectors' searches the detector-config index via +-- @POST /_plugins/_anomaly_detection/detectors/_search@. Pass 'Nothing' +-- for the plain empty-body @{}@ POST that returns the first page of all +-- detectors; pass @'Just' query@ to paginate (@from@\/@size@) or filter +-- using the standard OpenSearch query DSL carried opaquely as a 'Value'. +-- +-- Returns the full 'SearchDetectorsResponse' search envelope so callers +-- can drive pagination and inspect @_shards@ health; use +-- 'anomalySearchResponseSources' to project out just the +-- @['DetectorResponse']@ list. Mirrors the Alerting 'searchMonitors' +-- precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchDetectors :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse SearchDetectorsResponse) +searchDetectors mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'profileDetector' profiles a detector via +-- @GET /_plugins/_anomaly_detection/detectors/{detector_id}/_profile[/{types}]@. +-- Pass the profile-kind segments to select (e.g. @["ad_task"]@, +-- @["total_size_in_bytes"]@, or multiple @["ad_task","models"]@ joined +-- comma-separated); pass @[]@ for the bare profile. Pass 'True' to add +-- the @?_all=true@ flag (every profile section — expensive for +-- high-cardinality detectors). +-- +-- For a multi-entity detector (one created with a @category_field@), +-- pass @'Just' entities@ to filter the profile to a specific categorical +-- slice. The plugin documents this as a GET with a request body +-- @{entity: [{name, value}]}@; 'Entity' is reused for both the request +-- filter and the 'AnomalyResult' response. Pass 'Nothing' for a bodyless +-- profile. +-- +-- The response shape varies widely by requested kind and detector kind; +-- it is surfaced as an opaque 'DetectorProfileResponse' so every variant +-- round-trips losslessly (pragmatic-typing precedent). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id (or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +profileDetector :: + DetectorId -> + [Text] -> + Bool -> + Maybe [Entity] -> + BHRequest StatusDependant (ParsedEsResponse DetectorProfileResponse) +profileDetector detectorId types allFlag mEntities = + withBHResponseParsedEsResponse $ + case mEntities of + Nothing -> get @StatusDependant endpoint + Just entities -> getWithBody @StatusDependant endpoint (encode (object ["entity" .= entities])) + where + baseEndpoint = + mkEndpoint $ + ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId, "_profile"] + <> (case types of [] -> []; xs -> [T.intercalate "," xs]) + endpoint = + if allFlag + then withQueries baseEndpoint [("_all", Just "true")] + else baseEndpoint + +-- | 'getDetectorStats' fetches plugin statistics via +-- @GET /_plugins/_anomaly_detection/stats@ (and its filtered forms). +-- The OpenSearch path convention is asymmetric: when filtering by node, +-- the path is @\/{node_id}\/stats@; when filtering by stat only, it is +-- @\/stats\/{stat}@; both filters combine as +-- @\/{node_id}\/stats\/{stat}@. Pass the node id first (or 'Nothing'), +-- then the stat name (or 'Nothing'). +-- +-- The full response carries several top-level index-status keys plus a +-- @nodes@ map; the filtered forms return a subset. It is surfaced as an +-- opaque 'DetectorStatsResponse' so the variable top-level surface +-- round-trips losslessly (pragmatic-typing precedent). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, unknown +-- node id) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getDetectorStats :: + Maybe Text -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse DetectorStatsResponse) +getDetectorStats mNodeId mStat = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection"] + withNode = case mNodeId of + Nothing -> baseEndpoint + Just nodeId -> mkEndpoint (getRawEndpoint baseEndpoint <> [nodeId]) + withStats = mkEndpoint (getRawEndpoint withNode <> ["stats"]) + endpoint = case mStat of + Nothing -> withStats + Just stat -> mkEndpoint (getRawEndpoint withStats <> [stat]) + +-- | 'searchDetectorResults' searches the anomaly-result index via +-- @POST /_plugins/_anomaly_detection/detectors/results/_search[/{custom_result_index}]@. +-- Pass a custom result-index name to search it alongside (or, with +-- @'Just' True@ for @only_query_custom_result_index@, instead of) the +-- default result index. Pass 'Nothing' for the query body to send the +-- plain empty-body @{}@ POST. +-- +-- Each hit's @_source@ is an anomaly-result record; the response is +-- surfaced as a 'SearchDetectorResultsResponse' with opaque 'Value' +-- sources (the full result schema carries many optional fields and lives +-- in a separate mapping page). +-- +-- Surfaced as 'StatusDependant' so a 4xx decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +searchDetectorResults :: + Maybe Text -> + Maybe Bool -> + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse SearchDetectorResultsResponse) +searchDetectorResults mCustomResultIndex mOnlyCustom mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "results", "_search"] + endpointWithCustom = case mCustomResultIndex of + Nothing -> baseEndpoint + Just idx -> mkEndpoint (getRawEndpoint baseEndpoint <> [idx]) + endpoint = case mOnlyCustom of + Nothing -> endpointWithCustom + Just b -> withQueries endpointWithCustom [("only_query_custom_result_index", Just (showText b))] + body = encode (maybe (object []) id mQuery) + +-- | 'deleteDetectorResults' deletes anomaly-result documents by query via +-- @DELETE /_plugins/_anomaly_detection/detectors/results@ (introduced in +-- OpenSearch 1.1). The body is a standard OpenSearch query-DSL object +-- (the same shape @deleteByQuery@ accepts) carrying the selection +-- predicate — typically a @bool@ filter on @detector_id@, @task_id@ and +-- a @data_start_time@ range, as shown in the plugin docs. The endpoint +-- only operates on the default result index; anomaly results stored in +-- a custom result index must be deleted manually (per the docs). +-- +-- The body is mandatory by design: an empty @{}@ would match every +-- anomaly-result document in the default index, so we make the caller +-- pass the selection explicitly rather than defaulting to @{}@ (the +-- 'searchDetectorResults' precedent defaults to @{}@ because a bare +-- search is harmless; a bare delete-by-query is not). Construct the +-- body with the usual aeson helpers, e.g. +-- +-- @ +-- 'object' ["query" .= 'object' ["bool" .= 'object' ["filter" .= [...] ]]] +-- @ +-- +-- The response is the bare @_delete_by_query@ envelope (reused as +-- 'DeleteDetectorResultsResponse', which aliases the document-API +-- 'DeletedDocuments' since the shape is identical — @took@, +-- @timed_out@, @total@, @deleted@, @batches@, @version_conflicts@, +-- @noops@, @retries@, @throttled_millis@, @requests_per_second@, +-- @throttled_until_millis@, @failures@). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +deleteDetectorResults :: + Value -> + BHRequest StatusDependant (ParsedEsResponse DeleteDetectorResultsResponse) +deleteDetectorResults query = + withBHResponseParsedEsResponse $ + deleteWithBody @StatusDependant endpoint (encode query) + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "results"] + +-- | 'searchDetectorTasks' searches the detection-state index via +-- @POST /_plugins/_anomaly_detection/detectors/tasks/_search@ — the +-- record store for real-time and historical task state. Pass 'Nothing' +-- for the plain empty-body @{}@ POST; pass @'Just' query@ to filter +-- (e.g. by @detector_id@, @task_type@, @is_latest@) using the standard +-- query DSL. +-- +-- Each hit's @_source@ is a task record; the response is surfaced as a +-- 'SearchDetectorTasksResponse' with opaque 'Value' sources. +-- +-- Surfaced as 'StatusDependant' so a 4xx decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +searchDetectorTasks :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse SearchDetectorTasksResponse) +searchDetectorTasks mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "tasks", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'topAnomalies' returns the top anomaly results for a +-- high-cardinality detector via +-- @GET /_plugins/_anomaly_detection/detectors/{detector_id}/results/_topAnomalies?historical={bool}@, +-- bucketed by category-field values. Pass 'True' for historical results, +-- 'False' for real-time. The 'TopAnomaliesRequest' body is sent with the +-- GET (it carries @start_time_ms@ / @end_time_ms@ which are required). +-- +-- The response is a 'TopAnomaliesResponse' whose @buckets@ each carry a +-- categorical @key@, a @doc_count@, and the @max_anomaly_grade@. +-- +-- Surfaced as 'StatusDependant' so a 4xx decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +topAnomalies :: + DetectorId -> + Bool -> + TopAnomaliesRequest -> + BHRequest StatusDependant (ParsedEsResponse TopAnomaliesResponse) +topAnomalies detectorId historical req = + withBHResponseParsedEsResponse $ + getWithBody @StatusDependant endpoint (encode req) + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId, "results", "_topAnomalies"] + endpoint = + if historical + then withQueries baseEndpoint [("historical", Just "true")] + else withQueries baseEndpoint [("historical", Just "false")] + +-- ---------------------------------------------------------------------------- +-- Index Rollups plugin +-- +-- ---------------------------------------------------------------------------- + +-- | 'createRollup' creates or replaces an index rollup job via +-- @PUT /_plugins/_rollup/jobs/{rollup_id}@. The 'Rollup' body is wrapped +-- in the @{"rollup": ...}@ envelope the endpoint expects. Equivalent to +-- 'createRollupWith' with 'Nothing' (no optimistic-concurrency guard), so +-- a concurrent update silently clobbers the prior job definition. +-- +-- Surfaced as 'StatusDependant' so a 4xx (malformed body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createRollup :: + RollupId -> + Rollup -> + BHRequest StatusDependant (ParsedEsResponse RollupResponse) +createRollup rollupId rollup = createRollupWith rollupId rollup Nothing + +-- | 'createRollupWith' creates or replaces an index rollup job via +-- @PUT /_plugins/_rollup/jobs/{rollup_id}@ with an optional +-- optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ — both +-- values read from a prior 'RollupResponse' — to make the PUT conditional +-- on the job being unchanged since you last read it; a stale pair causes +-- OpenSearch to respond with HTTP 409 instead of silently overwriting. +-- Pass 'Nothing' for the unconditional semantics of 'createRollup'. The +-- two values must be supplied together (mirroring the 'putISMPolicyWith' +-- precedent). +-- +-- Surfaced as 'StatusDependant' so a 4xx (or a 409 on a sequence-number +-- mismatch) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createRollupWith :: + RollupId -> + Rollup -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant (ParsedEsResponse RollupResponse) +createRollupWith rollupId rollup mOcc = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode (RollupWrapper rollup)) + where + baseEndpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries baseEndpoint $ + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- ========================================================================= +-- Index Transforms plugin +-- ========================================================================= + +-- | 'createTransform' creates or replaces an Index Transforms job via +-- @PUT /_plugins/_transform/{transform_id}@. The body is the 'Transform' +-- wrapped under the top-level @transform@ key (see 'TransformRequest'); +-- the response is the 'TransformDocumentResponse' document envelope +-- (@_id@, @_version@, @_seq_no@, @_primary_term@, @transform@). +-- +-- OpenSearch treats the PUT as upsert: the same call creates a new +-- transform when @transform_id@ is unused and overwrites an existing one +-- otherwise (without an optimistic-concurrency guard). Use +-- 'updateTransformWith' to make the overwrite conditional on a prior +-- @_seq_no@ \/ @_primary_term@. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, RBAC denial, +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createTransform :: + TransformId -> + Transform -> + BHRequest StatusDependant (ParsedEsResponse TransformDocumentResponse) +createTransform transformId transform = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode (TransformRequest transform)) + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId] + +-- | 'updateTransform' replaces an Index Transforms job via +-- @PUT /_plugins/_transform/{transform_id}@. Equivalent to +-- 'updateTransformWith' with 'Nothing' (no optimistic-concurrency +-- guard), so concurrent updates to the same @transform_id@ silently +-- clobber each other. Mirrors the 'updateMonitor' / 'updateDetector' +-- unconditional-update precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, unknown +-- @transform_id@, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +updateTransform :: + TransformId -> + Transform -> + BHRequest StatusDependant (ParsedEsResponse TransformDocumentResponse) +updateTransform transformId transform = updateTransformWith transformId transform Nothing + +-- | 'updateTransformWith' replaces an Index Transforms job via +-- @PUT /_plugins/_transform/{transform_id}@ with an optional +-- optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ — +-- both values read from a prior 'TransformDocumentResponse' — to make +-- the PUT conditional on the transform being unchanged since you last +-- read it; a stale pair causes OpenSearch to respond with HTTP 409 +-- instead of silently overwriting. Pass 'Nothing' for the unconditional +-- semantics of 'updateTransform'. The two values must be supplied +-- together (mirroring the 'updateMonitorWith' / 'updateDetectorWith' / +-- 'putISMPolicyWith' precedent). +-- +-- The plugin docs document @if_seq_no@ \/ @if_primary_term@ as required +-- for the Update operation; OpenSearch still accepts an unparameterised +-- PUT as an overwrite (the @Nothing@ form), which is why +-- 'updateTransform' exists as a convenience. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing @transform_id@ +-- (or a 409 on a sequence-number mismatch) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +updateTransformWith :: + TransformId -> + Transform -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant (ParsedEsResponse TransformDocumentResponse) +updateTransformWith transformId transform mOcc = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode (TransformRequest transform)) + where + baseEndpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries baseEndpoint $ + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'getRollup' fetches a single rollup job by id via +-- @GET /_plugins/_rollup/jobs/{rollup_id}@. The response is the same +-- document-write envelope (@_id@, @_version@, @_seq_no@, +-- @_primary_term@) wrapping the inner rollup that 'createRollup' +-- returns, except the GET form emits @_seqNo@\/@_primaryTerm@ in +-- camelCase; both spellings are decoded (see 'RollupResponse'). +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @rollup_id@ or plugin +-- not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse RollupResponse) +getRollup rollupId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId] + +-- | 'getAllRollups' lists every rollup job via +-- @GET /_plugins/_rollup/jobs@. The response shape is not documented in +-- the field tables, so the body is returned as an opaque 'Value' for the +-- caller to inspect. +-- | 'getTransform' fetches a single Index Transforms job by id via +-- @GET /_plugins/_transform/{transform_id}@. The response is the +-- 'TransformDocumentResponse' document envelope carrying the persisted +-- 'TransformResponse' (with server-injected bookkeeping fields +-- @schema_version@, @updated_at@, @enabled_at@, @roles@, +-- @transform_id@) alongside the document-write metadata +-- (@_id@, @_version@, @_seq_no@, @_primary_term@). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing @transform_id@ +-- (or the plugin not installed) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +getTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse TransformDocumentResponse) +getTransform transformId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId] + +-- | 'getTransforms' lists Index Transforms jobs via +-- @GET /_plugins/_transform\/@. Pass 'Nothing' for the plain no-arg +-- list; pass @'Just' opts@ to filter by free-text @search@, paginate +-- with @from@ \/ @size@, or sort by @sortField@ \/ @sortDirection@ (see +-- 'TransformsListOptions'). +-- +-- The response is a 'GetTransformsResponse' carrying @total_transforms@ +-- (the count of all transforms the caller can see, independent of +-- pagination) and the per-page @transforms@ array. Each entry is a +-- 'GetTransformsListEntry' with the same document envelope + +-- 'TransformResponse' payload as 'getTransform'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getAllRollups :: + BHRequest StatusDependant (ParsedEsResponse Value) +getAllRollups = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs"] + +-- | 'deleteRollup' deletes a rollup job by id via +-- @DELETE /_plugins/_rollup/jobs/{rollup_id}@. The plugin returns the bare +-- Elasticsearch delete-document response (@_index@, @_id@, @_version@, +-- @result@, @forced_refresh@, @_shards@, @_seq_no@, @_primary_term@, NO +-- @acknowledged@ key), so the body is returned as an opaque 'Value'. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @rollup_id@ or plugin +-- not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse Value) +deleteRollup rollupId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId] + +-- | 'startRollup' starts a rollup job by id via +-- @POST /_plugins/_rollup/jobs/{rollup_id}/_start@. The plugin +-- acknowledges with an 'Acknowledged' body. +-- +-- Surfaced as 'StatusDependant' so a 4xx (unknown @rollup_id@, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +startRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +startRollup rollupId = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId, "_start"] + +-- | 'stopRollup' stops a rollup job by id via +-- @POST /_plugins/_rollup/jobs/{rollup_id}/_stop@. The plugin +-- acknowledges with an 'Acknowledged' body. +-- +-- Surfaced as 'StatusDependant' so a 4xx (unknown @rollup_id@, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +stopRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +stopRollup rollupId = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId, "_stop"] + +-- | 'explainRollup' returns execution metadata for a rollup job by id +-- via @GET /_plugins/_rollup/jobs/{rollup_id}/_explain@. The response is +-- keyed by the rollup id; decode it into 'ExplainRollupResponse' and +-- look up the entry with 'explainRollupResponseLookup'. Before the job +-- has executed, both @metadata_id@ and @rollup_metadata@ are JSON @null@. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @rollup_id@ or plugin +-- not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +explainRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse ExplainRollupResponse) +explainRollup rollupId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId, "_explain"] + +-- ========================================================================= +-- Cross-Cluster Replication (CCR) plugin +-- ========================================================================= + +-- | 'startReplication' calls the CCR plugin Start Replication API +-- (@PUT /_plugins/_replication/{follower-index}/_start@) on the +-- /follower/ cluster. Begins replicating the named leader index into the +-- given follower index. The follower index is created read-only and +-- stays so while replication is active; call 'stopReplication' to +-- convert it back into a standard writable index. +-- +-- The 'StartReplicationRequest' carries the leader connection alias, +-- the leader index name, and (when the Security plugin is enabled) the +-- cross-cluster roles. Returns 'Acknowledged'. +-- +-- For more information see +-- . +startReplication :: + Text -> + StartReplicationRequest -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +startReplication followerIndex req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_start"] + +-- | 'stopReplication' calls the CCR plugin Stop Replication API +-- (@POST /_plugins/_replication/{follower-index}/_stop@) on the +-- /follower/ cluster. Terminates replication and converts the follower +-- index into a standard (writable) index. The body is the empty object +-- @{}@ per the plugin docs. Returns 'Acknowledged'. +-- +-- For more information see +-- . +stopReplication :: + Text -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +stopReplication followerIndex = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_stop"] + +-- | 'pauseReplication' calls the CCR plugin Pause Replication API +-- (@POST /_plugins/_replication/{follower-index}/_pause@) on the +-- /follower/ cluster. Pauses replication of the leader index. +-- Replication cannot be resumed after being paused for more than 12 +-- hours — beyond that you must stop, delete the follower, and restart. +-- The body is the empty object @{}@. Returns 'Acknowledged'. +-- +-- For more information see +-- . +pauseReplication :: + Text -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +pauseReplication followerIndex = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_pause"] + +-- | 'resumeReplication' calls the CCR plugin Resume Replication API +-- (@POST /_plugins/_replication/{follower-index}/_resume@) on the +-- /follower/ cluster. Resumes replication of the leader index after a +-- 'pauseReplication'. The body is the empty object @{}@. Returns +-- 'Acknowledged'. +-- +-- For more information see +-- . +resumeReplication :: + Text -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +resumeReplication followerIndex = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_resume"] + +-- | 'updateReplicationSettings' calls the CCR plugin Update Settings API +-- (@PUT /_plugins/_replication/{follower-index}/_update@) on the +-- /follower/ cluster. Applies index-level settings (e.g. +-- @index.number_of_replicas@) to the follower index. Returns +-- 'Acknowledged'. +-- +-- For more information see +-- . +updateReplicationSettings :: + Text -> + UpdateReplicationSettingsRequest -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +updateReplicationSettings followerIndex req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_update"] + +-- | 'getReplicationStatus' calls the CCR plugin Status API +-- (@GET /_plugins/_replication/{follower-index}/_status@) on the +-- /follower/ cluster without the @verbose@ flag. Equivalent to +-- 'getReplicationStatusWith' with 'defaultReplicationStatusOptions'. +-- +-- For more information see +-- . +getReplicationStatus :: + Text -> + BHRequest StatusDependant (ParsedEsResponse ReplicationStatusResponse) +getReplicationStatus = getReplicationStatusWith defaultReplicationStatusOptions + +-- | 'getReplicationStatusWith' is the parameterized variant of +-- 'getReplicationStatus': the supplied 'ReplicationStatusOptions' are +-- forwarded as query-string parameters. Set +-- 'replicationStatusOptionsVerbose' to @'Just' True@ to include +-- shard-level 'SyncingDetails' in the response. +-- +-- See 'Database.Bloodhound.OpenSearch1.Requests.getReplicationStatus'. +getReplicationStatusWith :: + ReplicationStatusOptions -> + Text -> + BHRequest StatusDependant (ParsedEsResponse ReplicationStatusResponse) +getReplicationStatusWith opts followerIndex = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_replication", followerIndex, "_status"] + `withQueries` replicationStatusOptionsParams opts + +-- | 'getLeaderStats' calls the CCR plugin Leader Stats API +-- (@GET /_plugins/_replication/leader_stats@) on the /leader/ cluster. +-- Returns aggregate and per-index read-side counters across all +-- replicated leader indexes. +-- +-- For more information see +-- . +getLeaderStats :: + BHRequest StatusDependant (ParsedEsResponse LeaderStatsResponse) +getLeaderStats = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_replication", "leader_stats"] + +-- | 'getFollowerStats' calls the CCR plugin Follower Stats API +-- (@GET /_plugins/_replication/follower_stats@) on the /follower/ +-- cluster. Returns counts of follower indexes by state and aggregate +-- write-side throughput, plus a per-index breakdown. +-- +-- For more information see +-- . +getFollowerStats :: + BHRequest StatusDependant (ParsedEsResponse FollowerStatsResponse) +getFollowerStats = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_replication", "follower_stats"] + +-- | 'getAutoFollowStats' calls the CCR plugin Auto-Follow Stats API +-- (@GET /_plugins/_replication/autofollow_stats@) on the /follower/ +-- cluster. Returns auto-follow activity and the list of configured +-- replication rules. The docs note there is no dedicated \"list +-- patterns\" endpoint — this stats response is the only way to discover +-- existing auto-follow rules. +-- +-- For more information see +-- . +getAutoFollowStats :: + BHRequest StatusDependant (ParsedEsResponse AutoFollowStatsResponse) +getAutoFollowStats = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_replication", "autofollow_stats"] + +-- | 'createAutoFollowPattern' calls the CCR plugin Create Replication +-- Rule API (@POST /_plugins/_replication/_autofollow@) on the +-- /follower/ cluster. Creates (or, re-POSTed with the same @name@, +-- updates) an auto-follow rule that automatically starts replication on +-- any existing and future leader indexes whose names match the rule's +-- @pattern@. Returns 'Acknowledged'. +-- +-- For more information see +-- . +createAutoFollowPattern :: + CreateAutoFollowPatternRequest -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +createAutoFollowPattern req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_replication", "_autofollow"] + +-- | 'deleteAutoFollowPattern' calls the CCR plugin Delete Replication +-- Rule API (@DELETE /_plugins/_replication/_autofollow@) on the +-- /follower/ cluster. Deletes an auto-follow rule. This prevents /new/ +-- indexes from being replicated but does /not/ stop replication already +-- initiated by the rule — stop those individually with +-- 'stopReplication'. The delete carries a request body (the rule's +-- @leader_alias@ and @name@), hence 'deleteWithBody'. Returns +-- 'Acknowledged'. +-- +-- For more information see +-- . +deleteAutoFollowPattern :: + DeleteAutoFollowPatternRequest -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +deleteAutoFollowPattern req = + withBHResponseParsedEsResponse $ + deleteWithBody @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_replication", "_autofollow"] + +-- . +getTransforms :: + Maybe TransformsListOptions -> + BHRequest StatusDependant (ParsedEsResponse GetTransformsResponse) +getTransforms mOpts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_transform"] + endpoint = case mOpts of + Nothing -> baseEndpoint + Just opts -> withQueries baseEndpoint (transformsListOptionsParams opts) + +-- | 'startTransform' starts an Index Transforms job via +-- @POST /_plugins/_transform/{transform_id}/_start@. The endpoint takes +-- no request body and returns the 'Acknowledged' envelope on success. +-- A non-continuous transform runs to completion and transitions to the +-- @finished@ state; a continuous transform runs on the schedule until +-- 'stopTransform' is called. Poll 'explainTransform' for the runtime +-- state. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @transform_id@, the +-- plugin not installed, RBAC denial) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +startTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +startTransform transformId = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId, "_start"] + +-- | 'stopTransform' stops an Index Transforms job via +-- @POST /_plugins/_transform/{transform_id}/_stop@. The endpoint takes +-- no request body and returns the 'Acknowledged' envelope on success. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @transform_id@, the +-- plugin not installed, RBAC denial) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +stopTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +stopTransform transformId = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId, "_stop"] + +-- | 'explainTransform' returns the runtime status and statistics of an +-- Index Transforms job via +-- @GET /_plugins/_transform/{transform_id}/_explain@. The response is +-- keyed by @transform_id@ at the top level; the request builder +-- projects out the lone entry as a 'Maybe' 'TransformExplain' so the +-- public type reads as a plain per-id lookup. The 'Nothing' branch +-- surfaces when the server returns HTTP 200 with no entry (a miss is +-- more typically HTTP 404 via 'StatusDependant' before the body decode +-- runs). +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @transform_id@, the +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +explainTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse (Maybe TransformExplain)) +explainTransform transformId = + fmap (fmap (Map.lookup (unTransformId transformId))) + . withBHResponseParsedEsResponse + $ get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId, "_explain"] + +-- | 'previewTransform' previews what the transformed target index would +-- look like via @POST /_plugins/_transform/_preview@. The body is the +-- same 'Transform' wrapper as 'createTransform'; no state is +-- persisted. The response is a 'PreviewTransformResponse' carrying the +-- would-be target documents as opaque aeson 'Value's (the row shape is +-- caller-driven by @groups[].target_field@ names plus @aggregations@ +-- keys). +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +previewTransform :: + Transform -> + BHRequest StatusDependant (ParsedEsResponse PreviewTransformResponse) +previewTransform transform = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (TransformRequest transform)) + where + endpoint = mkEndpoint ["_plugins", "_transform", "_preview"] + +-- | 'deleteTransform' deletes an Index Transforms job by id via +-- @DELETE /_plugins/_transform/{transform_id}@. The endpoint does NOT +-- delete the source or target indexes — only the transform job itself. +-- +-- The response is the bulk-response envelope (the transform is stored +-- as a doc in @.opensearch-ism-config@, so DELETE surfaces through the +-- bulk handler). The shared 'BulkResponse' from +-- @Common.Types.Bulk@ matches that envelope byte-for-byte, so we reuse +-- it rather than introducing a per-plugin wrapper. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing @transform_id@ +-- (or the plugin not installed) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +deleteTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse BulkResponse) +deleteTransform transformId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId] diff --git a/src/Database/Bloodhound/OpenSearch1/Types.hs b/src/Database/Bloodhound/OpenSearch1/Types.hs --- a/src/Database/Bloodhound/OpenSearch1/Types.hs +++ b/src/Database/Bloodhound/OpenSearch1/Types.hs @@ -1,6 +1,179 @@ module Database.Bloodhound.OpenSearch1.Types ( module Reexport, + ReplicationUseRoles (..), + StartReplicationRequest (..), + UpdateReplicationSettingsRequest (..), + CreateAutoFollowPatternRequest (..), + DeleteAutoFollowPatternRequest (..), + ReplicationStatus (..), + SyncingDetails (..), + ReplicationStatusResponse (..), + ReplicationStatusOptions (..), + LeaderIndexStats (..), + LeaderStatsResponse (..), + FollowerIndexStats (..), + FollowerStatsResponse (..), + AutoFollowRuleStats (..), + AutoFollowStatsResponse (..), + ISMPolicyRequest (..), + ISMPolicyResponse (..), + ISMPolicyBody (..), + ISMState (..), + ISMTransition (..), + ISMCondition (..), + ISMCron (..), + ISMCronCondition (..), + ISMAction (..), + ISMRolloverConfig (..), + ISMForceMergeConfig (..), + ISMAllocationConfig (..), + ISMTemplate (..), + ISMErrorNotification (..), + ISMErrorNotificationDestination (..), + ISMMessageTemplate (..), + ISMUserVariables (..), + PolicyId (..), + PutISMPolicyResponse (..), + ISMUpdatedIndicesResponse (..), + ISMFailedIndex (..), + ISMChangePolicyInclude (..), + ChangePolicyRequest (..), + ISMExplanationNamed (..), + ISMExplanationAction (..), + ISMExplanationStep (..), + ISMExplanationRetryInfo (..), + ISMExplanationInfo (..), + ISMExplanationValidate (..), + ISMExplanationEntry (..), + ISMExplanation (..), + ISMPolicyInfo (..), + GetISMPoliciesResponse (..), + ISMPoliciesQuery (..), + ISMExplainOptions (..), + DetectorId (..), + PeriodUnit (..), + Period (..), + WindowPeriod (..), + FeatureAttribute (..), + DetectorType (..), + User (..), + Detector (..), + DetectorResponse (..), + CreateDetectorResponse (..), + PreviewRequest (..), + FeatureData (..), + Entity (..), + AnomalyResult (..), + PreviewResponse (..), + StartDetectorJobRequest (..), + DetectorJobAcknowledgment (..), + AnomalyShards (..), + DeleteDetectorResponse (..), + ValidateDetectorMode (..), + ValidateDetectorResponse (..), + AnomalySearchTotalRelation (..), + AnomalySearchTotal (..), + AnomalySearchHit (..), + AnomalySearchResponse (..), + DetectorProfileResponse (..), + DetectorStatsResponse (..), + TopAnomaliesOrder (..), + TopAnomaliesRequest (..), + TopAnomalyBucket (..), + TopAnomaliesResponse (..), + KnnNodeId (..), + KnnStatName (..), + KnnStats (..), + KnnModelState (..), + KnnModel (..), + KnnDeleteModelResponse (..), + KnnTrainingMethod (..), + KnnTrainingRequest (..), + KnnTrainResponse (..), + MLNodeId (..), + MLStatName (..), + MLStats (..), + ModelId (..), + AlgorithmName (..), + ModelFormat (..), + ModelState (..), + ModelConfig (..), + ModelInfo (..), + ModelSearchResponse (..), + ModelShards (..), + ModelTotal (..), + ModelTotalRelation (..), + ModelHit (..), + MLTaskId (..), + MLTaskType (..), + MLTaskState (..), + MLTaskInfo (..), + SQLRequest (..), + PPLRequest (..), + SQLParameter (..), + SQLCursor (..), + SQLCursorRequest (..), + SQLColumn (..), + SQLResult (..), + SQLCloseResult (..), + SQLPluginStats (..), + RollupId (..), + Rollup (..), + RollupWrapper (..), + RollupSchedule (..), + RollupInterval (..), + RollupIntervalUnit (..), + RollupCron (..), + RollupDimension (..), + RollupDateHistogram (..), + RollupTerms (..), + RollupHistogram (..), + RollupMetric (..), + RollupMetricAgg (..), + RollupResponse (..), + RollupResponseInner (..), + ExplainRollupResponse (..), + ExplainRollupEntry (..), + RollupMetadata (..), + RollupStatus (..), + RollupStats (..), + TransformId (..), + TransformPeriodUnit (..), + TransformInterval (..), + TransformSchedule (..), + TransformGroup (..), + TermsGroup (..), + HistogramGroup (..), + DateHistogramGroup (..), + Transform (..), + TransformResponse (..), + TransformRequest (..), + TransformDocumentResponse (..), + TransformSortDirection (..), + TransformsListOptions (..), + GetTransformsResponse (..), + GetTransformsListEntry (..), + TransformExplain (..), + TransformMetadata (..), + TransformStats (..), + TransformContinuousStats (..), + PreviewTransformResponse (..), ) where -import Database.Bloodhound.Common.Types as Reexport +-- Hide ES-only Common types that collide with OpenSearch plugin +-- re-exports below: the ES Security 'User' (OpenSearch security lives at +-- /_plugins/_security) and the ES X-Pack Transform types that share +-- names with the OpenSearch Index Transforms plugin (IndexTransforms). +import Database.Bloodhound.Common.Types as Reexport hiding + ( PreviewTransformResponse, + TransformId, + TransformStats, + User, + unTransformId, + ) +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.Alerting as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.CCR as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.IndexTransforms as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch1.Types.Rollups as Reexport diff --git a/src/Database/Bloodhound/OpenSearch2/Client.hs b/src/Database/Bloodhound/OpenSearch2/Client.hs --- a/src/Database/Bloodhound/OpenSearch2/Client.hs +++ b/src/Database/Bloodhound/OpenSearch2/Client.hs @@ -3,94 +3,2273 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module Database.Bloodhound.OpenSearch2.Client - ( module Reexport, - pitSearch, - openPointInTime, - closePointInTime, - ) -where - -import Control.Monad -import Data.Aeson -import Data.Monoid -import Database.Bloodhound.Client.Cluster -import Database.Bloodhound.Common.Client as Reexport -import Database.Bloodhound.Internal.Client.BHRequest -import qualified Database.Bloodhound.OpenSearch2.Requests as Requests -import Database.Bloodhound.OpenSearch2.Types -import Prelude hiding (filter, head) - --- | 'pitSearch' uses the point in time (PIT) API of elastic, for a given --- 'IndexName'. Note that this will consume the --- entire search result set and will be doing O(n) list appends so this may --- not be suitable for large result sets. In that case, the point in time API --- should be used directly with `openPointInTime` and `closePointInTime`. --- --- Note that 'pitSearch' utilizes the 'search_after' parameter under the hood, --- which requires a non-empty 'sortBody' field in the provided 'Search' value. --- Otherwise, 'pitSearch' will fail to return all matching documents. --- --- For more information see --- . -pitSearch :: - forall a m. - (FromJSON a, MonadBH m, WithBackend OpenSearch2 m) => - IndexName -> - Search -> - m [Hit a] -pitSearch indexName search = do - openResp <- openPointInTime indexName - case openResp of - Left e -> throwEsError e - Right OpenPointInTimeResponse {..} -> do - let searchPIT = search {pointInTime = Just (PointInTime oos2PitId "1m")} - hits <- pitAccumulator searchPIT [] - closeResp <- closePointInTime (ClosePointInTime oos2PitId) - case closeResp of - Left _ -> return [] - Right (ClosePointInTimeResponse False _) -> - error "failed to close point in time (PIT)" - Right (ClosePointInTimeResponse True _) -> return hits - where - pitAccumulator :: Search -> [Hit a] -> m [Hit a] - pitAccumulator search' oldHits = do - resp <- tryPerformBHRequest $ Requests.searchAll search' - case resp of - Left _ -> return [] - Right searchResult -> case hits (searchHits searchResult) of - [] -> return oldHits - newHits -> case (hitSort $ last newHits, pitId searchResult) of - (Nothing, Nothing) -> - error "no point in time (PIT) ID or last sort value" - (Just _, Nothing) -> error "no point in time (PIT) ID" - (Nothing, _) -> return (oldHits <> newHits) - (Just lastSort, Just pitId') -> do - let newSearch = - search' - { pointInTime = Just (PointInTime pitId' "1m"), - searchAfterKey = Just lastSort - } - pitAccumulator newSearch (oldHits <> newHits) - --- | 'openPointInTime' opens a point in time for an index given an 'IndexName'. --- Note that the point in time should be closed with 'closePointInTime' as soon --- as it is no longer needed. --- --- For more information see --- . -openPointInTime :: - (MonadBH m, WithBackend OpenSearch2 m) => - IndexName -> - m (ParsedEsResponse OpenPointInTimeResponse) -openPointInTime indexName = performBHRequest $ Requests.openPointInTime indexName - --- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'. --- --- For more information see --- . -closePointInTime :: - (MonadBH m, WithBackend OpenSearch2 m) => - ClosePointInTime -> - m (ParsedEsResponse ClosePointInTimeResponse) -closePointInTime q = performBHRequest $ Requests.closePointInTime q +-- | +-- Module : Database.Bloodhound.OpenSearch2.Client +-- Description : OpenSearch 2 client (re-exports Common + OpenSearch 2 plugins) +-- +-- The OpenSearch 2 client. Re-exports the version-agnostic "Database.Bloodhound.Common.Client" +-- surface and adds OpenSearch 2 plugins: Index State Management (ISM), ML commons +-- models and agents, neural/kNN cache warmup and clearing, point in time (PIT), +-- asynchronous search, SQL and PPL, the notifications framework, and the +-- alerting/monitors framework. +module Database.Bloodhound.OpenSearch2.Client + ( module Reexport, + pitSearch, + pitSearchWith, + openPointInTime, + openPointInTimeWith, + closePointInTime, + listAllPITs, + deleteAllPITs, + getMLTask, + deleteISMPolicy, + addISMPolicy, + putISMPolicy, + putISMPolicyWith, + removeISMPolicy, + changeISMPolicy, + retryISMIndex, + explainISMIndex, + explainISMIndexWith, + explainISMIndexFiltered, + getISMPolicy, + getISMPolicies, + postSMPolicy, + putSMPolicyWith, + getSMPolicy, + getSMPolicies, + deleteSMPolicy, + startSMPolicy, + stopSMPolicy, + explainSMPolicies, + getMLStats, + getModel, + registerModel, + registerModelWith, + deployModel, + undeployModel, + updateModel, + searchModels, + listModels, + deleteModel, + predict, + registerAgent, + getAgent, + deleteAgent, + searchAgents, + executeAgent, + warmupKnnIndex, + warmupKnnIndices, + clearKnnCache, + clearKnnCaches, + getKnnStats, + getKnnModel, + trainKnnModel, + trainKnnModelWith, + deleteKnnModel, + searchKnnModels, + submitOSAsyncSearch, + submitOSAsyncSearchWith, + getOSAsyncSearch, + deleteOSAsyncSearch, + getOSAsyncSearchStats, + sqlQuery, + sqlQueryNextPage, + closeSqlCursor, + explainSQL, + pplQuery, + explainPPL, + getSQLStats, + createNotificationConfig, + createNotificationConfigWith, + deleteNotificationConfig, + deleteNotificationConfigs, + getNotificationConfig, + getNotificationConfigs, + getNotificationConfigsWith, + getNotificationFeatures, + getNotificationChannels, + getNotificationChannelsWith, + updateNotificationConfig, + sendTestNotification, + createMonitor, + getMonitor, + updateMonitor, + updateMonitorWith, + deleteMonitor, + searchMonitors, + executeMonitor, + createSADetector, + getSADetector, + updateSADetector, + deleteSADetector, + searchSADetectors, + searchSAPrePackagedRules, + searchSACustomRules, + createSACustomRule, + updateSACustomRule, + deleteSACustomRule, + getSAMappingsView, + createSAMappings, + getSAMappings, + updateSAMappings, + getSAAlertsWith, + getSAAlerts, + acknowledgeSADetectorAlerts, + searchSAFindings, + createSACorrelationRule, + getSACorrelations, + findSACorrelation, + searchSACorrelationAlerts, + acknowledgeSACorrelationAlerts, + createSALogType, + searchSALogTypes, + updateSALogType, + deleteSALogType, + getDestinations, + getDestinationsWith, + createDestination, + updateDestination, + deleteDestination, + getAlertsWith, + getAlerts, + acknowledgeAlert, + getMonitorStats, + createEmailAccount, + getEmailAccount, + updateEmailAccount, + updateEmailAccountWith, + deleteEmailAccount, + createEmailGroup, + getEmailGroup, + updateEmailGroup, + updateEmailGroupWith, + deleteEmailGroup, + getDestination, + searchEmailAccounts, + searchEmailGroups, + searchFindings, + createComment, + updateComment, + searchComments, + deleteComment, + createDetector, + getDetector, + previewDetector, + previewDetectorInline, + startDetector, + stopDetector, + updateDetector, + updateDetectorWith, + deleteDetector, + validateDetector, + searchDetectors, + profileDetector, + getDetectorStats, + searchDetectorResults, + deleteDetectorResults, + searchDetectorTasks, + topAnomalies, + createRollup, + createRollupWith, + getRollup, + getAllRollups, + deleteRollup, + startRollup, + stopRollup, + explainRollup, + startReplication, + stopReplication, + pauseReplication, + resumeReplication, + updateReplicationSettings, + getReplicationStatus, + getReplicationStatusWith, + getLeaderStats, + getFollowerStats, + getAutoFollowStats, + createAutoFollowPattern, + deleteAutoFollowPattern, + createTransform, + updateTransform, + updateTransformWith, + getTransform, + getTransforms, + startTransform, + stopTransform, + explainTransform, + previewTransform, + deleteTransform, + ) +where + +import Control.Monad +import Data.Aeson +import Data.List.NonEmpty (NonEmpty) +import Data.Monoid +import Data.Text (Text) +import Data.Word (Word64) +import Database.Bloodhound.Client.Cluster +import Database.Bloodhound.Common.Client as Reexport hiding + ( PreviewTransformResponse, + TransformId, + TransformStats, + deleteTransform, + explainTransform, + getTransforms, + previewTransform, + startTransform, + stopTransform, + unTransformId, + updateTransform, + updateTransformWith, + ) +import Database.Bloodhound.Internal.Client.BHRequest +import Database.Bloodhound.OpenSearch2.Requests qualified as Requests +import Database.Bloodhound.OpenSearch2.Types +import Prelude hiding (filter, head) + +-- | 'pitSearch' uses the point in time (PIT) API of OpenSearch, for a given +-- 'IndexName'. The supplied 'KeepAlive' duration is forwarded to every PIT +-- open\/extend call. Note that this will consume the entire search result set +-- and will be doing O(n) list appends so this may not be suitable for large +-- result sets. In that case, the point in time API should be used directly +-- with `openPointInTime` and `closePointInTime`. +-- +-- This is a convenience wrapper around 'pitSearchWith' that lifts the +-- single 'IndexName' into an 'IndexPattern'. To search across multiple +-- comma-joined indices or a wildcard pattern, use 'pitSearchWith' +-- directly with an 'IndexPattern'. +-- +-- Note that 'pitSearch' utilizes the 'search_after' parameter under the hood, +-- which requires a non-empty 'sortBody' field in the provided 'Search' value. +-- Otherwise, 'pitSearch' will fail to return all matching documents. +-- +-- Closing the PIT (via 'closePointInTime') is best-effort cleanup: if it +-- fails, the accumulated hits are still returned rather than discarded. The +-- PIT will expire on its own once the @keep_alive@ elapses. +-- +-- For more information see +-- . +pitSearch :: + forall a m. + (FromJSON a, MonadBH m, WithBackend OpenSearch2 m) => + IndexName -> + KeepAlive -> + Search -> + m [Hit a] +pitSearch indexName = pitSearchWith (IndexPattern (unIndexName indexName)) + +-- | 'pitSearchWith' is the parameterized variant of 'pitSearch': it +-- takes an 'IndexPattern' as the target (@target_indexes@ on the wire), +-- which may be a single index name, a comma-separated list of indices, +-- or a wildcard pattern (e.g. @\"logs-*\"@, @\"logs-2024,logs-2025\"@). +-- Otherwise behaves exactly like 'pitSearch'. See +-- 'openPointInTimeWith' for the target rendering. +-- +-- For more information see +-- . +pitSearchWith :: + forall a m. + (FromJSON a, MonadBH m, WithBackend OpenSearch2 m) => + IndexPattern -> + KeepAlive -> + Search -> + m [Hit a] +pitSearchWith indexPattern keepAlive search = do + openResp <- openPointInTimeWith indexPattern keepAlive defaultPITOptions + case openResp of + Left e -> throwEsError e + Right OpenPointInTimeResponse {..} -> do + let searchPIT = search {pointInTime = Just (PointInTime oos2PitId (Just keepAlive))} + hits <- pitAccumulator searchPIT [] + closeResp <- closePointInTime (ClosePointInTime [oos2PitId]) + case closeResp of + Left _ -> return hits + Right resp + | not (null (closePITs resp)) && all cpitSuccessful (closePITs resp) -> return hits + | otherwise -> error "failed to close point in time (PIT)" + where + pitAccumulator :: Search -> [Hit a] -> m [Hit a] + pitAccumulator search' oldHits = do + resp <- tryPerformBHRequest $ Requests.searchAll search' + case resp of + Left _ -> return [] + Right searchResult -> case hits (searchHits searchResult) of + [] -> return oldHits + newHits -> case (hitSort $ last newHits, pitId searchResult) of + (Nothing, Nothing) -> + error "no point in time (PIT) ID or last sort value" + (Just _, Nothing) -> error "no point in time (PIT) ID" + (Nothing, _) -> return (oldHits <> newHits) + (Just lastSort, Just pitId') -> do + let newSearch = + search' + { pointInTime = Just (PointInTime pitId' (Just keepAlive)), + searchAfterKey = Just lastSort + } + pitAccumulator newSearch (oldHits <> newHits) + +-- | 'openPointInTime' opens a point in time for an index given an 'IndexName' +-- and a 'KeepAlive' duration (e.g. @keepAliveMinutes 1@). Note that the point +-- in time should be closed with 'closePointInTime' as soon as it is no longer +-- needed. +-- +-- Equivalent to 'openPointInTimeWith' with +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.defaultPITOptions' +-- (no optional URI parameters). +-- +-- For more information see +-- . +openPointInTime :: + (MonadBH m, WithBackend OpenSearch2 m) => + IndexName -> + KeepAlive -> + m (ParsedEsResponse OpenPointInTimeResponse) +openPointInTime indexName keepAlive = performBHRequest $ Requests.openPointInTime indexName keepAlive + +-- | 'openPointInTimeWith' is the parameterized variant of +-- 'openPointInTime': it takes an 'IndexPattern' target (single name, +-- comma-list, or wildcard) and forwards the supplied 'PITOptions' as +-- query-string parameters in addition to the mandatory @keep_alive@. +-- See 'Database.Bloodhound.OpenSearch2.Requests.openPointInTimeWith' +-- for which parameters are emitted. +-- +-- For more information see +-- . +openPointInTimeWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + IndexPattern -> + KeepAlive -> + PITOptions -> + m (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWith indexPattern keepAlive opts = + performBHRequest $ Requests.openPointInTimeWith indexPattern keepAlive opts + +-- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'. +-- +-- For more information see +-- . +closePointInTime :: + (MonadBH m, WithBackend OpenSearch2 m) => + ClosePointInTime -> + m (ParsedEsResponse ClosePointInTimeResponse) +closePointInTime q = performBHRequest $ Requests.closePointInTime q + +-- | 'listAllPITs' returns every currently-open point in time on the +-- cluster via @GET /_search/point_in_time/_all@. Each 'PITInfo' carries +-- the pit id, the @creation_time@ and the remaining @keep_alive@ (a bare +-- millisecond count on the wire); the @_shards@ summary is absent from +-- list entries (it appears only in the @POST@ create-PIT response, see +-- 'OpenPointInTimeResponse'). +-- +-- For more information see +-- . +listAllPITs :: + (MonadBH m, WithBackend OpenSearch2 m) => + m [PITInfo] +listAllPITs = performBHRequest Requests.listAllPITs + +-- | 'deleteAllPITs' deletes every currently-open point in time on the +-- cluster via @DELETE /_search/point_in_time/_all@ (no request body). +-- The server returns one 'ClosePointInTimeResult' per deleted PIT, so +-- the response reuses the 'ClosePointInTimeResponse' envelope; partial +-- failures are reported as failures. Deletes only local and mixed PITs, +-- not fully remote (cross-cluster) ones. +-- +-- For more information see +-- . +deleteAllPITs :: + (MonadBH m, WithBackend OpenSearch2 m) => + m (ParsedEsResponse ClosePointInTimeResponse) +deleteAllPITs = performBHRequest Requests.deleteAllPITs + +-- | 'getMLTask' fetches the current state of an ML Commons asynchronous task +-- (model registration, deployment, training, ...). Poll this with the +-- @task_id@ returned by the submit endpoint until 'mlTaskInfoState' reaches +-- 'MLTaskStateCompleted' or 'MLTaskStateFailed'. +-- +-- For more information see +-- . +getMLTask :: + (MonadBH m, WithBackend OpenSearch2 m) => + MLTaskId -> + m (ParsedEsResponse MLTaskInfo) +getMLTask mlTaskId = performBHRequest $ Requests.getMLTask mlTaskId + +-- | 'putISMPolicy' creates or updates an ISM policy. +-- See +putISMPolicy :: + (MonadBH m, WithBackend OpenSearch2 m) => + PolicyId -> + ISMPolicyRequest -> + m (ParsedEsResponse PutISMPolicyResponse) +putISMPolicy policyId policy = performBHRequest $ Requests.putISMPolicy policyId policy + +-- | 'putISMPolicyWith' creates or updates an ISM policy with an optional +-- optimistic-concurrency guard (@if_seq_no@ / @if_primary_term@). See +-- 'Requests.putISMPolicyWith' for semantics. +-- See +putISMPolicyWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + PolicyId -> + ISMPolicyRequest -> + Maybe (Word64, Word64) -> + m (ParsedEsResponse PutISMPolicyResponse) +putISMPolicyWith policyId policy mOcc = + performBHRequest $ Requests.putISMPolicyWith policyId policy mOcc + +-- | 'addISMPolicy' applies an existing ISM policy to an index. +-- See +addISMPolicy :: + (MonadBH m, WithBackend OpenSearch2 m) => + PolicyId -> + IndexName -> + m (ParsedEsResponse ISMUpdatedIndicesResponse) +addISMPolicy policyId indexName = performBHRequest $ Requests.addISMPolicy policyId indexName + +-- | 'removeISMPolicy' detaches any ISM policy from the given index. +-- See +removeISMPolicy :: + (MonadBH m, WithBackend OpenSearch2 m) => + IndexName -> + m (ParsedEsResponse ISMUpdatedIndicesResponse) +removeISMPolicy indexName = performBHRequest $ Requests.removeISMPolicy indexName + +-- | 'changeISMPolicy' updates the managed-index policy attached to an index. +-- See +changeISMPolicy :: + (MonadBH m, WithBackend OpenSearch2 m) => + IndexName -> + ChangePolicyRequest -> + m (ParsedEsResponse ISMUpdatedIndicesResponse) +changeISMPolicy indexName req = performBHRequest $ Requests.changeISMPolicy indexName req + +-- | 'retryISMIndex' retries the failed ISM action for an index. +-- See +retryISMIndex :: + (MonadBH m, WithBackend OpenSearch2 m) => + IndexName -> + Maybe Text -> + m (ParsedEsResponse ISMUpdatedIndicesResponse) +retryISMIndex indexName mState = performBHRequest $ Requests.retryISMIndex indexName mState + +-- | 'explainISMIndex' returns the ISM state of an index. +-- See +explainISMIndex :: + (MonadBH m, WithBackend OpenSearch2 m) => + IndexName -> + m (ParsedEsResponse ISMExplanation) +explainISMIndex indexName = performBHRequest $ Requests.explainISMIndex indexName + +-- | 'explainISMIndexWith' returns the ISM state of an index with optional +-- @show_policy@, @validate_action@, @local@ and @expand_wildcards@ query +-- parameters. +-- See +explainISMIndexWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + IndexName -> + ISMExplainOptions -> + m (ParsedEsResponse ISMExplanation) +explainISMIndexWith indexName opts = + performBHRequest $ Requests.explainISMIndexWith indexName opts + +-- | 'explainISMIndexFiltered' returns the ISM state of an index via the +-- @POST /_plugins/_ism/explain/{index}@ "Explain index with filtering" form, +-- sending an 'ISMExplainFilter' as the request body. +-- See +explainISMIndexFiltered :: + (MonadBH m, WithBackend OpenSearch2 m) => + IndexName -> + ISMExplainFilter -> + m (ParsedEsResponse ISMExplanation) +explainISMIndexFiltered indexName filt = + performBHRequest $ Requests.explainISMIndexFiltered indexName filt + +-- | 'getISMPolicy' fetches a single policy by id. +-- See +getISMPolicy :: + (MonadBH m, WithBackend OpenSearch2 m) => + PolicyId -> + m (ParsedEsResponse ISMPolicyInfo) +getISMPolicy policyId = performBHRequest $ Requests.getISMPolicy policyId + +-- | 'getISMPolicies' lists policies, optionally filtered / paginated. +-- See +getISMPolicies :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe ISMPoliciesQuery -> + m (ParsedEsResponse GetISMPoliciesResponse) +getISMPolicies mQuery = performBHRequest $ Requests.getISMPolicies mQuery + +-- | 'deleteISMPolicy' deletes an ISM policy by id. +-- OpenSearch stores policies as documents in @.opendistro-ism-config@, so the +-- response is the standard document-delete envelope (parsed here as +-- 'IndexedDocument'), not an 'Acknowledged' ack. +-- See +deleteISMPolicy :: + (MonadBH m, WithBackend OpenSearch2 m) => + PolicyId -> + m (ParsedEsResponse IndexedDocument) +deleteISMPolicy policyId = performBHRequest $ Requests.deleteISMPolicy policyId + +-- ========================================================================= +-- Snapshot Management plugin +-- ========================================================================= + +-- | 'postSMPolicy' creates a new SM policy. +postSMPolicy :: + (MonadBH m, WithBackend OpenSearch2 m) => + SMPolicyName -> + SMPolicyBody -> + m (ParsedEsResponse SMPolicyResponse) +postSMPolicy policyName body = performBHRequest $ Requests.postSMPolicy policyName body + +-- | 'putSMPolicyWith' updates an existing SM policy with the @if_seq_no@ +-- / @if_primary_term@ optimistic-concurrency guard. +putSMPolicyWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + SMPolicyName -> + SMPolicyBody -> + Word64 -> + Word64 -> + m (ParsedEsResponse SMPolicyResponse) +putSMPolicyWith policyName body seqNo primaryTerm = + performBHRequest $ Requests.putSMPolicyWith policyName body seqNo primaryTerm + +-- | 'getSMPolicy' fetches a single SM policy by name. +getSMPolicy :: + (MonadBH m, WithBackend OpenSearch2 m) => + SMPolicyName -> + m (ParsedEsResponse SMPolicyResponse) +getSMPolicy policyName = performBHRequest $ Requests.getSMPolicy policyName + +-- | 'getSMPolicies' lists SM policies, optionally filtered / paginated. +getSMPolicies :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe GetSMPoliciesQuery -> + m (ParsedEsResponse GetSMPoliciesResponse) +getSMPolicies mQuery = performBHRequest $ Requests.getSMPolicies mQuery + +-- | 'deleteSMPolicy' deletes an SM policy by name. +deleteSMPolicy :: + (MonadBH m, WithBackend OpenSearch2 m) => + SMPolicyName -> + m (ParsedEsResponse DeleteSMPolicyResponse) +deleteSMPolicy policyName = performBHRequest $ Requests.deleteSMPolicy policyName + +-- | 'startSMPolicy' enables an SM policy (sets @enabled=true@). +startSMPolicy :: + (MonadBH m, WithBackend OpenSearch2 m) => + SMPolicyName -> + m (ParsedEsResponse Acknowledged) +startSMPolicy policyName = performBHRequest $ Requests.startSMPolicy policyName + +-- | 'stopSMPolicy' disables an SM policy (sets @enabled=false@). +stopSMPolicy :: + (MonadBH m, WithBackend OpenSearch2 m) => + SMPolicyName -> + m (ParsedEsResponse Acknowledged) +stopSMPolicy policyName = performBHRequest $ Requests.stopSMPolicy policyName + +-- | 'explainSMPolicies' returns the running state of policies matching a +-- name expression (comma list / wildcard). +explainSMPolicies :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + m (ParsedEsResponse SMExplainResponse) +explainSMPolicies policyNames = performBHRequest $ Requests.explainSMPolicies policyNames + +-- | 'getMLStats' fetches ML Commons plugin statistics. Both arguments are +-- optional: 'Nothing' for the node ID queries every node; 'Nothing' for the +-- stat name returns every stat. The endpoint is available whenever the ML +-- Commons plugin is installed (no cluster setting needs to be enabled). +-- +-- For more information see +-- . +getMLStats :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe MLNodeId -> + Maybe MLStatName -> + m (ParsedEsResponse MLStats) +getMLStats mNodeId mStatName = performBHRequest $ Requests.getMLStats mNodeId mStatName + +-- | 'getModel' fetches full metadata for a registered model by its +-- 'ModelId'. +-- +-- For more information see +-- . +getModel :: + (MonadBH m, WithBackend OpenSearch2 m) => + ModelId -> + m (ParsedEsResponse ModelInfo) +getModel modelId = performBHRequest $ Requests.getModel modelId + +-- | 'registerModel' registers a model. Registration is asynchronous; poll +-- the returned @task_id@ via the Get ML Task API. Equivalent to +-- 'registerModelWith' with @deploy = False@. +-- See +registerModel :: + (MonadBH m, WithBackend OpenSearch2 m) => + RegisterModelRequest -> + m (ParsedEsResponse MLTaskAck) +registerModel = performBHRequest . Requests.registerModel + +-- | 'registerModelWith' registers a model with an optional @?deploy=true@ +-- query flag that chains a deploy after successful registration. +-- See +registerModelWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + Bool -> + RegisterModelRequest -> + m (ParsedEsResponse MLTaskAck) +registerModelWith deploy req = performBHRequest $ Requests.registerModelWith deploy req + +-- | 'deployModel' loads a registered model into memory on ML worker nodes. +-- Pass 'Nothing' to let OpenSearch pick eligible nodes; pass a +-- 'DeployModelRequest' to restrict to a node list. Deployment is +-- asynchronous; poll the returned @task_id@ via the Get ML Task API. +-- See +deployModel :: + (MonadBH m, WithBackend OpenSearch2 m) => + ModelId -> + Maybe DeployModelRequest -> + m (ParsedEsResponse MLTaskAck) +deployModel modelId mReq = performBHRequest $ Requests.deployModel modelId mReq + +-- | 'undeployModel' unloads a deployed model from ML worker nodes. +-- Synchronous; returns a node-keyed stats map. +-- See +undeployModel :: + (MonadBH m, WithBackend OpenSearch2 m) => + ModelId -> + m (ParsedEsResponse UndeployModelResponse) +undeployModel modelId = performBHRequest $ Requests.undeployModel modelId + +-- | 'updateModel' updates a subset of a registered model's metadata. +-- See +updateModel :: + (MonadBH m, WithBackend OpenSearch2 m) => + ModelId -> + UpdateModelRequest -> + m (ParsedEsResponse IndexedDocument) +updateModel modelId req = performBHRequest $ Requests.updateModel modelId req + +-- | 'searchModels' searches the model index. +-- See +searchModels :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe Value -> + m (ParsedEsResponse ModelSearchResponse) +searchModels = performBHRequest . Requests.searchModels + +-- | 'listModels' lists models. Historically this hit the +-- @POST /_plugins/_ml/models/_list@ endpoint, but OS 2.x removed POST +-- from @_list@ (it now returns 405). The modern, supported endpoint +-- for listing is @POST /_plugins/_ml/models/_search@ — the same one +-- 'searchModels' uses. Kept as a separate function rather than aliased +-- to 'searchModels' so callers and telemetry can distinguish the two +-- call sites. +listModels :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe Value -> + m (ParsedEsResponse ModelSearchResponse) +listModels = performBHRequest . Requests.listModels + +-- | 'deleteModel' deletes a registered model by id. OpenSearch stores +-- models as documents in @.plugins-ml-model@, so the response is the +-- standard document-delete envelope (parsed here as 'IndexedDocument'), +-- not an 'Acknowledged' ack — identical to 'deleteISMPolicy'. A +-- deployed model must be undeployed before it can be deleted, otherwise +-- the server returns an error which surfaces as an 'EsError'. +-- See +deleteModel :: + (MonadBH m, WithBackend OpenSearch2 m) => + ModelId -> + m (ParsedEsResponse IndexedDocument) +deleteModel modelId = performBHRequest $ Requests.deleteModel modelId + +-- | 'predict' invokes a deployed model. The request body and response are +-- model-specific, so both are opaque 'Value's. +-- +-- For more information see +-- . +predict :: + (MonadBH m, WithBackend OpenSearch2 m) => + AlgorithmName -> + ModelId -> + Value -> + m (ParsedEsResponse Value) +predict algo modelId body = performBHRequest $ Requests.predict algo modelId body + +-- | 'registerAgent' registers an ML Commons agent (OS 2.12+) — a named +-- configuration binding an LLM (or a routed population of sub-agents and +-- tools) behind a server-assigned 'AgentId'. Unlike 'registerModel', +-- registration is synchronous: the response carries the @agent_id@ +-- directly, with no @task_id@ to poll. +-- See +registerAgent :: + (MonadBH m, WithBackend OpenSearch2 m) => + RegisterAgentRequest -> + m (ParsedEsResponse RegisterAgentResponse) +registerAgent = performBHRequest . Requests.registerAgent + +-- | 'getAgent' fetches a registered agent by id. The body is the bare +-- stored agent document, decoded as 'AgentInfo'. +-- See +getAgent :: + (MonadBH m, WithBackend OpenSearch2 m) => + AgentId -> + m (ParsedEsResponse AgentInfo) +getAgent agentId = performBHRequest $ Requests.getAgent agentId + +-- | 'deleteAgent' deletes a registered agent by id. The response is +-- the standard document-delete envelope ('IndexedDocument'). +-- See +deleteAgent :: + (MonadBH m, WithBackend OpenSearch2 m) => + AgentId -> + m (ParsedEsResponse IndexedDocument) +deleteAgent agentId = performBHRequest $ Requests.deleteAgent agentId + +-- | 'searchAgents' searches the agent index via +-- @POST /_plugins/_ml/agents/_search@. +-- See +searchAgents :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe Value -> + m (ParsedEsResponse AgentSearchResponse) +searchAgents = performBHRequest . Requests.searchAgents + +-- | 'executeAgent' runs a registered agent synchronously, returning +-- its 'ExecuteAgentResponse'. +-- See +executeAgent :: + (MonadBH m, WithBackend OpenSearch2 m) => + AgentId -> + ExecuteAgentRequest -> + m (ParsedEsResponse ExecuteAgentResponse) +executeAgent agentId = performBHRequest . Requests.executeAgent agentId + +-- | 'warmupKnnIndices' loads the k-NN native library indices for the given +-- indices into memory on the data nodes, so the first k-NN search against +-- each index does not pay the native-engine load latency. Maps to +-- @GET /_plugins/_knn/warmup/{index}@ (the index segment is rendered as a +-- comma-separated list, matching the OpenSearch multi-target syntax) and +-- returns 'ShardsResult' (the @{\"_shards\":{...}}@ envelope, +-- live-verified against OS 2.19.5 and 3.7.0) on success. The warmup is +-- asynchronous — the response is returned as soon as the load is +-- scheduled. +-- +-- For more information see +-- . +warmupKnnIndices :: + (MonadBH m, WithBackend OpenSearch2 m) => + [IndexName] -> + m ShardsResult +warmupKnnIndices indexNames = performBHRequest $ Requests.warmupKnnIndex indexNames + +-- | 'warmupKnnIndex' is a convenience wrapper around 'warmupKnnIndices' +-- for the common single-index case. See 'warmupKnnIndices' for the +-- multi-index variant. +warmupKnnIndex :: + (MonadBH m, WithBackend OpenSearch2 m) => + IndexName -> + m ShardsResult +warmupKnnIndex indexName = warmupKnnIndices [indexName] + +-- | 'clearKnnCaches' drops the native cache entries that the k-NN plugin +-- maintains for the given indices (the @faiss@ \/ @nmslib@ native library +-- index handles), freeing the associated native-memory reservations. Has +-- no effect on @lucene@ indexes. Maps to +-- @POST /_plugins/_knn/clear_cache/{index}@ (the index segment is rendered +-- as a comma-separated list, matching the OpenSearch multi-target syntax; +-- available since OpenSearch 2.14) and returns 'ShardsResult' (the +-- @{\"_shards\":{...}}@ envelope, live-verified against OS 2.19.5 and +-- 3.7.0) on success. +-- +-- For more information see +-- . +clearKnnCaches :: + (MonadBH m, WithBackend OpenSearch2 m) => + [IndexName] -> + m ShardsResult +clearKnnCaches indexNames = performBHRequest $ Requests.clearKnnCache indexNames + +-- | 'clearKnnCache' is a convenience wrapper around 'clearKnnCaches' for +-- the common single-index case. See 'clearKnnCaches' for the multi-index +-- variant. +clearKnnCache :: + (MonadBH m, WithBackend OpenSearch2 m) => + IndexName -> + m ShardsResult +clearKnnCache indexName = clearKnnCaches [indexName] + +-- | 'getKnnStats' fetches k-NN plugin statistics. Both arguments are +-- optional: 'Nothing' for the node ID queries every node; 'Nothing' for the +-- stat name returns every stat. The response is a flat 'KnnStats' envelope +-- (cluster-level scalars plus a @nodes@ per-node map); navigate it via +-- 'knnStatsEntries'. +-- +-- For more information see +-- . +getKnnStats :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe KnnNodeId -> + Maybe KnnStatName -> + m (ParsedEsResponse KnnStats) +getKnnStats mNodeId mStatName = performBHRequest $ Requests.getKnnStats mNodeId mStatName + +-- | 'getKnnModel' fetches metadata for a trained k-NN model by its +-- 'ModelId'. Maps to @GET /_plugins/_knn/models/{model_id}@. The response is +-- a bare object (no envelope), decoded into 'KnnModel'; the +-- 'knnModelModelBlob' field is large and may be absent when the caller has +-- excluded it via @?filter_path@. +-- +-- For more information see +-- . +getKnnModel :: + (MonadBH m, WithBackend OpenSearch2 m) => + ModelId -> + m (ParsedEsResponse KnnModel) +getKnnModel modelId = performBHRequest $ Requests.getKnnModel modelId + +-- | 'trainKnnModel' schedules asynchronous training of a k-NN native library +-- model (e.g. FAISS IVF) from the vectors in a training index's +-- @knn_vector@ field. Maps to @POST /_plugins/_knn/models/{model_id}/_train@. +-- The request returns as soon as training is scheduled; the +-- 'KnnTrainResponse' echoes the @model_id@ under which training was +-- scheduled. To observe progress, poll 'getKnnModel' and watch +-- 'knnModelState' transition from @training@ to @created@ (success) or +-- @failed@ (consult 'knnModelError' for the cause). +-- +-- Equivalent to 'trainKnnModelWith' with @Nothing@ (no node preference). +-- +-- For more information see +-- . +trainKnnModel :: + (MonadBH m, WithBackend OpenSearch2 m) => + ModelId -> + KnnTrainingRequest -> + m (ParsedEsResponse KnnTrainResponse) +trainKnnModel = trainKnnModelWith Nothing + +-- | 'trainKnnModelWith' extends 'trainKnnModel' with an optional +-- @?preference@ query parameter. Supplying 'Just' a 'KnnNodeId' pins the +-- asynchronous training task to the specified data node, sent on the wire +-- as @?preference={node_id}@; 'Nothing' lets OpenSearch choose the training +-- node. The pinned node must already host a shard of the training index, +-- otherwise OpenSearch rejects the request. +-- +-- For more information see +-- . +trainKnnModelWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe KnnNodeId -> + ModelId -> + KnnTrainingRequest -> + m (ParsedEsResponse KnnTrainResponse) +trainKnnModelWith mNodeId modelId req = + performBHRequest $ Requests.trainKnnModelWith mNodeId modelId req + +-- | 'deleteKnnModel' removes a trained k-NN model by its 'ModelId'. +-- Maps to @DELETE /_plugins/_knn/models/{model_id}@ and returns a +-- 'KnnDeleteModelResponse' echoing the @model_id@ and reporting +-- @result = "deleted"@. Note this is NOT the standard 'Acknowledged' +-- envelope (the k-NN plugin returns a richer response than the typical +-- cluster-level ack). A missing model id surfaces as an 'EsError' via +-- 'StatusDependant', matching 'getKnnModel' and the ML Commons +-- 'deleteModel' precedent. +-- +-- For more information see +-- . +deleteKnnModel :: + (MonadBH m, WithBackend OpenSearch2 m) => + ModelId -> + m (ParsedEsResponse KnnDeleteModelResponse) +deleteKnnModel modelId = performBHRequest $ Requests.deleteKnnModel modelId + +-- | 'searchKnnModels' searches the @.opensearch-knn-models@ system index +-- via @POST /_plugins/_knn/models/_search@. The caller drives the query +-- through the standard 'Search' DSL (paginate with @from@\/@size@, filter +-- with 'queryBody', and exclude the large 'knnModelModelBlob' via the +-- 'source' projection). Returns the standard search envelope as a +-- 'SearchResult' whose hits carry a 'KnnModel' in each @_source@. +-- +-- Mirrors 'knnSearch' in shape; see +-- 'Database.Bloodhound.OpenSearch2.Requests.searchKnnModels' for the +-- request-level details. +-- +-- For more information see +-- . +searchKnnModels :: + (MonadBH m, WithBackend OpenSearch2 m) => + Search -> + m (SearchResult KnnModel) +searchKnnModels search = performBHRequest $ Requests.searchKnnModels search + +-- | 'submitOSAsyncSearch' submits a 'Search' for asynchronous execution via +-- the OpenSearch async search plugin (@POST /_plugins/_asynchronous_search@), +-- returning immediately with an id and partial results. This is the +-- OpenSearch-plugin-path analogue of the Elasticsearch 'submitAsyncSearch'; +-- poll the returned id with 'getOSAsyncSearch' until 'asyncSearchIsRunning' +-- is @False@. +-- +-- For more information see +-- . +submitOSAsyncSearch :: + (FromJSON a, MonadBH m, WithBackend OpenSearch2 m) => + Search -> + m (AsyncSearchResult a) +submitOSAsyncSearch = performBHRequest . Requests.submitOSAsyncSearch + +-- | Like 'submitOSAsyncSearch' but accepts 'AsyncSearchSubmitOptions' +-- carrying the URI parameters documented for +-- @POST /_plugins/_asynchronous_search@ (@wait_for_completion@, +-- @keep_on_completion@, @keep_alive@). The Elasticsearch-only +-- 'assoBatchedReduceSize' and 'assoCcsMinimizeRoundtrips' are silently +-- dropped. 'defaultAsyncSearchSubmitOptions' makes this byte-for-byte +-- equivalent to 'submitOSAsyncSearch'. +-- +-- For more information see +-- . +submitOSAsyncSearchWith :: + (FromJSON a, MonadBH m, WithBackend OpenSearch2 m) => + AsyncSearchSubmitOptions -> + Search -> + m (AsyncSearchResult a) +submitOSAsyncSearchWith opts = performBHRequest . Requests.submitOSAsyncSearchWith opts + +-- | 'getOSAsyncSearch' polls an OpenSearch async search by id, returning its +-- current state and (partial or final) results. Maps to +-- @GET /_plugins/_asynchronous_search/{id}@. +-- +-- For more information see +-- . +getOSAsyncSearch :: + (FromJSON a, MonadBH m, WithBackend OpenSearch2 m) => + AsyncSearchId -> + m (AsyncSearchResult a) +getOSAsyncSearch = performBHRequest . Requests.getOSAsyncSearch + +-- | 'deleteOSAsyncSearch' deletes an OpenSearch async search result and its +-- context by id. Maps to @DELETE /_plugins/_asynchronous_search/{id}@ and returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteOSAsyncSearch :: + (MonadBH m, WithBackend OpenSearch2 m) => + AsyncSearchId -> + m Acknowledged +deleteOSAsyncSearch = performBHRequest . Requests.deleteOSAsyncSearch + +-- | 'getOSAsyncSearchStats' fetches cluster-wide async-search statistics. +-- See 'Database.Bloodhound.OpenSearch2.Requests.getOSAsyncSearchStats'. +getOSAsyncSearchStats :: + (MonadBH m, WithBackend OpenSearch2 m) => + m AsyncSearchStatsResponse +getOSAsyncSearchStats = performBHRequest Requests.getOSAsyncSearchStats + +-- | 'sqlQuery' executes a SQL query via the OpenSearch SQL plugin +-- (@POST /_plugins/_sql@). Returns a JDBC-style rowset ('SQLResult'). Use +-- 'sqlRequestFetchSize' to opt into cursor pagination, then walk subsequent +-- pages with 'sqlQueryNextPage' and release an unfinished cursor with +-- 'closeSqlCursor'. +-- +-- For more information see +-- . +sqlQuery :: + (MonadBH m, WithBackend OpenSearch2 m) => + SQLRequest -> + m (ParsedEsResponse SQLResult) +sqlQuery = performBHRequest . Requests.sqlQuery + +-- | 'sqlQueryNextPage' fetches the next page of a paginated SQL result by +-- POSTing the opaque 'SQLCursor' returned by a previous 'sqlQuery' or +-- 'sqlQueryNextPage' call. The server drops @schema@, @total@, @size@ and +-- @status@ from continuation responses, so every 'SQLResult' field except +-- 'sqlResultDatarows' is 'Maybe'. +-- +-- For more information see +-- . +sqlQueryNextPage :: + (MonadBH m, WithBackend OpenSearch2 m) => + SQLCursor -> + m (ParsedEsResponse SQLResult) +sqlQueryNextPage = performBHRequest . Requests.sqlQueryNextPage + +-- | 'closeSqlCursor' releases the server-side context held by a SQL +-- pagination cursor (@POST /_plugins/_sql/close@). Call this when you stop +-- reading before the cursor is naturally exhausted. +-- +-- For more information see +-- . +closeSqlCursor :: + (MonadBH m, WithBackend OpenSearch2 m) => + SQLCursor -> + m (ParsedEsResponse SQLCloseResult) +closeSqlCursor = performBHRequest . Requests.closeSqlCursor + +-- | 'explainSQL' translates a SQL query into the underlying query DSL without +-- executing it (@POST /_plugins/_sql/_explain@). The response shape varies by +-- query and plugin version, so it is returned as an opaque 'Value'. +-- +-- For more information see +-- . +explainSQL :: + (MonadBH m, WithBackend OpenSearch2 m) => + SQLRequest -> + m (ParsedEsResponse Value) +explainSQL = performBHRequest . Requests.explainSQL + +-- | 'pplQuery' executes a PPL (Piped Processing Language) query via the +-- OpenSearch SQL plugin's PPL endpoint (@POST /_plugins/_ppl@). Returns the +-- same JDBC-style rowset shape as 'sqlQuery' (typed as 'PPLResult'). PPL +-- does not support cursor pagination. +-- +-- For more information see +-- . +pplQuery :: + (MonadBH m, WithBackend OpenSearch2 m) => + PPLRequest -> + m (ParsedEsResponse PPLResult) +pplQuery = performBHRequest . Requests.pplQuery + +-- | 'explainPPL' translates a PPL query into the underlying query DSL without +-- executing it (@POST /_plugins/_ppl/_explain@). The response shape varies by +-- query and plugin version, so it is returned as an opaque 'Value'. +-- +-- For more information see +-- . +explainPPL :: + (MonadBH m, WithBackend OpenSearch2 m) => + PPLRequest -> + m (ParsedEsResponse Value) +explainPPL = performBHRequest . Requests.explainPPL + +-- | 'getSQLStats' fetches SQL plugin statistics +-- (@GET /_plugins/_sql/stats@). The endpoint is node-level only (the +-- plugin documents that cluster-level stats are not implemented), so the +-- response describes only the node you hit; there is no @nodes@ sub-key +-- to navigate. The body is decoded as a flat 'SQLPluginStats' map keyed +-- by metric name because the metric-name set grows across OpenSearch +-- releases. +-- +-- For more information see +-- . +getSQLStats :: + (MonadBH m, WithBackend OpenSearch2 m) => + m (ParsedEsResponse SQLPluginStats) +getSQLStats = performBHRequest Requests.getSQLStats + +-- ========================================================================= +-- Notifications plugin +-- ========================================================================= + +-- | 'createNotificationConfig' creates a notification channel +-- configuration via the Notifications plugin +-- (@POST /_plugins/_notifications/configs@). The server assigns the +-- @config_id@ and echoes it in the 'CreateNotificationConfigResponse'. +-- Equivalent to 'createNotificationConfigWith' with 'Nothing'. +-- +-- For more information see +-- . +createNotificationConfig :: + (MonadBH m, WithBackend OpenSearch2 m) => + NotificationConfig -> + m (ParsedEsResponse CreateNotificationConfigResponse) +createNotificationConfig = performBHRequest . Requests.createNotificationConfig + +-- | 'createNotificationConfigWith' is the parameterized variant of +-- 'createNotificationConfig': the optional 'Text' is forwarded as the +-- request's @config_id@. Pass 'Nothing' for a server-assigned id; pass +-- @'Just' id@ for a stable identifier (a duplicate surfaces as HTTP +-- 409, decoded as an 'EsError' via 'StatusDependant'). +-- See . +createNotificationConfigWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe Text -> + NotificationConfig -> + m (ParsedEsResponse CreateNotificationConfigResponse) +createNotificationConfigWith mConfigId config = + performBHRequest $ Requests.createNotificationConfigWith mConfigId config + +-- | 'deleteNotificationConfig' removes a notification channel +-- configuration by @config_id@ via the Notifications plugin +-- (@DELETE /_plugins/_notifications/configs/{config_id}@). The result +-- is a 'DeleteNotificationConfigResponse' mapping the id to its +-- per-id deletion status; use 'deleteResponseAllOK' for a quick +-- success check or 'deleteResponseStatus' for the raw status string. +-- A 404 (unknown @config_id@) surfaces as 'Left' 'EsError'. +-- +-- For more information see +-- . +deleteNotificationConfig :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + m (ParsedEsResponse DeleteNotificationConfigResponse) +deleteNotificationConfig = + performBHRequest . Requests.deleteNotificationConfig + +-- | 'getNotificationConfigs' lists every notification channel +-- configuration (@GET /_plugins/_notifications/configs@), returning +-- each as a 'NotificationConfigEntry'. Equivalent to +-- 'getNotificationConfigsWith' with 'defaultNotificationListOptions'. +-- +-- For more information see +-- . +getNotificationConfigs :: + (MonadBH m, WithBackend OpenSearch2 m) => + m (ParsedEsResponse [NotificationConfigEntry]) +getNotificationConfigs = performBHRequest Requests.getNotificationConfigs + +-- | 'getNotificationConfigsWith' is the parameterized variant of +-- 'getNotificationConfigs': the supplied 'NotificationListOptions' are +-- forwarded as query-string parameters. Pass +-- 'defaultNotificationListOptions' for the plain no-arg GET. +-- +-- For more information see +-- . +getNotificationConfigsWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + NotificationListOptions -> + m (ParsedEsResponse [NotificationConfigEntry]) +getNotificationConfigsWith opts = + performBHRequest $ Requests.getNotificationConfigsWith opts + +-- | 'getNotificationChannels' lists every notification channel +-- (@GET /_plugins/_notifications/channels@) as a lightweight 'Channel' +-- summary view (no transport details). Equivalent to +-- 'getNotificationChannelsWith' with 'defaultNotificationListOptions'. +-- +-- For more information see +-- . +getNotificationChannels :: + (MonadBH m, WithBackend OpenSearch2 m) => + m (ParsedEsResponse [Channel]) +getNotificationChannels = performBHRequest Requests.getNotificationChannels + +-- | 'getNotificationChannelsWith' is the parameterized variant of +-- 'getNotificationChannels': the supplied 'NotificationListOptions' are +-- forwarded as query-string parameters. Pass +-- 'defaultNotificationListOptions' for the plain no-arg GET. +-- +-- For more information see +-- . +getNotificationChannelsWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + NotificationListOptions -> + m (ParsedEsResponse [Channel]) +getNotificationChannelsWith opts = + performBHRequest $ Requests.getNotificationChannelsWith opts + +-- | 'getNotificationConfig' fetches a single notification channel +-- configuration by id. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getNotificationConfig'. +getNotificationConfig :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + m (ParsedEsResponse (Maybe NotificationConfigEntry)) +getNotificationConfig = performBHRequest . Requests.getNotificationConfig + +-- | 'updateNotificationConfig' replaces a notification channel +-- configuration by id. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateNotificationConfig'. +updateNotificationConfig :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + NotificationConfig -> + m (ParsedEsResponse CreateNotificationConfigResponse) +updateNotificationConfig configId config = + performBHRequest $ Requests.updateNotificationConfig configId config + +-- | 'deleteNotificationConfigs' is the batch variant of +-- 'deleteNotificationConfig'. See +-- 'Database.Bloodhound.OpenSearch2.Requests.deleteNotificationConfigs'. +deleteNotificationConfigs :: + (MonadBH m, WithBackend OpenSearch2 m) => + NonEmpty Text -> + m (ParsedEsResponse DeleteNotificationConfigResponse) +deleteNotificationConfigs = + performBHRequest . Requests.deleteNotificationConfigs + +-- | 'getNotificationFeatures' lists supported channel configuration +-- types. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getNotificationFeatures'. +getNotificationFeatures :: + (MonadBH m, WithBackend OpenSearch2 m) => + m (ParsedEsResponse NotificationFeaturesResponse) +getNotificationFeatures = performBHRequest Requests.getNotificationFeatures + +-- | 'sendTestNotification' triggers a one-shot probe delivery to a +-- channel. See +-- 'Database.Bloodhound.OpenSearch2.Requests.sendTestNotification'. +sendTestNotification :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + m (ParsedEsResponse TestNotificationResponse) +sendTestNotification = + performBHRequest . Requests.sendTestNotification + +-- ========================================================================= +-- Alerting plugin +-- ========================================================================= + +-- | 'createMonitor' creates an alerting monitor. See +-- 'Database.Bloodhound.OpenSearch2.Requests.createMonitor' for the +-- underlying request and the wire-shape details. +createMonitor :: + (MonadBH m, WithBackend OpenSearch2 m) => + Monitor -> + m MonitorResponse +createMonitor monitor = performBHRequest $ Requests.createMonitor monitor + +-- | 'getMonitor' fetches a monitor by id. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getMonitor'. +getMonitor :: + (MonadBH m, WithBackend OpenSearch2 m) => + MonitorId -> + m Monitor +getMonitor monitorId = performBHRequest $ Requests.getMonitor monitorId + +-- | 'updateMonitor' replaces a monitor. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateMonitor'. +updateMonitor :: + (MonadBH m, WithBackend OpenSearch2 m) => + MonitorId -> + Monitor -> + m MonitorResponse +updateMonitor monitorId monitor = performBHRequest $ Requests.updateMonitor monitorId monitor + +-- | 'updateMonitorWith' replaces a monitor with an optional +-- optimistic-concurrency guard (@if_seq_no@ \/ @if_primary_term@). See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateMonitorWith'. +updateMonitorWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + MonitorId -> + Monitor -> + Maybe (Word64, Word64) -> + m MonitorResponse +updateMonitorWith monitorId monitor mOcc = + performBHRequest $ Requests.updateMonitorWith monitorId monitor mOcc + +-- | 'deleteMonitor' deletes a monitor by id. Returns the bare +-- Elasticsearch delete-document response (see 'DeleteMonitorResponse' for +-- why this deviates from @m 'Acknowledged'@). +deleteMonitor :: + (MonadBH m, WithBackend OpenSearch2 m) => + MonitorId -> + m DeleteMonitorResponse +deleteMonitor monitorId = performBHRequest $ Requests.deleteMonitor monitorId + +-- | 'searchMonitors' searches the monitor store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchMonitors'. +searchMonitors :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe MonitorsSearchQuery -> + m (ParsedEsResponse SearchMonitorsResponse) +searchMonitors = performBHRequest . Requests.searchMonitors + +-- | 'executeMonitor' runs a monitor immediately (out of schedule). See +-- 'Database.Bloodhound.OpenSearch2.Requests.executeMonitor'. +executeMonitor :: + (MonadBH m, WithBackend OpenSearch2 m) => + MonitorId -> + Maybe ExecuteMonitorRequest -> + m (ParsedEsResponse ExecuteMonitorResponse) +executeMonitor monitorId mRequest = + performBHRequest $ Requests.executeMonitor monitorId mRequest + +-- ========================================================================= +-- Security Analytics plugin +-- ========================================================================= + +-- | 'createSADetector' creates a Security Analytics detector. See +-- 'Database.Bloodhound.OpenSearch2.Requests.createSADetector' for the +-- underlying request and the wire-shape details. +createSADetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + SADetector -> + m SADetectorResponse +createSADetector detector = performBHRequest $ Requests.createSADetector detector + +-- | 'getSADetector' fetches a detector by id. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getSADetector'. +getSADetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + m SADetector +getSADetector detectorId = performBHRequest $ Requests.getSADetector detectorId + +-- | 'updateSADetector' replaces a detector. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateSADetector'. +updateSADetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + SADetector -> + m SADetectorResponse +updateSADetector detectorId detector = performBHRequest $ Requests.updateSADetector detectorId detector + +-- | 'deleteSADetector' deletes a detector by id. See +-- 'Database.Bloodhound.OpenSearch2.Requests.deleteSADetector'. +deleteSADetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + m DeleteSADetectorResponse +deleteSADetector detectorId = performBHRequest $ Requests.deleteSADetector detectorId + +-- | 'searchSAPrePackagedRules' searches the pre-packaged Sigma rules +-- index. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchSAPrePackagedRules' +-- for the underlying request and the bead-acceptance deviation note. +searchSAPrePackagedRules :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe SARulesQuery -> + m (ParsedEsResponse SARulesSearchResponse) +searchSAPrePackagedRules = performBHRequest . Requests.searchSAPrePackagedRules + +-- | 'searchSACustomRules' searches the custom Sigma rules index. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchSACustomRules'. +searchSACustomRules :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe SARulesQuery -> + m (ParsedEsResponse SARulesSearchResponse) +searchSACustomRules = performBHRequest . Requests.searchSACustomRules + +-- | 'createSACustomRule' creates a custom Sigma rule. See +-- 'Database.Bloodhound.OpenSearch2.Requests.createSACustomRule' for the +-- underlying request and the raw-YAML-body detail. +createSACustomRule :: + (MonadBH m, WithBackend OpenSearch2 m) => + SADetectorType -> + Text -> + m SARuleResponse +createSACustomRule category sigmaYaml = + performBHRequest $ Requests.createSACustomRule category sigmaYaml + +-- | 'updateSACustomRule' replaces a custom Sigma rule. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateSACustomRule'. +updateSACustomRule :: + (MonadBH m, WithBackend OpenSearch2 m) => + RuleId -> + SADetectorType -> + Bool -> + Text -> + m SARuleResponse +updateSACustomRule ruleId category forced sigmaYaml = + performBHRequest $ Requests.updateSACustomRule ruleId category forced sigmaYaml + +-- | 'deleteSACustomRule' deletes a custom Sigma rule. See +-- 'Database.Bloodhound.OpenSearch2.Requests.deleteSACustomRule'. +deleteSACustomRule :: + (MonadBH m, WithBackend OpenSearch2 m) => + RuleId -> + Bool -> + m DeleteSARuleResponse +deleteSACustomRule ruleId forced = + performBHRequest $ Requests.deleteSACustomRule ruleId forced + +-- | 'searchSADetectors' searches the detector store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchSADetectors'. +searchSADetectors :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe SADetectorsSearchQuery -> + m (ParsedEsResponse SADetectorsSearchResponse) +searchSADetectors = performBHRequest . Requests.searchSADetectors + +-- | 'getSAMappingsView' returns a mappings view for an index. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getSAMappingsView'. +getSAMappingsView :: + (MonadBH m, WithBackend OpenSearch2 m) => + SAMappingsViewRequest -> + m SAMappingsViewResponse +getSAMappingsView = performBHRequest . Requests.getSAMappingsView + +-- | 'createSAMappings' creates the field-to-alias mappings for an +-- index. See +-- 'Database.Bloodhound.OpenSearch2.Requests.createSAMappings'. +createSAMappings :: + (MonadBH m, WithBackend OpenSearch2 m) => + SACreateMappingsRequest -> + m Acknowledged +createSAMappings = performBHRequest . Requests.createSAMappings + +-- | 'getSAMappings' fetches the persisted mappings for an index. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getSAMappings'. +getSAMappings :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + m SAGetMappingsResponse +getSAMappings = performBHRequest . Requests.getSAMappings + +-- | 'updateSAMappings' updates a single field mapping for an index. +-- See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateSAMappings'. +updateSAMappings :: + (MonadBH m, WithBackend OpenSearch2 m) => + SAUpdateMappingsRequest -> + m Acknowledged +updateSAMappings = performBHRequest . Requests.updateSAMappings + +-- | 'getSAAlertsWith' lists Security Analytics alert documents with the +-- supplied options. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getSAAlertsWith'. +getSAAlertsWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + SAGetAlertsOptions -> + m SAGetAlertsResponse +getSAAlertsWith = performBHRequest . Requests.getSAAlertsWith + +-- | 'getSAAlerts' lists the alert documents of a single detector. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getSAAlerts'. +getSAAlerts :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + m [SAAlert] +getSAAlerts = performBHRequest . Requests.getSAAlerts + +-- | 'acknowledgeSADetectorAlerts' acknowledges one or more active +-- alerts of a detector. See +-- 'Database.Bloodhound.OpenSearch2.Requests.acknowledgeSADetectorAlerts'. +acknowledgeSADetectorAlerts :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + [Text] -> + m AcknowledgeSADetectorAlertsResponse +acknowledgeSADetectorAlerts = (performBHRequest .) . Requests.acknowledgeSADetectorAlerts + +-- | 'searchSAFindings' lists Security Analytics finding documents. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchSAFindings'. +searchSAFindings :: + (MonadBH m, WithBackend OpenSearch2 m) => + SASearchFindingsOptions -> + m (ParsedEsResponse SASearchFindingsResponse) +searchSAFindings = performBHRequest . Requests.searchSAFindings + +-- | 'createSACorrelationRule' creates a correlation rule. See +-- 'Database.Bloodhound.OpenSearch2.Requests.createSACorrelationRule'. +createSACorrelationRule :: + (MonadBH m, WithBackend OpenSearch2 m) => + CreateSACorrelationRuleRequest -> + m CreateSACorrelationRuleResponse +createSACorrelationRule = performBHRequest . Requests.createSACorrelationRule + +-- | 'getSACorrelations' lists pairwise finding correlations within a +-- time window. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getSACorrelations'. +getSACorrelations :: + (MonadBH m, WithBackend OpenSearch2 m) => + GetSACorrelationsOptions -> + m GetSACorrelationsResponse +getSACorrelations = performBHRequest . Requests.getSACorrelations + +-- | 'findSACorrelation' lists correlated findings for a given finding. +-- See +-- 'Database.Bloodhound.OpenSearch2.Requests.findSACorrelation'. +findSACorrelation :: + (MonadBH m, WithBackend OpenSearch2 m) => + FindSACorrelationOptions -> + m FindSACorrelationResponse +findSACorrelation = performBHRequest . Requests.findSACorrelation + +-- | 'searchSACorrelationAlerts' lists correlation alerts. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchSACorrelationAlerts'. +searchSACorrelationAlerts :: + (MonadBH m, WithBackend OpenSearch2 m) => + SearchSACorrelationAlertsOptions -> + m SearchSACorrelationAlertsResponse +searchSACorrelationAlerts = performBHRequest . Requests.searchSACorrelationAlerts + +-- | 'acknowledgeSACorrelationAlerts' acknowledges one or more +-- correlation alerts. See +-- 'Database.Bloodhound.OpenSearch2.Requests.acknowledgeSACorrelationAlerts'. +acknowledgeSACorrelationAlerts :: + (MonadBH m, WithBackend OpenSearch2 m) => + [Text] -> + m AcknowledgeSACorrelationAlertsResponse +acknowledgeSACorrelationAlerts = performBHRequest . Requests.acknowledgeSACorrelationAlerts + +-- | 'createSALogType' creates a custom log type. See +-- 'Database.Bloodhound.OpenSearch2.Requests.createSALogType'. +createSALogType :: + (MonadBH m, WithBackend OpenSearch2 m) => + SALogType -> + m SALogTypeResponse +createSALogType = performBHRequest . Requests.createSALogType + +-- | 'searchSALogTypes' searches the log type store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchSALogTypes'. +searchSALogTypes :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe SALogTypeSearchQuery -> + m (ParsedEsResponse SALogTypesSearchResponse) +searchSALogTypes = performBHRequest . Requests.searchSALogTypes + +-- | 'updateSALogType' replaces a custom log type. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateSALogType'. +updateSALogType :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + SALogType -> + m SALogTypeResponse +updateSALogType = (performBHRequest .) . Requests.updateSALogType + +-- | 'deleteSALogType' deletes a custom log type. See +-- 'Database.Bloodhound.OpenSearch2.Requests.deleteSALogType'. +deleteSALogType :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + m DeleteSALogTypeResponse +deleteSALogType = performBHRequest . Requests.deleteSALogType + +-- | 'getDestinations' lists every configured alerting destination. +-- Returns the bare 'Destination' list (the paging envelope is +-- discarded). See +-- 'Database.Bloodhound.OpenSearch2.Requests.getDestinations' for the +-- underlying request and the wire-shape details. +getDestinations :: + (MonadBH m, WithBackend OpenSearch2 m) => + m [Destination] +getDestinations = performBHRequest Requests.getDestinations + +-- | 'getDestinationsWith' is the parameterized variant of +-- 'getDestinations'. Returns the full 'GetDestinationsResponse' +-- envelope (including @totalDestinations@). See +-- 'Database.Bloodhound.OpenSearch2.Requests.getDestinationsWith'. +getDestinationsWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + DestinationListOptions -> + m GetDestinationsResponse +getDestinationsWith opts = + performBHRequest $ Requests.getDestinationsWith opts + +-- | 'createDestination' creates an alerting destination. See +-- 'Database.Bloodhound.OpenSearch2.Requests.createDestination' for the +-- underlying request and the wire-shape details. +createDestination :: + (MonadBH m, WithBackend OpenSearch2 m) => + Destination -> + m DestinationResponse +createDestination destination = + performBHRequest $ Requests.createDestination destination + +-- | 'updateDestination' replaces a destination. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateDestination'. +updateDestination :: + (MonadBH m, WithBackend OpenSearch2 m) => + DestinationId -> + Destination -> + m DestinationResponse +updateDestination destId destination = + performBHRequest $ Requests.updateDestination destId destination + +-- | 'deleteDestination' deletes a destination by id. Returns the bare +-- Elasticsearch delete-document response (see 'DeleteDestinationResponse' +-- for why this deviates from @m 'Acknowledged'@). +deleteDestination :: + (MonadBH m, WithBackend OpenSearch2 m) => + DestinationId -> + m DeleteDestinationResponse +deleteDestination destId = + performBHRequest $ Requests.deleteDestination destId + +-- | 'getAlertsWith' lists alert documents, returning the full +-- 'GetAlertsResponse' envelope (including @totalAlerts@). See +-- 'Database.Bloodhound.OpenSearch2.Requests.getAlertsWith'. +getAlertsWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + GetAlertsOptions -> + m GetAlertsResponse +getAlertsWith opts = performBHRequest $ Requests.getAlertsWith opts + +-- | 'getAlerts' lists every active alert, projecting out the bare +-- @['Alert']@ list. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getAlerts'. +getAlerts :: + (MonadBH m, WithBackend OpenSearch2 m) => + m [Alert] +getAlerts = performBHRequest Requests.getAlerts + +-- | 'acknowledgeAlert' acknowledges one or more active alerts of a +-- monitor. See +-- 'Database.Bloodhound.OpenSearch2.Requests.acknowledgeAlert'. +acknowledgeAlert :: + (MonadBH m, WithBackend OpenSearch2 m) => + MonitorId -> + [Text] -> + m AcknowledgeAlertResponse +acknowledgeAlert monitorId alertIds = + performBHRequest $ Requests.acknowledgeAlert monitorId alertIds + +-- | 'getMonitorStats' fetches alerting scheduler statistics. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getMonitorStats'. +getMonitorStats :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe Text -> + Maybe Text -> + m (ParsedEsResponse MonitorStats) +getMonitorStats mNodeId mMetric = + performBHRequest $ Requests.getMonitorStats mNodeId mMetric + +-- | 'createEmailAccount' creates a legacy alerting email account. See +-- 'Database.Bloodhound.OpenSearch2.Requests.createEmailAccount'. +createEmailAccount :: + (MonadBH m, WithBackend OpenSearch2 m) => + EmailAccount -> + m EmailAccountResponse +createEmailAccount account = + performBHRequest $ Requests.createEmailAccount account + +-- | 'getEmailAccount' fetches an email account by id. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getEmailAccount'. +getEmailAccount :: + (MonadBH m, WithBackend OpenSearch2 m) => + EmailAccountId -> + m EmailAccount +getEmailAccount emailAccountId = + performBHRequest $ Requests.getEmailAccount emailAccountId + +-- | 'updateEmailAccount' replaces an email account. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateEmailAccount'. +updateEmailAccount :: + (MonadBH m, WithBackend OpenSearch2 m) => + EmailAccountId -> + EmailAccount -> + m EmailAccountResponse +updateEmailAccount emailAccountId account = + performBHRequest $ Requests.updateEmailAccount emailAccountId account + +-- | 'updateEmailAccountWith' replaces an email account with an optional +-- optimistic-concurrency guard. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateEmailAccountWith'. +updateEmailAccountWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + EmailAccountId -> + EmailAccount -> + Maybe (Word64, Word64) -> + m EmailAccountResponse +updateEmailAccountWith emailAccountId account mOcc = + performBHRequest $ Requests.updateEmailAccountWith emailAccountId account mOcc + +-- | 'deleteEmailAccount' deletes an email account by id. Returns the +-- bare Elasticsearch delete-document response (see +-- 'DeleteEmailAccountResponse'). +deleteEmailAccount :: + (MonadBH m, WithBackend OpenSearch2 m) => + EmailAccountId -> + m DeleteEmailAccountResponse +deleteEmailAccount emailAccountId = + performBHRequest $ Requests.deleteEmailAccount emailAccountId + +-- | 'createEmailGroup' creates a legacy alerting email group. See +-- 'Database.Bloodhound.OpenSearch2.Requests.createEmailGroup'. +createEmailGroup :: + (MonadBH m, WithBackend OpenSearch2 m) => + EmailGroup -> + m EmailGroupResponse +createEmailGroup group = + performBHRequest $ Requests.createEmailGroup group + +-- | 'getEmailGroup' fetches an email group by id. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getEmailGroup'. +getEmailGroup :: + (MonadBH m, WithBackend OpenSearch2 m) => + EmailGroupId -> + m EmailGroup +getEmailGroup emailGroupId = + performBHRequest $ Requests.getEmailGroup emailGroupId + +-- | 'updateEmailGroup' replaces an email group. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateEmailGroup'. +updateEmailGroup :: + (MonadBH m, WithBackend OpenSearch2 m) => + EmailGroupId -> + EmailGroup -> + m EmailGroupResponse +updateEmailGroup emailGroupId group = + performBHRequest $ Requests.updateEmailGroup emailGroupId group + +-- | 'updateEmailGroupWith' replaces an email group with an optional +-- optimistic-concurrency guard. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateEmailGroupWith'. +updateEmailGroupWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + EmailGroupId -> + EmailGroup -> + Maybe (Word64, Word64) -> + m EmailGroupResponse +updateEmailGroupWith emailGroupId group mOcc = + performBHRequest $ Requests.updateEmailGroupWith emailGroupId group mOcc + +-- | 'deleteEmailGroup' deletes an email group by id. Returns the bare +-- Elasticsearch delete-document response (see 'DeleteEmailGroupResponse'). +deleteEmailGroup :: + (MonadBH m, WithBackend OpenSearch2 m) => + EmailGroupId -> + m DeleteEmailGroupResponse +deleteEmailGroup emailGroupId = + performBHRequest $ Requests.deleteEmailGroup emailGroupId + +-- | 'getDestination' fetches a single destination by id. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getDestination'. +getDestination :: + (MonadBH m, WithBackend OpenSearch2 m) => + DestinationId -> + m GetDestinationsResponse +getDestination destId = + performBHRequest $ Requests.getDestination destId + +-- | 'searchEmailAccounts' searches the email account store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchEmailAccounts'. +searchEmailAccounts :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe EmailAccountSearchQuery -> + m (ParsedEsResponse SearchEmailAccountsResponse) +searchEmailAccounts mQuery = + performBHRequest $ Requests.searchEmailAccounts mQuery + +-- | 'searchEmailGroups' searches the email group store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchEmailGroups'. +searchEmailGroups :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe EmailGroupSearchQuery -> + m (ParsedEsResponse SearchEmailGroupsResponse) +searchEmailGroups mQuery = + performBHRequest $ Requests.searchEmailGroups mQuery + +-- | 'searchFindings' searches the findings index. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchFindings'. +searchFindings :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe FindingsSearchOptions -> + m (ParsedEsResponse SearchFindingsResponse) +searchFindings mOpts = + performBHRequest $ Requests.searchFindings mOpts + +-- | 'createComment' adds a comment to an alert. See +-- 'Database.Bloodhound.OpenSearch2.Requests.createComment'. +createComment :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + CreateCommentRequest -> + m CommentResponse +createComment alertId req = + performBHRequest $ Requests.createComment alertId req + +-- | 'updateComment' modifies a comment. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateComment'. +updateComment :: + (MonadBH m, WithBackend OpenSearch2 m) => + CommentId -> + UpdateCommentRequest -> + m CommentResponse +updateComment commentId req = + performBHRequest $ Requests.updateComment commentId req + +-- | 'searchComments' searches comments. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchComments'. +searchComments :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe CommentSearchQuery -> + m (ParsedEsResponse SearchCommentsResponse) +searchComments mQuery = + performBHRequest $ Requests.searchComments mQuery + +-- | 'deleteComment' removes a comment. See +-- 'Database.Bloodhound.OpenSearch2.Requests.deleteComment'. +deleteComment :: + (MonadBH m, WithBackend OpenSearch2 m) => + CommentId -> + m DeleteCommentResponse +deleteComment commentId = + performBHRequest $ Requests.deleteComment commentId + +-- ========================================================================= +-- Anomaly Detection plugin +-- ========================================================================= + +-- | 'createDetector' creates an anomaly detector. See +-- 'Requests.createDetector' for semantics. +-- See +createDetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + Detector -> + m (ParsedEsResponse CreateDetectorResponse) +createDetector = performBHRequest . Requests.createDetector + +-- | 'getDetector' fetches a detector by id. See 'Requests.getDetector' for +-- semantics. +-- See +getDetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + GetDetectorParams -> + m (ParsedEsResponse GetDetectorResponse) +getDetector detectorId params = + performBHRequest $ Requests.getDetector detectorId params + +-- | 'previewDetector' previews a detector on historical data. See +-- 'Requests.previewDetector' for semantics. +-- See +previewDetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + PreviewRequest -> + m (ParsedEsResponse PreviewResponse) +previewDetector detectorId req = + performBHRequest $ Requests.previewDetector detectorId req + +-- | 'previewDetectorInline' previews an unpersisted or body-referenced +-- detector. See 'Requests.previewDetectorInline' for semantics. +-- See +previewDetectorInline :: + (MonadBH m, WithBackend OpenSearch2 m) => + PreviewRequest -> + m (ParsedEsResponse PreviewResponse) +previewDetectorInline req = + performBHRequest $ Requests.previewDetectorInline req + +-- | 'startDetector' starts a detector job. See +-- 'Requests.startDetector' for semantics. +-- See +startDetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + Maybe StartDetectorJobRequest -> + m (ParsedEsResponse DetectorJobAcknowledgment) +startDetector detectorId mReq = + performBHRequest $ Requests.startDetector detectorId mReq + +-- | 'stopDetector' stops a detector job. See 'Requests.stopDetector' +-- for semantics. +-- See +stopDetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + Bool -> + m (ParsedEsResponse DetectorJobAcknowledgment) +stopDetector detectorId historical = + performBHRequest $ Requests.stopDetector detectorId historical + +-- | 'updateDetector' replaces a detector. See +-- 'Requests.updateDetector' for semantics. +-- See +updateDetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + Detector -> + m (ParsedEsResponse CreateDetectorResponse) +updateDetector detectorId detector = + performBHRequest $ Requests.updateDetector detectorId detector + +-- | 'updateDetectorWith' replaces a detector with an optional +-- optimistic-concurrency guard. See 'Requests.updateDetectorWith'. +-- See +updateDetectorWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + Detector -> + Maybe (Word64, Word64) -> + m (ParsedEsResponse CreateDetectorResponse) +updateDetectorWith detectorId detector mOcc = + performBHRequest $ Requests.updateDetectorWith detectorId detector mOcc + +-- | 'deleteDetector' deletes a detector by id. See 'Requests.deleteDetector'. +-- See +deleteDetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + m (ParsedEsResponse DeleteDetectorResponse) +deleteDetector detectorId = + performBHRequest $ Requests.deleteDetector detectorId + +-- | 'validateDetector' validates a detector configuration. See +-- 'Requests.validateDetector'. +-- See +validateDetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + ValidateDetectorMode -> + Detector -> + m (ParsedEsResponse ValidateDetectorResponse) +validateDetector mode detector = + performBHRequest $ Requests.validateDetector mode detector + +-- | 'searchDetectors' searches the detector-config index. See +-- 'Requests.searchDetectors'. +-- See +searchDetectors :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe Value -> + m (ParsedEsResponse SearchDetectorsResponse) +searchDetectors mQuery = + performBHRequest $ Requests.searchDetectors mQuery + +-- | 'profileDetector' profiles a detector. See 'Requests.profileDetector'. +-- See +profileDetector :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + [Text] -> + Bool -> + Maybe [Entity] -> + m (ParsedEsResponse DetectorProfileResponse) +profileDetector detectorId types allFlag mEntities = + performBHRequest $ Requests.profileDetector detectorId types allFlag mEntities + +-- | 'getDetectorStats' fetches plugin statistics. See +-- 'Requests.getDetectorStats'. +-- See +getDetectorStats :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe Text -> + Maybe Text -> + m (ParsedEsResponse DetectorStatsResponse) +getDetectorStats mNodeId mStat = + performBHRequest $ Requests.getDetectorStats mNodeId mStat + +-- | 'searchDetectorResults' searches the anomaly-result index. See +-- 'Requests.searchDetectorResults'. +-- See +searchDetectorResults :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe Text -> + Maybe Bool -> + Maybe Value -> + m (ParsedEsResponse SearchDetectorResultsResponse) +searchDetectorResults mCustomResultIndex mOnlyCustom mQuery = + performBHRequest $ Requests.searchDetectorResults mCustomResultIndex mOnlyCustom mQuery + +-- | 'deleteDetectorResults' deletes anomaly-result documents by query. +-- See 'Requests.deleteDetectorResults'. +-- See +deleteDetectorResults :: + (MonadBH m, WithBackend OpenSearch2 m) => + Value -> + m (ParsedEsResponse DeleteDetectorResultsResponse) +deleteDetectorResults query = + performBHRequest $ Requests.deleteDetectorResults query + +-- | 'searchDetectorTasks' searches the detection-state index. See +-- 'Requests.searchDetectorTasks'. +-- See +searchDetectorTasks :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe Value -> + m (ParsedEsResponse SearchDetectorTasksResponse) +searchDetectorTasks mQuery = + performBHRequest $ Requests.searchDetectorTasks mQuery + +-- | 'topAnomalies' returns the top anomaly results for a +-- high-cardinality detector. See 'Requests.topAnomalies'. +-- See +topAnomalies :: + (MonadBH m, WithBackend OpenSearch2 m) => + DetectorId -> + Bool -> + TopAnomaliesRequest -> + m (ParsedEsResponse TopAnomaliesResponse) +topAnomalies detectorId historical req = + performBHRequest $ Requests.topAnomalies detectorId historical req + +-- Index Rollups plugin +-- +-- ---------------------------------------------------------------------------- + +-- | 'createRollup' creates or replaces an index rollup job. See +-- 'Requests.createRollup'. +-- See +createRollup :: + (MonadBH m, WithBackend OpenSearch2 m) => + RollupId -> + Rollup -> + m (ParsedEsResponse RollupResponse) +createRollup rollupId rollup = + performBHRequest $ Requests.createRollup rollupId rollup + +-- | 'createRollupWith' creates or replaces an index rollup job with an +-- optional optimistic-concurrency guard. See 'Requests.createRollupWith'. +-- See +createRollupWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + RollupId -> + Rollup -> + Maybe (Word64, Word64) -> + m (ParsedEsResponse RollupResponse) +createRollupWith rollupId rollup mOcc = + performBHRequest $ Requests.createRollupWith rollupId rollup mOcc + +-- | 'getRollup' fetches a rollup job by id. See 'Requests.getRollup'. +-- See +getRollup :: + (MonadBH m, WithBackend OpenSearch2 m) => + RollupId -> + m (ParsedEsResponse RollupResponse) +getRollup rollupId = + performBHRequest $ Requests.getRollup rollupId + +-- | 'getAllRollups' lists every rollup job. See 'Requests.getAllRollups'. +-- See +getAllRollups :: + (MonadBH m, WithBackend OpenSearch2 m) => + m (ParsedEsResponse Value) +getAllRollups = + performBHRequest $ Requests.getAllRollups + +-- | 'deleteRollup' deletes a rollup job by id. See 'Requests.deleteRollup'. +-- See +deleteRollup :: + (MonadBH m, WithBackend OpenSearch2 m) => + RollupId -> + m (ParsedEsResponse Value) +deleteRollup rollupId = + performBHRequest $ Requests.deleteRollup rollupId + +-- | 'startRollup' starts a rollup job by id. See 'Requests.startRollup'. +-- See +startRollup :: + (MonadBH m, WithBackend OpenSearch2 m) => + RollupId -> + m (ParsedEsResponse Acknowledged) +startRollup rollupId = + performBHRequest $ Requests.startRollup rollupId + +-- | 'stopRollup' stops a rollup job by id. See 'Requests.stopRollup'. +-- See +stopRollup :: + (MonadBH m, WithBackend OpenSearch2 m) => + RollupId -> + m (ParsedEsResponse Acknowledged) +stopRollup rollupId = + performBHRequest $ Requests.stopRollup rollupId + +-- | 'explainRollup' returns execution metadata for a rollup job by id. +-- See 'Requests.explainRollup'. +-- See +explainRollup :: + (MonadBH m, WithBackend OpenSearch2 m) => + RollupId -> + m (ParsedEsResponse ExplainRollupResponse) +explainRollup rollupId = + performBHRequest $ Requests.explainRollup rollupId + +-- ========================================================================= +-- Cross-Cluster Replication (CCR) plugin +-- ========================================================================= + +-- | 'startReplication' begins replicating a leader index into a follower +-- index on the /follower/ cluster. See +-- 'Database.Bloodhound.OpenSearch2.Requests.startReplication'. +startReplication :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + StartReplicationRequest -> + m (ParsedEsResponse Acknowledged) +startReplication followerIndex req = + performBHRequest $ Requests.startReplication followerIndex req + +-- | 'stopReplication' terminates replication and converts the follower +-- index into a standard writable index. See +-- 'Database.Bloodhound.OpenSearch2.Requests.stopReplication'. +stopReplication :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + m (ParsedEsResponse Acknowledged) +stopReplication = performBHRequest . Requests.stopReplication + +-- | 'pauseReplication' pauses replication of the leader index. See +-- 'Database.Bloodhound.OpenSearch2.Requests.pauseReplication'. +pauseReplication :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + m (ParsedEsResponse Acknowledged) +pauseReplication = performBHRequest . Requests.pauseReplication + +-- | 'resumeReplication' resumes replication after a pause. See +-- 'Database.Bloodhound.OpenSearch2.Requests.resumeReplication'. +resumeReplication :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + m (ParsedEsResponse Acknowledged) +resumeReplication = performBHRequest . Requests.resumeReplication + +-- | 'updateReplicationSettings' applies index-level settings to the +-- follower index. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateReplicationSettings'. +updateReplicationSettings :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + UpdateReplicationSettingsRequest -> + m (ParsedEsResponse Acknowledged) +updateReplicationSettings followerIndex req = + performBHRequest $ Requests.updateReplicationSettings followerIndex req + +-- | 'getReplicationStatus' fetches the replication state of a follower +-- index without the @verbose@ flag. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getReplicationStatus'. +getReplicationStatus :: + (MonadBH m, WithBackend OpenSearch2 m) => + Text -> + m (ParsedEsResponse ReplicationStatusResponse) +getReplicationStatus = performBHRequest . Requests.getReplicationStatus + +-- | 'getReplicationStatusWith' is the parameterized variant of +-- 'getReplicationStatus'. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getReplicationStatusWith'. +getReplicationStatusWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + ReplicationStatusOptions -> + Text -> + m (ParsedEsResponse ReplicationStatusResponse) +getReplicationStatusWith opts followerIndex = + performBHRequest $ Requests.getReplicationStatusWith opts followerIndex + +-- | 'getLeaderStats' fetches aggregate and per-index read-side counters +-- from the /leader/ cluster. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getLeaderStats'. +getLeaderStats :: + (MonadBH m, WithBackend OpenSearch2 m) => + m (ParsedEsResponse LeaderStatsResponse) +getLeaderStats = performBHRequest Requests.getLeaderStats + +-- | 'getFollowerStats' fetches follower index state counts and write-side +-- throughput from the /follower/ cluster. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getFollowerStats'. +getFollowerStats :: + (MonadBH m, WithBackend OpenSearch2 m) => + m (ParsedEsResponse FollowerStatsResponse) +getFollowerStats = performBHRequest Requests.getFollowerStats + +-- | 'getAutoFollowStats' fetches auto-follow activity and the configured +-- replication rules. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getAutoFollowStats'. +getAutoFollowStats :: + (MonadBH m, WithBackend OpenSearch2 m) => + m (ParsedEsResponse AutoFollowStatsResponse) +getAutoFollowStats = performBHRequest Requests.getAutoFollowStats + +-- | 'createAutoFollowPattern' creates or updates an auto-follow rule. +-- See +-- 'Database.Bloodhound.OpenSearch2.Requests.createAutoFollowPattern'. +createAutoFollowPattern :: + (MonadBH m, WithBackend OpenSearch2 m) => + CreateAutoFollowPatternRequest -> + m (ParsedEsResponse Acknowledged) +createAutoFollowPattern = + performBHRequest . Requests.createAutoFollowPattern + +-- | 'deleteAutoFollowPattern' deletes an auto-follow rule. See +-- 'Database.Bloodhound.OpenSearch2.Requests.deleteAutoFollowPattern'. +deleteAutoFollowPattern :: + (MonadBH m, WithBackend OpenSearch2 m) => + DeleteAutoFollowPatternRequest -> + m (ParsedEsResponse Acknowledged) +deleteAutoFollowPattern = + performBHRequest . Requests.deleteAutoFollowPattern + +-- ========================================================================= +-- Index Transforms plugin +-- ========================================================================= + +-- | 'createTransform' creates or replaces a transform job. See +-- 'Requests.createTransform' for semantics. +-- See +createTransform :: + (MonadBH m, WithBackend OpenSearch2 m) => + TransformId -> + Transform -> + m (ParsedEsResponse TransformDocumentResponse) +createTransform transformId transform = + performBHRequest $ Requests.createTransform transformId transform + +-- | 'updateTransform' replaces a transform job (unconditional). See +-- 'Requests.updateTransform' for semantics. +-- See +updateTransform :: + (MonadBH m, WithBackend OpenSearch2 m) => + TransformId -> + Transform -> + m (ParsedEsResponse TransformDocumentResponse) +updateTransform transformId transform = + performBHRequest $ Requests.updateTransform transformId transform + +-- | 'updateTransformWith' replaces a transform job with an optional +-- optimistic-concurrency guard. See 'Requests.updateTransformWith'. +-- See +updateTransformWith :: + (MonadBH m, WithBackend OpenSearch2 m) => + TransformId -> + Transform -> + Maybe (Word64, Word64) -> + m (ParsedEsResponse TransformDocumentResponse) +updateTransformWith transformId transform mOcc = + performBHRequest $ Requests.updateTransformWith transformId transform mOcc + +-- | 'getTransform' fetches a single transform job by id. See +-- 'Requests.getTransform'. +-- See +getTransform :: + (MonadBH m, WithBackend OpenSearch2 m) => + TransformId -> + m (ParsedEsResponse TransformDocumentResponse) +getTransform transformId = + performBHRequest $ Requests.getTransform transformId + +-- | 'getTransforms' lists transform jobs, optionally filtered / +-- paginated. See 'Requests.getTransforms'. +-- See +getTransforms :: + (MonadBH m, WithBackend OpenSearch2 m) => + Maybe TransformsListOptions -> + m (ParsedEsResponse GetTransformsResponse) +getTransforms mOpts = + performBHRequest $ Requests.getTransforms mOpts + +-- | 'startTransform' starts a transform job. See +-- 'Requests.startTransform'. +-- See +startTransform :: + (MonadBH m, WithBackend OpenSearch2 m) => + TransformId -> + m (ParsedEsResponse Acknowledged) +startTransform transformId = + performBHRequest $ Requests.startTransform transformId + +-- | 'stopTransform' stops a transform job. See 'Requests.stopTransform'. +-- See +stopTransform :: + (MonadBH m, WithBackend OpenSearch2 m) => + TransformId -> + m (ParsedEsResponse Acknowledged) +stopTransform transformId = + performBHRequest $ Requests.stopTransform transformId + +-- | 'explainTransform' returns the runtime status and statistics of a +-- transform job. See 'Requests.explainTransform'. +-- See +explainTransform :: + (MonadBH m, WithBackend OpenSearch2 m) => + TransformId -> + m (ParsedEsResponse (Maybe TransformExplain)) +explainTransform transformId = + performBHRequest $ Requests.explainTransform transformId + +-- | 'previewTransform' previews what the transformed target index would +-- look like. See 'Requests.previewTransform'. +-- See +previewTransform :: + (MonadBH m, WithBackend OpenSearch2 m) => + Transform -> + m (ParsedEsResponse PreviewTransformResponse) +previewTransform transform = + performBHRequest $ Requests.previewTransform transform + +-- | 'deleteTransform' deletes a transform job by id. See +-- 'Requests.deleteTransform'. +-- See +deleteTransform :: + (MonadBH m, WithBackend OpenSearch2 m) => + TransformId -> + m (ParsedEsResponse BulkResponse) +deleteTransform transformId = + performBHRequest $ Requests.deleteTransform transformId diff --git a/src/Database/Bloodhound/OpenSearch2/Requests.hs b/src/Database/Bloodhound/OpenSearch2/Requests.hs --- a/src/Database/Bloodhound/OpenSearch2/Requests.hs +++ b/src/Database/Bloodhound/OpenSearch2/Requests.hs @@ -1,40 +1,4773 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} - -module Database.Bloodhound.OpenSearch2.Requests - ( module Reexport, - openPointInTime, - closePointInTime, - ) -where - -import Data.Aeson -import Database.Bloodhound.Client.Cluster -import Database.Bloodhound.Common.Requests as Reexport -import Database.Bloodhound.Internal.Client.BHRequest -import Database.Bloodhound.Internal.Utils.Requests -import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes -import Database.Bloodhound.OpenSearch2.Types -import Prelude hiding (filter, head) - --- | 'openPointInTime' opens a point in time for an index given an 'IndexName'. --- Note that the point in time should be closed with 'closePointInTime' as soon --- as it is no longer needed. --- --- For more information see --- . -openPointInTime :: - IndexName -> - BHRequest StatusDependant (ParsedEsResponse OpenPointInTimeResponse) -openPointInTime indexName = - withBHResponseParsedEsResponse $ post @StatusDependant [unIndexName indexName, "_search", "point_in_time?keep_alive=1m"] emptyBody - --- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'. --- --- For more information see --- . -closePointInTime :: - ClosePointInTime -> - BHRequest StatusDependant (ParsedEsResponse ClosePointInTimeResponse) -closePointInTime q = do - withBHResponseParsedEsResponse $ deleteWithBody @StatusDependant ["_search", "point_in_time"] (encode q) +{-# LANGUAGE TypeApplications #-} + +module Database.Bloodhound.OpenSearch2.Requests + ( module Reexport, + deleteISMPolicy, + addISMPolicy, + openPointInTime, + openPointInTimeWith, + closePointInTime, + listAllPITs, + deleteAllPITs, + getMLTask, + putISMPolicy, + putISMPolicyWith, + removeISMPolicy, + changeISMPolicy, + retryISMIndex, + explainISMIndex, + explainISMIndexWith, + explainISMIndexFiltered, + getISMPolicy, + getISMPolicies, + postSMPolicy, + putSMPolicyWith, + getSMPolicy, + getSMPolicies, + deleteSMPolicy, + startSMPolicy, + stopSMPolicy, + explainSMPolicies, + getMLStats, + getModel, + registerModel, + registerModelWith, + deployModel, + undeployModel, + updateModel, + searchModels, + listModels, + deleteModel, + predict, + trainModel, + trainModelWith, + trainAndPredictModel, + searchMLTasks, + deleteMLTask, + registerModelGroup, + updateModelGroup, + getModelGroup, + searchModelGroups, + deleteModelGroup, + createConnector, + getConnector, + searchConnectors, + updateConnector, + deleteConnector, + createMemory, + updateMemory, + getMemory, + listMemories, + searchMemory, + deleteMemory, + createMemoryMessage, + updateMemoryMessage, + getMemoryMessage, + listMemoryMessages, + searchMemoryMessages, + getMemoryTraces, + createController, + updateController, + getController, + deleteController, + getMLProfile, + getMLProfileModels, + getMLProfileModel, + getMLProfileTasks, + getMLProfileTask, + registerAgent, + getAgent, + deleteAgent, + searchAgents, + executeAgent, + warmupKnnIndex, + clearKnnCache, + getKnnStats, + getKnnModel, + trainKnnModel, + trainKnnModelWith, + deleteKnnModel, + searchKnnModels, + submitOSAsyncSearch, + submitOSAsyncSearchWith, + getOSAsyncSearch, + deleteOSAsyncSearch, + getOSAsyncSearchStats, + sqlQuery, + sqlQueryNextPage, + closeSqlCursor, + explainSQL, + pplQuery, + explainPPL, + getSQLStats, + createNotificationConfig, + createNotificationConfigWith, + deleteNotificationConfig, + deleteNotificationConfigs, + getNotificationConfig, + getNotificationConfigs, + getNotificationConfigsWith, + getNotificationFeatures, + getNotificationChannels, + getNotificationChannelsWith, + updateNotificationConfig, + sendTestNotification, + createMonitor, + getMonitor, + updateMonitor, + updateMonitorWith, + deleteMonitor, + searchMonitors, + executeMonitor, + createSADetector, + getSADetector, + updateSADetector, + deleteSADetector, + searchSADetectors, + searchSAPrePackagedRules, + searchSACustomRules, + createSACustomRule, + updateSACustomRule, + deleteSACustomRule, + getSAMappingsView, + createSAMappings, + getSAMappings, + updateSAMappings, + getSAAlertsWith, + getSAAlerts, + acknowledgeSADetectorAlerts, + searchSAFindings, + createSACorrelationRule, + getSACorrelations, + findSACorrelation, + searchSACorrelationAlerts, + acknowledgeSACorrelationAlerts, + createSALogType, + searchSALogTypes, + updateSALogType, + deleteSALogType, + getDestinations, + getDestinationsWith, + createDestination, + updateDestination, + deleteDestination, + getAlertsWith, + getAlerts, + acknowledgeAlert, + getMonitorStats, + createEmailAccount, + getEmailAccount, + updateEmailAccount, + updateEmailAccountWith, + deleteEmailAccount, + createEmailGroup, + getEmailGroup, + updateEmailGroup, + updateEmailGroupWith, + deleteEmailGroup, + getDestination, + searchEmailAccounts, + searchEmailGroups, + searchFindings, + createComment, + updateComment, + searchComments, + deleteComment, + createDetector, + getDetector, + previewDetector, + previewDetectorInline, + startDetector, + stopDetector, + updateDetector, + updateDetectorWith, + deleteDetector, + validateDetector, + searchDetectors, + profileDetector, + getDetectorStats, + searchDetectorResults, + deleteDetectorResults, + searchDetectorTasks, + topAnomalies, + createRollup, + createRollupWith, + getRollup, + getAllRollups, + deleteRollup, + startRollup, + stopRollup, + explainRollup, + startReplication, + stopReplication, + pauseReplication, + resumeReplication, + updateReplicationSettings, + getReplicationStatus, + getReplicationStatusWith, + getLeaderStats, + getFollowerStats, + getAutoFollowStats, + createAutoFollowPattern, + deleteAutoFollowPattern, + createTransform, + updateTransform, + updateTransformWith, + getTransform, + getTransforms, + startTransform, + stopTransform, + explainTransform, + previewTransform, + deleteTransform, + ) +where + +import Data.Aeson +import Data.ByteString.Lazy qualified as BL +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, listToMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Word (Word64) +import Database.Bloodhound.Client.Cluster +import Database.Bloodhound.Common.Requests as Reexport hiding + ( deleteTransform, + explainTransform, + getTransforms, + previewTransform, + startTransform, + stopTransform, + updateTransform, + updateTransformWith, + ) +import Database.Bloodhound.Internal.Client.BHRequest +import Database.Bloodhound.Internal.Utils.Imports (deleteSeveral, showText) +import Database.Bloodhound.Internal.Utils.Requests +import Database.Bloodhound.Internal.Versions.Common.Types.KeepAlive +import Database.Bloodhound.Internal.Versions.Common.Types.Newtypes +import Database.Bloodhound.OpenSearch2.Types +import Network.HTTP.Client (responseBody) +import Prelude hiding (filter, head) + +-- | 'openPointInTime' opens a point in time for a single index given an +-- 'IndexName', using the supplied 'KeepAlive' duration (e.g. +-- @keepAliveMinutes 1@). Note that the point in time should be closed +-- with 'closePointInTime' as soon as it is no longer needed. +-- +-- This is a convenience wrapper around 'openPointInTimeWith' that lifts +-- the single 'IndexName' into an 'IndexPattern'. To target multiple +-- comma-joined indices or a wildcard pattern (e.g. @\"logs-*,app-*\"@), +-- use 'openPointInTimeWith' directly with an 'IndexPattern'. +-- +-- For more information see +-- . +openPointInTime :: + IndexName -> + KeepAlive -> + BHRequest StatusDependant (ParsedEsResponse OpenPointInTimeResponse) +openPointInTime indexName keepAlive = + openPointInTimeWith (IndexPattern (unIndexName indexName)) keepAlive defaultPITOptions + +-- | 'openPointInTimeWith' is the parameterized variant of +-- 'openPointInTime' on OpenSearch 2: it takes an 'IndexPattern' as the +-- target (@target_indexes@ on the wire), which may be a single index +-- name, a comma-separated list of indices, or a wildcard pattern +-- (e.g. @\"logs-*\"@, @\"logs-2024,logs-2025\"@). It forwards the +-- supplied 'PITOptions' as query-string parameters in addition to the +-- mandatory @keep_alive@. All four documented parameters are emitted +-- (@routing@, @preference@, @expand_wildcards@, +-- @allow_partial_pit_creation@); the last is OpenSearch-only and is +-- silently dropped by the Elasticsearch request builders. The target is +-- carried as a URL path segment (not a query parameter). Pass +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.defaultPITOptions' +-- to reproduce the wire shape of 'openPointInTime'. +-- +-- For more information see +-- . +openPointInTimeWith :: + IndexPattern -> + KeepAlive -> + PITOptions -> + BHRequest StatusDependant (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWith indexPattern keepAlive opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint emptyBody + where + endpoint = + [unIndexPattern indexPattern, "_search", "point_in_time"] + `withQueries` (("keep_alive", Just (keepAliveToText keepAlive)) : osPITOptionsParams opts) + +-- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'. +-- +-- For more information see +-- . +closePointInTime :: + ClosePointInTime -> + BHRequest StatusDependant (ParsedEsResponse ClosePointInTimeResponse) +closePointInTime q = do + withBHResponseParsedEsResponse $ deleteWithBody @StatusDependant ["_search", "point_in_time"] (encode q) + +-- | 'listAllPITs' returns every currently-open point in time on the cluster +-- via @GET /_search/point_in_time/_all@. Each 'PITInfo' carries the pit +-- id, the @creation_time@ and the remaining @keep_alive@ (a bare +-- millisecond count on the wire); the @_shards@ summary is absent from +-- list entries (it appears only in the @POST@ create-PIT response, see +-- 'OpenPointInTimeResponse'). +-- +-- For more information see +-- . +listAllPITs :: + BHRequest StatusDependant [PITInfo] +listAllPITs = + listPITs <$> get @StatusDependant ["_search", "point_in_time", "_all"] + +-- | 'deleteAllPITs' deletes every currently-open point in time on the +-- cluster via @DELETE /_search/point_in_time/_all@. Unlike +-- 'closePointInTime' (the delete-by-ID endpoint, which takes a +-- 'ClosePointInTime' body), this call carries no request body. The +-- server processes each PIT individually and returns one +-- 'ClosePointInTimeResult' per deleted PIT (partial failures are +-- reported as failures); the response therefore reuses the +-- 'ClosePointInTimeResponse' envelope documented for the by-ID +-- endpoint. +-- +-- Note: the Delete All PITs API deletes only local and mixed PITs; it +-- does not delete fully remote (cross-cluster) PITs. +-- +-- For more information see +-- . +deleteAllPITs :: + BHRequest StatusDependant (ParsedEsResponse ClosePointInTimeResponse) +deleteAllPITs = + withBHResponseParsedEsResponse $ + delete @StatusDependant ["_search", "point_in_time", "_all"] + +-- | 'getMLTask' calls the ML Commons plugin Get Task API +-- (@GET /_plugins/_ml/tasks/{task_id}@). The plugin returns the current state +-- of a single asynchronous task created by @POST /_plugins/_ml/models/_register@, +-- @POST /_plugins/_ml/models/{id}/_deploy@, training, and friends. Callers +-- poll this endpoint with the @task_id@ returned by the submit call until +-- 'mlTaskInfoState' reaches 'MLTaskStateCompleted' or 'MLTaskStateFailed'. +-- +-- For more information see +-- . +getMLTask :: + MLTaskId -> + BHRequest StatusDependant (ParsedEsResponse MLTaskInfo) +getMLTask mlTaskId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "tasks", unMLTaskId mlTaskId] + +-- | 'putISMPolicy' creates or updates an ISM policy. Equivalent to +-- 'putISMPolicyWith' with 'Nothing' (no optimistic-concurrency guard), so +-- concurrent updates to the same policy id silently clobber each other. +-- See +putISMPolicy :: + PolicyId -> + ISMPolicyRequest -> + BHRequest StatusDependant (ParsedEsResponse PutISMPolicyResponse) +putISMPolicy policyId policy = putISMPolicyWith policyId policy Nothing + +-- | 'putISMPolicyWith' creates or updates an ISM policy with an optional +-- optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ — both +-- values read from a prior 'PutISMPolicyResponse' — to make the PUT +-- conditional on the policy being unchanged since you last read it; a stale +-- pair causes OpenSearch to respond with HTTP 409 instead of silently +-- overwriting. Pass 'Nothing' for the unconditional semantics of +-- 'putISMPolicy'. The two values must be supplied together: OpenSearch +-- rejects a partial pair with HTTP 400 (mirroring the document-write +-- @if_seq_no@ / @if_primary_term@ semantics). +-- See +putISMPolicyWith :: + PolicyId -> + ISMPolicyRequest -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant (ParsedEsResponse PutISMPolicyResponse) +putISMPolicyWith policyId policy mOcc = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode policy) + where + baseEndpoint = mkEndpoint ["_plugins", "_ism", "policies", unPolicyId policyId] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries baseEndpoint $ + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'addISMPolicy' applies an existing ISM policy to one or more indices. +-- The @policy_id@ in the body identifies the policy to attach. Indices that +-- already have a policy attached (or reject the operation for other reasons) +-- appear in the @failed_indices@ field of the response. +-- See +addISMPolicy :: + PolicyId -> + IndexName -> + BHRequest StatusDependant (ParsedEsResponse ISMUpdatedIndicesResponse) +addISMPolicy policyId indexName = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_plugins", "_ism", "add", unIndexName indexName] + body = object ["policy_id" .= unPolicyId policyId] + +-- | 'removeISMPolicy' detaches any ISM policy from the given index. +-- See +removeISMPolicy :: + IndexName -> + BHRequest StatusDependant (ParsedEsResponse ISMUpdatedIndicesResponse) +removeISMPolicy indexName = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_ism", "remove", unIndexName indexName] + +-- | 'changeISMPolicy' updates the managed-index policy attached to @index@. +-- See +changeISMPolicy :: + IndexName -> + ChangePolicyRequest -> + BHRequest StatusDependant (ParsedEsResponse ISMUpdatedIndicesResponse) +changeISMPolicy indexName req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ism", "change_policy", unIndexName indexName] + +-- | 'retryISMIndex' retries the failed ISM action for an index. +-- See +retryISMIndex :: + IndexName -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse ISMUpdatedIndicesResponse) +retryISMIndex indexName mState = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ism", "retry", unIndexName indexName] + body = case mState of + Nothing -> encode (object []) + Just st -> encode (object ["state" .= st]) + +-- | 'explainISMIndex' returns the ISM state of @index@. Equivalent to +-- 'explainISMIndexWith' with 'defaultISMExplainOptions' (no query +-- parameters). +-- See +explainISMIndex :: + IndexName -> + BHRequest StatusDependant (ParsedEsResponse ISMExplanation) +explainISMIndex indexName = explainISMIndexWith indexName defaultISMExplainOptions + +-- | 'explainISMIndexWith' returns the ISM state of @index@, forwarding the +-- supplied 'ISMExplainOptions' as query-string parameters. All four +-- documented parameters are emitted (@show_policy@, @validate_action@, +-- @local@, @expand_wildcards@); 'Nothing' \/ 'False' fields are omitted so +-- 'defaultISMExplainOptions' reproduces the wire shape of 'explainISMIndex'. +-- See +explainISMIndexWith :: + IndexName -> + ISMExplainOptions -> + BHRequest StatusDependant (ParsedEsResponse ISMExplanation) +explainISMIndexWith indexName opts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_ism", "explain", unIndexName indexName] + endpoint = withQueries baseEndpoint (ismExplainOptionsParams opts) + +-- | 'explainISMIndexFiltered' returns the ISM state of @index@ via the +-- @POST /_plugins/_ism/explain/{index}@ "Explain index with filtering" form +-- (introduced in OpenSearch 2.12). The 'ISMExplainFilter' is sent as a +-- @{"filter": {...}}@ body; the server returns only indexes matching /all/ +-- specified criteria. The response shape is identical to +-- 'explainISMIndex' ('ISMExplanation'). Pass 'defaultISMExplainFilter' for an +-- unfiltered POST. +-- See +explainISMIndexFiltered :: + IndexName -> + ISMExplainFilter -> + BHRequest StatusDependant (ParsedEsResponse ISMExplanation) +explainISMIndexFiltered indexName filt = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (ISMExplainFilterRequest filt)) + where + endpoint = mkEndpoint ["_plugins", "_ism", "explain", unIndexName indexName] + +-- | 'getISMPolicy' fetches a single policy by id. +-- See +getISMPolicy :: + PolicyId -> + BHRequest StatusDependant (ParsedEsResponse ISMPolicyInfo) +getISMPolicy policyId = + withBHResponseParsedEsResponse $ + get @StatusDependant (mkEndpoint ["_plugins", "_ism", "policies", unPolicyId policyId]) + +-- | 'getISMPolicies' lists policies, optionally filtered / paginated. +-- See +getISMPolicies :: + Maybe ISMPoliciesQuery -> + BHRequest StatusDependant (ParsedEsResponse GetISMPoliciesResponse) +getISMPolicies mQuery = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_ism", "policies"] + endpoint = case mQuery of + Nothing -> baseEndpoint + Just query -> withQueries baseEndpoint (ismPoliciesQueryToPairs query) + +-- | 'deleteISMPolicy' deletes an ISM policy by id. +-- OpenSearch stores policies as documents in @.opendistro-ism-config@, so the +-- response is the standard document-delete envelope (parsed here as +-- 'IndexedDocument'), not an 'Acknowledged' ack. +-- See +deleteISMPolicy :: + PolicyId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteISMPolicy policyId = + withBHResponseParsedEsResponse $ + delete @StatusDependant (mkEndpoint ["_plugins", "_ism", "policies", unPolicyId policyId]) + +-- ========================================================================= +-- Snapshot Management plugin +-- ========================================================================= +-- +-- The SM plugin runs snapshot creation/deletion on a schedule. Policies +-- live under @/_plugins/_sm/policies/{policy_name}@. The plugin was +-- introduced in OpenSearch 2.1; the path is identical across OS 2.x/3.x. +-- See + +-- | 'postSMPolicy' creates a new SM policy. The server rejects the request +-- with HTTP 409 if a policy with the same name already exists — use +-- 'putSMPolicyWith' for updates (which requires the current @_seq_no@ / +-- @_primary_term@ for optimistic concurrency). +-- See +postSMPolicy :: + SMPolicyName -> + SMPolicyBody -> + BHRequest StatusDependant (ParsedEsResponse SMPolicyResponse) +postSMPolicy policyName body = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_plugins", "_sm", "policies", unSMPolicyName policyName] + +-- | 'putSMPolicyWith' updates an existing SM policy. OpenSearch requires +-- the @if_seq_no@ / @if_primary_term@ pair for updates: pass the values +-- read from a prior 'SMPolicyResponse' (or the @_seq_no@ / @_primary_term@ +-- of a create response). A stale pair causes HTTP 409; a missing pair +-- causes HTTP 400. +-- See +putSMPolicyWith :: + SMPolicyName -> + SMPolicyBody -> + Word64 -> + Word64 -> + BHRequest StatusDependant (ParsedEsResponse SMPolicyResponse) +putSMPolicyWith policyName body seqNo primaryTerm = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode body) + where + endpoint = + withQueries + (mkEndpoint ["_plugins", "_sm", "policies", unSMPolicyName policyName]) + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'getSMPolicy' fetches a single SM policy by name. +-- See +getSMPolicy :: + SMPolicyName -> + BHRequest StatusDependant (ParsedEsResponse SMPolicyResponse) +getSMPolicy policyName = + withBHResponseParsedEsResponse $ + get @StatusDependant (mkEndpoint ["_plugins", "_sm", "policies", unSMPolicyName policyName]) + +-- | 'getSMPolicies' lists SM policies, optionally filtered / paginated via +-- a 'GetSMPoliciesQuery'. Pass 'Nothing' (or 'defaultGetSMPoliciesQuery') +-- to list all policies with server defaults. +-- See +getSMPolicies :: + Maybe GetSMPoliciesQuery -> + BHRequest StatusDependant (ParsedEsResponse GetSMPoliciesResponse) +getSMPolicies mQuery = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_sm", "policies"] + endpoint = case mQuery of + Nothing -> baseEndpoint + Just query -> withQueries baseEndpoint (getSMPoliciesQueryParams query) + +-- | 'deleteSMPolicy' deletes an SM policy by name. The server returns the +-- standard OpenSearch document-delete envelope (SM policies are stored as +-- documents in @.opendistro-ism-config@). +-- See +deleteSMPolicy :: + SMPolicyName -> + BHRequest StatusDependant (ParsedEsResponse DeleteSMPolicyResponse) +deleteSMPolicy policyName = + withBHResponseParsedEsResponse $ + delete @StatusDependant (mkEndpoint ["_plugins", "_sm", "policies", unSMPolicyName policyName]) + +-- | 'startSMPolicy' enables an SM policy (sets @enabled=true@). The job +-- scheduler picks up the policy on its next tick. +-- See +startSMPolicy :: + SMPolicyName -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +startSMPolicy policyName = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant (mkEndpoint ["_plugins", "_sm", "policies", unSMPolicyName policyName, "_start"]) + +-- | 'stopSMPolicy' disables an SM policy (sets @enabled=false@). In-flight +-- snapshot operations are not interrupted; the policy simply stops +-- scheduling new ones. +-- See +stopSMPolicy :: + SMPolicyName -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +stopSMPolicy policyName = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant (mkEndpoint ["_plugins", "_sm", "policies", unSMPolicyName policyName, "_stop"]) + +-- | 'explainSMPolicies' returns the running state and metadata of the +-- policies matching the supplied name expression. The expression is a +-- comma-separated list and/or a wildcard pattern (e.g. @"daily*"@, +-- @"policy-a,policy-b"@); pass @"*"@ to explain all policies. +-- See +explainSMPolicies :: + Text -> + BHRequest StatusDependant (ParsedEsResponse SMExplainResponse) +explainSMPolicies policyNames = + withBHResponseParsedEsResponse $ + get @StatusDependant (mkEndpoint ["_plugins", "_sm", "policies", policyNames, "_explain"]) + +-- | 'getMLStats' calls the ML Commons plugin Stats API +-- (@GET /_plugins/_ml/[{nodeId}/]stats[/{stat}]@). Both arguments are +-- optional and select, respectively, which node(s) to query (defaults to all) +-- and which stat(s) to return (defaults to all). The ML Commons stats +-- endpoint is always available whenever the plugin is installed — no cluster +-- setting needs to be enabled. +-- +-- The response body is a JSON object whose top-level keys are either +-- cluster-level stat names (mapping to scalars) or the literal key @nodes@ +-- (mapping to a per-node map keyed by opaque node ID); see the module docs +-- of 'MLStats' for why the entries are kept as aeson 'Value's rather than +-- modelled per-stat. +-- +-- For more information see +-- . +getMLStats :: + Maybe MLNodeId -> + Maybe MLStatName -> + BHRequest StatusDependant (ParsedEsResponse MLStats) +getMLStats mNodeId mStatName = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint segments + segments = + ["_plugins", "_ml"] + <> foldMap (pure . unMLNodeId) mNodeId + <> ["stats"] + <> foldMap (pure . unMLStatName) mStatName + +-- ========================================================================= +-- ML Commons model APIs +-- ========================================================================= + +-- | 'getModel' calls the ML Commons Get Model API +-- (@GET /_plugins/_ml/models/{model_id}@). Returns the model's full metadata. +-- +-- For more information see +-- . +getModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse ModelInfo) +getModel modelId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", unModelId modelId] + +-- | 'registerModel' registers a model. Equivalent to 'registerModelWith' +-- with @deploy = False@. Registration is asynchronous; poll the returned +-- @task_id@ via the Get ML Task API. +-- See +registerModel :: + RegisterModelRequest -> + BHRequest StatusDependant (ParsedEsResponse MLTaskAck) +registerModel = registerModelWith False + +-- | 'registerModelWith' registers a model with an optional @?deploy=true@ +-- query flag that chains a deploy after successful registration. +-- See +registerModelWith :: + Bool -> + RegisterModelRequest -> + BHRequest StatusDependant (ParsedEsResponse MLTaskAck) +registerModelWith deploy req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + baseEndpoint = mkEndpoint ["_plugins", "_ml", "models", "_register"] + endpoint = + if deploy + then withQueries baseEndpoint [("deploy", Just "true")] + else baseEndpoint + +-- | 'deployModel' loads a registered model into memory on ML worker nodes. +-- Pass 'Nothing' to let OpenSearch pick eligible nodes; pass a +-- 'DeployModelRequest' to restrict to a node list. Deployment is +-- asynchronous; poll the returned @task_id@ via the Get ML Task API. +-- See +deployModel :: + ModelId -> + Maybe DeployModelRequest -> + BHRequest StatusDependant (ParsedEsResponse MLTaskAck) +deployModel modelId mReq = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", unModelId modelId, "_deploy"] + body = maybe (encode (object [])) encode mReq + +-- | 'deleteModel' deletes a registered model by id. OpenSearch stores +-- models as documents in @.plugins-ml-model@, so the response is the +-- standard document-delete envelope (parsed here as 'IndexedDocument'), +-- not an 'Acknowledged' ack — identical to 'deleteISMPolicy'. A +-- deployed model must be undeployed before it can be deleted, otherwise +-- the server returns an error which surfaces as an 'EsError' under +-- 'StatusDependant'. +-- See +deleteModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteModel modelId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", unModelId modelId] + +-- | 'undeployModel' unloads a deployed model from ML worker nodes +-- (the inverse of 'deployModel'). Synchronous; returns a node-keyed +-- stats map ('UndeployModelResponse'), not a task ack. +-- See +undeployModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse UndeployModelResponse) +undeployModel modelId = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", unModelId modelId, "_undeploy"] + +-- | 'updateModel' updates a subset of a registered model's metadata. +-- See +updateModel :: + ModelId -> + UpdateModelRequest -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateModel modelId req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", unModelId modelId] + +-- | 'searchModels' searches the model index via +-- @POST /_plugins/_ml/models/_search@. +-- See +searchModels :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse ModelSearchResponse) +searchModels = searchModelsOn "_search" + +-- | 'listModels' lists models. Historically this hit the +-- @POST /_plugins/_ml/models/_list@ endpoint, but OS 2.x removed POST +-- from @_list@ (it now returns 405). The modern, supported endpoint +-- for listing is @POST /_plugins/_ml/models/_search@ — the same one +-- 'searchModels' uses. Kept as a separate function rather than aliased +-- to 'searchModels' so callers and telemetry can distinguish the two +-- call sites. +listModels :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse ModelSearchResponse) +listModels = searchModelsOn "_search" + +-- | Shared body of 'searchModels' and 'listModels'. +searchModelsOn :: + Text -> + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse ModelSearchResponse) +searchModelsOn suffix mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", suffix] + body = encode (maybe (object []) id mQuery) + +-- ========================================================================= +-- ML Commons agent APIs +-- ========================================================================= + +-- | 'registerAgent' registers an ML Commons agent (OS 2.12+) — a named +-- configuration that binds a large-language model (or a routed +-- population of sub-agents and tools) behind a server-assigned +-- 'AgentId'. Unlike 'registerModel', registration is synchronous: the +-- POST persists a single config document in the @.plugins-ml-agent@ +-- system index and returns @{"agent_id": "..."}@ directly, so the +-- returned 'RegisterAgentResponse' carries no @task_id@ to poll and the +-- agent is callable immediately (subject to its bound model being +-- deployed). +-- +-- Surfaced as 'StatusDependant' so a 4xx (e.g. an unknown tool @type@, +-- a missing @llm@ on a @conversation@ agent, or an @app_type@ mismatch +-- on a @template@ agent) decodes as an 'EsError' rather than throwing. +-- See +registerAgent :: + RegisterAgentRequest -> + BHRequest StatusDependant (ParsedEsResponse RegisterAgentResponse) +registerAgent req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "agents", "_register"] + +-- | 'getAgent' fetches a registered agent by id. The body is the bare +-- stored agent document, decoded as 'AgentInfo'. +-- See +getAgent :: + AgentId -> + BHRequest StatusDependant (ParsedEsResponse AgentInfo) +getAgent agentId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "agents", unAgentId agentId] + +-- | 'deleteAgent' deletes a registered agent by id. The response is +-- the standard document-delete envelope ('IndexedDocument'). +-- See +deleteAgent :: + AgentId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteAgent agentId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "agents", unAgentId agentId] + +-- | 'searchAgents' searches the agent index via +-- @POST /_plugins/_ml/agents/_search@. +-- +-- /Empty-cluster handling:/ when no agent has ever been registered +-- the @.plugins-ml-agent@ system index does not exist, and OpenSearch +-- responds with HTTP 404 @index_not_found_exception@ instead of an +-- empty search result. This wrapper detects that 404 and substitutes +-- 'emptyAgentSearchResponse', so callers see a uniform @Right empty@ +-- regardless of whether any agent has been registered. +-- See +searchAgents :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse AgentSearchResponse) +searchAgents mQuery = withBHResponseParsedEsResponse innerReq + where + innerReq = baseInner {bhRequestParser = innerParser} + baseInner = post @StatusDependant @AgentSearchResponse endpoint body + endpoint = mkEndpoint ["_plugins", "_ml", "agents", "_search"] + body = encode (maybe (object []) id mQuery) + innerParser resp + | isAgentsIndexMissing404 resp = Right (Right emptyAgentSearchResponse) + | otherwise = bhRequestParser baseInner resp + isAgentsIndexMissing404 resp = + statusCodeIs (404, 404) resp + && case eitherDecode (responseBody (getResponse resp)) of + Right es -> "no such index" `T.isInfixOf` errorMessage (es :: EsError) + Left _ -> False + +-- | 'executeAgent' runs a registered agent synchronously via +-- @POST /_plugins/_ml/agents/{agent_id}/_execute@ (the Execute Agent +-- API, introduced in OpenSearch 2.13 — available on OpenSearch 2.x). +-- The agent runs its configured tools and returns an +-- 'ExecuteAgentResponse' carrying the @inference_results.output[]@ +-- list. The request body is the permissive 'ExecuteAgentRequest' +-- (opaque @parameters@ map and\/or polymorphic @input@). +-- +-- For asynchronous execution (OpenSearch 3.0+; not available on OS 2.x) +-- use 'Database.Bloodhound.OpenSearch3.Client.executeAgentAsync' on an +-- OpenSearch 3 client. The asynchronous variant is intentionally not +-- exposed on OpenSearch 2 because its @?async=true@ query parameter is +-- rejected by OS 2.x servers. +-- See +executeAgent :: + AgentId -> + ExecuteAgentRequest -> + BHRequest StatusDependant (ParsedEsResponse ExecuteAgentResponse) +executeAgent agentId req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "agents", unAgentId agentId, "_execute"] + +-- | 'predict' invokes a deployed model. The path carries an +-- @algorithm_name@ and a @model_id@; the request body and the response are +-- model-specific, so both are typed as opaque 'Value's. +-- +-- For more information see +-- . +predict :: + AlgorithmName -> + ModelId -> + Value -> + BHRequest StatusDependant (ParsedEsResponse Value) +predict algo modelId body = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint + ["_plugins", "_ml", "_predict", unAlgorithmName algo, unModelId modelId] + +-- ========================================================================= +-- ML Commons train and task APIs +-- ========================================================================= + +-- | 'trainModel' trains a classical algorithm (kmeans, RCF, ...) on a +-- dataset, returning either a @model_id@ (sync, the default) or a +-- @task_id@ (when 'trainModelWith' is called with @async = True@). The +-- response shape is the same 'MLTaskAck' in both cases — sync populates +-- 'mlTaskAckModelId', async populates 'mlTaskAckTaskId'. +-- See . +trainModel :: + AlgorithmName -> + TrainModelRequest -> + BHRequest StatusDependant (ParsedEsResponse MLTaskAck) +trainModel = trainModelWith False + +-- | 'trainModelWith' is the async-flagged variant of 'trainModel'. Pass +-- @True@ to run training asynchronously (the call returns a @task_id@ +-- immediately; poll it via 'getMLTask'). +trainModelWith :: + Bool -> + AlgorithmName -> + TrainModelRequest -> + BHRequest StatusDependant (ParsedEsResponse MLTaskAck) +trainModelWith asyncFlag algorithm req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + baseEndpoint = mkEndpoint ["_plugins", "_ml", "_train", unAlgorithmName algorithm] + endpoint = + if asyncFlag + then withQueries baseEndpoint [("async", Just "true")] + else baseEndpoint + +-- | 'trainAndPredictModel' trains an unsupervised algorithm on a dataset +-- and immediately runs prediction against the same data, returning the +-- prediction payload as 'TrainAndPredictResponse'. +-- See . +trainAndPredictModel :: + AlgorithmName -> + TrainModelRequest -> + BHRequest StatusDependant (ParsedEsResponse TrainAndPredictResponse) +trainAndPredictModel algorithm req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "_train_predict", unAlgorithmName algorithm] + +-- | 'searchMLTasks' searches the @.plugins-ml-task@ system index via +-- @POST /_plugins/_ml/tasks/_search@. Pass 'Nothing' for the plain +-- empty-body @{}@ POST; pass @'Just' query@ to filter (e.g. by +-- @function_name@) or paginate. The @.plugins-ml-task@ index does not +-- exist until the first asynchronous ML operation runs, so a 404 +-- @index_not_found@ is decoded as an empty result (mirroring +-- 'searchAgents'). +searchMLTasks :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult MLTaskInfo)) +searchMLTasks mQuery = + withBHResponseParsedEsResponse $ + searchMLWithEmptyIndex404 $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "tasks", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'deleteMLTask' deletes an ML task by id via +-- @DELETE /_plugins/_ml/tasks/{task_id}@. The response is the standard +-- document-delete envelope ('IndexedDocument'). The plugin does not +-- check task status before deleting — a running task can be deleted. +deleteMLTask :: + MLTaskId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteMLTask taskId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "tasks", unMLTaskId taskId] + +-- ========================================================================= +-- ML Commons model group APIs +-- ========================================================================= + +-- | 'registerModelGroup' registers a model group via +-- @POST /_plugins/_ml/model_groups/_register@ (OS 2.12+). +-- See . +registerModelGroup :: + RegisterModelGroupRequest -> + BHRequest StatusDependant (ParsedEsResponse RegisterModelGroupResponse) +registerModelGroup req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "model_groups", "_register"] + +-- | 'updateModelGroup' updates a model group via +-- @PUT /_plugins/_ml/model_groups/{model_group_id}@. The body is a +-- partial update; the response is the standard document-update envelope. +updateModelGroup :: + ModelGroupId -> + UpdateModelGroupRequest -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateModelGroup groupId req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "model_groups", unModelGroupId groupId] + +-- | 'getModelGroup' fetches a model group by id via +-- @GET /_plugins/_ml/model_groups/{model_group_id}@. +getModelGroup :: + ModelGroupId -> + BHRequest StatusDependant (ParsedEsResponse ModelGroupInfo) +getModelGroup groupId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "model_groups", unModelGroupId groupId] + +-- | 'searchModelGroups' searches the @.plugins-ml-model-group@ index via +-- @POST /_plugins/_ml/model_groups/_search@. The backing index does not +-- exist until the first group is registered, so a 404 is decoded as an +-- empty result. +searchModelGroups :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult ModelGroupInfo)) +searchModelGroups mQuery = + withBHResponseParsedEsResponse $ + searchMLWithEmptyIndex404 $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "model_groups", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'deleteModelGroup' deletes a model group via +-- @DELETE /_plugins/_ml/model_groups/{model_group_id}@. Idempotent: a +-- missing group returns HTTP 200 with @result = "not_found"@ (not a +-- 404). A group can only be manually deleted if it has no model +-- versions. +deleteModelGroup :: + ModelGroupId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteModelGroup groupId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "model_groups", unModelGroupId groupId] + +-- ========================================================================= +-- ML Commons connector APIs +-- ========================================================================= + +-- | 'createConnector' creates a remote-model connector via +-- @POST /_plugins/_ml/connectors/_create@ (OS 2.12+). @credential@ is +-- write-only and never returned by subsequent get\/search calls. +-- See . +createConnector :: + CreateConnectorRequest -> + BHRequest StatusDependant (ParsedEsResponse CreateConnectorResponse) +createConnector req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "connectors", "_create"] + +-- | 'getConnector' fetches a connector by id via +-- @GET /_plugins/_ml/connectors/{connector_id}@. The @credential@ field +-- is never present in the response. +getConnector :: + ConnectorId -> + BHRequest StatusDependant (ParsedEsResponse ConnectorInfo) +getConnector connId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "connectors", unConnectorId connId] + +-- | 'searchConnectors' searches the @.plugins-ml-connector@ index via +-- @POST /_plugins/_ml/connectors/_search@. The backing index does not +-- exist until the first connector is created, so a 404 is decoded as an +-- empty result. +searchConnectors :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult ConnectorInfo)) +searchConnectors mQuery = + withBHResponseParsedEsResponse $ + searchMLWithEmptyIndex404 $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "connectors", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'updateConnector' updates a connector via +-- @PUT /_plugins/_ml/connectors/{connector_id}@ (OS 2.12+). Partial +-- update; omitted fields are preserved. All models using the connector +-- must be undeployed before updating. +updateConnector :: + ConnectorId -> + UpdateConnectorRequest -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateConnector connId req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "connectors", unConnectorId connId] + +-- | 'deleteConnector' deletes a connector via +-- @DELETE /_plugins/_ml/connectors/{connector_id}@. Idempotent: a +-- missing connector returns HTTP 200 with @result = "not_found"@. +deleteConnector :: + ConnectorId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteConnector connId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "connectors", unConnectorId connId] + +-- ========================================================================= +-- ML Commons memory and message APIs +-- ========================================================================= + +-- | 'createMemory' creates a conversation memory via +-- @POST /_plugins/_ml/memory/@ (OS 2.12+). +-- See . +createMemory :: + CreateMemoryRequest -> + BHRequest StatusDependant (ParsedEsResponse CreateMemoryResponse) +createMemory req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory"] + +-- | 'updateMemory' updates a memory's @name@ via +-- @PUT /_plugins/_ml/memory/{memory_id}@. The response is the standard +-- document-update envelope. +updateMemory :: + MemoryId -> + CreateMemoryRequest -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateMemory memoryId req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", unMemoryId memoryId] + +-- | 'getMemory' fetches a single memory by id via +-- @GET /_plugins/_ml/memory/{memory_id}@. +getMemory :: + MemoryId -> + BHRequest StatusDependant (ParsedEsResponse Memory) +getMemory memoryId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", unMemoryId memoryId] + +-- | 'listMemories' lists memories (newest first) via +-- @GET /_plugins/_ml/memory@. Both arguments are optional query +-- parameters: @maxResults@ maps to @max_results@ (default 10) and +-- @nextToken@ maps to @next_token@ (default 0, the index of the first +-- memory to return). +listMemories :: + Maybe Int -> + Maybe Int -> + BHRequest StatusDependant (ParsedEsResponse ListMemoriesResponse) +listMemories mMaxResults mNextToken = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_ml", "memory"] + endpoint = withQueries baseEndpoint renderedPairs + renderedPairs = + catMaybes + [ fmap (\n -> ("max_results", Just (T.pack (show n)))) mMaxResults, + fmap (\n -> ("next_token", Just (T.pack (show n)))) mNextToken + ] + +-- | 'searchMemory' searches the @.plugins-ml-memory-meta@ index via +-- @POST /_plugins/_ml/memory/_search@. The backing index does not exist +-- until the first memory is created, so a 404 is decoded as an empty +-- result. +searchMemory :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult Memory)) +searchMemory mQuery = + withBHResponseParsedEsResponse $ + searchMLWithEmptyIndex404 $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'deleteMemory' deletes a memory by id via +-- @DELETE /_plugins/_ml/memory/{memory_id}@. The response is +-- @{success: }@. Unlike connector \/ model-group delete, memory +-- delete is /not/ idempotent — a missing memory returns HTTP 404. +deleteMemory :: + MemoryId -> + BHRequest StatusDependant (ParsedEsResponse DeleteMemoryResponse) +deleteMemory memoryId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", unMemoryId memoryId] + +-- | 'createMemoryMessage' appends a message to a memory via +-- @POST /_plugins/_ml/memory/{memory_id}/messages@. At least one +-- request field must be non-null. +createMemoryMessage :: + MemoryId -> + CreateMemoryMessageRequest -> + BHRequest StatusDependant (ParsedEsResponse CreateMemoryMessageResponse) +createMemoryMessage memoryId req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", unMemoryId memoryId, "messages"] + +-- | 'updateMemoryMessage' updates a message's @additional_info@ via +-- @PUT /_plugins/_ml/memory/message/{message_id}@. Only @additional_info@ +-- is updatable; the other 'CreateMemoryMessageRequest' fields are +-- write-once and ignored on update. The response is the standard +-- document-update envelope. +updateMemoryMessage :: + MessageId -> + CreateMemoryMessageRequest -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateMemoryMessage messageId req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", "message", unMessageId messageId] + +-- | 'getMemoryMessage' fetches a single message by id via +-- @GET /_plugins/_ml/memory/message/{message_id}@. +getMemoryMessage :: + MessageId -> + BHRequest StatusDependant (ParsedEsResponse MemoryMessage) +getMemoryMessage messageId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", "message", unMessageId messageId] + +-- | 'listMemoryMessages' lists the messages in a memory via +-- @GET /_plugins/_ml/memory/{memory_id}/messages@. +listMemoryMessages :: + MemoryId -> + BHRequest StatusDependant (ParsedEsResponse ListMemoryMessagesResponse) +listMemoryMessages memoryId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", unMemoryId memoryId, "messages"] + +-- | 'searchMemoryMessages' searches the messages of a memory via +-- @POST /_plugins/_ml/memory/{memory_id}/_search@. The backing +-- @.plugins-ml-memory-message@ index does not exist until the first +-- message is created, so a 404 is decoded as an empty result. +searchMemoryMessages :: + MemoryId -> + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult MemoryMessage)) +searchMemoryMessages memoryId mQuery = + withBHResponseParsedEsResponse $ + searchMLWithEmptyIndex404 $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", unMemoryId memoryId, "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'getMemoryTraces' fetches the trace messages of a message via +-- @GET /_plugins/_ml/memory/message/{message_id}/traces@. Traces are +-- diagnostic sub-messages recording an agent's intermediate tool calls. +getMemoryTraces :: + MessageId -> + BHRequest StatusDependant (ParsedEsResponse MemoryMessageTraces) +getMemoryTraces messageId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", "message", unMessageId messageId, "traces"] + +-- ========================================================================= +-- ML Commons controller APIs +-- ========================================================================= + +-- | 'createController' creates a per-user rate-limit controller for a +-- model via @POST /_plugins/_ml/controllers/{model_id}@ (OS 2.12+). +-- POST overwrites the entire @user_rate_limiter@ map. The controller is +-- keyed by the model's id. +-- See . +createController :: + ModelId -> + ControllerConfig -> + BHRequest StatusDependant (ParsedEsResponse ControllerCreateResponse) +createController modelId config = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode config) + where + endpoint = mkEndpoint ["_plugins", "_ml", "controllers", unModelId modelId] + +-- | 'updateController' updates a controller via +-- @PUT /_plugins/_ml/controllers/{model_id}@. PUT updates individual +-- user entries, preserving others. The response is the standard +-- document-update envelope. +updateController :: + ModelId -> + ControllerConfig -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateController modelId config = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode config) + where + endpoint = mkEndpoint ["_plugins", "_ml", "controllers", unModelId modelId] + +-- | 'getController' fetches a controller by model id via +-- @GET /_plugins/_ml/controllers/{model_id}@. Returns HTTP 404 when no +-- controller exists for the model. +getController :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse ControllerConfig) +getController modelId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "controllers", unModelId modelId] + +-- | 'deleteController' deletes a controller via +-- @DELETE /_plugins/_ml/controllers/{model_id}@. Returns HTTP 404 with +-- @index_not_found_exception@ when the @.plugins-ml-controller@ index +-- does not exist. +deleteController :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteController modelId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "controllers", unModelId modelId] + +-- ========================================================================= +-- ML Commons profile API +-- ========================================================================= + +-- | 'getMLProfile' profiles ML models and tasks across all nodes via +-- @GET /_plugins/_ml/profile@. Pass @'Just' body@ to filter by +-- @node_ids@ \/ @model_ids@ \/ @task_ids@ or to toggle +-- @return_all_tasks@ \/ @return_all_models@; pass 'Nothing' for the +-- bodyless form that returns everything. Use 'getMLProfileModels', +-- 'getMLProfileModel', 'getMLProfileTasks', or 'getMLProfileTask' for +-- the path-scoped forms. +-- See . +getMLProfile :: + Maybe MLProfileRequest -> + BHRequest StatusDependant (ParsedEsResponse MLProfileResponse) +getMLProfile mReq = + withBHResponseParsedEsResponse $ + case mReq of + Nothing -> get @StatusDependant endpoint + Just req -> getWithBody @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "profile"] + +-- | 'getMLProfileModels' profiles all deployed models via +-- @GET /_plugins/_ml/profile/models@. +getMLProfileModels :: + BHRequest StatusDependant (ParsedEsResponse MLProfileResponse) +getMLProfileModels = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "profile", "models"] + +-- | 'getMLProfileModel' profiles one or more models via +-- @GET /_plugins/_ml/profile/models/{model_id}@. Pass multiple ids to +-- fetch several profiles at once (rendered as a single comma-separated +-- path segment). +getMLProfileModel :: + [ModelId] -> + BHRequest StatusDependant (ParsedEsResponse MLProfileResponse) +getMLProfileModel modelIds = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + segment = T.intercalate "," (map unModelId modelIds) + endpoint = mkEndpoint ["_plugins", "_ml", "profile", "models", segment] + +-- | 'getMLProfileTasks' profiles all ML tasks via +-- @GET /_plugins/_ml/profile/tasks@. +getMLProfileTasks :: + BHRequest StatusDependant (ParsedEsResponse MLProfileResponse) +getMLProfileTasks = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "profile", "tasks"] + +-- | 'getMLProfileTask' profiles one or more tasks via +-- @GET /_plugins/_ml/profile/tasks/{task_id}@. Pass multiple ids to +-- fetch several profiles at once (rendered as a single comma-separated +-- path segment). +getMLProfileTask :: + [MLTaskId] -> + BHRequest StatusDependant (ParsedEsResponse MLProfileResponse) +getMLProfileTask taskIds = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + segment = T.intercalate "," (map unMLTaskId taskIds) + endpoint = mkEndpoint ["_plugins", "_ml", "profile", "tasks", segment] + +-- ========================================================================= +-- ML Commons search helpers +-- ========================================================================= + +-- | Empty 'SearchResult' substituted by 'searchMLWithEmptyIndex404' when +-- a plugin's backing @.plugins-ml-*@ system index does not yet exist. +emptyMLSearchResult :: SearchResult a +emptyMLSearchResult = + SearchResult + { took = 0, + timedOut = False, + shards = ShardResult 0 0 0 0, + searchHits = mempty, + aggregations = Nothing, + scrollId = Nothing, + suggest = Nothing, + pitId = Nothing + } + +-- | Wrap a plugin search 'BHRequest' so that the HTTP 404 +-- @index_not_found_exception@ the plugin returns when its backing +-- @.plugins-ml-*@ system index does not yet exist decodes as +-- 'emptyMLSearchResult' instead of an 'EsError'. Mirrors the +-- 'searchAgents' empty-cluster handling. +searchMLWithEmptyIndex404 :: + BHRequest StatusDependant (SearchResult a) -> + BHRequest StatusDependant (SearchResult a) +searchMLWithEmptyIndex404 base = base {bhRequestParser = parser} + where + parser resp + | isMLIndexMissing404 resp = Right (Right emptyMLSearchResult) + | otherwise = bhRequestParser base resp + isMLIndexMissing404 resp = + statusCodeIs (404, 404) resp + && case eitherDecode (responseBody (getResponse resp)) of + Right es -> "no such index" `T.isInfixOf` errorMessage (es :: EsError) + Left _ -> False + +-- ========================================================================= +-- k-NN plugin +-- ========================================================================= + +-- | 'warmupKnnIndex' calls the k-NN plugin Warmup API +-- (@GET /_plugins/_knn/warmup/{index}@). Loads the k-NN native library +-- indices for the supplied indices into memory on the data nodes so the +-- first k-NN search against each index does not pay the native-engine +-- load latency. The request carries no body; the response is a +-- 'ShardsResult' (@{\"_shards\":{...}}@ envelope) reporting how many +-- shards scheduled the load. +-- +-- The @index@ path segment follows the OpenSearch multi-target syntax: the +-- supplied list is rendered as a single comma-separated segment +-- (e.g. @[i1, i2]@ becomes @i1,i2@). An empty list renders an empty +-- segment and the server will respond with an error. +-- +-- The warmup is asynchronous: the response is returned as soon as the +-- load is scheduled, not when it completes. +-- +-- For more information see +-- . +warmupKnnIndex :: + [IndexName] -> + BHRequest StatusIndependant ShardsResult +warmupKnnIndex indexNames = + get endpoint + where + endpoint = mkEndpoint ["_plugins", "_knn", "warmup", T.intercalate "," (map unIndexName indexNames)] + +-- | 'clearKnnCache' calls the k-NN plugin Clear Cache API +-- (@POST /_plugins/_knn/clear_cache/{index}@), available since OpenSearch 2.14. +-- Drops the native cache entries that @faiss@ and @nmslib@ (deprecated) +-- maintain for the supplied indices, freeing the associated native-memory +-- reservations. This API has no effect on @lucene@ indexes — their graph +-- lives in the Lucene heap and is not cleared here. The request body is +-- an empty JSON object (@{}@); the response is a 'ShardsResult' +-- (@{\"_shards\":{...}}@ envelope) reporting how many shards were +-- cleared. The resulting cache-size drop is visible immediately in +-- 'getKnnStats'. +-- +-- The @index@ path segment follows the OpenSearch multi-target syntax: the +-- supplied list is rendered as a single comma-separated segment +-- (e.g. @[i1, i2]@ becomes @i1,i2@). An empty list renders an empty +-- segment and the server will respond with an error. +-- +-- For more information see +-- . +clearKnnCache :: + [IndexName] -> + BHRequest StatusIndependant ShardsResult +clearKnnCache indexNames = + post endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_knn", "clear_cache", T.intercalate "," (map unIndexName indexNames)] + +-- | 'getKnnStats' calls the k-NN plugin Stats API +-- (@GET /_plugins/_knn/[{nodeId}/]stats[/{stat}]@). Both arguments are +-- optional and select, respectively, which node(s) to query (defaults to all) +-- and which stat(s) to return (defaults to all). +-- +-- The response body is a typed envelope ('KnnStats') — a flat +-- 'Map.Map Text Value' whose top-level keys are either cluster-level +-- stat names (mapping to scalars) or the literal @nodes@ key (mapping to +-- a per-node map keyed by opaque node ID); see the module docs of +-- 'KnnStats' for why the entries are kept as aeson 'Value's rather than +-- modelled per-stat, and for how to navigate to a given node or cluster +-- value. +-- +-- For more information see +-- . +getKnnStats :: + Maybe KnnNodeId -> + Maybe KnnStatName -> + BHRequest StatusDependant (ParsedEsResponse KnnStats) +getKnnStats mNodeId mStatName = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint segments + segments = + ["_plugins", "_knn"] + <> foldMap (pure . unKnnNodeId) mNodeId + <> ["stats"] + <> foldMap (pure . unKnnStatName) mStatName + +-- | 'getKnnModel' calls the k-NN plugin Get Model API +-- (@GET /_plugins/_knn/models/{model_id}@). Returns the model's metadata, +-- including its lifecycle 'KnnModelState', the base64-serialized +-- 'knnModelModelBlob' (large, often excluded server-side via @?filter_path@), +-- the vector 'knnModelDimension' and distance 'knnModelSpaceType', and the +-- native 'knnModelEngine' (@faiss@ or deprecated @nmslib@). The response is a +-- bare object (no envelope), decoded into 'KnnModel'. +-- +-- For more information see +-- . +getKnnModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse KnnModel) +getKnnModel modelId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_knn", "models", unModelId modelId] + +-- | 'trainKnnModel' calls the k-NN plugin Train Model API +-- (@POST /_plugins/_knn/models/{model_id}/_train@). Schedules asynchronous +-- training of a native library model (FAISS IVF and friends) from the +-- @knn_vector@ field of a training index. The request returns as soon as +-- training is scheduled, carrying only the @model_id@ in +-- 'KnnTrainResponse'; the model enters the @training@ state. Poll +-- 'getKnnModel' to observe the transition to @created@ (success) or +-- @failed@ (with the @error@ field populated). +-- +-- Equivalent to 'trainKnnModelWith' with @Nothing@ (no node preference). +-- +-- For more information see +-- . +trainKnnModel :: + ModelId -> + KnnTrainingRequest -> + BHRequest StatusDependant (ParsedEsResponse KnnTrainResponse) +trainKnnModel = trainKnnModelWith Nothing + +-- | 'trainKnnModelWith' extends 'trainKnnModel' with an optional +-- @?preference@ query parameter. Supplying 'Just' a 'KnnNodeId' pins the +-- asynchronous training task to the specified data node, sent on the wire +-- as @?preference={node_id}@; 'Nothing' lets OpenSearch choose the training +-- node. The pinned node must already host a shard of the training index, +-- otherwise OpenSearch rejects the request. +-- +-- For more information see +-- . +trainKnnModelWith :: + Maybe KnnNodeId -> + ModelId -> + KnnTrainingRequest -> + BHRequest StatusDependant (ParsedEsResponse KnnTrainResponse) +trainKnnModelWith mNodeId modelId req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + baseEndpoint = mkEndpoint ["_plugins", "_knn", "models", unModelId modelId, "_train"] + endpoint = case mNodeId of + Nothing -> baseEndpoint + Just nodeId -> withQueries baseEndpoint [("preference", Just (unKnnNodeId nodeId))] + +-- | 'deleteKnnModel' calls the k-NN plugin Delete Model API +-- (@DELETE /_plugins/_knn/models/{model_id}@). Removes a trained model +-- from the cluster's @.opensearch-knn-models@ system index. The response +-- is a 'KnnDeleteModelResponse' echoing the @model_id@ and reporting +-- @result = "deleted"@ — note this is NOT the standard 'Acknowledged' +-- envelope (the k-NN plugin returns a richer response than the typical +-- cluster-level ack). A 404 for a missing model id surfaces as an +-- 'EsError' under 'StatusDependant', matching 'getKnnModel' and the ML +-- Commons 'deleteModel' precedent. +-- +-- For more information see +-- . +deleteKnnModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse KnnDeleteModelResponse) +deleteKnnModel modelId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_knn", "models", unModelId modelId] + +-- | 'searchKnnModels' searches the @.opensearch-knn-models@ system index +-- via @POST /_plugins/_knn/models/_search@ (k-NN plugin Search Models +-- API). The caller drives the query entirely through the standard +-- bloodhound 'Search' DSL — pagination (@from@\/@size@), filtering, +-- sorting, and @_source@ projection (use 'source' to exclude the large +-- 'knnModelModelBlob', mirroring the docs' +-- @_source_excludes=model_blob@ example). +-- +-- The response is the standard OpenSearch search envelope, decoded as +-- 'SearchResult' whose hits carry a 'KnnModel' in each @_source@. The +-- 'KnnModel' parser tolerates any field except @model_id@ being absent, +-- so a blob-excluding @_source@ projection decodes cleanly. +-- +-- Surfaced as 'StatusDependant' so a non-2xx response is parsed as an +-- 'EsError' and thrown by 'performBHRequest' — matching the vanilla +-- search envelope rather than 'getKnnModel' and 'deleteKnnModel', which +-- capture the error as a value via 'ParsedEsResponse'. +-- +-- For more information see +-- . +searchKnnModels :: + Search -> + BHRequest StatusDependant (SearchResult KnnModel) +searchKnnModels search = + post @StatusDependant endpoint (encode search) + where + endpoint = mkEndpoint ["_plugins", "_knn", "models", "_search"] + +-- ========================================================================= +-- Async Search plugin +-- ========================================================================= + +-- | 'submitOSAsyncSearch' submits a 'Search' for asynchronous execution via +-- the OpenSearch async search plugin (@POST /_plugins/_asynchronous_search@). It +-- returns immediately with an id and partial results; poll the returned id +-- with 'getOSAsyncSearch' until 'asyncSearchIsRunning' is @False@. +-- +-- The OpenSearch async search response is shaped exactly like Elasticsearch's +-- (the plugin was forked from ES 7.7's async search), so the result is decoded +-- into the shared 'AsyncSearchResult' — no OpenSearch-specific type is needed. +-- +-- Equivalent to @'submitOSAsyncSearchWith' 'defaultAsyncSearchSubmitOptions'@ +-- — it forwards no URI parameters. +-- +-- For more information see +-- . +submitOSAsyncSearch :: + (FromJSON a) => + Search -> + BHRequest StatusDependant (AsyncSearchResult a) +submitOSAsyncSearch = submitOSAsyncSearchWith defaultAsyncSearchSubmitOptions + +-- | Like 'submitOSAsyncSearch' but accepts 'AsyncSearchSubmitOptions' +-- carrying the URI parameters documented for +-- @POST /_plugins/_asynchronous_search@. OpenSearch documents only the +-- @wait_for_completion@, @keep_on_completion@ and @keep_alive@ parameters; +-- the Elasticsearch-only 'assoBatchedReduceSize' and +-- 'assoCcsMinimizeRoundtrips' are silently dropped by the underlying +-- 'osAsyncSearchSubmitOptionsParams' renderer. 'defaultAsyncSearchSubmitOptions' +-- makes this byte-for-byte equivalent to 'submitOSAsyncSearch'. +-- +-- For more information see +-- . +submitOSAsyncSearchWith :: + (FromJSON a) => + AsyncSearchSubmitOptions -> + Search -> + BHRequest StatusDependant (AsyncSearchResult a) +submitOSAsyncSearchWith opts search = + post + (["_plugins", "_asynchronous_search"] `withQueries` osAsyncSearchSubmitOptionsParams opts) + (encode search) + +-- | 'getOSAsyncSearch' retrieves the current state and (partial or final) +-- results of an OpenSearch async search by id +-- (@GET /_plugins/_asynchronous_search/{id}@). +-- +-- For more information see +-- . +getOSAsyncSearch :: + (FromJSON a) => + AsyncSearchId -> + BHRequest StatusDependant (AsyncSearchResult a) +getOSAsyncSearch (AsyncSearchId searchId) = + get ["_plugins", "_asynchronous_search", searchId] + +-- | 'deleteOSAsyncSearch' deletes an OpenSearch async search result and its +-- context by id (@DELETE /_plugins/_asynchronous_search/{id}@) and returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteOSAsyncSearch :: + AsyncSearchId -> + BHRequest StatusIndependant Acknowledged +deleteOSAsyncSearch (AsyncSearchId searchId) = + delete ["_plugins", "_asynchronous_search", searchId] + +-- | 'getOSAsyncSearchStats' fetches cluster-wide async-search statistics +-- via @GET /_plugins/_asynchronous_search/stats@. Returns per-node +-- counters for the nine documented async-search lifecycle events +-- (submitted, initialized, rejected, search_completed, search_failed, +-- persisted, persist_failed, running_current, cancelled). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getOSAsyncSearchStats :: + BHRequest StatusDependant AsyncSearchStatsResponse +getOSAsyncSearchStats = + get ["_plugins", "_asynchronous_search", "stats"] + +-- ========================================================================= +-- SQL & PPL plugin +-- ========================================================================= + +-- | 'sqlQuery' calls the SQL plugin Query API +-- (@POST /_plugins/_sql@). Executes a SQL query against the cluster and +-- returns a JDBC-style rowset ('SQLResult'). Pagination is opt-in: pass a +-- positive 'sqlRequestFetchSize' to receive a 'SQLResult' carrying a +-- 'sqlResultCursor' and then use 'sqlQueryNextPage' to walk subsequent +-- pages. Release an unfinished cursor with 'closeSqlCursor' to free the +-- server-side context. +-- +-- Surfaced as 'StatusDependant' so a 4xx error (bad SQL, missing index) +-- decodes as 'EsError' rather than throwing. +-- +-- For more information see +-- . +sqlQuery :: + SQLRequest -> + BHRequest StatusDependant (ParsedEsResponse SQLResult) +sqlQuery req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_sql"] + +-- | 'sqlQueryNextPage' fetches the next page of a paginated SQL result by +-- POSTing a cursor body (@{"cursor": ...}@) to @/_plugins/_sql@. Use the +-- 'sqlResultCursor' returned by the previous 'sqlQuery' or +-- 'sqlQueryNextPage' call. Continuation responses carry only 'sqlResultDatarows' +-- and a new 'sqlResultCursor'; @schema@, @total@, @size@ and @status@ are +-- dropped by the server, so every other 'SQLResult' field is 'Maybe'. +-- +-- When the response no longer carries a 'sqlResultCursor' the last page has +-- been consumed and the server-side context is released automatically; no +-- 'closeSqlCursor' call is needed in that case. +-- +-- For more information see +-- . +sqlQueryNextPage :: + SQLCursor -> + BHRequest StatusDependant (ParsedEsResponse SQLResult) +sqlQueryNextPage cursor = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (SQLCursorRequest cursor)) + where + endpoint = mkEndpoint ["_plugins", "_sql"] + +-- | 'closeSqlCursor' releases the server-side context held by a SQL +-- pagination cursor (@POST /_plugins/_sql/close@). Call this to free the +-- context when you stop reading before the cursor is naturally exhausted +-- (i.e. before 'sqlResultCursor' disappears from a 'sqlQueryNextPage' +-- response). Closing an already-released cursor is a no-op server-side. +-- +-- For more information see +-- . +closeSqlCursor :: + SQLCursor -> + BHRequest StatusDependant (ParsedEsResponse SQLCloseResult) +closeSqlCursor cursor = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (SQLCursorRequest cursor)) + where + endpoint = mkEndpoint ["_plugins", "_sql", "close"] + +-- | 'explainSQL' calls the SQL plugin Explain API +-- (@POST /_plugins/_sql/_explain@). Translates a SQL query into the underlying +-- Elasticsearch query DSL without executing it. The request body is the same +-- 'SQLRequest' shape accepted by 'sqlQuery'. The response is a free-form JSON +-- object whose structure tracks the translated DSL (and varies by query and +-- plugin version), so it is returned as an opaque aeson 'Value'. +-- +-- Surfaced as 'StatusDependant' so a 4xx error (bad SQL, missing index) +-- decodes as 'EsError' rather than throwing. +-- +-- For more information see +-- . +explainSQL :: + SQLRequest -> + BHRequest StatusDependant (ParsedEsResponse Value) +explainSQL req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_sql", "_explain"] + +-- | 'pplQuery' calls the PPL plugin Query API +-- (@POST /_plugins/_ppl@). Executes a PPL (Piped Processing Language) query +-- against the cluster and returns the same JDBC-style rowset shape as +-- 'sqlQuery' (typed here as 'PPLResult', an alias of 'SQLResult'). PPL does +-- not support cursor pagination (the plugin documents 'fetch_size' as +-- SQL-only), so 'sqlResultCursor' will always be 'Nothing' on a PPL +-- response. +-- +-- Surfaced as 'StatusDependant' so a 4xx error decodes as 'EsError'. +-- +-- For more information see +-- . +pplQuery :: + PPLRequest -> + BHRequest StatusDependant (ParsedEsResponse PPLResult) +pplQuery req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ppl"] + +-- | 'explainPPL' calls the PPL plugin Explain API +-- (@POST /_plugins/_ppl/_explain@). Translates a PPL query into the underlying +-- Elasticsearch query DSL without executing it. The request body is the same +-- 'PPLRequest' shape accepted by 'pplQuery'. The response is a free-form JSON +-- object whose structure tracks the translated DSL (and varies by query and +-- plugin version), so it is returned as an opaque aeson 'Value'. +-- +-- Surfaced as 'StatusDependant' so a 4xx error decodes as 'EsError'. +-- +-- For more information see +-- . +explainPPL :: + PPLRequest -> + BHRequest StatusDependant (ParsedEsResponse Value) +explainPPL req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ppl", "_explain"] + +-- | 'getSQLStats' calls the SQL plugin Stats API +-- (@GET /_plugins/_sql/stats@). Returns node-level plugin metrics as a flat +-- 'SQLPluginStats' map (cluster-level stats are not implemented by the +-- plugin; the response describes only the node you hit). The metric-name +-- set is large and grows across OpenSearch releases (eight keys on 1.x; +-- @ppl_*@, @datasource_*@, @async_query_*@, @emr_*@ and @streaming_*@ +-- keys land later), so the body is decoded as 'Data.Aeson.Value' entries +-- keyed by metric name. +-- +-- Surfaced as 'StatusDependant' so a 404 (SQL plugin not installed) +-- decodes as 'EsError' rather than throwing. +-- +-- For more information see +-- . +getSQLStats :: + BHRequest StatusDependant (ParsedEsResponse SQLPluginStats) +getSQLStats = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_sql", "stats"] + +-- ========================================================================= +-- Notifications plugin +-- ========================================================================= + +-- | 'createNotificationConfig' calls the Notifications plugin Create Config +-- API (@POST /_plugins/_notifications/configs@). Persists a new +-- notification channel configuration (a Slack webhook, an email account, +-- an SNS topic, ...) to the @.opendistro-notifications-config@ system +-- index and returns the resulting 'CreateNotificationConfigResponse', +-- which echoes the server-assigned @config_id@. +-- +-- Equivalent to 'createNotificationConfigWith' with 'Nothing' — the +-- server generates the @config_id@. Supply a custom id via +-- 'createNotificationConfigWith' if you need a stable, predictable +-- identifier (a pre-existing id yields HTTP 409, surfacing as an +-- 'EsError' under 'StatusDependant'). +-- +-- For more information see +-- . +createNotificationConfig :: + NotificationConfig -> + BHRequest StatusDependant (ParsedEsResponse CreateNotificationConfigResponse) +createNotificationConfig = createNotificationConfigWith Nothing + +-- | 'createNotificationConfigWith' is the parameterized variant of +-- 'createNotificationConfig': the optional 'Text' is forwarded as the +-- @config_id@ of the request body. Pass 'Nothing' to let OpenSearch +-- generate one; pass @'Just' id@ for a stable identifier, bearing in +-- mind that a duplicate surfaces as HTTP 409 ('EsError'). +-- See . +createNotificationConfigWith :: + Maybe Text -> + NotificationConfig -> + BHRequest StatusDependant (ParsedEsResponse CreateNotificationConfigResponse) +createNotificationConfigWith mConfigId config = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_notifications", "configs"] + req = CreateNotificationConfigRequest mConfigId config + +-- | 'deleteNotificationConfig' calls the Notifications plugin Delete Config +-- API (@DELETE /_plugins/_notifications/configs/{config_id}@). Removes the +-- named channel configuration from the @.opendistro-notifications-config@ +-- system index and returns a 'DeleteNotificationConfigResponse' mapping +-- the requested @config_id@ to its per-id deletion status (@"OK"@ on +-- success). Use 'deleteResponseStatus' \/ 'deleteResponseAllOK' to +-- inspect the result. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @config_id@, or the +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- This is the single-id variant; for batch deletion use +-- 'deleteNotificationConfigs' with the @config_id_list@ query. +-- +-- For more information see +-- . +deleteNotificationConfig :: + Text -> + BHRequest StatusDependant (ParsedEsResponse DeleteNotificationConfigResponse) +deleteNotificationConfig configId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_notifications", "configs", configId] + +-- | 'deleteNotificationConfigs' is the batch variant of +-- 'deleteNotificationConfig': it calls +-- @DELETE /_plugins/_notifications/configs/?config_id_list=id1,id2,...@ +-- and removes every supplied channel configuration in a single +-- round-trip. The plugin returns the same 'DeleteNotificationConfigResponse' +-- shape as the single-id variant, mapping each requested id to its +-- per-id deletion status (@"OK"@ on success, a failure tag otherwise); +-- use 'deleteResponseStatus' to inspect a specific id or +-- 'deleteResponseAllOK' to summarise the whole batch. The batch +-- variant is preferred when sweeping many configs: it amortises the +-- per-request RBAC and system-index refresh cost. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @config_id@, or the +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- An empty id list is rejected by the plugin with HTTP 400; callers +-- who want a no-op on empty should guard the call site. The +-- @config_id_list@ value is rendered comma-separated by the underlying +-- 'withQueries' without URL-encoding, so config ids must not contain +-- @,@ (which would inject extra ids) or other URL-significant +-- characters (@&@, @=@, @\/@). The plugin emits URL-safe server-assigned +-- identifiers (e.g. @0Jnlh4ABa4TCWn5C5H2G@), so this only bites +-- hand-rolled ids. +-- +-- For more information see +-- . +deleteNotificationConfigs :: + NonEmpty Text -> + BHRequest StatusDependant (ParsedEsResponse DeleteNotificationConfigResponse) +deleteNotificationConfigs configIds = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_notifications", "configs"] + `withQueries` [("config_id_list", Just (T.intercalate "," (toList configIds)))] + +-- | 'getNotificationConfigs' lists every notification channel +-- configuration via the Notifications plugin +-- (@GET /_plugins/_notifications/configs@). Returns each entry as a +-- 'NotificationConfigEntry' (config_id + timestamps + the full +-- 'NotificationConfig'). Equivalent to 'getNotificationConfigsWith' +-- with 'defaultNotificationListOptions' (no filtering or pagination). +-- +-- Surfaced as 'StatusDependant' so a 404 (plugin not installed) +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getNotificationConfigs :: + BHRequest StatusDependant (ParsedEsResponse [NotificationConfigEntry]) +getNotificationConfigs = getNotificationConfigsWith defaultNotificationListOptions + +-- | 'getNotificationConfigsWith' is the parameterized variant of +-- 'getNotificationConfigs': the supplied 'NotificationListOptions' are +-- forwarded as query-string parameters (filtering by config_id \/ type +-- \/ enabled state, pagination via from_index \/ max_items, and +-- sort_order \/ sort_field). Pass 'defaultNotificationListOptions' for +-- the plain no-arg GET. +-- +-- The paging envelope (@start_index@, @total_hits@, +-- @total_hit_relation@) is decoded and discarded; the public return +-- type is the bare @config_list@. File a feature request if you need +-- the paging metadata surfaced. +-- +-- For more information see +-- . +getNotificationConfigsWith :: + NotificationListOptions -> + BHRequest StatusDependant (ParsedEsResponse [NotificationConfigEntry]) +getNotificationConfigsWith opts = + fmap (fmap getNotificationConfigsResponseConfigList) + . withBHResponseParsedEsResponse + $ get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_notifications", "configs"] + `withQueries` notificationListOptionsParams opts + +-- | 'getNotificationChannels' lists every notification channel via the +-- Notifications plugin (@GET /_plugins/_notifications/channels@). The +-- channels endpoint is the lightweight \"runtime\" view: each 'Channel' +-- carries the identifying metadata (config_id, name, description, +-- config_type, is_enabled) but omits the transport-specific details +-- exposed by 'getNotificationConfigs'. Equivalent to +-- 'getNotificationChannelsWith' with 'defaultNotificationListOptions'. +-- +-- Surfaced as 'StatusDependant' so a 404 (plugin not installed) +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getNotificationChannels :: + BHRequest StatusDependant (ParsedEsResponse [Channel]) +getNotificationChannels = getNotificationChannelsWith defaultNotificationListOptions + +-- | 'getNotificationChannelsWith' is the parameterized variant of +-- 'getNotificationChannels': the supplied 'NotificationListOptions' are +-- forwarded as query-string parameters (same filter \/ pagination +-- surface as 'getNotificationConfigsWith'). Pass +-- 'defaultNotificationListOptions' for the plain no-arg GET. +-- +-- The paging envelope is decoded and discarded; the public return type +-- is the bare @channel_list@. +-- +-- For more information see +-- . +getNotificationChannelsWith :: + NotificationListOptions -> + BHRequest StatusDependant (ParsedEsResponse [Channel]) +getNotificationChannelsWith opts = + fmap (fmap getNotificationChannelsResponseChannelList) + . withBHResponseParsedEsResponse + $ get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_notifications", "channels"] + `withQueries` notificationListOptionsParams opts + +-- | 'getNotificationConfig' fetches a single notification channel +-- configuration by id via the Notifications plugin +-- (@GET /_plugins/_notifications/configs/{config_id}@). The endpoint +-- returns the same @start_index@ \/ @total_hits@ \/ @total_hit_relation@ +-- \/ @config_list@ envelope as the list-all 'getNotificationConfigs', +-- with @total_hits@ clamped to @1@ and a single-element @config_list@ +-- on hit; we decode the envelope and project out the lone entry as a +-- 'Maybe' (using 'listToMaybe') so the public type reads as a plain +-- per-id lookup. The 'Nothing' branch surfaces when the server returns +-- HTTP 200 with an empty @config_list@ — a genuine miss is expected to +-- come back as HTTP 404 (surfacing as @'Left' 'EsError'@ via +-- 'StatusDependant' before the body decode runs), but the plugin +-- version-dependent miss encoding is not pinned by a live test, so +-- 'Nothing' is the total fallback rather than a partial head. Callers +-- needing the paging metadata can build the underlying request +-- directly. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @config_id@, or the +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getNotificationConfig :: + Text -> + BHRequest StatusDependant (ParsedEsResponse (Maybe NotificationConfigEntry)) +getNotificationConfig configId = + fmap (fmap (listToMaybe . getNotificationConfigsResponseConfigList)) + . withBHResponseParsedEsResponse + $ get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_notifications", "configs", configId] + +-- | 'updateNotificationConfig' replaces a notification channel +-- configuration via the Notifications plugin +-- (@PUT /_plugins/_notifications/configs/{config_id}@). The body is +-- the 'NotificationConfig' wrapped under the @config@ key (see +-- 'UpdateNotificationConfigRequest'); the @config_id@ identity is the +-- URL path segment, not a body field, so a body shaped like +-- 'CreateNotificationConfigRequest' would be rejected server-side. +-- The response echoes the @config_id@ as a +-- 'CreateNotificationConfigResponse' (the same shape the create +-- endpoint returns). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing @config_id@ +-- (or a 409 on a concurrent modification) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +updateNotificationConfig :: + Text -> + NotificationConfig -> + BHRequest StatusDependant (ParsedEsResponse CreateNotificationConfigResponse) +updateNotificationConfig configId config = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_notifications", "configs", configId] + req = UpdateNotificationConfigRequest config + +-- | 'getNotificationFeatures' lists the channel configuration types +-- this cluster's Notifications plugin supports via +-- @GET /_plugins/_notifications/features@. The result is a +-- 'NotificationFeaturesResponse' carrying the @allowed_config_type_list@ +-- (a subset of 'NotificationConfigType') and the @plugin_features@ +-- feature-flag map. Useful for capability discovery before creating a +-- config — e.g. gate an SNS setup on @NotificationConfigTypeSns@ +-- being present in 'notificationFeaturesResponseAllowedConfigTypeList'. +-- +-- Surfaced as 'StatusDependant' so a 404 (plugin not installed) +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getNotificationFeatures :: + BHRequest StatusDependant (ParsedEsResponse NotificationFeaturesResponse) +getNotificationFeatures = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_notifications", "features"] + +-- | 'sendTestNotification' triggers a one-shot probe delivery to the +-- channel identified by @config_id@ via the Notifications plugin +-- (@GET /_plugins/_notifications/feature/test/{config_id}@). The +-- plugin synthesises an 'TestNotificationEventSource' (title, +-- reference_id, severity, tags), attempts delivery through the +-- config's transport, and returns a 'TestNotificationResponse' +-- carrying a per-config 'TestNotificationStatus' with the upstream +-- delivery result (HTTP code + raw response body in +-- 'testNotificationDeliveryStatusText'). The probe is a real +-- delivery attempt: a Slack config POSTs to its webhook, an email +-- config sends mail, etc. — do not call this against production +-- channels from a loop. +-- +-- Surfaced as 'StatusDependant' so a 4xx (unknown @config_id@, +-- transport misconfiguration, plugin not installed) decodes as an +-- 'EsError' rather than throwing. +-- +-- For more information see +-- . +sendTestNotification :: + Text -> + BHRequest StatusDependant (ParsedEsResponse TestNotificationResponse) +sendTestNotification configId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_notifications", "feature", "test", configId] + +-- ========================================================================= +-- Alerting plugin +-- ========================================================================= + +-- | 'createMonitor' creates an alerting monitor via the Alerting plugin +-- (@POST /_plugins/_alerting/monitors@). The body is the encoded +-- 'Monitor'; the response is the 'MonitorResponse' wrapper carrying the +-- server-assigned @_id@, @_version@, @_seq_no@, @_primary_term@, and the +-- persisted monitor document. +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (invalid monitor body, +-- plugin not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +createMonitor :: + Monitor -> + BHRequest StatusDependant MonitorResponse +createMonitor monitor = + post (mkEndpoint ["_plugins", "_alerting", "monitors"]) (encode monitor) + +-- | 'getMonitor' fetches a single monitor by id via +-- @GET /_plugins/_alerting/monitors/{monitor_id}@. The endpoint returns +-- the 'MonitorResponse' wrapper on the wire +-- (@{_id,_version,_seq_no,_primary_term, monitor:{...}}@); the wrapper +-- is decoded and the 'Monitor' is projected out so the public type +-- matches the bead acceptance (@m 'Monitor'@). Callers needing the +-- indexing metadata can build the underlying request directly. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing monitor id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getMonitor :: + MonitorId -> + BHRequest StatusDependant Monitor +getMonitor (MonitorId mid) = + monitorResponseMonitor <$> get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_alerting", "monitors", mid] + +-- | 'updateMonitor' replaces a monitor via +-- @PUT /_plugins/_alerting/monitors/{monitor_id}@. The body is the +-- encoded 'Monitor'; the response is the same 'MonitorResponse' wrapper +-- as 'createMonitor' (with the incremented @_version@ and @_seq_no@). +-- Equivalent to 'updateMonitorWith' with 'Nothing' (no +-- optimistic-concurrency guard), so concurrent updates to the same +-- monitor id silently clobber each other. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing monitor id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateMonitor :: + MonitorId -> + Monitor -> + BHRequest StatusDependant MonitorResponse +updateMonitor monitorId monitor = updateMonitorWith monitorId monitor Nothing + +-- | 'updateMonitorWith' replaces a monitor via +-- @PUT /_plugins/_alerting/monitors/{monitor_id}@ with an optional +-- optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ — +-- both values read from a prior 'MonitorResponse' — to make the PUT +-- conditional on the monitor being unchanged since you last read it; a +-- stale pair causes OpenSearch to respond with HTTP 409 instead of +-- silently overwriting. Pass 'Nothing' for the unconditional semantics +-- of 'updateMonitor'. The two values must be supplied together: +-- OpenSearch rejects a partial pair with HTTP 400 (mirroring the +-- document-write @if_seq_no@ \/ @if_primary_term@ semantics). Mirrors +-- the 'putISMPolicyWith' precedent. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing monitor id (or a +-- 409 on a sequence-number mismatch) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +updateMonitorWith :: + MonitorId -> + Monitor -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant MonitorResponse +updateMonitorWith (MonitorId mid) monitor mOcc = + put @StatusDependant endpoint (encode monitor) + where + baseEndpoint = mkEndpoint ["_plugins", "_alerting", "monitors", mid] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries baseEndpoint $ + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'deleteMonitor' deletes a monitor by id via +-- @DELETE /_plugins/_alerting/monitors/{monitor_id}@. +-- +-- The return type 'DeleteMonitorResponse' deviates from the bead's +-- @m 'Acknowledged'@ acceptance: the body never carries an +-- @acknowledged@ key, so an 'Acknowledged' decoder would raise +-- 'EsProtocolException' at runtime (same deviation pattern as +-- bloodhound-04f.3.13 rethrottle). The exact shape is version-dependent +-- and live-verified on OS 1.3.19, 2.19.5 and 3.7.0 (bead +-- bloodhound-z5j): OS 1.3.x returns the full bare Elasticsearch +-- delete-document response; OS 2.x/3.x return only @_id@ + @_version@. +-- See the Haddock on 'DeleteMonitorResponse' for the field-level detail. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing monitor id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteMonitor :: + MonitorId -> + BHRequest StatusDependant DeleteMonitorResponse +deleteMonitor (MonitorId mid) = + delete (mkEndpoint ["_plugins", "_alerting", "monitors", mid]) + +-- | 'searchMonitors' searches the monitor store via +-- @GET /_plugins/_alerting/monitors/_search@. Pass 'Nothing' for the +-- plain empty-body @{}@ request that returns the first page of all +-- monitors; pass @'Just' query@ to paginate (@from@\/@size@) or filter +-- by name, type, enabled state, ... using the standard OpenSearch +-- query DSL carried opaquely in 'monitorsSearchQueryQuery'. +-- +-- The endpoint is documented as GET but, like the core search API, +-- carries the query DSL in the request body; 'getWithBody' sends a +-- GET with a body (mirrors the @GET /_render/template@ precedent). +-- +-- Returns the full search envelope 'SearchMonitorsResponse' so callers +-- can drive pagination and inspect @_shards@ health; use +-- 'searchMonitorsResponseMonitors' to project out just the @['Monitor']@ +-- list. Mirrors the Security Analytics 'searchSAPrePackagedRules' +-- precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchMonitors :: + Maybe MonitorsSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SearchMonitorsResponse) +searchMonitors mQuery = + withBHResponseParsedEsResponse $ + getWithBody @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_alerting", "monitors", "_search"] + body = encode (maybe defaultMonitorsSearchQuery id mQuery) + +-- | 'executeMonitor' runs a monitor's inputs and triggers immediately +-- (out of schedule) via +-- @POST /_plugins/_alerting/monitors/{monitor_id}/_execute@. The +-- endpoint takes no request body; a dry run (which exercises the +-- triggers without dispatching actions to destinations) is requested +-- with the @?dryrun=true@ query parameter, so pass @'Just' +-- ('ExecuteMonitorRequest' {dryrun = Just True})@ to set it. Pass +-- 'Nothing' for a real execution with action dispatch. +-- +-- Returns 'ExecuteMonitorResponse' (typed shell + opaque aeson +-- 'Value's for the per-kind @trigger_results@ \/ @input_results@ \/ +-- @script_actions@ sub-objects). Mirrors the ML Commons @predict@ +-- pragmatic-typing precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid monitor id, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +executeMonitor :: + MonitorId -> + Maybe ExecuteMonitorRequest -> + BHRequest StatusDependant (ParsedEsResponse ExecuteMonitorResponse) +executeMonitor (MonitorId mid) mRequest = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_alerting", "monitors", mid, "_execute"] + `withQueries` dryrunQuery + dryrunQuery = + case mRequest >>= executeMonitorRequestDryrun of + Just True -> [("dryrun", Just "true")] + _ -> [] + +-- ========================================================================= +-- Security Analytics plugin +-- ========================================================================= + +-- | 'createSADetector' creates a Security Analytics detector +-- (@POST /_plugins/_security_analytics/detectors@). The body is the +-- encoded 'SADetector'; the response is the 'SADetectorResponse' +-- wrapper carrying the server-assigned @_id@, @_version@, and the +-- persisted detector document (with server-injected @last_update_time@ +-- and @enabled_time@). +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (invalid detector body, +-- plugin not installed, RBAC denial) raises a structured 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +createSADetector :: + SADetector -> + BHRequest StatusDependant SADetectorResponse +createSADetector detector = + post (mkEndpoint ["_plugins", "_security_analytics", "detectors"]) (encode detector) + +-- | 'getSADetector' fetches a single detector by id via +-- @GET /_plugins/_security_analytics/detectors/{detector_id}@. The +-- endpoint returns the 'SADetectorResponse' wrapper on the wire +-- (@{_id,_version, detector:{...}}@); the wrapper is decoded and the +-- 'SADetector' is projected out so the public type matches the bead +-- acceptance (@m 'SADetector'@). Callers needing the indexing +-- metadata can build the underlying request directly. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getSADetector :: + DetectorId -> + BHRequest StatusDependant SADetector +getSADetector (DetectorId did) = + saDetectorResponseDetector <$> get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_security_analytics", "detectors", did] + +-- | 'updateSADetector' replaces a Security Analytics detector via +-- @PUT /_plugins/_security_analytics/detectors/{detector_id}@. The +-- body is the encoded 'SADetector'; the response is the same +-- 'SADetectorResponse' wrapper as 'createSADetector' (with the +-- incremented @_version@ and a refreshed @last_update_time@). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id +-- (or a 4xx for an invalid detector body) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +updateSADetector :: + DetectorId -> + SADetector -> + BHRequest StatusDependant SADetectorResponse +updateSADetector (DetectorId did) detector = + put (mkEndpoint ["_plugins", "_security_analytics", "detectors", did]) (encode detector) + +-- | 'deleteSADetector' deletes a Security Analytics detector via +-- @DELETE /_plugins/_security_analytics/detectors/{detector_id}@. +-- Returns 'DeleteSADetectorResponse', which is NOT an 'Acknowledged' +-- ack (an 'Acknowledged' decoder would raise 'EsProtocolException' at +-- runtime — same deviation pattern as the Alerting 'deleteMonitor'). +-- The exact shape is version-dependent and live-verified on OS 2.19.5 +-- and 3.7.0 (bead bloodhound-z5j): OS 2.x/3.x return only +-- @_id@ + @_version@. OS 1.3.x does not ship the Security Analytics +-- plugin. See the Haddock on 'DeleteSADetectorResponse' for detail. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteSADetector :: + DetectorId -> + BHRequest StatusDependant DeleteSADetectorResponse +deleteSADetector (DetectorId did) = + delete (mkEndpoint ["_plugins", "_security_analytics", "detectors", did]) + +-- | 'searchSAPrePackagedRules' searches the pre-packaged Sigma rules +-- index (@POST /_plugins/_security_analytics/rules/_search?pre_packaged=true@) +-- via the Security Analytics plugin. Pass 'Nothing' for the plain +-- empty-body @{}@ POST that returns the first page of all +-- pre-packaged rules; pass @'Just' query@ to paginate (@from@\/@size@) +-- or filter by category, tag, level, ... using the standard OpenSearch +-- query DSL carried opaquely in 'saRulesQueryQuery'. +-- +-- Returns the full search envelope 'SARulesSearchResponse' so callers +-- can drive pagination and inspect @_shards@ health; use +-- 'saRulesSearchResponseRules' to project out just the @['SARule']@ +-- list. +-- +-- /Deviation from the bead acceptance/ (bloodhound-04f.6.11.3): the +-- bead names a @GET /_plugins/_security_analytics/rules@ endpoint +-- that does not exist on the server. Rule retrieval is via the +-- search endpoints; this function and 'searchSACustomRules' are +-- shipped instead of the bead's @getSARules :: m [SARule]@, mirroring +-- the bloodhound-04f.6.7.4 'deleteMonitor' precedent (bead +-- acceptance typed as a simpler shape than the real wire). See the +-- changelog entry for bloodhound-04f.6.11.3 for the full rationale. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchSAPrePackagedRules :: + Maybe SARulesQuery -> + BHRequest StatusDependant (ParsedEsResponse SARulesSearchResponse) +searchSAPrePackagedRules = searchSARules True + +-- | 'searchSACustomRules' searches the custom Sigma rules index +-- (@POST /_plugins/_security_analytics/rules/_search?pre_packaged=false@). +-- Otherwise identical in shape and semantics to +-- 'searchSAPrePackagedRules'; see that function's Haddock for the +-- query-body handling and the bead-acceptance deviation note. +-- +-- For more information see +-- . +searchSACustomRules :: + Maybe SARulesQuery -> + BHRequest StatusDependant (ParsedEsResponse SARulesSearchResponse) +searchSACustomRules = searchSARules False + +-- | Shared body of 'searchSAPrePackagedRules' and 'searchSACustomRules': +-- POSTs the (possibly-empty) query body to the rules search endpoint +-- with the @pre_packaged@ query flag set accordingly. +searchSARules :: + Bool -> + Maybe SARulesQuery -> + BHRequest StatusDependant (ParsedEsResponse SARulesSearchResponse) +searchSARules prePackaged mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + baseEndpoint = mkEndpoint ["_plugins", "_security_analytics", "rules", "_search"] + endpoint = + withQueries + baseEndpoint + [ ("pre_packaged", Just (if prePackaged then "true" else "false")) + ] + body = encode (maybe defaultSARulesQuery id mQuery) + +-- | 'createSACustomRule' creates a custom Sigma rule via +-- @POST /_plugins/_security_analytics/rules?category={logtype}@. +-- The request body is the /raw Sigma YAML text/ (NOT JSON-encoded): +-- the Security Analytics plugin parses Sigma YAML directly, even +-- though the request carries an @application/json@ content type. The +-- supplied 'SADetectorType' selects the rule's @category@ query +-- parameter (rendered via 'saDetectorTypeText'); pass the full Sigma +-- rule document as 'Text'. +-- +-- Returns 'SARuleResponse' (@{_id, _version, rule}@), where the inner +-- 'SARule' carries the server-normalised typed fields plus the +-- original YAML serialised in 'saRuleRule'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid Sigma, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +createSACustomRule :: + SADetectorType -> + Text -> + BHRequest StatusDependant SARuleResponse +createSACustomRule category sigmaYaml = + post endpoint (BL.fromStrict (TE.encodeUtf8 sigmaYaml)) + where + endpoint = + withQueries + (mkEndpoint ["_plugins", "_security_analytics", "rules"]) + [("category", Just (saDetectorTypeText category))] + +-- | 'updateSACustomRule' replaces a custom Sigma rule via +-- @PUT /_plugins/_security_analytics/rules/{id}?category={logtype}[&forced=true]@. +-- Like 'createSACustomRule' the body is the raw Sigma YAML text (not +-- JSON). The @forced@ flag, when 'True', forces the update even when +-- the rule is actively referenced by detectors (the server returns a +-- @500@ otherwise); when 'False' the @forced@ query parameter is +-- omitted. Returns the updated 'SARuleResponse'. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing rule id (or a +-- 4xx\/5xx for an invalid body or an un-forced update of a referenced +-- rule) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateSACustomRule :: + RuleId -> + SADetectorType -> + Bool -> + Text -> + BHRequest StatusDependant SARuleResponse +updateSACustomRule (RuleId rid) category forced sigmaYaml = + put endpoint (BL.fromStrict (TE.encodeUtf8 sigmaYaml)) + where + baseEndpoint = mkEndpoint ["_plugins", "_security_analytics", "rules", rid] + endpoint = + withQueries baseEndpoint $ + ("category", Just (saDetectorTypeText category)) + : [("forced", Just "true") | forced] + +-- | 'deleteSACustomRule' deletes a custom Sigma rule via +-- @DELETE /_plugins/_security_analytics/rules/{id}[?forced=true]@. +-- The @forced@ flag, when 'True', forces the delete even when the rule +-- is actively referenced by detectors; when 'False' the @forced@ query +-- parameter is omitted. There is no request body. +-- +-- Returns the bare Elasticsearch delete-document response +-- ('DeleteSARuleResponse', wire shape +-- @{_index,_id,_version,result,forced_refresh,_shards,_seq_no,_primary_term}@) +-- — NOT an 'Acknowledged' ack, which would raise 'EsProtocolException' +-- at runtime. Same deviation pattern as 'deleteSADetector'. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing rule id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteSACustomRule :: + RuleId -> + Bool -> + BHRequest StatusDependant DeleteSARuleResponse +deleteSACustomRule (RuleId rid) forced = + delete endpoint + where + endpoint = + withQueries + (mkEndpoint ["_plugins", "_security_analytics", "rules", rid]) + [("forced", Just "true") | forced] + +-- | 'searchSADetectors' searches the detector store via +-- @POST /_plugins/_security_analytics/detectors/_search@. Pass +-- 'Nothing' for the plain empty-body @{}@ POST that returns the first +-- page of all detectors; pass @'Just' query@ to paginate +-- (@from@\/@size@) or filter by name, type, enabled state, ... using +-- the standard OpenSearch query DSL carried opaquely in +-- 'saDetectorsSearchQueryQuery'. Mirrors 'searchSAPrePackagedRules' +-- (without the @pre_packaged@ query flag, which is rule-specific). +-- +-- Returns the full search envelope 'SADetectorsSearchResponse' so +-- callers can drive pagination and inspect @_shards@ health; use +-- 'saDetectorsSearchResponseDetectors' to project out just the +-- @['SADetector']@ list. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchSADetectors :: + Maybe SADetectorsSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SADetectorsSearchResponse) +searchSADetectors mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_security_analytics", "detectors", "_search"] + body = encode (maybe defaultSADetectorsSearchQuery id mQuery) + +-- | 'getSAMappingsView' returns a view of the fields contained in an +-- index used as a log source, via +-- @GET /_plugins/_security_analytics/mappings/view@. The +-- 'SAMappingsViewRequest' body names the index and the log type (rule +-- topic); the server requires these as a request body even though the +-- method is GET, so this uses a body-bearing GET. The +-- 'SAMappingsViewResponse' carries the proposed @properties@ map and +-- the list of @unmapped_index_fields@. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, missing index) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getSAMappingsView :: + SAMappingsViewRequest -> + BHRequest StatusDependant SAMappingsViewResponse +getSAMappingsView req = + getWithBody @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_security_analytics", "mappings", "view"] + +-- | 'createSAMappings' creates the field-to-alias mappings for an +-- index via @POST /_plugins/_security_analytics/mappings@. The +-- 'SACreateMappingsRequest' body names the index, the log type (rule +-- topic), an optional @partial@ flag, and the @alias_mappings@ +-- ('SAMappingsBody') to persist. The server acknowledges with the +-- standard @{"acknowledged": true}@ envelope ('Acknowledged'). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, invalid body) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createSAMappings :: + SACreateMappingsRequest -> + BHRequest StatusDependant Acknowledged +createSAMappings req = + post (mkEndpoint ["_plugins", "_security_analytics", "mappings"]) (encode req) + +-- | 'getSAMappings' fetches the persisted mappings for a single index +-- via @GET /_plugins/_security_analytics/mappings?index_name={name}@. +-- The response is keyed by index name +-- ('SAGetMappingsResponse'); each value is an 'SAMappingsIndexBody' +-- carrying the @mappings.properties@ map. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, unknown index) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getSAMappings :: + Text -> + BHRequest StatusDependant SAGetMappingsResponse +getSAMappings indexName = + get @StatusDependant endpoint + where + endpoint = + withQueries + (mkEndpoint ["_plugins", "_security_analytics", "mappings"]) + [("index_name", Just indexName)] + +-- | 'updateSAMappings' updates a single field-to-alias mapping for an +-- index via @PUT /_plugins/_security_analytics/mappings@. The +-- 'SAUpdateMappingsRequest' body names the index, the source @field@, +-- and the @alias@ to assign. The server acknowledges with the +-- standard @{"acknowledged": true}@ envelope ('Acknowledged'). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, unknown index\/field) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +updateSAMappings :: + SAUpdateMappingsRequest -> + BHRequest StatusDependant Acknowledged +updateSAMappings req = + put (mkEndpoint ["_plugins", "_security_analytics", "mappings"]) (encode req) + +-- ========================================================================= +-- Security Analytics plugin: alerts, findings, correlations, log types +-- ========================================================================= + +-- | 'getSAAlertsWith' lists Security Analytics alert documents via +-- @GET /_plugins/_security_analytics/alerts@, forwarding the supplied +-- 'SAGetAlertsOptions' as query-string parameters (filtering by +-- @detector_id@ \/ @detectorType@ — one of which the server requires — +-- plus @alertState@ \/ @severityLevel@, pagination via @size@ \/ +-- @startIndex@, sort via @sortString@ \/ @sortOrder@ \/ @missing@, +-- free-text @searchString@). Pass 'defaultSAGetAlertsOptions' (with one +-- of the two detector filters set via record update) for the plain +-- GET. Returns the full 'SAGetAlertsResponse' envelope so callers can +-- read @total_alerts@ (which differs from the page size when @size@ +-- truncates the result). Mirrors the Alerting 'getAlertsWith' precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, missing required @detector_id@\/@detectorType@) decodes as an +-- 'EsError' rather than throwing. +-- +-- For more information see +-- . +getSAAlertsWith :: + SAGetAlertsOptions -> + BHRequest StatusDependant SAGetAlertsResponse +getSAAlertsWith opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_security_analytics", "alerts"] + `withQueries` saGetAlertsOptionsParams opts + +-- | 'getSAAlerts' lists the alert documents of a single detector. +-- Equivalent to 'getSAAlertsWith' with 'defaultSAGetAlertsOptions' (the +-- @detector_id@ is set from the argument) and projects out the bare +-- @['SAAlert']@ list (the paging envelope is discarded). Callers +-- needing @total_alerts@ or custom filtering should use +-- 'getSAAlertsWith'. Mirrors the Alerting 'getAlerts' precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx decodes as an 'EsError'. +-- +-- For more information see +-- . +getSAAlerts :: + DetectorId -> + BHRequest StatusDependant [SAAlert] +getSAAlerts did = + saGetAlertsResponseAlerts + <$> getSAAlertsWith + defaultSAGetAlertsOptions + { saGetAlertsOptionsDetectorId = Just (unDetectorId did) + } + +-- | 'acknowledgeSADetectorAlerts' acknowledges one or more active alerts +-- of a Security Analytics detector via +-- @POST /_plugins/_security_analytics/detectors/{detector_id}/_acknowledge/alerts@. +-- The request body is the encoded 'AcknowledgeSADetectorAlertsRequest' +-- (@{"alerts":[ids]}@). Alerts already in a terminal state are not +-- transitioned and are echoed in the @failed@ array of the +-- 'AcknowledgeSADetectorAlertsResponse'. Mirrors the Alerting +-- 'acknowledgeAlert' precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid detector id, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +acknowledgeSADetectorAlerts :: + DetectorId -> + [Text] -> + BHRequest StatusDependant AcknowledgeSADetectorAlertsResponse +acknowledgeSADetectorAlerts (DetectorId did) alertIds = + post + (mkEndpoint ["_plugins", "_security_analytics", "detectors", did, "_acknowledge", "alerts"]) + (encode (AcknowledgeSADetectorAlertsRequest alertIds)) + +-- | 'searchSAFindings' lists Security Analytics finding documents via +-- @GET /_plugins/_security_analytics/findings/_search@, forwarding the +-- supplied 'SASearchFindingsOptions' as query-string parameters +-- (filtering by @detector_id@ \/ @detectorType@ \/ @severity@ \/ +-- @detectionType@, pagination via @size@ \/ @startIndex@, sort via +-- @sortOrder@). Pass 'defaultSASearchFindingsOptions' for the plain +-- no-arg GET that returns the first page of all findings. +-- +-- Note: the @GET \/findings\/_search@ endpoint is the only documented +-- findings-retrieval surface; per-id GET is not documented. The +-- response envelope is plugin-specific (@{total_findings, findings}@) +-- and is NOT the standard OpenSearch search envelope; the decoded +-- 'SASearchFindingsResponse' reflects this. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +searchSAFindings :: + SASearchFindingsOptions -> + BHRequest StatusDependant (ParsedEsResponse SASearchFindingsResponse) +searchSAFindings opts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_security_analytics", "findings", "_search"] + `withQueries` saSearchFindingsOptionsParams opts + +-- | 'createSACorrelationRule' creates a Security Analytics correlation +-- rule via @POST /_plugins/_security_analytics/correlation/rules@. The +-- request body carries the list of index\/query\/category triples +-- ('SACorrelateEntry') that define the correlation; the server assigns +-- an @_id@ and @_version@ and echoes the persisted 'SACorrelationRule' +-- in 'createSACorrelationRuleResponseRule'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createSACorrelationRule :: + CreateSACorrelationRuleRequest -> + BHRequest StatusDependant CreateSACorrelationRuleResponse +createSACorrelationRule req = + post (mkEndpoint ["_plugins", "_security_analytics", "correlation", "rules"]) (encode req) + +-- | 'getSACorrelations' lists pairwise finding correlations within a +-- time window via @GET /_plugins/_security_analytics/correlations@. The +-- two required query parameters @start_timestamp@ and @end_timestamp@ +-- (epoch-millis integers) are carried in 'GetSACorrelationsOptions'; +-- the caller MUST set both via record update on +-- 'defaultGetSACorrelationsOptions'. Returns the +-- 'GetSACorrelationsResponse' envelope (@{findings: [...]}@ of +-- 'SACorrelationFinding' pairwise entries). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, missing required timestamps) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +getSACorrelations :: + GetSACorrelationsOptions -> + BHRequest StatusDependant GetSACorrelationsResponse +getSACorrelations opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_security_analytics", "correlations"] + `withQueries` getSACorrelationsOptionsParams opts + +-- | 'findSACorrelation' lists correlated findings for a given finding +-- via @GET /_plugins/_security_analytics/findings/correlate@. The two +-- required query parameters @finding@ (a finding id) and +-- @detector_type@ (a log type) are carried in 'FindSACorrelationOptions'; +-- the caller MUST set both via record update on +-- 'defaultFindSACorrelationOptions'. The optional @nearby_findings@ +-- (int) and @time_window@ (e.g. @"10m"@) tune the correlation window. +-- Returns the 'FindSACorrelationResponse' envelope (@{findings: [...]}@ +-- of 'SACorrelationScore' entries ranked by proximity score). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, missing required parameters) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +findSACorrelation :: + FindSACorrelationOptions -> + BHRequest StatusDependant FindSACorrelationResponse +findSACorrelation opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_security_analytics", "findings", "correlate"] + `withQueries` findSACorrelationOptionsParams opts + +-- | 'searchSACorrelationAlerts' lists Security Analytics correlation +-- alerts via @GET /_plugins/_security_analytics/correlationAlerts@. +-- The optional @correlation_rule_id@ query parameter filters the result +-- to alerts produced by a specific correlation rule. Pass +-- 'defaultSearchSACorrelationAlertsOptions' for the plain no-arg GET +-- that returns all correlation alerts. Returns the +-- 'SearchSACorrelationAlertsResponse' envelope (@{correlationAlerts, +-- total_alerts}@). +-- +-- /Documentation gotcha/ (pinned in the Haddock on +-- 'SearchSACorrelationAlertsOptions'): the endpoint is declared as +-- @GET \/correlationAlerts@, but the docs' example request uses +-- @GET \/correlations?correlation_rule_id=...@. This function ships +-- the declared path. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +searchSACorrelationAlerts :: + SearchSACorrelationAlertsOptions -> + BHRequest StatusDependant SearchSACorrelationAlertsResponse +searchSACorrelationAlerts opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_security_analytics", "correlationAlerts"] + `withQueries` searchSACorrelationAlertsOptionsParams opts + +-- | 'acknowledgeSACorrelationAlerts' acknowledges one or more +-- correlation alerts via +-- @POST /_plugins/_security_analytics/_acknowledge/correlationAlerts@. +-- The request body is the encoded +-- 'AcknowledgeSACorrelationAlertsRequest' (@{"alertIds":[ids]}@ — note +-- the camelCase key, contrast with 'acknowledgeSADetectorAlerts' which +-- uses snake_case @alerts@). The unusual path (@\/_acknowledge\/...@, +-- with @_acknowledge@ as a sibling of @correlationAlerts@ rather than +-- nested under it) is documented and matches the live server. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid alert ids, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +acknowledgeSACorrelationAlerts :: + [Text] -> + BHRequest StatusDependant AcknowledgeSACorrelationAlertsResponse +acknowledgeSACorrelationAlerts alertIds = + post + (mkEndpoint ["_plugins", "_security_analytics", "_acknowledge", "correlationAlerts"]) + (encode (AcknowledgeSACorrelationAlertsRequest alertIds)) + +-- | 'createSALogType' creates a custom Security Analytics log type via +-- @POST /_plugins/_security_analytics/logtype@. The request body is the +-- encoded 'SALogType' (carrying @name@, @description@, @source@, and +-- optional @tags@); the server assigns an @_id@ and @_version@ and +-- echoes the persisted log type in the @logType@ wrapper of +-- 'SALogTypeResponse'. Built-in log types (@source: "Sigma"@) cannot +-- be created via this endpoint; pass @source = 'SALogTypeSourceCustom'@ +-- (or omit the field, which the server defaults to @"Custom"@). +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createSALogType :: + SALogType -> + BHRequest StatusDependant SALogTypeResponse +createSALogType logType = + post (mkEndpoint ["_plugins", "_security_analytics", "logtype"]) (encode logType) + +-- | 'searchSALogTypes' searches the Security Analytics log type store +-- via @POST /_plugins/_security_analytics/logtype/_search@. Pass +-- 'Nothing' for the plain @{"query": {"match_all": {}}}@ POST that +-- returns the first page of all log types (built-in and custom); pass +-- @'Just' query@ to filter by name, source, tags, ... using the +-- standard OpenSearch query DSL carried opaquely in +-- 'saLogTypeSearchQueryQuery'. Returns the full search envelope +-- 'SALogTypesSearchResponse' so callers can drive pagination and +-- inspect @_shards@ health; use 'saLogTypesSearchResponseLogTypes' to +-- project out just the @['SALogType']@ list. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchSALogTypes :: + Maybe SALogTypeSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SALogTypesSearchResponse) +searchSALogTypes mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_security_analytics", "logtype", "_search"] + body = encode (maybe defaultSALogTypeSearchQuery id mQuery) + +-- | 'updateSALogType' replaces a custom Security Analytics log type via +-- @PUT /_plugins/_security_analytics/logtype/{log_type_id}@. The +-- request body is the encoded 'SALogType'; the response is the same +-- 'SALogTypeResponse' wrapper as 'createSALogType' (with the +-- incremented @_version@). Built-in log types cannot be updated. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing log type id (or +-- a 4xx for an invalid body, or an attempt to update a built-in log +-- type) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateSALogType :: + Text -> + SALogType -> + BHRequest StatusDependant SALogTypeResponse +updateSALogType logTypeId logType = + put (mkEndpoint ["_plugins", "_security_analytics", "logtype", logTypeId]) (encode logType) + +-- | 'deleteSALogType' deletes a custom Security Analytics log type via +-- @DELETE /_plugins/_security_analytics/logtype/{log_type_id}@. +-- Built-in log types cannot be deleted — the server rejects the +-- request; the resulting 'EsError' surfaces via 'StatusDependant'. +-- Returns 'DeleteSALogTypeResponse' carrying just @_id@ and @_version@. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing log type id (or +-- a 4xx for a built-in log type id) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +deleteSALogType :: + Text -> + BHRequest StatusDependant DeleteSALogTypeResponse +deleteSALogType logTypeId = + delete (mkEndpoint ["_plugins", "_security_analytics", "logtype", logTypeId]) + +-- | 'getDestinations' lists every configured alerting destination via +-- @GET /_plugins/_alerting/destinations@. The endpoint returns a +-- paging envelope (@{totalDestinations, destinations}@); this wrapper +-- projects out the bare 'Destination' list so the public type matches +-- the bead acceptance (@m [Destination]@). Equivalent to +-- 'getDestinationsWith' with 'defaultDestinationListOptions' (server +-- defaults: @size=20@, @start_index=0@, +-- @sortString=destination.name.keyword@, @sortOrder=asc@). Callers +-- needing paging metadata (@totalDestinations@) or custom filtering +-- should use 'getDestinationsWith'. +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (plugin not installed, +-- RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getDestinations :: + BHRequest StatusDependant [Destination] +getDestinations = + getDestinationsResponseDestinations + <$> getDestinationsWith defaultDestinationListOptions + +-- | 'getDestinationsWith' is the parameterized variant of +-- 'getDestinations': the supplied 'DestinationListOptions' are +-- forwarded as query-string parameters (filtering by +-- 'DestinationListOptions''s @destinationType@, pagination via +-- @size@ \/ @start_index@, sort via @sortString@ \/ @sortOrder@ \/ +-- @missing@, and free-text @searchString@). Pass +-- 'defaultDestinationListOptions' for the plain no-arg GET. Returns +-- the full 'GetDestinationsResponse' envelope so callers can read +-- @totalDestinations@ (the total hit count, which differs from the +-- page size when @size@ truncates the result). +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (plugin not installed, +-- RBAC denial, or the documented HTTP 405 when multi-tenancy is +-- enabled) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getDestinationsWith :: + DestinationListOptions -> + BHRequest StatusDependant GetDestinationsResponse +getDestinationsWith opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_alerting", "destinations"] + `withQueries` destinationListOptionsParams opts + +-- | The Alerting server assigns @id@, @schema_version@, @seq_no@, and +-- @primary_term@ when a destination is first written, so the documented +-- 'createDestination' request body omits them (a caller-supplied @id@ +-- is ignored; @seq_no@\/@primary_term@ are meaningless on a create). +-- This drops those keys from the encoded 'Destination' so the create +-- body matches the documented shape. It is local to the create path: +-- 'updateDestination' and the 'Destination' round-trip keep the full +-- document (server-assigned fields and all). +stripDestinationCreateKeys :: Value -> Value +stripDestinationCreateKeys (Object o) = + Object (deleteSeveral ["id", "schema_version", "seq_no", "primary_term"] o) +stripDestinationCreateKeys v = v + +-- | 'createDestination' creates an alerting destination via the +-- Alerting plugin (@POST /_plugins/_alerting/destinations@). The body +-- is the encoded 'Destination' with the server-assigned @id@, +-- @schema_version@, @seq_no@, and @primary_term@ stripped +-- ('stripDestinationCreateKeys') so it matches the documented +-- create-request shape; the response is the 'DestinationResponse' +-- wrapper carrying the server-assigned indexing metadata and the +-- persisted destination document. +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (invalid destination +-- body, plugin not installed, RBAC denial) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +createDestination :: + Destination -> + BHRequest StatusDependant DestinationResponse +createDestination destination = + post (mkEndpoint ["_plugins", "_alerting", "destinations"]) body + where + body = encode (stripDestinationCreateKeys (toJSON destination)) + +-- | 'updateDestination' replaces a destination via +-- @PUT /_plugins/_alerting/destinations/{destination_id}@. The body is +-- the encoded 'Destination'; the response is the same +-- 'DestinationResponse' wrapper as 'createDestination' (with the +-- incremented @_version@ and @_seq_no@). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing destination id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateDestination :: + DestinationId -> + Destination -> + BHRequest StatusDependant DestinationResponse +updateDestination (DestinationId did) destination = + put (mkEndpoint ["_plugins", "_alerting", "destinations", did]) (encode destination) + +-- | 'deleteDestination' deletes a destination by id via +-- @DELETE /_plugins/_alerting/destinations/{destination_id}@. +-- +-- The return type 'DeleteDestinationResponse' deviates from a naive +-- @m 'Acknowledged'@ acceptance for the same reason as 'deleteMonitor': +-- the OpenSearch alerting delete endpoint returns the standard +-- Elasticsearch delete-document response (bare, with a @_shards@ +-- report, NO @acknowledged@ key), so an 'Acknowledged' decoder would +-- raise 'EsProtocolException' at runtime. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing destination id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteDestination :: + DestinationId -> + BHRequest StatusDependant DeleteDestinationResponse +deleteDestination (DestinationId did) = + delete (mkEndpoint ["_plugins", "_alerting", "destinations", did]) + +-- ========================================================================= +-- Alerting plugin: alerts, acknowledge, stats, email accounts/groups +-- ========================================================================= + +-- | 'getAlertsWith' lists alert documents via +-- @GET /_plugins/_alerting/monitors/alerts@, forwarding the supplied +-- 'GetAlertsOptions' as query-string parameters (filtering by +-- @alertState@ \/ @severityLevel@ \/ @monitorId@, pagination via +-- @size@ \/ @startIndex@, sort via @sortString@ \/ @sortOrder@ \/ +-- @missing@, free-text @searchString@, and @workflowIds@ for chained +-- alerts on OpenSearch 2.9+). Pass 'defaultGetAlertsOptions' for the +-- plain no-arg GET. Returns the full 'GetAlertsResponse' envelope so +-- callers can read @totalAlerts@ (the total hit count, which differs +-- from the page size when @size@ truncates the result). Mirrors the +-- 'getDestinationsWith' precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getAlertsWith :: + GetAlertsOptions -> + BHRequest StatusDependant GetAlertsResponse +getAlertsWith opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_alerting", "monitors", "alerts"] + `withQueries` getAlertsOptionsParams opts + +-- | 'getAlerts' lists every active alert. Equivalent to 'getAlertsWith' +-- with 'defaultGetAlertsOptions' (server defaults apply) and projects +-- out the bare @['Alert']@ list (the paging envelope is discarded). +-- Callers needing @totalAlerts@ or custom filtering should use +-- 'getAlertsWith'. Mirrors the 'getDestinations' precedent. +getAlerts :: + BHRequest StatusDependant [Alert] +getAlerts = + getAlertsResponseAlerts <$> getAlertsWith defaultGetAlertsOptions + +-- | 'acknowledgeAlert' acknowledges one or more active alerts of a +-- monitor via +-- @POST /_plugins/_alerting/monitors/{monitor_id}/_acknowledge/alerts@. +-- Alerts already in an @ERROR@, @COMPLETED@, or @ACKNOWLEDGED@ state are +-- not transitioned and are echoed in the @failed@ array of the +-- 'AcknowledgeAlertResponse'. The request body is the encoded +-- 'AcknowledgeAlertRequest' (@{"alerts":[ids]}@). +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid monitor id, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +acknowledgeAlert :: + MonitorId -> + [Text] -> + BHRequest StatusDependant AcknowledgeAlertResponse +acknowledgeAlert (MonitorId mid) alertIds = + post + (mkEndpoint ["_plugins", "_alerting", "monitors", mid, "_acknowledge", "alerts"]) + (encode (AcknowledgeAlertRequest alertIds)) + +-- | 'getMonitorStats' fetches alerting scheduler statistics via +-- @GET /_plugins/_alerting/stats[/...]@. The four documented forms are +-- selected by the two optional arguments: +-- +-- * @Nothing Nothing@ — @GET /_plugins/_alerting/stats@ (cluster-wide) +-- * @'Nothing' metric@ — @GET /_plugins/_alerting/stats/{metric}@ +-- * @nodeId 'Nothing'@ — @GET /_plugins/_alerting/{node-id}/stats@ +-- * @nodeId metric@ — @GET /_plugins/_alerting/{node-id}/stats/{metric}@ +-- +-- The response is large and partly node-specific; the stable shell is +-- decoded into 'MonitorStats' and the variable @nodes@ map is kept as +-- an opaque aeson 'Value' (see 'monitorStatsOther'). Mirrors the +-- 'getSQLStats' pragmatic-typing precedent. +-- +-- Surfaced as 'StatusDependant' so a 404 (Alerting plugin disabled +-- \/ unknown metric \/ unknown node id) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +getMonitorStats :: + Maybe Text -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse MonitorStats) +getMonitorStats mNodeId mMetric = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = case mNodeId of + Nothing -> + case mMetric of + Nothing -> mkEndpoint ["_plugins", "_alerting", "stats"] + Just metric -> mkEndpoint ["_plugins", "_alerting", "stats", metric] + Just nodeId -> + case mMetric of + Nothing -> mkEndpoint ["_plugins", "_alerting", nodeId, "stats"] + Just metric -> mkEndpoint ["_plugins", "_alerting", nodeId, "stats", metric] + +-- | 'createEmailAccount' creates a legacy alerting email account via +-- @POST /_plugins/_alerting/destinations/email_accounts@. The body is +-- the encoded 'EmailAccount' (the server assigns @_id@, @_version@, +-- @_seq_no@, @_primary_term@, and @schema_version@ on write); the +-- response is the 'EmailAccountResponse' wrapper. Mirrors +-- 'createDestination'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createEmailAccount :: + EmailAccount -> + BHRequest StatusDependant EmailAccountResponse +createEmailAccount account = + post (mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts"]) (encode account) + +-- | 'getEmailAccount' fetches a single email account by id via +-- @GET /_plugins/_alerting/destinations/email_accounts/{id}@. The +-- endpoint returns the 'EmailAccountResponse' wrapper on the wire +-- (@{_id,_version,_seq_no,_primary_term, email_account:{...}}@); the +-- wrapper is decoded and the 'EmailAccount' is projected out so the +-- public type matches the 'getMonitor' precedent. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing id decodes as +-- an 'EsError' rather than throwing. +getEmailAccount :: + EmailAccountId -> + BHRequest StatusDependant EmailAccount +getEmailAccount (EmailAccountId eid) = + emailAccountResponseEmailAccount <$> get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts", eid] + +-- | 'updateEmailAccount' replaces an email account via +-- @PUT /_plugins/_alerting/destinations/email_accounts/{id}@. +-- Equivalent to 'updateEmailAccountWith' with 'Nothing' (no +-- optimistic-concurrency guard). Mirrors 'updateDestination'. +updateEmailAccount :: + EmailAccountId -> + EmailAccount -> + BHRequest StatusDependant EmailAccountResponse +updateEmailAccount emailAccountId account = + updateEmailAccountWith emailAccountId account Nothing + +-- | 'updateEmailAccountWith' replaces an email account with an optional +-- optimistic-concurrency guard (@if_seq_no@ \/ @if_primary_term@). See +-- 'updateMonitorWith' for the guard semantics. Mirrors the +-- 'updateMonitorWith' precedent. +-- +-- Surfaced as 'StatusDependant' so a 404 (or a 409 on a sequence-number +-- mismatch) decodes as an 'EsError' rather than throwing. +updateEmailAccountWith :: + EmailAccountId -> + EmailAccount -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant EmailAccountResponse +updateEmailAccountWith (EmailAccountId eid) account mOcc = + put @StatusDependant endpoint (encode account) + where + baseEndpoint = + mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts", eid] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries + baseEndpoint + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'deleteEmailAccount' deletes an email account by id via +-- @DELETE /_plugins/_alerting/destinations/email_accounts/{id}@. Returns +-- the bare Elasticsearch delete-document response (see +-- 'DeleteEmailAccountResponse' for why this deviates from +-- @m 'Acknowledged'@). Mirrors 'deleteDestination'. +deleteEmailAccount :: + EmailAccountId -> + BHRequest StatusDependant DeleteEmailAccountResponse +deleteEmailAccount (EmailAccountId eid) = + delete (mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts", eid]) + +-- | 'createEmailGroup' creates a legacy alerting email group via +-- @POST /_plugins/_alerting/destinations/email_groups@. Mirrors +-- 'createEmailAccount'. +createEmailGroup :: + EmailGroup -> + BHRequest StatusDependant EmailGroupResponse +createEmailGroup group = + post (mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups"]) (encode group) + +-- | 'getEmailGroup' fetches a single email group by id via +-- @GET /_plugins/_alerting/destinations/email_groups/{id}@, projecting +-- out the 'EmailGroup'. Mirrors 'getEmailAccount'. +getEmailGroup :: + EmailGroupId -> + BHRequest StatusDependant EmailGroup +getEmailGroup (EmailGroupId gid) = + emailGroupResponseEmailGroup <$> get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups", gid] + +-- | 'updateEmailGroup' replaces an email group. Equivalent to +-- 'updateEmailGroupWith' with 'Nothing'. Mirrors 'updateEmailAccount'. +updateEmailGroup :: + EmailGroupId -> + EmailGroup -> + BHRequest StatusDependant EmailGroupResponse +updateEmailGroup emailGroupId group = + updateEmailGroupWith emailGroupId group Nothing + +-- | 'updateEmailGroupWith' replaces an email group with an optional +-- optimistic-concurrency guard. Mirrors 'updateEmailAccountWith'. +updateEmailGroupWith :: + EmailGroupId -> + EmailGroup -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant EmailGroupResponse +updateEmailGroupWith (EmailGroupId gid) group mOcc = + put @StatusDependant endpoint (encode group) + where + baseEndpoint = + mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups", gid] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries + baseEndpoint + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'deleteEmailGroup' deletes an email group by id via +-- @DELETE /_plugins/_alerting/destinations/email_groups/{id}@. Mirrors +-- 'deleteEmailAccount'. +deleteEmailGroup :: + EmailGroupId -> + BHRequest StatusDependant DeleteEmailGroupResponse +deleteEmailGroup (EmailGroupId gid) = + delete (mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups", gid]) + +-- | 'getDestination' fetches a single destination by id via +-- @GET /_plugins/_alerting/destinations/{id}@. The endpoint returns the +-- same envelope as 'getDestinationsWith' +-- (@{totalDestinations, destinations}@), so the response is decoded as +-- 'GetDestinationsResponse'. When the id exists the @destinations@ +-- list contains exactly one element. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing destination id +-- decodes as an 'EsError' rather than throwing. +-- +-- The list-envelope response shape is live-verified on OS 1.3.19, +-- 2.19.5 and 3.7.0 (bead bloodhound-z5j): the single-id GET returns +-- @{totalDestinations: 1, destinations: []}@, not a +-- bare single object. +-- +-- For more information see +-- . +getDestination :: + DestinationId -> + BHRequest StatusDependant GetDestinationsResponse +getDestination (DestinationId did) = + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", did] + +-- | 'searchEmailAccounts' searches the email account store via +-- @POST /_plugins/_alerting/destinations/email_accounts/_search@. Pass +-- 'Nothing' for the plain empty-body @{}@ POST that returns the first +-- page of all email accounts; pass @'Just' query@ to paginate +-- (@from@\/@size@), sort, or filter using the standard OpenSearch query +-- DSL carried opaquely in 'emailAccountSearchQueryQuery'. +-- +-- Returns the full search envelope 'SearchEmailAccountsResponse' so +-- callers can drive pagination and inspect @_shards@ health. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchEmailAccounts :: + Maybe EmailAccountSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SearchEmailAccountsResponse) +searchEmailAccounts mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts", "_search"] + body = encode (maybe defaultEmailAccountSearchQuery id mQuery) + +-- | 'searchEmailGroups' searches the email group store via +-- @POST /_plugins/_alerting/destinations/email_groups/_search@. Mirrors +-- 'searchEmailAccounts'. +-- +-- For more information see +-- . +searchEmailGroups :: + Maybe EmailGroupSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SearchEmailGroupsResponse) +searchEmailGroups mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups", "_search"] + body = encode (maybe defaultEmailGroupSearchQuery id mQuery) + +-- | 'searchFindings' searches the document-level monitor findings index +-- via @GET /_plugins/_alerting/findings/_search@. Unlike the other +-- alerting search endpoints, this is a GET with query-string parameters +-- only (no body). Pass 'Nothing' for the plain no-arg GET that returns +-- all findings; pass @'Just' opts@ to filter by @findingId@, sort via +-- @sortString@ \/ @sortOrder@, paginate via @size@ \/ @startIndex@, or +-- filter by @searchString@. +-- +-- Returns 'SearchFindingsResponse' (typed @total_findings@ count + +-- opaque findings payload). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +searchFindings :: + Maybe FindingsSearchOptions -> + BHRequest StatusDependant (ParsedEsResponse SearchFindingsResponse) +searchFindings mOpts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_alerting", "findings", "_search"] + `withQueries` findingsSearchOptionsParams opts + opts = maybe defaultFindingsSearchOptions id mOpts + +-- | 'createComment' adds a comment to a specific alert via +-- @POST /_plugins/_alerting/comments/{alert-id}@. The request body is +-- the encoded 'CreateCommentRequest' (@{"content":"..."}@); the response +-- is the 'CommentResponse' wrapper carrying the server-assigned @_id@, +-- @_seq_no@, @_primary_term@, and the persisted 'Comment'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid alert id, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createComment :: + Text -> + CreateCommentRequest -> + BHRequest StatusDependant CommentResponse +createComment alertId req = + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_alerting", "comments", alertId] + +-- | 'updateComment' modifies a previously created comment via +-- @PUT /_plugins/_alerting/comments/{comment-id}@. The request body is +-- the encoded 'UpdateCommentRequest' (@{"content":"..."}@); the response +-- is the same 'CommentResponse' wrapper (with incremented @_seq_no@ and +-- updated @last_updated_time@). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing comment id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateComment :: + CommentId -> + UpdateCommentRequest -> + BHRequest StatusDependant CommentResponse +updateComment (CommentId cid) req = + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_alerting", "comments", cid] + +-- | 'searchComments' queries and retrieves existing comments via +-- @GET /_plugins/_alerting/comments/_search@ (a GET-with-body endpoint). +-- Pass 'Nothing' for the plain empty-body @{}@ request that returns all +-- comments; pass @'Just' query@ to filter using the standard OpenSearch +-- query DSL. +-- +-- Returns the full search envelope 'SearchCommentsResponse'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchComments :: + Maybe CommentSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SearchCommentsResponse) +searchComments mQuery = + withBHResponseParsedEsResponse $ + getWithBody @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_alerting", "comments", "_search"] + body = encode (maybe defaultCommentSearchQuery id mQuery) + +-- | 'deleteComment' removes a specific comment via +-- @DELETE /_plugins/_alerting/comments/{comment-id}@. Returns the +-- minimal 'DeleteCommentResponse' (@{"_id":"..."}@). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing comment id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteComment :: + CommentId -> + BHRequest StatusDependant DeleteCommentResponse +deleteComment (CommentId cid) = + delete (mkEndpoint ["_plugins", "_alerting", "comments", cid]) + +-- ========================================================================= +-- Anomaly Detection plugin +-- ========================================================================= + +-- | 'createDetector' calls the Anomaly Detection plugin Create Detector API +-- (@POST /_plugins/_anomaly_detection/detectors@). Persists a new +-- detector (single-entity or, when @category_field@ is set, +-- high-cardinality multi-entity) to the +-- @.opendistro-anomaly-detection-state@ system index and returns the +-- standard document-write envelope (@_id@, @_version@, @_primary_term@, +-- @_seq_no@) wrapping the persisted detector under @anomaly_detector@. +-- +-- The target index must already contain at least one document, otherwise +-- the plugin rejects the request with HTTP 400 (@Can't create anomaly +-- detector as no document is found in the indices: [...]@). Surfaced as +-- 'StatusDependant' so that 400 (and a 404 for the plugin-not-installed +-- case) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createDetector :: + Detector -> + BHRequest StatusDependant (ParsedEsResponse CreateDetectorResponse) +createDetector detector = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode detector) + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors"] + +-- | 'getDetector' calls the Anomaly Detection plugin Get Detector API +-- (@GET /_plugins/_anomaly_detection/detectors/{detector_id}@). Returns +-- the full detector record — the same shape 'createDetector' returns — +-- plus, when the corresponding 'GetDetectorParams' flag is set, the +-- real-time job (@?job=true@) and/or the running task records +-- (@?task=true@) embedded as siblings of @anomaly_detector@. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @detector_id@ or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getDetector :: + DetectorId -> + GetDetectorParams -> + BHRequest StatusDependant (ParsedEsResponse GetDetectorResponse) +getDetector detectorId params = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId] + endpoint = withQueries baseEndpoint (getDetectorParamsPairs params) + +-- | Renders the 'GetDetectorParams' flags as the @?job@ \/ @?task@ query +-- pairs the plugin expects. A 'False' flag contributes no pair, so the +-- default ('defaultGetDetectorParams') produces a bare GET. Uses '(<>)' +-- rather than @concat [..]@ because OS2\/OS3 Requests enable +-- @OverloadedLists@, which would otherwise leave the outer list literal +-- passed to 'concat' (which is @Foldable@-polymorphic) ambiguous. +getDetectorParamsPairs :: GetDetectorParams -> [(Text, Maybe Text)] +getDetectorParamsPairs params = + [("job", Just "true") | getDetectorParamsJob params] + <> [("task", Just "true") | getDetectorParamsTask params] + +-- | 'previewDetector' calls the Anomaly Detection plugin Preview Detector +-- API (@POST /_plugins/_anomaly_detection/detectors/_preview@). Runs the +-- detector's feature aggregations and RCF model over the historical +-- window bounded by 'previewRequestPeriodStart' / +-- 'previewRequestPeriodEnd' (epoch milliseconds) and returns the +-- resulting anomaly grades alongside a snapshot of the detector. No +-- state is persisted. +-- +-- The 'DetectorId' is sent in the request body (@detector_id@) rather +-- than the URL path, matching the documented canonical @_plugins@ form; +-- the path-param form is only documented under the legacy @_opendistro@ +-- prefix. The plugin requires both endpoints of the window; a missing +-- field surfaces as HTTP 400 with @Must set both period start and end +-- date with epoch of milliseconds@. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @detector_id@ or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +previewDetector :: + DetectorId -> + PreviewRequest -> + BHRequest StatusDependant (ParsedEsResponse PreviewResponse) +previewDetector detectorId req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = + mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "_preview"] + body = + encode $ + object + [ "detector_id" .= unDetectorId detectorId, + "period_start" .= previewRequestPeriodStart req, + "period_end" .= previewRequestPeriodEnd req + ] + +-- | 'previewDetectorInline' previews a detector whose identity is carried +-- entirely in the request body rather than as a separate 'DetectorId' +-- argument — the variant 'previewDetector' does not expose. Use it for an +-- unpersisted detector by setting 'previewRequestDetector' to the full +-- inline 'Detector' config, or to preview a persisted detector by +-- reference via 'previewRequestDetectorId'. The endpoint +-- (@POST /_plugins/_anomaly_detection/detectors/_preview@) and the rest +-- of the semantics match 'previewDetector'; no state is persisted. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown +-- 'previewRequestDetectorId' or plugin not installed) decodes as an +-- 'EsError' rather than throwing. +-- +-- For more information see +-- . +previewDetectorInline :: + PreviewRequest -> + BHRequest StatusDependant (ParsedEsResponse PreviewResponse) +previewDetectorInline req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "_preview"] + +-- | 'startDetector' starts an Anomaly Detection detector job via the +-- documented Start Detector Job API +-- (@POST /_plugins/_anomaly_detection/detectors/{detector_id}/_start@). +-- +-- Pass 'Nothing' to start the real-time detector job; pass @'Just' req@ +-- to kick off a one-shot historical backfill over the window bounded by +-- 'startDetectorJobRequestStartTime' / 'startDetectorJobRequestEndTime'. +-- The server returns a 'DetectorJobAcknowledgment' whose @_id@ is the +-- real-time job id (= the detector id) for the no-body form, or the +-- historical batch task id (a UUID) for the body form. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @detector_id@ or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +startDetector :: + DetectorId -> + Maybe StartDetectorJobRequest -> + BHRequest StatusDependant (ParsedEsResponse DetectorJobAcknowledgment) +startDetector detectorId mReq = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (maybe emptyBody encode mReq) + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId, "_start"] + +-- | 'stopDetector' stops an Anomaly Detection detector job via the +-- documented Stop Detector Job API +-- (@POST /_plugins/_anomaly_detection/detectors/{detector_id}/_stop@). +-- +-- Pass 'False' to stop the real-time detector job; pass 'True' to stop +-- the historical analysis, which adds the @?historical=true@ query +-- parameter. The server returns a 'DetectorJobAcknowledgment' with +-- zeroed @_version@ / @_seq_no@ / @_primary_term@ on success. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @detector_id@ or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +stopDetector :: + DetectorId -> + Bool -> + BHRequest StatusDependant (ParsedEsResponse DetectorJobAcknowledgment) +stopDetector detectorId historical = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint emptyBody + where + endpoint = + mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId, "_stop"] + `withQueries` [("historical", Just "true") | historical] + +-- | 'updateDetector' replaces a detector via +-- @PUT /_plugins/_anomaly_detection/detectors/{detector_id}@. The body +-- is the encoded 'Detector' (you cannot update @category_field@, and the +-- server requires both the real-time and historical jobs to be stopped +-- first); the response is the same 'CreateDetectorResponse' envelope as +-- 'createDetector' (with the incremented @_version@ / @_seq_no@). +-- Equivalent to 'updateDetectorWith' with 'Nothing' (no +-- optimistic-concurrency guard), so concurrent updates to the same +-- detector id silently clobber each other. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateDetector :: + DetectorId -> + Detector -> + BHRequest StatusDependant (ParsedEsResponse CreateDetectorResponse) +updateDetector detectorId detector = updateDetectorWith detectorId detector Nothing + +-- | 'updateDetectorWith' replaces a detector via +-- @PUT /_plugins/_anomaly_detection/detectors/{detector_id}@ with an +-- optional optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ +-- — both values read from a prior 'CreateDetectorResponse' — to make the +-- PUT conditional on the detector being unchanged since you last read it; +-- a stale pair causes OpenSearch to respond with HTTP 409 instead of +-- silently overwriting. Pass 'Nothing' for the unconditional semantics of +-- 'updateDetector'. The two values must be supplied together (mirroring +-- the 'updateMonitorWith' / 'putISMPolicyWith' precedent). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id (or a +-- 409 on a sequence-number mismatch) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +updateDetectorWith :: + DetectorId -> + Detector -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant (ParsedEsResponse CreateDetectorResponse) +updateDetectorWith detectorId detector mOcc = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode detector) + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries + baseEndpoint + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'deleteDetector' deletes a detector by id via +-- @DELETE /_plugins/_anomaly_detection/detectors/{detector_id}@. +-- +-- The return type 'DeleteDetectorResponse' deviates from an +-- @m 'Acknowledged'@ acceptance for the same reason as the Alerting +-- 'deleteMonitor' and Security Analytics 'deleteSADetector': the AD +-- delete endpoint returns the bare Elasticsearch delete-document response +-- (@_index@, @_id@, @_version@, @result@, @forced_refresh@, @_shards@, +-- @_seq_no@, @_primary_term@, NO @acknowledged@ key), so an +-- 'Acknowledged' decoder would raise 'EsProtocolException' at runtime. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteDetector :: + DetectorId -> + BHRequest StatusDependant (ParsedEsResponse DeleteDetectorResponse) +deleteDetector detectorId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId] + +-- | 'validateDetector' validates a detector configuration via +-- @POST /_plugins/_anomaly_detection/detectors/_validate[/mode]@. The +-- 'ValidateDetectorMode' argument selects the validation mode: +-- 'ValidateDetector' (the bare @\/_validate@ alias, which finds issues +-- that would block creation) or 'ValidateModel' (the @\/_validate\/model@ +-- advisory check that estimates the likelihood of successful model +-- training). The body is the encoded 'Detector'. The response is an +-- opaque 'ValidateDetectorResponse' (@{}@ on success; a @detector@ / +-- @model@ sub-object carrying the issues otherwise). +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid detector body, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +validateDetector :: + ValidateDetectorMode -> + Detector -> + BHRequest StatusDependant (ParsedEsResponse ValidateDetectorResponse) +validateDetector mode detector = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode detector) + where + endpoint = + mkEndpoint $ + ["_plugins", "_anomaly_detection", "detectors", "_validate"] + <> validateDetectorModeSegments mode + +-- | 'searchDetectors' searches the detector-config index via +-- @POST /_plugins/_anomaly_detection/detectors/_search@. Pass 'Nothing' +-- for the plain empty-body @{}@ POST that returns the first page of all +-- detectors; pass @'Just' query@ to paginate (@from@\/@size@) or filter +-- using the standard OpenSearch query DSL carried opaquely as a 'Value'. +-- +-- Returns the full 'SearchDetectorsResponse' search envelope so callers +-- can drive pagination and inspect @_shards@ health; use +-- 'anomalySearchResponseSources' to project out just the +-- @['DetectorResponse']@ list. Mirrors the Alerting 'searchMonitors' +-- precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchDetectors :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse SearchDetectorsResponse) +searchDetectors mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'profileDetector' profiles a detector via +-- @GET /_plugins/_anomaly_detection/detectors/{detector_id}/_profile[/{types}]@. +-- Pass the profile-kind segments to select (e.g. @["ad_task"]@, +-- @["total_size_in_bytes"]@, or multiple @["ad_task","models"]@ joined +-- comma-separated); pass @[]@ for the bare profile. Pass 'True' to add +-- the @?_all=true@ flag (every profile section — expensive for +-- high-cardinality detectors). +-- +-- For a multi-entity detector (one created with a @category_field@), +-- pass @'Just' entities@ to filter the profile to a specific categorical +-- slice. The plugin documents this as a GET with a request body +-- @{entity: [{name, value}]}@; 'Entity' is reused for both the request +-- filter and the 'AnomalyResult' response. Pass 'Nothing' for a bodyless +-- profile. +-- +-- The response shape varies widely by requested kind and detector kind; +-- it is surfaced as an opaque 'DetectorProfileResponse' so every variant +-- round-trips losslessly (pragmatic-typing precedent). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id (or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +profileDetector :: + DetectorId -> + [Text] -> + Bool -> + Maybe [Entity] -> + BHRequest StatusDependant (ParsedEsResponse DetectorProfileResponse) +profileDetector detectorId types allFlag mEntities = + withBHResponseParsedEsResponse $ + case mEntities of + Nothing -> get @StatusDependant endpoint + Just entities -> getWithBody @StatusDependant endpoint (encode (object ["entity" .= entities])) + where + baseEndpoint = + mkEndpoint $ + ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId, "_profile"] + <> (case types of [] -> []; xs -> [T.intercalate "," xs]) + endpoint = + if allFlag + then withQueries baseEndpoint [("_all", Just "true")] + else baseEndpoint + +-- | 'getDetectorStats' fetches plugin statistics via +-- @GET /_plugins/_anomaly_detection/stats@ (and its filtered forms). +-- The OpenSearch path convention is asymmetric: when filtering by node, +-- the path is @\/{node_id}\/stats@; when filtering by stat only, it is +-- @\/stats\/{stat}@; both filters combine as +-- @\/{node_id}\/stats\/{stat}@. Pass the node id first (or 'Nothing'), +-- then the stat name (or 'Nothing'). +-- +-- The full response carries several top-level index-status keys plus a +-- @nodes@ map; the filtered forms return a subset. It is surfaced as an +-- opaque 'DetectorStatsResponse' so the variable top-level surface +-- round-trips losslessly (pragmatic-typing precedent). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, unknown +-- node id) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getDetectorStats :: + Maybe Text -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse DetectorStatsResponse) +getDetectorStats mNodeId mStat = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection"] + withNode = case mNodeId of + Nothing -> baseEndpoint + Just nodeId -> mkEndpoint (getRawEndpoint baseEndpoint <> [nodeId]) + withStats = mkEndpoint (getRawEndpoint withNode <> ["stats"]) + endpoint = case mStat of + Nothing -> withStats + Just stat -> mkEndpoint (getRawEndpoint withStats <> [stat]) + +-- | 'searchDetectorResults' searches the anomaly-result index via +-- @POST /_plugins/_anomaly_detection/detectors/results/_search[/{custom_result_index}]@. +-- Pass a custom result-index name to search it alongside (or, with +-- @'Just' True@ for @only_query_custom_result_index@, instead of) the +-- default result index. Pass 'Nothing' for the query body to send the +-- plain empty-body @{}@ POST. +-- +-- Each hit's @_source@ is an anomaly-result record; the response is +-- surfaced as a 'SearchDetectorResultsResponse' with opaque 'Value' +-- sources (the full result schema carries many optional fields and lives +-- in a separate mapping page). +-- +-- Surfaced as 'StatusDependant' so a 4xx decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +searchDetectorResults :: + Maybe Text -> + Maybe Bool -> + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse SearchDetectorResultsResponse) +searchDetectorResults mCustomResultIndex mOnlyCustom mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "results", "_search"] + endpointWithCustom = case mCustomResultIndex of + Nothing -> baseEndpoint + Just idx -> mkEndpoint (getRawEndpoint baseEndpoint <> [idx]) + endpoint = case mOnlyCustom of + Nothing -> endpointWithCustom + Just b -> withQueries endpointWithCustom [("only_query_custom_result_index", Just (showText b))] + body = encode (maybe (object []) id mQuery) + +-- | 'deleteDetectorResults' deletes anomaly-result documents by query via +-- @DELETE /_plugins/_anomaly_detection/detectors/results@ (introduced in +-- OpenSearch 1.1). The body is a standard OpenSearch query-DSL object +-- (the same shape @deleteByQuery@ accepts) carrying the selection +-- predicate — typically a @bool@ filter on @detector_id@, @task_id@ and +-- a @data_start_time@ range, as shown in the plugin docs. The endpoint +-- only operates on the default result index; anomaly results stored in +-- a custom result index must be deleted manually (per the docs). +-- +-- The body is mandatory by design: an empty @{}@ would match every +-- anomaly-result document in the default index, so we make the caller +-- pass the selection explicitly rather than defaulting to @{}@ (the +-- 'searchDetectorResults' precedent defaults to @{}@ because a bare +-- search is harmless; a bare delete-by-query is not). Construct the +-- body with the usual aeson helpers, e.g. +-- +-- @ +-- 'object' ["query" .= 'object' ["bool" .= 'object' ["filter" .= [...] ]]] +-- @ +-- +-- The response is the bare @_delete_by_query@ envelope (reused as +-- 'DeleteDetectorResultsResponse', which aliases the document-API +-- 'DeletedDocuments' since the shape is identical — @took@, +-- @timed_out@, @total@, @deleted@, @batches@, @version_conflicts@, +-- @noops@, @retries@, @throttled_millis@, @requests_per_second@, +-- @throttled_until_millis@, @failures@). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +deleteDetectorResults :: + Value -> + BHRequest StatusDependant (ParsedEsResponse DeleteDetectorResultsResponse) +deleteDetectorResults query = + withBHResponseParsedEsResponse $ + deleteWithBody @StatusDependant endpoint (encode query) + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "results"] + +-- | 'searchDetectorTasks' searches the detection-state index via +-- @POST /_plugins/_anomaly_detection/detectors/tasks/_search@ — the +-- record store for real-time and historical task state. Pass 'Nothing' +-- for the plain empty-body @{}@ POST; pass @'Just' query@ to filter +-- (e.g. by @detector_id@, @task_type@, @is_latest@) using the standard +-- query DSL. +-- +-- Each hit's @_source@ is a task record; the response is surfaced as a +-- 'SearchDetectorTasksResponse' with opaque 'Value' sources. +-- +-- Surfaced as 'StatusDependant' so a 4xx decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +searchDetectorTasks :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse SearchDetectorTasksResponse) +searchDetectorTasks mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "tasks", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'topAnomalies' returns the top anomaly results for a +-- high-cardinality detector via +-- @GET /_plugins/_anomaly_detection/detectors/{detector_id}/results/_topAnomalies?historical={bool}@, +-- bucketed by category-field values. Pass 'True' for historical results, +-- 'False' for real-time. The 'TopAnomaliesRequest' body is sent with the +-- GET (it carries @start_time_ms@ / @end_time_ms@ which are required). +-- +-- The response is a 'TopAnomaliesResponse' whose @buckets@ each carry a +-- categorical @key@, a @doc_count@, and the @max_anomaly_grade@. +-- +-- Surfaced as 'StatusDependant' so a 4xx decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +topAnomalies :: + DetectorId -> + Bool -> + TopAnomaliesRequest -> + BHRequest StatusDependant (ParsedEsResponse TopAnomaliesResponse) +topAnomalies detectorId historical req = + withBHResponseParsedEsResponse $ + getWithBody @StatusDependant endpoint (encode req) + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId, "results", "_topAnomalies"] + endpoint = + if historical + then withQueries baseEndpoint [("historical", Just "true")] + else withQueries baseEndpoint [("historical", Just "false")] + +-- Index Rollups plugin +-- +-- ---------------------------------------------------------------------------- + +-- | 'createRollup' creates or replaces an index rollup job via +-- @PUT /_plugins/_rollup/jobs/{rollup_id}@. The 'Rollup' body is wrapped +-- in the @{"rollup": ...}@ envelope the endpoint expects. Equivalent to +-- 'createRollupWith' with 'Nothing' (no optimistic-concurrency guard), so +-- a concurrent update silently clobbers the prior job definition. +-- +-- Surfaced as 'StatusDependant' so a 4xx (malformed body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createRollup :: + RollupId -> + Rollup -> + BHRequest StatusDependant (ParsedEsResponse RollupResponse) +createRollup rollupId rollup = createRollupWith rollupId rollup Nothing + +-- | 'createRollupWith' creates or replaces an index rollup job via +-- @PUT /_plugins/_rollup/jobs/{rollup_id}@ with an optional +-- optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ — both +-- values read from a prior 'RollupResponse' — to make the PUT conditional +-- on the job being unchanged since you last read it; a stale pair causes +-- OpenSearch to respond with HTTP 409 instead of silently overwriting. +-- Pass 'Nothing' for the unconditional semantics of 'createRollup'. The +-- two values must be supplied together (mirroring the 'putISMPolicyWith' +-- precedent). +-- +-- Surfaced as 'StatusDependant' so a 4xx (or a 409 on a sequence-number +-- mismatch) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createRollupWith :: + RollupId -> + Rollup -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant (ParsedEsResponse RollupResponse) +createRollupWith rollupId rollup mOcc = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode (RollupWrapper rollup)) + where + baseEndpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries baseEndpoint $ + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- ========================================================================= +-- Index Transforms plugin +-- ========================================================================= + +-- | 'createTransform' creates or replaces an Index Transforms job via +-- @PUT /_plugins/_transform/{transform_id}@. The body is the 'Transform' +-- wrapped under the top-level @transform@ key (see 'TransformRequest'); +-- the response is the 'TransformDocumentResponse' document envelope +-- (@_id@, @_version@, @_seq_no@, @_primary_term@, @transform@). +-- +-- OpenSearch treats the PUT as upsert: the same call creates a new +-- transform when @transform_id@ is unused and overwrites an existing one +-- otherwise (without an optimistic-concurrency guard). Use +-- 'updateTransformWith' to make the overwrite conditional on a prior +-- @_seq_no@ \/ @_primary_term@. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, RBAC denial, +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createTransform :: + TransformId -> + Transform -> + BHRequest StatusDependant (ParsedEsResponse TransformDocumentResponse) +createTransform transformId transform = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode (TransformRequest transform)) + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId] + +-- | 'updateTransform' replaces an Index Transforms job via +-- @PUT /_plugins/_transform/{transform_id}@. Equivalent to +-- 'updateTransformWith' with 'Nothing' (no optimistic-concurrency +-- guard), so concurrent updates to the same @transform_id@ silently +-- clobber each other. Mirrors the 'updateMonitor' / 'updateDetector' +-- unconditional-update precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, unknown +-- @transform_id@, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +updateTransform :: + TransformId -> + Transform -> + BHRequest StatusDependant (ParsedEsResponse TransformDocumentResponse) +updateTransform transformId transform = updateTransformWith transformId transform Nothing + +-- | 'updateTransformWith' replaces an Index Transforms job via +-- @PUT /_plugins/_transform/{transform_id}@ with an optional +-- optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ — +-- both values read from a prior 'TransformDocumentResponse' — to make +-- the PUT conditional on the transform being unchanged since you last +-- read it; a stale pair causes OpenSearch to respond with HTTP 409 +-- instead of silently overwriting. Pass 'Nothing' for the unconditional +-- semantics of 'updateTransform'. The two values must be supplied +-- together (mirroring the 'updateMonitorWith' / 'updateDetectorWith' / +-- 'putISMPolicyWith' precedent). +-- +-- The plugin docs document @if_seq_no@ \/ @if_primary_term@ as required +-- for the Update operation; OpenSearch still accepts an unparameterised +-- PUT as an overwrite (the @Nothing@ form), which is why +-- 'updateTransform' exists as a convenience. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing @transform_id@ +-- (or a 409 on a sequence-number mismatch) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +updateTransformWith :: + TransformId -> + Transform -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant (ParsedEsResponse TransformDocumentResponse) +updateTransformWith transformId transform mOcc = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode (TransformRequest transform)) + where + baseEndpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries baseEndpoint $ + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'getRollup' fetches a single rollup job by id via +-- @GET /_plugins/_rollup/jobs/{rollup_id}@. The response is the same +-- document-write envelope (@_id@, @_version@, @_seq_no@, +-- @_primary_term@) wrapping the inner rollup that 'createRollup' +-- returns, except the GET form emits @_seqNo@\/@_primaryTerm@ in +-- camelCase; both spellings are decoded (see 'RollupResponse'). +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @rollup_id@ or plugin +-- not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse RollupResponse) +getRollup rollupId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId] + +-- | 'getAllRollups' lists every rollup job via +-- @GET /_plugins/_rollup/jobs@. The response shape is not documented in +-- the field tables, so the body is returned as an opaque 'Value' for the +-- caller to inspect. +-- | 'getTransform' fetches a single Index Transforms job by id via +-- @GET /_plugins/_transform/{transform_id}@. The response is the +-- 'TransformDocumentResponse' document envelope carrying the persisted +-- 'TransformResponse' (with server-injected bookkeeping fields +-- @schema_version@, @updated_at@, @enabled_at@, @roles@, +-- @transform_id@) alongside the document-write metadata +-- (@_id@, @_version@, @_seq_no@, @_primary_term@). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing @transform_id@ +-- (or the plugin not installed) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +getTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse TransformDocumentResponse) +getTransform transformId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId] + +-- | 'getTransforms' lists Index Transforms jobs via +-- @GET /_plugins/_transform\/@. Pass 'Nothing' for the plain no-arg +-- list; pass @'Just' opts@ to filter by free-text @search@, paginate +-- with @from@ \/ @size@, or sort by @sortField@ \/ @sortDirection@ (see +-- 'TransformsListOptions'). +-- +-- The response is a 'GetTransformsResponse' carrying @total_transforms@ +-- (the count of all transforms the caller can see, independent of +-- pagination) and the per-page @transforms@ array. Each entry is a +-- 'GetTransformsListEntry' with the same document envelope + +-- 'TransformResponse' payload as 'getTransform'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getAllRollups :: + BHRequest StatusDependant (ParsedEsResponse Value) +getAllRollups = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs"] + +-- | 'deleteRollup' deletes a rollup job by id via +-- @DELETE /_plugins/_rollup/jobs/{rollup_id}@. The plugin returns the bare +-- Elasticsearch delete-document response (@_index@, @_id@, @_version@, +-- @result@, @forced_refresh@, @_shards@, @_seq_no@, @_primary_term@, NO +-- @acknowledged@ key), so the body is returned as an opaque 'Value'. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @rollup_id@ or plugin +-- not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse Value) +deleteRollup rollupId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId] + +-- | 'startRollup' starts a rollup job by id via +-- @POST /_plugins/_rollup/jobs/{rollup_id}/_start@. The plugin +-- acknowledges with an 'Acknowledged' body. +-- +-- Surfaced as 'StatusDependant' so a 4xx (unknown @rollup_id@, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +startRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +startRollup rollupId = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId, "_start"] + +-- | 'stopRollup' stops a rollup job by id via +-- @POST /_plugins/_rollup/jobs/{rollup_id}/_stop@. The plugin +-- acknowledges with an 'Acknowledged' body. +-- +-- Surfaced as 'StatusDependant' so a 4xx (unknown @rollup_id@, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +stopRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +stopRollup rollupId = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId, "_stop"] + +-- | 'explainRollup' returns execution metadata for a rollup job by id +-- via @GET /_plugins/_rollup/jobs/{rollup_id}/_explain@. The response is +-- keyed by the rollup id; decode it into 'ExplainRollupResponse' and +-- look up the entry with 'explainRollupResponseLookup'. Before the job +-- has executed, both @metadata_id@ and @rollup_metadata@ are JSON @null@. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @rollup_id@ or plugin +-- not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +explainRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse ExplainRollupResponse) +explainRollup rollupId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId, "_explain"] + +-- ========================================================================= +-- Cross-Cluster Replication (CCR) plugin +-- ========================================================================= + +-- | 'startReplication' calls the CCR plugin Start Replication API +-- (@PUT /_plugins/_replication/{follower-index}/_start@) on the +-- /follower/ cluster. Begins replicating the named leader index into the +-- given follower index. The follower index is created read-only and +-- stays so while replication is active; call 'stopReplication' to +-- convert it back into a standard writable index. +-- +-- The 'StartReplicationRequest' carries the leader connection alias, +-- the leader index name, and (when the Security plugin is enabled) the +-- cross-cluster roles. Returns 'Acknowledged'. +-- +-- For more information see +-- . +startReplication :: + Text -> + StartReplicationRequest -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +startReplication followerIndex req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_start"] + +-- | 'stopReplication' calls the CCR plugin Stop Replication API +-- (@POST /_plugins/_replication/{follower-index}/_stop@) on the +-- /follower/ cluster. Terminates replication and converts the follower +-- index into a standard (writable) index. The body is the empty object +-- @{}@ per the plugin docs. Returns 'Acknowledged'. +-- +-- For more information see +-- . +stopReplication :: + Text -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +stopReplication followerIndex = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_stop"] + +-- | 'pauseReplication' calls the CCR plugin Pause Replication API +-- (@POST /_plugins/_replication/{follower-index}/_pause@) on the +-- /follower/ cluster. Pauses replication of the leader index. +-- Replication cannot be resumed after being paused for more than 12 +-- hours — beyond that you must stop, delete the follower, and restart. +-- The body is the empty object @{}@. Returns 'Acknowledged'. +-- +-- For more information see +-- . +pauseReplication :: + Text -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +pauseReplication followerIndex = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_pause"] + +-- | 'resumeReplication' calls the CCR plugin Resume Replication API +-- (@POST /_plugins/_replication/{follower-index}/_resume@) on the +-- /follower/ cluster. Resumes replication of the leader index after a +-- 'pauseReplication'. The body is the empty object @{}@. Returns +-- 'Acknowledged'. +-- +-- For more information see +-- . +resumeReplication :: + Text -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +resumeReplication followerIndex = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_resume"] + +-- | 'updateReplicationSettings' calls the CCR plugin Update Settings API +-- (@PUT /_plugins/_replication/{follower-index}/_update@) on the +-- /follower/ cluster. Applies index-level settings (e.g. +-- @index.number_of_replicas@) to the follower index. Returns +-- 'Acknowledged'. +-- +-- For more information see +-- . +updateReplicationSettings :: + Text -> + UpdateReplicationSettingsRequest -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +updateReplicationSettings followerIndex req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_update"] + +-- | 'getReplicationStatus' calls the CCR plugin Status API +-- (@GET /_plugins/_replication/{follower-index}/_status@) on the +-- /follower/ cluster without the @verbose@ flag. Equivalent to +-- 'getReplicationStatusWith' with 'defaultReplicationStatusOptions'. +-- +-- For more information see +-- . +getReplicationStatus :: + Text -> + BHRequest StatusDependant (ParsedEsResponse ReplicationStatusResponse) +getReplicationStatus = getReplicationStatusWith defaultReplicationStatusOptions + +-- | 'getReplicationStatusWith' is the parameterized variant of +-- 'getReplicationStatus': the supplied 'ReplicationStatusOptions' are +-- forwarded as query-string parameters. Set +-- 'replicationStatusOptionsVerbose' to @'Just' True@ to include +-- shard-level 'SyncingDetails' in the response. +-- +-- See 'Database.Bloodhound.OpenSearch2.Requests.getReplicationStatus'. +getReplicationStatusWith :: + ReplicationStatusOptions -> + Text -> + BHRequest StatusDependant (ParsedEsResponse ReplicationStatusResponse) +getReplicationStatusWith opts followerIndex = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_replication", followerIndex, "_status"] + `withQueries` replicationStatusOptionsParams opts + +-- | 'getLeaderStats' calls the CCR plugin Leader Stats API +-- (@GET /_plugins/_replication/leader_stats@) on the /leader/ cluster. +-- Returns aggregate and per-index read-side counters across all +-- replicated leader indexes. +-- +-- For more information see +-- . +getLeaderStats :: + BHRequest StatusDependant (ParsedEsResponse LeaderStatsResponse) +getLeaderStats = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_replication", "leader_stats"] + +-- | 'getFollowerStats' calls the CCR plugin Follower Stats API +-- (@GET /_plugins/_replication/follower_stats@) on the /follower/ +-- cluster. Returns counts of follower indexes by state and aggregate +-- write-side throughput, plus a per-index breakdown. +-- +-- For more information see +-- . +getFollowerStats :: + BHRequest StatusDependant (ParsedEsResponse FollowerStatsResponse) +getFollowerStats = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_replication", "follower_stats"] + +-- | 'getAutoFollowStats' calls the CCR plugin Auto-Follow Stats API +-- (@GET /_plugins/_replication/autofollow_stats@) on the /follower/ +-- cluster. Returns auto-follow activity and the list of configured +-- replication rules. The docs note there is no dedicated \"list +-- patterns\" endpoint — this stats response is the only way to discover +-- existing auto-follow rules. +-- +-- For more information see +-- . +getAutoFollowStats :: + BHRequest StatusDependant (ParsedEsResponse AutoFollowStatsResponse) +getAutoFollowStats = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_replication", "autofollow_stats"] + +-- | 'createAutoFollowPattern' calls the CCR plugin Create Replication +-- Rule API (@POST /_plugins/_replication/_autofollow@) on the +-- /follower/ cluster. Creates (or, re-POSTed with the same @name@, +-- updates) an auto-follow rule that automatically starts replication on +-- any existing and future leader indexes whose names match the rule's +-- @pattern@. Returns 'Acknowledged'. +-- +-- For more information see +-- . +createAutoFollowPattern :: + CreateAutoFollowPatternRequest -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +createAutoFollowPattern req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_replication", "_autofollow"] + +-- | 'deleteAutoFollowPattern' calls the CCR plugin Delete Replication +-- Rule API (@DELETE /_plugins/_replication/_autofollow@) on the +-- /follower/ cluster. Deletes an auto-follow rule. This prevents /new/ +-- indexes from being replicated but does /not/ stop replication already +-- initiated by the rule — stop those individually with +-- 'stopReplication'. The delete carries a request body (the rule's +-- @leader_alias@ and @name@), hence 'deleteWithBody'. Returns +-- 'Acknowledged'. +-- +-- For more information see +-- . +deleteAutoFollowPattern :: + DeleteAutoFollowPatternRequest -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +deleteAutoFollowPattern req = + withBHResponseParsedEsResponse $ + deleteWithBody @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_replication", "_autofollow"] + +-- . +getTransforms :: + Maybe TransformsListOptions -> + BHRequest StatusDependant (ParsedEsResponse GetTransformsResponse) +getTransforms mOpts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_transform"] + endpoint = case mOpts of + Nothing -> baseEndpoint + Just opts -> withQueries baseEndpoint (transformsListOptionsParams opts) + +-- | 'startTransform' starts an Index Transforms job via +-- @POST /_plugins/_transform/{transform_id}/_start@. The endpoint takes +-- no request body and returns the 'Acknowledged' envelope on success. +-- A non-continuous transform runs to completion and transitions to the +-- @finished@ state; a continuous transform runs on the schedule until +-- 'stopTransform' is called. Poll 'explainTransform' for the runtime +-- state. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @transform_id@, the +-- plugin not installed, RBAC denial) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +startTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +startTransform transformId = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId, "_start"] + +-- | 'stopTransform' stops an Index Transforms job via +-- @POST /_plugins/_transform/{transform_id}/_stop@. The endpoint takes +-- no request body and returns the 'Acknowledged' envelope on success. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @transform_id@, the +-- plugin not installed, RBAC denial) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +stopTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +stopTransform transformId = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId, "_stop"] + +-- | 'explainTransform' returns the runtime status and statistics of an +-- Index Transforms job via +-- @GET /_plugins/_transform/{transform_id}/_explain@. The response is +-- keyed by @transform_id@ at the top level; the request builder +-- projects out the lone entry as a 'Maybe' 'TransformExplain' so the +-- public type reads as a plain per-id lookup. The 'Nothing' branch +-- surfaces when the server returns HTTP 200 with no entry (a miss is +-- more typically HTTP 404 via 'StatusDependant' before the body decode +-- runs). +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @transform_id@, the +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +explainTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse (Maybe TransformExplain)) +explainTransform transformId = + fmap (fmap (Map.lookup (unTransformId transformId))) + . withBHResponseParsedEsResponse + $ get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId, "_explain"] + +-- | 'previewTransform' previews what the transformed target index would +-- look like via @POST /_plugins/_transform/_preview@. The body is the +-- same 'Transform' wrapper as 'createTransform'; no state is +-- persisted. The response is a 'PreviewTransformResponse' carrying the +-- would-be target documents as opaque aeson 'Value's (the row shape is +-- caller-driven by @groups[].target_field@ names plus @aggregations@ +-- keys). +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +previewTransform :: + Transform -> + BHRequest StatusDependant (ParsedEsResponse PreviewTransformResponse) +previewTransform transform = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (TransformRequest transform)) + where + endpoint = mkEndpoint ["_plugins", "_transform", "_preview"] + +-- | 'deleteTransform' deletes an Index Transforms job by id via +-- @DELETE /_plugins/_transform/{transform_id}@. The endpoint does NOT +-- delete the source or target indexes — only the transform job itself. +-- +-- The response is the bulk-response envelope (the transform is stored +-- as a doc in @.opensearch-ism-config@, so DELETE surfaces through the +-- bulk handler). The shared 'BulkResponse' from +-- @Common.Types.Bulk@ matches that envelope byte-for-byte, so we reuse +-- it rather than introducing a per-plugin wrapper. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing @transform_id@ +-- (or the plugin not installed) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +deleteTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse BulkResponse) +deleteTransform transformId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId] diff --git a/src/Database/Bloodhound/OpenSearch2/Types.hs b/src/Database/Bloodhound/OpenSearch2/Types.hs --- a/src/Database/Bloodhound/OpenSearch2/Types.hs +++ b/src/Database/Bloodhound/OpenSearch2/Types.hs @@ -1,7 +1,333 @@ module Database.Bloodhound.OpenSearch2.Types ( module Reexport, + ReplicationUseRoles (..), + StartReplicationRequest (..), + UpdateReplicationSettingsRequest (..), + CreateAutoFollowPatternRequest (..), + DeleteAutoFollowPatternRequest (..), + ReplicationStatus (..), + SyncingDetails (..), + ReplicationStatusResponse (..), + ReplicationStatusOptions (..), + LeaderIndexStats (..), + LeaderStatsResponse (..), + FollowerIndexStats (..), + FollowerStatsResponse (..), + AutoFollowRuleStats (..), + AutoFollowStatsResponse (..), + ISMPolicyRequest (..), + ISMPolicyResponse (..), + ISMPolicyBody (..), + ISMState (..), + ISMTransition (..), + ISMCondition (..), + ISMCron (..), + ISMCronCondition (..), + ISMAction (..), + actionTagName, + actionConfigValue, + ISMActionEntry (..), + ISMRetryConfig (..), + ISMRetryBackoff (..), + ismRetryBackoffText, + mkISMActionEntry, + ismActionEntryActionLens, + ismActionEntryTimeoutLens, + ismActionEntryRetryLens, + ISMRolloverConfig (..), + ISMForceMergeConfig (..), + ISMAllocationConfig (..), + ISMReplicaCountConfig (..), + ISMAliasAction (..), + ISMAliasConfig (..), + ISMTemplate (..), + ISMErrorNotification (..), + ISMErrorNotificationDestination (..), + destinationTag, + destinationConfig, + ISMMessageTemplate (..), + ISMUserVariables (..), + PolicyId (..), + PutISMPolicyResponse (..), + ISMUpdatedIndicesResponse (..), + AddISMPolicyResponse, + ISMFailedIndex (..), + ISMChangePolicyInclude (..), + ChangePolicyRequest (..), + ISMExplanationNamed (..), + ISMExplanationAction (..), + ISMExplanationStep (..), + ISMExplanationRetryInfo (..), + ISMExplanationInfo (..), + ISMExplanationValidate (..), + ISMExplanationEntry (..), + ISMExplanation (..), + ISMPolicyInfo (..), + GetISMPoliciesResponse (..), + ISMPoliciesQuery (..), + ismPoliciesQueryToPairs, + ISMExplainOptions (..), + defaultISMExplainOptions, + ismExplainOptionsParams, + ISMExplainFilter (..), + defaultISMExplainFilter, + ISMExplainFilterRequest (..), + KnnNodeId (..), + KnnStatName (..), + KnnStats (..), + KnnModelState (..), + KnnModel (..), + KnnDeleteModelResponse (..), + KnnTrainingMethod (..), + KnnTrainingRequest (..), + KnnTrainResponse (..), + MLNodeId (..), + MLStatName (..), + MLStats (..), + ModelId (..), + AlgorithmName (..), + ModelFormat (..), + ModelState (..), + ModelConfig (..), + ModelInfo (..), + RegisterModelRequest (..), + MLTaskAck (..), + DeployModelRequest (..), + UndeployModelResponse (..), + ModelNodeUndeployStats (..), + UpdateModelRequest (..), + ModelRateLimiter (..), + ModelSearchResponse (..), + ModelShards (..), + ModelTotal (..), + ModelTotalRelation (..), + ModelHit (..), + ModelGroupId (..), + ModelGroupAccessMode (..), + RegisterModelGroupRequest (..), + RegisterModelGroupResponse (..), + UpdateModelGroupRequest (..), + ModelGroupInfo (..), + ConnectorId (..), + ConnectorProtocol (..), + MLConnectorAction (..), + CreateConnectorRequest (..), + CreateConnectorResponse (..), + UpdateConnectorRequest (..), + ConnectorInfo (..), + MemoryId (..), + MessageId (..), + Memory (..), + CreateMemoryRequest (..), + CreateMemoryResponse (..), + DeleteMemoryResponse (..), + ListMemoriesResponse (..), + MemoryMessage (..), + CreateMemoryMessageRequest (..), + CreateMemoryMessageResponse (..), + ListMemoryMessagesResponse (..), + MemoryMessageTraces (..), + ControllerConfig (..), + ControllerCreateResponse (..), + MLProfileRequest (..), + MLProfilePredictRequestStats (..), + MLProfileModel (..), + MLProfileNode (..), + MLProfileResponse (..), + MLTaskId (..), + MLTaskType (..), + MLTaskState (..), + MLTaskInfo (..), + TrainModelRequest (..), + TrainAndPredictResponse (..), + AgentId (..), + AgentType (..), + LlmConfig (..), + MemoryConfig (..), + ToolConfig (..), + ToolInlineConfig (..), + RegisterAgentRequest (..), + RegisterAgentResponse (..), + ExecuteAgentRequest (..), + ExecuteAgentResponse (..), + InferenceResult (..), + ExecuteOutput (..), + AgentInfo (..), + AgentShards (..), + AgentTotal (..), + AgentTotalRelation (..), + AgentHit (..), + AgentSearchResponse (..), + SQLRequest (..), + PPLRequest (..), + SQLParameter (..), + SQLCursor (..), + SQLCursorRequest (..), + SQLColumn (..), + SQLResult (..), + SQLCloseResult (..), + SQLPluginStats (..), + DetectorId (..), + PeriodUnit (..), + Period (..), + WindowPeriod (..), + FeatureAttribute (..), + DetectorType (..), + User (..), + Detector (..), + DetectorResponse (..), + CreateDetectorResponse (..), + PreviewRequest (..), + FeatureData (..), + Entity (..), + AnomalyResult (..), + PreviewResponse (..), + StartDetectorJobRequest (..), + DetectorJobAcknowledgment (..), + AnomalyShards (..), + DeleteDetectorResponse (..), + ValidateDetectorMode (..), + ValidateDetectorResponse (..), + AnomalySearchTotalRelation (..), + AnomalySearchTotal (..), + AnomalySearchHit (..), + AnomalySearchResponse (..), + DetectorProfileResponse (..), + DetectorStatsResponse (..), + TopAnomaliesOrder (..), + TopAnomaliesRequest (..), + TopAnomalyBucket (..), + TopAnomaliesResponse (..), + NotificationConfigType (..), + NotificationTransport (..), + NotificationConfig (..), + NotificationConfigEntry (..), + GetNotificationConfigsResponse (..), + Channel (..), + GetNotificationChannelsResponse (..), + NotificationSortOrder (..), + NotificationListOptions (..), + CreateNotificationConfigRequest (..), + CreateNotificationConfigResponse (..), + UpdateNotificationConfigRequest (..), + DeleteNotificationConfigResponse (..), + NotificationFeaturesResponse (..), + TestNotificationResponse (..), + TestNotificationEventSource (..), + TestNotificationStatus (..), + TestNotificationDeliveryStatus (..), + SlackTransport (..), + ChimeTransport (..), + WebhookTransport (..), + MicrosoftTeamsTransport (..), + SnsTransport (..), + SesAccountTransport (..), + SmtpAccountTransport (..), + EmailGroupTransport (..), + EmailTransport (..), + EmailRecipient (..), + RollupId (..), + Rollup (..), + RollupWrapper (..), + RollupSchedule (..), + RollupInterval (..), + RollupIntervalUnit (..), + RollupCron (..), + RollupDimension (..), + RollupDateHistogram (..), + RollupTerms (..), + RollupHistogram (..), + RollupMetric (..), + RollupMetricAgg (..), + RollupResponse (..), + RollupResponseInner (..), + ExplainRollupResponse (..), + ExplainRollupEntry (..), + RollupMetadata (..), + RollupStatus (..), + RollupStats (..), + SMPolicyName (..), + SMCron (..), + SMSchedule (..), + SMJobSchedulerInterval (..), + SMCreation (..), + SMDeleteCondition (..), + SMDeletion (..), + SMSnapshotConfig (..), + parseLenientBool, + SMNotificationChannel (..), + SMNotificationConditions (..), + SMNotification (..), + SMPolicyBody (..), + SMPolicy (..), + SMPolicyResponse (..), + GetSMPoliciesResponse (..), + GetSMPoliciesQuery (..), + defaultGetSMPoliciesQuery, + getSMPoliciesQueryParams, + DeleteSMPolicyResponse (..), + SMExplainExecution (..), + SMExplainTrigger (..), + SMExplainRetry (..), + SMExplainWorkflow (..), + SMExplainEntry (..), + SMExplainResponse (..), + TransformId (..), + TransformPeriodUnit (..), + TransformInterval (..), + TransformSchedule (..), + TransformGroup (..), + TermsGroup (..), + HistogramGroup (..), + DateHistogramGroup (..), + Transform (..), + TransformResponse (..), + TransformRequest (..), + TransformDocumentResponse (..), + TransformSortDirection (..), + TransformsListOptions (..), + GetTransformsResponse (..), + GetTransformsListEntry (..), + TransformExplain (..), + TransformMetadata (..), + TransformStats (..), + TransformContinuousStats (..), + PreviewTransformResponse (..), ) where -import Database.Bloodhound.Common.Types as Reexport +-- Hide ES-only Common types that collide with OpenSearch plugin +-- re-exports below: the ES Security 'User' (OpenSearch security lives at +-- /_plugins/_security) and the ES X-Pack Transform types that share +-- names with the OpenSearch Index Transforms plugin (IndexTransforms). +import Database.Bloodhound.Common.Types as Reexport hiding + ( PreviewTransformResponse, + TransformId, + TransformStats, + User, + unTransformId, + ) +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.Alerting as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.AnomalyDetection as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.CCR as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.ISM +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.IndexTransforms as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.KnnModel as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.KnnStats as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.KnnTrain as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLAgent as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLConnectors as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLControllers as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLMemory as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLModel as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLModelGroups as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLProfile as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLStats as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.MLTask as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.Notifications as Reexport import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.PointInTime as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.Rollups as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.SQLPPL as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.SQLStats as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.SecurityAnalytics as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch2.Types.SnapshotManagement diff --git a/src/Database/Bloodhound/OpenSearch3/Client.hs b/src/Database/Bloodhound/OpenSearch3/Client.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/OpenSearch3/Client.hs @@ -0,0 +1,2814 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Database.Bloodhound.OpenSearch3.Client +-- Description : OpenSearch 3 client (re-exports Common + OpenSearch 3 plugins) +-- +-- The OpenSearch 3 client. Re-exports the version-agnostic "Database.Bloodhound.Common.Client" +-- surface and adds OpenSearch 3 plugins: neural and k-NN search/stats (incl. k-NN +-- model training), Index State Management (ISM), ML commons models and agents, +-- point in time (PIT), asynchronous search, SQL and PPL, the notifications +-- framework, and the alerting/monitors framework. +module Database.Bloodhound.OpenSearch3.Client + ( module Reexport, + pitSearch, + pitSearchWith, + openPointInTime, + openPointInTimeWith, + closePointInTime, + listAllPITs, + deleteAllPITs, + neuralSearchByIndices, + neuralSearchByIndex, + getNeuralStats, + getNeuralStatsWith, + warmupNeuralIndex, + warmupNeuralIndices, + clearNeuralCache, + clearNeuralCaches, + getKnnStats, + warmupKnnIndex, + warmupKnnIndices, + clearKnnCache, + clearKnnCaches, + getKnnModel, + trainKnnModel, + trainKnnModelWith, + deleteKnnModel, + searchKnnModels, + getMLStats, + getModel, + registerModel, + registerModelWith, + deployModel, + undeployModel, + updateModel, + searchModels, + listModels, + deleteModel, + predict, + registerAgent, + getAgent, + deleteAgent, + searchAgents, + updateAgent, + executeAgent, + executeAgentAsync, + executeStreamAgent, + executeStreamAgentAGUI, + knnSearch, + getMLTask, + deleteISMPolicy, + addISMPolicy, + putISMPolicy, + putISMPolicyWith, + removeISMPolicy, + changeISMPolicy, + retryISMIndex, + explainISMIndex, + explainISMIndexWith, + explainISMIndexFiltered, + simulateISMPolicy, + getISMPolicy, + getISMPolicies, + postSMPolicy, + putSMPolicyWith, + getSMPolicy, + getSMPolicies, + deleteSMPolicy, + startSMPolicy, + stopSMPolicy, + explainSMPolicies, + submitOSAsyncSearch, + submitOSAsyncSearchWith, + getOSAsyncSearch, + deleteOSAsyncSearch, + getOSAsyncSearchStats, + sqlQuery, + sqlQueryNextPage, + closeSqlCursor, + explainSQL, + pplQuery, + explainPPL, + getSQLStats, + createNotificationConfig, + createNotificationConfigWith, + deleteNotificationConfig, + deleteNotificationConfigs, + getNotificationConfig, + getNotificationConfigs, + getNotificationConfigsWith, + getNotificationFeatures, + getNotificationChannels, + getNotificationChannelsWith, + updateNotificationConfig, + sendTestNotification, + createMonitor, + getMonitor, + updateMonitor, + updateMonitorWith, + deleteMonitor, + searchMonitors, + executeMonitor, + createSADetector, + getSADetector, + updateSADetector, + deleteSADetector, + searchSADetectors, + searchSAPrePackagedRules, + searchSACustomRules, + createSACustomRule, + updateSACustomRule, + deleteSACustomRule, + getSAMappingsView, + createSAMappings, + getSAMappings, + updateSAMappings, + getSAAlertsWith, + getSAAlerts, + acknowledgeSADetectorAlerts, + searchSAFindings, + createSACorrelationRule, + getSACorrelations, + findSACorrelation, + searchSACorrelationAlerts, + acknowledgeSACorrelationAlerts, + createSALogType, + searchSALogTypes, + updateSALogType, + deleteSALogType, + getDestinations, + getDestinationsWith, + createDestination, + updateDestination, + deleteDestination, + getAlertsWith, + getAlerts, + acknowledgeAlert, + getMonitorStats, + createEmailAccount, + getEmailAccount, + updateEmailAccount, + updateEmailAccountWith, + deleteEmailAccount, + createEmailGroup, + getEmailGroup, + updateEmailGroup, + updateEmailGroupWith, + deleteEmailGroup, + getDestination, + searchEmailAccounts, + searchEmailGroups, + searchFindings, + createComment, + updateComment, + searchComments, + deleteComment, + createWorkflow, + createWorkflowWith, + getWorkflow, + provisionWorkflow, + provisionWorkflowWith, + deleteWorkflow, + deleteWorkflowWith, + searchWorkflows, + updateWorkflow, + updateWorkflowWith, + deprovisionWorkflow, + deprovisionWorkflowWith, + getWorkflowState, + getWorkflowStateWith, + getWorkflowSteps, + getWorkflowStepsWith, + searchWorkflowState, + createDetector, + getDetector, + previewDetector, + previewDetectorInline, + startDetector, + stopDetector, + updateDetector, + updateDetectorWith, + deleteDetector, + validateDetector, + searchDetectors, + profileDetector, + getDetectorStats, + searchDetectorResults, + deleteDetectorResults, + searchDetectorTasks, + topAnomalies, + createRollup, + createRollupWith, + getRollup, + getAllRollups, + deleteRollup, + startRollup, + stopRollup, + explainRollup, + startReplication, + stopReplication, + pauseReplication, + resumeReplication, + updateReplicationSettings, + getReplicationStatus, + getReplicationStatusWith, + getLeaderStats, + getFollowerStats, + getAutoFollowStats, + createAutoFollowPattern, + deleteAutoFollowPattern, + createTransform, + updateTransform, + updateTransformWith, + getTransform, + getTransforms, + startTransform, + stopTransform, + explainTransform, + previewTransform, + deleteTransform, + getJobSchedulerJobs, + getJobSchedulerLocks, + getJobSchedulerLock, + ) +where + +import Control.Monad +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as BL +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Text (Text) +import Data.Text.Encoding qualified as TE +import Data.Word (Word64) +import Database.Bloodhound.Client.Cluster +import Database.Bloodhound.Common.Client as Reexport hiding + ( PreviewTransformResponse, + TransformId, + TransformStats, + deleteTransform, + explainTransform, + getTransforms, + previewTransform, + startTransform, + stopTransform, + unTransformId, + updateTransform, + updateTransformWith, + ) +import Database.Bloodhound.Internal.Utils.SSE (newSSEState, readSSEEvent, sseData) +import Database.Bloodhound.Internal.Versions.Common.Types.Knn +import Database.Bloodhound.Internal.Versions.Common.Types.Search +import Database.Bloodhound.OpenSearch3.Requests qualified as Requests +import Database.Bloodhound.OpenSearch3.Types +import Network.HTTP.Client qualified as HTTP (responseBody) +import Prelude hiding (filter, head) + +-- | 'pitSearch' uses the point in time (PIT) API of OpenSearch, for a given +-- 'IndexName'. The supplied 'KeepAlive' duration is forwarded to every PIT +-- open\/extend call. Note that this will consume the entire search result set +-- and will be doing O(n) list appends so this may not be suitable for large +-- result sets. In that case, the point in time API should be used directly +-- with `openPointInTime` and `closePointInTime`. +-- +-- This is a convenience wrapper around 'pitSearchWith' that lifts the +-- single 'IndexName' into an 'IndexPattern'. To search across multiple +-- comma-joined indices or a wildcard pattern, use 'pitSearchWith' +-- directly with an 'IndexPattern'. +-- +-- Note that 'pitSearch' utilizes the 'search_after' parameter under the hood, +-- which requires a non-empty 'sortBody' field in the provided 'Search' value. +-- Otherwise, 'pitSearch' will fail to return all matching documents. +-- +-- Closing the PIT (via 'closePointInTime') is best-effort cleanup: if it +-- fails, the accumulated hits are still returned rather than discarded. The +-- PIT will expire on its own once the @keep_alive@ elapses. +-- +-- For more information see +-- . +pitSearch :: + forall a m. + (FromJSON a, MonadBH m, WithBackend OpenSearch3 m) => + IndexName -> + KeepAlive -> + Search -> + m [Hit a] +pitSearch indexName = pitSearchWith (IndexPattern (unIndexName indexName)) + +-- | 'pitSearchWith' is the parameterized variant of 'pitSearch': it +-- takes an 'IndexPattern' as the target (@target_indexes@ on the wire), +-- which may be a single index name, a comma-separated list of indices, +-- or a wildcard pattern (e.g. @\"logs-*\"@, @\"logs-2024,logs-2025\"@). +-- Otherwise behaves exactly like 'pitSearch'. See +-- 'openPointInTimeWith' for the target rendering. +-- +-- For more information see +-- . +pitSearchWith :: + forall a m. + (FromJSON a, MonadBH m, WithBackend OpenSearch3 m) => + IndexPattern -> + KeepAlive -> + Search -> + m [Hit a] +pitSearchWith indexPattern keepAlive search = do + openResp <- openPointInTimeWith indexPattern keepAlive defaultPITOptions + case openResp of + Left e -> throwEsError e + Right OpenPointInTimeResponse {..} -> do + let searchPIT = search {pointInTime = Just (PointInTime oos3PitId (Just keepAlive))} + hits <- pitAccumulator searchPIT [] + closeResp <- closePointInTime (ClosePointInTime [oos3PitId]) + case closeResp of + Left _ -> return hits + Right resp + | not (null (closePITs resp)) && all cpitSuccessful (closePITs resp) -> return hits + | otherwise -> error "failed to close point in time (PIT)" + where + pitAccumulator :: Search -> [Hit a] -> m [Hit a] + pitAccumulator search' oldHits = do + resp <- tryPerformBHRequest $ Requests.searchAll search' + case resp of + Left _ -> return [] + Right searchResult -> case hits (searchHits searchResult) of + [] -> return oldHits + newHits -> case (hitSort $ last newHits, pitId searchResult) of + (Nothing, Nothing) -> + error "no point in time (PIT) ID or last sort value" + (Just _, Nothing) -> error "no point in time (PIT) ID" + (Nothing, _) -> return (oldHits <> newHits) + (Just lastSort, Just pitId') -> do + let newSearch = + search' + { pointInTime = Just (PointInTime pitId' (Just keepAlive)), + searchAfterKey = Just lastSort + } + pitAccumulator newSearch (oldHits <> newHits) + +-- | 'openPointInTime' opens a point in time for an index given an 'IndexName' +-- and a 'KeepAlive' duration (e.g. @keepAliveMinutes 1@). Note that the point +-- in time should be closed with 'closePointInTime' as soon as it is no longer +-- needed. +-- +-- Equivalent to 'openPointInTimeWith' with +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.defaultPITOptions' +-- (no optional URI parameters). +-- +-- For more information see +-- . +openPointInTime :: + (MonadBH m, WithBackend OpenSearch3 m) => + IndexName -> + KeepAlive -> + m (ParsedEsResponse OpenPointInTimeResponse) +openPointInTime indexName keepAlive = performBHRequest $ Requests.openPointInTime indexName keepAlive + +-- | 'openPointInTimeWith' is the parameterized variant of +-- 'openPointInTime': it takes an 'IndexPattern' target (single name, +-- comma-list, or wildcard) and forwards the supplied 'PITOptions' as +-- query-string parameters in addition to the mandatory @keep_alive@. +-- See 'Database.Bloodhound.OpenSearch3.Requests.openPointInTimeWith' +-- for which parameters are emitted. +-- +-- For more information see +-- . +openPointInTimeWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + IndexPattern -> + KeepAlive -> + PITOptions -> + m (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWith indexPattern keepAlive opts = + performBHRequest $ Requests.openPointInTimeWith indexPattern keepAlive opts + +-- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'. +-- +-- For more information see +-- . +closePointInTime :: + (MonadBH m, WithBackend OpenSearch3 m) => + ClosePointInTime -> + m (ParsedEsResponse ClosePointInTimeResponse) +closePointInTime q = performBHRequest $ Requests.closePointInTime q + +-- | 'listAllPITs' returns every currently-open point in time on the +-- cluster via @GET /_search/point_in_time/_all@. Each 'PITInfo' carries +-- the pit id, the @creation_time@ and the remaining @keep_alive@ (a bare +-- millisecond count on the wire); the @_shards@ summary is absent from +-- list entries (it appears only in the @POST@ create-PIT response, see +-- 'OpenPointInTimeResponse'). +-- +-- For more information see +-- . +listAllPITs :: + (MonadBH m, WithBackend OpenSearch3 m) => + m [PITInfo] +listAllPITs = performBHRequest Requests.listAllPITs + +-- | 'deleteAllPITs' deletes every currently-open point in time on the +-- cluster via @DELETE /_search/point_in_time/_all@ (no request body). +-- The server returns one 'ClosePointInTimeResult' per deleted PIT, so +-- the response reuses the 'ClosePointInTimeResponse' envelope; partial +-- failures are reported as failures. Deletes only local and mixed PITs, +-- not fully remote (cross-cluster) ones. +-- +-- For more information see +-- . +deleteAllPITs :: + (MonadBH m, WithBackend OpenSearch3 m) => + m (ParsedEsResponse ClosePointInTimeResponse) +deleteAllPITs = performBHRequest Requests.deleteAllPITs + +-- | 'neuralSearchByIndices' executes a neural search against a list of +-- indices via the standard @POST \/{indices}\/_search@ endpoint; the +-- neural behaviour comes from a @neural@ clause in the 'Search' body. +-- +-- For more information see +-- . +neuralSearchByIndices :: + (MonadBH m, WithBackend OpenSearch3 m, FromJSON a) => + [IndexName] -> + Search -> + m (ParsedEsResponse (SearchResult a)) +neuralSearchByIndices indices search = performBHRequest $ Requests.neuralSearch indices search + +-- | 'neuralSearchByIndex' executes a neural search against a single +-- index (a 'neural' clause in the 'Search' body against +-- @POST \/{index}\/_search@). +neuralSearchByIndex :: + (MonadBH m, WithBackend OpenSearch3 m, FromJSON a) => + IndexName -> + Search -> + m (ParsedEsResponse (SearchResult a)) +neuralSearchByIndex indexName = neuralSearchByIndices [indexName] + +-- | 'getNeuralStats' fetches Neural Search plugin statistics. Both arguments +-- are optional: 'Nothing' for the node ID queries every node; 'Nothing' for +-- the stat name returns every stat. The endpoint is disabled by default and +-- must be enabled with the @plugins.neural_search.stats_enabled@ cluster +-- setting before it will respond (else HTTP 403). See +-- "Database.Bloodhound.OpenSearch3.Requests" for the live-verified wire +-- shape. +-- +-- Equivalent to 'getNeuralStatsWith' with 'defaultNeuralStatsOptions'; see +-- 'getNeuralStatsWith' to toggle individual response sections via the +-- @include_*@ query parameters. +-- +-- For more information see +-- . +getNeuralStats :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe NeuralNodeId -> + Maybe NeuralStatName -> + m (ParsedEsResponse NeuralStats) +getNeuralStats mNodeId mStatName = performBHRequest $ Requests.getNeuralStats mNodeId mStatName + +-- | 'getNeuralStatsWith' is the parameterized variant of 'getNeuralStats': +-- it forwards the supplied 'NeuralStatsOptions' as the three documented +-- @include_*@ query parameters (@include_info@, @include_all_nodes@, +-- @include_individual_nodes@), each toggling whether the server emits the +-- corresponding top-level section of the 'NeuralStats' response. Fields set +-- to 'Nothing' are omitted; with 'defaultNeuralStatsOptions' this yields no +-- query string, reproducing the wire shape of 'getNeuralStats'. Pass +-- 'defaultNeuralStatsOptions' to reproduce the wire shape of 'getNeuralStats'. +-- +-- For more information see +-- . +getNeuralStatsWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe NeuralNodeId -> + Maybe NeuralStatName -> + NeuralStatsOptions -> + m (ParsedEsResponse NeuralStats) +getNeuralStatsWith mNodeId mStatName opts = + performBHRequest $ Requests.getNeuralStatsWith mNodeId mStatName opts + +-- | 'warmupNeuralIndices' preloads the neural sparse data for the given +-- indices into JVM memory on the data nodes, so the first neural sparse +-- search against each index does not pay the cache-load latency. Maps to +-- @POST /_plugins/_neural/warmup/{index}@ (the index segment is rendered +-- as a comma-separated list, matching the OpenSearch multi-target syntax) +-- and returns 'ShardsResult' (the @{\"_shards\":{...}}@ envelope) on +-- success. The warmup is asynchronous — the response is returned as soon +-- as the load is scheduled; 'getNeuralStats' reports plugin cache +-- statistics. +-- +-- Wire shape live-verified against OS 3.7.0 (bead bloodhound-at5); see +-- 'Database.Bloodhound.OpenSearch3.Requests.warmupNeuralIndex' for +-- details. +-- +-- For more information see +-- . +warmupNeuralIndices :: + (MonadBH m, WithBackend OpenSearch3 m) => + [IndexName] -> + m ShardsResult +warmupNeuralIndices indexNames = performBHRequest $ Requests.warmupNeuralIndex indexNames + +-- | 'warmupNeuralIndex' is a convenience wrapper around +-- 'warmupNeuralIndices' for the common single-index case. See +-- 'warmupNeuralIndices' for the multi-index variant. +warmupNeuralIndex :: + (MonadBH m, WithBackend OpenSearch3 m) => + IndexName -> + m ShardsResult +warmupNeuralIndex indexName = warmupNeuralIndices [indexName] + +-- | 'clearNeuralCaches' drops the neural search cache entries that the +-- plugin maintains for the given indices, freeing the associated +-- native-memory reservations. Maps to +-- @POST /_plugins/_neural/clear_cache/{index}@ (the index segment is +-- rendered as a comma-separated list, matching the OpenSearch +-- multi-target syntax) and returns 'ShardsResult' (the +-- @{\"_shards\":{...}}@ envelope) on success. +-- +-- Wire shape live-verified against OS 3.7.0 (bead bloodhound-at5); see +-- 'Database.Bloodhound.OpenSearch3.Requests.clearNeuralCache' for +-- details. +-- +-- For more information see +-- . +clearNeuralCaches :: + (MonadBH m, WithBackend OpenSearch3 m) => + [IndexName] -> + m ShardsResult +clearNeuralCaches indexNames = performBHRequest $ Requests.clearNeuralCache indexNames + +-- | 'clearNeuralCache' is a convenience wrapper around 'clearNeuralCaches' +-- for the common single-index case. See 'clearNeuralCaches' for the +-- multi-index variant. +clearNeuralCache :: + (MonadBH m, WithBackend OpenSearch3 m) => + IndexName -> + m ShardsResult +clearNeuralCache indexName = clearNeuralCaches [indexName] + +-- | 'getKnnStats' fetches k-NN plugin statistics. Both arguments are +-- optional: 'Nothing' for the node ID queries every node; 'Nothing' for the +-- stat name returns every stat. The response is a flat 'KnnStats' envelope +-- (cluster-level scalars plus a @nodes@ per-node map); navigate it via +-- 'knnStatsEntries'. +-- +-- For more information see +-- . +getKnnStats :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe KnnNodeId -> + Maybe KnnStatName -> + m (ParsedEsResponse KnnStats) +getKnnStats mNodeId mStatName = performBHRequest $ Requests.getKnnStats mNodeId mStatName + +-- | 'warmupKnnIndices' loads the k-NN native library indices for the given +-- indices into memory on the data nodes, so the first k-NN search against +-- each index does not pay the native-engine load latency. Maps to +-- @GET /_plugins/_knn/warmup/{index}@ (the index segment is rendered as a +-- comma-separated list, matching the OpenSearch multi-target syntax) and +-- returns 'ShardsResult' (the @{\"_shards\":{...}}@ envelope, +-- live-verified against OS 2.19.5 and 3.7.0) on success. The warmup is +-- asynchronous — the response is returned as soon as the load is +-- scheduled; poll 'getKnnStats' to observe progress. +-- +-- For more information see +-- . +warmupKnnIndices :: + (MonadBH m, WithBackend OpenSearch3 m) => + [IndexName] -> + m ShardsResult +warmupKnnIndices indexNames = performBHRequest $ Requests.warmupKnnIndex indexNames + +-- | 'warmupKnnIndex' is a convenience wrapper around 'warmupKnnIndices' +-- for the common single-index case. See 'warmupKnnIndices' for the +-- multi-index variant. +warmupKnnIndex :: + (MonadBH m, WithBackend OpenSearch3 m) => + IndexName -> + m ShardsResult +warmupKnnIndex indexName = warmupKnnIndices [indexName] + +-- | 'clearKnnCaches' drops the native cache entries that the k-NN plugin +-- maintains for the given indices (the @faiss@ \/ @nmslib@ native library +-- index handles), freeing the associated native-memory reservations. Has +-- no effect on @lucene@ indexes. Maps to +-- @POST /_plugins/_knn/clear_cache/{index}@ (the index segment is rendered +-- as a comma-separated list, matching the OpenSearch multi-target syntax; +-- available since OpenSearch 2.14) and returns 'ShardsResult' (the +-- @{\"_shards\":{...}}@ envelope, live-verified against OS 2.19.5 and +-- 3.7.0) on success. The resulting cache-size drop is visible immediately +-- in 'getKnnStats'. +-- +-- For more information see +-- . +clearKnnCaches :: + (MonadBH m, WithBackend OpenSearch3 m) => + [IndexName] -> + m ShardsResult +clearKnnCaches indexNames = performBHRequest $ Requests.clearKnnCache indexNames + +-- | 'clearKnnCache' is a convenience wrapper around 'clearKnnCaches' for +-- the common single-index case. See 'clearKnnCaches' for the multi-index +-- variant. +clearKnnCache :: + (MonadBH m, WithBackend OpenSearch3 m) => + IndexName -> + m ShardsResult +clearKnnCache indexName = clearKnnCaches [indexName] + +-- | 'getKnnModel' fetches metadata for a trained k-NN model by its +-- 'ModelId'. Maps to @GET /_plugins/_knn/models/{model_id}@. The response is +-- a bare object (no envelope), decoded into 'KnnModel'; the +-- 'knnModelModelBlob' field is large and may be absent when the caller has +-- excluded it via @?filter_path@. +-- +-- For more information see +-- . +getKnnModel :: + (MonadBH m, WithBackend OpenSearch3 m) => + ModelId -> + m (ParsedEsResponse KnnModel) +getKnnModel modelId = performBHRequest $ Requests.getKnnModel modelId + +-- | 'trainKnnModel' schedules asynchronous training of a k-NN native library +-- model (e.g. FAISS IVF) from the vectors in a training index's +-- @knn_vector@ field. Maps to @POST /_plugins/_knn/models/{model_id}/_train@. +-- The request returns as soon as training is scheduled; the +-- 'KnnTrainResponse' echoes the @model_id@ under which training was +-- scheduled. To observe progress, poll 'getKnnModel' and watch +-- 'knnModelState' transition from @training@ to @created@ (success) or +-- @failed@ (consult 'knnModelError' for the cause). +-- +-- Equivalent to 'trainKnnModelWith' with @Nothing@ (no node preference). +-- +-- For more information see +-- . +trainKnnModel :: + (MonadBH m, WithBackend OpenSearch3 m) => + ModelId -> + KnnTrainingRequest -> + m (ParsedEsResponse KnnTrainResponse) +trainKnnModel = trainKnnModelWith Nothing + +-- | 'trainKnnModelWith' extends 'trainKnnModel' with an optional +-- @?preference@ query parameter. Supplying 'Just' a 'KnnNodeId' pins the +-- asynchronous training task to the specified data node, sent on the wire +-- as @?preference={node_id}@; 'Nothing' lets OpenSearch choose the training +-- node. The pinned node must already host a shard of the training index, +-- otherwise OpenSearch rejects the request. +-- +-- For more information see +-- . +trainKnnModelWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe KnnNodeId -> + ModelId -> + KnnTrainingRequest -> + m (ParsedEsResponse KnnTrainResponse) +trainKnnModelWith mNodeId modelId req = + performBHRequest $ Requests.trainKnnModelWith mNodeId modelId req + +-- | 'deleteKnnModel' removes a trained k-NN model by its 'ModelId'. +-- Maps to @DELETE /_plugins/_knn/models/{model_id}@ and returns a +-- 'KnnDeleteModelResponse' echoing the @model_id@ and reporting +-- @result = "deleted"@. Note this is NOT the standard 'Acknowledged' +-- envelope (the k-NN plugin returns a richer response than the typical +-- cluster-level ack). A missing model id surfaces as an 'EsError' via +-- 'StatusDependant', matching 'getKnnModel' and the ML Commons +-- 'deleteModel' precedent. +-- +-- For more information see +-- . +deleteKnnModel :: + (MonadBH m, WithBackend OpenSearch3 m) => + ModelId -> + m (ParsedEsResponse KnnDeleteModelResponse) +deleteKnnModel modelId = performBHRequest $ Requests.deleteKnnModel modelId + +-- | 'searchKnnModels' searches the @.opensearch-knn-models@ system index +-- via @POST /_plugins/_knn/models/_search@. The caller drives the query +-- through the standard 'Search' DSL (paginate with @from@\/@size@, filter +-- with 'queryBody', and exclude the large 'knnModelModelBlob' via the +-- 'source' projection). Returns the standard search envelope as a +-- 'SearchResult' whose hits carry a 'KnnModel' in each @_source@. +-- +-- Mirrors 'knnSearch' in shape; see +-- 'Database.Bloodhound.OpenSearch3.Requests.searchKnnModels' for the +-- request-level details. +-- +-- For more information see +-- . +searchKnnModels :: + (MonadBH m, WithBackend OpenSearch3 m) => + Search -> + m (SearchResult KnnModel) +searchKnnModels search = performBHRequest $ Requests.searchKnnModels search + +-- | 'getMLStats' fetches ML Commons plugin statistics. Both arguments are +-- optional: 'Nothing' for the node ID queries every node; 'Nothing' for the +-- stat name returns every stat. The endpoint is available whenever the ML +-- Commons plugin is installed (no cluster setting needs to be enabled, +-- unlike 'getNeuralStats'). +-- +-- For more information see +-- . +getMLStats :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe MLNodeId -> + Maybe MLStatName -> + m (ParsedEsResponse MLStats) +getMLStats mNodeId mStatName = performBHRequest $ Requests.getMLStats mNodeId mStatName + +-- | 'getModel' fetches full metadata for a registered model by its +-- 'ModelId'. The response is a bare object (no envelope), decoded into +-- 'ModelInfo'. +-- +-- For more information see +-- . +getModel :: + (MonadBH m, WithBackend OpenSearch3 m) => + ModelId -> + m (ParsedEsResponse ModelInfo) +getModel modelId = performBHRequest $ Requests.getModel modelId + +-- | 'registerModel' registers a model. Registration is asynchronous; poll +-- the returned @task_id@ via the Get ML Task API. Equivalent to +-- 'registerModelWith' with @deploy = False@. +-- See +registerModel :: + (MonadBH m, WithBackend OpenSearch3 m) => + RegisterModelRequest -> + m (ParsedEsResponse MLTaskAck) +registerModel = performBHRequest . Requests.registerModel + +-- | 'registerModelWith' registers a model with an optional @?deploy=true@ +-- query flag that chains a deploy after successful registration. +-- See +registerModelWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + Bool -> + RegisterModelRequest -> + m (ParsedEsResponse MLTaskAck) +registerModelWith deploy req = performBHRequest $ Requests.registerModelWith deploy req + +-- | 'deployModel' loads a registered model into memory on ML worker nodes. +-- Pass 'Nothing' to let OpenSearch pick eligible nodes; pass a +-- 'DeployModelRequest' to restrict to a node list. Deployment is +-- asynchronous; poll the returned @task_id@ via the Get ML Task API. +-- See +deployModel :: + (MonadBH m, WithBackend OpenSearch3 m) => + ModelId -> + Maybe DeployModelRequest -> + m (ParsedEsResponse MLTaskAck) +deployModel modelId mReq = performBHRequest $ Requests.deployModel modelId mReq + +-- | 'undeployModel' unloads a deployed model from ML worker nodes +-- (the inverse of 'deployModel'). Unlike deploy, undeploy is +-- synchronous: the response is a node-keyed stats map +-- ('UndeployModelResponse'), not a task ack. +-- See +undeployModel :: + (MonadBH m, WithBackend OpenSearch3 m) => + ModelId -> + m (ParsedEsResponse UndeployModelResponse) +undeployModel modelId = performBHRequest $ Requests.undeployModel modelId + +-- | 'updateModel' updates a subset of a registered model's metadata +-- via @PUT /_plugins/_ml/models/{model_id}@. The body is an +-- 'UpdateModelRequest' whose every field is 'Maybe'; only the +-- supplied fields are written. The response is the standard +-- document-update envelope ('IndexedDocument' with +-- @result = "updated"@). +-- See +updateModel :: + (MonadBH m, WithBackend OpenSearch3 m) => + ModelId -> + UpdateModelRequest -> + m (ParsedEsResponse IndexedDocument) +updateModel modelId req = performBHRequest $ Requests.updateModel modelId req + +-- | 'searchModels' searches the model index via +-- @POST /_plugins/_ml/models/_search@. Pass 'Nothing' for the plain +-- empty-body @{}@ POST that returns the first page of all models; +-- pass @'Just' query@ to filter, paginate, or sort using the +-- standard OpenSearch query DSL carried opaquely as a 'Value'. +-- See +searchModels :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe Value -> + m (ParsedEsResponse ModelSearchResponse) +searchModels = performBHRequest . Requests.searchModels + +-- | 'listModels' lists models. Historically this hit the +-- @POST /_plugins/_ml/models/_list@ endpoint, but OS 3.x removed POST +-- from @_list@ (it now returns 405). The modern, supported endpoint +-- for listing is @POST /_plugins/_ml/models/_search@ — the same one +-- 'searchModels' uses. Kept as a separate function rather than aliased +-- to 'searchModels' so callers and telemetry can distinguish the two +-- call sites. +-- See +listModels :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe Value -> + m (ParsedEsResponse ModelSearchResponse) +listModels = performBHRequest . Requests.listModels + +-- | 'deleteModel' deletes a registered model by id. OpenSearch stores +-- models as documents in @.plugins-ml-model@, so the response is the +-- standard document-delete envelope (parsed here as 'IndexedDocument'), +-- not an 'Acknowledged' ack — identical to 'deleteISMPolicy'. A +-- deployed model must be undeployed before it can be deleted, otherwise +-- the server returns an error which surfaces as an 'EsError'. +-- See +deleteModel :: + (MonadBH m, WithBackend OpenSearch3 m) => + ModelId -> + m (ParsedEsResponse IndexedDocument) +deleteModel modelId = performBHRequest $ Requests.deleteModel modelId + +-- | 'predict' invokes a deployed model. The request body and response are +-- model-specific, so both are opaque 'Value's; the caller decodes the +-- payload with a model-specific parser. +-- +-- For more information see +-- . +predict :: + (MonadBH m, WithBackend OpenSearch3 m) => + AlgorithmName -> + ModelId -> + Value -> + m (ParsedEsResponse Value) +predict algo modelId body = performBHRequest $ Requests.predict algo modelId body + +-- | 'registerAgent' registers an ML Commons agent (OS 2.12+) — a named +-- configuration binding an LLM (or a routed population of sub-agents and +-- tools) behind a server-assigned 'AgentId'. Unlike 'registerModel', +-- registration is synchronous: the response carries the @agent_id@ +-- directly, with no @task_id@ to poll. +-- See +registerAgent :: + (MonadBH m, WithBackend OpenSearch3 m) => + RegisterAgentRequest -> + m (ParsedEsResponse RegisterAgentResponse) +registerAgent = performBHRequest . Requests.registerAgent + +-- | 'getAgent' fetches a registered agent by id. The body is the bare +-- stored agent document, decoded as 'AgentInfo'. +-- See +getAgent :: + (MonadBH m, WithBackend OpenSearch3 m) => + AgentId -> + m (ParsedEsResponse AgentInfo) +getAgent agentId = performBHRequest $ Requests.getAgent agentId + +-- | 'deleteAgent' deletes a registered agent by id. The response is +-- the standard document-delete envelope ('IndexedDocument'), +-- identical to 'deleteModel'. +-- See +deleteAgent :: + (MonadBH m, WithBackend OpenSearch3 m) => + AgentId -> + m (ParsedEsResponse IndexedDocument) +deleteAgent agentId = performBHRequest $ Requests.deleteAgent agentId + +-- | 'searchAgents' searches the agent index via +-- @POST /_plugins/_ml/agents/_search@. Pass 'Nothing' for the plain +-- empty-body @{}@ POST; pass @'Just' query@ to filter, paginate, or +-- sort using the standard OpenSearch query DSL carried opaquely as a +-- 'Value'. +-- See +searchAgents :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe Value -> + m (ParsedEsResponse AgentSearchResponse) +searchAgents = performBHRequest . Requests.searchAgents + +-- | 'updateAgent' updates a subset of a registered agent's +-- configuration via @PUT /_plugins/_ml/agents/{agent_id}@. The body is +-- a partial update ('UpdateAgentRequest'); the response is the +-- standard document-update envelope ('IndexedDocument' with +-- @result = "updated"@). +-- See +updateAgent :: + (MonadBH m, WithBackend OpenSearch3 m) => + AgentId -> + UpdateAgentRequest -> + m (ParsedEsResponse IndexedDocument) +updateAgent agentId = performBHRequest . Requests.updateAgent agentId + +-- | 'executeAgent' runs a registered agent synchronously, returning +-- its 'ExecuteAgentResponse'. For the asynchronous variant (3.0+) use +-- 'executeAgentAsync'. +-- See +executeAgent :: + (MonadBH m, WithBackend OpenSearch3 m) => + AgentId -> + ExecuteAgentRequest -> + m (ParsedEsResponse ExecuteAgentResponse) +executeAgent agentId = performBHRequest . Requests.executeAgent agentId + +-- | 'executeAgentAsync' runs a registered agent asynchronously +-- (OpenSearch 3.0+), returning an 'MLTaskAck' carrying a @task_id@ to +-- poll via 'getMLTask'. Sets @?async=true@. +-- See +executeAgentAsync :: + (MonadBH m, WithBackend OpenSearch3 m) => + AgentId -> + ExecuteAgentRequest -> + m (ParsedEsResponse MLTaskAck) +executeAgentAsync agentId = performBHRequest . Requests.executeAgentAsync agentId + +-- | 'executeStreamAgent' runs a conversational agent against the +-- streaming Execute Stream Agent API +-- (@POST /_plugins/_ml/agents/{agent_id}/_execute/stream@, OS 3.3+) +-- and invokes the supplied callback once per Server-Sent Event chunk +-- as it arrives — the response body is /not/ buffered, so partial +-- results (token-by-token LLM output) are visible immediately. +-- +-- Each chunk is decoded into an 'ExecuteStreamChunk' pairing the +-- 'ExecuteAgentResponse' payload with its per-chunk @is_last@ flag. +-- The stream terminates after yielding the chunk whose +-- 'isStreamChunkLast' is 'True' (an empty-content chunk the server +-- emits to signal completion); the callback is /not/ invoked for that +-- final terminator unless you wish to handle it — it is yielded like +-- any other chunk. If the body ends without a terminator (network +-- error, server crash), parsing simply stops. +-- +-- The callback runs in 'IO' (not the underlying monad @m@): lift into +-- your monad inside the callback if needed +-- (e.g. @liftIO . writeTBQueue chunk@). To collect chunks into a +-- conduit, pipes, or an 'IO' list, adapt the callback accordingly — +-- the raw conduit source 'Database.Bloodhound.Internal.Utils.SSE.sseSource' +-- is also available for callers who want to drive framing themselves. +-- +-- /Status errors are not parsed:/ unlike 'performBHRequest', a non-2xx +-- response does not surface as an 'EsError' here — the body of a 4xx +-- is not SSE-framed, so the decoder would yield nothing. Inspect the +-- cluster settings if the callback is never invoked +-- (@plugins.ml_commons.stream_enabled@, the @transport-reactor-netty4@ +-- and @arrow-flight-rpc@ plugins; see the endpoint docs). +-- See +executeStreamAgent :: + (MonadIO m) => + AgentId -> + ExecuteAgentRequest -> + (ExecuteStreamChunk -> IO ()) -> + BH m () +executeStreamAgent agentId req callback = + withStreamingResponse (Requests.executeStreamAgentRequest agentId req) $ + \resp -> do + st <- newSSEState (HTTP.responseBody resp) + chunkLoop st + where + chunkLoop st = do + next <- readSSEEvent st + case next of + Nothing -> pure () + Just ev -> + case decodeTextAsJson (sseData ev) of + Just payload -> do + let chunk = ExecuteStreamChunk payload (detectIsLast payload) + callback chunk + if executeStreamChunkIsLast chunk + then pure () + else chunkLoop st + Nothing -> chunkLoop st + +-- | 'executeStreamAgentAGUI' is the AG-UI-protocol variant of +-- 'executeStreamAgent' (OS 3.5+). The request body uses the AG-UI +-- request format (@threadId@\/@runId@\/@messages@; passed opaquely as +-- a 'Value' because the schema is defined by the AG-UI spec and +-- varies across agent configurations), and the stream emits +-- 'AgUIEvent's discriminated by @type@. The stream terminates after +-- yielding an 'AgUIRunFinished'; an unknown event type decodes to +-- 'AgUIOther' rather than throwing, so future plugin releases adding +-- event kinds round-trip. +-- See +executeStreamAgentAGUI :: + (MonadIO m) => + AgentId -> + Value -> + (AgUIEvent -> IO ()) -> + BH m () +executeStreamAgentAGUI agentId body callback = + withStreamingResponse (Requests.executeStreamAgentAGUIRequest agentId body) $ + \resp -> do + st <- newSSEState (HTTP.responseBody resp) + eventLoop st + where + eventLoop st = do + next <- readSSEEvent st + case next of + Nothing -> pure () + Just ev -> + case decodeTextAsJson (sseData ev) of + Just agEv -> do + callback agEv + case agEv of + AgUIRunFinished {} -> pure () + _ -> eventLoop st + Nothing -> eventLoop st + +-- | Decode a 'Text' (an SSE @data:@ payload, which is itself a JSON +-- fragment) to a value via a strict UTF-8 encode + aeson 'decode'. +decodeTextAsJson :: (FromJSON a) => Text -> Maybe a +decodeTextAsJson = decode . BL.fromStrict . TE.encodeUtf8 + +-- | Examine a decoded chunk's @response@ output for the @is_last@ +-- flag in its @dataAsMap@. The conversational agent emits +-- @{\"content\": ..., \"is_last\": }@ under the @response@ name; +-- the terminal chunk has empty @content@ and @is_last: true@. Returns +-- 'False' if the flag is absent or not a boolean. +detectIsLast :: ExecuteAgentResponse -> Bool +detectIsLast resp = + any (any checkOutput . inferenceResultOutput) (executeAgentInferenceResults resp) + where + checkOutput out = + executeOutputName out == Just "response" + && fromMaybe False (executeOutputDataAsMap out >>= boolField "is_last") + boolField k value = + case value of + Object o -> + case KM.lookup k o of + Just (Bool b) -> Just b + _ -> Nothing + _ -> Nothing + +-- | 'knnSearch' executes a k-NN vector search request against a single index for OpenSearch 3+. +-- +-- OpenSearch kNN uses the standard @POST \/{index}\/_search@ body with a knn +-- clause nested inside @query@ (different shape from ES8+ which uses a +-- top-level knn array). See 'OpenSearchKnnQuery' for the body shape and +-- for the spec. +knnSearch :: + (MonadBH m, WithBackend OpenSearch3 m, FromJSON a) => + IndexName -> + OpenSearchKnnQuery -> + Search -> + m (SearchResult a) +knnSearch indexName osknnQuery search = performBHRequest $ Requests.knnSearch indexName osknnQuery search + +-- | 'getMLTask' fetches the current state of an ML Commons asynchronous task +-- (model registration, deployment, training, ...). Poll this with the +-- @task_id@ returned by the submit endpoint until 'mlTaskInfoState' reaches +-- 'MLTaskStateCompleted' or 'MLTaskStateFailed'. +-- +-- For more information see +-- . +getMLTask :: + (MonadBH m, WithBackend OpenSearch3 m) => + MLTaskId -> + m (ParsedEsResponse MLTaskInfo) +getMLTask mlTaskId = performBHRequest $ Requests.getMLTask mlTaskId + +-- | 'putISMPolicy' creates or updates an ISM policy. +-- See +putISMPolicy :: + (MonadBH m, WithBackend OpenSearch3 m) => + PolicyId -> + ISMPolicyRequest -> + m (ParsedEsResponse PutISMPolicyResponse) +putISMPolicy policyId policy = performBHRequest $ Requests.putISMPolicy policyId policy + +-- | 'putISMPolicyWith' creates or updates an ISM policy with an optional +-- optimistic-concurrency guard (@if_seq_no@ / @if_primary_term@). See +-- 'Requests.putISMPolicyWith' for semantics. +-- See +putISMPolicyWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + PolicyId -> + ISMPolicyRequest -> + Maybe (Word64, Word64) -> + m (ParsedEsResponse PutISMPolicyResponse) +putISMPolicyWith policyId policy mOcc = + performBHRequest $ Requests.putISMPolicyWith policyId policy mOcc + +-- | 'addISMPolicy' applies an existing ISM policy to an index. +-- See +addISMPolicy :: + (MonadBH m, WithBackend OpenSearch3 m) => + PolicyId -> + IndexName -> + m (ParsedEsResponse ISMUpdatedIndicesResponse) +addISMPolicy policyId indexName = performBHRequest $ Requests.addISMPolicy policyId indexName + +-- | 'removeISMPolicy' detaches any ISM policy from the given index. +-- See +removeISMPolicy :: + (MonadBH m, WithBackend OpenSearch3 m) => + IndexName -> + m (ParsedEsResponse ISMUpdatedIndicesResponse) +removeISMPolicy indexName = performBHRequest $ Requests.removeISMPolicy indexName + +-- | 'changeISMPolicy' updates the managed-index policy attached to an index. +-- See +changeISMPolicy :: + (MonadBH m, WithBackend OpenSearch3 m) => + IndexName -> + ChangePolicyRequest -> + m (ParsedEsResponse ISMUpdatedIndicesResponse) +changeISMPolicy indexName req = performBHRequest $ Requests.changeISMPolicy indexName req + +-- | 'retryISMIndex' retries the failed ISM action for an index. +-- See +retryISMIndex :: + (MonadBH m, WithBackend OpenSearch3 m) => + IndexName -> + Maybe Text -> + m (ParsedEsResponse ISMUpdatedIndicesResponse) +retryISMIndex indexName mState = performBHRequest $ Requests.retryISMIndex indexName mState + +-- | 'explainISMIndex' returns the ISM state of an index. +-- See +explainISMIndex :: + (MonadBH m, WithBackend OpenSearch3 m) => + IndexName -> + m (ParsedEsResponse ISMExplanation) +explainISMIndex indexName = performBHRequest $ Requests.explainISMIndex indexName + +-- | 'explainISMIndexWith' returns the ISM state of an index with optional +-- @show_policy@, @validate_action@, @local@ and @expand_wildcards@ query +-- parameters. +-- See +explainISMIndexWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + IndexName -> + ISMExplainOptions -> + m (ParsedEsResponse ISMExplanation) +explainISMIndexWith indexName opts = + performBHRequest $ Requests.explainISMIndexWith indexName opts + +-- | 'explainISMIndexFiltered' returns the ISM state of an index via the +-- @POST /_plugins/_ism/explain/{index}@ "Explain index with filtering" form, +-- sending an 'ISMExplainFilter' as the request body. +-- See +explainISMIndexFiltered :: + (MonadBH m, WithBackend OpenSearch3 m) => + IndexName -> + ISMExplainFilter -> + m (ParsedEsResponse ISMExplanation) +explainISMIndexFiltered indexName filt = + performBHRequest $ Requests.explainISMIndexFiltered indexName filt + +-- | 'simulateISMPolicy' previews how a policy would apply to indexes (OS 3.7+). +-- See 'Database.Bloodhound.OpenSearch3.Requests.simulateISMPolicy'. +simulateISMPolicy :: + (MonadBH m, WithBackend OpenSearch3 m) => + SimulateISMPolicyRequest -> + m SimulateISMPolicyResponse +simulateISMPolicy = performBHRequest . Requests.simulateISMPolicy + +-- | 'getISMPolicy' fetches a single policy by id. +-- See +getISMPolicy :: + (MonadBH m, WithBackend OpenSearch3 m) => + PolicyId -> + m (ParsedEsResponse ISMPolicyInfo) +getISMPolicy policyId = performBHRequest $ Requests.getISMPolicy policyId + +-- | 'getISMPolicies' lists policies, optionally filtered / paginated. +-- See +getISMPolicies :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe ISMPoliciesQuery -> + m (ParsedEsResponse GetISMPoliciesResponse) +getISMPolicies mQuery = performBHRequest $ Requests.getISMPolicies mQuery + +-- | 'deleteISMPolicy' deletes an ISM policy by id. +-- OpenSearch stores policies as documents in @.opendistro-ism-config@, so the +-- response is the standard document-delete envelope (parsed here as +-- 'IndexedDocument'), not an 'Acknowledged' ack. +-- See +deleteISMPolicy :: + (MonadBH m, WithBackend OpenSearch3 m) => + PolicyId -> + m (ParsedEsResponse IndexedDocument) +deleteISMPolicy policyId = performBHRequest $ Requests.deleteISMPolicy policyId + +-- ========================================================================= +-- Snapshot Management plugin +-- ========================================================================= + +-- | 'postSMPolicy' creates a new SM policy. +postSMPolicy :: + (MonadBH m, WithBackend OpenSearch3 m) => + SMPolicyName -> + SMPolicyBody -> + m (ParsedEsResponse SMPolicyResponse) +postSMPolicy policyName body = performBHRequest $ Requests.postSMPolicy policyName body + +-- | 'putSMPolicyWith' updates an existing SM policy with the @if_seq_no@ +-- / @if_primary_term@ optimistic-concurrency guard. +putSMPolicyWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + SMPolicyName -> + SMPolicyBody -> + Word64 -> + Word64 -> + m (ParsedEsResponse SMPolicyResponse) +putSMPolicyWith policyName body seqNo primaryTerm = + performBHRequest $ Requests.putSMPolicyWith policyName body seqNo primaryTerm + +-- | 'getSMPolicy' fetches a single SM policy by name. +getSMPolicy :: + (MonadBH m, WithBackend OpenSearch3 m) => + SMPolicyName -> + m (ParsedEsResponse SMPolicyResponse) +getSMPolicy policyName = performBHRequest $ Requests.getSMPolicy policyName + +-- | 'getSMPolicies' lists SM policies, optionally filtered / paginated. +getSMPolicies :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe GetSMPoliciesQuery -> + m (ParsedEsResponse GetSMPoliciesResponse) +getSMPolicies mQuery = performBHRequest $ Requests.getSMPolicies mQuery + +-- | 'deleteSMPolicy' deletes an SM policy by name. +deleteSMPolicy :: + (MonadBH m, WithBackend OpenSearch3 m) => + SMPolicyName -> + m (ParsedEsResponse DeleteSMPolicyResponse) +deleteSMPolicy policyName = performBHRequest $ Requests.deleteSMPolicy policyName + +-- | 'startSMPolicy' enables an SM policy (sets @enabled=true@). +startSMPolicy :: + (MonadBH m, WithBackend OpenSearch3 m) => + SMPolicyName -> + m (ParsedEsResponse Acknowledged) +startSMPolicy policyName = performBHRequest $ Requests.startSMPolicy policyName + +-- | 'stopSMPolicy' disables an SM policy (sets @enabled=false@). +stopSMPolicy :: + (MonadBH m, WithBackend OpenSearch3 m) => + SMPolicyName -> + m (ParsedEsResponse Acknowledged) +stopSMPolicy policyName = performBHRequest $ Requests.stopSMPolicy policyName + +-- | 'explainSMPolicies' returns the running state of policies matching a +-- name expression (comma list / wildcard). +explainSMPolicies :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + m (ParsedEsResponse SMExplainResponse) +explainSMPolicies policyNames = performBHRequest $ Requests.explainSMPolicies policyNames + +-- | 'submitOSAsyncSearch' submits a 'Search' for asynchronous execution via +-- the OpenSearch async search plugin (@POST /_plugins/_asynchronous_search@), +-- returning immediately with an id and partial results. This is the +-- OpenSearch-plugin-path analogue of the Elasticsearch 'submitAsyncSearch'; +-- poll the returned id with 'getOSAsyncSearch' until 'asyncSearchIsRunning' +-- is @False@. +-- +-- For more information see +-- . +submitOSAsyncSearch :: + (FromJSON a, MonadBH m, WithBackend OpenSearch3 m) => + Search -> + m (AsyncSearchResult a) +submitOSAsyncSearch = performBHRequest . Requests.submitOSAsyncSearch + +-- | Like 'submitOSAsyncSearch' but accepts 'AsyncSearchSubmitOptions' +-- carrying the URI parameters documented for +-- @POST /_plugins/_asynchronous_search@ (@wait_for_completion@, +-- @keep_on_completion@, @keep_alive@). The Elasticsearch-only +-- 'assoBatchedReduceSize' and 'assoCcsMinimizeRoundtrips' are silently +-- dropped. 'defaultAsyncSearchSubmitOptions' makes this byte-for-byte +-- equivalent to 'submitOSAsyncSearch'. +-- +-- For more information see +-- . +submitOSAsyncSearchWith :: + (FromJSON a, MonadBH m, WithBackend OpenSearch3 m) => + AsyncSearchSubmitOptions -> + Search -> + m (AsyncSearchResult a) +submitOSAsyncSearchWith opts = performBHRequest . Requests.submitOSAsyncSearchWith opts + +-- | 'getOSAsyncSearch' polls an OpenSearch async search by id, returning its +-- current state and (partial or final) results. Maps to +-- @GET /_plugins/_asynchronous_search/{id}@. +-- +-- For more information see +-- . +getOSAsyncSearch :: + (FromJSON a, MonadBH m, WithBackend OpenSearch3 m) => + AsyncSearchId -> + m (AsyncSearchResult a) +getOSAsyncSearch = performBHRequest . Requests.getOSAsyncSearch + +-- | 'deleteOSAsyncSearch' deletes an OpenSearch async search result and its +-- context by id. Maps to @DELETE /_plugins/_asynchronous_search/{id}@ and returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteOSAsyncSearch :: + (MonadBH m, WithBackend OpenSearch3 m) => + AsyncSearchId -> + m Acknowledged +deleteOSAsyncSearch = performBHRequest . Requests.deleteOSAsyncSearch + +-- | 'getOSAsyncSearchStats' fetches cluster-wide async-search statistics. +-- See 'Database.Bloodhound.OpenSearch3.Requests.getOSAsyncSearchStats'. +getOSAsyncSearchStats :: + (MonadBH m, WithBackend OpenSearch3 m) => + m AsyncSearchStatsResponse +getOSAsyncSearchStats = performBHRequest Requests.getOSAsyncSearchStats + +-- | 'sqlQuery' executes a SQL query via the OpenSearch SQL plugin +-- (@POST /_plugins/_sql@). Returns a JDBC-style rowset ('SQLResult'). Use +-- 'sqlRequestFetchSize' to opt into cursor pagination, then walk subsequent +-- pages with 'sqlQueryNextPage' and release an unfinished cursor with +-- 'closeSqlCursor'. +-- +-- For more information see +-- . +sqlQuery :: + (MonadBH m, WithBackend OpenSearch3 m) => + SQLRequest -> + m (ParsedEsResponse SQLResult) +sqlQuery = performBHRequest . Requests.sqlQuery + +-- | 'sqlQueryNextPage' fetches the next page of a paginated SQL result by +-- POSTing the opaque 'SQLCursor' returned by a previous 'sqlQuery' or +-- 'sqlQueryNextPage' call. The server drops @schema@, @total@, @size@ and +-- @status@ from continuation responses, so every 'SQLResult' field except +-- 'sqlResultDatarows' is 'Maybe'. +-- +-- For more information see +-- . +sqlQueryNextPage :: + (MonadBH m, WithBackend OpenSearch3 m) => + SQLCursor -> + m (ParsedEsResponse SQLResult) +sqlQueryNextPage = performBHRequest . Requests.sqlQueryNextPage + +-- | 'closeSqlCursor' releases the server-side context held by a SQL +-- pagination cursor (@POST /_plugins/_sql/close@). Call this when you stop +-- reading before the cursor is naturally exhausted. +-- +-- For more information see +-- . +closeSqlCursor :: + (MonadBH m, WithBackend OpenSearch3 m) => + SQLCursor -> + m (ParsedEsResponse SQLCloseResult) +closeSqlCursor = performBHRequest . Requests.closeSqlCursor + +-- | 'explainSQL' translates a SQL query into the underlying query DSL without +-- executing it (@POST /_plugins/_sql/_explain@). The response shape varies by +-- query and plugin version, so it is returned as an opaque 'Value'. +-- +-- For more information see +-- . +explainSQL :: + (MonadBH m, WithBackend OpenSearch3 m) => + SQLRequest -> + m (ParsedEsResponse Value) +explainSQL = performBHRequest . Requests.explainSQL + +-- | 'pplQuery' executes a PPL (Piped Processing Language) query via the +-- OpenSearch SQL plugin's PPL endpoint (@POST /_plugins/_ppl@). Returns the +-- same JDBC-style rowset shape as 'sqlQuery' (typed as 'PPLResult'). PPL +-- does not support cursor pagination. +-- +-- For more information see +-- . +pplQuery :: + (MonadBH m, WithBackend OpenSearch3 m) => + PPLRequest -> + m (ParsedEsResponse PPLResult) +pplQuery = performBHRequest . Requests.pplQuery + +-- | 'explainPPL' translates a PPL query into the underlying query DSL without +-- executing it (@POST /_plugins/_ppl/_explain@). The response shape varies by +-- query and plugin version, so it is returned as an opaque 'Value'. +-- +-- For more information see +-- . +explainPPL :: + (MonadBH m, WithBackend OpenSearch3 m) => + PPLRequest -> + m (ParsedEsResponse Value) +explainPPL = performBHRequest . Requests.explainPPL + +-- | 'getSQLStats' fetches SQL plugin statistics +-- (@GET /_plugins/_sql/stats@). The endpoint is node-level only (the +-- plugin documents that cluster-level stats are not implemented), so the +-- response describes only the node you hit; there is no @nodes@ sub-key +-- to navigate. The body is decoded as a flat 'SQLPluginStats' map keyed +-- by metric name because the metric-name set grows across OpenSearch +-- releases. +-- +-- For more information see +-- . +getSQLStats :: + (MonadBH m, WithBackend OpenSearch3 m) => + m (ParsedEsResponse SQLPluginStats) +getSQLStats = performBHRequest Requests.getSQLStats + +-- ========================================================================= +-- Notifications plugin +-- ========================================================================= + +-- | 'createNotificationConfig' creates a notification channel +-- configuration via the Notifications plugin +-- (@POST /_plugins/_notifications/configs@). The server assigns the +-- @config_id@ and echoes it in the 'CreateNotificationConfigResponse'. +-- Equivalent to 'createNotificationConfigWith' with 'Nothing'. +-- +-- For more information see +-- . +createNotificationConfig :: + (MonadBH m, WithBackend OpenSearch3 m) => + NotificationConfig -> + m (ParsedEsResponse CreateNotificationConfigResponse) +createNotificationConfig = performBHRequest . Requests.createNotificationConfig + +-- | 'createNotificationConfigWith' is the parameterized variant of +-- 'createNotificationConfig': the optional 'Text' is forwarded as the +-- request's @config_id@. Pass 'Nothing' for a server-assigned id; pass +-- @'Just' id@ for a stable identifier (a duplicate surfaces as HTTP +-- 409, decoded as an 'EsError' via 'StatusDependant'). +-- See . +createNotificationConfigWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe Text -> + NotificationConfig -> + m (ParsedEsResponse CreateNotificationConfigResponse) +createNotificationConfigWith mConfigId config = + performBHRequest $ Requests.createNotificationConfigWith mConfigId config + +-- | 'deleteNotificationConfig' removes a notification channel +-- configuration by @config_id@ via the Notifications plugin +-- (@DELETE /_plugins/_notifications/configs/{config_id}@). The result +-- is a 'DeleteNotificationConfigResponse' mapping the id to its +-- per-id deletion status; use 'deleteResponseAllOK' for a quick +-- success check or 'deleteResponseStatus' for the raw status string. +-- A 404 (unknown @config_id@) surfaces as 'Left' 'EsError'. +-- +-- For more information see +-- . +deleteNotificationConfig :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + m (ParsedEsResponse DeleteNotificationConfigResponse) +deleteNotificationConfig = + performBHRequest . Requests.deleteNotificationConfig + +-- | 'getNotificationConfigs' lists every notification channel +-- configuration (@GET /_plugins/_notifications/configs@), returning +-- each as a 'NotificationConfigEntry'. Equivalent to +-- 'getNotificationConfigsWith' with 'defaultNotificationListOptions'. +-- +-- For more information see +-- . +getNotificationConfigs :: + (MonadBH m, WithBackend OpenSearch3 m) => + m (ParsedEsResponse [NotificationConfigEntry]) +getNotificationConfigs = performBHRequest Requests.getNotificationConfigs + +-- | 'getNotificationConfigsWith' is the parameterized variant of +-- 'getNotificationConfigs': the supplied 'NotificationListOptions' are +-- forwarded as query-string parameters. Pass +-- 'defaultNotificationListOptions' for the plain no-arg GET. +-- +-- For more information see +-- . +getNotificationConfigsWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + NotificationListOptions -> + m (ParsedEsResponse [NotificationConfigEntry]) +getNotificationConfigsWith opts = + performBHRequest $ Requests.getNotificationConfigsWith opts + +-- | 'getNotificationChannels' lists every notification channel +-- (@GET /_plugins/_notifications/channels@) as a lightweight 'Channel' +-- summary view (no transport details). Equivalent to +-- 'getNotificationChannelsWith' with 'defaultNotificationListOptions'. +-- +-- For more information see +-- . +getNotificationChannels :: + (MonadBH m, WithBackend OpenSearch3 m) => + m (ParsedEsResponse [Channel]) +getNotificationChannels = performBHRequest Requests.getNotificationChannels + +-- | 'getNotificationChannelsWith' is the parameterized variant of +-- 'getNotificationChannels': the supplied 'NotificationListOptions' are +-- forwarded as query-string parameters. Pass +-- 'defaultNotificationListOptions' for the plain no-arg GET. +-- +-- For more information see +-- . +getNotificationChannelsWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + NotificationListOptions -> + m (ParsedEsResponse [Channel]) +getNotificationChannelsWith opts = + performBHRequest $ Requests.getNotificationChannelsWith opts + +-- | 'getNotificationConfig' fetches a single notification channel +-- configuration by id. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getNotificationConfig'. +getNotificationConfig :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + m (ParsedEsResponse (Maybe NotificationConfigEntry)) +getNotificationConfig = performBHRequest . Requests.getNotificationConfig + +-- | 'updateNotificationConfig' replaces a notification channel +-- configuration by id. See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateNotificationConfig'. +updateNotificationConfig :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + NotificationConfig -> + m (ParsedEsResponse CreateNotificationConfigResponse) +updateNotificationConfig configId config = + performBHRequest $ Requests.updateNotificationConfig configId config + +-- | 'deleteNotificationConfigs' is the batch variant of +-- 'deleteNotificationConfig'. See +-- 'Database.Bloodhound.OpenSearch3.Requests.deleteNotificationConfigs'. +deleteNotificationConfigs :: + (MonadBH m, WithBackend OpenSearch3 m) => + NonEmpty Text -> + m (ParsedEsResponse DeleteNotificationConfigResponse) +deleteNotificationConfigs = + performBHRequest . Requests.deleteNotificationConfigs + +-- | 'getNotificationFeatures' lists supported channel configuration +-- types. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getNotificationFeatures'. +getNotificationFeatures :: + (MonadBH m, WithBackend OpenSearch3 m) => + m (ParsedEsResponse NotificationFeaturesResponse) +getNotificationFeatures = performBHRequest Requests.getNotificationFeatures + +-- | 'sendTestNotification' triggers a one-shot probe delivery to a +-- channel. See +-- 'Database.Bloodhound.OpenSearch3.Requests.sendTestNotification'. +sendTestNotification :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + m (ParsedEsResponse TestNotificationResponse) +sendTestNotification = + performBHRequest . Requests.sendTestNotification + +-- ========================================================================= +-- Alerting plugin +-- ========================================================================= + +-- | 'createMonitor' creates an alerting monitor. See +-- 'Database.Bloodhound.OpenSearch3.Requests.createMonitor' for the +-- underlying request and the wire-shape details. +createMonitor :: + (MonadBH m, WithBackend OpenSearch3 m) => + Monitor -> + m MonitorResponse +createMonitor monitor = performBHRequest $ Requests.createMonitor monitor + +-- | 'getMonitor' fetches a monitor by id. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getMonitor'. +getMonitor :: + (MonadBH m, WithBackend OpenSearch3 m) => + MonitorId -> + m Monitor +getMonitor monitorId = performBHRequest $ Requests.getMonitor monitorId + +-- | 'updateMonitor' replaces a monitor. See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateMonitor'. +updateMonitor :: + (MonadBH m, WithBackend OpenSearch3 m) => + MonitorId -> + Monitor -> + m MonitorResponse +updateMonitor monitorId monitor = performBHRequest $ Requests.updateMonitor monitorId monitor + +-- | 'updateMonitorWith' replaces a monitor with an optional +-- optimistic-concurrency guard (@if_seq_no@ \/ @if_primary_term@). See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateMonitorWith'. +updateMonitorWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + MonitorId -> + Monitor -> + Maybe (Word64, Word64) -> + m MonitorResponse +updateMonitorWith monitorId monitor mOcc = + performBHRequest $ Requests.updateMonitorWith monitorId monitor mOcc + +-- | 'deleteMonitor' deletes a monitor by id. Returns the bare +-- Elasticsearch delete-document response (see 'DeleteMonitorResponse' for +-- why this deviates from @m 'Acknowledged'@). +deleteMonitor :: + (MonadBH m, WithBackend OpenSearch3 m) => + MonitorId -> + m DeleteMonitorResponse +deleteMonitor monitorId = performBHRequest $ Requests.deleteMonitor monitorId + +-- | 'searchMonitors' searches the monitor store. See +-- 'Database.Bloodhound.OpenSearch3.Requests.searchMonitors'. +searchMonitors :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe MonitorsSearchQuery -> + m (ParsedEsResponse SearchMonitorsResponse) +searchMonitors = performBHRequest . Requests.searchMonitors + +-- | 'executeMonitor' runs a monitor immediately (out of schedule). See +-- 'Database.Bloodhound.OpenSearch3.Requests.executeMonitor'. +executeMonitor :: + (MonadBH m, WithBackend OpenSearch3 m) => + MonitorId -> + Maybe ExecuteMonitorRequest -> + m (ParsedEsResponse ExecuteMonitorResponse) +executeMonitor monitorId mRequest = + performBHRequest $ Requests.executeMonitor monitorId mRequest + +-- ========================================================================= +-- Security Analytics plugin +-- ========================================================================= + +-- | 'createSADetector' creates a Security Analytics detector. See +-- 'Database.Bloodhound.OpenSearch3.Requests.createSADetector' for the +-- underlying request and the wire-shape details. +createSADetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + SADetector -> + m SADetectorResponse +createSADetector detector = performBHRequest $ Requests.createSADetector detector + +-- | 'getSADetector' fetches a detector by id. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getSADetector'. +getSADetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + m SADetector +getSADetector detectorId = performBHRequest $ Requests.getSADetector detectorId + +-- | 'updateSADetector' replaces a detector. See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateSADetector'. +updateSADetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + SADetector -> + m SADetectorResponse +updateSADetector detectorId detector = performBHRequest $ Requests.updateSADetector detectorId detector + +-- | 'deleteSADetector' deletes a detector by id. See +-- 'Database.Bloodhound.OpenSearch3.Requests.deleteSADetector'. +deleteSADetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + m DeleteSADetectorResponse +deleteSADetector detectorId = performBHRequest $ Requests.deleteSADetector detectorId + +-- | 'searchSAPrePackagedRules' searches the pre-packaged Sigma rules +-- index. See +-- 'Database.Bloodhound.OpenSearch3.Requests.searchSAPrePackagedRules' +-- for the underlying request and the bead-acceptance deviation note. +searchSAPrePackagedRules :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe SARulesQuery -> + m (ParsedEsResponse SARulesSearchResponse) +searchSAPrePackagedRules = performBHRequest . Requests.searchSAPrePackagedRules + +-- | 'searchSACustomRules' searches the custom Sigma rules index. See +-- 'Database.Bloodhound.OpenSearch3.Requests.searchSACustomRules'. +searchSACustomRules :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe SARulesQuery -> + m (ParsedEsResponse SARulesSearchResponse) +searchSACustomRules = performBHRequest . Requests.searchSACustomRules + +-- | 'createSACustomRule' creates a custom Sigma rule. See +-- 'Database.Bloodhound.OpenSearch3.Requests.createSACustomRule' for the +-- underlying request and the raw-YAML-body detail. +createSACustomRule :: + (MonadBH m, WithBackend OpenSearch3 m) => + SADetectorType -> + Text -> + m SARuleResponse +createSACustomRule category sigmaYaml = + performBHRequest $ Requests.createSACustomRule category sigmaYaml + +-- | 'updateSACustomRule' replaces a custom Sigma rule. See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateSACustomRule'. +updateSACustomRule :: + (MonadBH m, WithBackend OpenSearch3 m) => + RuleId -> + SADetectorType -> + Bool -> + Text -> + m SARuleResponse +updateSACustomRule ruleId category forced sigmaYaml = + performBHRequest $ Requests.updateSACustomRule ruleId category forced sigmaYaml + +-- | 'deleteSACustomRule' deletes a custom Sigma rule. See +-- 'Database.Bloodhound.OpenSearch3.Requests.deleteSACustomRule'. +deleteSACustomRule :: + (MonadBH m, WithBackend OpenSearch3 m) => + RuleId -> + Bool -> + m DeleteSARuleResponse +deleteSACustomRule ruleId forced = + performBHRequest $ Requests.deleteSACustomRule ruleId forced + +-- | 'searchSADetectors' searches the detector store. See +-- 'Database.Bloodhound.OpenSearch3.Requests.searchSADetectors'. +searchSADetectors :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe SADetectorsSearchQuery -> + m (ParsedEsResponse SADetectorsSearchResponse) +searchSADetectors = performBHRequest . Requests.searchSADetectors + +-- | 'getSAMappingsView' returns a mappings view for an index. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getSAMappingsView'. +getSAMappingsView :: + (MonadBH m, WithBackend OpenSearch3 m) => + SAMappingsViewRequest -> + m SAMappingsViewResponse +getSAMappingsView = performBHRequest . Requests.getSAMappingsView + +-- | 'createSAMappings' creates the field-to-alias mappings for an +-- index. See +-- 'Database.Bloodhound.OpenSearch3.Requests.createSAMappings'. +createSAMappings :: + (MonadBH m, WithBackend OpenSearch3 m) => + SACreateMappingsRequest -> + m Acknowledged +createSAMappings = performBHRequest . Requests.createSAMappings + +-- | 'getSAMappings' fetches the persisted mappings for an index. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getSAMappings'. +getSAMappings :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + m SAGetMappingsResponse +getSAMappings = performBHRequest . Requests.getSAMappings + +-- | 'updateSAMappings' updates a single field mapping for an index. +-- See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateSAMappings'. +updateSAMappings :: + (MonadBH m, WithBackend OpenSearch3 m) => + SAUpdateMappingsRequest -> + m Acknowledged +updateSAMappings = performBHRequest . Requests.updateSAMappings + +-- | 'getSAAlertsWith' lists Security Analytics alert documents with the +-- supplied options. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getSAAlertsWith'. +getSAAlertsWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + SAGetAlertsOptions -> + m SAGetAlertsResponse +getSAAlertsWith = performBHRequest . Requests.getSAAlertsWith + +-- | 'getSAAlerts' lists the alert documents of a single detector. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getSAAlerts'. +getSAAlerts :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + m [SAAlert] +getSAAlerts = performBHRequest . Requests.getSAAlerts + +-- | 'acknowledgeSADetectorAlerts' acknowledges one or more active +-- alerts of a detector. See +-- 'Database.Bloodhound.OpenSearch3.Requests.acknowledgeSADetectorAlerts'. +acknowledgeSADetectorAlerts :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + [Text] -> + m AcknowledgeSADetectorAlertsResponse +acknowledgeSADetectorAlerts = (performBHRequest .) . Requests.acknowledgeSADetectorAlerts + +-- | 'searchSAFindings' lists Security Analytics finding documents. See +-- 'Database.Bloodhound.OpenSearch3.Requests.searchSAFindings'. +searchSAFindings :: + (MonadBH m, WithBackend OpenSearch3 m) => + SASearchFindingsOptions -> + m (ParsedEsResponse SASearchFindingsResponse) +searchSAFindings = performBHRequest . Requests.searchSAFindings + +-- | 'createSACorrelationRule' creates a correlation rule. See +-- 'Database.Bloodhound.OpenSearch3.Requests.createSACorrelationRule'. +createSACorrelationRule :: + (MonadBH m, WithBackend OpenSearch3 m) => + CreateSACorrelationRuleRequest -> + m CreateSACorrelationRuleResponse +createSACorrelationRule = performBHRequest . Requests.createSACorrelationRule + +-- | 'getSACorrelations' lists pairwise finding correlations within a +-- time window. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getSACorrelations'. +getSACorrelations :: + (MonadBH m, WithBackend OpenSearch3 m) => + GetSACorrelationsOptions -> + m GetSACorrelationsResponse +getSACorrelations = performBHRequest . Requests.getSACorrelations + +-- | 'findSACorrelation' lists correlated findings for a given finding. +-- See +-- 'Database.Bloodhound.OpenSearch3.Requests.findSACorrelation'. +findSACorrelation :: + (MonadBH m, WithBackend OpenSearch3 m) => + FindSACorrelationOptions -> + m FindSACorrelationResponse +findSACorrelation = performBHRequest . Requests.findSACorrelation + +-- | 'searchSACorrelationAlerts' lists correlation alerts. See +-- 'Database.Bloodhound.OpenSearch3.Requests.searchSACorrelationAlerts'. +searchSACorrelationAlerts :: + (MonadBH m, WithBackend OpenSearch3 m) => + SearchSACorrelationAlertsOptions -> + m SearchSACorrelationAlertsResponse +searchSACorrelationAlerts = performBHRequest . Requests.searchSACorrelationAlerts + +-- | 'acknowledgeSACorrelationAlerts' acknowledges one or more +-- correlation alerts. See +-- 'Database.Bloodhound.OpenSearch3.Requests.acknowledgeSACorrelationAlerts'. +acknowledgeSACorrelationAlerts :: + (MonadBH m, WithBackend OpenSearch3 m) => + [Text] -> + m AcknowledgeSACorrelationAlertsResponse +acknowledgeSACorrelationAlerts = performBHRequest . Requests.acknowledgeSACorrelationAlerts + +-- | 'createSALogType' creates a custom log type. See +-- 'Database.Bloodhound.OpenSearch3.Requests.createSALogType'. +createSALogType :: + (MonadBH m, WithBackend OpenSearch3 m) => + SALogType -> + m SALogTypeResponse +createSALogType = performBHRequest . Requests.createSALogType + +-- | 'searchSALogTypes' searches the log type store. See +-- 'Database.Bloodhound.OpenSearch3.Requests.searchSALogTypes'. +searchSALogTypes :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe SALogTypeSearchQuery -> + m (ParsedEsResponse SALogTypesSearchResponse) +searchSALogTypes = performBHRequest . Requests.searchSALogTypes + +-- | 'updateSALogType' replaces a custom log type. See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateSALogType'. +updateSALogType :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + SALogType -> + m SALogTypeResponse +updateSALogType = (performBHRequest .) . Requests.updateSALogType + +-- | 'deleteSALogType' deletes a custom log type. See +-- 'Database.Bloodhound.OpenSearch3.Requests.deleteSALogType'. +deleteSALogType :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + m DeleteSALogTypeResponse +deleteSALogType = performBHRequest . Requests.deleteSALogType + +-- | 'getDestinations' lists every configured alerting destination. +-- Returns the bare 'Destination' list (the paging envelope is +-- discarded). See +-- 'Database.Bloodhound.OpenSearch3.Requests.getDestinations' for the +-- underlying request and the wire-shape details. +getDestinations :: + (MonadBH m, WithBackend OpenSearch3 m) => + m [Destination] +getDestinations = performBHRequest Requests.getDestinations + +-- | 'getDestinationsWith' is the parameterized variant of +-- 'getDestinations'. Returns the full 'GetDestinationsResponse' +-- envelope (including @totalDestinations@). See +-- 'Database.Bloodhound.OpenSearch3.Requests.getDestinationsWith'. +getDestinationsWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + DestinationListOptions -> + m GetDestinationsResponse +getDestinationsWith opts = + performBHRequest $ Requests.getDestinationsWith opts + +-- | 'createDestination' creates an alerting destination. See +-- 'Database.Bloodhound.OpenSearch3.Requests.createDestination' for the +-- underlying request and the wire-shape details. +createDestination :: + (MonadBH m, WithBackend OpenSearch3 m) => + Destination -> + m DestinationResponse +createDestination destination = + performBHRequest $ Requests.createDestination destination + +-- | 'updateDestination' replaces a destination. See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateDestination'. +updateDestination :: + (MonadBH m, WithBackend OpenSearch3 m) => + DestinationId -> + Destination -> + m DestinationResponse +updateDestination destId destination = + performBHRequest $ Requests.updateDestination destId destination + +-- | 'deleteDestination' deletes a destination by id. Returns the bare +-- Elasticsearch delete-document response (see 'DeleteDestinationResponse' +-- for why this deviates from @m 'Acknowledged'@). +deleteDestination :: + (MonadBH m, WithBackend OpenSearch3 m) => + DestinationId -> + m DeleteDestinationResponse +deleteDestination destId = + performBHRequest $ Requests.deleteDestination destId + +-- | 'getAlertsWith' lists alert documents, returning the full +-- 'GetAlertsResponse' envelope (including @totalAlerts@). See +-- 'Database.Bloodhound.OpenSearch3.Requests.getAlertsWith'. +getAlertsWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + GetAlertsOptions -> + m GetAlertsResponse +getAlertsWith opts = performBHRequest $ Requests.getAlertsWith opts + +-- | 'getAlerts' lists every active alert, projecting out the bare +-- @['Alert']@ list. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getAlerts'. +getAlerts :: + (MonadBH m, WithBackend OpenSearch3 m) => + m [Alert] +getAlerts = performBHRequest Requests.getAlerts + +-- | 'acknowledgeAlert' acknowledges one or more active alerts of a +-- monitor. See +-- 'Database.Bloodhound.OpenSearch3.Requests.acknowledgeAlert'. +acknowledgeAlert :: + (MonadBH m, WithBackend OpenSearch3 m) => + MonitorId -> + [Text] -> + m AcknowledgeAlertResponse +acknowledgeAlert monitorId alertIds = + performBHRequest $ Requests.acknowledgeAlert monitorId alertIds + +-- | 'getMonitorStats' fetches alerting scheduler statistics. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getMonitorStats'. +getMonitorStats :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe Text -> + Maybe Text -> + m (ParsedEsResponse MonitorStats) +getMonitorStats mNodeId mMetric = + performBHRequest $ Requests.getMonitorStats mNodeId mMetric + +-- | 'createEmailAccount' creates a legacy alerting email account. See +-- 'Database.Bloodhound.OpenSearch3.Requests.createEmailAccount'. +createEmailAccount :: + (MonadBH m, WithBackend OpenSearch3 m) => + EmailAccount -> + m EmailAccountResponse +createEmailAccount account = + performBHRequest $ Requests.createEmailAccount account + +-- | 'getEmailAccount' fetches an email account by id. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getEmailAccount'. +getEmailAccount :: + (MonadBH m, WithBackend OpenSearch3 m) => + EmailAccountId -> + m EmailAccount +getEmailAccount emailAccountId = + performBHRequest $ Requests.getEmailAccount emailAccountId + +-- | 'updateEmailAccount' replaces an email account. See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateEmailAccount'. +updateEmailAccount :: + (MonadBH m, WithBackend OpenSearch3 m) => + EmailAccountId -> + EmailAccount -> + m EmailAccountResponse +updateEmailAccount emailAccountId account = + performBHRequest $ Requests.updateEmailAccount emailAccountId account + +-- | 'updateEmailAccountWith' replaces an email account with an optional +-- optimistic-concurrency guard. See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateEmailAccountWith'. +updateEmailAccountWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + EmailAccountId -> + EmailAccount -> + Maybe (Word64, Word64) -> + m EmailAccountResponse +updateEmailAccountWith emailAccountId account mOcc = + performBHRequest $ Requests.updateEmailAccountWith emailAccountId account mOcc + +-- | 'deleteEmailAccount' deletes an email account by id. Returns the +-- bare Elasticsearch delete-document response (see +-- 'DeleteEmailAccountResponse'). +deleteEmailAccount :: + (MonadBH m, WithBackend OpenSearch3 m) => + EmailAccountId -> + m DeleteEmailAccountResponse +deleteEmailAccount emailAccountId = + performBHRequest $ Requests.deleteEmailAccount emailAccountId + +-- | 'createEmailGroup' creates a legacy alerting email group. See +-- 'Database.Bloodhound.OpenSearch3.Requests.createEmailGroup'. +createEmailGroup :: + (MonadBH m, WithBackend OpenSearch3 m) => + EmailGroup -> + m EmailGroupResponse +createEmailGroup group = + performBHRequest $ Requests.createEmailGroup group + +-- | 'getEmailGroup' fetches an email group by id. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getEmailGroup'. +getEmailGroup :: + (MonadBH m, WithBackend OpenSearch3 m) => + EmailGroupId -> + m EmailGroup +getEmailGroup emailGroupId = + performBHRequest $ Requests.getEmailGroup emailGroupId + +-- | 'updateEmailGroup' replaces an email group. See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateEmailGroup'. +updateEmailGroup :: + (MonadBH m, WithBackend OpenSearch3 m) => + EmailGroupId -> + EmailGroup -> + m EmailGroupResponse +updateEmailGroup emailGroupId group = + performBHRequest $ Requests.updateEmailGroup emailGroupId group + +-- | 'updateEmailGroupWith' replaces an email group with an optional +-- optimistic-concurrency guard. See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateEmailGroupWith'. +updateEmailGroupWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + EmailGroupId -> + EmailGroup -> + Maybe (Word64, Word64) -> + m EmailGroupResponse +updateEmailGroupWith emailGroupId group mOcc = + performBHRequest $ Requests.updateEmailGroupWith emailGroupId group mOcc + +-- | 'deleteEmailGroup' deletes an email group by id. Returns the bare +-- Elasticsearch delete-document response (see 'DeleteEmailGroupResponse'). +deleteEmailGroup :: + (MonadBH m, WithBackend OpenSearch3 m) => + EmailGroupId -> + m DeleteEmailGroupResponse +deleteEmailGroup emailGroupId = + performBHRequest $ Requests.deleteEmailGroup emailGroupId + +-- | 'getDestination' fetches a single destination by id. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getDestination'. +getDestination :: + (MonadBH m, WithBackend OpenSearch3 m) => + DestinationId -> + m GetDestinationsResponse +getDestination destId = + performBHRequest $ Requests.getDestination destId + +-- | 'searchEmailAccounts' searches the email account store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchEmailAccounts'. +searchEmailAccounts :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe EmailAccountSearchQuery -> + m (ParsedEsResponse SearchEmailAccountsResponse) +searchEmailAccounts mQuery = + performBHRequest $ Requests.searchEmailAccounts mQuery + +-- | 'searchEmailGroups' searches the email group store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchEmailGroups'. +searchEmailGroups :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe EmailGroupSearchQuery -> + m (ParsedEsResponse SearchEmailGroupsResponse) +searchEmailGroups mQuery = + performBHRequest $ Requests.searchEmailGroups mQuery + +-- | 'searchFindings' searches the findings index. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchFindings'. +searchFindings :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe FindingsSearchOptions -> + m (ParsedEsResponse SearchFindingsResponse) +searchFindings mOpts = + performBHRequest $ Requests.searchFindings mOpts + +-- | 'createComment' adds a comment to an alert. See +-- 'Database.Bloodhound.OpenSearch2.Requests.createComment'. +createComment :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + CreateCommentRequest -> + m CommentResponse +createComment alertId req = + performBHRequest $ Requests.createComment alertId req + +-- | 'updateComment' modifies a comment. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateComment'. +updateComment :: + (MonadBH m, WithBackend OpenSearch3 m) => + CommentId -> + UpdateCommentRequest -> + m CommentResponse +updateComment commentId req = + performBHRequest $ Requests.updateComment commentId req + +-- | 'searchComments' searches comments. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchComments'. +searchComments :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe CommentSearchQuery -> + m (ParsedEsResponse SearchCommentsResponse) +searchComments mQuery = + performBHRequest $ Requests.searchComments mQuery + +-- | 'deleteComment' removes a comment. See +-- 'Database.Bloodhound.OpenSearch2.Requests.deleteComment'. +deleteComment :: + (MonadBH m, WithBackend OpenSearch3 m) => + CommentId -> + m DeleteCommentResponse +deleteComment commentId = + performBHRequest $ Requests.deleteComment commentId + +-- ========================================================================= +-- Anomaly Detection plugin +-- ========================================================================= + +-- | 'createDetector' creates an anomaly detector. See +-- 'Requests.createDetector' for semantics. +-- See +createDetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + Detector -> + m (ParsedEsResponse CreateDetectorResponse) +createDetector = performBHRequest . Requests.createDetector + +-- | 'getDetector' fetches a detector by id. See 'Requests.getDetector' for +-- semantics. +-- See +getDetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + GetDetectorParams -> + m (ParsedEsResponse GetDetectorResponse) +getDetector detectorId params = + performBHRequest $ Requests.getDetector detectorId params + +-- | 'previewDetector' previews a detector on historical data. See +-- 'Requests.previewDetector' for semantics. +-- See +previewDetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + PreviewRequest -> + m (ParsedEsResponse PreviewResponse) +previewDetector detectorId req = + performBHRequest $ Requests.previewDetector detectorId req + +-- | 'previewDetectorInline' previews an unpersisted or body-referenced +-- detector. See 'Requests.previewDetectorInline' for semantics. +-- See +previewDetectorInline :: + (MonadBH m, WithBackend OpenSearch3 m) => + PreviewRequest -> + m (ParsedEsResponse PreviewResponse) +previewDetectorInline req = + performBHRequest $ Requests.previewDetectorInline req + +-- | 'startDetector' starts a detector job. See +-- 'Requests.startDetector' for semantics. +-- See +startDetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + Maybe StartDetectorJobRequest -> + m (ParsedEsResponse DetectorJobAcknowledgment) +startDetector detectorId mReq = + performBHRequest $ Requests.startDetector detectorId mReq + +-- | 'stopDetector' stops a detector job. See 'Requests.stopDetector' +-- for semantics. +-- See +stopDetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + Bool -> + m (ParsedEsResponse DetectorJobAcknowledgment) +stopDetector detectorId historical = + performBHRequest $ Requests.stopDetector detectorId historical + +-- | 'updateDetector' replaces a detector. See +-- 'Requests.updateDetector' for semantics. +-- See +updateDetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + Detector -> + m (ParsedEsResponse CreateDetectorResponse) +updateDetector detectorId detector = + performBHRequest $ Requests.updateDetector detectorId detector + +-- | 'updateDetectorWith' replaces a detector with an optional +-- optimistic-concurrency guard. See 'Requests.updateDetectorWith'. +-- See +updateDetectorWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + Detector -> + Maybe (Word64, Word64) -> + m (ParsedEsResponse CreateDetectorResponse) +updateDetectorWith detectorId detector mOcc = + performBHRequest $ Requests.updateDetectorWith detectorId detector mOcc + +-- | 'deleteDetector' deletes a detector by id. See 'Requests.deleteDetector'. +-- See +deleteDetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + m (ParsedEsResponse DeleteDetectorResponse) +deleteDetector detectorId = + performBHRequest $ Requests.deleteDetector detectorId + +-- | 'validateDetector' validates a detector configuration. See +-- 'Requests.validateDetector'. +-- See +validateDetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + ValidateDetectorMode -> + Detector -> + m (ParsedEsResponse ValidateDetectorResponse) +validateDetector mode detector = + performBHRequest $ Requests.validateDetector mode detector + +-- | 'searchDetectors' searches the detector-config index. See +-- 'Requests.searchDetectors'. +-- See +searchDetectors :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe Value -> + m (ParsedEsResponse SearchDetectorsResponse) +searchDetectors mQuery = + performBHRequest $ Requests.searchDetectors mQuery + +-- | 'profileDetector' profiles a detector. See 'Requests.profileDetector'. +-- See +profileDetector :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + [Text] -> + Bool -> + Maybe [Entity] -> + m (ParsedEsResponse DetectorProfileResponse) +profileDetector detectorId types allFlag mEntities = + performBHRequest $ Requests.profileDetector detectorId types allFlag mEntities + +-- | 'getDetectorStats' fetches plugin statistics. See +-- 'Requests.getDetectorStats'. +-- See +getDetectorStats :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe Text -> + Maybe Text -> + m (ParsedEsResponse DetectorStatsResponse) +getDetectorStats mNodeId mStat = + performBHRequest $ Requests.getDetectorStats mNodeId mStat + +-- | 'searchDetectorResults' searches the anomaly-result index. See +-- 'Requests.searchDetectorResults'. +-- See +searchDetectorResults :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe Text -> + Maybe Bool -> + Maybe Value -> + m (ParsedEsResponse SearchDetectorResultsResponse) +searchDetectorResults mCustomResultIndex mOnlyCustom mQuery = + performBHRequest $ Requests.searchDetectorResults mCustomResultIndex mOnlyCustom mQuery + +-- | 'deleteDetectorResults' deletes anomaly-result documents by query. +-- See 'Requests.deleteDetectorResults'. +-- See +deleteDetectorResults :: + (MonadBH m, WithBackend OpenSearch3 m) => + Value -> + m (ParsedEsResponse DeleteDetectorResultsResponse) +deleteDetectorResults query = + performBHRequest $ Requests.deleteDetectorResults query + +-- | 'searchDetectorTasks' searches the detection-state index. See +-- 'Requests.searchDetectorTasks'. +-- See +searchDetectorTasks :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe Value -> + m (ParsedEsResponse SearchDetectorTasksResponse) +searchDetectorTasks mQuery = + performBHRequest $ Requests.searchDetectorTasks mQuery + +-- | 'topAnomalies' returns the top anomaly results for a +-- high-cardinality detector. See 'Requests.topAnomalies'. +-- See +topAnomalies :: + (MonadBH m, WithBackend OpenSearch3 m) => + DetectorId -> + Bool -> + TopAnomaliesRequest -> + m (ParsedEsResponse TopAnomaliesResponse) +topAnomalies detectorId historical req = + performBHRequest $ Requests.topAnomalies detectorId historical req + +-- ========================================================================= +-- Flow Framework plugin +-- ========================================================================= + +-- | 'createWorkflow' persists a 'WorkflowTemplate'. See +-- 'Requests.createWorkflow' for semantics. +-- See . +createWorkflow :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowTemplate -> + m (ParsedEsResponse CreateWorkflowResponse) +createWorkflow = performBHRequest . Requests.createWorkflow + +-- | 'createWorkflowWith' is the parameterized variant of 'createWorkflow'. +-- See 'Requests.createWorkflowWith'. +createWorkflowWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + CreateWorkflowOptions -> + WorkflowTemplate -> + m (ParsedEsResponse CreateWorkflowResponse) +createWorkflowWith opts = performBHRequest . Requests.createWorkflowWith opts + +-- | 'getWorkflow' fetches a stored 'WorkflowTemplate' by id. See +-- 'Requests.getWorkflow'. +getWorkflow :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowId -> + m (ParsedEsResponse WorkflowTemplate) +getWorkflow = performBHRequest . Requests.getWorkflow + +-- | 'provisionWorkflow' provisions a workflow. See +-- 'Requests.provisionWorkflow'. +provisionWorkflow :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowId -> + m (ParsedEsResponse CreateWorkflowResponse) +provisionWorkflow = performBHRequest . Requests.provisionWorkflow + +-- | 'provisionWorkflowWith' is the parameterized variant of +-- 'provisionWorkflow'. See 'Requests.provisionWorkflowWith'. +provisionWorkflowWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowId -> + ProvisionOptions -> + m (ParsedEsResponse CreateWorkflowResponse) +provisionWorkflowWith workflowId opts = + performBHRequest $ Requests.provisionWorkflowWith workflowId opts + +-- | 'deleteWorkflow' removes a stored template. See +-- 'Requests.deleteWorkflow'. +deleteWorkflow :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowId -> + m (ParsedEsResponse IndexedDocument) +deleteWorkflow = performBHRequest . Requests.deleteWorkflow + +-- | 'deleteWorkflowWith' is the parameterized variant of +-- 'deleteWorkflow'. See 'Requests.deleteWorkflowWith'. +deleteWorkflowWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowId -> + DeleteWorkflowOptions -> + m (ParsedEsResponse IndexedDocument) +deleteWorkflowWith workflowId opts = + performBHRequest $ Requests.deleteWorkflowWith workflowId opts + +-- | 'searchWorkflows' searches the stored 'WorkflowTemplate' documents. +-- See 'Requests.searchWorkflows'. +searchWorkflows :: + forall a m. + (MonadBH m, WithBackend OpenSearch3 m, FromJSON a) => + Search -> + m (ParsedEsResponse (SearchResult a)) +searchWorkflows = performBHRequest . Requests.searchWorkflows + +-- | 'updateWorkflow' replaces a stored template (PUT). See +-- 'Requests.updateWorkflow'. +updateWorkflow :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowId -> + WorkflowTemplate -> + m (ParsedEsResponse CreateWorkflowResponse) +updateWorkflow workflowId tmpl = + performBHRequest $ Requests.updateWorkflow workflowId tmpl + +-- | 'updateWorkflowWith' is the parameterized variant of +-- 'updateWorkflow'. See 'Requests.updateWorkflowWith'. +updateWorkflowWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowId -> + CreateWorkflowOptions -> + WorkflowTemplate -> + m (ParsedEsResponse CreateWorkflowResponse) +updateWorkflowWith workflowId opts tmpl = + performBHRequest $ Requests.updateWorkflowWith workflowId opts tmpl + +-- | 'deprovisionWorkflow' tears down a workflow's resources. See +-- 'Requests.deprovisionWorkflow'. +deprovisionWorkflow :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowId -> + m (ParsedEsResponse DeprovisionWorkflowResponse) +deprovisionWorkflow = performBHRequest . Requests.deprovisionWorkflow + +-- | 'deprovisionWorkflowWith' is the parameterized variant of +-- 'deprovisionWorkflow'. See 'Requests.deprovisionWorkflowWith'. +deprovisionWorkflowWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowId -> + DeprovisionWorkflowOptions -> + m (ParsedEsResponse DeprovisionWorkflowResponse) +deprovisionWorkflowWith workflowId opts = + performBHRequest $ Requests.deprovisionWorkflowWith workflowId opts + +-- | 'getWorkflowState' fetches a workflow's provisioning state. See +-- 'Requests.getWorkflowState'. +getWorkflowState :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowId -> + m (ParsedEsResponse WorkflowStateResponse) +getWorkflowState = performBHRequest . Requests.getWorkflowState + +-- | 'getWorkflowStateWith' is the parameterized variant of +-- 'getWorkflowState'. See 'Requests.getWorkflowStateWith'. +getWorkflowStateWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowId -> + WorkflowStateOptions -> + m (ParsedEsResponse WorkflowStateResponse) +getWorkflowStateWith workflowId opts = + performBHRequest $ Requests.getWorkflowStateWith workflowId opts + +-- | 'getWorkflowSteps' lists the registered workflow step types. See +-- 'Requests.getWorkflowSteps'. +getWorkflowSteps :: + (MonadBH m, WithBackend OpenSearch3 m) => + m (ParsedEsResponse WorkflowStepsResponse) +getWorkflowSteps = performBHRequest Requests.getWorkflowSteps + +-- | 'getWorkflowStepsWith' is the parameterized variant of +-- 'getWorkflowSteps'. See 'Requests.getWorkflowStepsWith'. +getWorkflowStepsWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + WorkflowStepsOptions -> + m (ParsedEsResponse WorkflowStepsResponse) +getWorkflowStepsWith opts = + performBHRequest $ Requests.getWorkflowStepsWith opts + +-- | 'searchWorkflowState' searches the stored workflow-state documents. +-- See 'Requests.searchWorkflowState'. +searchWorkflowState :: + forall a m. + (MonadBH m, WithBackend OpenSearch3 m, FromJSON a) => + Search -> + m (ParsedEsResponse (SearchResult a)) +searchWorkflowState = performBHRequest . Requests.searchWorkflowState + +-- Index Rollups plugin +-- +-- ---------------------------------------------------------------------------- + +-- | 'createRollup' creates or replaces an index rollup job. See +-- 'Requests.createRollup'. +-- See +createRollup :: + (MonadBH m, WithBackend OpenSearch3 m) => + RollupId -> + Rollup -> + m (ParsedEsResponse RollupResponse) +createRollup rollupId rollup = + performBHRequest $ Requests.createRollup rollupId rollup + +-- | 'createRollupWith' creates or replaces an index rollup job with an +-- optional optimistic-concurrency guard. See 'Requests.createRollupWith'. +-- See +createRollupWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + RollupId -> + Rollup -> + Maybe (Word64, Word64) -> + m (ParsedEsResponse RollupResponse) +createRollupWith rollupId rollup mOcc = + performBHRequest $ Requests.createRollupWith rollupId rollup mOcc + +-- | 'getRollup' fetches a rollup job by id. See 'Requests.getRollup'. +-- See +getRollup :: + (MonadBH m, WithBackend OpenSearch3 m) => + RollupId -> + m (ParsedEsResponse RollupResponse) +getRollup rollupId = + performBHRequest $ Requests.getRollup rollupId + +-- | 'getAllRollups' lists every rollup job. See 'Requests.getAllRollups'. +-- See +getAllRollups :: + (MonadBH m, WithBackend OpenSearch3 m) => + m (ParsedEsResponse Value) +getAllRollups = + performBHRequest $ Requests.getAllRollups + +-- | 'deleteRollup' deletes a rollup job by id. See 'Requests.deleteRollup'. +-- See +deleteRollup :: + (MonadBH m, WithBackend OpenSearch3 m) => + RollupId -> + m (ParsedEsResponse Value) +deleteRollup rollupId = + performBHRequest $ Requests.deleteRollup rollupId + +-- | 'startRollup' starts a rollup job by id. See 'Requests.startRollup'. +-- See +startRollup :: + (MonadBH m, WithBackend OpenSearch3 m) => + RollupId -> + m (ParsedEsResponse Acknowledged) +startRollup rollupId = + performBHRequest $ Requests.startRollup rollupId + +-- | 'stopRollup' stops a rollup job by id. See 'Requests.stopRollup'. +-- See +stopRollup :: + (MonadBH m, WithBackend OpenSearch3 m) => + RollupId -> + m (ParsedEsResponse Acknowledged) +stopRollup rollupId = + performBHRequest $ Requests.stopRollup rollupId + +-- | 'explainRollup' returns execution metadata for a rollup job by id. +-- See 'Requests.explainRollup'. +-- See +explainRollup :: + (MonadBH m, WithBackend OpenSearch3 m) => + RollupId -> + m (ParsedEsResponse ExplainRollupResponse) +explainRollup rollupId = + performBHRequest $ Requests.explainRollup rollupId + +-- ========================================================================= +-- Cross-Cluster Replication (CCR) plugin +-- ========================================================================= + +-- | 'startReplication' begins replicating a leader index into a follower +-- index on the /follower/ cluster. See +-- 'Database.Bloodhound.OpenSearch3.Requests.startReplication'. +startReplication :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + StartReplicationRequest -> + m (ParsedEsResponse Acknowledged) +startReplication followerIndex req = + performBHRequest $ Requests.startReplication followerIndex req + +-- | 'stopReplication' terminates replication and converts the follower +-- index into a standard writable index. See +-- 'Database.Bloodhound.OpenSearch3.Requests.stopReplication'. +stopReplication :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + m (ParsedEsResponse Acknowledged) +stopReplication = performBHRequest . Requests.stopReplication + +-- | 'pauseReplication' pauses replication of the leader index. See +-- 'Database.Bloodhound.OpenSearch3.Requests.pauseReplication'. +pauseReplication :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + m (ParsedEsResponse Acknowledged) +pauseReplication = performBHRequest . Requests.pauseReplication + +-- | 'resumeReplication' resumes replication after a pause. See +-- 'Database.Bloodhound.OpenSearch3.Requests.resumeReplication'. +resumeReplication :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + m (ParsedEsResponse Acknowledged) +resumeReplication = performBHRequest . Requests.resumeReplication + +-- | 'updateReplicationSettings' applies index-level settings to the +-- follower index. See +-- 'Database.Bloodhound.OpenSearch3.Requests.updateReplicationSettings'. +updateReplicationSettings :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + UpdateReplicationSettingsRequest -> + m (ParsedEsResponse Acknowledged) +updateReplicationSettings followerIndex req = + performBHRequest $ Requests.updateReplicationSettings followerIndex req + +-- | 'getReplicationStatus' fetches the replication state of a follower +-- index without the @verbose@ flag. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getReplicationStatus'. +getReplicationStatus :: + (MonadBH m, WithBackend OpenSearch3 m) => + Text -> + m (ParsedEsResponse ReplicationStatusResponse) +getReplicationStatus = performBHRequest . Requests.getReplicationStatus + +-- | 'getReplicationStatusWith' is the parameterized variant of +-- 'getReplicationStatus'. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getReplicationStatusWith'. +getReplicationStatusWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + ReplicationStatusOptions -> + Text -> + m (ParsedEsResponse ReplicationStatusResponse) +getReplicationStatusWith opts followerIndex = + performBHRequest $ Requests.getReplicationStatusWith opts followerIndex + +-- | 'getLeaderStats' fetches aggregate and per-index read-side counters +-- from the /leader/ cluster. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getLeaderStats'. +getLeaderStats :: + (MonadBH m, WithBackend OpenSearch3 m) => + m (ParsedEsResponse LeaderStatsResponse) +getLeaderStats = performBHRequest Requests.getLeaderStats + +-- | 'getFollowerStats' fetches follower index state counts and write-side +-- throughput from the /follower/ cluster. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getFollowerStats'. +getFollowerStats :: + (MonadBH m, WithBackend OpenSearch3 m) => + m (ParsedEsResponse FollowerStatsResponse) +getFollowerStats = performBHRequest Requests.getFollowerStats + +-- | 'getAutoFollowStats' fetches auto-follow activity and the configured +-- replication rules. See +-- 'Database.Bloodhound.OpenSearch3.Requests.getAutoFollowStats'. +getAutoFollowStats :: + (MonadBH m, WithBackend OpenSearch3 m) => + m (ParsedEsResponse AutoFollowStatsResponse) +getAutoFollowStats = performBHRequest Requests.getAutoFollowStats + +-- | 'createAutoFollowPattern' creates or updates an auto-follow rule. +-- See +-- 'Database.Bloodhound.OpenSearch3.Requests.createAutoFollowPattern'. +createAutoFollowPattern :: + (MonadBH m, WithBackend OpenSearch3 m) => + CreateAutoFollowPatternRequest -> + m (ParsedEsResponse Acknowledged) +createAutoFollowPattern = + performBHRequest . Requests.createAutoFollowPattern + +-- | 'deleteAutoFollowPattern' deletes an auto-follow rule. See +-- 'Database.Bloodhound.OpenSearch3.Requests.deleteAutoFollowPattern'. +deleteAutoFollowPattern :: + (MonadBH m, WithBackend OpenSearch3 m) => + DeleteAutoFollowPatternRequest -> + m (ParsedEsResponse Acknowledged) +deleteAutoFollowPattern = + performBHRequest . Requests.deleteAutoFollowPattern + +-- ========================================================================= +-- Index Transforms plugin +-- ========================================================================= + +-- | 'createTransform' creates or replaces a transform job. See +-- 'Requests.createTransform' for semantics. +-- See +createTransform :: + (MonadBH m, WithBackend OpenSearch3 m) => + TransformId -> + Transform -> + m (ParsedEsResponse TransformDocumentResponse) +createTransform transformId transform = + performBHRequest $ Requests.createTransform transformId transform + +-- | 'updateTransform' replaces a transform job (unconditional). See +-- 'Requests.updateTransform' for semantics. +-- See +updateTransform :: + (MonadBH m, WithBackend OpenSearch3 m) => + TransformId -> + Transform -> + m (ParsedEsResponse TransformDocumentResponse) +updateTransform transformId transform = + performBHRequest $ Requests.updateTransform transformId transform + +-- | 'updateTransformWith' replaces a transform job with an optional +-- optimistic-concurrency guard. See 'Requests.updateTransformWith'. +-- See +updateTransformWith :: + (MonadBH m, WithBackend OpenSearch3 m) => + TransformId -> + Transform -> + Maybe (Word64, Word64) -> + m (ParsedEsResponse TransformDocumentResponse) +updateTransformWith transformId transform mOcc = + performBHRequest $ Requests.updateTransformWith transformId transform mOcc + +-- | 'getTransform' fetches a single transform job by id. See +-- 'Requests.getTransform'. +-- See +getTransform :: + (MonadBH m, WithBackend OpenSearch3 m) => + TransformId -> + m (ParsedEsResponse TransformDocumentResponse) +getTransform transformId = + performBHRequest $ Requests.getTransform transformId + +-- | 'getTransforms' lists transform jobs, optionally filtered / +-- paginated. See 'Requests.getTransforms'. +-- See +getTransforms :: + (MonadBH m, WithBackend OpenSearch3 m) => + Maybe TransformsListOptions -> + m (ParsedEsResponse GetTransformsResponse) +getTransforms mOpts = + performBHRequest $ Requests.getTransforms mOpts + +-- | 'startTransform' starts a transform job. See +-- 'Requests.startTransform'. +-- See +startTransform :: + (MonadBH m, WithBackend OpenSearch3 m) => + TransformId -> + m (ParsedEsResponse Acknowledged) +startTransform transformId = + performBHRequest $ Requests.startTransform transformId + +-- | 'stopTransform' stops a transform job. See 'Requests.stopTransform'. +-- See +stopTransform :: + (MonadBH m, WithBackend OpenSearch3 m) => + TransformId -> + m (ParsedEsResponse Acknowledged) +stopTransform transformId = + performBHRequest $ Requests.stopTransform transformId + +-- | 'explainTransform' returns the runtime status and statistics of a +-- transform job. See 'Requests.explainTransform'. +-- See +explainTransform :: + (MonadBH m, WithBackend OpenSearch3 m) => + TransformId -> + m (ParsedEsResponse (Maybe TransformExplain)) +explainTransform transformId = + performBHRequest $ Requests.explainTransform transformId + +-- | 'previewTransform' previews what the transformed target index would +-- look like. See 'Requests.previewTransform'. +-- See +previewTransform :: + (MonadBH m, WithBackend OpenSearch3 m) => + Transform -> + m (ParsedEsResponse PreviewTransformResponse) +previewTransform transform = + performBHRequest $ Requests.previewTransform transform + +-- | 'deleteTransform' deletes a transform job by id. See +-- 'Requests.deleteTransform'. +-- See +deleteTransform :: + (MonadBH m, WithBackend OpenSearch3 m) => + TransformId -> + m (ParsedEsResponse BulkResponse) +deleteTransform transformId = + performBHRequest $ Requests.deleteTransform transformId + +-- ========================================================================= +-- Job Scheduler plugin +-- +-- ========================================================================= + +-- | 'getJobSchedulerJobs' lists every scheduled job. See +-- 'Requests.getJobSchedulerJobs'. +-- See +getJobSchedulerJobs :: + (MonadBH m, WithBackend OpenSearch3 m) => + m (ParsedEsResponse JobsResponse) +getJobSchedulerJobs = + performBHRequest $ Requests.getJobSchedulerJobs + +-- | 'getJobSchedulerLocks' lists every distributed lock. See +-- 'Requests.getJobSchedulerLocks'. +-- See +getJobSchedulerLocks :: + (MonadBH m, WithBackend OpenSearch3 m) => + m (ParsedEsResponse LocksResponse) +getJobSchedulerLocks = + performBHRequest $ Requests.getJobSchedulerLocks + +-- | 'getJobSchedulerLock' looks up a single lock by id. See +-- 'Requests.getJobSchedulerLock'. +-- See +getJobSchedulerLock :: + (MonadBH m, WithBackend OpenSearch3 m) => + LockId -> + m (ParsedEsResponse LocksResponse) +getJobSchedulerLock lockId = + performBHRequest $ Requests.getJobSchedulerLock lockId diff --git a/src/Database/Bloodhound/OpenSearch3/Requests.hs b/src/Database/Bloodhound/OpenSearch3/Requests.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/OpenSearch3/Requests.hs @@ -0,0 +1,5513 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +module Database.Bloodhound.OpenSearch3.Requests + ( module Reexport, + deleteISMPolicy, + addISMPolicy, + openPointInTime, + openPointInTimeWith, + closePointInTime, + listAllPITs, + deleteAllPITs, + neuralSearch, + getNeuralStats, + getNeuralStatsWith, + warmupNeuralIndex, + clearNeuralCache, + getKnnStats, + warmupKnnIndex, + clearKnnCache, + getKnnModel, + trainKnnModel, + trainKnnModelWith, + deleteKnnModel, + searchKnnModels, + getMLStats, + getModel, + registerModel, + registerModelWith, + deployModel, + undeployModel, + updateModel, + searchModels, + listModels, + deleteModel, + predict, + trainModel, + trainModelWith, + trainAndPredictModel, + searchMLTasks, + deleteMLTask, + registerModelGroup, + updateModelGroup, + getModelGroup, + searchModelGroups, + deleteModelGroup, + createConnector, + getConnector, + searchConnectors, + updateConnector, + deleteConnector, + createMemory, + updateMemory, + getMemory, + listMemories, + searchMemory, + deleteMemory, + createMemoryMessage, + updateMemoryMessage, + getMemoryMessage, + listMemoryMessages, + searchMemoryMessages, + getMemoryTraces, + createController, + updateController, + getController, + deleteController, + getMLProfile, + getMLProfileModels, + getMLProfileModel, + getMLProfileTasks, + getMLProfileTask, + registerAgent, + getAgent, + deleteAgent, + searchAgents, + updateAgent, + executeAgent, + executeAgentAsync, + executeStreamAgentRequest, + executeStreamAgentAGUIRequest, + knnSearch, + getMLTask, + putISMPolicy, + putISMPolicyWith, + removeISMPolicy, + changeISMPolicy, + retryISMIndex, + explainISMIndex, + explainISMIndexWith, + explainISMIndexFiltered, + simulateISMPolicy, + getISMPolicy, + getISMPolicies, + postSMPolicy, + putSMPolicyWith, + getSMPolicy, + getSMPolicies, + deleteSMPolicy, + startSMPolicy, + stopSMPolicy, + explainSMPolicies, + submitOSAsyncSearch, + submitOSAsyncSearchWith, + getOSAsyncSearch, + deleteOSAsyncSearch, + getOSAsyncSearchStats, + sqlQuery, + sqlQueryNextPage, + closeSqlCursor, + explainSQL, + pplQuery, + explainPPL, + getSQLStats, + createNotificationConfig, + createNotificationConfigWith, + deleteNotificationConfig, + deleteNotificationConfigs, + getNotificationConfig, + getNotificationConfigs, + getNotificationConfigsWith, + getNotificationFeatures, + getNotificationChannels, + getNotificationChannelsWith, + updateNotificationConfig, + sendTestNotification, + createMonitor, + getMonitor, + updateMonitor, + updateMonitorWith, + deleteMonitor, + searchMonitors, + executeMonitor, + getDestinations, + getDestinationsWith, + createDestination, + updateDestination, + deleteDestination, + getAlertsWith, + getAlerts, + acknowledgeAlert, + getMonitorStats, + createEmailAccount, + getEmailAccount, + updateEmailAccount, + updateEmailAccountWith, + deleteEmailAccount, + createEmailGroup, + getEmailGroup, + updateEmailGroup, + updateEmailGroupWith, + deleteEmailGroup, + getDestination, + searchEmailAccounts, + searchEmailGroups, + searchFindings, + createComment, + updateComment, + searchComments, + deleteComment, + createWorkflow, + createWorkflowWith, + getWorkflow, + provisionWorkflow, + provisionWorkflowWith, + deleteWorkflow, + deleteWorkflowWith, + searchWorkflows, + updateWorkflow, + updateWorkflowWith, + deprovisionWorkflow, + deprovisionWorkflowWith, + getWorkflowState, + getWorkflowStateWith, + getWorkflowSteps, + getWorkflowStepsWith, + searchWorkflowState, + createSADetector, + getSADetector, + updateSADetector, + deleteSADetector, + searchSADetectors, + searchSAPrePackagedRules, + searchSACustomRules, + createSACustomRule, + updateSACustomRule, + deleteSACustomRule, + getSAMappingsView, + createSAMappings, + getSAMappings, + updateSAMappings, + getSAAlertsWith, + getSAAlerts, + acknowledgeSADetectorAlerts, + searchSAFindings, + createSACorrelationRule, + getSACorrelations, + findSACorrelation, + searchSACorrelationAlerts, + acknowledgeSACorrelationAlerts, + createSALogType, + searchSALogTypes, + updateSALogType, + deleteSALogType, + createDetector, + getDetector, + previewDetector, + previewDetectorInline, + startDetector, + stopDetector, + updateDetector, + updateDetectorWith, + deleteDetector, + validateDetector, + searchDetectors, + profileDetector, + getDetectorStats, + searchDetectorResults, + deleteDetectorResults, + searchDetectorTasks, + topAnomalies, + createRollup, + createRollupWith, + getRollup, + getAllRollups, + deleteRollup, + startRollup, + stopRollup, + explainRollup, + startReplication, + stopReplication, + pauseReplication, + resumeReplication, + updateReplicationSettings, + getReplicationStatus, + getReplicationStatusWith, + getLeaderStats, + getFollowerStats, + getAutoFollowStats, + createAutoFollowPattern, + deleteAutoFollowPattern, + createTransform, + updateTransform, + updateTransformWith, + getTransform, + getTransforms, + startTransform, + stopTransform, + explainTransform, + previewTransform, + deleteTransform, + getJobSchedulerJobs, + getJobSchedulerLocks, + getJobSchedulerLock, + ) +where + +import Data.Aeson +import Data.ByteString.Lazy qualified as BL +import Data.List.NonEmpty (NonEmpty, toList) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, listToMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Word (Word64) +import Database.Bloodhound.Client.Cluster +import Database.Bloodhound.Common.Requests as Reexport hiding + ( deleteTransform, + explainTransform, + getTransforms, + previewTransform, + startTransform, + stopTransform, + updateTransform, + updateTransformWith, + ) +import Database.Bloodhound.Common.Types hiding + ( PreviewTransformResponse, + TransformId, + TransformStats, + unTransformId, + ) +import Database.Bloodhound.Internal.Utils.Imports (deleteSeveral, showText) +import Database.Bloodhound.Internal.Utils.Requests +import Database.Bloodhound.OpenSearch3.Types +import Network.HTTP.Client (responseBody) +import Prelude hiding (filter, head) + +-- | 'openPointInTime' opens a point in time for a single index given an +-- 'IndexName', using the supplied 'KeepAlive' duration (e.g. +-- @keepAliveMinutes 1@). Note that the point in time should be closed +-- with 'closePointInTime' as soon as it is no longer needed. +-- +-- This is a convenience wrapper around 'openPointInTimeWith' that lifts +-- the single 'IndexName' into an 'IndexPattern'. To target multiple +-- comma-joined indices or a wildcard pattern (e.g. @\"logs-*,app-*\"@), +-- use 'openPointInTimeWith' directly with an 'IndexPattern'. +-- +-- For more information see +-- . +openPointInTime :: + IndexName -> + KeepAlive -> + BHRequest StatusDependant (ParsedEsResponse OpenPointInTimeResponse) +openPointInTime indexName keepAlive = + openPointInTimeWith (IndexPattern (unIndexName indexName)) keepAlive defaultPITOptions + +-- | 'openPointInTimeWith' is the parameterized variant of +-- 'openPointInTime' on OpenSearch 3: it takes an 'IndexPattern' as the +-- target (@target_indexes@ on the wire), which may be a single index +-- name, a comma-separated list of indices, or a wildcard pattern +-- (e.g. @\"logs-*\"@, @\"logs-2024,logs-2025\"@). It forwards the +-- supplied 'PITOptions' as query-string parameters in addition to the +-- mandatory @keep_alive@. All four documented parameters are emitted +-- (@routing@, @preference@, @expand_wildcards@, +-- @allow_partial_pit_creation@); the last is OpenSearch-only and is +-- silently dropped by the Elasticsearch request builders. The target is +-- carried as a URL path segment (not a query parameter). Pass +-- 'Database.Bloodhound.Internal.Versions.Common.Types.PointInTime.defaultPITOptions' +-- to reproduce the wire shape of 'openPointInTime'. +-- +-- For more information see +-- . +openPointInTimeWith :: + IndexPattern -> + KeepAlive -> + PITOptions -> + BHRequest StatusDependant (ParsedEsResponse OpenPointInTimeResponse) +openPointInTimeWith indexPattern keepAlive opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint emptyBody + where + endpoint = + [unIndexPattern indexPattern, "_search", "point_in_time"] + `withQueries` (("keep_alive", Just (keepAliveToText keepAlive)) : osPITOptionsParams opts) + +-- | 'closePointInTime' closes a point in time given a 'ClosePointInTime'. +-- +-- For more information see +-- . +closePointInTime :: + ClosePointInTime -> + BHRequest StatusDependant (ParsedEsResponse ClosePointInTimeResponse) +closePointInTime q = do + withBHResponseParsedEsResponse $ deleteWithBody @StatusDependant ["_search", "point_in_time"] (encode q) + +-- | 'listAllPITs' returns every currently-open point in time on the cluster +-- via @GET /_search/point_in_time/_all@. Each 'PITInfo' carries the pit +-- id, the @creation_time@ and the remaining @keep_alive@ (a bare +-- millisecond count on the wire); the @_shards@ summary is absent from +-- list entries (it appears only in the @POST@ create-PIT response, see +-- 'OpenPointInTimeResponse'). +-- +-- For more information see +-- . +listAllPITs :: + BHRequest StatusDependant [PITInfo] +listAllPITs = + listPITs <$> get @StatusDependant ["_search", "point_in_time", "_all"] + +-- | 'deleteAllPITs' deletes every currently-open point in time on the +-- cluster via @DELETE /_search/point_in_time/_all@. Unlike +-- 'closePointInTime' (the delete-by-ID endpoint, which takes a +-- 'ClosePointInTime' body), this call carries no request body. The +-- server processes each PIT individually and returns one +-- 'ClosePointInTimeResult' per deleted PIT (partial failures are +-- reported as failures); the response therefore reuses the +-- 'ClosePointInTimeResponse' envelope documented for the by-ID +-- endpoint. +-- +-- Note: the Delete All PITs API deletes only local and mixed PITs; it +-- does not delete fully remote (cross-cluster) PITs. +-- +-- For more information see +-- . +deleteAllPITs :: + BHRequest StatusDependant (ParsedEsResponse ClosePointInTimeResponse) +deleteAllPITs = + withBHResponseParsedEsResponse $ + delete @StatusDependant ["_search", "point_in_time", "_all"] + +-- | 'neuralSearch' executes a neural search against the standard +-- @POST \/{indices}\/_search@ endpoint (or @POST /_search@ when no +-- indices are supplied, which searches every index on the cluster). +-- Neural search is /not/ a dedicated route: it is distinguished by the +-- presence of a @neural@ clause inside the @query@ of the 'Search' body +-- (e.g. a 'NeuralQuery'); the server inspects the body, not the URL. +-- The supplied index list is therefore rendered as a comma-joined path +-- segment, exactly as in 'searchByIndices', rather than as a query +-- parameter. +-- +-- For more information see +-- . +neuralSearch :: + (FromJSON a) => + [IndexName] -> + Search -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult a)) +neuralSearch indices search = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode search) + where + endpoint = + if null indices + then mkEndpoint ["_search"] + else mkEndpoint [renderedIxs, "_search"] + renderedIxs = T.intercalate "," (map unIndexName indices) + +-- | 'getNeuralStats' calls the Neural Search plugin Stats API +-- (@GET /_plugins/_neural/[{nodeId}/]stats[/{stat}]@). Both arguments are +-- optional and select, respectively, which node(s) to query (defaults to all) +-- and which stat(s) to return (defaults to all). The endpoint is disabled +-- by default; the cluster setting +-- @plugins.neural_search.stats_enabled@ must be @true@ or the server will +-- respond with HTTP 403 (plain-text body @Stats endpoint is disabled@, not +-- a JSON error envelope). +-- +-- The route is live-verified as registered on OS 3.7.0: it answers 403 +-- (disabled) rather than 404, and the wire shape below is captured from a +-- live OS 3.7.0 cluster with the setting on (bead bloodhound-6py). The +-- OpenSearch docs site does not document this endpoint; the section\/stat +-- names are derived from the plugin source +-- (, +-- @RestNeuralStatsAction@ \/ @NeuralStatsResponse@). +-- +-- The response body is a typed envelope ('NeuralStats') around up to three +-- dynamic JSON sections (@info@, @all_nodes@, @nodes@). With the default +-- request (no @include_*@ parameters) the server emits all three sections; +-- the 'NeuralStats' decoder also ignores the @_nodes@ \/ @cluster_name@ +-- envelope keys the live endpoint prepends. See the module docs of +-- 'NeuralStats' for why the section bodies are kept as aeson 'Value's. +-- +-- Equivalent to 'getNeuralStatsWith' with 'defaultNeuralStatsOptions' (no +-- @include_*@ query parameters, so the server chooses which sections to +-- emit). See 'getNeuralStatsWith' for the parameterized variant that lets +-- the caller toggle each section on or off. +-- +-- For more information see +-- . +getNeuralStats :: + Maybe NeuralNodeId -> + Maybe NeuralStatName -> + BHRequest StatusDependant (ParsedEsResponse NeuralStats) +getNeuralStats mNodeId mStatName = + getNeuralStatsWith mNodeId mStatName defaultNeuralStatsOptions + +-- | 'getNeuralStatsWith' is the parameterized variant of 'getNeuralStats': +-- it forwards the supplied 'NeuralStatsOptions' as the three documented +-- @include_*@ query parameters (@include_info@, @include_all_nodes@, +-- @include_individual_nodes@), each of which toggles whether the server +-- emits the corresponding top-level section of the 'NeuralStats' response. +-- Fields set to 'Nothing' are omitted; with 'defaultNeuralStatsOptions' this +-- yields no query string, so the call is byte-identical to 'getNeuralStats'. +-- The endpoint is disabled by default; see 'getNeuralStats' for the +-- @plugins.neural_search.stats_enabled@ cluster setting that gates it. +-- +-- For more information see +-- . +getNeuralStatsWith :: + Maybe NeuralNodeId -> + Maybe NeuralStatName -> + NeuralStatsOptions -> + BHRequest StatusDependant (ParsedEsResponse NeuralStats) +getNeuralStatsWith mNodeId mStatName opts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint segments + `withQueries` neuralStatsOptionsParams opts + segments = + ["_plugins", "_neural"] + <> foldMap (pure . unNeuralNodeId) mNodeId + <> ["stats"] + <> foldMap (pure . unNeuralStatName) mStatName + +-- | 'warmupNeuralIndex' targets the Neural Search plugin warmup route +-- (@POST /_plugins/_neural/warmup/{index}@), which preloads the neural +-- sparse data for the supplied indices into JVM memory on the data nodes +-- so the first neural sparse search against each index does not pay the +-- cache-load latency. The request body is an empty JSON object (@{}@); +-- the response is typed as 'ShardsResult' (@{\"_shards\":{...}}@ +-- envelope). +-- +-- The @index@ path segment follows the OpenSearch multi-target syntax: the +-- supplied list is rendered as a single comma-separated segment +-- (e.g. @[i1, i2]@ becomes @i1,i2@). An empty list renders an empty +-- segment and the server will respond with an error. +-- +-- Wire shape live-verified against OS 3.7.0 (bead bloodhound-at5): the +-- response is +-- @{"_shards":{"total":2,"successful":1,"failed":0}}@ — the @_shards@ +-- envelope, matching the k-NN sibling warmup API. The endpoint requires +-- an index with @index.sparse: true@ and a @sparse_vector@ field mapping; +-- calling it against any other index type returns HTTP 400. +-- +-- The warmup is asynchronous: the response is returned as soon as the +-- load is scheduled, not when it completes. OpenSearch 3.x exposes +-- 'getNeuralStats', which reports plugin cache statistics. +-- +-- For more information see +-- . +warmupNeuralIndex :: + [IndexName] -> + BHRequest StatusIndependant ShardsResult +warmupNeuralIndex indexNames = + post endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_neural", "warmup", T.intercalate "," (map unIndexName indexNames)] + +-- | 'clearNeuralCache' targets the Neural Search plugin clear-cache route +-- (@POST /_plugins/_neural/clear_cache/{index}@), which drops the neural +-- search cache entries that the plugin maintains for the supplied indices, +-- freeing the associated native-memory reservations. The request body is +-- an empty JSON object (@{}@); the response is typed as 'ShardsResult' +-- (@{\"_shards\":{...}}@ envelope). +-- +-- The @index@ path segment follows the OpenSearch multi-target syntax: the +-- supplied list is rendered as a single comma-separated segment +-- (e.g. @[i1, i2]@ becomes @i1,i2@). An empty list renders an empty +-- segment and the server will respond with an error. +-- +-- Wire shape live-verified against OS 3.7.0 (bead bloodhound-at5): the +-- response is +-- @{"_shards":{"total":2,"successful":1,"failed":0}}@ — the @_shards@ +-- envelope, matching the sibling k-NN clear-cache API. The endpoint +-- requires an index with @index.sparse: true@ and a @sparse_vector@ field +-- mapping; calling it against any other index type returns HTTP 400. +-- +-- For more information see +-- . +clearNeuralCache :: + [IndexName] -> + BHRequest StatusIndependant ShardsResult +clearNeuralCache indexNames = + post endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_neural", "clear_cache", T.intercalate "," (map unIndexName indexNames)] + +-- | 'getKnnStats' calls the k-NN plugin Stats API +-- (@GET /_plugins/_knn/[{nodeId}/]stats[/{stat}]@). Both arguments are +-- optional and select, respectively, which node(s) to query (defaults to all) +-- and which stat(s) to return (defaults to all). +-- +-- The response body is a typed envelope ('KnnStats') — a flat +-- 'Map.Map Text Value' whose top-level keys are either cluster-level +-- stat names (mapping to scalars) or the literal @nodes@ key (mapping to +-- a per-node map keyed by opaque node ID); see the module docs of +-- 'KnnStats' for why the entries are kept as aeson 'Value's rather than +-- modelled per-stat, and for how to navigate to a given node or cluster +-- value. +-- +-- For more information see +-- . +getKnnStats :: + Maybe KnnNodeId -> + Maybe KnnStatName -> + BHRequest StatusDependant (ParsedEsResponse KnnStats) +getKnnStats mNodeId mStatName = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint segments + segments = + ["_plugins", "_knn"] + <> foldMap (pure . unKnnNodeId) mNodeId + <> ["stats"] + <> foldMap (pure . unKnnStatName) mStatName + +-- | 'warmupKnnIndex' calls the k-NN plugin Warmup API +-- (@GET /_plugins/_knn/warmup/{index}@). Loads the k-NN native library +-- indices for the supplied indices into memory on the data nodes so the +-- first k-NN search against each index does not pay the native-engine +-- load latency. The request carries no body; the response is a +-- 'ShardsResult' (@{\"_shards\":{...}}@ envelope) reporting how many +-- shards scheduled the load. +-- +-- The @index@ path segment follows the OpenSearch multi-target syntax: the +-- supplied list is rendered as a single comma-separated segment +-- (e.g. @[i1, i2]@ becomes @i1,i2@). An empty list renders an empty +-- segment and the server will respond with an error. +-- +-- The warmup is asynchronous: the response is returned as soon as the +-- load is scheduled, not when it completes. Poll 'getKnnStats' to +-- observe progress. +-- +-- For more information see +-- . +warmupKnnIndex :: + [IndexName] -> + BHRequest StatusIndependant ShardsResult +warmupKnnIndex indexNames = + get endpoint + where + endpoint = mkEndpoint ["_plugins", "_knn", "warmup", T.intercalate "," (map unIndexName indexNames)] + +-- | 'clearKnnCache' calls the k-NN plugin Clear Cache API +-- (@POST /_plugins/_knn/clear_cache/{index}@), available since OpenSearch 2.14. +-- Drops the native cache entries that @faiss@ and @nmslib@ (deprecated) +-- maintain for the supplied indices, freeing the associated native-memory +-- reservations. This API has no effect on @lucene@ indexes — their graph +-- lives in the Lucene heap and is not cleared here. The request body is +-- an empty JSON object (@{}@); the response is a 'ShardsResult' +-- (@{\"_shards\":{...}}@ envelope) reporting how many shards were +-- cleared. The resulting cache-size drop is visible immediately in +-- 'getKnnStats'. +-- +-- The @index@ path segment follows the OpenSearch multi-target syntax: the +-- supplied list is rendered as a single comma-separated segment +-- (e.g. @[i1, i2]@ becomes @i1,i2@). An empty list renders an empty +-- segment and the server will respond with an error. +-- +-- For more information see +-- . +clearKnnCache :: + [IndexName] -> + BHRequest StatusIndependant ShardsResult +clearKnnCache indexNames = + post endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_knn", "clear_cache", T.intercalate "," (map unIndexName indexNames)] + +-- | 'getKnnModel' calls the k-NN plugin Get Model API +-- (@GET /_plugins/_knn/models/{model_id}@). Returns the model's metadata, +-- including its lifecycle 'KnnModelState', the base64-serialized +-- 'knnModelModelBlob' (large, often excluded server-side via @?filter_path@), +-- the vector 'knnModelDimension' and distance 'knnModelSpaceType', and the +-- native 'knnModelEngine' (@faiss@ or deprecated @nmslib@). The response is a +-- bare object (no envelope), decoded into 'KnnModel'. +-- +-- For more information see +-- . +getKnnModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse KnnModel) +getKnnModel modelId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_knn", "models", unModelId modelId] + +-- | 'trainKnnModel' calls the k-NN plugin Train Model API +-- (@POST /_plugins/_knn/models/{model_id}/_train@). Schedules asynchronous +-- training of a native library model (FAISS IVF and friends) from the +-- @knn_vector@ field of a training index. The request returns as soon as +-- training is scheduled, carrying only the @model_id@ in +-- 'KnnTrainResponse'; the model enters the @training@ state. Poll +-- 'getKnnModel' to observe the transition to @created@ (success) or +-- @failed@ (with the @error@ field populated). +-- +-- Equivalent to 'trainKnnModelWith' with @Nothing@ (no node preference). +-- +-- For more information see +-- . +trainKnnModel :: + ModelId -> + KnnTrainingRequest -> + BHRequest StatusDependant (ParsedEsResponse KnnTrainResponse) +trainKnnModel = trainKnnModelWith Nothing + +-- | 'trainKnnModelWith' extends 'trainKnnModel' with an optional +-- @?preference@ query parameter. Supplying 'Just' a 'KnnNodeId' pins the +-- asynchronous training task to the specified data node, sent on the wire +-- as @?preference={node_id}@; 'Nothing' lets OpenSearch choose the training +-- node. The pinned node must already host a shard of the training index, +-- otherwise OpenSearch rejects the request. +-- +-- For more information see +-- . +trainKnnModelWith :: + Maybe KnnNodeId -> + ModelId -> + KnnTrainingRequest -> + BHRequest StatusDependant (ParsedEsResponse KnnTrainResponse) +trainKnnModelWith mNodeId modelId req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + baseEndpoint = mkEndpoint ["_plugins", "_knn", "models", unModelId modelId, "_train"] + endpoint = case mNodeId of + Nothing -> baseEndpoint + Just nodeId -> withQueries baseEndpoint [("preference", Just (unKnnNodeId nodeId))] + +-- | 'deleteKnnModel' calls the k-NN plugin Delete Model API +-- (@DELETE /_plugins/_knn/models/{model_id}@). Removes a trained model +-- from the cluster's @.opensearch-knn-models@ system index. The response +-- is a 'KnnDeleteModelResponse' echoing the @model_id@ and reporting +-- @result = "deleted"@ — note this is NOT the standard 'Acknowledged' +-- envelope (the k-NN plugin returns a richer response than the typical +-- cluster-level ack). A 404 for a missing model id surfaces as an +-- 'EsError' under 'StatusDependant', matching 'getKnnModel' and the ML +-- Commons 'deleteModel' precedent. +-- +-- For more information see +-- . +deleteKnnModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse KnnDeleteModelResponse) +deleteKnnModel modelId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_knn", "models", unModelId modelId] + +-- | 'searchKnnModels' searches the @.opensearch-knn-models@ system index +-- via @POST /_plugins/_knn/models/_search@ (k-NN plugin Search Models +-- API). The caller drives the query entirely through the standard +-- bloodhound 'Search' DSL — pagination (@from@\/@size@), filtering, +-- sorting, and @_source@ projection (use 'source' to exclude the large +-- 'knnModelModelBlob', mirroring the docs' +-- @_source_excludes=model_blob@ example). +-- +-- The response is the standard OpenSearch search envelope, decoded as +-- 'SearchResult' whose hits carry a 'KnnModel' in each @_source@. The +-- 'KnnModel' parser tolerates any field except @model_id@ being absent, +-- so a blob-excluding @_source@ projection decodes cleanly. +-- +-- Mirrors 'knnSearch' (same 'Search' body, same 'SearchResult' return +-- shape, same bare-'post' dispatch) rather than the sibling ML Commons +-- 'searchModels': k-NN's response is the vanilla search envelope, so no +-- dedicated response type is needed. +-- +-- Surfaced as 'StatusDependant' so a non-2xx response is parsed as an +-- 'EsError' and thrown by 'performBHRequest' — matching 'knnSearch' +-- (the function this mirrors), rather than 'getKnnModel' and +-- 'deleteKnnModel', which capture the error as a value via +-- 'ParsedEsResponse'. +-- +-- For more information see +-- . +searchKnnModels :: + Search -> + BHRequest StatusDependant (SearchResult KnnModel) +searchKnnModels search = + post @StatusDependant endpoint (encode search) + where + endpoint = mkEndpoint ["_plugins", "_knn", "models", "_search"] + +-- | 'getMLStats' calls the ML Commons plugin Stats API +-- (@GET /_plugins/_ml/[{nodeId}/]stats[/{stat}]@). Both arguments are +-- optional and select, respectively, which node(s) to query (defaults to all) +-- and which stat(s) to return (defaults to all). Unlike the Neural Search +-- stats endpoint, the ML Commons stats endpoint is always available whenever +-- the plugin is installed — no cluster setting needs to be enabled. +-- +-- The response body is a JSON object whose top-level keys are either +-- cluster-level stat names (mapping to scalars) or the literal key @nodes@ +-- (mapping to a per-node map keyed by opaque node ID); see the module docs +-- of 'MLStats' for why the entries are kept as aeson 'Value's rather than +-- modelled per-stat. +-- +-- For more information see +-- . +getMLStats :: + Maybe MLNodeId -> + Maybe MLStatName -> + BHRequest StatusDependant (ParsedEsResponse MLStats) +getMLStats mNodeId mStatName = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint segments + segments = + ["_plugins", "_ml"] + <> foldMap (pure . unMLNodeId) mNodeId + <> ["stats"] + <> foldMap (pure . unMLStatName) mStatName + +-- | 'knnSearch' executes a k-NN vector search against a single index for +-- OpenSearch 3+. +-- +-- OpenSearch does not expose a @\/{index}\/_knn_search@ endpoint (that path is +-- Elasticsearch-specific and was never wired up correctly here before). kNN +-- search in OpenSearch uses the standard @POST \/{index}\/_search@ body with +-- the kNN clause nested inside @query@ as @\"query\": {\"knn\": {: {...}}}@. +-- This function injects the supplied 'OpenSearchKnnQuery' via 'Search.osKnnBody' +-- (which 'Search.toJSON' renders at the @query@ slot) and POSTs to @\/_search@. +-- +-- For more information see +-- . +knnSearch :: + (FromJSON a) => + IndexName -> + OpenSearchKnnQuery -> + Search -> + BHRequest StatusDependant (SearchResult a) +knnSearch indexName osknnQuery search = + post @StatusDependant endpoint (encode searchWithKnn) + where + endpoint = mkEndpoint [unIndexName indexName, "_search"] + searchWithKnn = search {osKnnBody = Just osknnQuery} + +-- | 'getMLTask' calls the ML Commons plugin Get Task API +-- (@GET /_plugins/_ml/tasks/{task_id}@). The plugin returns the current state +-- of a single asynchronous task created by @POST /_plugins/_ml/models/_register@, +-- @POST /_plugins/_ml/models/{id}/_deploy@, training, and friends. Callers +-- poll this endpoint with the @task_id@ returned by the submit call until +-- 'mlTaskInfoState' reaches 'MLTaskStateCompleted' or 'MLTaskStateFailed'. +-- +-- For more information see +-- . +getMLTask :: + MLTaskId -> + BHRequest StatusDependant (ParsedEsResponse MLTaskInfo) +getMLTask mlTaskId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "tasks", unMLTaskId mlTaskId] + +-- | 'putISMPolicy' creates or updates an ISM policy. Equivalent to +-- 'putISMPolicyWith' with 'Nothing' (no optimistic-concurrency guard), so +-- concurrent updates to the same policy id silently clobber each other. +-- See +putISMPolicy :: + PolicyId -> + ISMPolicyRequest -> + BHRequest StatusDependant (ParsedEsResponse PutISMPolicyResponse) +putISMPolicy policyId policy = putISMPolicyWith policyId policy Nothing + +-- | 'putISMPolicyWith' creates or updates an ISM policy with an optional +-- optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ — both +-- values read from a prior 'PutISMPolicyResponse' — to make the PUT +-- conditional on the policy being unchanged since you last read it; a stale +-- pair causes OpenSearch to respond with HTTP 409 instead of silently +-- overwriting. Pass 'Nothing' for the unconditional semantics of +-- 'putISMPolicy'. The two values must be supplied together: OpenSearch +-- rejects a partial pair with HTTP 400 (mirroring the document-write +-- @if_seq_no@ / @if_primary_term@ semantics). +-- See +putISMPolicyWith :: + PolicyId -> + ISMPolicyRequest -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant (ParsedEsResponse PutISMPolicyResponse) +putISMPolicyWith policyId policy mOcc = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode policy) + where + baseEndpoint = mkEndpoint ["_plugins", "_ism", "policies", unPolicyId policyId] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries baseEndpoint $ + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'addISMPolicy' applies an existing ISM policy to one or more indices. +-- The @policy_id@ in the body identifies the policy to attach. Indices that +-- already have a policy attached (or reject the operation for other reasons) +-- appear in the @failed_indices@ field of the response. +-- See +addISMPolicy :: + PolicyId -> + IndexName -> + BHRequest StatusDependant (ParsedEsResponse ISMUpdatedIndicesResponse) +addISMPolicy policyId indexName = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_plugins", "_ism", "add", unIndexName indexName] + body = object ["policy_id" .= unPolicyId policyId] + +-- | 'removeISMPolicy' detaches any ISM policy from the given index. +-- See +removeISMPolicy :: + IndexName -> + BHRequest StatusDependant (ParsedEsResponse ISMUpdatedIndicesResponse) +removeISMPolicy indexName = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_ism", "remove", unIndexName indexName] + +-- | 'changeISMPolicy' updates the managed-index policy attached to @index@. +-- See +changeISMPolicy :: + IndexName -> + ChangePolicyRequest -> + BHRequest StatusDependant (ParsedEsResponse ISMUpdatedIndicesResponse) +changeISMPolicy indexName req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ism", "change_policy", unIndexName indexName] + +-- | 'retryISMIndex' retries the failed ISM action for an index. +-- See +retryISMIndex :: + IndexName -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse ISMUpdatedIndicesResponse) +retryISMIndex indexName mState = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ism", "retry", unIndexName indexName] + body = case mState of + Nothing -> encode (object []) + Just st -> encode (object ["state" .= st]) + +-- | 'explainISMIndex' returns the ISM state of @index@. Equivalent to +-- 'explainISMIndexWith' with 'defaultISMExplainOptions' (no query +-- parameters). +-- See +explainISMIndex :: + IndexName -> + BHRequest StatusDependant (ParsedEsResponse ISMExplanation) +explainISMIndex indexName = explainISMIndexWith indexName defaultISMExplainOptions + +-- | 'explainISMIndexWith' returns the ISM state of @index@, forwarding the +-- supplied 'ISMExplainOptions' as query-string parameters. All four +-- documented parameters are emitted (@show_policy@, @validate_action@, +-- @local@, @expand_wildcards@); 'Nothing' \/ 'False' fields are omitted so +-- 'defaultISMExplainOptions' reproduces the wire shape of 'explainISMIndex'. +-- See +explainISMIndexWith :: + IndexName -> + ISMExplainOptions -> + BHRequest StatusDependant (ParsedEsResponse ISMExplanation) +explainISMIndexWith indexName opts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_ism", "explain", unIndexName indexName] + endpoint = withQueries baseEndpoint (ismExplainOptionsParams opts) + +-- | 'explainISMIndexFiltered' returns the ISM state of @index@ via the +-- @POST /_plugins/_ism/explain/{index}@ "Explain index with filtering" form +-- (introduced in OpenSearch 2.12). The 'ISMExplainFilter' is sent as a +-- @{"filter": {...}}@ body; the server returns only indexes matching /all/ +-- specified criteria. The response shape is identical to +-- 'explainISMIndex' ('ISMExplanation'). Pass 'defaultISMExplainFilter' for an +-- unfiltered POST. +-- See +explainISMIndexFiltered :: + IndexName -> + ISMExplainFilter -> + BHRequest StatusDependant (ParsedEsResponse ISMExplanation) +explainISMIndexFiltered indexName filt = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (ISMExplainFilterRequest filt)) + where + endpoint = mkEndpoint ["_plugins", "_ism", "explain", unIndexName indexName] + +-- | 'simulateISMPolicy' previews how a policy would apply to one or more +-- indexes without making changes (@POST /_plugins/_ism/simulate@, OS 3.7+). +-- The 'SimulateISMPolicyRequest' carries either a stored @policy_id@ or +-- an inline @policy@ body (exactly one must be set), plus the list of +-- index names\/wildcard patterns to simulate against. For each index the +-- response returns the current state, the next action, every +-- transition-condition evaluation, and the state the index would move to +-- next. Indexes that do not exist are returned inline with an @error@ +-- field (NOT an HTTP 404). +-- +-- /OS 3.7+ only/ — the simulate endpoint does not exist on OS 1.x, OS +-- 2.x, or OS 3.0–3.6. Calling it on an older cluster returns a 404 +-- 'EsError'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (malformed body — both or +-- neither @policy_id@\/@policy@ set, plugin not installed, RBAC denial, +-- or a 404 on older OS versions) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +simulateISMPolicy :: + SimulateISMPolicyRequest -> + BHRequest StatusDependant SimulateISMPolicyResponse +simulateISMPolicy req = + post (mkEndpoint ["_plugins", "_ism", "simulate"]) (encode req) + +-- | 'getISMPolicy' fetches a single policy by id. +-- See +getISMPolicy :: + PolicyId -> + BHRequest StatusDependant (ParsedEsResponse ISMPolicyInfo) +getISMPolicy policyId = + withBHResponseParsedEsResponse $ + get @StatusDependant (mkEndpoint ["_plugins", "_ism", "policies", unPolicyId policyId]) + +-- | 'getISMPolicies' lists policies, optionally filtered / paginated. +-- See +getISMPolicies :: + Maybe ISMPoliciesQuery -> + BHRequest StatusDependant (ParsedEsResponse GetISMPoliciesResponse) +getISMPolicies mQuery = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_ism", "policies"] + endpoint = case mQuery of + Nothing -> baseEndpoint + Just query -> withQueries baseEndpoint (ismPoliciesQueryToPairs query) + +-- | 'deleteISMPolicy' deletes an ISM policy by id. +-- OpenSearch stores policies as documents in @.opendistro-ism-config@, so the +-- response is the standard document-delete envelope (parsed here as +-- 'IndexedDocument'), not an 'Acknowledged' ack. +-- See +deleteISMPolicy :: + PolicyId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteISMPolicy policyId = + withBHResponseParsedEsResponse $ + delete @StatusDependant (mkEndpoint ["_plugins", "_ism", "policies", unPolicyId policyId]) + +-- ========================================================================= +-- Snapshot Management plugin +-- ========================================================================= +-- +-- The SM plugin runs snapshot creation/deletion on a schedule. Policies +-- live under @/_plugins/_sm/policies/{policy_name}@. The plugin was +-- introduced in OpenSearch 2.1; the path is identical across OS 2.x/3.x. +-- See + +-- | 'postSMPolicy' creates a new SM policy. The server rejects the request +-- with HTTP 409 if a policy with the same name already exists — use +-- 'putSMPolicyWith' for updates (which requires the current @_seq_no@ / +-- @_primary_term@ for optimistic concurrency). +-- See +postSMPolicy :: + SMPolicyName -> + SMPolicyBody -> + BHRequest StatusDependant (ParsedEsResponse SMPolicyResponse) +postSMPolicy policyName body = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode body) + where + endpoint = mkEndpoint ["_plugins", "_sm", "policies", unSMPolicyName policyName] + +-- | 'putSMPolicyWith' updates an existing SM policy. OpenSearch requires +-- the @if_seq_no@ / @if_primary_term@ pair for updates: pass the values +-- read from a prior 'SMPolicyResponse' (or the @_seq_no@ / @_primary_term@ +-- of a create response). A stale pair causes HTTP 409; a missing pair +-- causes HTTP 400. +-- See +putSMPolicyWith :: + SMPolicyName -> + SMPolicyBody -> + Word64 -> + Word64 -> + BHRequest StatusDependant (ParsedEsResponse SMPolicyResponse) +putSMPolicyWith policyName body seqNo primaryTerm = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode body) + where + endpoint = + withQueries + (mkEndpoint ["_plugins", "_sm", "policies", unSMPolicyName policyName]) + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'getSMPolicy' fetches a single SM policy by name. +-- See +getSMPolicy :: + SMPolicyName -> + BHRequest StatusDependant (ParsedEsResponse SMPolicyResponse) +getSMPolicy policyName = + withBHResponseParsedEsResponse $ + get @StatusDependant (mkEndpoint ["_plugins", "_sm", "policies", unSMPolicyName policyName]) + +-- | 'getSMPolicies' lists SM policies, optionally filtered / paginated via +-- a 'GetSMPoliciesQuery'. Pass 'Nothing' (or 'defaultGetSMPoliciesQuery') +-- to list all policies with server defaults. +-- See +getSMPolicies :: + Maybe GetSMPoliciesQuery -> + BHRequest StatusDependant (ParsedEsResponse GetSMPoliciesResponse) +getSMPolicies mQuery = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_sm", "policies"] + endpoint = case mQuery of + Nothing -> baseEndpoint + Just query -> withQueries baseEndpoint (getSMPoliciesQueryParams query) + +-- | 'deleteSMPolicy' deletes an SM policy by name. The server returns the +-- standard OpenSearch document-delete envelope (SM policies are stored as +-- documents in @.opendistro-ism-config@). +-- See +deleteSMPolicy :: + SMPolicyName -> + BHRequest StatusDependant (ParsedEsResponse DeleteSMPolicyResponse) +deleteSMPolicy policyName = + withBHResponseParsedEsResponse $ + delete @StatusDependant (mkEndpoint ["_plugins", "_sm", "policies", unSMPolicyName policyName]) + +-- | 'startSMPolicy' enables an SM policy (sets @enabled=true@). The job +-- scheduler picks up the policy on its next tick. +-- See +startSMPolicy :: + SMPolicyName -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +startSMPolicy policyName = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant (mkEndpoint ["_plugins", "_sm", "policies", unSMPolicyName policyName, "_start"]) + +-- | 'stopSMPolicy' disables an SM policy (sets @enabled=false@). In-flight +-- snapshot operations are not interrupted; the policy simply stops +-- scheduling new ones. +-- See +stopSMPolicy :: + SMPolicyName -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +stopSMPolicy policyName = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant (mkEndpoint ["_plugins", "_sm", "policies", unSMPolicyName policyName, "_stop"]) + +-- | 'explainSMPolicies' returns the running state and metadata of the +-- policies matching the supplied name expression. The expression is a +-- comma-separated list and/or a wildcard pattern (e.g. @"daily*"@, +-- @"policy-a,policy-b"@); pass @"*"@ to explain all policies. +-- See +explainSMPolicies :: + Text -> + BHRequest StatusDependant (ParsedEsResponse SMExplainResponse) +explainSMPolicies policyNames = + withBHResponseParsedEsResponse $ + get @StatusDependant (mkEndpoint ["_plugins", "_sm", "policies", policyNames, "_explain"]) + +-- ========================================================================= +-- ML Commons model APIs +-- ========================================================================= + +-- | 'getModel' calls the ML Commons Get Model API +-- (@GET /_plugins/_ml/models/{model_id}@). Returns the model's full metadata +-- (name, algorithm, version, format, lifecycle state, content size and hash, +-- config, and lifecycle timestamps). +-- +-- For more information see +-- . +getModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse ModelInfo) +getModel modelId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", unModelId modelId] + +-- | 'registerModel' registers a model. Equivalent to 'registerModelWith' +-- with @deploy = False@ — registration proceeds asynchronously and the +-- returned 'MLTaskAck' carries a @task_id@ to poll via the Get ML Task API +-- (@GET /_plugins/_ml/tasks/{task_id}@). +-- See +registerModel :: + RegisterModelRequest -> + BHRequest StatusDependant (ParsedEsResponse MLTaskAck) +registerModel = registerModelWith False + +-- | 'registerModelWith' registers a model with an optional @?deploy=true@ +-- query flag. When the flag is set, OpenSearch chains a deploy operation +-- after successful registration, saving a separate 'deployModel' round +-- trip. The model is not callable via 'predict' until the deploy task +-- completes. +-- See +registerModelWith :: + Bool -> + RegisterModelRequest -> + BHRequest StatusDependant (ParsedEsResponse MLTaskAck) +registerModelWith deploy req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + baseEndpoint = mkEndpoint ["_plugins", "_ml", "models", "_register"] + endpoint = + if deploy + then withQueries baseEndpoint [("deploy", Just "true")] + else baseEndpoint + +-- | 'deployModel' loads a registered model's chunks from the model index +-- into memory on ML worker nodes so it can serve inference requests. Pass +-- 'Nothing' to let OpenSearch pick the eligible nodes; pass @'Just' +-- (DeployModelRequest ('Just' nodeIds))@ to restrict deployment to a +-- specific node list. Like 'registerModel', deployment is asynchronous +-- and the returned 'MLTaskAck' carries a @task_id@ for polling. +-- See +deployModel :: + ModelId -> + Maybe DeployModelRequest -> + BHRequest StatusDependant (ParsedEsResponse MLTaskAck) +deployModel modelId mReq = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", unModelId modelId, "_deploy"] + body = maybe (encode (object [])) encode mReq + +-- | 'deleteModel' deletes a registered model by id. OpenSearch stores +-- models as documents in @.plugins-ml-model@, so the response is the +-- standard document-delete envelope (parsed here as 'IndexedDocument'), +-- not an 'Acknowledged' ack — identical to 'deleteISMPolicy'. A +-- deployed model must be undeployed before it can be deleted, otherwise +-- the server returns an error which surfaces as an 'EsError' under +-- 'StatusDependant'. +-- See +deleteModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteModel modelId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", unModelId modelId] + +-- | 'undeployModel' unloads a deployed model from ML worker nodes +-- (the inverse of 'deployModel'). Unlike deploy, undeploy is +-- /synchronous/: the response is a node-keyed stats map +-- ('UndeployModelResponse') reporting per-node, per-model state +-- (typically @UNDEPLOYED@), not a task ack. The {model_id}/_undeploy +-- path form takes no request body; the @node_ids@-scoped variant +-- (path @/_plugins/_ml/models/_undeploy@, body +-- @{node_ids, model_ids}@) is a separate endpoint not exposed here. +-- See +undeployModel :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse UndeployModelResponse) +undeployModel modelId = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", unModelId modelId, "_undeploy"] + +-- | 'updateModel' updates a subset of a registered model's metadata +-- via @PUT /_plugins/_ml/models/{model_id}@. The body is an +-- 'UpdateModelRequest' whose every field is 'Maybe'; only the +-- supplied fields are written (partial update). The response is the +-- standard document-update envelope (parsed here as 'IndexedDocument' +-- with @result = "updated"@), not an ack. +-- See +updateModel :: + ModelId -> + UpdateModelRequest -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateModel modelId req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", unModelId modelId] + +-- | 'searchModels' searches the model index via +-- @POST /_plugins/_ml/models/_search@. Pass 'Nothing' for the plain +-- empty-body @{}@ POST that returns the first page of all models; +-- pass @'Just' query@ to filter, paginate (@from@\/@size@), or sort +-- using the standard OpenSearch query DSL carried opaquely as a +-- 'Value'. Returns the full 'ModelSearchResponse' envelope so callers +-- can drive pagination and inspect @_shards@ health; use +-- 'modelSearchResponseHits' to project out just the @['ModelHit']@ +-- list. +-- See +searchModels :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse ModelSearchResponse) +searchModels = searchModelsOn "_search" + +-- | 'listModels' lists models. Historically this hit the +-- @POST /_plugins/_ml/models/_list@ endpoint, but OS 3.x removed POST +-- from @_list@ (it now returns 405). The modern, supported endpoint +-- for listing is @POST /_plugins/_ml/models/_search@ — the same one +-- 'searchModels' uses. Kept as a separate function rather than aliased +-- to 'searchModels' so callers and telemetry can distinguish the two +-- call sites. +-- See +listModels :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse ModelSearchResponse) +listModels = searchModelsOn "_search" + +-- | Shared body of 'searchModels' and 'listModels': POSTs the +-- (possibly-empty) query body to @/_plugins/_ml/models/_search@ (both +-- call sites now route through @_search@). An empty 'Value' object is +-- sent when the caller supplies 'Nothing'. +searchModelsOn :: + Text -> + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse ModelSearchResponse) +searchModelsOn suffix mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "models", suffix] + body = encode (maybe (object []) id mQuery) + +-- ========================================================================= +-- ML Commons agent APIs +-- ========================================================================= + +-- | 'registerAgent' registers an ML Commons agent (OS 2.12+) — a named +-- configuration that binds a large-language model (or a routed +-- population of sub-agents and tools) behind a server-assigned +-- 'AgentId'. Unlike 'registerModel', registration is synchronous: the +-- POST persists a single config document in the @.plugins-ml-agent@ +-- system index and returns @{"agent_id": "..."}@ directly, so the +-- returned 'RegisterAgentResponse' carries no @task_id@ to poll and the +-- agent is callable immediately (subject to its bound model being +-- deployed). +-- +-- Surfaced as 'StatusDependant' so a 4xx (e.g. an unknown tool @type@, +-- a missing @llm@ on a @conversation@ agent, or an @app_type@ mismatch +-- on a @template@ agent) decodes as an 'EsError' rather than throwing. +-- See +registerAgent :: + RegisterAgentRequest -> + BHRequest StatusDependant (ParsedEsResponse RegisterAgentResponse) +registerAgent req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "agents", "_register"] + +-- | 'getAgent' fetches a registered agent by id via +-- @GET /_plugins/_ml/agents/{agent_id}@. The body is the bare stored +-- agent document (no @_source@ wrapper, no envelope), decoded here as +-- 'AgentInfo'. Agents are stored as documents in +-- @.plugins-ml-agent@; an unknown id surfaces as an 'EsError' under +-- 'StatusDependant' (HTTP 404). +-- See +getAgent :: + AgentId -> + BHRequest StatusDependant (ParsedEsResponse AgentInfo) +getAgent agentId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "agents", unAgentId agentId] + +-- | 'deleteAgent' deletes a registered agent by id via +-- @DELETE /_plugins/_ml/agents/{agent_id}@. OpenSearch stores agents +-- as documents in @.plugins-ml-agent@, so the response is the +-- standard document-delete envelope (parsed here as 'IndexedDocument', +-- identical to 'deleteModel'); an unknown id surfaces as an 'EsError' +-- under 'StatusDependant' (HTTP 404). +-- See +deleteAgent :: + AgentId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteAgent agentId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "agents", unAgentId agentId] + +-- | 'searchAgents' searches the agent index via +-- @POST /_plugins/_ml/agents/_search@. Pass 'Nothing' for the plain +-- empty-body @{}@ POST that returns the first page of all agents; +-- pass @'Just' query@ to filter, paginate (@from@\/@size@), or sort +-- using the standard OpenSearch query DSL carried opaquely as a +-- 'Value'. Returns the full 'AgentSearchResponse' envelope; note +-- that the @agent_id@ surfaces as each hit's @_id@, not as a field +-- inside @_source@. +-- +-- /Empty-cluster handling:/ when no agent has ever been registered +-- the @.plugins-ml-agent@ system index does not exist, and OpenSearch +-- responds with HTTP 404 @index_not_found_exception@ instead of an +-- empty search result. This wrapper detects that 404 and substitutes +-- 'emptyAgentSearchResponse', so callers see a uniform @Right empty@ +-- regardless of whether any agent has been registered. +-- See +searchAgents :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse AgentSearchResponse) +searchAgents mQuery = withBHResponseParsedEsResponse innerReq + where + innerReq = baseInner {bhRequestParser = innerParser} + baseInner = post @StatusDependant @AgentSearchResponse endpoint body + endpoint = mkEndpoint ["_plugins", "_ml", "agents", "_search"] + body = encode (maybe (object []) id mQuery) + innerParser resp + | isAgentsIndexMissing404 resp = Right (Right emptyAgentSearchResponse) + | otherwise = bhRequestParser baseInner resp + isAgentsIndexMissing404 resp = + statusCodeIs (404, 404) resp + && case eitherDecode (responseBody (getResponse resp)) of + Right es -> "no such index" `T.isInfixOf` errorMessage (es :: EsError) + Left _ -> False + +-- | 'updateAgent' updates a subset of a registered agent's +-- configuration via @PUT /_plugins/_ml/agents/{agent_id}@ (the Update +-- Agent API, introduced in OpenSearch 3.1). The body is an +-- 'UpdateAgentRequest' whose every field is 'Maybe'; only the supplied +-- fields are written (partial update — 'omitNulls' drops 'Nothing' +-- fields on encode). The agent's @type@ is /not/ updatable and is +-- therefore absent from the request record. The response is the +-- standard document-update envelope (parsed here as 'IndexedDocument' +-- with @result = "updated"@), not an ack — identical to 'updateModel' +-- and 'deleteModel'. An unknown @agent_id@ surfaces as an 'EsError' +-- under 'StatusDependant' (HTTP 404). +-- See +updateAgent :: + AgentId -> + UpdateAgentRequest -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateAgent agentId req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "agents", unAgentId agentId] + +-- | 'executeAgent' runs a registered agent synchronously via +-- @POST /_plugins/_ml/agents/{agent_id}/_execute@ (the Execute Agent +-- API, introduced in OpenSearch 2.13). The agent runs its configured +-- tools and returns an 'ExecuteAgentResponse' carrying the +-- @inference_results.output[]@ list. The request body is the +-- permissive 'ExecuteAgentRequest' (opaque @parameters@ map and\/or +-- polymorphic @input@); see its docs for why those are 'Value'-typed. +-- +-- For asynchronous execution (OpenSearch 3.0+) — which returns a +-- @task_id@ to poll via 'getMLTask' instead of blocking until +-- completion — use 'executeAgentAsync'. +-- See +executeAgent :: + AgentId -> + ExecuteAgentRequest -> + BHRequest StatusDependant (ParsedEsResponse ExecuteAgentResponse) +executeAgent agentId req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "agents", unAgentId agentId, "_execute"] + +-- | 'executeAgentAsync' is the asynchronous variant of 'executeAgent' +-- (OpenSearch 3.0+): it sets the @?async=true@ query parameter, so the +-- server returns immediately with an 'MLTaskAck' carrying a @task_id@ +-- rather than blocking until the agent finishes. Poll the returned +-- @task_id@ with 'getMLTask' until 'mlTaskInfoState' reaches +-- 'MLTaskStateCompleted' or 'MLTaskStateFailed'. +-- +-- The return type differs from 'executeAgent' (which yields +-- 'ExecuteAgentResponse'), so the two are separate top-level functions +-- rather than a @...With@ variant — mirroring the +-- 'registerModel'\/'registerModelWith' split in shape, but with a +-- genuinely different result type. +-- See +executeAgentAsync :: + AgentId -> + ExecuteAgentRequest -> + BHRequest StatusDependant (ParsedEsResponse MLTaskAck) +executeAgentAsync agentId req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = + withQueries + (mkEndpoint ["_plugins", "_ml", "agents", unAgentId agentId, "_execute"]) + [("async", Just "true")] + +-- | 'executeStreamAgentRequest' builds the 'BHRequest' for the +-- streaming Execute Stream Agent API +-- (@POST /_plugins/_ml/agents/{agent_id}/_execute/stream@, OS 3.3+). +-- The 'BHRequest' is consumed by +-- 'Database.Bloodhound.OpenSearch3.Client.executeStreamAgent', which +-- bypasses the buffering 'dispatch' path and reads the Server-Sent +-- Events body incrementally via +-- 'Database.Bloodhound.Client.Cluster.withStreamingResponse'. The +-- 'BHRequest'\'s response-body type (@'BHRequest' 'StatusDependant' +-- 'Value'@) is therefore never actually decoded through the normal +-- parser — it is a placeholder so the request fits the existing +-- 'BHRequest' shape that 'withStreamingResponse' requires. +executeStreamAgentRequest :: + AgentId -> + ExecuteAgentRequest -> + BHRequest StatusDependant Value +executeStreamAgentRequest agentId req = + post @StatusDependant endpoint (encode req) + where + endpoint = + mkEndpoint ["_plugins", "_ml", "agents", unAgentId agentId, "_execute", "stream"] + +-- | 'executeStreamAgentAGUIRequest' is the AG-UI-protocol variant of +-- 'executeStreamAgentRequest' (OS 3.5+). The body is the AG-UI +-- request object, passed opaquely as a 'Value' (the schema is defined +-- by the AG-UI spec and varies across agent configurations). +executeStreamAgentAGUIRequest :: + AgentId -> + Value -> + BHRequest StatusDependant Value +executeStreamAgentAGUIRequest agentId body = + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint ["_plugins", "_ml", "agents", unAgentId agentId, "_execute", "stream"] + +-- | 'predict' invokes a deployed or registered model. The path carries an +-- @algorithm_name@ (e.g. @kmeans@, @text_embedding@, @remote@) and a +-- @model_id@; the request body and the response are model-specific, so +-- both are typed as opaque 'Value's and the caller decodes the payload +-- with a model-specific parser. +-- +-- For more information see +-- . +predict :: + AlgorithmName -> + ModelId -> + Value -> + BHRequest StatusDependant (ParsedEsResponse Value) +predict algo modelId body = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode body) + where + endpoint = + mkEndpoint + ["_plugins", "_ml", "_predict", unAlgorithmName algo, unModelId modelId] + +-- ========================================================================= +-- ML Commons train and task APIs +-- ========================================================================= + +-- | 'trainModel' trains a classical algorithm (kmeans, RCF, ...) on a +-- dataset, returning either a @model_id@ (sync, the default) or a +-- @task_id@ (when 'trainModelWith' is called with @async = True@). The +-- response shape is the same 'MLTaskAck' in both cases — sync populates +-- 'mlTaskAckModelId', async populates 'mlTaskAckTaskId'. +-- See . +trainModel :: + AlgorithmName -> + TrainModelRequest -> + BHRequest StatusDependant (ParsedEsResponse MLTaskAck) +trainModel = trainModelWith False + +-- | 'trainModelWith' is the async-flagged variant of 'trainModel'. Pass +-- @True@ to run training asynchronously (the call returns a @task_id@ +-- immediately; poll it via 'getMLTask'). +trainModelWith :: + Bool -> + AlgorithmName -> + TrainModelRequest -> + BHRequest StatusDependant (ParsedEsResponse MLTaskAck) +trainModelWith asyncFlag algorithm req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + baseEndpoint = mkEndpoint ["_plugins", "_ml", "_train", unAlgorithmName algorithm] + endpoint = + if asyncFlag + then withQueries baseEndpoint [("async", Just "true")] + else baseEndpoint + +-- | 'trainAndPredictModel' trains an unsupervised algorithm on a dataset +-- and immediately runs prediction against the same data, returning the +-- prediction payload as 'TrainAndPredictResponse'. +-- See . +trainAndPredictModel :: + AlgorithmName -> + TrainModelRequest -> + BHRequest StatusDependant (ParsedEsResponse TrainAndPredictResponse) +trainAndPredictModel algorithm req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "_train_predict", unAlgorithmName algorithm] + +-- | 'searchMLTasks' searches the @.plugins-ml-task@ system index via +-- @POST /_plugins/_ml/tasks/_search@. Pass 'Nothing' for the plain +-- empty-body @{}@ POST; pass @'Just' query@ to filter (e.g. by +-- @function_name@) or paginate. The @.plugins-ml-task@ index does not +-- exist until the first asynchronous ML operation runs, so a 404 +-- @index_not_found@ is decoded as an empty result (mirroring +-- 'searchAgents'). +searchMLTasks :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult MLTaskInfo)) +searchMLTasks mQuery = + withBHResponseParsedEsResponse $ + searchMLWithEmptyIndex404 $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "tasks", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'deleteMLTask' deletes an ML task by id via +-- @DELETE /_plugins/_ml/tasks/{task_id}@. The response is the standard +-- document-delete envelope ('IndexedDocument'). The plugin does not +-- check task status before deleting — a running task can be deleted. +deleteMLTask :: + MLTaskId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteMLTask taskId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "tasks", unMLTaskId taskId] + +-- ========================================================================= +-- ML Commons model group APIs +-- ========================================================================= + +-- | 'registerModelGroup' registers a model group via +-- @POST /_plugins/_ml/model_groups/_register@ (OS 2.12+). +-- See . +registerModelGroup :: + RegisterModelGroupRequest -> + BHRequest StatusDependant (ParsedEsResponse RegisterModelGroupResponse) +registerModelGroup req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "model_groups", "_register"] + +-- | 'updateModelGroup' updates a model group via +-- @PUT /_plugins/_ml/model_groups/{model_group_id}@. The body is a +-- partial update; the response is the standard document-update envelope. +updateModelGroup :: + ModelGroupId -> + UpdateModelGroupRequest -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateModelGroup groupId req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "model_groups", unModelGroupId groupId] + +-- | 'getModelGroup' fetches a model group by id via +-- @GET /_plugins/_ml/model_groups/{model_group_id}@. +getModelGroup :: + ModelGroupId -> + BHRequest StatusDependant (ParsedEsResponse ModelGroupInfo) +getModelGroup groupId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "model_groups", unModelGroupId groupId] + +-- | 'searchModelGroups' searches the @.plugins-ml-model-group@ index via +-- @POST /_plugins/_ml/model_groups/_search@. The backing index does not +-- exist until the first group is registered, so a 404 is decoded as an +-- empty result. +searchModelGroups :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult ModelGroupInfo)) +searchModelGroups mQuery = + withBHResponseParsedEsResponse $ + searchMLWithEmptyIndex404 $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "model_groups", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'deleteModelGroup' deletes a model group via +-- @DELETE /_plugins/_ml/model_groups/{model_group_id}@. Idempotent: a +-- missing group returns HTTP 200 with @result = "not_found"@ (not a +-- 404). A group can only be manually deleted if it has no model +-- versions. +deleteModelGroup :: + ModelGroupId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteModelGroup groupId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "model_groups", unModelGroupId groupId] + +-- ========================================================================= +-- ML Commons connector APIs +-- ========================================================================= + +-- | 'createConnector' creates a remote-model connector via +-- @POST /_plugins/_ml/connectors/_create@ (OS 2.12+). @credential@ is +-- write-only and never returned by subsequent get\/search calls. +-- See . +createConnector :: + CreateConnectorRequest -> + BHRequest StatusDependant (ParsedEsResponse CreateConnectorResponse) +createConnector req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "connectors", "_create"] + +-- | 'getConnector' fetches a connector by id via +-- @GET /_plugins/_ml/connectors/{connector_id}@. The @credential@ field +-- is never present in the response. +getConnector :: + ConnectorId -> + BHRequest StatusDependant (ParsedEsResponse ConnectorInfo) +getConnector connId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "connectors", unConnectorId connId] + +-- | 'searchConnectors' searches the @.plugins-ml-connector@ index via +-- @POST /_plugins/_ml/connectors/_search@. The backing index does not +-- exist until the first connector is created, so a 404 is decoded as an +-- empty result. +searchConnectors :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult ConnectorInfo)) +searchConnectors mQuery = + withBHResponseParsedEsResponse $ + searchMLWithEmptyIndex404 $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "connectors", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'updateConnector' updates a connector via +-- @PUT /_plugins/_ml/connectors/{connector_id}@ (OS 2.12+). Partial +-- update; omitted fields are preserved. All models using the connector +-- must be undeployed before updating. +updateConnector :: + ConnectorId -> + UpdateConnectorRequest -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateConnector connId req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "connectors", unConnectorId connId] + +-- | 'deleteConnector' deletes a connector via +-- @DELETE /_plugins/_ml/connectors/{connector_id}@. Idempotent: a +-- missing connector returns HTTP 200 with @result = "not_found"@. +deleteConnector :: + ConnectorId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteConnector connId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "connectors", unConnectorId connId] + +-- ========================================================================= +-- ML Commons memory and message APIs +-- ========================================================================= + +-- | 'createMemory' creates a conversation memory via +-- @POST /_plugins/_ml/memory/@ (OS 2.12+). +-- See . +createMemory :: + CreateMemoryRequest -> + BHRequest StatusDependant (ParsedEsResponse CreateMemoryResponse) +createMemory req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory"] + +-- | 'updateMemory' updates a memory's @name@ via +-- @PUT /_plugins/_ml/memory/{memory_id}@. The response is the standard +-- document-update envelope. +updateMemory :: + MemoryId -> + CreateMemoryRequest -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateMemory memoryId req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", unMemoryId memoryId] + +-- | 'getMemory' fetches a single memory by id via +-- @GET /_plugins/_ml/memory/{memory_id}@. +getMemory :: + MemoryId -> + BHRequest StatusDependant (ParsedEsResponse Memory) +getMemory memoryId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", unMemoryId memoryId] + +-- | 'listMemories' lists memories (newest first) via +-- @GET /_plugins/_ml/memory@. Both arguments are optional query +-- parameters: @maxResults@ maps to @max_results@ (default 10) and +-- @nextToken@ maps to @next_token@ (default 0, the index of the first +-- memory to return). +listMemories :: + Maybe Int -> + Maybe Int -> + BHRequest StatusDependant (ParsedEsResponse ListMemoriesResponse) +listMemories mMaxResults mNextToken = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_ml", "memory"] + endpoint = withQueries baseEndpoint renderedPairs + renderedPairs = + catMaybes + [ fmap (\n -> ("max_results", Just (T.pack (show n)))) mMaxResults, + fmap (\n -> ("next_token", Just (T.pack (show n)))) mNextToken + ] + +-- | 'searchMemory' searches the @.plugins-ml-memory-meta@ index via +-- @POST /_plugins/_ml/memory/_search@. The backing index does not exist +-- until the first memory is created, so a 404 is decoded as an empty +-- result. +searchMemory :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult Memory)) +searchMemory mQuery = + withBHResponseParsedEsResponse $ + searchMLWithEmptyIndex404 $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'deleteMemory' deletes a memory by id via +-- @DELETE /_plugins/_ml/memory/{memory_id}@. The response is +-- @{success: }@. Unlike connector \/ model-group delete, memory +-- delete is /not/ idempotent — a missing memory returns HTTP 404. +deleteMemory :: + MemoryId -> + BHRequest StatusDependant (ParsedEsResponse DeleteMemoryResponse) +deleteMemory memoryId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", unMemoryId memoryId] + +-- | 'createMemoryMessage' appends a message to a memory via +-- @POST /_plugins/_ml/memory/{memory_id}/messages@. At least one +-- request field must be non-null. +createMemoryMessage :: + MemoryId -> + CreateMemoryMessageRequest -> + BHRequest StatusDependant (ParsedEsResponse CreateMemoryMessageResponse) +createMemoryMessage memoryId req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", unMemoryId memoryId, "messages"] + +-- | 'updateMemoryMessage' updates a message's @additional_info@ via +-- @PUT /_plugins/_ml/memory/message/{message_id}@. Only @additional_info@ +-- is updatable; the other 'CreateMemoryMessageRequest' fields are +-- write-once and ignored on update. The response is the standard +-- document-update envelope. +updateMemoryMessage :: + MessageId -> + CreateMemoryMessageRequest -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateMemoryMessage messageId req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", "message", unMessageId messageId] + +-- | 'getMemoryMessage' fetches a single message by id via +-- @GET /_plugins/_ml/memory/message/{message_id}@. +getMemoryMessage :: + MessageId -> + BHRequest StatusDependant (ParsedEsResponse MemoryMessage) +getMemoryMessage messageId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", "message", unMessageId messageId] + +-- | 'listMemoryMessages' lists the messages in a memory via +-- @GET /_plugins/_ml/memory/{memory_id}/messages@. +listMemoryMessages :: + MemoryId -> + BHRequest StatusDependant (ParsedEsResponse ListMemoryMessagesResponse) +listMemoryMessages memoryId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", unMemoryId memoryId, "messages"] + +-- | 'searchMemoryMessages' searches the messages of a memory via +-- @POST /_plugins/_ml/memory/{memory_id}/_search@. The backing +-- @.plugins-ml-memory-message@ index does not exist until the first +-- message is created, so a 404 is decoded as an empty result. +searchMemoryMessages :: + MemoryId -> + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult MemoryMessage)) +searchMemoryMessages memoryId mQuery = + withBHResponseParsedEsResponse $ + searchMLWithEmptyIndex404 $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", unMemoryId memoryId, "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'getMemoryTraces' fetches the trace messages of a message via +-- @GET /_plugins/_ml/memory/message/{message_id}/traces@. Traces are +-- diagnostic sub-messages recording an agent's intermediate tool calls. +getMemoryTraces :: + MessageId -> + BHRequest StatusDependant (ParsedEsResponse MemoryMessageTraces) +getMemoryTraces messageId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "memory", "message", unMessageId messageId, "traces"] + +-- ========================================================================= +-- ML Commons controller APIs +-- ========================================================================= + +-- | 'createController' creates a per-user rate-limit controller for a +-- model via @POST /_plugins/_ml/controllers/{model_id}@ (OS 2.12+). +-- POST overwrites the entire @user_rate_limiter@ map. The controller is +-- keyed by the model's id. +-- See . +createController :: + ModelId -> + ControllerConfig -> + BHRequest StatusDependant (ParsedEsResponse ControllerCreateResponse) +createController modelId config = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode config) + where + endpoint = mkEndpoint ["_plugins", "_ml", "controllers", unModelId modelId] + +-- | 'updateController' updates a controller via +-- @PUT /_plugins/_ml/controllers/{model_id}@. PUT updates individual +-- user entries, preserving others. The response is the standard +-- document-update envelope. +updateController :: + ModelId -> + ControllerConfig -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +updateController modelId config = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode config) + where + endpoint = mkEndpoint ["_plugins", "_ml", "controllers", unModelId modelId] + +-- | 'getController' fetches a controller by model id via +-- @GET /_plugins/_ml/controllers/{model_id}@. Returns HTTP 404 when no +-- controller exists for the model. +getController :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse ControllerConfig) +getController modelId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "controllers", unModelId modelId] + +-- | 'deleteController' deletes a controller via +-- @DELETE /_plugins/_ml/controllers/{model_id}@. Returns HTTP 404 with +-- @index_not_found_exception@ when the @.plugins-ml-controller@ index +-- does not exist. +deleteController :: + ModelId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteController modelId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "controllers", unModelId modelId] + +-- ========================================================================= +-- ML Commons profile API +-- ========================================================================= + +-- | 'getMLProfile' profiles ML models and tasks across all nodes via +-- @GET /_plugins/_ml/profile@. Pass @'Just' body@ to filter by +-- @node_ids@ \/ @model_ids@ \/ @task_ids@ or to toggle +-- @return_all_tasks@ \/ @return_all_models@; pass 'Nothing' for the +-- bodyless form that returns everything. Use 'getMLProfileModels', +-- 'getMLProfileModel', 'getMLProfileTasks', or 'getMLProfileTask' for +-- the path-scoped forms. +-- See . +getMLProfile :: + Maybe MLProfileRequest -> + BHRequest StatusDependant (ParsedEsResponse MLProfileResponse) +getMLProfile mReq = + withBHResponseParsedEsResponse $ + case mReq of + Nothing -> get @StatusDependant endpoint + Just req -> getWithBody @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ml", "profile"] + +-- | 'getMLProfileModels' profiles all deployed models via +-- @GET /_plugins/_ml/profile/models@. +getMLProfileModels :: + BHRequest StatusDependant (ParsedEsResponse MLProfileResponse) +getMLProfileModels = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "profile", "models"] + +-- | 'getMLProfileModel' profiles one or more models via +-- @GET /_plugins/_ml/profile/models/{model_id}@. Pass multiple ids to +-- fetch several profiles at once (rendered as a single comma-separated +-- path segment). +getMLProfileModel :: + [ModelId] -> + BHRequest StatusDependant (ParsedEsResponse MLProfileResponse) +getMLProfileModel modelIds = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + segment = T.intercalate "," (map unModelId modelIds) + endpoint = mkEndpoint ["_plugins", "_ml", "profile", "models", segment] + +-- | 'getMLProfileTasks' profiles all ML tasks via +-- @GET /_plugins/_ml/profile/tasks@. +getMLProfileTasks :: + BHRequest StatusDependant (ParsedEsResponse MLProfileResponse) +getMLProfileTasks = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_ml", "profile", "tasks"] + +-- | 'getMLProfileTask' profiles one or more tasks via +-- @GET /_plugins/_ml/profile/tasks/{task_id}@. Pass multiple ids to +-- fetch several profiles at once (rendered as a single comma-separated +-- path segment). +getMLProfileTask :: + [MLTaskId] -> + BHRequest StatusDependant (ParsedEsResponse MLProfileResponse) +getMLProfileTask taskIds = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + segment = T.intercalate "," (map unMLTaskId taskIds) + endpoint = mkEndpoint ["_plugins", "_ml", "profile", "tasks", segment] + +-- ========================================================================= +-- ML Commons search helpers +-- ========================================================================= + +-- | Empty 'SearchResult' substituted by 'searchMLWithEmptyIndex404' when +-- a plugin's backing @.plugins-ml-*@ system index does not yet exist. +emptyMLSearchResult :: SearchResult a +emptyMLSearchResult = + SearchResult + { took = 0, + timedOut = False, + shards = ShardResult 0 0 0 0, + searchHits = mempty, + aggregations = Nothing, + scrollId = Nothing, + suggest = Nothing, + pitId = Nothing + } + +-- | Wrap a plugin search 'BHRequest' so that the HTTP 404 +-- @index_not_found_exception@ the plugin returns when its backing +-- @.plugins-ml-*@ system index does not yet exist decodes as +-- 'emptyMLSearchResult' instead of an 'EsError'. Mirrors the +-- 'searchAgents' empty-cluster handling. +searchMLWithEmptyIndex404 :: + BHRequest StatusDependant (SearchResult a) -> + BHRequest StatusDependant (SearchResult a) +searchMLWithEmptyIndex404 base = base {bhRequestParser = parser} + where + parser resp + | isMLIndexMissing404 resp = Right (Right emptyMLSearchResult) + | otherwise = bhRequestParser base resp + isMLIndexMissing404 resp = + statusCodeIs (404, 404) resp + && case eitherDecode (responseBody (getResponse resp)) of + Right es -> "no such index" `T.isInfixOf` errorMessage (es :: EsError) + Left _ -> False + +-- ========================================================================= +-- Async Search plugin +-- ========================================================================= + +-- | 'submitOSAsyncSearch' submits a 'Search' for asynchronous execution via +-- the OpenSearch async search plugin (@POST /_plugins/_asynchronous_search@). It +-- returns immediately with an id and partial results; poll the returned id +-- with 'getOSAsyncSearch' until 'asyncSearchIsRunning' is @False@. +-- +-- The OpenSearch async search response is shaped exactly like Elasticsearch's +-- (the plugin was forked from ES 7.7's async search), so the result is decoded +-- into the shared 'AsyncSearchResult' — no OpenSearch-specific type is needed. +-- +-- Equivalent to @'submitOSAsyncSearchWith' 'defaultAsyncSearchSubmitOptions'@ +-- — it forwards no URI parameters. +-- +-- For more information see +-- . +submitOSAsyncSearch :: + (FromJSON a) => + Search -> + BHRequest StatusDependant (AsyncSearchResult a) +submitOSAsyncSearch = submitOSAsyncSearchWith defaultAsyncSearchSubmitOptions + +-- | Like 'submitOSAsyncSearch' but accepts 'AsyncSearchSubmitOptions' +-- carrying the URI parameters documented for +-- @POST /_plugins/_asynchronous_search@. OpenSearch documents only the +-- @wait_for_completion@, @keep_on_completion@ and @keep_alive@ parameters; +-- the Elasticsearch-only 'assoBatchedReduceSize' and +-- 'assoCcsMinimizeRoundtrips' are silently dropped by the underlying +-- 'osAsyncSearchSubmitOptionsParams' renderer. 'defaultAsyncSearchSubmitOptions' +-- makes this byte-for-byte equivalent to 'submitOSAsyncSearch'. +-- +-- For more information see +-- . +submitOSAsyncSearchWith :: + (FromJSON a) => + AsyncSearchSubmitOptions -> + Search -> + BHRequest StatusDependant (AsyncSearchResult a) +submitOSAsyncSearchWith opts search = + post + (["_plugins", "_asynchronous_search"] `withQueries` osAsyncSearchSubmitOptionsParams opts) + (encode search) + +-- | 'getOSAsyncSearch' retrieves the current state and (partial or final) +-- results of an OpenSearch async search by id +-- (@GET /_plugins/_asynchronous_search/{id}@). +-- +-- For more information see +-- . +getOSAsyncSearch :: + (FromJSON a) => + AsyncSearchId -> + BHRequest StatusDependant (AsyncSearchResult a) +getOSAsyncSearch (AsyncSearchId searchId) = + get ["_plugins", "_asynchronous_search", searchId] + +-- | 'deleteOSAsyncSearch' deletes an OpenSearch async search result and its +-- context by id (@DELETE /_plugins/_asynchronous_search/{id}@) and returns +-- 'Acknowledged' on success. +-- +-- For more information see +-- . +deleteOSAsyncSearch :: + AsyncSearchId -> + BHRequest StatusIndependant Acknowledged +deleteOSAsyncSearch (AsyncSearchId searchId) = + delete ["_plugins", "_asynchronous_search", searchId] + +-- | 'getOSAsyncSearchStats' fetches cluster-wide async-search statistics +-- via @GET /_plugins/_asynchronous_search/stats@. Returns per-node +-- counters for the nine documented async-search lifecycle events +-- (submitted, initialized, rejected, search_completed, search_failed, +-- persisted, persist_failed, running_current, cancelled). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getOSAsyncSearchStats :: + BHRequest StatusDependant AsyncSearchStatsResponse +getOSAsyncSearchStats = + get ["_plugins", "_asynchronous_search", "stats"] + +-- ========================================================================= +-- SQL & PML plugin +-- ========================================================================= + +-- | 'sqlQuery' calls the SQL plugin Query API +-- (@POST /_plugins/_sql@). Executes a SQL query against the cluster and +-- returns a JDBC-style rowset ('SQLResult'). Pagination is opt-in: pass a +-- positive 'sqlRequestFetchSize' to receive a 'SQLResult' carrying a +-- 'sqlResultCursor' and then use 'sqlQueryNextPage' to walk subsequent +-- pages. Release an unfinished cursor with 'closeSqlCursor' to free the +-- server-side context. +-- +-- Surfaced as 'StatusDependant' so a 4xx error (bad SQL, missing index) +-- decodes as 'EsError' rather than throwing. +-- +-- For more information see +-- . +sqlQuery :: + SQLRequest -> + BHRequest StatusDependant (ParsedEsResponse SQLResult) +sqlQuery req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_sql"] + +-- | 'sqlQueryNextPage' fetches the next page of a paginated SQL result by +-- POSTing a cursor body (@{"cursor": ...}@) to @/_plugins/_sql@. Use the +-- 'sqlResultCursor' returned by the previous 'sqlQuery' or +-- 'sqlQueryNextPage' call. Continuation responses carry only 'sqlResultDatarows' +-- and a new 'sqlResultCursor'; @schema@, @total@, @size@ and @status@ are +-- dropped by the server, so every other 'SQLResult' field is 'Maybe'. +-- +-- When the response no longer carries a 'sqlResultCursor' the last page has +-- been consumed and the server-side context is released automatically; no +-- 'closeSqlCursor' call is needed in that case. +-- +-- For more information see +-- . +sqlQueryNextPage :: + SQLCursor -> + BHRequest StatusDependant (ParsedEsResponse SQLResult) +sqlQueryNextPage cursor = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (SQLCursorRequest cursor)) + where + endpoint = mkEndpoint ["_plugins", "_sql"] + +-- | 'closeSqlCursor' releases the server-side context held by a SQL +-- pagination cursor (@POST /_plugins/_sql/close@). Call this to free the +-- context when you stop reading before the cursor is naturally exhausted +-- (i.e. before 'sqlResultCursor' disappears from a 'sqlQueryNextPage' +-- response). Closing an already-released cursor is a no-op server-side. +-- +-- For more information see +-- . +closeSqlCursor :: + SQLCursor -> + BHRequest StatusDependant (ParsedEsResponse SQLCloseResult) +closeSqlCursor cursor = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (SQLCursorRequest cursor)) + where + endpoint = mkEndpoint ["_plugins", "_sql", "close"] + +-- | 'explainSQL' calls the SQL plugin Explain API +-- (@POST /_plugins/_sql/_explain@). Translates a SQL query into the underlying +-- Elasticsearch query DSL without executing it. The request body is the same +-- 'SQLRequest' shape accepted by 'sqlQuery'. The response is a free-form JSON +-- object whose structure tracks the translated DSL (and varies by query and +-- plugin version), so it is returned as an opaque aeson 'Value'. +-- +-- Surfaced as 'StatusDependant' so a 4xx error (bad SQL, missing index) +-- decodes as 'EsError' rather than throwing. +-- +-- For more information see +-- . +explainSQL :: + SQLRequest -> + BHRequest StatusDependant (ParsedEsResponse Value) +explainSQL req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_sql", "_explain"] + +-- | 'pplQuery' calls the PPL plugin Query API +-- (@POST /_plugins/_ppl@). Executes a PPL (Piped Processing Language) query +-- against the cluster and returns the same JDBC-style rowset shape as +-- 'sqlQuery' (typed here as 'PPLResult', an alias of 'SQLResult'). PPL does +-- not support cursor pagination (the plugin documents 'fetch_size' as +-- SQL-only), so 'sqlResultCursor' will always be 'Nothing' on a PPL +-- response. +-- +-- Surfaced as 'StatusDependant' so a 4xx error decodes as 'EsError'. +-- +-- For more information see +-- . +pplQuery :: + PPLRequest -> + BHRequest StatusDependant (ParsedEsResponse PPLResult) +pplQuery req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ppl"] + +-- | 'explainPPL' calls the PPL plugin Explain API +-- (@POST /_plugins/_ppl/_explain@). Translates a PPL query into the underlying +-- Elasticsearch query DSL without executing it. The request body is the same +-- 'PPLRequest' shape accepted by 'pplQuery'. The response is a free-form JSON +-- object whose structure tracks the translated DSL (and varies by query and +-- plugin version), so it is returned as an opaque aeson 'Value'. +-- +-- Surfaced as 'StatusDependant' so a 4xx error decodes as 'EsError'. +-- +-- For more information see +-- . +explainPPL :: + PPLRequest -> + BHRequest StatusDependant (ParsedEsResponse Value) +explainPPL req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_ppl", "_explain"] + +-- | 'getSQLStats' calls the SQL plugin Stats API +-- (@GET /_plugins/_sql/stats@). Returns node-level plugin metrics as a flat +-- 'SQLPluginStats' map (cluster-level stats are not implemented by the +-- plugin; the response describes only the node you hit). The metric-name +-- set is large and grows across OpenSearch releases (eight keys on 1.x; +-- @ppl_*@, @datasource_*@, @async_query_*@, @emr_*@ and @streaming_*@ +-- keys land later), so the body is decoded as 'Data.Aeson.Value' entries +-- keyed by metric name. +-- +-- Surfaced as 'StatusDependant' so a 404 (SQL plugin not installed) +-- decodes as 'EsError' rather than throwing. +-- +-- For more information see +-- . +getSQLStats :: + BHRequest StatusDependant (ParsedEsResponse SQLPluginStats) +getSQLStats = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_sql", "stats"] + +-- ========================================================================= +-- Notifications plugin +-- ========================================================================= + +-- | 'createNotificationConfig' calls the Notifications plugin Create Config +-- API (@POST /_plugins/_notifications/configs@). Persists a new +-- notification channel configuration (a Slack webhook, an email account, +-- an SNS topic, ...) to the @.opendistro-notifications-config@ system +-- index and returns the resulting 'CreateNotificationConfigResponse', +-- which echoes the server-assigned @config_id@. +-- +-- Equivalent to 'createNotificationConfigWith' with 'Nothing' — the +-- server generates the @config_id@. Supply a custom id via +-- 'createNotificationConfigWith' if you need a stable, predictable +-- identifier (a pre-existing id yields HTTP 409, surfacing as an +-- 'EsError' under 'StatusDependant'). +-- +-- For more information see +-- . +createNotificationConfig :: + NotificationConfig -> + BHRequest StatusDependant (ParsedEsResponse CreateNotificationConfigResponse) +createNotificationConfig = createNotificationConfigWith Nothing + +-- | 'createNotificationConfigWith' is the parameterized variant of +-- 'createNotificationConfig': the optional 'Text' is forwarded as the +-- @config_id@ of the request body. Pass 'Nothing' to let OpenSearch +-- generate one; pass @'Just' id@ for a stable identifier, bearing in +-- mind that a duplicate surfaces as HTTP 409 ('EsError'). +-- See . +createNotificationConfigWith :: + Maybe Text -> + NotificationConfig -> + BHRequest StatusDependant (ParsedEsResponse CreateNotificationConfigResponse) +createNotificationConfigWith mConfigId config = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_notifications", "configs"] + req = CreateNotificationConfigRequest mConfigId config + +-- | 'deleteNotificationConfig' calls the Notifications plugin Delete Config +-- API (@DELETE /_plugins/_notifications/configs/{config_id}@). Removes the +-- named channel configuration from the @.opendistro-notifications-config@ +-- system index and returns a 'DeleteNotificationConfigResponse' mapping +-- the requested @config_id@ to its per-id deletion status (@"OK"@ on +-- success). Use 'deleteResponseStatus' \/ 'deleteResponseAllOK' to +-- inspect the result. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @config_id@, or the +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- This is the single-id variant; for batch deletion use +-- 'deleteNotificationConfigs' with the @config_id_list@ query. +-- +-- For more information see +-- . +deleteNotificationConfig :: + Text -> + BHRequest StatusDependant (ParsedEsResponse DeleteNotificationConfigResponse) +deleteNotificationConfig configId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_notifications", "configs", configId] + +-- | 'deleteNotificationConfigs' is the batch variant of +-- 'deleteNotificationConfig': it calls +-- @DELETE /_plugins/_notifications/configs/?config_id_list=id1,id2,...@ +-- and removes every supplied channel configuration in a single +-- round-trip. The plugin returns the same 'DeleteNotificationConfigResponse' +-- shape as the single-id variant, mapping each requested id to its +-- per-id deletion status (@"OK"@ on success, a failure tag otherwise); +-- use 'deleteResponseStatus' to inspect a specific id or +-- 'deleteResponseAllOK' to summarise the whole batch. The batch +-- variant is preferred when sweeping many configs: it amortises the +-- per-request RBAC and system-index refresh cost. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @config_id@, or the +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- An empty id list is rejected by the plugin with HTTP 400; callers +-- who want a no-op on empty should guard the call site. The +-- @config_id_list@ value is rendered comma-separated by the underlying +-- 'withQueries' without URL-encoding, so config ids must not contain +-- @,@ (which would inject extra ids) or other URL-significant +-- characters (@&@, @=@, @\/@). The plugin emits URL-safe server-assigned +-- identifiers (e.g. @0Jnlh4ABa4TCWn5C5H2G@), so this only bites +-- hand-rolled ids. +-- +-- For more information see +-- . +deleteNotificationConfigs :: + NonEmpty Text -> + BHRequest StatusDependant (ParsedEsResponse DeleteNotificationConfigResponse) +deleteNotificationConfigs configIds = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_notifications", "configs"] + `withQueries` [("config_id_list", Just (T.intercalate "," (toList configIds)))] + +-- | 'getNotificationConfigs' lists every notification channel +-- configuration via the Notifications plugin +-- (@GET /_plugins/_notifications/configs@). Returns each entry as a +-- 'NotificationConfigEntry' (config_id + timestamps + the full +-- 'NotificationConfig'). Equivalent to 'getNotificationConfigsWith' +-- with 'defaultNotificationListOptions' (no filtering or pagination). +-- +-- Surfaced as 'StatusDependant' so a 404 (plugin not installed) +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getNotificationConfigs :: + BHRequest StatusDependant (ParsedEsResponse [NotificationConfigEntry]) +getNotificationConfigs = getNotificationConfigsWith defaultNotificationListOptions + +-- | 'getNotificationConfigsWith' is the parameterized variant of +-- 'getNotificationConfigs': the supplied 'NotificationListOptions' are +-- forwarded as query-string parameters (filtering by config_id \/ type +-- \/ enabled state, pagination via from_index \/ max_items, and +-- sort_order \/ sort_field). Pass 'defaultNotificationListOptions' for +-- the plain no-arg GET. +-- +-- The paging envelope (@start_index@, @total_hits@, +-- @total_hit_relation@) is decoded and discarded; the public return +-- type is the bare @config_list@. File a feature request if you need +-- the paging metadata surfaced. +-- +-- For more information see +-- . +getNotificationConfigsWith :: + NotificationListOptions -> + BHRequest StatusDependant (ParsedEsResponse [NotificationConfigEntry]) +getNotificationConfigsWith opts = + fmap (fmap getNotificationConfigsResponseConfigList) + . withBHResponseParsedEsResponse + $ get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_notifications", "configs"] + `withQueries` notificationListOptionsParams opts + +-- | 'getNotificationChannels' lists every notification channel via the +-- Notifications plugin (@GET /_plugins/_notifications/channels@). The +-- channels endpoint is the lightweight \"runtime\" view: each 'Channel' +-- carries the identifying metadata (config_id, name, description, +-- config_type, is_enabled) but omits the transport-specific details +-- exposed by 'getNotificationConfigs'. Equivalent to +-- 'getNotificationChannelsWith' with 'defaultNotificationListOptions'. +-- +-- Surfaced as 'StatusDependant' so a 404 (plugin not installed) +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getNotificationChannels :: + BHRequest StatusDependant (ParsedEsResponse [Channel]) +getNotificationChannels = getNotificationChannelsWith defaultNotificationListOptions + +-- | 'getNotificationChannelsWith' is the parameterized variant of +-- 'getNotificationChannels': the supplied 'NotificationListOptions' are +-- forwarded as query-string parameters (same filter \/ pagination +-- surface as 'getNotificationConfigsWith'). Pass +-- 'defaultNotificationListOptions' for the plain no-arg GET. +-- +-- The paging envelope is decoded and discarded; the public return type +-- is the bare @channel_list@. +-- +-- For more information see +-- . +getNotificationChannelsWith :: + NotificationListOptions -> + BHRequest StatusDependant (ParsedEsResponse [Channel]) +getNotificationChannelsWith opts = + fmap (fmap getNotificationChannelsResponseChannelList) + . withBHResponseParsedEsResponse + $ get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_notifications", "channels"] + `withQueries` notificationListOptionsParams opts + +-- | 'getNotificationConfig' fetches a single notification channel +-- configuration by id via the Notifications plugin +-- (@GET /_plugins/_notifications/configs/{config_id}@). The endpoint +-- returns the same @start_index@ \/ @total_hits@ \/ @total_hit_relation@ +-- \/ @config_list@ envelope as the list-all 'getNotificationConfigs', +-- with @total_hits@ clamped to @1@ and a single-element @config_list@ +-- on hit; we decode the envelope and project out the lone entry as a +-- 'Maybe' (using 'listToMaybe') so the public type reads as a plain +-- per-id lookup. The 'Nothing' branch surfaces when the server returns +-- HTTP 200 with an empty @config_list@ — a genuine miss is expected to +-- come back as HTTP 404 (surfacing as @'Left' 'EsError'@ via +-- 'StatusDependant' before the body decode runs), but the plugin +-- version-dependent miss encoding is not pinned by a live test, so +-- 'Nothing' is the total fallback rather than a partial head. Callers +-- needing the paging metadata can build the underlying request +-- directly. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @config_id@, or the +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getNotificationConfig :: + Text -> + BHRequest StatusDependant (ParsedEsResponse (Maybe NotificationConfigEntry)) +getNotificationConfig configId = + fmap (fmap (listToMaybe . getNotificationConfigsResponseConfigList)) + . withBHResponseParsedEsResponse + $ get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_notifications", "configs", configId] + +-- | 'updateNotificationConfig' replaces a notification channel +-- configuration via the Notifications plugin +-- (@PUT /_plugins/_notifications/configs/{config_id}@). The body is +-- the 'NotificationConfig' wrapped under the @config@ key (see +-- 'UpdateNotificationConfigRequest'); the @config_id@ identity is the +-- URL path segment, not a body field, so a body shaped like +-- 'CreateNotificationConfigRequest' would be rejected server-side. +-- The response echoes the @config_id@ as a +-- 'CreateNotificationConfigResponse' (the same shape the create +-- endpoint returns). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing @config_id@ +-- (or a 409 on a concurrent modification) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +updateNotificationConfig :: + Text -> + NotificationConfig -> + BHRequest StatusDependant (ParsedEsResponse CreateNotificationConfigResponse) +updateNotificationConfig configId config = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_notifications", "configs", configId] + req = UpdateNotificationConfigRequest config + +-- | 'getNotificationFeatures' lists the channel configuration types +-- this cluster's Notifications plugin supports via +-- @GET /_plugins/_notifications/features@. The result is a +-- 'NotificationFeaturesResponse' carrying the @allowed_config_type_list@ +-- (a subset of 'NotificationConfigType') and the @plugin_features@ +-- feature-flag map. Useful for capability discovery before creating a +-- config — e.g. gate an SNS setup on @NotificationConfigTypeSns@ +-- being present in 'notificationFeaturesResponseAllowedConfigTypeList'. +-- +-- Surfaced as 'StatusDependant' so a 404 (plugin not installed) +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getNotificationFeatures :: + BHRequest StatusDependant (ParsedEsResponse NotificationFeaturesResponse) +getNotificationFeatures = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_notifications", "features"] + +-- | 'sendTestNotification' triggers a one-shot probe delivery to the +-- channel identified by @config_id@ via the Notifications plugin +-- (@GET /_plugins/_notifications/feature/test/{config_id}@). The +-- plugin synthesises an 'TestNotificationEventSource' (title, +-- reference_id, severity, tags), attempts delivery through the +-- config's transport, and returns a 'TestNotificationResponse' +-- carrying a per-config 'TestNotificationStatus' with the upstream +-- delivery result (HTTP code + raw response body in +-- 'testNotificationDeliveryStatusText'). The probe is a real +-- delivery attempt: a Slack config POSTs to its webhook, an email +-- config sends mail, etc. — do not call this against production +-- channels from a loop. +-- +-- Surfaced as 'StatusDependant' so a 4xx (unknown @config_id@, +-- transport misconfiguration, plugin not installed) decodes as an +-- 'EsError' rather than throwing. +-- +-- For more information see +-- . +sendTestNotification :: + Text -> + BHRequest StatusDependant (ParsedEsResponse TestNotificationResponse) +sendTestNotification configId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_notifications", "feature", "test", configId] + +-- ========================================================================= +-- Alerting plugin +-- ========================================================================= + +-- | 'createMonitor' creates an alerting monitor via the Alerting plugin +-- (@POST /_plugins/_alerting/monitors@). The body is the encoded +-- 'Monitor'; the response is the 'MonitorResponse' wrapper carrying the +-- server-assigned @_id@, @_version@, @_seq_no@, @_primary_term@, and the +-- persisted monitor document. +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (invalid monitor body, +-- plugin not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +createMonitor :: + Monitor -> + BHRequest StatusDependant MonitorResponse +createMonitor monitor = + post (mkEndpoint ["_plugins", "_alerting", "monitors"]) (encode monitor) + +-- | 'getMonitor' fetches a single monitor by id via +-- @GET /_plugins/_alerting/monitors/{monitor_id}@. The endpoint returns +-- the 'MonitorResponse' wrapper on the wire +-- (@{_id,_version,_seq_no,_primary_term, monitor:{...}}@); the wrapper +-- is decoded and the 'Monitor' is projected out so the public type +-- matches the bead acceptance (@m 'Monitor'@). Callers needing the +-- indexing metadata can build the underlying request directly. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing monitor id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getMonitor :: + MonitorId -> + BHRequest StatusDependant Monitor +getMonitor (MonitorId mid) = + monitorResponseMonitor <$> get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_alerting", "monitors", mid] + +-- | 'updateMonitor' replaces a monitor via +-- @PUT /_plugins/_alerting/monitors/{monitor_id}@. The body is the +-- encoded 'Monitor'; the response is the same 'MonitorResponse' wrapper +-- as 'createMonitor' (with the incremented @_version@ and @_seq_no@). +-- Equivalent to 'updateMonitorWith' with 'Nothing' (no +-- optimistic-concurrency guard), so concurrent updates to the same +-- monitor id silently clobber each other. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing monitor id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateMonitor :: + MonitorId -> + Monitor -> + BHRequest StatusDependant MonitorResponse +updateMonitor monitorId monitor = updateMonitorWith monitorId monitor Nothing + +-- | 'updateMonitorWith' replaces a monitor via +-- @PUT /_plugins/_alerting/monitors/{monitor_id}@ with an optional +-- optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ — +-- both values read from a prior 'MonitorResponse' — to make the PUT +-- conditional on the monitor being unchanged since you last read it; a +-- stale pair causes OpenSearch to respond with HTTP 409 instead of +-- silently overwriting. Pass 'Nothing' for the unconditional semantics +-- of 'updateMonitor'. The two values must be supplied together: +-- OpenSearch rejects a partial pair with HTTP 400 (mirroring the +-- document-write @if_seq_no@ \/ @if_primary_term@ semantics). Mirrors +-- the 'putISMPolicyWith' precedent. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing monitor id (or a +-- 409 on a sequence-number mismatch) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +updateMonitorWith :: + MonitorId -> + Monitor -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant MonitorResponse +updateMonitorWith (MonitorId mid) monitor mOcc = + put @StatusDependant endpoint (encode monitor) + where + baseEndpoint = mkEndpoint ["_plugins", "_alerting", "monitors", mid] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries baseEndpoint $ + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'deleteMonitor' deletes a monitor by id via +-- @DELETE /_plugins/_alerting/monitors/{monitor_id}@. +-- +-- The return type 'DeleteMonitorResponse' deviates from the bead's +-- @m 'Acknowledged'@ acceptance: the body never carries an +-- @acknowledged@ key, so an 'Acknowledged' decoder would raise +-- 'EsProtocolException' at runtime (same deviation pattern as +-- bloodhound-04f.3.13 rethrottle). The exact shape is version-dependent +-- and live-verified on OS 1.3.19, 2.19.5 and 3.7.0 (bead +-- bloodhound-z5j): OS 1.3.x returns the full bare Elasticsearch +-- delete-document response; OS 2.x/3.x return only @_id@ + @_version@. +-- See the Haddock on 'DeleteMonitorResponse' for the field-level detail. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing monitor id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteMonitor :: + MonitorId -> + BHRequest StatusDependant DeleteMonitorResponse +deleteMonitor (MonitorId mid) = + delete (mkEndpoint ["_plugins", "_alerting", "monitors", mid]) + +-- | 'searchMonitors' searches the monitor store via +-- @GET /_plugins/_alerting/monitors/_search@. Pass 'Nothing' for the +-- plain empty-body @{}@ request that returns the first page of all +-- monitors; pass @'Just' query@ to paginate (@from@\/@size@) or filter +-- by name, type, enabled state, ... using the standard OpenSearch +-- query DSL carried opaquely in 'monitorsSearchQueryQuery'. +-- +-- The endpoint is documented as GET but, like the core search API, +-- carries the query DSL in the request body; 'getWithBody' sends a +-- GET with a body (mirrors the @GET /_render/template@ precedent). +-- +-- Returns the full search envelope 'SearchMonitorsResponse' so callers +-- can drive pagination and inspect @_shards@ health; use +-- 'searchMonitorsResponseMonitors' to project out just the @['Monitor']@ +-- list. Mirrors the Security Analytics 'searchSAPrePackagedRules' +-- precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchMonitors :: + Maybe MonitorsSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SearchMonitorsResponse) +searchMonitors mQuery = + withBHResponseParsedEsResponse $ + getWithBody @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_alerting", "monitors", "_search"] + body = encode (maybe defaultMonitorsSearchQuery id mQuery) + +-- | 'executeMonitor' runs a monitor's inputs and triggers immediately +-- (out of schedule) via +-- @POST /_plugins/_alerting/monitors/{monitor_id}/_execute@. The +-- endpoint takes no request body; a dry run (which exercises the +-- triggers without dispatching actions to destinations) is requested +-- with the @?dryrun=true@ query parameter, so pass @'Just' +-- ('ExecuteMonitorRequest' {dryrun = Just True})@ to set it. Pass +-- 'Nothing' for a real execution with action dispatch. +-- +-- Returns 'ExecuteMonitorResponse' (typed shell + opaque aeson +-- 'Value's for the per-kind @trigger_results@ \/ @input_results@ \/ +-- @script_actions@ sub-objects). Mirrors the ML Commons @predict@ +-- pragmatic-typing precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid monitor id, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +executeMonitor :: + MonitorId -> + Maybe ExecuteMonitorRequest -> + BHRequest StatusDependant (ParsedEsResponse ExecuteMonitorResponse) +executeMonitor (MonitorId mid) mRequest = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_alerting", "monitors", mid, "_execute"] + `withQueries` dryrunQuery + dryrunQuery = + case mRequest >>= executeMonitorRequestDryrun of + Just True -> [("dryrun", Just "true")] + _ -> [] + +-- | 'getDestinations' lists every configured alerting destination via +-- @GET /_plugins/_alerting/destinations@. The endpoint returns a +-- paging envelope (@{totalDestinations, destinations}@); this wrapper +-- projects out the bare 'Destination' list so the public type matches +-- the bead acceptance (@m [Destination]@). Equivalent to +-- 'getDestinationsWith' with 'defaultDestinationListOptions' (server +-- defaults: @size=20@, @start_index=0@, +-- @sortString=destination.name.keyword@, @sortOrder=asc@). Callers +-- needing paging metadata (@totalDestinations@) or custom filtering +-- should use 'getDestinationsWith'. +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (plugin not installed, +-- RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getDestinations :: + BHRequest StatusDependant [Destination] +getDestinations = + getDestinationsResponseDestinations + <$> getDestinationsWith defaultDestinationListOptions + +-- | 'getDestinationsWith' is the parameterized variant of +-- 'getDestinations': the supplied 'DestinationListOptions' are +-- forwarded as query-string parameters (filtering by +-- 'DestinationListOptions''s @destinationType@, pagination via +-- @size@ \/ @start_index@, sort via @sortString@ \/ @sortOrder@ \/ +-- @missing@, and free-text @searchString@). Pass +-- 'defaultDestinationListOptions' for the plain no-arg GET. Returns +-- the full 'GetDestinationsResponse' envelope so callers can read +-- @totalDestinations@ (the total hit count, which differs from the +-- page size when @size@ truncates the result). +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (plugin not installed, +-- RBAC denial, or the documented HTTP 405 when multi-tenancy is +-- enabled) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getDestinationsWith :: + DestinationListOptions -> + BHRequest StatusDependant GetDestinationsResponse +getDestinationsWith opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_alerting", "destinations"] + `withQueries` destinationListOptionsParams opts + +-- | The Alerting server assigns @id@, @schema_version@, @seq_no@, and +-- @primary_term@ when a destination is first written, so the documented +-- 'createDestination' request body omits them (a caller-supplied @id@ +-- is ignored; @seq_no@\/@primary_term@ are meaningless on a create). +-- This drops those keys from the encoded 'Destination' so the create +-- body matches the documented shape. It is local to the create path: +-- 'updateDestination' and the 'Destination' round-trip keep the full +-- document (server-assigned fields and all). +stripDestinationCreateKeys :: Value -> Value +stripDestinationCreateKeys (Object o) = + Object (deleteSeveral ["id", "schema_version", "seq_no", "primary_term"] o) +stripDestinationCreateKeys v = v + +-- | 'createDestination' creates an alerting destination via the +-- Alerting plugin (@POST /_plugins/_alerting/destinations@). The body +-- is the encoded 'Destination' with the server-assigned @id@, +-- @schema_version@, @seq_no@, and @primary_term@ stripped +-- ('stripDestinationCreateKeys') so it matches the documented +-- create-request shape; the response is the 'DestinationResponse' +-- wrapper carrying the server-assigned indexing metadata and the +-- persisted destination document. +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (invalid destination +-- body, plugin not installed, RBAC denial) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +createDestination :: + Destination -> + BHRequest StatusDependant DestinationResponse +createDestination destination = + post (mkEndpoint ["_plugins", "_alerting", "destinations"]) body + where + body = encode (stripDestinationCreateKeys (toJSON destination)) + +-- | 'updateDestination' replaces a destination via +-- @PUT /_plugins/_alerting/destinations/{destination_id}@. The body is +-- the encoded 'Destination'; the response is the same +-- 'DestinationResponse' wrapper as 'createDestination' (with the +-- incremented @_version@ and @_seq_no@). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing destination id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateDestination :: + DestinationId -> + Destination -> + BHRequest StatusDependant DestinationResponse +updateDestination (DestinationId did) destination = + put (mkEndpoint ["_plugins", "_alerting", "destinations", did]) (encode destination) + +-- | 'deleteDestination' deletes a destination by id via +-- @DELETE /_plugins/_alerting/destinations/{destination_id}@. +-- +-- The return type 'DeleteDestinationResponse' deviates from a naive +-- @m 'Acknowledged'@ acceptance for the same reason as 'deleteMonitor': +-- the OpenSearch alerting delete endpoint returns the standard +-- Elasticsearch delete-document response (bare, with a @_shards@ +-- report, NO @acknowledged@ key), so an 'Acknowledged' decoder would +-- raise 'EsProtocolException' at runtime. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing destination id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteDestination :: + DestinationId -> + BHRequest StatusDependant DeleteDestinationResponse +deleteDestination (DestinationId did) = + delete (mkEndpoint ["_plugins", "_alerting", "destinations", did]) + +-- ========================================================================= +-- Alerting plugin: alerts, acknowledge, stats, email accounts/groups +-- ========================================================================= + +-- | 'getAlertsWith' lists alert documents via +-- @GET /_plugins/_alerting/monitors/alerts@, forwarding the supplied +-- 'GetAlertsOptions' as query-string parameters (filtering by +-- @alertState@ \/ @severityLevel@ \/ @monitorId@, pagination via +-- @size@ \/ @startIndex@, sort via @sortString@ \/ @sortOrder@ \/ +-- @missing@, free-text @searchString@, and @workflowIds@ for chained +-- alerts on OpenSearch 2.9+). Pass 'defaultGetAlertsOptions' for the +-- plain no-arg GET. Returns the full 'GetAlertsResponse' envelope so +-- callers can read @totalAlerts@ (the total hit count, which differs +-- from the page size when @size@ truncates the result). Mirrors the +-- 'getDestinationsWith' precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getAlertsWith :: + GetAlertsOptions -> + BHRequest StatusDependant GetAlertsResponse +getAlertsWith opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_alerting", "monitors", "alerts"] + `withQueries` getAlertsOptionsParams opts + +-- | 'getAlerts' lists every active alert. Equivalent to 'getAlertsWith' +-- with 'defaultGetAlertsOptions' (server defaults apply) and projects +-- out the bare @['Alert']@ list (the paging envelope is discarded). +-- Callers needing @totalAlerts@ or custom filtering should use +-- 'getAlertsWith'. Mirrors the 'getDestinations' precedent. +getAlerts :: + BHRequest StatusDependant [Alert] +getAlerts = + getAlertsResponseAlerts <$> getAlertsWith defaultGetAlertsOptions + +-- | 'acknowledgeAlert' acknowledges one or more active alerts of a +-- monitor via +-- @POST /_plugins/_alerting/monitors/{monitor_id}/_acknowledge/alerts@. +-- Alerts already in an @ERROR@, @COMPLETED@, or @ACKNOWLEDGED@ state are +-- not transitioned and are echoed in the @failed@ array of the +-- 'AcknowledgeAlertResponse'. The request body is the encoded +-- 'AcknowledgeAlertRequest' (@{"alerts":[ids]}@). +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid monitor id, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +acknowledgeAlert :: + MonitorId -> + [Text] -> + BHRequest StatusDependant AcknowledgeAlertResponse +acknowledgeAlert (MonitorId mid) alertIds = + post + (mkEndpoint ["_plugins", "_alerting", "monitors", mid, "_acknowledge", "alerts"]) + (encode (AcknowledgeAlertRequest alertIds)) + +-- | 'getMonitorStats' fetches alerting scheduler statistics via +-- @GET /_plugins/_alerting/stats[/...]@. The four documented forms are +-- selected by the two optional arguments: +-- +-- * @Nothing Nothing@ — @GET /_plugins/_alerting/stats@ (cluster-wide) +-- * @'Nothing' metric@ — @GET /_plugins/_alerting/stats/{metric}@ +-- * @nodeId 'Nothing'@ — @GET /_plugins/_alerting/{node-id}/stats@ +-- * @nodeId metric@ — @GET /_plugins/_alerting/{node-id}/stats/{metric}@ +-- +-- The response is large and partly node-specific; the stable shell is +-- decoded into 'MonitorStats' and the variable @nodes@ map is kept as +-- an opaque aeson 'Value' (see 'monitorStatsOther'). Mirrors the +-- 'getSQLStats' pragmatic-typing precedent. +-- +-- Surfaced as 'StatusDependant' so a 404 (Alerting plugin disabled +-- \/ unknown metric \/ unknown node id) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +getMonitorStats :: + Maybe Text -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse MonitorStats) +getMonitorStats mNodeId mMetric = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = case mNodeId of + Nothing -> + case mMetric of + Nothing -> mkEndpoint ["_plugins", "_alerting", "stats"] + Just metric -> mkEndpoint ["_plugins", "_alerting", "stats", metric] + Just nodeId -> + case mMetric of + Nothing -> mkEndpoint ["_plugins", "_alerting", nodeId, "stats"] + Just metric -> mkEndpoint ["_plugins", "_alerting", nodeId, "stats", metric] + +-- | 'createEmailAccount' creates a legacy alerting email account via +-- @POST /_plugins/_alerting/destinations/email_accounts@. The body is +-- the encoded 'EmailAccount' (the server assigns @_id@, @_version@, +-- @_seq_no@, @_primary_term@, and @schema_version@ on write); the +-- response is the 'EmailAccountResponse' wrapper. Mirrors +-- 'createDestination'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createEmailAccount :: + EmailAccount -> + BHRequest StatusDependant EmailAccountResponse +createEmailAccount account = + post (mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts"]) (encode account) + +-- | 'getEmailAccount' fetches a single email account by id via +-- @GET /_plugins/_alerting/destinations/email_accounts/{id}@. The +-- endpoint returns the 'EmailAccountResponse' wrapper on the wire +-- (@{_id,_version,_seq_no,_primary_term, email_account:{...}}@); the +-- wrapper is decoded and the 'EmailAccount' is projected out so the +-- public type matches the 'getMonitor' precedent. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing id decodes as +-- an 'EsError' rather than throwing. +getEmailAccount :: + EmailAccountId -> + BHRequest StatusDependant EmailAccount +getEmailAccount (EmailAccountId eid) = + emailAccountResponseEmailAccount <$> get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts", eid] + +-- | 'updateEmailAccount' replaces an email account via +-- @PUT /_plugins/_alerting/destinations/email_accounts/{id}@. +-- Equivalent to 'updateEmailAccountWith' with 'Nothing' (no +-- optimistic-concurrency guard). Mirrors 'updateDestination'. +updateEmailAccount :: + EmailAccountId -> + EmailAccount -> + BHRequest StatusDependant EmailAccountResponse +updateEmailAccount emailAccountId account = + updateEmailAccountWith emailAccountId account Nothing + +-- | 'updateEmailAccountWith' replaces an email account with an optional +-- optimistic-concurrency guard (@if_seq_no@ \/ @if_primary_term@). See +-- 'updateMonitorWith' for the guard semantics. Mirrors the +-- 'updateMonitorWith' precedent. +-- +-- Surfaced as 'StatusDependant' so a 404 (or a 409 on a sequence-number +-- mismatch) decodes as an 'EsError' rather than throwing. +updateEmailAccountWith :: + EmailAccountId -> + EmailAccount -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant EmailAccountResponse +updateEmailAccountWith (EmailAccountId eid) account mOcc = + put @StatusDependant endpoint (encode account) + where + baseEndpoint = + mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts", eid] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries + baseEndpoint + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'deleteEmailAccount' deletes an email account by id via +-- @DELETE /_plugins/_alerting/destinations/email_accounts/{id}@. Returns +-- the bare Elasticsearch delete-document response (see +-- 'DeleteEmailAccountResponse' for why this deviates from +-- @m 'Acknowledged'@). Mirrors 'deleteDestination'. +deleteEmailAccount :: + EmailAccountId -> + BHRequest StatusDependant DeleteEmailAccountResponse +deleteEmailAccount (EmailAccountId eid) = + delete (mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts", eid]) + +-- | 'createEmailGroup' creates a legacy alerting email group via +-- @POST /_plugins/_alerting/destinations/email_groups@. Mirrors +-- 'createEmailAccount'. +createEmailGroup :: + EmailGroup -> + BHRequest StatusDependant EmailGroupResponse +createEmailGroup group = + post (mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups"]) (encode group) + +-- | 'getEmailGroup' fetches a single email group by id via +-- @GET /_plugins/_alerting/destinations/email_groups/{id}@, projecting +-- out the 'EmailGroup'. Mirrors 'getEmailAccount'. +getEmailGroup :: + EmailGroupId -> + BHRequest StatusDependant EmailGroup +getEmailGroup (EmailGroupId gid) = + emailGroupResponseEmailGroup <$> get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups", gid] + +-- | 'updateEmailGroup' replaces an email group. Equivalent to +-- 'updateEmailGroupWith' with 'Nothing'. Mirrors 'updateEmailAccount'. +updateEmailGroup :: + EmailGroupId -> + EmailGroup -> + BHRequest StatusDependant EmailGroupResponse +updateEmailGroup emailGroupId group = + updateEmailGroupWith emailGroupId group Nothing + +-- | 'updateEmailGroupWith' replaces an email group with an optional +-- optimistic-concurrency guard. Mirrors 'updateEmailAccountWith'. +updateEmailGroupWith :: + EmailGroupId -> + EmailGroup -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant EmailGroupResponse +updateEmailGroupWith (EmailGroupId gid) group mOcc = + put @StatusDependant endpoint (encode group) + where + baseEndpoint = + mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups", gid] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries + baseEndpoint + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'deleteEmailGroup' deletes an email group by id via +-- @DELETE /_plugins/_alerting/destinations/email_groups/{id}@. Mirrors +-- 'deleteEmailAccount'. +deleteEmailGroup :: + EmailGroupId -> + BHRequest StatusDependant DeleteEmailGroupResponse +deleteEmailGroup (EmailGroupId gid) = + delete (mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups", gid]) + +-- | 'getDestination' fetches a single destination by id via +-- @GET /_plugins/_alerting/destinations/{id}@. See +-- 'Database.Bloodhound.OpenSearch2.Requests.getDestination' for details. +getDestination :: + DestinationId -> + BHRequest StatusDependant GetDestinationsResponse +getDestination (DestinationId did) = + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", did] + +-- | 'searchEmailAccounts' searches the email account store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchEmailAccounts'. +searchEmailAccounts :: + Maybe EmailAccountSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SearchEmailAccountsResponse) +searchEmailAccounts mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", "email_accounts", "_search"] + body = encode (maybe defaultEmailAccountSearchQuery id mQuery) + +-- | 'searchEmailGroups' searches the email group store. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchEmailGroups'. +searchEmailGroups :: + Maybe EmailGroupSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SearchEmailGroupsResponse) +searchEmailGroups mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_alerting", "destinations", "email_groups", "_search"] + body = encode (maybe defaultEmailGroupSearchQuery id mQuery) + +-- | 'searchFindings' searches the findings index. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchFindings'. +searchFindings :: + Maybe FindingsSearchOptions -> + BHRequest StatusDependant (ParsedEsResponse SearchFindingsResponse) +searchFindings mOpts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_alerting", "findings", "_search"] + `withQueries` findingsSearchOptionsParams opts + opts = maybe defaultFindingsSearchOptions id mOpts + +-- | 'createComment' adds a comment to an alert. See +-- 'Database.Bloodhound.OpenSearch2.Requests.createComment'. +createComment :: + Text -> + CreateCommentRequest -> + BHRequest StatusDependant CommentResponse +createComment alertId req = + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_alerting", "comments", alertId] + +-- | 'updateComment' modifies a comment. See +-- 'Database.Bloodhound.OpenSearch2.Requests.updateComment'. +updateComment :: + CommentId -> + UpdateCommentRequest -> + BHRequest StatusDependant CommentResponse +updateComment (CommentId cid) req = + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_alerting", "comments", cid] + +-- | 'searchComments' searches comments. See +-- 'Database.Bloodhound.OpenSearch2.Requests.searchComments'. +searchComments :: + Maybe CommentSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SearchCommentsResponse) +searchComments mQuery = + withBHResponseParsedEsResponse $ + getWithBody @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_alerting", "comments", "_search"] + body = encode (maybe defaultCommentSearchQuery id mQuery) + +-- | 'deleteComment' removes a comment. See +-- 'Database.Bloodhound.OpenSearch2.Requests.deleteComment'. +deleteComment :: + CommentId -> + BHRequest StatusDependant DeleteCommentResponse +deleteComment (CommentId cid) = + delete (mkEndpoint ["_plugins", "_alerting", "comments", cid]) + +-- ========================================================================= +-- Flow Framework plugin +-- ========================================================================= + +-- | 'createWorkflow' calls the Flow Framework plugin Create Workflow API +-- (@POST /_plugins/_flow_framework/workflow@) with no optional query +-- parameters. Persists the supplied 'WorkflowTemplate' and returns the +-- server-assigned 'WorkflowId' in 'createWorkflowResponseWorkflowId'. +-- The template is /not/ provisioned — call 'provisionWorkflow' to +-- materialize resources, or use 'createWorkflowWith' with +-- @provision = Just True@ to chain the provision step. +-- +-- Equivalent to 'createWorkflowWith' with 'defaultCreateWorkflowOptions'. +-- +-- For more information see +-- . +createWorkflow :: + WorkflowTemplate -> + BHRequest StatusDependant (ParsedEsResponse CreateWorkflowResponse) +createWorkflow = createWorkflowWith defaultCreateWorkflowOptions + +-- | 'createWorkflowWith' is the parameterized variant of 'createWorkflow': +-- the supplied 'CreateWorkflowOptions' are forwarded as query-string +-- parameters. Pass @provision = Just True@ to chain a provision step +-- (saving a separate 'provisionWorkflow' round trip); pass +-- @validation = Just ValidationNone@ to store a work-in-progress +-- template that would fail full validation; pass @use_case = Just name@ +-- to use a built-in +-- +-- as the body (the request body is then ignored). Pass +-- @waitForCompletionTimeout = Just "2s"@ with @provision = Just True@ +-- to block until the provision step settles or the timeout elapses +-- (in which case the response carries the current 'WorkflowState' and +-- any 'ResourceCreated' entries). +-- +-- For more information see +-- . +createWorkflowWith :: + CreateWorkflowOptions -> + WorkflowTemplate -> + BHRequest StatusDependant (ParsedEsResponse CreateWorkflowResponse) +createWorkflowWith opts tmpl = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode tmpl) + where + endpoint = + mkEndpoint ["_plugins", "_flow_framework", "workflow"] + `withQueries` createWorkflowOptionsParams opts + +-- | 'getWorkflow' calls the Flow Framework plugin Get Workflow API +-- (@GET /_plugins/_flow_framework/workflow/{workflow_id}@). Returns the +-- stored 'WorkflowTemplate' for the supplied id — the same shape that +-- was supplied to 'createWorkflow'. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown workflow id, or the +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getWorkflow :: + WorkflowId -> + BHRequest StatusDependant (ParsedEsResponse WorkflowTemplate) +getWorkflow workflowId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_flow_framework", "workflow", unWorkflowId workflowId] + +-- | 'provisionWorkflow' calls the Flow Framework plugin Provision +-- Workflow API +-- (@POST /_plugins/_flow_framework/workflow/{workflow_id}/_provision@) +-- with no optional query parameters and an empty body. Walks the +-- @provision@ entry of the stored template and creates resources in +-- dependency order. Returns immediately with the 'WorkflowId' in +-- 'createWorkflowResponseWorkflowId'; poll the separate +-- 'getWorkflowState' API to observe progress, or use +-- 'provisionWorkflowWith' with a @wait_for_completion_timeout@ to +-- block. +-- +-- A workflow can only be provisioned once. To re-provision, the +-- resources must first be deprovisioned via 'deprovisionWorkflow'. +-- +-- For more information see +-- . +provisionWorkflow :: + WorkflowId -> + BHRequest StatusDependant (ParsedEsResponse CreateWorkflowResponse) +provisionWorkflow workflowId = provisionWorkflowWith workflowId defaultProvisionOptions + +-- | 'provisionWorkflowWith' is the parameterized variant of +-- 'provisionWorkflow': the supplied 'ProvisionOptions' are forwarded +-- both as query-string parameters (the +-- @wait_for_completion_timeout@ and any substitution keys in +-- 'provisionOptionsSubstitutions') and /or/ as the request body +-- (the substitution map alone). Pass a timeout to block until the +-- provision settles or the timeout elapses (in which case the +-- response carries the current 'WorkflowState' and any +-- 'ResourceCreated' entries). +-- +-- For more information see +-- . +provisionWorkflowWith :: + WorkflowId -> + ProvisionOptions -> + BHRequest StatusDependant (ParsedEsResponse CreateWorkflowResponse) +provisionWorkflowWith workflowId opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = + mkEndpoint ["_plugins", "_flow_framework", "workflow", unWorkflowId workflowId, "_provision"] + `withQueries` provisionOptionsParams opts + body = maybe emptyBody encode (provisionOptionsSubstitutions opts) + +-- | 'deleteWorkflow' calls the Flow Framework plugin Delete Workflow +-- API (@DELETE /_plugins/_flow_framework/workflow/{workflow_id}@) +-- with no optional query parameters. Removes the stored template. +-- Does /not/ deprovision resources — those must be removed via +-- 'deprovisionWorkflow' first. +-- +-- The response is the raw index-delete envelope ('IndexedDocument', +-- the same shape returned by 'deleteISMPolicy' and 'deleteModel'), +-- not 'Acknowledged'. Pass 'deleteWorkflowWith' with +-- @clearStatus = Just True@ to also delete the workflow state when +-- provisioning is not @PROVISIONING@. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown workflow id, or the +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- Note: the plugin may return @result = "not_found"@ in the body for +-- an unknown id rather than HTTP 404 — verify against a live cluster +-- if you depend on the distinction. +-- +-- For more information see +-- . +deleteWorkflow :: + WorkflowId -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteWorkflow workflowId = deleteWorkflowWith workflowId defaultDeleteWorkflowOptions + +-- | 'deleteWorkflowWith' is the parameterized variant of +-- 'deleteWorkflow': the supplied 'DeleteWorkflowOptions' are +-- forwarded as query-string parameters. Pass +-- @clearStatus = Just True@ to also delete the workflow state +-- document alongside the template (the plugin only honors the flag +-- when the provisioning state is not @PROVISIONING@). +-- +-- For more information see +-- . +deleteWorkflowWith :: + WorkflowId -> + DeleteWorkflowOptions -> + BHRequest StatusDependant (ParsedEsResponse IndexedDocument) +deleteWorkflowWith workflowId opts = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_flow_framework", "workflow", unWorkflowId workflowId] + `withQueries` deleteWorkflowOptionsParams opts + +-- | 'searchWorkflows' calls the Flow Framework plugin Search Workflows +-- API (@GET\/POST /_plugins/_flow_framework/workflow/_search@) with the +-- supplied 'Search' body (the implementation uses @POST@ so a query +-- body can be supplied). Returns a standard 'SearchResult' whose hits +-- are the stored 'WorkflowTemplate' documents. Errors — notably a 403 +-- when the @plugins.flow_framework.enabled@ setting is off — are +-- returned as a 'ParsedEsResponse' ('Left' 'EsError'), matching every +-- other endpoint in this workflow family. +-- +-- The response body shape is undocumented on the OpenSearch site, but +-- the plugin (@RestSearchWorkflowAction@) builds a standard OpenSearch +-- search response envelope, so the conventional 'SearchResult' decode +-- applies. Verify against a live cluster if you depend on a field the +-- search envelope does not normally carry. +-- +-- For more information see +-- . +searchWorkflows :: + (FromJSON a) => + Search -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult a)) +searchWorkflows search = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode search) + where + endpoint = + mkEndpoint ["_plugins", "_flow_framework", "workflow", "_search"] + +-- | 'updateWorkflow' calls the Flow Framework plugin Create-or-Update +-- Workflow API with @PUT@ +-- (@PUT /_plugins/_flow_framework/workflow/{workflow_id}@) and no +-- optional query parameters — the full 'WorkflowTemplate' body replaces +-- the stored template (only allowed before the first provision). +-- +-- Equivalent to 'updateWorkflowWith' with 'defaultCreateWorkflowOptions'. +-- The update endpoint reuses the create endpoint's options record +-- (the @update_fields@ and @reprovision@ flags only do anything on the +-- PUT path). +-- +-- For more information see +-- . +updateWorkflow :: + WorkflowId -> + WorkflowTemplate -> + BHRequest StatusDependant (ParsedEsResponse CreateWorkflowResponse) +updateWorkflow workflowId = updateWorkflowWith workflowId defaultCreateWorkflowOptions + +-- | 'updateWorkflowWith' is the parameterized variant of +-- 'updateWorkflow': the supplied 'CreateWorkflowOptions' are forwarded +-- as query-string parameters. Pass @updateFields = Just True@ to patch +-- only the body fields supplied (rather than replace the whole +-- template); pass @reprovision = Just True@ with a full template to +-- re-provision an already-provisioned workflow; pass +-- @provision = Just True@ (with @waitForCompletionTimeout@) to chain a +-- provision step. The plugin rejects combinations it does not allow +-- (e.g. @provision@ and @update_fields@ together) with a 4xx that +-- surfaces as an 'EsError'. +-- +-- For more information see +-- . +updateWorkflowWith :: + WorkflowId -> + CreateWorkflowOptions -> + WorkflowTemplate -> + BHRequest StatusDependant (ParsedEsResponse CreateWorkflowResponse) +updateWorkflowWith workflowId opts tmpl = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode tmpl) + where + endpoint = + mkEndpoint ["_plugins", "_flow_framework", "workflow", unWorkflowId workflowId] + `withQueries` createWorkflowOptionsParams opts + +-- | 'deprovisionWorkflow' calls the Flow Framework plugin Deprovision +-- Workflow API +-- (@POST /_plugins/_flow_framework/workflow/{workflow_id}/_deprovision@) +-- with no optional query parameters and an empty body. Walks the +-- @provision@ entry in reverse order, deleting the resources the +-- workflow created. On full success the workflow returns to the +-- @NOT_STARTED@ state and can be re-provisioned via 'provisionWorkflow'. +-- +-- Equivalent to 'deprovisionWorkflowWith' with +-- 'defaultDeprovisionWorkflowOptions'. +-- +-- For more information see +-- . +deprovisionWorkflow :: + WorkflowId -> + BHRequest StatusDependant (ParsedEsResponse DeprovisionWorkflowResponse) +deprovisionWorkflow workflowId = + deprovisionWorkflowWith workflowId defaultDeprovisionWorkflowOptions + +-- | 'deprovisionWorkflowWith' is the parameterized variant of +-- 'deprovisionWorkflow': the supplied 'DeprovisionWorkflowOptions' are +-- forwarded as query-string parameters. Pass +-- @allowDelete = Just \"my-index,my-pipeline\"@ to acknowledge deletion +-- of @index_name@ \/ @pipeline_id@ resources (the plugin returns 403 +-- without it when such resources are present). +-- +-- Doc ambiguity: a partial deprovision answers @202 ACCEPTED@ with an +-- @error@ field; that body does not decode as +-- 'DeprovisionWorkflowResponse' and instead surfaces as an 'EsError'. +-- +-- For more information see +-- . +deprovisionWorkflowWith :: + WorkflowId -> + DeprovisionWorkflowOptions -> + BHRequest StatusDependant (ParsedEsResponse DeprovisionWorkflowResponse) +deprovisionWorkflowWith workflowId opts = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint emptyBody + where + endpoint = + mkEndpoint ["_plugins", "_flow_framework", "workflow", unWorkflowId workflowId, "_deprovision"] + `withQueries` deprovisionWorkflowOptionsParams opts + +-- | 'getWorkflowState' calls the Flow Framework plugin Get Workflow +-- State API +-- (@GET /_plugins/_flow_framework/workflow/{workflow_id}/_status@) +-- with no optional query parameters. Returns the provisioning state +-- and, when present, the list of resources created so far. Poll this +-- to observe the progress of a fire-and-forget 'provisionWorkflow'. +-- The in-flight state is the wire value @PROVISIONING@, decoded to +-- the typed 'WorkflowStateProvisioning' constructor; unknown values +-- parse into 'WorkflowStateOther' so decode stays total across plugin +-- releases. +-- +-- Equivalent to 'getWorkflowStateWith' with 'defaultWorkflowStateOptions'. +-- +-- For more information see +-- . +getWorkflowState :: + WorkflowId -> + BHRequest StatusDependant (ParsedEsResponse WorkflowStateResponse) +getWorkflowState workflowId = + getWorkflowStateWith workflowId defaultWorkflowStateOptions + +-- | 'getWorkflowStateWith' is the parameterized variant of +-- 'getWorkflowState': the supplied 'WorkflowStateOptions' are forwarded +-- as query-string parameters. Pass @all = Just True@ to additionally +-- retrieve @provisioning_progress@, @provision_start_time@, +-- @provision_end_time@, @user@ and @user_outputs@ (captured verbatim in +-- 'workflowStateResponseOther'). +-- +-- For more information see +-- . +getWorkflowStateWith :: + WorkflowId -> + WorkflowStateOptions -> + BHRequest StatusDependant (ParsedEsResponse WorkflowStateResponse) +getWorkflowStateWith workflowId opts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_flow_framework", "workflow", unWorkflowId workflowId, "_status"] + `withQueries` workflowStateOptionsParams opts + +-- | 'getWorkflowSteps' calls the Flow Framework plugin Get Workflow Steps +-- API (@GET /_plugins/_flow_framework/workflow/_steps@) with no optional +-- query parameters. Returns the catalogue of workflow step @type@s +-- registered by the plugin, each with its @inputs@, @outputs@ and +-- @required_plugins@. Useful for introspecting which step types a given +-- cluster supports before authoring a 'WorkflowTemplate'. +-- +-- Equivalent to 'getWorkflowStepsWith' with +-- 'defaultWorkflowStepsOptions'. +-- +-- For more information see +-- . +getWorkflowSteps :: + BHRequest StatusDependant (ParsedEsResponse WorkflowStepsResponse) +getWorkflowSteps = getWorkflowStepsWith defaultWorkflowStepsOptions + +-- | 'getWorkflowStepsWith' is the parameterized variant of +-- 'getWorkflowSteps': the supplied 'WorkflowStepsOptions' are forwarded +-- as query-string parameters. Pass @step = Just \"create_connector\"@ +-- (or a comma-separated list) to fetch a subset of steps rather than the +-- full catalogue. +-- +-- For more information see +-- . +getWorkflowStepsWith :: + WorkflowStepsOptions -> + BHRequest StatusDependant (ParsedEsResponse WorkflowStepsResponse) +getWorkflowStepsWith opts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_flow_framework", "workflow", "_steps"] + `withQueries` workflowStepsOptionsParams opts + +-- | 'searchWorkflowState' calls the Flow Framework plugin Search Workflow +-- State API (@GET\/POST /_plugins/_flow_framework/workflow/state/_search@) +-- with the supplied 'Search' body (the implementation uses @POST@ so a +-- query body can be supplied, matching 'searchWorkflows'). Returns a +-- standard 'SearchResult' whose hits are the stored workflow-state +-- documents — the same shape returned by the Get Workflow State API +-- ('WorkflowStateResponse'), whose field names (@state@, +-- @resources_created@, ...) are the searchable terms. +-- +-- The response body shape is undocumented on the OpenSearch site, but the +-- plugin (@RestSearchWorkflowStateAction@) builds a standard OpenSearch +-- search response envelope, so the conventional 'SearchResult' decode +-- applies. Verify against a live cluster if you depend on a field the +-- search envelope does not normally carry. +-- +-- For more information see +-- . +searchWorkflowState :: + (FromJSON a) => + Search -> + BHRequest StatusDependant (ParsedEsResponse (SearchResult a)) +searchWorkflowState search = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode search) + where + endpoint = + mkEndpoint ["_plugins", "_flow_framework", "workflow", "state", "_search"] + +-- ========================================================================= +-- Security Analytics plugin +-- ========================================================================= + +-- | 'createSADetector' creates a Security Analytics detector +-- (@POST /_plugins/_security_analytics/detectors@). The body is the +-- encoded 'SADetector'; the response is the 'SADetectorResponse' +-- wrapper carrying the server-assigned @_id@, @_version@, and the +-- persisted detector document (with server-injected @last_update_time@ +-- and @enabled_time@). +-- +-- Surfaced as 'StatusDependant' so a 4xx\/5xx (invalid detector body, +-- plugin not installed, RBAC denial) raises a structured 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +createSADetector :: + SADetector -> + BHRequest StatusDependant SADetectorResponse +createSADetector detector = + post (mkEndpoint ["_plugins", "_security_analytics", "detectors"]) (encode detector) + +-- | 'getSADetector' fetches a single detector by id via +-- @GET /_plugins/_security_analytics/detectors/{detector_id}@. The +-- endpoint returns the 'SADetectorResponse' wrapper on the wire +-- (@{_id,_version, detector:{...}}@); the wrapper is decoded and the +-- 'SADetector' is projected out so the public type matches the bead +-- acceptance (@m 'SADetector'@). Callers needing the indexing +-- metadata can build the underlying request directly. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getSADetector :: + DetectorId -> + BHRequest StatusDependant SADetector +getSADetector (DetectorId did) = + saDetectorResponseDetector <$> get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_security_analytics", "detectors", did] + +-- | 'updateSADetector' replaces a Security Analytics detector via +-- @PUT /_plugins/_security_analytics/detectors/{detector_id}@. The +-- body is the encoded 'SADetector'; the response is the same +-- 'SADetectorResponse' wrapper as 'createSADetector' (with the +-- incremented @_version@ and a refreshed @last_update_time@). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id +-- (or a 4xx for an invalid detector body) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +updateSADetector :: + DetectorId -> + SADetector -> + BHRequest StatusDependant SADetectorResponse +updateSADetector (DetectorId did) detector = + put (mkEndpoint ["_plugins", "_security_analytics", "detectors", did]) (encode detector) + +-- | 'deleteSADetector' deletes a Security Analytics detector via +-- @DELETE /_plugins/_security_analytics/detectors/{detector_id}@. +-- Returns 'DeleteSADetectorResponse', which is NOT an 'Acknowledged' +-- ack (an 'Acknowledged' decoder would raise 'EsProtocolException' at +-- runtime — same deviation pattern as the Alerting 'deleteMonitor'). +-- The exact shape is version-dependent and live-verified on OS 2.19.5 +-- and 3.7.0 (bead bloodhound-z5j): OS 2.x/3.x return only +-- @_id@ + @_version@. OS 1.3.x does not ship the Security Analytics +-- plugin. See the Haddock on 'DeleteSADetectorResponse' for detail. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteSADetector :: + DetectorId -> + BHRequest StatusDependant DeleteSADetectorResponse +deleteSADetector (DetectorId did) = + delete (mkEndpoint ["_plugins", "_security_analytics", "detectors", did]) + +-- | 'searchSAPrePackagedRules' searches the pre-packaged Sigma rules +-- index (@POST /_plugins/_security_analytics/rules/_search?pre_packaged=true@) +-- via the Security Analytics plugin. Pass 'Nothing' for the plain +-- empty-body @{}@ POST that returns the first page of all +-- pre-packaged rules; pass @'Just' query@ to paginate (@from@\/@size@) +-- or filter by category, tag, level, ... using the standard OpenSearch +-- query DSL carried opaquely in 'saRulesQueryQuery'. +-- +-- Returns the full search envelope 'SARulesSearchResponse' so callers +-- can drive pagination and inspect @_shards@ health; use +-- 'saRulesSearchResponseRules' to project out just the @['SARule']@ +-- list. +-- +-- /Deviation from the bead acceptance/ (bloodhound-04f.6.11.3): the +-- bead names a @GET /_plugins/_security_analytics/rules@ endpoint +-- that does not exist on the server. Rule retrieval is via the +-- search endpoints; this function and 'searchSACustomRules' are +-- shipped instead of the bead's @getSARules :: m [SARule]@, mirroring +-- the bloodhound-04f.6.7.4 'deleteMonitor' precedent (bead +-- acceptance typed as a simpler shape than the real wire). See the +-- changelog entry for bloodhound-04f.6.11.3 for the full rationale. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchSAPrePackagedRules :: + Maybe SARulesQuery -> + BHRequest StatusDependant (ParsedEsResponse SARulesSearchResponse) +searchSAPrePackagedRules = searchSARules True + +-- | 'searchSACustomRules' searches the custom Sigma rules index +-- (@POST /_plugins/_security_analytics/rules/_search?pre_packaged=false@). +-- Otherwise identical in shape and semantics to +-- 'searchSAPrePackagedRules'; see that function's Haddock for the +-- query-body handling and the bead-acceptance deviation note. +-- +-- For more information see +-- . +searchSACustomRules :: + Maybe SARulesQuery -> + BHRequest StatusDependant (ParsedEsResponse SARulesSearchResponse) +searchSACustomRules = searchSARules False + +-- | Shared body of 'searchSAPrePackagedRules' and 'searchSACustomRules': +-- POSTs the (possibly-empty) query body to the rules search endpoint +-- with the @pre_packaged@ query flag set accordingly. +searchSARules :: + Bool -> + Maybe SARulesQuery -> + BHRequest StatusDependant (ParsedEsResponse SARulesSearchResponse) +searchSARules prePackaged mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + baseEndpoint = mkEndpoint ["_plugins", "_security_analytics", "rules", "_search"] + endpoint = + withQueries + baseEndpoint + [ ("pre_packaged", Just (if prePackaged then "true" else "false")) + ] + body = encode (maybe defaultSARulesQuery id mQuery) + +-- | 'createSACustomRule' creates a custom Sigma rule via +-- @POST /_plugins/_security_analytics/rules?category={logtype}@. +-- The request body is the /raw Sigma YAML text/ (NOT JSON-encoded): +-- the Security Analytics plugin parses Sigma YAML directly, even +-- though the request carries an @application/json@ content type. The +-- supplied 'SADetectorType' selects the rule's @category@ query +-- parameter (rendered via 'saDetectorTypeText'); pass the full Sigma +-- rule document as 'Text'. +-- +-- Returns 'SARuleResponse' (@{_id, _version, rule}@), where the inner +-- 'SARule' carries the server-normalised typed fields plus the +-- original YAML serialised in 'saRuleRule'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid Sigma, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +createSACustomRule :: + SADetectorType -> + Text -> + BHRequest StatusDependant SARuleResponse +createSACustomRule category sigmaYaml = + post endpoint (BL.fromStrict (TE.encodeUtf8 sigmaYaml)) + where + endpoint = + withQueries + (mkEndpoint ["_plugins", "_security_analytics", "rules"]) + [("category", Just (saDetectorTypeText category))] + +-- | 'updateSACustomRule' replaces a custom Sigma rule via +-- @PUT /_plugins/_security_analytics/rules/{id}?category={logtype}[&forced=true]@. +-- Like 'createSACustomRule' the body is the raw Sigma YAML text (not +-- JSON). The @forced@ flag, when 'True', forces the update even when +-- the rule is actively referenced by detectors (the server returns a +-- @500@ otherwise); when 'False' the @forced@ query parameter is +-- omitted. Returns the updated 'SARuleResponse'. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing rule id (or a +-- 4xx\/5xx for an invalid body or an un-forced update of a referenced +-- rule) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateSACustomRule :: + RuleId -> + SADetectorType -> + Bool -> + Text -> + BHRequest StatusDependant SARuleResponse +updateSACustomRule (RuleId rid) category forced sigmaYaml = + put endpoint (BL.fromStrict (TE.encodeUtf8 sigmaYaml)) + where + baseEndpoint = mkEndpoint ["_plugins", "_security_analytics", "rules", rid] + endpoint = + withQueries baseEndpoint $ + ("category", Just (saDetectorTypeText category)) + : [("forced", Just "true") | forced] + +-- | 'deleteSACustomRule' deletes a custom Sigma rule via +-- @DELETE /_plugins/_security_analytics/rules/{id}[?forced=true]@. +-- The @forced@ flag, when 'True', forces the delete even when the rule +-- is actively referenced by detectors; when 'False' the @forced@ query +-- parameter is omitted. There is no request body. +-- +-- Returns the bare Elasticsearch delete-document response +-- ('DeleteSARuleResponse', wire shape +-- @{_index,_id,_version,result,forced_refresh,_shards,_seq_no,_primary_term}@) +-- — NOT an 'Acknowledged' ack, which would raise 'EsProtocolException' +-- at runtime. Same deviation pattern as 'deleteSADetector'. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing rule id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteSACustomRule :: + RuleId -> + Bool -> + BHRequest StatusDependant DeleteSARuleResponse +deleteSACustomRule (RuleId rid) forced = + delete endpoint + where + endpoint = + withQueries + (mkEndpoint ["_plugins", "_security_analytics", "rules", rid]) + [("forced", Just "true") | forced] + +-- | 'searchSADetectors' searches the detector store via +-- @POST /_plugins/_security_analytics/detectors/_search@. Pass +-- 'Nothing' for the plain empty-body @{}@ POST that returns the first +-- page of all detectors; pass @'Just' query@ to paginate +-- (@from@\/@size@) or filter by name, type, enabled state, ... using +-- the standard OpenSearch query DSL carried opaquely in +-- 'saDetectorsSearchQueryQuery'. Mirrors 'searchSAPrePackagedRules' +-- (without the @pre_packaged@ query flag, which is rule-specific). +-- +-- Returns the full search envelope 'SADetectorsSearchResponse' so +-- callers can drive pagination and inspect @_shards@ health; use +-- 'saDetectorsSearchResponseDetectors' to project out just the +-- @['SADetector']@ list. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchSADetectors :: + Maybe SADetectorsSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SADetectorsSearchResponse) +searchSADetectors mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_security_analytics", "detectors", "_search"] + body = encode (maybe defaultSADetectorsSearchQuery id mQuery) + +-- | 'getSAMappingsView' returns a view of the fields contained in an +-- index used as a log source, via +-- @GET /_plugins/_security_analytics/mappings/view@. The +-- 'SAMappingsViewRequest' body names the index and the log type (rule +-- topic); the server requires these as a request body even though the +-- method is GET, so this uses a body-bearing GET. The +-- 'SAMappingsViewResponse' carries the proposed @properties@ map and +-- the list of @unmapped_index_fields@. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, missing index) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getSAMappingsView :: + SAMappingsViewRequest -> + BHRequest StatusDependant SAMappingsViewResponse +getSAMappingsView req = + getWithBody @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_security_analytics", "mappings", "view"] + +-- | 'createSAMappings' creates the field-to-alias mappings for an +-- index via @POST /_plugins/_security_analytics/mappings@. The +-- 'SACreateMappingsRequest' body names the index, the log type (rule +-- topic), an optional @partial@ flag, and the @alias_mappings@ +-- ('SAMappingsBody') to persist. The server acknowledges with the +-- standard @{"acknowledged": true}@ envelope ('Acknowledged'). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, invalid body) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createSAMappings :: + SACreateMappingsRequest -> + BHRequest StatusDependant Acknowledged +createSAMappings req = + post (mkEndpoint ["_plugins", "_security_analytics", "mappings"]) (encode req) + +-- | 'getSAMappings' fetches the persisted mappings for a single index +-- via @GET /_plugins/_security_analytics/mappings?index_name={name}@. +-- The response is keyed by index name +-- ('SAGetMappingsResponse'); each value is an 'SAMappingsIndexBody' +-- carrying the @mappings.properties@ map. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, unknown index) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getSAMappings :: + Text -> + BHRequest StatusDependant SAGetMappingsResponse +getSAMappings indexName = + get @StatusDependant endpoint + where + endpoint = + withQueries + (mkEndpoint ["_plugins", "_security_analytics", "mappings"]) + [("index_name", Just indexName)] + +-- | 'updateSAMappings' updates a single field-to-alias mapping for an +-- index via @PUT /_plugins/_security_analytics/mappings@. The +-- 'SAUpdateMappingsRequest' body names the index, the source @field@, +-- and the @alias@ to assign. The server acknowledges with the +-- standard @{"acknowledged": true}@ envelope ('Acknowledged'). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, unknown index\/field) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +updateSAMappings :: + SAUpdateMappingsRequest -> + BHRequest StatusDependant Acknowledged +updateSAMappings req = + put (mkEndpoint ["_plugins", "_security_analytics", "mappings"]) (encode req) + +-- ========================================================================= +-- Security Analytics plugin: alerts, findings, correlations, log types +-- ========================================================================= + +-- | 'getSAAlertsWith' lists Security Analytics alert documents via +-- @GET /_plugins/_security_analytics/alerts@, forwarding the supplied +-- 'SAGetAlertsOptions' as query-string parameters (filtering by +-- @detector_id@ \/ @detectorType@ — one of which the server requires — +-- plus @alertState@ \/ @severityLevel@, pagination via @size@ \/ +-- @startIndex@, sort via @sortString@ \/ @sortOrder@ \/ @missing@, +-- free-text @searchString@). Pass 'defaultSAGetAlertsOptions' (with one +-- of the two detector filters set via record update) for the plain +-- GET. Returns the full 'SAGetAlertsResponse' envelope so callers can +-- read @total_alerts@ (which differs from the page size when @size@ +-- truncates the result). Mirrors the Alerting 'getAlertsWith' precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, missing required @detector_id@\/@detectorType@) decodes as an +-- 'EsError' rather than throwing. +-- +-- For more information see +-- . +getSAAlertsWith :: + SAGetAlertsOptions -> + BHRequest StatusDependant SAGetAlertsResponse +getSAAlertsWith opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_security_analytics", "alerts"] + `withQueries` saGetAlertsOptionsParams opts + +-- | 'getSAAlerts' lists the alert documents of a single detector. +-- Equivalent to 'getSAAlertsWith' with 'defaultSAGetAlertsOptions' (the +-- @detector_id@ is set from the argument) and projects out the bare +-- @['SAAlert']@ list (the paging envelope is discarded). Callers +-- needing @total_alerts@ or custom filtering should use +-- 'getSAAlertsWith'. Mirrors the Alerting 'getAlerts' precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx decodes as an 'EsError'. +-- +-- For more information see +-- . +getSAAlerts :: + DetectorId -> + BHRequest StatusDependant [SAAlert] +getSAAlerts did = + saGetAlertsResponseAlerts + <$> getSAAlertsWith + defaultSAGetAlertsOptions + { saGetAlertsOptionsDetectorId = Just (unDetectorId did) + } + +-- | 'acknowledgeSADetectorAlerts' acknowledges one or more active alerts +-- of a Security Analytics detector via +-- @POST /_plugins/_security_analytics/detectors/{detector_id}/_acknowledge/alerts@. +-- The request body is the encoded 'AcknowledgeSADetectorAlertsRequest' +-- (@{"alerts":[ids]}@). Alerts already in a terminal state are not +-- transitioned and are echoed in the @failed@ array of the +-- 'AcknowledgeSADetectorAlertsResponse'. Mirrors the Alerting +-- 'acknowledgeAlert' precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid detector id, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +acknowledgeSADetectorAlerts :: + DetectorId -> + [Text] -> + BHRequest StatusDependant AcknowledgeSADetectorAlertsResponse +acknowledgeSADetectorAlerts (DetectorId did) alertIds = + post + (mkEndpoint ["_plugins", "_security_analytics", "detectors", did, "_acknowledge", "alerts"]) + (encode (AcknowledgeSADetectorAlertsRequest alertIds)) + +-- | 'searchSAFindings' lists Security Analytics finding documents via +-- @GET /_plugins/_security_analytics/findings/_search@, forwarding the +-- supplied 'SASearchFindingsOptions' as query-string parameters +-- (filtering by @detector_id@ \/ @detectorType@ \/ @severity@ \/ +-- @detectionType@, pagination via @size@ \/ @startIndex@, sort via +-- @sortOrder@). Pass 'defaultSASearchFindingsOptions' for the plain +-- no-arg GET that returns the first page of all findings. +-- +-- Note: the @GET \/findings\/_search@ endpoint is the only documented +-- findings-retrieval surface; per-id GET is not documented. The +-- response envelope is plugin-specific (@{total_findings, findings}@) +-- and is NOT the standard OpenSearch search envelope; the decoded +-- 'SASearchFindingsResponse' reflects this. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +searchSAFindings :: + SASearchFindingsOptions -> + BHRequest StatusDependant (ParsedEsResponse SASearchFindingsResponse) +searchSAFindings opts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_security_analytics", "findings", "_search"] + `withQueries` saSearchFindingsOptionsParams opts + +-- | 'createSACorrelationRule' creates a Security Analytics correlation +-- rule via @POST /_plugins/_security_analytics/correlation/rules@. The +-- request body carries the list of index\/query\/category triples +-- ('SACorrelateEntry') that define the correlation; the server assigns +-- an @_id@ and @_version@ and echoes the persisted 'SACorrelationRule' +-- in 'createSACorrelationRuleResponseRule'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createSACorrelationRule :: + CreateSACorrelationRuleRequest -> + BHRequest StatusDependant CreateSACorrelationRuleResponse +createSACorrelationRule req = + post (mkEndpoint ["_plugins", "_security_analytics", "correlation", "rules"]) (encode req) + +-- | 'getSACorrelations' lists pairwise finding correlations within a +-- time window via @GET /_plugins/_security_analytics/correlations@. The +-- two required query parameters @start_timestamp@ and @end_timestamp@ +-- (epoch-millis integers) are carried in 'GetSACorrelationsOptions'; +-- the caller MUST set both via record update on +-- 'defaultGetSACorrelationsOptions'. Returns the +-- 'GetSACorrelationsResponse' envelope (@{findings: [...]}@ of +-- 'SACorrelationFinding' pairwise entries). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, missing required timestamps) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +getSACorrelations :: + GetSACorrelationsOptions -> + BHRequest StatusDependant GetSACorrelationsResponse +getSACorrelations opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_security_analytics", "correlations"] + `withQueries` getSACorrelationsOptionsParams opts + +-- | 'findSACorrelation' lists correlated findings for a given finding +-- via @GET /_plugins/_security_analytics/findings/correlate@. The two +-- required query parameters @finding@ (a finding id) and +-- @detector_type@ (a log type) are carried in 'FindSACorrelationOptions'; +-- the caller MUST set both via record update on +-- 'defaultFindSACorrelationOptions'. The optional @nearby_findings@ +-- (int) and @time_window@ (e.g. @"10m"@) tune the correlation window. +-- Returns the 'FindSACorrelationResponse' envelope (@{findings: [...]}@ +-- of 'SACorrelationScore' entries ranked by proximity score). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, missing required parameters) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +findSACorrelation :: + FindSACorrelationOptions -> + BHRequest StatusDependant FindSACorrelationResponse +findSACorrelation opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_security_analytics", "findings", "correlate"] + `withQueries` findSACorrelationOptionsParams opts + +-- | 'searchSACorrelationAlerts' lists Security Analytics correlation +-- alerts via @GET /_plugins/_security_analytics/correlationAlerts@. +-- The optional @correlation_rule_id@ query parameter filters the result +-- to alerts produced by a specific correlation rule. Pass +-- 'defaultSearchSACorrelationAlertsOptions' for the plain no-arg GET +-- that returns all correlation alerts. Returns the +-- 'SearchSACorrelationAlertsResponse' envelope (@{correlationAlerts, +-- total_alerts}@). +-- +-- /Documentation gotcha/ (pinned in the Haddock on +-- 'SearchSACorrelationAlertsOptions'): the endpoint is declared as +-- @GET \/correlationAlerts@, but the docs' example request uses +-- @GET \/correlations?correlation_rule_id=...@. This function ships +-- the declared path. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +searchSACorrelationAlerts :: + SearchSACorrelationAlertsOptions -> + BHRequest StatusDependant SearchSACorrelationAlertsResponse +searchSACorrelationAlerts opts = + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_security_analytics", "correlationAlerts"] + `withQueries` searchSACorrelationAlertsOptionsParams opts + +-- | 'acknowledgeSACorrelationAlerts' acknowledges one or more +-- correlation alerts via +-- @POST /_plugins/_security_analytics/_acknowledge/correlationAlerts@. +-- The request body is the encoded +-- 'AcknowledgeSACorrelationAlertsRequest' (@{"alertIds":[ids]}@ — note +-- the camelCase key, contrast with 'acknowledgeSADetectorAlerts' which +-- uses snake_case @alerts@). The unusual path (@\/_acknowledge\/...@, +-- with @_acknowledge@ as a sibling of @correlationAlerts@ rather than +-- nested under it) is documented and matches the live server. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid alert ids, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +acknowledgeSACorrelationAlerts :: + [Text] -> + BHRequest StatusDependant AcknowledgeSACorrelationAlertsResponse +acknowledgeSACorrelationAlerts alertIds = + post + (mkEndpoint ["_plugins", "_security_analytics", "_acknowledge", "correlationAlerts"]) + (encode (AcknowledgeSACorrelationAlertsRequest alertIds)) + +-- | 'createSALogType' creates a custom Security Analytics log type via +-- @POST /_plugins/_security_analytics/logtype@. The request body is the +-- encoded 'SALogType' (carrying @name@, @description@, @source@, and +-- optional @tags@); the server assigns an @_id@ and @_version@ and +-- echoes the persisted log type in the @logType@ wrapper of +-- 'SALogTypeResponse'. Built-in log types (@source: "Sigma"@) cannot +-- be created via this endpoint; pass @source = 'SALogTypeSourceCustom'@ +-- (or omit the field, which the server defaults to @"Custom"@). +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createSALogType :: + SALogType -> + BHRequest StatusDependant SALogTypeResponse +createSALogType logType = + post (mkEndpoint ["_plugins", "_security_analytics", "logtype"]) (encode logType) + +-- | 'searchSALogTypes' searches the Security Analytics log type store +-- via @POST /_plugins/_security_analytics/logtype/_search@. Pass +-- 'Nothing' for the plain @{"query": {"match_all": {}}}@ POST that +-- returns the first page of all log types (built-in and custom); pass +-- @'Just' query@ to filter by name, source, tags, ... using the +-- standard OpenSearch query DSL carried opaquely in +-- 'saLogTypeSearchQueryQuery'. Returns the full search envelope +-- 'SALogTypesSearchResponse' so callers can drive pagination and +-- inspect @_shards@ health; use 'saLogTypesSearchResponseLogTypes' to +-- project out just the @['SALogType']@ list. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchSALogTypes :: + Maybe SALogTypeSearchQuery -> + BHRequest StatusDependant (ParsedEsResponse SALogTypesSearchResponse) +searchSALogTypes mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_security_analytics", "logtype", "_search"] + body = encode (maybe defaultSALogTypeSearchQuery id mQuery) + +-- | 'updateSALogType' replaces a custom Security Analytics log type via +-- @PUT /_plugins/_security_analytics/logtype/{log_type_id}@. The +-- request body is the encoded 'SALogType'; the response is the same +-- 'SALogTypeResponse' wrapper as 'createSALogType' (with the +-- incremented @_version@). Built-in log types cannot be updated. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing log type id (or +-- a 4xx for an invalid body, or an attempt to update a built-in log +-- type) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateSALogType :: + Text -> + SALogType -> + BHRequest StatusDependant SALogTypeResponse +updateSALogType logTypeId logType = + put (mkEndpoint ["_plugins", "_security_analytics", "logtype", logTypeId]) (encode logType) + +-- | 'deleteSALogType' deletes a custom Security Analytics log type via +-- @DELETE /_plugins/_security_analytics/logtype/{log_type_id}@. +-- Built-in log types cannot be deleted — the server rejects the +-- request; the resulting 'EsError' surfaces via 'StatusDependant'. +-- Returns 'DeleteSALogTypeResponse' carrying just @_id@ and @_version@. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing log type id (or +-- a 4xx for a built-in log type id) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +deleteSALogType :: + Text -> + BHRequest StatusDependant DeleteSALogTypeResponse +deleteSALogType logTypeId = + delete (mkEndpoint ["_plugins", "_security_analytics", "logtype", logTypeId]) + +-- Anomaly Detection plugin +-- ========================================================================= + +-- | 'createDetector' calls the Anomaly Detection plugin Create Detector API +-- (@POST /_plugins/_anomaly_detection/detectors@). Persists a new +-- detector (single-entity or, when @category_field@ is set, +-- high-cardinality multi-entity) to the +-- @.opendistro-anomaly-detection-state@ system index and returns the +-- standard document-write envelope (@_id@, @_version@, @_primary_term@, +-- @_seq_no@) wrapping the persisted detector under @anomaly_detector@. +-- +-- The target index must already contain at least one document, otherwise +-- the plugin rejects the request with HTTP 400 (@Can't create anomaly +-- detector as no document is found in the indices: [...]@). Surfaced as +-- 'StatusDependant' so that 400 (and a 404 for the plugin-not-installed +-- case) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createDetector :: + Detector -> + BHRequest StatusDependant (ParsedEsResponse CreateDetectorResponse) +createDetector detector = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode detector) + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors"] + +-- | 'getDetector' calls the Anomaly Detection plugin Get Detector API +-- (@GET /_plugins/_anomaly_detection/detectors/{detector_id}@). Returns +-- the full detector record — the same shape 'createDetector' returns — +-- plus, when the corresponding 'GetDetectorParams' flag is set, the +-- real-time job (@?job=true@) and/or the running task records +-- (@?task=true@) embedded as siblings of @anomaly_detector@. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @detector_id@ or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getDetector :: + DetectorId -> + GetDetectorParams -> + BHRequest StatusDependant (ParsedEsResponse GetDetectorResponse) +getDetector detectorId params = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId] + endpoint = withQueries baseEndpoint (getDetectorParamsPairs params) + +-- | Renders the 'GetDetectorParams' flags as the @?job@ \/ @?task@ query +-- pairs the plugin expects. A 'False' flag contributes no pair, so the +-- default ('defaultGetDetectorParams') produces a bare GET. Uses '(<>)' +-- rather than @concat [..]@ because OS2\/OS3 Requests enable +-- @OverloadedLists@, which would otherwise leave the outer list literal +-- passed to 'concat' (which is @Foldable@-polymorphic) ambiguous. +getDetectorParamsPairs :: GetDetectorParams -> [(Text, Maybe Text)] +getDetectorParamsPairs params = + [("job", Just "true") | getDetectorParamsJob params] + <> [("task", Just "true") | getDetectorParamsTask params] + +-- | 'previewDetector' calls the Anomaly Detection plugin Preview Detector +-- API (@POST /_plugins/_anomaly_detection/detectors/_preview@). Runs the +-- detector's feature aggregations and RCF model over the historical +-- window bounded by 'previewRequestPeriodStart' / +-- 'previewRequestPeriodEnd' (epoch milliseconds) and returns the +-- resulting anomaly grades alongside a snapshot of the detector. No +-- state is persisted. +-- +-- The 'DetectorId' is sent in the request body (@detector_id@) rather +-- than the URL path, matching the documented canonical @_plugins@ form; +-- the path-param form is only documented under the legacy @_opendistro@ +-- prefix. The plugin requires both endpoints of the window; a missing +-- field surfaces as HTTP 400 with @Must set both period start and end +-- date with epoch of milliseconds@. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @detector_id@ or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +previewDetector :: + DetectorId -> + PreviewRequest -> + BHRequest StatusDependant (ParsedEsResponse PreviewResponse) +previewDetector detectorId req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = + mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "_preview"] + body = + encode $ + object + [ "detector_id" .= unDetectorId detectorId, + "period_start" .= previewRequestPeriodStart req, + "period_end" .= previewRequestPeriodEnd req + ] + +-- | 'previewDetectorInline' previews a detector whose identity is carried +-- entirely in the request body rather than as a separate 'DetectorId' +-- argument — the variant 'previewDetector' does not expose. Use it for an +-- unpersisted detector by setting 'previewRequestDetector' to the full +-- inline 'Detector' config, or to preview a persisted detector by +-- reference via 'previewRequestDetectorId'. The endpoint +-- (@POST /_plugins/_anomaly_detection/detectors/_preview@) and the rest +-- of the semantics match 'previewDetector'; no state is persisted. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown +-- 'previewRequestDetectorId' or plugin not installed) decodes as an +-- 'EsError' rather than throwing. +-- +-- For more information see +-- . +previewDetectorInline :: + PreviewRequest -> + BHRequest StatusDependant (ParsedEsResponse PreviewResponse) +previewDetectorInline req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "_preview"] + +-- | 'startDetector' starts an Anomaly Detection detector job via the +-- documented Start Detector Job API +-- (@POST /_plugins/_anomaly_detection/detectors/{detector_id}/_start@). +-- +-- Pass 'Nothing' to start the real-time detector job; pass @'Just' req@ +-- to kick off a one-shot historical backfill over the window bounded by +-- 'startDetectorJobRequestStartTime' / 'startDetectorJobRequestEndTime'. +-- The server returns a 'DetectorJobAcknowledgment' whose @_id@ is the +-- real-time job id (= the detector id) for the no-body form, or the +-- historical batch task id (a UUID) for the body form. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @detector_id@ or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +startDetector :: + DetectorId -> + Maybe StartDetectorJobRequest -> + BHRequest StatusDependant (ParsedEsResponse DetectorJobAcknowledgment) +startDetector detectorId mReq = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (maybe emptyBody encode mReq) + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId, "_start"] + +-- | 'stopDetector' stops an Anomaly Detection detector job via the +-- documented Stop Detector Job API +-- (@POST /_plugins/_anomaly_detection/detectors/{detector_id}/_stop@). +-- +-- Pass 'False' to stop the real-time detector job; pass 'True' to stop +-- the historical analysis, which adds the @?historical=true@ query +-- parameter. The server returns a 'DetectorJobAcknowledgment' with +-- zeroed @_version@ / @_seq_no@ / @_primary_term@ on success. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @detector_id@ or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +stopDetector :: + DetectorId -> + Bool -> + BHRequest StatusDependant (ParsedEsResponse DetectorJobAcknowledgment) +stopDetector detectorId historical = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint emptyBody + where + endpoint = + mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId, "_stop"] + `withQueries` [("historical", Just "true") | historical] + +-- | 'updateDetector' replaces a detector via +-- @PUT /_plugins/_anomaly_detection/detectors/{detector_id}@. The body +-- is the encoded 'Detector' (you cannot update @category_field@, and the +-- server requires both the real-time and historical jobs to be stopped +-- first); the response is the same 'CreateDetectorResponse' envelope as +-- 'createDetector' (with the incremented @_version@ / @_seq_no@). +-- Equivalent to 'updateDetectorWith' with 'Nothing' (no +-- optimistic-concurrency guard), so concurrent updates to the same +-- detector id silently clobber each other. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +updateDetector :: + DetectorId -> + Detector -> + BHRequest StatusDependant (ParsedEsResponse CreateDetectorResponse) +updateDetector detectorId detector = updateDetectorWith detectorId detector Nothing + +-- | 'updateDetectorWith' replaces a detector via +-- @PUT /_plugins/_anomaly_detection/detectors/{detector_id}@ with an +-- optional optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ +-- — both values read from a prior 'CreateDetectorResponse' — to make the +-- PUT conditional on the detector being unchanged since you last read it; +-- a stale pair causes OpenSearch to respond with HTTP 409 instead of +-- silently overwriting. Pass 'Nothing' for the unconditional semantics of +-- 'updateDetector'. The two values must be supplied together (mirroring +-- the 'updateMonitorWith' / 'putISMPolicyWith' precedent). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id (or a +-- 409 on a sequence-number mismatch) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +updateDetectorWith :: + DetectorId -> + Detector -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant (ParsedEsResponse CreateDetectorResponse) +updateDetectorWith detectorId detector mOcc = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode detector) + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries + baseEndpoint + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'deleteDetector' deletes a detector by id via +-- @DELETE /_plugins/_anomaly_detection/detectors/{detector_id}@. +-- +-- The return type 'DeleteDetectorResponse' deviates from an +-- @m 'Acknowledged'@ acceptance for the same reason as the Alerting +-- 'deleteMonitor' and Security Analytics 'deleteSADetector': the AD +-- delete endpoint returns the bare Elasticsearch delete-document response +-- (@_index@, @_id@, @_version@, @result@, @forced_refresh@, @_shards@, +-- @_seq_no@, @_primary_term@, NO @acknowledged@ key), so an +-- 'Acknowledged' decoder would raise 'EsProtocolException' at runtime. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id +-- decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteDetector :: + DetectorId -> + BHRequest StatusDependant (ParsedEsResponse DeleteDetectorResponse) +deleteDetector detectorId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId] + +-- | 'validateDetector' validates a detector configuration via +-- @POST /_plugins/_anomaly_detection/detectors/_validate[/mode]@. The +-- 'ValidateDetectorMode' argument selects the validation mode: +-- 'ValidateDetector' (the bare @\/_validate@ alias, which finds issues +-- that would block creation) or 'ValidateModel' (the @\/_validate\/model@ +-- advisory check that estimates the likelihood of successful model +-- training). The body is the encoded 'Detector'. The response is an +-- opaque 'ValidateDetectorResponse' (@{}@ on success; a @detector@ / +-- @model@ sub-object carrying the issues otherwise). +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid detector body, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +validateDetector :: + ValidateDetectorMode -> + Detector -> + BHRequest StatusDependant (ParsedEsResponse ValidateDetectorResponse) +validateDetector mode detector = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode detector) + where + endpoint = + mkEndpoint $ + ["_plugins", "_anomaly_detection", "detectors", "_validate"] + <> validateDetectorModeSegments mode + +-- | 'searchDetectors' searches the detector-config index via +-- @POST /_plugins/_anomaly_detection/detectors/_search@. Pass 'Nothing' +-- for the plain empty-body @{}@ POST that returns the first page of all +-- detectors; pass @'Just' query@ to paginate (@from@\/@size@) or filter +-- using the standard OpenSearch query DSL carried opaquely as a 'Value'. +-- +-- Returns the full 'SearchDetectorsResponse' search envelope so callers +-- can drive pagination and inspect @_shards@ health; use +-- 'anomalySearchResponseSources' to project out just the +-- @['DetectorResponse']@ list. Mirrors the Alerting 'searchMonitors' +-- precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query DSL) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +searchDetectors :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse SearchDetectorsResponse) +searchDetectors mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'profileDetector' profiles a detector via +-- @GET /_plugins/_anomaly_detection/detectors/{detector_id}/_profile[/{types}]@. +-- Pass the profile-kind segments to select (e.g. @["ad_task"]@, +-- @["total_size_in_bytes"]@, or multiple @["ad_task","models"]@ joined +-- comma-separated); pass @[]@ for the bare profile. Pass 'True' to add +-- the @?_all=true@ flag (every profile section — expensive for +-- high-cardinality detectors). +-- +-- For a multi-entity detector (one created with a @category_field@), +-- pass @'Just' entities@ to filter the profile to a specific categorical +-- slice. The plugin documents this as a GET with a request body +-- @{entity: [{name, value}]}@; 'Entity' is reused for both the request +-- filter and the 'AnomalyResult' response. Pass 'Nothing' for a bodyless +-- profile. +-- +-- The response shape varies widely by requested kind and detector kind; +-- it is surfaced as an opaque 'DetectorProfileResponse' so every variant +-- round-trips losslessly (pragmatic-typing precedent). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing detector id (or +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +profileDetector :: + DetectorId -> + [Text] -> + Bool -> + Maybe [Entity] -> + BHRequest StatusDependant (ParsedEsResponse DetectorProfileResponse) +profileDetector detectorId types allFlag mEntities = + withBHResponseParsedEsResponse $ + case mEntities of + Nothing -> get @StatusDependant endpoint + Just entities -> getWithBody @StatusDependant endpoint (encode (object ["entity" .= entities])) + where + baseEndpoint = + mkEndpoint $ + ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId, "_profile"] + <> (case types of [] -> []; xs -> [T.intercalate "," xs]) + endpoint = + if allFlag + then withQueries baseEndpoint [("_all", Just "true")] + else baseEndpoint + +-- | 'getDetectorStats' fetches plugin statistics via +-- @GET /_plugins/_anomaly_detection/stats@ (and its filtered forms). +-- The OpenSearch path convention is asymmetric: when filtering by node, +-- the path is @\/{node_id}\/stats@; when filtering by stat only, it is +-- @\/stats\/{stat}@; both filters combine as +-- @\/{node_id}\/stats\/{stat}@. Pass the node id first (or 'Nothing'), +-- then the stat name (or 'Nothing'). +-- +-- The full response carries several top-level index-status keys plus a +-- @nodes@ map; the filtered forms return a subset. It is surfaced as an +-- opaque 'DetectorStatsResponse' so the variable top-level surface +-- round-trips losslessly (pragmatic-typing precedent). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, unknown +-- node id) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getDetectorStats :: + Maybe Text -> + Maybe Text -> + BHRequest StatusDependant (ParsedEsResponse DetectorStatsResponse) +getDetectorStats mNodeId mStat = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection"] + withNode = case mNodeId of + Nothing -> baseEndpoint + Just nodeId -> mkEndpoint (getRawEndpoint baseEndpoint <> [nodeId]) + withStats = mkEndpoint (getRawEndpoint withNode <> ["stats"]) + endpoint = case mStat of + Nothing -> withStats + Just stat -> mkEndpoint (getRawEndpoint withStats <> [stat]) + +-- | 'searchDetectorResults' searches the anomaly-result index via +-- @POST /_plugins/_anomaly_detection/detectors/results/_search[/{custom_result_index}]@. +-- Pass a custom result-index name to search it alongside (or, with +-- @'Just' True@ for @only_query_custom_result_index@, instead of) the +-- default result index. Pass 'Nothing' for the query body to send the +-- plain empty-body @{}@ POST. +-- +-- Each hit's @_source@ is an anomaly-result record; the response is +-- surfaced as a 'SearchDetectorResultsResponse' with opaque 'Value' +-- sources (the full result schema carries many optional fields and lives +-- in a separate mapping page). +-- +-- Surfaced as 'StatusDependant' so a 4xx decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +searchDetectorResults :: + Maybe Text -> + Maybe Bool -> + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse SearchDetectorResultsResponse) +searchDetectorResults mCustomResultIndex mOnlyCustom mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "results", "_search"] + endpointWithCustom = case mCustomResultIndex of + Nothing -> baseEndpoint + Just idx -> mkEndpoint (getRawEndpoint baseEndpoint <> [idx]) + endpoint = case mOnlyCustom of + Nothing -> endpointWithCustom + Just b -> withQueries endpointWithCustom [("only_query_custom_result_index", Just (showText b))] + body = encode (maybe (object []) id mQuery) + +-- | 'deleteDetectorResults' deletes anomaly-result documents by query via +-- @DELETE /_plugins/_anomaly_detection/detectors/results@ (introduced in +-- OpenSearch 1.1). The body is a standard OpenSearch query-DSL object +-- (the same shape @deleteByQuery@ accepts) carrying the selection +-- predicate — typically a @bool@ filter on @detector_id@, @task_id@ and +-- a @data_start_time@ range, as shown in the plugin docs. The endpoint +-- only operates on the default result index; anomaly results stored in +-- a custom result index must be deleted manually (per the docs). +-- +-- The body is mandatory by design: an empty @{}@ would match every +-- anomaly-result document in the default index, so we make the caller +-- pass the selection explicitly rather than defaulting to @{}@ (the +-- 'searchDetectorResults' precedent defaults to @{}@ because a bare +-- search is harmless; a bare delete-by-query is not). Construct the +-- body with the usual aeson helpers, e.g. +-- +-- @ +-- 'object' ["query" .= 'object' ["bool" .= 'object' ["filter" .= [...] ]]] +-- @ +-- +-- The response is the bare @_delete_by_query@ envelope (reused as +-- 'DeleteDetectorResultsResponse', which aliases the document-API +-- 'DeletedDocuments' since the shape is identical — @took@, +-- @timed_out@, @total@, @deleted@, @batches@, @version_conflicts@, +-- @noops@, @retries@, @throttled_millis@, @requests_per_second@, +-- @throttled_until_millis@, @failures@). +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial, malformed query) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +deleteDetectorResults :: + Value -> + BHRequest StatusDependant (ParsedEsResponse DeleteDetectorResultsResponse) +deleteDetectorResults query = + withBHResponseParsedEsResponse $ + deleteWithBody @StatusDependant endpoint (encode query) + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "results"] + +-- | 'searchDetectorTasks' searches the detection-state index via +-- @POST /_plugins/_anomaly_detection/detectors/tasks/_search@ — the +-- record store for real-time and historical task state. Pass 'Nothing' +-- for the plain empty-body @{}@ POST; pass @'Just' query@ to filter +-- (e.g. by @detector_id@, @task_type@, @is_latest@) using the standard +-- query DSL. +-- +-- Each hit's @_source@ is a task record; the response is surfaced as a +-- 'SearchDetectorTasksResponse' with opaque 'Value' sources. +-- +-- Surfaced as 'StatusDependant' so a 4xx decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +searchDetectorTasks :: + Maybe Value -> + BHRequest StatusDependant (ParsedEsResponse SearchDetectorTasksResponse) +searchDetectorTasks mQuery = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint body + where + endpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", "tasks", "_search"] + body = encode (maybe (object []) id mQuery) + +-- | 'topAnomalies' returns the top anomaly results for a +-- high-cardinality detector via +-- @GET /_plugins/_anomaly_detection/detectors/{detector_id}/results/_topAnomalies?historical={bool}@, +-- bucketed by category-field values. Pass 'True' for historical results, +-- 'False' for real-time. The 'TopAnomaliesRequest' body is sent with the +-- GET (it carries @start_time_ms@ / @end_time_ms@ which are required). +-- +-- The response is a 'TopAnomaliesResponse' whose @buckets@ each carry a +-- categorical @key@, a @doc_count@, and the @max_anomaly_grade@. +-- +-- Surfaced as 'StatusDependant' so a 4xx decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +topAnomalies :: + DetectorId -> + Bool -> + TopAnomaliesRequest -> + BHRequest StatusDependant (ParsedEsResponse TopAnomaliesResponse) +topAnomalies detectorId historical req = + withBHResponseParsedEsResponse $ + getWithBody @StatusDependant endpoint (encode req) + where + baseEndpoint = mkEndpoint ["_plugins", "_anomaly_detection", "detectors", unDetectorId detectorId, "results", "_topAnomalies"] + endpoint = + if historical + then withQueries baseEndpoint [("historical", Just "true")] + else withQueries baseEndpoint [("historical", Just "false")] + +-- Index Rollups plugin +-- +-- ---------------------------------------------------------------------------- + +-- | 'createRollup' creates or replaces an index rollup job via +-- @PUT /_plugins/_rollup/jobs/{rollup_id}@. The 'Rollup' body is wrapped +-- in the @{"rollup": ...}@ envelope the endpoint expects. Equivalent to +-- 'createRollupWith' with 'Nothing' (no optimistic-concurrency guard), so +-- a concurrent update silently clobbers the prior job definition. +-- +-- Surfaced as 'StatusDependant' so a 4xx (malformed body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createRollup :: + RollupId -> + Rollup -> + BHRequest StatusDependant (ParsedEsResponse RollupResponse) +createRollup rollupId rollup = createRollupWith rollupId rollup Nothing + +-- | 'createRollupWith' creates or replaces an index rollup job via +-- @PUT /_plugins/_rollup/jobs/{rollup_id}@ with an optional +-- optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ — both +-- values read from a prior 'RollupResponse' — to make the PUT conditional +-- on the job being unchanged since you last read it; a stale pair causes +-- OpenSearch to respond with HTTP 409 instead of silently overwriting. +-- Pass 'Nothing' for the unconditional semantics of 'createRollup'. The +-- two values must be supplied together (mirroring the 'putISMPolicyWith' +-- precedent). +-- +-- Surfaced as 'StatusDependant' so a 4xx (or a 409 on a sequence-number +-- mismatch) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createRollupWith :: + RollupId -> + Rollup -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant (ParsedEsResponse RollupResponse) +createRollupWith rollupId rollup mOcc = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode (RollupWrapper rollup)) + where + baseEndpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries baseEndpoint $ + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- ========================================================================= +-- Index Transforms plugin +-- ========================================================================= + +-- | 'createTransform' creates or replaces an Index Transforms job via +-- @PUT /_plugins/_transform/{transform_id}@. The body is the 'Transform' +-- wrapped under the top-level @transform@ key (see 'TransformRequest'); +-- the response is the 'TransformDocumentResponse' document envelope +-- (@_id@, @_version@, @_seq_no@, @_primary_term@, @transform@). +-- +-- OpenSearch treats the PUT as upsert: the same call creates a new +-- transform when @transform_id@ is unused and overwrites an existing one +-- otherwise (without an optimistic-concurrency guard). Use +-- 'updateTransformWith' to make the overwrite conditional on a prior +-- @_seq_no@ \/ @_primary_term@. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, RBAC denial, +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +createTransform :: + TransformId -> + Transform -> + BHRequest StatusDependant (ParsedEsResponse TransformDocumentResponse) +createTransform transformId transform = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode (TransformRequest transform)) + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId] + +-- | 'updateTransform' replaces an Index Transforms job via +-- @PUT /_plugins/_transform/{transform_id}@. Equivalent to +-- 'updateTransformWith' with 'Nothing' (no optimistic-concurrency +-- guard), so concurrent updates to the same @transform_id@ silently +-- clobber each other. Mirrors the 'updateMonitor' / 'updateDetector' +-- unconditional-update precedent. +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, unknown +-- @transform_id@, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +updateTransform :: + TransformId -> + Transform -> + BHRequest StatusDependant (ParsedEsResponse TransformDocumentResponse) +updateTransform transformId transform = updateTransformWith transformId transform Nothing + +-- | 'updateTransformWith' replaces an Index Transforms job via +-- @PUT /_plugins/_transform/{transform_id}@ with an optional +-- optimistic-concurrency guard. Pass @'Just' (seqNo, primaryTerm)@ — +-- both values read from a prior 'TransformDocumentResponse' — to make +-- the PUT conditional on the transform being unchanged since you last +-- read it; a stale pair causes OpenSearch to respond with HTTP 409 +-- instead of silently overwriting. Pass 'Nothing' for the unconditional +-- semantics of 'updateTransform'. The two values must be supplied +-- together (mirroring the 'updateMonitorWith' / 'updateDetectorWith' / +-- 'putISMPolicyWith' precedent). +-- +-- The plugin docs document @if_seq_no@ \/ @if_primary_term@ as required +-- for the Update operation; OpenSearch still accepts an unparameterised +-- PUT as an overwrite (the @Nothing@ form), which is why +-- 'updateTransform' exists as a convenience. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing @transform_id@ +-- (or a 409 on a sequence-number mismatch) decodes as an 'EsError' +-- rather than throwing. +-- +-- For more information see +-- . +updateTransformWith :: + TransformId -> + Transform -> + Maybe (Word64, Word64) -> + BHRequest StatusDependant (ParsedEsResponse TransformDocumentResponse) +updateTransformWith transformId transform mOcc = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode (TransformRequest transform)) + where + baseEndpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId] + endpoint = case mOcc of + Nothing -> baseEndpoint + Just (seqNo, primaryTerm) -> + withQueries baseEndpoint $ + [ ("if_seq_no", Just (showText seqNo)), + ("if_primary_term", Just (showText primaryTerm)) + ] + +-- | 'getRollup' fetches a single rollup job by id via +-- @GET /_plugins/_rollup/jobs/{rollup_id}@. The response is the same +-- document-write envelope (@_id@, @_version@, @_seq_no@, +-- @_primary_term@) wrapping the inner rollup that 'createRollup' +-- returns, except the GET form emits @_seqNo@\/@_primaryTerm@ in +-- camelCase; both spellings are decoded (see 'RollupResponse'). +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @rollup_id@ or plugin +-- not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse RollupResponse) +getRollup rollupId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId] + +-- | 'getAllRollups' lists every rollup job via +-- @GET /_plugins/_rollup/jobs@. The response shape is not documented in +-- the field tables, so the body is returned as an opaque 'Value' for the +-- caller to inspect. +-- | 'getTransform' fetches a single Index Transforms job by id via +-- @GET /_plugins/_transform/{transform_id}@. The response is the +-- 'TransformDocumentResponse' document envelope carrying the persisted +-- 'TransformResponse' (with server-injected bookkeeping fields +-- @schema_version@, @updated_at@, @enabled_at@, @roles@, +-- @transform_id@) alongside the document-write metadata +-- (@_id@, @_version@, @_seq_no@, @_primary_term@). +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing @transform_id@ +-- (or the plugin not installed) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +getTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse TransformDocumentResponse) +getTransform transformId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId] + +-- | 'getTransforms' lists Index Transforms jobs via +-- @GET /_plugins/_transform\/@. Pass 'Nothing' for the plain no-arg +-- list; pass @'Just' opts@ to filter by free-text @search@, paginate +-- with @from@ \/ @size@, or sort by @sortField@ \/ @sortDirection@ (see +-- 'TransformsListOptions'). +-- +-- The response is a 'GetTransformsResponse' carrying @total_transforms@ +-- (the count of all transforms the caller can see, independent of +-- pagination) and the per-page @transforms@ array. Each entry is a +-- 'GetTransformsListEntry' with the same document envelope + +-- 'TransformResponse' payload as 'getTransform'. +-- +-- Surfaced as 'StatusDependant' so a 4xx (plugin not installed, RBAC +-- denial) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +getAllRollups :: + BHRequest StatusDependant (ParsedEsResponse Value) +getAllRollups = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs"] + +-- | 'deleteRollup' deletes a rollup job by id via +-- @DELETE /_plugins/_rollup/jobs/{rollup_id}@. The plugin returns the bare +-- Elasticsearch delete-document response (@_index@, @_id@, @_version@, +-- @result@, @forced_refresh@, @_shards@, @_seq_no@, @_primary_term@, NO +-- @acknowledged@ key), so the body is returned as an opaque 'Value'. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @rollup_id@ or plugin +-- not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +deleteRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse Value) +deleteRollup rollupId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId] + +-- | 'startRollup' starts a rollup job by id via +-- @POST /_plugins/_rollup/jobs/{rollup_id}/_start@. The plugin +-- acknowledges with an 'Acknowledged' body. +-- +-- Surfaced as 'StatusDependant' so a 4xx (unknown @rollup_id@, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +startRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +startRollup rollupId = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId, "_start"] + +-- | 'stopRollup' stops a rollup job by id via +-- @POST /_plugins/_rollup/jobs/{rollup_id}/_stop@. The plugin +-- acknowledges with an 'Acknowledged' body. +-- +-- Surfaced as 'StatusDependant' so a 4xx (unknown @rollup_id@, plugin +-- not installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +stopRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +stopRollup rollupId = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId, "_stop"] + +-- | 'explainRollup' returns execution metadata for a rollup job by id +-- via @GET /_plugins/_rollup/jobs/{rollup_id}/_explain@. The response is +-- keyed by the rollup id; decode it into 'ExplainRollupResponse' and +-- look up the entry with 'explainRollupResponseLookup'. Before the job +-- has executed, both @metadata_id@ and @rollup_metadata@ are JSON @null@. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @rollup_id@ or plugin +-- not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +explainRollup :: + RollupId -> + BHRequest StatusDependant (ParsedEsResponse ExplainRollupResponse) +explainRollup rollupId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_rollup", "jobs", unRollupId rollupId, "_explain"] + +-- ========================================================================= +-- Cross-Cluster Replication (CCR) plugin +-- ========================================================================= + +-- | 'startReplication' calls the CCR plugin Start Replication API +-- (@PUT /_plugins/_replication/{follower-index}/_start@) on the +-- /follower/ cluster. Begins replicating the named leader index into the +-- given follower index. The follower index is created read-only and +-- stays so while replication is active; call 'stopReplication' to +-- convert it back into a standard writable index. +-- +-- The 'StartReplicationRequest' carries the leader connection alias, +-- the leader index name, and (when the Security plugin is enabled) the +-- cross-cluster roles. Returns 'Acknowledged'. +-- +-- For more information see +-- . +startReplication :: + Text -> + StartReplicationRequest -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +startReplication followerIndex req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_start"] + +-- | 'stopReplication' calls the CCR plugin Stop Replication API +-- (@POST /_plugins/_replication/{follower-index}/_stop@) on the +-- /follower/ cluster. Terminates replication and converts the follower +-- index into a standard (writable) index. The body is the empty object +-- @{}@ per the plugin docs. Returns 'Acknowledged'. +-- +-- For more information see +-- . +stopReplication :: + Text -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +stopReplication followerIndex = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_stop"] + +-- | 'pauseReplication' calls the CCR plugin Pause Replication API +-- (@POST /_plugins/_replication/{follower-index}/_pause@) on the +-- /follower/ cluster. Pauses replication of the leader index. +-- Replication cannot be resumed after being paused for more than 12 +-- hours — beyond that you must stop, delete the follower, and restart. +-- The body is the empty object @{}@. Returns 'Acknowledged'. +-- +-- For more information see +-- . +pauseReplication :: + Text -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +pauseReplication followerIndex = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_pause"] + +-- | 'resumeReplication' calls the CCR plugin Resume Replication API +-- (@POST /_plugins/_replication/{follower-index}/_resume@) on the +-- /follower/ cluster. Resumes replication of the leader index after a +-- 'pauseReplication'. The body is the empty object @{}@. Returns +-- 'Acknowledged'. +-- +-- For more information see +-- . +resumeReplication :: + Text -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +resumeReplication followerIndex = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (object [])) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_resume"] + +-- | 'updateReplicationSettings' calls the CCR plugin Update Settings API +-- (@PUT /_plugins/_replication/{follower-index}/_update@) on the +-- /follower/ cluster. Applies index-level settings (e.g. +-- @index.number_of_replicas@) to the follower index. Returns +-- 'Acknowledged'. +-- +-- For more information see +-- . +updateReplicationSettings :: + Text -> + UpdateReplicationSettingsRequest -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +updateReplicationSettings followerIndex req = + withBHResponseParsedEsResponse $ + put @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_replication", followerIndex, "_update"] + +-- | 'getReplicationStatus' calls the CCR plugin Status API +-- (@GET /_plugins/_replication/{follower-index}/_status@) on the +-- /follower/ cluster without the @verbose@ flag. Equivalent to +-- 'getReplicationStatusWith' with 'defaultReplicationStatusOptions'. +-- +-- For more information see +-- . +getReplicationStatus :: + Text -> + BHRequest StatusDependant (ParsedEsResponse ReplicationStatusResponse) +getReplicationStatus = getReplicationStatusWith defaultReplicationStatusOptions + +-- | 'getReplicationStatusWith' is the parameterized variant of +-- 'getReplicationStatus': the supplied 'ReplicationStatusOptions' are +-- forwarded as query-string parameters. Set +-- 'replicationStatusOptionsVerbose' to @'Just' True@ to include +-- shard-level 'SyncingDetails' in the response. +-- +-- See 'Database.Bloodhound.OpenSearch3.Requests.getReplicationStatus'. +getReplicationStatusWith :: + ReplicationStatusOptions -> + Text -> + BHRequest StatusDependant (ParsedEsResponse ReplicationStatusResponse) +getReplicationStatusWith opts followerIndex = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = + mkEndpoint ["_plugins", "_replication", followerIndex, "_status"] + `withQueries` replicationStatusOptionsParams opts + +-- | 'getLeaderStats' calls the CCR plugin Leader Stats API +-- (@GET /_plugins/_replication/leader_stats@) on the /leader/ cluster. +-- Returns aggregate and per-index read-side counters across all +-- replicated leader indexes. +-- +-- For more information see +-- . +getLeaderStats :: + BHRequest StatusDependant (ParsedEsResponse LeaderStatsResponse) +getLeaderStats = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_replication", "leader_stats"] + +-- | 'getFollowerStats' calls the CCR plugin Follower Stats API +-- (@GET /_plugins/_replication/follower_stats@) on the /follower/ +-- cluster. Returns counts of follower indexes by state and aggregate +-- write-side throughput, plus a per-index breakdown. +-- +-- For more information see +-- . +getFollowerStats :: + BHRequest StatusDependant (ParsedEsResponse FollowerStatsResponse) +getFollowerStats = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_replication", "follower_stats"] + +-- | 'getAutoFollowStats' calls the CCR plugin Auto-Follow Stats API +-- (@GET /_plugins/_replication/autofollow_stats@) on the /follower/ +-- cluster. Returns auto-follow activity and the list of configured +-- replication rules. The docs note there is no dedicated \"list +-- patterns\" endpoint — this stats response is the only way to discover +-- existing auto-follow rules. +-- +-- For more information see +-- . +getAutoFollowStats :: + BHRequest StatusDependant (ParsedEsResponse AutoFollowStatsResponse) +getAutoFollowStats = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_replication", "autofollow_stats"] + +-- | 'createAutoFollowPattern' calls the CCR plugin Create Replication +-- Rule API (@POST /_plugins/_replication/_autofollow@) on the +-- /follower/ cluster. Creates (or, re-POSTed with the same @name@, +-- updates) an auto-follow rule that automatically starts replication on +-- any existing and future leader indexes whose names match the rule's +-- @pattern@. Returns 'Acknowledged'. +-- +-- For more information see +-- . +createAutoFollowPattern :: + CreateAutoFollowPatternRequest -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +createAutoFollowPattern req = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_replication", "_autofollow"] + +-- | 'deleteAutoFollowPattern' calls the CCR plugin Delete Replication +-- Rule API (@DELETE /_plugins/_replication/_autofollow@) on the +-- /follower/ cluster. Deletes an auto-follow rule. This prevents /new/ +-- indexes from being replicated but does /not/ stop replication already +-- initiated by the rule — stop those individually with +-- 'stopReplication'. The delete carries a request body (the rule's +-- @leader_alias@ and @name@), hence 'deleteWithBody'. Returns +-- 'Acknowledged'. +-- +-- For more information see +-- . +deleteAutoFollowPattern :: + DeleteAutoFollowPatternRequest -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +deleteAutoFollowPattern req = + withBHResponseParsedEsResponse $ + deleteWithBody @StatusDependant endpoint (encode req) + where + endpoint = mkEndpoint ["_plugins", "_replication", "_autofollow"] + +-- . +getTransforms :: + Maybe TransformsListOptions -> + BHRequest StatusDependant (ParsedEsResponse GetTransformsResponse) +getTransforms mOpts = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + baseEndpoint = mkEndpoint ["_plugins", "_transform"] + endpoint = case mOpts of + Nothing -> baseEndpoint + Just opts -> withQueries baseEndpoint (transformsListOptionsParams opts) + +-- | 'startTransform' starts an Index Transforms job via +-- @POST /_plugins/_transform/{transform_id}/_start@. The endpoint takes +-- no request body and returns the 'Acknowledged' envelope on success. +-- A non-continuous transform runs to completion and transitions to the +-- @finished@ state; a continuous transform runs on the schedule until +-- 'stopTransform' is called. Poll 'explainTransform' for the runtime +-- state. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @transform_id@, the +-- plugin not installed, RBAC denial) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +startTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +startTransform transformId = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId, "_start"] + +-- | 'stopTransform' stops an Index Transforms job via +-- @POST /_plugins/_transform/{transform_id}/_stop@. The endpoint takes +-- no request body and returns the 'Acknowledged' envelope on success. +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @transform_id@, the +-- plugin not installed, RBAC denial) decodes as an 'EsError' rather +-- than throwing. +-- +-- For more information see +-- . +stopTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse Acknowledged) +stopTransform transformId = + withBHResponseParsedEsResponse $ + postNoBody @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId, "_stop"] + +-- | 'explainTransform' returns the runtime status and statistics of an +-- Index Transforms job via +-- @GET /_plugins/_transform/{transform_id}/_explain@. The response is +-- keyed by @transform_id@ at the top level; the request builder +-- projects out the lone entry as a 'Maybe' 'TransformExplain' so the +-- public type reads as a plain per-id lookup. The 'Nothing' branch +-- surfaces when the server returns HTTP 200 with no entry (a miss is +-- more typically HTTP 404 via 'StatusDependant' before the body decode +-- runs). +-- +-- Surfaced as 'StatusDependant' so a 404 (unknown @transform_id@, the +-- plugin not installed) decodes as an 'EsError' rather than throwing. +-- +-- For more information see +-- . +explainTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse (Maybe TransformExplain)) +explainTransform transformId = + fmap (fmap (Map.lookup (unTransformId transformId))) + . withBHResponseParsedEsResponse + $ get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId, "_explain"] + +-- | 'previewTransform' previews what the transformed target index would +-- look like via @POST /_plugins/_transform/_preview@. The body is the +-- same 'Transform' wrapper as 'createTransform'; no state is +-- persisted. The response is a 'PreviewTransformResponse' carrying the +-- would-be target documents as opaque aeson 'Value's (the row shape is +-- caller-driven by @groups[].target_field@ names plus @aggregations@ +-- keys). +-- +-- Surfaced as 'StatusDependant' so a 4xx (invalid body, plugin not +-- installed, RBAC denial) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +previewTransform :: + Transform -> + BHRequest StatusDependant (ParsedEsResponse PreviewTransformResponse) +previewTransform transform = + withBHResponseParsedEsResponse $ + post @StatusDependant endpoint (encode (TransformRequest transform)) + where + endpoint = mkEndpoint ["_plugins", "_transform", "_preview"] + +-- | 'deleteTransform' deletes an Index Transforms job by id via +-- @DELETE /_plugins/_transform/{transform_id}@. The endpoint does NOT +-- delete the source or target indexes — only the transform job itself. +-- +-- The response is the bulk-response envelope (the transform is stored +-- as a doc in @.opensearch-ism-config@, so DELETE surfaces through the +-- bulk handler). The shared 'BulkResponse' from +-- @Common.Types.Bulk@ matches that envelope byte-for-byte, so we reuse +-- it rather than introducing a per-plugin wrapper. +-- +-- Surfaced as 'StatusDependant' so a 404 for a missing @transform_id@ +-- (or the plugin not installed) decodes as an 'EsError' rather than +-- throwing. +-- +-- For more information see +-- . +deleteTransform :: + TransformId -> + BHRequest StatusDependant (ParsedEsResponse BulkResponse) +deleteTransform transformId = + withBHResponseParsedEsResponse $ + delete @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_transform", unTransformId transformId] + +-- ---------------------------------------------------------------------------- +-- Job Scheduler plugin +-- +-- ---------------------------------------------------------------------------- + +-- | 'getJobSchedulerJobs' lists every scheduled job the Job Scheduler +-- plugin is tracking via @GET /_plugins/_job_scheduler/api/jobs@. The +-- response is a 'JobsResponse' (@{total_jobs, jobs, failures}@). +-- +-- /Availability:/ the @\/api\/jobs@ REST handler is only registered on +-- OpenSearch 3.x. On a 1.x or 2.x cluster the request surfaces as a 404 +-- 'EsError' via 'StatusDependant' (the plugin is installed but the +-- inspection endpoint is absent). +-- +-- For more information see +-- . +getJobSchedulerJobs :: + BHRequest StatusDependant (ParsedEsResponse JobsResponse) +getJobSchedulerJobs = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_job_scheduler", "api", "jobs"] + +-- | 'getJobSchedulerLocks' lists every distributed lock the Job Scheduler +-- plugin currently holds via @GET /_plugins/_job_scheduler/api/locks@. +-- The response is a 'LocksResponse' (@{total_locks, locks}@) whose +-- @locks@ field is a 'Map' keyed by the lock document id. Use +-- 'lookupLockEntry' to fetch a specific entry from the by-id response. +-- +-- /Availability:/ OS 3.x only — see 'getJobSchedulerJobs'. +-- +-- For more information see +-- . +getJobSchedulerLocks :: + BHRequest StatusDependant (ParsedEsResponse LocksResponse) +getJobSchedulerLocks = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_job_scheduler", "api", "locks"] + +-- | 'getJobSchedulerLock' looks up a single distributed lock by id via +-- @GET /_plugins/_job_scheduler/api/locks/{lock_id}@. The server answers +-- with the same 'LocksResponse' envelope as 'getJobSchedulerLocks' +-- (keyed by document id); use 'lookupLockEntry' on the result to obtain +-- the 'LockEntry'. A valid-format but unknown id yields an empty +-- @locks@ map rather than an error. +-- +-- The @lock_id@ /must/ be in the @index-jobid@ format +-- (e.g. @.opendistro-ism-config-myjob_123@); any other shape is rejected +-- by the server with @400 illegal_argument_exception@, which surfaces as +-- an 'EsError' via 'StatusDependant'. +-- +-- /Availability:/ OS 3.x only — see 'getJobSchedulerJobs'. +-- +-- For more information see +-- . +getJobSchedulerLock :: + LockId -> + BHRequest StatusDependant (ParsedEsResponse LocksResponse) +getJobSchedulerLock lockId = + withBHResponseParsedEsResponse $ + get @StatusDependant endpoint + where + endpoint = mkEndpoint ["_plugins", "_job_scheduler", "api", "locks", unLockId lockId] diff --git a/src/Database/Bloodhound/OpenSearch3/Types.hs b/src/Database/Bloodhound/OpenSearch3/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bloodhound/OpenSearch3/Types.hs @@ -0,0 +1,379 @@ +module Database.Bloodhound.OpenSearch3.Types + ( module Reexport, + ReplicationUseRoles (..), + StartReplicationRequest (..), + UpdateReplicationSettingsRequest (..), + CreateAutoFollowPatternRequest (..), + DeleteAutoFollowPatternRequest (..), + ReplicationStatus (..), + SyncingDetails (..), + ReplicationStatusResponse (..), + ReplicationStatusOptions (..), + LeaderIndexStats (..), + LeaderStatsResponse (..), + FollowerIndexStats (..), + FollowerStatsResponse (..), + AutoFollowRuleStats (..), + AutoFollowStatsResponse (..), + ISMPolicyRequest (..), + ISMPolicyResponse (..), + ISMPolicyBody (..), + ISMState (..), + ISMTransition (..), + ISMCondition (..), + ISMCron (..), + ISMCronCondition (..), + ISMAction (..), + actionTagName, + actionConfigValue, + ISMActionEntry (..), + ISMRetryConfig (..), + ISMRetryBackoff (..), + ismRetryBackoffText, + mkISMActionEntry, + ismActionEntryActionLens, + ismActionEntryTimeoutLens, + ismActionEntryRetryLens, + ISMRolloverConfig (..), + ISMForceMergeConfig (..), + ISMAllocationConfig (..), + ISMReplicaCountConfig (..), + ISMAliasAction (..), + ISMAliasConfig (..), + ISMTemplate (..), + ISMErrorNotification (..), + ISMErrorNotificationDestination (..), + destinationTag, + destinationConfig, + ISMMessageTemplate (..), + ISMUserVariables (..), + PolicyId (..), + PutISMPolicyResponse (..), + ISMUpdatedIndicesResponse (..), + AddISMPolicyResponse, + ISMFailedIndex (..), + ISMChangePolicyInclude (..), + ChangePolicyRequest (..), + ISMExplanationNamed (..), + ISMExplanationAction (..), + ISMExplanationStep (..), + ISMExplanationRetryInfo (..), + ISMExplanationInfo (..), + ISMExplanationValidate (..), + ISMExplanationEntry (..), + ISMExplanation (..), + ISMPolicyInfo (..), + GetISMPoliciesResponse (..), + ISMPoliciesQuery (..), + ismPoliciesQueryToPairs, + ISMExplainOptions (..), + defaultISMExplainOptions, + ismExplainOptionsParams, + ISMExplainFilter (..), + defaultISMExplainFilter, + ISMExplainFilterRequest (..), + SimulateISMPolicyRequest (..), + SimulateISMTransitionEvaluation (..), + SimulateISMPolicyResult (..), + SimulateISMPolicyResponse (..), + OpenPointInTimeResponse (..), + PITInfo (..), + ClosePointInTime (..), + ClosePointInTimeResult (..), + ClosePointInTimeResponse (..), + NeuralNodeId (..), + NeuralStatName (..), + NeuralStats (..), + NeuralStatsOptions (..), + KnnNodeId (..), + KnnStatName (..), + KnnStats (..), + KnnModelState (..), + KnnModel (..), + KnnDeleteModelResponse (..), + KnnTrainingMethod (..), + KnnTrainingRequest (..), + KnnTrainResponse (..), + MLNodeId (..), + MLStatName (..), + MLStats (..), + ModelId (..), + AlgorithmName (..), + ModelFormat (..), + ModelState (..), + ModelConfig (..), + ModelInfo (..), + RegisterModelRequest (..), + MLTaskAck (..), + DeployModelRequest (..), + UndeployModelResponse (..), + ModelNodeUndeployStats (..), + UpdateModelRequest (..), + ModelRateLimiter (..), + ModelSearchResponse (..), + ModelShards (..), + ModelTotal (..), + ModelTotalRelation (..), + ModelHit (..), + ModelGroupId (..), + ModelGroupAccessMode (..), + RegisterModelGroupRequest (..), + RegisterModelGroupResponse (..), + UpdateModelGroupRequest (..), + ModelGroupInfo (..), + ConnectorId (..), + ConnectorProtocol (..), + MLConnectorAction (..), + CreateConnectorRequest (..), + CreateConnectorResponse (..), + UpdateConnectorRequest (..), + ConnectorInfo (..), + MemoryId (..), + MessageId (..), + Memory (..), + CreateMemoryRequest (..), + CreateMemoryResponse (..), + DeleteMemoryResponse (..), + ListMemoriesResponse (..), + MemoryMessage (..), + CreateMemoryMessageRequest (..), + CreateMemoryMessageResponse (..), + ListMemoryMessagesResponse (..), + MemoryMessageTraces (..), + ControllerConfig (..), + ControllerCreateResponse (..), + MLProfileRequest (..), + MLProfilePredictRequestStats (..), + MLProfileModel (..), + MLProfileNode (..), + MLProfileResponse (..), + MLTaskId (..), + MLTaskType (..), + MLTaskState (..), + MLTaskInfo (..), + TrainModelRequest (..), + TrainAndPredictResponse (..), + AgentId (..), + AgentType (..), + LlmConfig (..), + MemoryConfig (..), + ToolConfig (..), + ToolInlineConfig (..), + RegisterAgentRequest (..), + RegisterAgentResponse (..), + UpdateAgentRequest (..), + ExecuteAgentRequest (..), + ExecuteAgentResponse (..), + InferenceResult (..), + ExecuteOutput (..), + AgUIEvent (..), + ExecuteStreamChunk (..), + AgentInfo (..), + AgentShards (..), + AgentTotal (..), + AgentTotalRelation (..), + AgentHit (..), + AgentSearchResponse (..), + SQLRequest (..), + PPLRequest (..), + SQLParameter (..), + SQLCursor (..), + SQLCursorRequest (..), + SQLColumn (..), + SQLResult (..), + SQLCloseResult (..), + SQLPluginStats (..), + DetectorId (..), + PeriodUnit (..), + Period (..), + WindowPeriod (..), + FeatureAttribute (..), + DetectorType (..), + User (..), + Detector (..), + DetectorResponse (..), + CreateDetectorResponse (..), + PreviewRequest (..), + FeatureData (..), + Entity (..), + AnomalyResult (..), + PreviewResponse (..), + StartDetectorJobRequest (..), + DetectorJobAcknowledgment (..), + AnomalyShards (..), + DeleteDetectorResponse (..), + ValidateDetectorMode (..), + ValidateDetectorResponse (..), + AnomalySearchTotalRelation (..), + AnomalySearchTotal (..), + AnomalySearchHit (..), + AnomalySearchResponse (..), + DetectorProfileResponse (..), + DetectorStatsResponse (..), + TopAnomaliesOrder (..), + TopAnomaliesRequest (..), + TopAnomalyBucket (..), + TopAnomaliesResponse (..), + NotificationConfigType (..), + NotificationTransport (..), + NotificationConfig (..), + NotificationConfigEntry (..), + GetNotificationConfigsResponse (..), + Channel (..), + GetNotificationChannelsResponse (..), + NotificationSortOrder (..), + NotificationListOptions (..), + CreateNotificationConfigRequest (..), + CreateNotificationConfigResponse (..), + UpdateNotificationConfigRequest (..), + DeleteNotificationConfigResponse (..), + NotificationFeaturesResponse (..), + TestNotificationResponse (..), + TestNotificationEventSource (..), + TestNotificationStatus (..), + TestNotificationDeliveryStatus (..), + SlackTransport (..), + ChimeTransport (..), + WebhookTransport (..), + MicrosoftTeamsTransport (..), + SnsTransport (..), + SesAccountTransport (..), + SmtpAccountTransport (..), + EmailGroupTransport (..), + EmailTransport (..), + EmailRecipient (..), + WorkflowId (..), + WorkflowTemplate (..), + WorkflowVersion (..), + WorkflowState (..), + WorkflowEntry (..), + WorkflowNode (..), + WorkflowEdge (..), + NodeInputs (..), + CreateConnectorUserInputs (..), + WorkflowConnectorAction (..), + RegisterRemoteModelUserInputs (..), + DeployModelUserInputs (..), + CreateIndexUserInputs (..), + CreateIngestPipelineUserInputs (..), + ResourceCreated (..), + CreateWorkflowResponse (..), + CreateWorkflowOptions (..), + ValidationMode (..), + ProvisionOptions (..), + DeleteWorkflowOptions (..), + DeprovisionWorkflowOptions (..), + DeprovisionWorkflowResponse (..), + WorkflowStateOptions (..), + WorkflowStateResponse (..), + WorkflowStep (..), + WorkflowStepsResponse (..), + WorkflowStepsOptions (..), + RollupId (..), + Rollup (..), + RollupWrapper (..), + RollupSchedule (..), + RollupInterval (..), + RollupIntervalUnit (..), + RollupCron (..), + RollupDimension (..), + RollupDateHistogram (..), + RollupTerms (..), + RollupHistogram (..), + RollupMetric (..), + RollupMetricAgg (..), + RollupResponse (..), + RollupResponseInner (..), + ExplainRollupResponse (..), + ExplainRollupEntry (..), + RollupMetadata (..), + RollupStatus (..), + RollupStats (..), + SMPolicyName (..), + SMCron (..), + SMSchedule (..), + SMJobSchedulerInterval (..), + SMCreation (..), + SMDeleteCondition (..), + SMDeletion (..), + SMSnapshotConfig (..), + parseLenientBool, + SMNotificationChannel (..), + SMNotificationConditions (..), + SMNotification (..), + SMPolicyBody (..), + SMPolicy (..), + SMPolicyResponse (..), + GetSMPoliciesResponse (..), + GetSMPoliciesQuery (..), + defaultGetSMPoliciesQuery, + getSMPoliciesQueryParams, + DeleteSMPolicyResponse (..), + SMExplainExecution (..), + SMExplainTrigger (..), + SMExplainRetry (..), + SMExplainWorkflow (..), + SMExplainEntry (..), + SMExplainResponse (..), + TransformId (..), + TransformPeriodUnit (..), + TransformInterval (..), + TransformSchedule (..), + TransformGroup (..), + TermsGroup (..), + HistogramGroup (..), + DateHistogramGroup (..), + Transform (..), + TransformResponse (..), + TransformRequest (..), + TransformDocumentResponse (..), + TransformSortDirection (..), + TransformsListOptions (..), + GetTransformsResponse (..), + GetTransformsListEntry (..), + TransformExplain (..), + TransformMetadata (..), + TransformStats (..), + TransformContinuousStats (..), + PreviewTransformResponse (..), + ) +where + +-- Hide ES-only Common types that collide with OpenSearch plugin +-- re-exports below: the ES Security 'User' (OpenSearch security lives at +-- /_plugins/_security) and the ES X-Pack Transform types that share +-- names with the OpenSearch Index Transforms plugin (IndexTransforms). +import Database.Bloodhound.Common.Types as Reexport hiding + ( PreviewTransformResponse, + TransformId, + TransformStats, + User, + unTransformId, + ) +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.Alerting as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.AnomalyDetection as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.CCR as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.FlowFramework as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.ISM +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.IndexTransforms as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.JobScheduler as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.KnnModel as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.KnnStats as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.KnnTrain as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLAgent as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLConnectors as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLControllers as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLMemory as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLModel as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLModelGroups as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLProfile as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLStats as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.MLTask as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.NeuralStats as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.Notifications as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.PointInTime as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.Rollups as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.SQLPPL as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.SQLStats as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.SecurityAnalytics as Reexport +import Database.Bloodhound.Internal.Versions.OpenSearch3.Types.SnapshotManagement diff --git a/src/Database/Bloodhound/Types.hs b/src/Database/Bloodhound/Types.hs --- a/src/Database/Bloodhound/Types.hs +++ b/src/Database/Bloodhound/Types.hs @@ -4,3 +4,4 @@ where import Database.Bloodhound.ElasticSearch7.Types as Reexport +import Database.Bloodhound.Internal.Versions.Common.Types.Aggregation as Reexport diff --git a/tests/Test/AggregationSpec.hs b/tests/Test/AggregationSpec.hs --- a/tests/Test/AggregationSpec.hs +++ b/tests/Test/AggregationSpec.hs @@ -3,11 +3,21 @@ module Test.AggregationSpec (spec) where import Control.Error (fmapL, note) -import qualified Data.Map as M -import qualified Database.Bloodhound +import Data.Map qualified as M +import Data.Text qualified as T +import Database.Bloodhound qualified +import Database.Bloodhound.Types (BucketsPath) import TestsUtils.Common import TestsUtils.Import +-- | Extract a single aggregation value from a tweet-search result that may +-- itself have failed. Returns 'Nothing' if the request failed, no +-- aggregations were returned, or the named aggregation is absent. Used by +-- the pipeline-aggregation specs (bloodhound-5vp) to assert just the +-- pipeline value without depending on the (brittle) parent bucket shape. +lookupAgg :: Key -> Either EsError (SearchResult a) -> Maybe Value +lookupAgg name = either (const Nothing) (aggregations >=> M.lookup name) + spec :: Spec spec = describe "Aggregation API" $ do @@ -115,7 +125,7 @@ let ags = mkAggregations "date_ranges" (DateRangeAgg agg) let search = mkAggregateSearch Nothing ags res <- searchTweets search - liftIO $ hitsTotal . searchHits <$> res `shouldBe` Right (HitsTotal 2 HTR_EQ) + liftIO $ hitsTotal . searchHits <$> res `shouldBe` Right (Just (HitsTotal 2 HTR_EQ)) let bucks = do magrs <- fmapL show (aggregations <$> res) agrs <- note "no aggregations returned" magrs @@ -148,7 +158,7 @@ it "returns date histogram aggregation results" $ withTestEnv $ do _ <- insertData - let histogram = DateHistogramAgg (mkDateHistogram (FieldName "postDate")) {dateInterval = Just Minute} + let histogram = DateHistogramAgg (mkDateHistogram (FieldName "postDate")) {dateFixedInterval = Just (FixedInterval 1 Minutes)} let search = mkAggregateSearch Nothing (mkAggregations "byDate" histogram) searchExpectAggs search searchValidBucketAgg search "byDate" toDateHistogram @@ -163,3 +173,188 @@ res <- searchTweets search liftIO $ fmap aggregations res `shouldBe` Right (Just (M.fromList [docCountPair "missing_agg" 1])) + + -- With a single document indexed (exampleTweet, age = 10000), min == max + -- == 10000. Mirrors the sibling "max aggregation" spec below. + it "can execute min aggregation" $ + withTestEnv $ do + _ <- insertData + let minAgg = MinAgg (mkMinAggregation (FieldName "age")) + let search = mkAggregateSearch Nothing (mkAggregations "min_age" minAgg) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' + res <- searchTweets search' + liftIO $ + fmap aggregations res `shouldBe` Right (Just (M.fromList [("min_age", object ["value" .= Number 10000])])) + + it "can execute max aggregation" $ + withTestEnv $ do + _ <- insertData + let maxAgg = MaxAgg (mkMaxAggregation (FieldName "age")) + let search = mkAggregateSearch Nothing (mkAggregations "max_age" maxAgg) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' + res <- searchTweets search' + liftIO $ + fmap aggregations res `shouldBe` Right (Just (M.fromList [("max_age", object ["value" .= Number 10000])])) + + -- Bucket aggregations return a @buckets@ array, not a top-level + -- @doc_count@. Single doc (age = 10000), interval 1000 -> one bucket + -- keyed at 10000.0. + it "can execute histogram aggregation" $ + withTestEnv $ do + _ <- insertData + let histogram = HistogramAgg (mkHistogramAggregation (FieldName "age") 1000) + let search = mkAggregateSearch Nothing (mkAggregations "age_histogram" histogram) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' + res <- searchTweets search' + liftIO $ + lookupAgg "age_histogram" res `shouldBe` Just (object ["buckets" .= [object ["key" .= Number 10000, "doc_count" .= Number 1]]]) + + -- Bucket-shape drift as above: @buckets@ array with one entry per range. + -- Ranges: 0.0-*, 0.0-1000.0, 10000.0-*. Single doc age = 10000 falls in + -- both unbounded-from-above ranges. ES orders buckets by @from@ asc, + -- bounded-before-unbounded on ties, hence 0.0-1000.0 precedes 0.0-*. + it "can execute range aggregation" $ + withTestEnv $ do + _ <- insertData + let rangeAgg = RangeAgg (mkRangeAggregation (FieldName "age") (RangeFrom 0 :| [RangeFromTo 0 1000, RangeFrom 10000])) + let search = mkAggregateSearch Nothing (mkAggregations "age_ranges" rangeAgg) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' + res <- searchTweets search' + liftIO $ + lookupAgg "age_ranges" res `shouldBe` Just (object ["buckets" .= [object ["key" .= String "0.0-1000.0", "from" .= Number 0, "to" .= Number 1000, "doc_count" .= Number 0], object ["key" .= String "0.0-*", "from" .= Number 0, "doc_count" .= Number 1], object ["key" .= String "10000.0-*", "from" .= Number 10000, "doc_count" .= Number 1]]]) + + -- The Tweet fixture has no @comments@ field, so the nested aggregation + -- correctly reports doc_count = 0. + it "can execute nested aggregation" $ + withTestEnv $ do + _ <- insertData + let nestedAgg = NestedAgg (mkNestedAggregation (FieldName "comments")) + let search = mkAggregateSearch Nothing (mkAggregations "comments_nested" nestedAgg) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' + res <- searchTweets search' + liftIO $ + lookupAgg "comments_nested" res `shouldBe` Just (object ["doc_count" .= Number 0]) + + -- With a single document, every requested percentile equals age = 10000. + -- ES defaults to the 7 percentiles below. + it "can execute percentile aggregation" $ + withTestEnv $ do + _ <- insertData + let percentileAgg = PercentileAgg (mkPercentileAggregation (FieldName "age")) + let search = mkAggregateSearch Nothing (mkAggregations "age_percentiles" percentileAgg) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' + res <- searchTweets search' + liftIO $ + lookupAgg "age_percentiles" res `shouldBe` Just (object ["values" .= object ["1.0" .= Number 10000, "5.0" .= Number 10000, "25.0" .= Number 10000, "50.0" .= Number 10000, "75.0" .= Number 10000, "95.0" .= Number 10000, "99.0" .= Number 10000]]) + + -- The pipeline-aggregation tests below were restructured in bloodhound-5vp. + -- Previous shape placed the metric agg (SumAgg/AvgAgg/...) directly under + -- the @ages@ name as a sibling of the pipeline agg, then pointed + -- @buckets_path@ at @ages>sum_age@. Modern Elasticsearch validates the + -- path and rejects it because @ages@ has no bucket children. The fix is to + -- make @ages@ a real bucket aggregation (TermsAgg on @user@) with the + -- metric as a named sub-aggregation, so the path "ages>metric" + -- resolves. With a single document indexed (exampleTweet, age = 10000), + -- the bucket contains one value, 10000, so every sibling pipeline + -- aggregator reduces to that same number. + it "can execute avg bucket aggregation" $ + withTestEnv $ do + _ <- insertData + let sumAgg = SumAgg (mkSumAggregation (FieldName "age")) + let agesAgg = TermsAgg $ (mkTermsAggregation (FieldName "user")) {termAggs = Just (mkAggregations "sum_age" sumAgg)} + let avgBucketAgg = AvgBucketAgg (mkAvgBucketAggregation (BucketsPath "ages>sum_age")) + let search = mkAggregateSearch Nothing (mkAggregations "ages" agesAgg <> mkAggregations "avg_ages" avgBucketAgg) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' + res <- searchTweets search' + liftIO $ + lookupAgg "avg_ages" res `shouldBe` Just (object ["value" .= Number 10000]) + + it "can execute sum bucket aggregation" $ + withTestEnv $ do + _ <- insertData + let avgAgg = AvgAgg (mkAvgAggregation (FieldName "age")) + let agesAgg = TermsAgg $ (mkTermsAggregation (FieldName "user")) {termAggs = Just (mkAggregations "avg_age" avgAgg)} + let sumBucketAgg = SumBucketAgg (mkSumBucketAggregation (BucketsPath "ages>avg_age")) + let search = mkAggregateSearch Nothing (mkAggregations "ages" agesAgg <> mkAggregations "sum_ages" sumBucketAgg) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' + res <- searchTweets search' + liftIO $ + lookupAgg "sum_ages" res `shouldBe` Just (object ["value" .= Number 10000]) + + it "can execute min bucket aggregation" $ + withTestEnv $ do + _ <- insertData + let maxAgg = MaxAgg (mkMaxAggregation (FieldName "age")) + let agesAgg = TermsAgg $ (mkTermsAggregation (FieldName "user")) {termAggs = Just (mkAggregations "max_age" maxAgg)} + let minBucketAgg = MinBucketAgg (mkMinBucketAggregation (BucketsPath "ages>max_age")) + let search = mkAggregateSearch Nothing (mkAggregations "ages" agesAgg <> mkAggregations "min_ages" minBucketAgg) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' + res <- searchTweets search' + liftIO $ + lookupAgg "min_ages" res `shouldBe` Just (object ["keys" .= ["bitemyapp" :: Text], "value" .= Number 10000]) + + it "can execute max bucket aggregation" $ + withTestEnv $ do + _ <- insertData + let minAgg = MinAgg (mkMinAggregation (FieldName "age")) + let agesAgg = TermsAgg $ (mkTermsAggregation (FieldName "user")) {termAggs = Just (mkAggregations "min_age" minAgg)} + let maxBucketAgg = MaxBucketAgg (mkMaxBucketAggregation (BucketsPath "ages>min_age")) + let search = mkAggregateSearch Nothing (mkAggregations "ages" agesAgg <> mkAggregations "max_ages" maxBucketAgg) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' + res <- searchTweets search' + liftIO $ + lookupAgg "max_ages" res `shouldBe` Just (object ["keys" .= ["bitemyapp" :: Text], "value" .= Number 10000]) + + it "can execute stats bucket aggregation" $ + withTestEnv $ do + _ <- insertData + let sumAgg = SumAgg (mkSumAggregation (FieldName "age")) + let agesAgg = TermsAgg $ (mkTermsAggregation (FieldName "user")) {termAggs = Just (mkAggregations "sum_age" sumAgg)} + let statsBucketAgg = StatsBucketAgg (mkStatsBucketAggregation (BucketsPath "ages>sum_age")) + let search = mkAggregateSearch Nothing (mkAggregations "ages" agesAgg <> mkAggregations "stats_ages" statsBucketAgg) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' + res <- searchTweets search' + liftIO $ + lookupAgg "stats_ages" res `shouldBe` Just (object ["count" .= Number 1, "min" .= Number 10000, "max" .= Number 10000, "avg" .= Number 10000, "sum" .= Number 10000]) + + -- derivative and cumulative_sum are *parent* pipeline aggregations: + -- Elasticsearch requires them to live inside a histogram-family bucket + -- aggregation (histogram / date_histogram / auto_date_histogram), with a + -- path relative to each bucket. Two documents are indexed so derivative + -- has more than one bucket to diff over; we assert only that the request + -- succeeds (searchExpectAggs) since per-bucket values are ordering + -- dependent. + it "can execute derivative aggregation" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + let sumAgg = SumAgg (mkSumAggregation (FieldName "age")) + let derivativeAgg = DerivativeAgg (mkDerivativeAggregation (BucketsPath "sum_age")) + let subAggs = mkAggregations "sum_age" sumAgg <> mkAggregations "derivatives" derivativeAgg + let histAgg = HistogramAgg $ (mkHistogramAggregation (FieldName "age") 1000) {histogramMinDocCount = Just 0, histogramAggs = Just subAggs} + let search = mkAggregateSearch Nothing (mkAggregations "ages" histAgg) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' + + it "can execute cumulative sum aggregation" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + let sumAgg = SumAgg (mkSumAggregation (FieldName "age")) + let cumulativeSumAgg = CumulativeSumAgg (mkCumulativeSumAggregation (BucketsPath "sum_age")) + let subAggs = mkAggregations "sum_age" sumAgg <> mkAggregations "cumulative" cumulativeSumAgg + let histAgg = HistogramAgg $ (mkHistogramAggregation (FieldName "age") 1000) {histogramMinDocCount = Just 0, histogramAggs = Just subAggs} + let search = mkAggregateSearch Nothing (mkAggregations "ages" histAgg) + let search' = search {Database.Bloodhound.from = From 0, size = Size 0} + searchExpectAggs search' diff --git a/tests/Test/AlertingSpec.hs b/tests/Test/AlertingSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/AlertingSpec.hs @@ -0,0 +1,1782 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.AlertingSpec (spec) where + +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List (isInfixOf, sortOn) +import Data.Maybe (fromJust, isJust) +import Database.Bloodhound.OpenSearch1.Client qualified as OS1.Client +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch1.Types qualified as OS1A +import Database.Bloodhound.OpenSearch2.Client qualified as OS2.Client +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2A +import Database.Bloodhound.OpenSearch3.Client qualified as OS3.Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types qualified as OS3A +import Numeric.Natural (Natural) +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- | Pure endpoint-shape and decoder tests for the Alerting plugin monitor +-- CRUD endpoints (@POST\/GET\/PUT\/DELETE /_plugins/_alerting/monitors[\/{id}]@) +-- across OpenSearch 1, 2, and 3. Mirrors 'Test.KnnWarmupSpec'\/'Test.IsmSpec' +-- for the shape tests and 'Test.MLModelSpec' for the decoder tests. +-- +-- The monitor 'Monitor' is modelled pragmatically: the typed shell (name, +-- enabled, schedule, triggers, actions) plus opaque aeson 'Value's for the +-- per-kind payloads. These tests pin (a) the endpoint shape per backend, +-- (b) OS1\/OS2\/OS3 cross-backend parity, (c) decoder round-trips for the +-- documented wire fixtures, and (d) the wrapper-key discrimination on +-- 'Trigger' (query-level bare vs. bucket-level wrapped). +-- +-- The live round-trip is @pendingWith@'d: the CI docker-compose runs +-- Elasticsearch clusters only, so the Alerting plugin (OS-specific) is not +-- available in CI. Re-enable once a live OS cluster is wired in; see the +-- precedent in 'Test.KnnWarmupSpec' \/ 'Test.IsmSpec' live blocks. +spec :: Spec +spec = describe "Alerting monitor CRUD API" $ do + -- =========================================================== -- + -- Endpoint shape: OpenSearch 3 (detailed) -- + -- =========================================================== -- + describe "endpoint shape (OpenSearch 3)" $ do + it "createMonitor POSTs to /_plugins/_alerting/monitors with the encoded body" $ do + let req = OS3Requests.createMonitor os3SampleMonitor + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + -- Body is present and decodes back to the same monitor on the typed fields. + let body = fromJust (bhRequestBody req) + let decoded = (decode body :: Maybe OS3A.Monitor) + decoded `shouldSatisfy` \m -> isJust m && OS3A.monitorName (fromJust m) == "test-monitor" + + it "getMonitor GETs /_plugins/_alerting/monitors/{id} with no body" $ do + let req = OS3Requests.getMonitor (OS3A.MonitorId "my-monitor-id") + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "my-monitor-id"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "getMonitor keeps the id as a single opaque path segment" $ do + let req = OS3Requests.getMonitor (OS3A.MonitorId "my-monitor_42") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "my-monitor_42"] + + it "getMonitor uses a distinct id in the path for a different MonitorId" $ do + let req = OS3Requests.getMonitor (OS3A.MonitorId "other-id") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "other-id"] + + it "updateMonitor PUTs /_plugins/_alerting/monitors/{id} with the encoded body" $ do + let req = OS3Requests.updateMonitor (OS3A.MonitorId "my-monitor-id") os3SampleMonitor + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "my-monitor-id"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldSatisfy` isJust + + it "deleteMonitor DELETEs /_plugins/_alerting/monitors/{id} with no body" $ do + let req = OS3Requests.deleteMonitor (OS3A.MonitorId "my-monitor-id") + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "my-monitor-id"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + -- =========================================================== -- + -- Endpoint shape: OpenSearch 1 and 2 (path/method parity) -- + -- =========================================================== -- + describe "endpoint shape (OpenSearch 1)" $ do + it "getMonitor GETs /_plugins/_alerting/monitors/{id}" $ do + let req = OS1Requests.getMonitor (OS1A.MonitorId "os1-id") + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "os1-id"] + bhRequestBody req `shouldBe` Nothing + + it "deleteMonitor DELETEs /_plugins/_alerting/monitors/{id}" $ do + let req = OS1Requests.deleteMonitor (OS1A.MonitorId "os1-id") + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "os1-id"] + + it "createMonitor POSTs to /_plugins/_alerting/monitors" $ do + let req = OS1Requests.createMonitor os1SampleMonitor + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors"] + + it "updateMonitor PUTs /_plugins/_alerting/monitors/{id}" $ do + let req = OS1Requests.updateMonitor (OS1A.MonitorId "os1-id") os1SampleMonitor + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "os1-id"] + + describe "endpoint shape (OpenSearch 2)" $ do + it "getMonitor GETs /_plugins/_alerting/monitors/{id}" $ do + let req = OS2Requests.getMonitor (OS2A.MonitorId "os2-id") + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "os2-id"] + bhRequestBody req `shouldBe` Nothing + + it "deleteMonitor DELETEs /_plugins/_alerting/monitors/{id}" $ do + let req = OS2Requests.deleteMonitor (OS2A.MonitorId "os2-id") + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "os2-id"] + + it "createMonitor POSTs to /_plugins/_alerting/monitors" $ do + let req = OS2Requests.createMonitor os2SampleMonitor + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors"] + + it "updateMonitor PUTs /_plugins/_alerting/monitors/{id}" $ do + let req = OS2Requests.updateMonitor (OS2A.MonitorId "os2-id") os2SampleMonitor + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "os2-id"] + + -- =========================================================== -- + -- Cross-backend parity (OS1, OS2, OS3 emit identical requests) -- + -- =========================================================== -- + describe "cross-backend parity" $ do + let mid1 = OS1A.MonitorId "shared-id" + mid2 = OS2A.MonitorId "shared-id" + mid3 = OS3A.MonitorId "shared-id" + + it "createMonitor: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.createMonitor os1SampleMonitor)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.createMonitor os2SampleMonitor)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.createMonitor os2SampleMonitor)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.createMonitor os3SampleMonitor)) + bhRequestMethod (OS1Requests.createMonitor os1SampleMonitor) + `shouldBe` bhRequestMethod (OS3Requests.createMonitor os3SampleMonitor) + + it "createMonitor: OS1, OS2, OS3 attach identical body bytes" $ do + -- The three Monitors are structurally identical, so their encoded + -- bodies must match byte-for-byte across the three backends. + let b1 = bhRequestBody (OS1Requests.createMonitor os1SampleMonitor) + b2 = bhRequestBody (OS2Requests.createMonitor os2SampleMonitor) + b3 = bhRequestBody (OS3Requests.createMonitor os3SampleMonitor) + b1 `shouldBe` b2 + b2 `shouldBe` b3 + + it "getMonitor: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.getMonitor mid1)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.getMonitor mid2)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.getMonitor mid2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.getMonitor mid3)) + bhRequestMethod (OS1Requests.getMonitor mid1) + `shouldBe` bhRequestMethod (OS3Requests.getMonitor mid3) + + it "deleteMonitor: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.deleteMonitor mid1)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteMonitor mid2)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteMonitor mid2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteMonitor mid3)) + bhRequestMethod (OS1Requests.deleteMonitor mid1) + `shouldBe` bhRequestMethod (OS3Requests.deleteMonitor mid3) + + -- =========================================================== -- + -- Decoder tests (OS3 types — identical instances across OS1-3) -- + -- =========================================================== -- + describe "MonitorResponse decoding" $ do + let fixture = + LBS.pack + "{\"_id\":\"vd5k2GsBlQ5JUWWFxhsP\",\"_version\":1,\"_seq_no\":0,\"_primary_term\":1,\"monitor\":{\"type\":\"monitor\",\"schema_version\":1,\"name\":\"test-monitor\",\"monitor_type\":\"query_level_monitor\",\"enabled\":true,\"enabled_time\":1551466220455,\"schedule\":{\"period\":{\"interval\":1,\"unit\":\"MINUTES\"}},\"inputs\":[],\"triggers\":[],\"last_update_time\":1551466639295}}" + + it "decodes the documented create-response fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.MonitorResponse + OS3A.monitorResponseId decoded `shouldBe` "vd5k2GsBlQ5JUWWFxhsP" + OS3A.monitorResponseVersion decoded `shouldBe` 1 + OS3A.monitorResponseSeqNo decoded `shouldBe` 0 + OS3A.monitorResponsePrimaryTerm decoded `shouldBe` 1 + let mon = OS3A.monitorResponseMonitor decoded + OS3A.monitorName mon `shouldBe` "test-monitor" + OS3A.monitorEnabled mon `shouldBe` Just True + OS3A.monitorEnabledTime mon `shouldBe` Just 1551466220455 + OS3A.monitorMonitorType mon `shouldBe` Just OS3A.MonitorTypeQueryLevel + OS3A.monitorType mon `shouldBe` Just OS3A.AlertTypeMonitor + OS3A.monitorSchemaVersion mon `shouldBe` Just 1 + + it "monitor round-trips through encode/decode on the typed fields" $ do + let encoded = encode os3SampleMonitor + Just reDecoded = decode encoded :: Maybe OS3A.Monitor + OS3A.monitorName reDecoded `shouldBe` OS3A.monitorName os3SampleMonitor + OS3A.monitorSchedule reDecoded `shouldBe` OS3A.monitorSchedule os3SampleMonitor + OS3A.monitorMonitorType reDecoded `shouldBe` OS3A.monitorMonitorType os3SampleMonitor + + describe "DeleteMonitorResponse decoding" $ do + let fixture = + LBS.pack + "{\"_index\":\".opensearch-scheduled-jobs\",\"_id\":\"vd5k2GsBlQ5JUWWFxhsP\",\"_version\":2,\"result\":\"deleted\",\"forced_refresh\":false,\"_shards\":{\"total\":2,\"successful\":1,\"skipped\":0,\"failed\":0},\"_seq_no\":1,\"_primary_term\":1}" + + it "decodes the full bare delete-document fixture (OS 1.3.x shape)" $ do + let Just decoded = decode fixture :: Maybe OS3A.DeleteMonitorResponse + OS3A.deleteMonitorResponseIndex decoded `shouldBe` Just ".opensearch-scheduled-jobs" + OS3A.deleteMonitorResponseId decoded `shouldBe` "vd5k2GsBlQ5JUWWFxhsP" + OS3A.deleteMonitorResponseVersion decoded `shouldBe` 2 + OS3A.deleteMonitorResponseResult decoded `shouldBe` Just "deleted" + OS3A.deleteMonitorResponseForcedRefresh decoded `shouldBe` Just False + let Just sh = OS3A.deleteMonitorResponseShards decoded + OS3A.alertingShardsTotal sh `shouldBe` 2 + OS3A.alertingShardsSuccessful sh `shouldBe` 1 + OS3A.alertingShardsFailed sh `shouldBe` 0 + OS3A.deleteMonitorResponseSeqNo decoded `shouldBe` Just 1 + OS3A.deleteMonitorResponsePrimaryTerm decoded `shouldBe` Just 1 + + it "decodes the minimal {_id,_version} fixture (OS 2.x/3.x shape, live-verified bead bloodhound-z5j)" $ do + let minimal = LBS.pack "{\"_id\":\"abc123\",\"_version\":2}" + Just decoded = decode minimal :: Maybe OS3A.DeleteMonitorResponse + OS3A.deleteMonitorResponseId decoded `shouldBe` "abc123" + OS3A.deleteMonitorResponseVersion decoded `shouldBe` 2 + OS3A.deleteMonitorResponseIndex decoded `shouldBe` Nothing + OS3A.deleteMonitorResponseResult decoded `shouldBe` Nothing + OS3A.deleteMonitorResponseForcedRefresh decoded `shouldBe` Nothing + OS3A.deleteMonitorResponseShards decoded `shouldBe` Nothing + OS3A.deleteMonitorResponseSeqNo decoded `shouldBe` Nothing + OS3A.deleteMonitorResponsePrimaryTerm decoded `shouldBe` Nothing + + it "rejects a payload missing _id (the sole universally-required field)" $ do + let decoded = decode "{\"_version\":2}" :: Maybe OS3A.DeleteMonitorResponse + decoded `shouldBe` Nothing + + describe "Schedule decoding" $ do + it "decodes a period schedule" $ do + let Just s = decode "{\"period\":{\"interval\":5,\"unit\":\"HOURS\"}}" :: Maybe OS3A.Schedule + Just (OS3A.PeriodSchedule p) = Just s + OS3A.schedulePeriodInterval p `shouldBe` 5 + OS3A.schedulePeriodUnit p `shouldBe` "HOURS" + + it "decodes a cron schedule" $ do + let Just s = decode "{\"cron\":{\"expression\":\"10 12 1 * *\",\"timezone\":\"America/Los_Angeles\"}}" :: Maybe OS3A.Schedule + Just (OS3A.CronSchedule c) = Just s + OS3A.scheduleCronExpression c `shouldBe` "10 12 1 * *" + OS3A.scheduleCronTimezone c `shouldBe` Just "America/Los_Angeles" + + it "falls through to OtherSchedule for an unknown schedule kind" $ do + let Just s = decode "{\"custom\":{\"foo\":1}}" :: Maybe OS3A.Schedule + Just (OS3A.OtherSchedule _) = Just s + s `shouldBe` OS3A.OtherSchedule (object ["custom" .= object ["foo" .= (1 :: Int)]]) + + describe "MonitorType discriminator" $ do + it "decodes each documented monitor_type value" $ do + "query_level_monitor" `decodesMonitorTypeTo` OS3A.MonitorTypeQueryLevel + "bucket_level_monitor" `decodesMonitorTypeTo` OS3A.MonitorTypeBucketLevel + "doc_level_monitor" `decodesMonitorTypeTo` OS3A.MonitorTypeDocLevel + "cluster_metrics_monitor" `decodesMonitorTypeTo` OS3A.MonitorTypeClusterMetrics + "remote_monitor" `decodesMonitorTypeTo` OS3A.MonitorTypeRemote + + it "round-trips through monitorTypeText" $ + OS3A.monitorTypeText OS3A.MonitorTypeQueryLevel `shouldBe` "query_level_monitor" + + it "falls through to MonitorTypeOther for an unknown value" $ + "future_monitor_kind" `decodesMonitorTypeTo` OS3A.MonitorTypeOther "future_monitor_kind" + + describe "Trigger wrapper-key discrimination" $ do + it "decodes a bare query-level trigger (fields directly on the element)" $ do + let fixture = + LBS.pack + "{\"name\":\"t\",\"severity\":\"1\",\"condition\":{\"script\":{\"source\":\"ctx.results[0] > 0\",\"lang\":\"painless\"}},\"actions\":[]}" + let Just t = decode fixture :: Maybe OS3A.Trigger + OS3A.triggerName t `shouldBe` "t" + OS3A.triggerSeverity t `shouldBe` "1" + OS3A.triggerActions t `shouldBe` [] + + it "decodes a wrapped bucket-level trigger (fields under bucket_level_trigger)" $ do + let fixture = + LBS.pack + "{\"bucket_level_trigger\":{\"name\":\"bt\",\"severity\":\"2\",\"condition\":{\"buckets_path\":{\"_count\":\"_count\"},\"parent_bucket_path\":\"agg\"},\"actions\":[]}}" + let Just t = decode fixture :: Maybe OS3A.Trigger + OS3A.triggerName t `shouldBe` "bt" + OS3A.triggerSeverity t `shouldBe` "2" + + it "decodes a wrapped document-level trigger (fields under document_level_trigger)" $ do + let fixture = + LBS.pack + "{\"document_level_trigger\":{\"name\":\"dt\",\"severity\":\"3\",\"condition\":{\"script\":{\"source\":\"true\",\"lang\":\"painless\"}},\"actions\":[]}}" + let Just t = decode fixture :: Maybe OS3A.Trigger + OS3A.triggerName t `shouldBe` "dt" + OS3A.triggerSeverity t `shouldBe` "3" + + it "round-trips a wrapped bucket-level trigger losslessly" $ do + let fixture = + LBS.pack + "{\"bucket_level_trigger\":{\"name\":\"bt\",\"severity\":\"2\",\"condition\":{\"buckets_path\":{}},\"actions\":[]}}" + let Just t = decode fixture :: Maybe OS3A.Trigger + -- The wrapper key must survive the encode so the discrimination round-trips. + encode t `shouldSatisfy` \bs -> "bucket_level_trigger" `isInfixOf` LBS.unpack bs + + it "severity is decoded as a string (not a number) per the wire" $ do + let Just t = decode "{\"name\":\"x\",\"severity\":\"1\",\"condition\":{},\"actions\":[]}" :: Maybe OS3A.Trigger + OS3A.triggerSeverity t `shouldBe` "1" + + describe "Action decoding" $ do + it "decodes a full action fixture" $ do + let fixture = + LBS.pack + "{\"name\":\"test-action\",\"destination_id\":\"ld7912sBlQ5JUWWFThoW\",\"message_template\":{\"source\":\"Body.\",\"lang\":\"mustache\"},\"subject_template\":{\"source\":\"Subject\",\"lang\":\"mustache\"},\"throttle_enabled\":true,\"throttle\":{\"value\":27,\"unit\":\"MINUTES\"}}" + let Just a = decode fixture :: Maybe OS3A.Action + OS3A.actionName a `shouldBe` "test-action" + OS3A.actionDestinationId a `shouldBe` "ld7912sBlQ5JUWWFThoW" + OS3A.actionThrottleEnabled a `shouldBe` Just True + let Just th = OS3A.actionThrottle a + OS3A.throttleValue th `shouldBe` 27 + OS3A.throttleUnit th `shouldBe` "MINUTES" + + -- =========================================================== -- + -- Destinations: GET /_plugins/_alerting/destinations -- + -- Endpoint shape, decoders, type round-trip, query params. -- + -- =========================================================== -- + describe "getDestinations endpoint shape (OpenSearch 3)" $ do + it "getDestinations GETs /_plugins/_alerting/destinations with no body" $ do + let req = OS3Requests.getDestinations + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations"] + bhRequestBody req `shouldBe` Nothing + + it "getDestinations with default options emits no query params" $ do + let req = OS3Requests.getDestinationsWith OS3A.defaultDestinationListOptions + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "getDestinationsWith forwards options as camelCase query params" $ do + let opts = + OS3A.defaultDestinationListOptions + { OS3A.destinationListOptionsSize = Just 5, + OS3A.destinationListOptionsStartIndex = Just 10, + OS3A.destinationListOptionsSortString = Just "destination.name.keyword", + OS3A.destinationListOptionsSortOrder = Just OS3A.DestinationSortOrderDesc, + OS3A.destinationListOptionsMissing = Just "_last", + OS3A.destinationListOptionsSearchString = Just "alert", + OS3A.destinationListOptionsDestinationType = Just OS3A.DestinationTypeSlack + } + let req = OS3Requests.getDestinationsWith opts + -- Order is not significant; sort to compare deterministically. + sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sortOn + fst + [ ("destinationType", Just "slack"), + ("missing", Just "_last"), + ("searchString", Just "alert"), + ("size", Just "5"), + ("sortString", Just "destination.name.keyword"), + ("sortOrder", Just "desc"), + ("start_index", Just "10") + ] + + it "getDestinationsWith omits fields set to Nothing (not rendered with empty values)" $ do + let opts = + OS3A.defaultDestinationListOptions + { OS3A.destinationListOptionsSize = Just 5 + } + let req = OS3Requests.getDestinationsWith opts + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("size", Just "5")] + + describe "getDestinations endpoint shape (OpenSearch 1 and 2 parity)" $ do + it "OS1 getDestinations GETs /_plugins/_alerting/destinations" $ do + let req = OS1Requests.getDestinations + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations"] + bhRequestBody req `shouldBe` Nothing + + it "OS2 getDestinations GETs /_plugins/_alerting/destinations" $ do + let req = OS2Requests.getDestinations + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations"] + bhRequestBody req `shouldBe` Nothing + + it "OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint OS1Requests.getDestinations) + `shouldBe` getRawEndpoint (bhRequestEndpoint OS2Requests.getDestinations) + getRawEndpoint (bhRequestEndpoint OS2Requests.getDestinations) + `shouldBe` getRawEndpoint (bhRequestEndpoint OS3Requests.getDestinations) + bhRequestMethod OS1Requests.getDestinations + `shouldBe` bhRequestMethod OS3Requests.getDestinations + + describe "DestinationType discriminator" $ do + it "round-trips each documented value through destinationTypeText" $ do + OS3A.destinationTypeText OS3A.DestinationTypeSlack `shouldBe` "slack" + OS3A.destinationTypeText OS3A.DestinationTypeChime `shouldBe` "chime" + OS3A.destinationTypeText OS3A.DestinationTypeCustomWebhook `shouldBe` "custom_webhook" + OS3A.destinationTypeText OS3A.DestinationTypeEmail `shouldBe` "email" + OS3A.destinationTypeText OS3A.DestinationTypeTestAction `shouldBe` "test_action" + + it "decodes each documented wire value" $ do + "slack" `decodesDestinationTypeTo` OS3A.DestinationTypeSlack + "chime" `decodesDestinationTypeTo` OS3A.DestinationTypeChime + "custom_webhook" `decodesDestinationTypeTo` OS3A.DestinationTypeCustomWebhook + "email" `decodesDestinationTypeTo` OS3A.DestinationTypeEmail + "test_action" `decodesDestinationTypeTo` OS3A.DestinationTypeTestAction + + it "falls through to DestinationTypeOther for an unknown value" $ + "future_dest_kind" `decodesDestinationTypeTo` OS3A.DestinationTypeOther "future_dest_kind" + + describe "Destination decoding" $ do + it "decodes the documented Slack fixture" $ do + let fixture = + LBS.pack + "{\"id\":\"1a2a3a4a5a6a7a\",\"type\":\"slack\",\"name\":\"sample-destination\",\"schema_version\":3,\"seq_no\":0,\"primary_term\":6,\"last_update_time\":1603943261722,\"slack\":{\"url\":\"https://example.com\"}}" + let Just d = decode fixture :: Maybe OS3A.Destination + OS3A.destinationId d `shouldBe` "1a2a3a4a5a6a7a" + OS3A.destinationType d `shouldBe` OS3A.DestinationTypeSlack + OS3A.destinationName d `shouldBe` "sample-destination" + OS3A.destinationSchemaVersion d `shouldBe` 3 + OS3A.destinationSeqNo d `shouldBe` 0 + OS3A.destinationPrimaryTerm d `shouldBe` 6 + OS3A.destinationLastUpdateTime d `shouldBe` Just 1603943261722 + OS3A.destinationBody d `shouldBe` object ["url" .= ("https://example.com" :: Text)] + + it "decodes a Chime destination" $ do + let fixture = + LBS.pack + "{\"id\":\"ch1\",\"type\":\"chime\",\"name\":\"chime-dest\",\"schema_version\":3,\"seq_no\":1,\"primary_term\":1,\"chime\":{\"url\":\"https://hooks.chime.aws/incomingwebhooks/x\"}}" + let Just d = decode fixture :: Maybe OS3A.Destination + OS3A.destinationType d `shouldBe` OS3A.DestinationTypeChime + OS3A.destinationBody d `shouldBe` object ["url" .= ("https://hooks.chime.aws/incomingwebhooks/x" :: Text)] + + it "decodes a Custom Webhook destination (full sub-object)" $ do + let fixture = + LBS.pack + "{\"id\":\"cw1\",\"type\":\"custom_webhook\",\"name\":\"cw-dest\",\"schema_version\":3,\"seq_no\":0,\"primary_term\":1,\"custom_webhook\":{\"url\":\"https://example.com/hook\",\"scheme\":\"HTTPS\",\"host\":\"example.com\",\"port\":443,\"path\":\"hook\",\"method\":\"POST\",\"query_params\":{\"token\":\"abc\"},\"header_params\":{\"Content-Type\":\"application/json\"}}}" + let Just d = decode fixture :: Maybe OS3A.Destination + OS3A.destinationType d `shouldBe` OS3A.DestinationTypeCustomWebhook + OS3A.destinationBody d + `shouldSatisfy` \body -> "\"url\"" `isInfixOf` LBS.unpack (encode body) + + it "decodes an Email destination" $ do + let fixture = + LBS.pack + "{\"id\":\"em1\",\"type\":\"email\",\"name\":\"email-dest\",\"schema_version\":3,\"seq_no\":0,\"primary_term\":1,\"email\":{\"email_account_id\":\"YjY7mXMBx015759_IcfW\",\"recipients\":[{\"type\":\"email\",\"email\":\"example@email.com\"}]}}" + let Just d = decode fixture :: Maybe OS3A.Destination + OS3A.destinationType d `shouldBe` OS3A.DestinationTypeEmail + OS3A.destinationBody d + `shouldSatisfy` \body -> "\"email_account_id\"" `isInfixOf` LBS.unpack (encode body) + + it "decodes a test_action destination (no sub-object, body=Null)" $ do + let fixture = + LBS.pack + "{\"id\":\"ta1\",\"type\":\"test_action\",\"name\":\"ta-dest\",\"schema_version\":3,\"seq_no\":0,\"primary_term\":1}" + let Just d = decode fixture :: Maybe OS3A.Destination + OS3A.destinationType d `shouldBe` OS3A.DestinationTypeTestAction + OS3A.destinationBody d `shouldBe` Null + + it "decodes the documented fixture with a user sub-object" $ do + let fixture = + LBS.pack + "{\"id\":\"1a2a3a4a5a6a7a\",\"type\":\"slack\",\"name\":\"sample-destination\",\"user\":{\"name\":\"psantos\",\"backend_roles\":[\"human-resources\"],\"roles\":[\"alerting_full_access\"]},\"schema_version\":3,\"seq_no\":0,\"primary_term\":6,\"last_update_time\":1603943261722,\"slack\":{\"url\":\"https://example.com\"}}" + let Just d = decode fixture :: Maybe OS3A.Destination + OS3A.destinationUser d + `shouldSatisfy` \case + Just _ -> True + _ -> False + + it "tolerates missing schema_version, seq_no, primary_term (default 0)" $ do + let fixture = + LBS.pack + "{\"id\":\"x\",\"type\":\"slack\",\"name\":\"x\",\"slack\":{\"url\":\"https://example.com\"}}" + let Just d = decode fixture :: Maybe OS3A.Destination + OS3A.destinationSchemaVersion d `shouldBe` 0 + OS3A.destinationSeqNo d `shouldBe` 0 + OS3A.destinationPrimaryTerm d `shouldBe` 0 + + it "round-trips through encode/decode on the typed fields" $ do + let encoded = encode os3SampleSlackDestination + Just reDecoded = decode encoded :: Maybe OS3A.Destination + OS3A.destinationId reDecoded `shouldBe` OS3A.destinationId os3SampleSlackDestination + OS3A.destinationType reDecoded `shouldBe` OS3A.destinationType os3SampleSlackDestination + OS3A.destinationName reDecoded `shouldBe` OS3A.destinationName os3SampleSlackDestination + OS3A.destinationBody reDecoded `shouldBe` OS3A.destinationBody os3SampleSlackDestination + + it "re-encodes the per-type sub-object under its discriminator key" $ do + let encoded = encode os3SampleSlackDestination + -- The slack sub-object key must survive the round-trip. + encoded `shouldSatisfy` \bs -> "\"slack\"" `isInfixOf` LBS.unpack bs + + describe "GetDestinationsResponse envelope decoding" $ do + it "decodes the documented envelope" $ do + let fixture = + LBS.pack + "{\"totalDestinations\":1,\"destinations\":[{\"id\":\"1a2a3a4a5a6a7a\",\"type\":\"slack\",\"name\":\"sample-destination\",\"schema_version\":3,\"seq_no\":0,\"primary_term\":6,\"last_update_time\":1603943261722,\"slack\":{\"url\":\"https://example.com\"}}]}" + let Just resp = decode fixture :: Maybe OS3A.GetDestinationsResponse + OS3A.getDestinationsResponseTotalDestinations resp `shouldBe` 1 + length (OS3A.getDestinationsResponseDestinations resp) `shouldBe` 1 + + it "decodes an empty destinations list" $ do + let fixture = LBS.pack "{\"totalDestinations\":0,\"destinations\":[]}" + let Just resp = decode fixture :: Maybe OS3A.GetDestinationsResponse + OS3A.getDestinationsResponseTotalDestinations resp `shouldBe` 0 + OS3A.getDestinationsResponseDestinations resp `shouldBe` [] + + it "tolerates a missing totalDestinations field (defaults to 0)" $ do + let fixture = LBS.pack "{\"destinations\":[]}" + let Just resp = decode fixture :: Maybe OS3A.GetDestinationsResponse + OS3A.getDestinationsResponseTotalDestinations resp `shouldBe` 0 + + describe "destinationListOptionsParams rendering" $ do + it "default options render to an empty parameter list" $ + OS3A.destinationListOptionsParams OS3A.defaultDestinationListOptions `shouldBe` [] + + it "renders all set fields with the documented camelCase wire names" $ do + let opts = + OS3A.defaultDestinationListOptions + { OS3A.destinationListOptionsSize = Just 50, + OS3A.destinationListOptionsStartIndex = Just 0, + OS3A.destinationListOptionsSortString = Just "destination.type.keyword", + OS3A.destinationListOptionsSortOrder = Just OS3A.DestinationSortOrderAsc, + OS3A.destinationListOptionsMissing = Just "_first", + OS3A.destinationListOptionsSearchString = Just "slack", + OS3A.destinationListOptionsDestinationType = Just OS3A.DestinationTypeChime + } + -- Sorted for determinism; the actual emission order is not significant + -- for the alerting plugin's @RestGetDestinationsAction@. + sortOn fst (OS3A.destinationListOptionsParams opts) + `shouldBe` sortOn + fst + [ ("size", Just "50"), + ("start_index", Just "0"), + ("sortString", Just "destination.type.keyword"), + ("sortOrder", Just "asc"), + ("missing", Just "_first"), + ("searchString", Just "slack"), + ("destinationType", Just "chime") + ] + + -- =========================================================== -- + -- updateMonitorWith: optimistic-concurrency query params. -- + -- =========================================================== -- + describe "updateMonitorWith endpoint shape (OpenSearch 3)" $ do + it "emits if_seq_no and if_primary_term query params when Just" $ do + let req = OS3Requests.updateMonitorWith (OS3A.MonitorId "mid") os3SampleMonitor (Just (3, 2)) + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "mid"] + sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [("if_primary_term", Just "2"), ("if_seq_no", Just "3")] + + it "omits query params when Nothing" $ do + let req = OS3Requests.updateMonitorWith (OS3A.MonitorId "mid") os3SampleMonitor Nothing + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "updateMonitor is the Nothing special-case (delegation regression)" $ do + let req = OS3Requests.updateMonitor (OS3A.MonitorId "mid") os3SampleMonitor + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestMethod req `shouldBe` "PUT" + + -- =========================================================== -- + -- searchMonitors / executeMonitor endpoint shape. -- + -- =========================================================== -- + describe "searchMonitors endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_alerting/monitors/_search with {} body when Nothing" $ do + let req = OS3Requests.searchMonitors Nothing + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + let Just body = bhRequestBody req + body `shouldBe` "{}" + + it "forwards the encoded MonitorsSearchQuery body when Just" $ do + let q = OS3A.defaultMonitorsSearchQuery {OS3A.monitorsSearchQuerySize = Just 5} + let req = OS3Requests.searchMonitors (Just q) + bhRequestMethod req `shouldBe` "GET" + let Just body = bhRequestBody req + body `shouldBe` encode q + + describe "executeMonitor endpoint shape (OpenSearch 3)" $ do + it "POSTs to /_plugins/_alerting/monitors/{id}/_execute with no body and no query when Nothing" $ do + let req = OS3Requests.executeMonitor (OS3A.MonitorId "my-monitor-id") Nothing + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "my-monitor-id", "_execute"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "keeps the id as a single opaque path segment" $ do + let req = OS3Requests.executeMonitor (OS3A.MonitorId "my-monitor_42") Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "my-monitor_42", "_execute"] + + it "emits the ?dryrun=true query param and no body when dryrun is Just True" $ do + let r = OS3A.defaultExecuteMonitorRequest {OS3A.executeMonitorRequestDryrun = Just True} + let req = OS3Requests.executeMonitor (OS3A.MonitorId "mid") (Just r) + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("dryrun", Just "true")] + bhRequestBody req `shouldBe` Nothing + + it "omits the dryrun query param when dryrun is Just False" $ do + let r = OS3A.defaultExecuteMonitorRequest {OS3A.executeMonitorRequestDryrun = Just False} + let req = OS3Requests.executeMonitor (OS3A.MonitorId "mid") (Just r) + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + -- =========================================================== -- + -- Destination lifecycle (create/update/delete) endpoint shape. -- + -- =========================================================== -- + describe "destination lifecycle endpoint shape (OpenSearch 3)" $ do + it "createDestination POSTs to /_plugins/_alerting/destinations with the encoded body" $ do + let req = OS3Requests.createDestination os3SampleSlackDestination + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldSatisfy` isJust + + it "createDestination strips the server-assigned keys (id, schema_version, seq_no, primary_term)" $ do + let req = OS3Requests.createDestination os3SampleSlackDestination + Just body = bhRequestBody req + Just (Object o) = decode body :: Maybe Value + KM.lookup "id" o `shouldBe` Nothing + KM.lookup "schema_version" o `shouldBe` Nothing + KM.lookup "seq_no" o `shouldBe` Nothing + KM.lookup "primary_term" o `shouldBe` Nothing + KM.lookup "name" o `shouldNotBe` Nothing + KM.lookup "type" o `shouldNotBe` Nothing + KM.lookup "slack" o `shouldNotBe` Nothing + + it "updateDestination PUTs /_plugins/_alerting/destinations/{id} with the encoded body" $ do + let req = OS3Requests.updateDestination (OS3A.DestinationId "dest-1") os3SampleSlackDestination + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "dest-1"] + bhRequestBody req `shouldSatisfy` isJust + + it "updateDestination keeps the server-assigned keys (only create strips them)" $ do + let req = OS3Requests.updateDestination (OS3A.DestinationId "dest-1") os3SampleSlackDestination + Just body = bhRequestBody req + Just (Object o) = decode body :: Maybe Value + KM.lookup "id" o `shouldNotBe` Nothing + KM.lookup "schema_version" o `shouldNotBe` Nothing + + it "deleteDestination DELETEs /_plugins/_alerting/destinations/{id} with no body" $ do + let req = OS3Requests.deleteDestination (OS3A.DestinationId "dest-1") + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "dest-1"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + -- =========================================================== -- + -- Cross-backend parity for the new endpoints (OS1=OS2=OS3). -- + -- =========================================================== -- + describe "cross-backend parity (new endpoints)" $ do + let mid1 = OS1A.MonitorId "shared-id" + mid2 = OS2A.MonitorId "shared-id" + mid3 = OS3A.MonitorId "shared-id" + did1 = OS1A.DestinationId "shared-dest" + did2 = OS2A.DestinationId "shared-dest" + did3 = OS3A.DestinationId "shared-dest" + + it "searchMonitors: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.searchMonitors Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.searchMonitors Nothing)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.searchMonitors Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.searchMonitors Nothing)) + bhRequestMethod (OS1Requests.searchMonitors Nothing) + `shouldBe` bhRequestMethod (OS3Requests.searchMonitors Nothing) + + it "executeMonitor: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.executeMonitor mid1 Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.executeMonitor mid2 Nothing)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.executeMonitor mid2 Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.executeMonitor mid3 Nothing)) + bhRequestMethod (OS1Requests.executeMonitor mid1 Nothing) + `shouldBe` bhRequestMethod (OS3Requests.executeMonitor mid3 Nothing) + + it "executeMonitor: OS1, OS2, OS3 emit the same ?dryrun=true query param" $ do + let d1 = OS1A.defaultExecuteMonitorRequest {OS1A.executeMonitorRequestDryrun = Just True} + d2 = OS2A.defaultExecuteMonitorRequest {OS2A.executeMonitorRequestDryrun = Just True} + d3 = OS3A.defaultExecuteMonitorRequest {OS3A.executeMonitorRequestDryrun = Just True} + q1 = getRawEndpointQueries (bhRequestEndpoint (OS1Requests.executeMonitor mid1 (Just d1))) + q2 = getRawEndpointQueries (bhRequestEndpoint (OS2Requests.executeMonitor mid2 (Just d2))) + q3 = getRawEndpointQueries (bhRequestEndpoint (OS3Requests.executeMonitor mid3 (Just d3))) + q1 `shouldBe` [("dryrun", Just "true")] + q2 `shouldBe` q1 + q3 `shouldBe` q1 + + it "deleteDestination: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.deleteDestination did1)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteDestination did2)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteDestination did2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteDestination did3)) + bhRequestMethod (OS1Requests.deleteDestination did1) + `shouldBe` bhRequestMethod (OS3Requests.deleteDestination did3) + + it "updateMonitorWith emits the same query params across backends" $ do + sortOn fst (getRawEndpointQueries (bhRequestEndpoint (OS1Requests.updateMonitorWith mid1 os1SampleMonitor (Just (7, 4))))) + `shouldBe` sortOn fst (getRawEndpointQueries (bhRequestEndpoint (OS3Requests.updateMonitorWith mid3 os3SampleMonitor (Just (7, 4))))) + + -- =========================================================== -- + -- Decoder tests for the new response/request types. -- + -- =========================================================== -- + describe "MonitorsSearchQuery rendering" $ do + it "default query renders to {}" $ + encode OS3A.defaultMonitorsSearchQuery `shouldBe` "{}" + + it "renders size and query and round-trips through encode/decode" $ do + let q = + OS3A.defaultMonitorsSearchQuery + { OS3A.monitorsSearchQuerySize = Just 10, + OS3A.monitorsSearchQueryQuery = + Just + ( object + [ "match" + .= object + ["monitor.name" .= object ["query" .= ("my" :: Text)]] + ] + ) + } + -- aeson's KeyMap is hash-ordered, so compare by decoding rather than + -- asserting exact byte order. + decode (encode q) `shouldBe` Just q + + describe "DestinationResponse decoding" $ do + let fixture = + LBS.pack + "{\"_id\":\"d1\",\"_version\":1,\"_seq_no\":0,\"_primary_term\":1,\"destination\":{\"id\":\"d1\",\"type\":\"slack\",\"name\":\"dest\",\"schema_version\":3,\"seq_no\":0,\"primary_term\":1,\"slack\":{\"url\":\"https://example.com\"}}}" + + it "decodes the documented create-response fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.DestinationResponse + OS3A.destinationResponseId decoded `shouldBe` "d1" + OS3A.destinationResponseVersion decoded `shouldBe` 1 + OS3A.destinationResponseSeqNo decoded `shouldBe` 0 + OS3A.destinationResponsePrimaryTerm decoded `shouldBe` 1 + let d = OS3A.destinationResponseDestination decoded + OS3A.destinationType d `shouldBe` OS3A.DestinationTypeSlack + OS3A.destinationName d `shouldBe` "dest" + + it "round-trips through encode/decode on the typed fields" $ do + let original = + OS3A.DestinationResponse + { OS3A.destinationResponseId = "d1", + OS3A.destinationResponseVersion = 1, + OS3A.destinationResponseSeqNo = 0, + OS3A.destinationResponsePrimaryTerm = 1, + OS3A.destinationResponseDestination = os3SampleSlackDestination + } + Just reDecoded = decode (encode original) :: Maybe OS3A.DestinationResponse + OS3A.destinationResponseId reDecoded `shouldBe` "d1" + OS3A.destinationResponseVersion reDecoded `shouldBe` 1 + + describe "DeleteDestinationResponse decoding" $ do + let fixture = + LBS.pack + "{\"_index\":\".opendistro-allocator-config\",\"_id\":\"d1\",\"_version\":2,\"result\":\"deleted\",\"forced_refresh\":false,\"_shards\":{\"total\":2,\"successful\":1,\"skipped\":0,\"failed\":0},\"_seq_no\":1,\"_primary_term\":1}" + + it "decodes the bare delete-document fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.DeleteDestinationResponse + OS3A.deleteDestinationResponseIndex decoded `shouldBe` ".opendistro-allocator-config" + OS3A.deleteDestinationResponseId decoded `shouldBe` "d1" + OS3A.deleteDestinationResponseVersion decoded `shouldBe` 2 + OS3A.deleteDestinationResponseResult decoded `shouldBe` "deleted" + OS3A.deleteDestinationResponseForcedRefresh decoded `shouldBe` False + let sh = OS3A.deleteDestinationResponseShards decoded + OS3A.alertingShardsTotal sh `shouldBe` 2 + OS3A.alertingShardsSuccessful sh `shouldBe` 1 + OS3A.deleteDestinationResponseSeqNo decoded `shouldBe` 1 + OS3A.deleteDestinationResponsePrimaryTerm decoded `shouldBe` 1 + + describe "SearchMonitorsResponse decoding" $ do + let fixture = + LBS.pack + "{\"took\":5,\"timed_out\":false,\"_shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"hits\":{\"total\":{\"value\":1,\"relation\":\"eq\"},\"max_score\":1.0,\"hits\":[{\"_index\":\".opendistro-allocator-config\",\"_id\":\"m1\",\"_version\":1,\"_seq_no\":0,\"_primary_term\":1,\"_score\":1.0,\"_source\":{\"name\":\"my-monitor\",\"type\":\"monitor\",\"monitor_type\":\"query_level_monitor\",\"schedule\":{\"period\":{\"interval\":1,\"unit\":\"MINUTES\"}}}}]}}" + + it "decodes the search envelope" $ do + let Just resp = decode fixture :: Maybe OS3A.SearchMonitorsResponse + OS3A.searchMonitorsResponseTook resp `shouldBe` 5 + OS3A.searchMonitorsResponseTimedOut resp `shouldBe` False + OS3A.monitorsTotalValue (OS3A.searchMonitorsResponseTotal resp) `shouldBe` 1 + OS3A.monitorsTotalRelation (OS3A.searchMonitorsResponseTotal resp) + `shouldBe` OS3A.MonitorsTotalRelationEq + OS3A.searchMonitorsResponseMaxScore resp `shouldBe` Just 1.0 + length (OS3A.searchMonitorsResponseHits resp) `shouldBe` 1 + + it "searchMonitorsResponseMonitors projects out the bare Monitor list" $ do + let Just resp = decode fixture :: Maybe OS3A.SearchMonitorsResponse + case OS3A.searchMonitorsResponseMonitors resp of + (m : _) -> OS3A.monitorName m `shouldBe` "my-monitor" + [] -> expectationFailure "expected at least one monitor hit" + + it "tolerates a missing max_score (defaults to Nothing)" $ do + let fixture' = + LBS.pack + "{\"took\":1,\"timed_out\":false,\"_shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"hits\":{\"total\":{\"value\":0,\"relation\":\"eq\"},\"hits\":[]}}" + let Just resp = decode fixture' :: Maybe OS3A.SearchMonitorsResponse + OS3A.searchMonitorsResponseMaxScore resp `shouldBe` Nothing + OS3A.searchMonitorsResponseHits resp `shouldBe` [] + + describe "ExecuteMonitorResponse decoding" $ do + let fixture = + LBS.pack + "{\"monitor_name\":\"my-monitor\",\"period_start\":1551466220455,\"period_end\":1551466280455,\"dry_run\":false,\"trigger_results\":{\"foo\":{\"action_id\":\"a1\"}},\"input_results\":{\"results\":[]},\"script_actions\":{}}" + + it "decodes the typed shell and keeps the variable sub-objects opaque" $ do + let Just decoded = decode fixture :: Maybe OS3A.ExecuteMonitorResponse + OS3A.executeMonitorResponseMonitorName decoded `shouldBe` Just "my-monitor" + OS3A.executeMonitorResponsePeriodStart decoded `shouldBe` Just 1551466220455 + OS3A.executeMonitorResponsePeriodEnd decoded `shouldBe` Just 1551466280455 + OS3A.executeMonitorResponseDryRun decoded `shouldBe` Just False + OS3A.executeMonitorResponseTriggerResults decoded `shouldSatisfy` isJust + OS3A.executeMonitorResponseInputResults decoded `shouldSatisfy` isJust + + it "round-trips the typed fields through encode/decode" $ do + let original = + OS3A.ExecuteMonitorResponse + { OS3A.executeMonitorResponseMonitorName = Just "my-monitor", + OS3A.executeMonitorResponsePeriodStart = Just 1, + OS3A.executeMonitorResponsePeriodEnd = Just 2, + OS3A.executeMonitorResponseDryRun = Just True, + OS3A.executeMonitorResponseTriggerResults = Nothing, + OS3A.executeMonitorResponseInputResults = Nothing, + OS3A.executeMonitorResponseScriptActions = Nothing, + OS3A.executeMonitorResponseOther = Null + } + encoded = encode original + Just reDecoded = decode encoded :: Maybe OS3A.ExecuteMonitorResponse + OS3A.executeMonitorResponseMonitorName reDecoded `shouldBe` Just "my-monitor" + OS3A.executeMonitorResponseDryRun reDecoded `shouldBe` Just True + OS3A.executeMonitorResponsePeriodStart reDecoded `shouldBe` Just 1 + + describe "MonitorsTotalRelation discriminator" $ do + it "round-trips each documented value through monitorsTotalRelationText" $ do + OS3A.monitorsTotalRelationText OS3A.MonitorsTotalRelationEq `shouldBe` "eq" + OS3A.monitorsTotalRelationText OS3A.MonitorsTotalRelationGe `shouldBe` "ge" + + it "falls through to MonitorsTotalRelationOther for an unknown value" $ + decode "\"future\"" `shouldBe` Just (OS3A.MonitorsTotalRelationOther "future") + + -- =========================================================== -- + -- Get alerts endpoint shape + decoders. -- + -- =========================================================== -- + describe "getAlerts endpoint shape (OpenSearch 3)" $ do + it "getAlerts GETs /_plugins/_alerting/monitors/alerts with no body" $ do + let req = OS3Requests.getAlerts + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "alerts"] + bhRequestBody req `shouldBe` Nothing + + it "getAlertsWith with default options emits no query params" $ do + let req = OS3Requests.getAlertsWith OS3A.defaultGetAlertsOptions + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "getAlertsWith forwards options as camelCase query params (startIndex is camelCase, unlike destinations)" $ do + let opts = + OS3A.defaultGetAlertsOptions + { OS3A.getAlertsOptionsSize = Just 5, + OS3A.getAlertsOptionsStartIndex = Just 10, + OS3A.getAlertsOptionsSortString = Just "monitor_name.keyword", + OS3A.getAlertsOptionsSortOrder = Just OS3A.AlertSortOrderDesc, + OS3A.getAlertsOptionsMissing = Just "_last", + OS3A.getAlertsOptionsSearchString = Just "alert", + OS3A.getAlertsOptionsSeverityLevel = Just "1", + OS3A.getAlertsOptionsAlertState = Just OS3A.AlertStateActive, + OS3A.getAlertsOptionsMonitorId = Just "mon-1", + OS3A.getAlertsOptionsWorkflowIds = Just "wf-1,wf-2" + } + let req = OS3Requests.getAlertsWith opts + sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sortOn + fst + [ ("alertState", Just "ACTIVE"), + ("missing", Just "_last"), + ("monitorId", Just "mon-1"), + ("searchString", Just "alert"), + ("severityLevel", Just "1"), + ("size", Just "5"), + ("sortOrder", Just "desc"), + ("sortString", Just "monitor_name.keyword"), + ("startIndex", Just "10"), + ("workflowIds", Just "wf-1,wf-2") + ] + + it "getAlertsWith omits fields set to Nothing" $ do + let opts = OS3A.defaultGetAlertsOptions {OS3A.getAlertsOptionsSize = Just 5} + let req = OS3Requests.getAlertsWith opts + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("size", Just "5")] + + describe "AlertState discriminator" $ do + it "round-trips each documented value through alertStateText" $ do + OS3A.alertStateText OS3A.AlertStateActive `shouldBe` "ACTIVE" + OS3A.alertStateText OS3A.AlertStateCompleted `shouldBe` "COMPLETED" + OS3A.alertStateText OS3A.AlertStateError `shouldBe` "ERROR" + OS3A.alertStateText OS3A.AlertStateAcknowledged `shouldBe` "ACKNOWLEDGED" + + it "decodes each documented wire value" $ do + decode "\"ACTIVE\"" `shouldBe` Just OS3A.AlertStateActive + decode "\"COMPLETED\"" `shouldBe` Just OS3A.AlertStateCompleted + decode "\"ERROR\"" `shouldBe` Just OS3A.AlertStateError + decode "\"ACKNOWLEDGED\"" `shouldBe` Just OS3A.AlertStateAcknowledged + + it "falls through to AlertStateOther for an unknown value" $ + decode "\"DUMMY\"" `shouldBe` Just (OS3A.AlertStateOther "DUMMY") + + describe "Alert decoding" $ do + let fixture = + LBS.pack + "{\"id\":\"eQURa3gBKo1jAh6qUo49\",\"version\":300,\"monitor_id\":\"awUMa3gBKo1jAh6qu47E\",\"schema_version\":2,\"monitor_version\":2,\"monitor_name\":\"Example_monitor_name\",\"trigger_id\":\"bQUQa3gBKo1jAh6qnY6G\",\"trigger_name\":\"Example_trigger_name\",\"state\":\"ACTIVE\",\"error_message\":null,\"severity\":\"1\",\"action_execution_results\":[],\"start_time\":1616704000492,\"last_notification_time\":1617317979908,\"end_time\":null,\"acknowledged_time\":null}" + + it "decodes the documented alert fixture" $ do + let Just a = decode fixture :: Maybe OS3A.Alert + OS3A.alertId a `shouldBe` "eQURa3gBKo1jAh6qUo49" + OS3A.alertVersion a `shouldBe` 300 + OS3A.alertMonitorId a `shouldBe` "awUMa3gBKo1jAh6qu47E" + OS3A.alertSchemaVersion a `shouldBe` Just 2 + OS3A.alertMonitorVersion a `shouldBe` Just 2 + OS3A.alertMonitorName a `shouldBe` "Example_monitor_name" + OS3A.alertTriggerId a `shouldBe` "bQUQa3gBKo1jAh6qnY6G" + OS3A.alertTriggerName a `shouldBe` "Example_trigger_name" + OS3A.alertState a `shouldBe` OS3A.AlertStateActive + OS3A.alertSeverity a `shouldBe` "1" + OS3A.alertErrorMessage a `shouldBe` Nothing + OS3A.alertStartTime a `shouldBe` Just 1616704000492 + OS3A.alertLastNotificationTime a `shouldBe` Just 1617317979908 + OS3A.alertEndTime a `shouldBe` Nothing + OS3A.alertAcknowledgedTime a `shouldBe` Nothing + + it "keeps the variable sub-objects captured (action_execution_results round-trips)" $ do + let Just a = decode fixture :: Maybe OS3A.Alert + encode a `shouldSatisfy` \bs -> "action_execution_results" `isInfixOf` LBS.unpack bs + + describe "GetAlertsResponse envelope decoding" $ do + let fixture = + LBS.pack + "{\"alerts\":[{\"id\":\"a1\",\"version\":1,\"monitor_id\":\"m1\",\"monitor_name\":\"mn\",\"trigger_id\":\"t1\",\"trigger_name\":\"tn\",\"state\":\"ACTIVE\",\"severity\":\"1\"}],\"totalAlerts\":1}" + + it "decodes the documented envelope" $ do + let Just resp = decode fixture :: Maybe OS3A.GetAlertsResponse + OS3A.getAlertsResponseTotalAlerts resp `shouldBe` 1 + length (OS3A.getAlertsResponseAlerts resp) `shouldBe` 1 + + it "decodes an empty alerts list" $ do + let Just resp = decode "{\"alerts\":[],\"totalAlerts\":0}" :: Maybe OS3A.GetAlertsResponse + OS3A.getAlertsResponseTotalAlerts resp `shouldBe` 0 + OS3A.getAlertsResponseAlerts resp `shouldBe` [] + + it "tolerates a missing totalAlerts field (defaults to 0)" $ do + let Just resp = decode "{\"alerts\":[]}" :: Maybe OS3A.GetAlertsResponse + OS3A.getAlertsResponseTotalAlerts resp `shouldBe` 0 + + -- =========================================================== -- + -- Acknowledge alert endpoint shape + decoders. -- + -- =========================================================== -- + describe "acknowledgeAlert endpoint shape (OpenSearch 3)" $ + it "POSTs to /_plugins/_alerting/monitors/{id}/_acknowledge/alerts with the alerts body" $ do + let req = OS3Requests.acknowledgeAlert (OS3A.MonitorId "my-monitor-id") ["a1", "a2"] + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "monitors", "my-monitor-id", "_acknowledge", "alerts"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + let Just body = bhRequestBody req + body `shouldBe` "{\"alerts\":[\"a1\",\"a2\"]}" + + describe "AcknowledgeAlertRequest / AcknowledgeAlertResponse" $ do + it "default request renders to {\"alerts\":[]}" $ + encode OS3A.defaultAcknowledgeAlertRequest `shouldBe` "{\"alerts\":[]}" + + it "decodes the documented acknowledge response (success + failed)" $ do + let Just resp = decode "{\"success\":[\"a1\"],\"failed\":[\"a2\"]}" :: Maybe OS3A.AcknowledgeAlertResponse + OS3A.acknowledgeAlertResponseSuccess resp `shouldBe` ["a1"] + OS3A.acknowledgeAlertResponseFailed resp `shouldBe` ["a2"] + + it "tolerates a missing failed array (defaults to [])" $ do + let Just resp = decode "{\"success\":[\"a1\"]}" :: Maybe OS3A.AcknowledgeAlertResponse + OS3A.acknowledgeAlertResponseFailed resp `shouldBe` [] + + -- =========================================================== -- + -- Monitor stats endpoint shape + decoders. -- + -- =========================================================== -- + describe "getMonitorStats endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_alerting/stats with no args" $ do + let req = OS3Requests.getMonitorStats Nothing Nothing + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "stats"] + + it "GETs /_plugins/_alerting/stats/{metric} with a metric only" $ do + let req = OS3Requests.getMonitorStats Nothing (Just "job_scheduled_metrics") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "stats", "job_scheduled_metrics"] + + it "GETs /_plugins/_alerting/{node-id}/stats with a node only" $ do + let req = OS3Requests.getMonitorStats (Just "node-1") Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "node-1", "stats"] + + it "GETs /_plugins/_alerting/{node-id}/stats/{metric} with both" $ do + let req = OS3Requests.getMonitorStats (Just "node-1") (Just "job_scheduled_metrics") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "node-1", "stats", "job_scheduled_metrics"] + + describe "MonitorStats decoding" $ do + let fixture = + LBS.pack + "{\"_nodes\":{\"total\":9,\"successful\":9,\"failed\":0},\"cluster_name\":\"alerting\",\"plugins.scheduled_jobs.enabled\":true,\"scheduled_job_index_exists\":true,\"scheduled_job_index_status\":\"green\",\"nodes_on_schedule\":9,\"nodes_not_on_schedule\":0,\"nodes\":{\"id1\":{\"name\":\"n\"}}}" + + it "decodes the typed shell and keeps nodes opaque" $ do + let Just s = decode fixture :: Maybe OS3A.MonitorStats + let Just nodes = OS3A.monitorStatsNodes s + OS3A.monitorStatsNodesCountTotal nodes `shouldBe` 9 + OS3A.monitorStatsNodesCountSuccessful nodes `shouldBe` 9 + OS3A.monitorStatsNodesCountFailed nodes `shouldBe` 0 + OS3A.monitorStatsClusterName s `shouldBe` Just "alerting" + OS3A.monitorStatsScheduledJobsEnabled s `shouldBe` Just True + OS3A.monitorStatsScheduledJobIndexExists s `shouldBe` Just True + OS3A.monitorStatsScheduledJobIndexStatus s `shouldBe` Just "green" + OS3A.monitorStatsNodesOnSchedule s `shouldBe` Just 9 + OS3A.monitorStatsNodesNotOnSchedule s `shouldBe` Just 0 + encode s `shouldSatisfy` \bs -> "\"nodes\"" `isInfixOf` LBS.unpack bs + + it "tolerates a stats body with only the nodes map" $ do + let Just s = decode "{\"nodes\":{}}" :: Maybe OS3A.MonitorStats + OS3A.monitorStatsNodes s `shouldBe` Nothing + OS3A.monitorStatsClusterName s `shouldBe` Nothing + + -- =========================================================== -- + -- Email account lifecycle endpoint shape + decoders. -- + -- =========================================================== -- + describe "email account lifecycle endpoint shape (OpenSearch 3)" $ do + it "createEmailAccount POSTs to .../email_accounts with the encoded body" $ do + let req = OS3Requests.createEmailAccount os3SampleEmailAccount + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "email_accounts"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldSatisfy` isJust + + it "getEmailAccount GETs .../email_accounts/{id}" $ do + let req = OS3Requests.getEmailAccount (OS3A.EmailAccountId "ea-1") + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "email_accounts", "ea-1"] + bhRequestBody req `shouldBe` Nothing + + it "updateEmailAccount PUTs .../email_accounts/{id}" $ do + let req = OS3Requests.updateEmailAccount (OS3A.EmailAccountId "ea-1") os3SampleEmailAccount + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "email_accounts", "ea-1"] + + it "updateEmailAccountWith emits if_seq_no and if_primary_term when Just" $ do + let req = OS3Requests.updateEmailAccountWith (OS3A.EmailAccountId "ea-1") os3SampleEmailAccount (Just (3, 2)) + sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [("if_primary_term", Just "2"), ("if_seq_no", Just "3")] + + it "updateEmailAccountWith omits query params when Nothing" $ do + let req = OS3Requests.updateEmailAccountWith (OS3A.EmailAccountId "ea-1") os3SampleEmailAccount Nothing + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "deleteEmailAccount DELETEs .../email_accounts/{id} with no body" $ do + let req = OS3Requests.deleteEmailAccount (OS3A.EmailAccountId "ea-1") + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "email_accounts", "ea-1"] + bhRequestBody req `shouldBe` Nothing + + describe "EmailAccount decoding" $ do + it "decodes the documented email account fixture" $ do + let fixture = + LBS.pack + "{\"name\":\"example_account\",\"email\":\"example@email.com\",\"host\":\"smtp.email.com\",\"port\":465,\"method\":\"ssl\",\"schema_version\":2}" + let Just a = decode fixture :: Maybe OS3A.EmailAccount + OS3A.emailAccountName a `shouldBe` "example_account" + OS3A.emailAccountEmail a `shouldBe` "example@email.com" + OS3A.emailAccountHost a `shouldBe` "smtp.email.com" + OS3A.emailAccountPort a `shouldBe` 465 + OS3A.emailAccountMethod a `shouldBe` "ssl" + OS3A.emailAccountSchemaVersion a `shouldBe` Just 2 + + it "round-trips through encode/decode on the typed fields" $ do + let encoded = encode os3SampleEmailAccount + Just reDecoded = decode encoded :: Maybe OS3A.EmailAccount + OS3A.emailAccountName reDecoded `shouldBe` OS3A.emailAccountName os3SampleEmailAccount + OS3A.emailAccountPort reDecoded `shouldBe` OS3A.emailAccountPort os3SampleEmailAccount + OS3A.emailAccountMethod reDecoded `shouldBe` OS3A.emailAccountMethod os3SampleEmailAccount + + describe "EmailAccountResponse decoding" $ + it "decodes the documented create-response fixture" $ do + let fixture = + LBS.pack + "{\"_id\":\"ea-id\",\"_version\":1,\"_seq_no\":7,\"_primary_term\":2,\"email_account\":{\"schema_version\":2,\"name\":\"example_account\",\"email\":\"example@email.com\",\"host\":\"smtp.email.com\",\"port\":465,\"method\":\"ssl\"}}" + let Just r = decode fixture :: Maybe OS3A.EmailAccountResponse + OS3A.emailAccountResponseId r `shouldBe` "ea-id" + OS3A.emailAccountResponseVersion r `shouldBe` 1 + OS3A.emailAccountResponseSeqNo r `shouldBe` 7 + OS3A.emailAccountResponsePrimaryTerm r `shouldBe` 2 + let ea = OS3A.emailAccountResponseEmailAccount r + OS3A.emailAccountName ea `shouldBe` "example_account" + OS3A.emailAccountMethod ea `shouldBe` "ssl" + + describe "DeleteEmailAccountResponse decoding" $ + it "decodes the bare delete-document fixture" $ do + let fixture = + LBS.pack + "{\"_index\":\".opendistro-alerting-config\",\"_id\":\"ea-id\",\"_version\":1,\"result\":\"deleted\",\"forced_refresh\":true,\"_shards\":{\"total\":2,\"successful\":2,\"failed\":0},\"_seq_no\":12,\"_primary_term\":2}" + let Just r = decode fixture :: Maybe OS3A.DeleteEmailAccountResponse + OS3A.deleteEmailAccountResponseIndex r `shouldBe` ".opendistro-alerting-config" + OS3A.deleteEmailAccountResponseId r `shouldBe` "ea-id" + OS3A.deleteEmailAccountResponseResult r `shouldBe` "deleted" + OS3A.deleteEmailAccountResponseForcedRefresh r `shouldBe` True + OS3A.deleteEmailAccountResponseSeqNo r `shouldBe` 12 + + -- =========================================================== -- + -- Email group lifecycle endpoint shape + decoders. -- + -- =========================================================== -- + describe "email group lifecycle endpoint shape (OpenSearch 3)" $ do + it "createEmailGroup POSTs to .../email_groups with the encoded body" $ do + let req = OS3Requests.createEmailGroup os3SampleEmailGroup + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "email_groups"] + bhRequestBody req `shouldSatisfy` isJust + + it "getEmailGroup GETs .../email_groups/{id}" $ do + let req = OS3Requests.getEmailGroup (OS3A.EmailGroupId "eg-1") + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "email_groups", "eg-1"] + + it "updateEmailGroup PUTs .../email_groups/{id}" $ do + let req = OS3Requests.updateEmailGroup (OS3A.EmailGroupId "eg-1") os3SampleEmailGroup + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "email_groups", "eg-1"] + + it "updateEmailGroupWith emits if_seq_no and if_primary_term when Just" $ do + let req = OS3Requests.updateEmailGroupWith (OS3A.EmailGroupId "eg-1") os3SampleEmailGroup (Just (5, 3)) + sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [("if_primary_term", Just "3"), ("if_seq_no", Just "5")] + + it "updateEmailGroupWith omits query params when Nothing" $ do + let req = OS3Requests.updateEmailGroupWith (OS3A.EmailGroupId "eg-1") os3SampleEmailGroup Nothing + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "deleteEmailGroup DELETEs .../email_groups/{id} with no body" $ do + let req = OS3Requests.deleteEmailGroup (OS3A.EmailGroupId "eg-1") + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "email_groups", "eg-1"] + bhRequestBody req `shouldBe` Nothing + + describe "EmailGroup decoding" $ do + it "decodes the documented email group fixture" $ do + let fixture = + LBS.pack + "{\"name\":\"example_email_group\",\"emails\":[{\"email\":\"example@email.com\"}],\"schema_version\":2}" + let Just g = decode fixture :: Maybe OS3A.EmailGroup + OS3A.emailGroupName g `shouldBe` "example_email_group" + OS3A.emailGroupSchemaVersion g `shouldBe` Just 2 + case OS3A.emailGroupEmails g of + (r : _) -> OS3A.emailGroupRecipientEmail r `shouldBe` "example@email.com" + [] -> expectationFailure "expected at least one recipient" + + it "tolerates a missing emails array (defaults to [])" $ do + let Just g = decode "{\"name\":\"empty_group\"}" :: Maybe OS3A.EmailGroup + OS3A.emailGroupName g `shouldBe` "empty_group" + OS3A.emailGroupEmails g `shouldBe` [] + + it "round-trips through encode/decode on the typed fields" $ do + let encoded = encode os3SampleEmailGroup + Just reDecoded = decode encoded :: Maybe OS3A.EmailGroup + OS3A.emailGroupName reDecoded `shouldBe` OS3A.emailGroupName os3SampleEmailGroup + length (OS3A.emailGroupEmails reDecoded) + `shouldBe` length (OS3A.emailGroupEmails os3SampleEmailGroup) + + describe "EmailGroupResponse decoding" $ + it "decodes the documented create-response fixture" $ do + let fixture = + LBS.pack + "{\"_id\":\"eg-id\",\"_version\":1,\"_seq_no\":9,\"_primary_term\":2,\"email_group\":{\"schema_version\":2,\"name\":\"example_email_group\",\"emails\":[{\"email\":\"example@email.com\"}]}}" + let Just r = decode fixture :: Maybe OS3A.EmailGroupResponse + OS3A.emailGroupResponseId r `shouldBe` "eg-id" + OS3A.emailGroupResponseVersion r `shouldBe` 1 + OS3A.emailGroupResponseSeqNo r `shouldBe` 9 + let eg = OS3A.emailGroupResponseEmailGroup r + OS3A.emailGroupName eg `shouldBe` "example_email_group" + length (OS3A.emailGroupEmails eg) `shouldBe` 1 + + describe "DeleteEmailGroupResponse decoding" $ + it "decodes the bare delete-document fixture" $ do + let fixture = + LBS.pack + "{\"_index\":\".opendistro-alerting-config\",\"_id\":\"eg-id\",\"_version\":1,\"result\":\"deleted\",\"forced_refresh\":true,\"_shards\":{\"total\":2,\"successful\":2,\"failed\":0},\"_seq_no\":11,\"_primary_term\":2}" + let Just r = decode fixture :: Maybe OS3A.DeleteEmailGroupResponse + OS3A.deleteEmailGroupResponseId r `shouldBe` "eg-id" + OS3A.deleteEmailGroupResponseResult r `shouldBe` "deleted" + OS3A.deleteEmailGroupResponseForcedRefresh r `shouldBe` True + + -- =========================================================== -- + -- Cross-backend parity for the new endpoints (OS1=OS2=OS3). -- + -- =========================================================== -- + describe "cross-backend parity (alerts/acknowledge/stats/email endpoints)" $ do + let mid1 = OS1A.MonitorId "shared-id" + mid2 = OS2A.MonitorId "shared-id" + mid3 = OS3A.MonitorId "shared-id" + ea1 = OS1A.EmailAccountId "shared-ea" + ea2 = OS2A.EmailAccountId "shared-ea" + ea3 = OS3A.EmailAccountId "shared-ea" + eg1 = OS1A.EmailGroupId "shared-eg" + eg2 = OS2A.EmailGroupId "shared-eg" + eg3 = OS3A.EmailGroupId "shared-eg" + + it "getAlerts: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint OS1Requests.getAlerts) + `shouldBe` getRawEndpoint (bhRequestEndpoint OS2Requests.getAlerts) + getRawEndpoint (bhRequestEndpoint OS2Requests.getAlerts) + `shouldBe` getRawEndpoint (bhRequestEndpoint OS3Requests.getAlerts) + bhRequestMethod OS1Requests.getAlerts + `shouldBe` bhRequestMethod OS3Requests.getAlerts + + it "acknowledgeAlert: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.acknowledgeAlert mid1 ["a"])) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.acknowledgeAlert mid2 ["a"])) + getRawEndpoint (bhRequestEndpoint (OS2Requests.acknowledgeAlert mid2 ["a"])) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.acknowledgeAlert mid3 ["a"])) + bhRequestMethod (OS1Requests.acknowledgeAlert mid1 ["a"]) + `shouldBe` bhRequestMethod (OS3Requests.acknowledgeAlert mid3 ["a"]) + + it "getMonitorStats: OS1, OS2, OS3 produce the same path" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.getMonitorStats Nothing Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.getMonitorStats Nothing Nothing)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.getMonitorStats Nothing Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.getMonitorStats Nothing Nothing)) + + it "getMonitorStats: OS1, OS2, OS3 produce the same path with node + metric" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.getMonitorStats (Just "n") (Just "m"))) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.getMonitorStats (Just "n") (Just "m"))) + getRawEndpoint (bhRequestEndpoint (OS2Requests.getMonitorStats (Just "n") (Just "m"))) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.getMonitorStats (Just "n") (Just "m"))) + + it "deleteEmailAccount: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.deleteEmailAccount ea1)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteEmailAccount ea2)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteEmailAccount ea2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteEmailAccount ea3)) + bhRequestMethod (OS1Requests.deleteEmailAccount ea1) + `shouldBe` bhRequestMethod (OS3Requests.deleteEmailAccount ea3) + + it "deleteEmailGroup: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.deleteEmailGroup eg1)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteEmailGroup eg2)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteEmailGroup eg2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteEmailGroup eg3)) + bhRequestMethod (OS1Requests.deleteEmailGroup eg1) + `shouldBe` bhRequestMethod (OS3Requests.deleteEmailGroup eg3) + + it "getAlertsWith emits identical query params across backends" $ do + let o1 = + OS1A.defaultGetAlertsOptions + { OS1A.getAlertsOptionsSize = Just 5, + OS1A.getAlertsOptionsAlertState = Just OS1A.AlertStateActive + } + o3 = + OS3A.defaultGetAlertsOptions + { OS3A.getAlertsOptionsSize = Just 5, + OS3A.getAlertsOptionsAlertState = Just OS3A.AlertStateActive + } + sortOn fst (getRawEndpointQueries (bhRequestEndpoint (OS1Requests.getAlertsWith o1))) + `shouldBe` sortOn fst (getRawEndpointQueries (bhRequestEndpoint (OS3Requests.getAlertsWith o3))) + + -- =========================================================== -- + -- New endpoint shape: getDestination, search endpoints, -- + -- comments CRUD (bloodhound-ee2). -- + -- =========================================================== -- + describe "getDestination endpoint shape (OpenSearch 3)" $ do + it "getDestination GETs /_plugins/_alerting/destinations/{id} with no body" $ do + let req = OS3Requests.getDestination (OS3A.DestinationId "my-dest") + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "my-dest"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "getDestination keeps the id as a single opaque path segment" $ do + let req = OS3Requests.getDestination (OS3A.DestinationId "dest_42") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "dest_42"] + + describe "searchEmailAccounts endpoint shape (OpenSearch 3)" $ do + it "searchEmailAccounts POSTs to .../email_accounts/_search with a body" $ do + let req = OS3Requests.searchEmailAccounts Nothing + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "email_accounts", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldSatisfy` isJust + + it "searchEmailAccounts with Nothing emits an empty-body {} JSON" $ do + let req = OS3Requests.searchEmailAccounts Nothing + let body = fromJust (bhRequestBody req) + decode body `shouldBe` Just (Object mempty) + + it "searchEmailAccounts with Just encodes the query DSL" $ do + let q = + OS3A.EmailAccountSearchQuery + { OS3A.emailAccountSearchQueryFrom = Just 0, + OS3A.emailAccountSearchQuerySize = Just 10, + OS3A.emailAccountSearchQuerySort = Nothing, + OS3A.emailAccountSearchQueryQuery = Nothing + } + let req = OS3Requests.searchEmailAccounts (Just q) + let body = fromJust (bhRequestBody req) + decode body `shouldBe` Just (object ["from" .= (0 :: Int), "size" .= (10 :: Int)]) + + describe "searchEmailGroups endpoint shape (OpenSearch 3)" $ do + it "searchEmailGroups POSTs to .../email_groups/_search with a body" $ do + let req = OS3Requests.searchEmailGroups Nothing + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "destinations", "email_groups", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldSatisfy` isJust + + describe "searchFindings endpoint shape (OpenSearch 3)" $ do + it "searchFindings GETs /_plugins/_alerting/findings/_search with no body" $ do + let req = OS3Requests.searchFindings Nothing + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "findings", "_search"] + bhRequestBody req `shouldBe` Nothing + + it "searchFindings with default options emits no query params" $ do + let req = OS3Requests.searchFindings Nothing + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "searchFindings with options forwards them as query params" $ do + let opts = + OS3A.defaultFindingsSearchOptions + { OS3A.findingsSearchOptionsFindingId = Just "finding-1", + OS3A.findingsSearchOptionsSize = Just 20 + } + let req = OS3Requests.searchFindings (Just opts) + getRawEndpointQueries (bhRequestEndpoint req) + `shouldSatisfy` any (\(k, v) -> k == "findingId" && v == Just "finding-1") + getRawEndpointQueries (bhRequestEndpoint req) + `shouldSatisfy` any (\(k, v) -> k == "size" && v == Just "20") + + describe "createComment endpoint shape (OpenSearch 3)" $ do + it "createComment POSTs to /_plugins/_alerting/comments/{alertId} with a body" $ do + let req = OS3Requests.createComment "alert-1" (OS3A.CreateCommentRequest "hello") + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "comments", "alert-1"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + let body = fromJust (bhRequestBody req) + decode body `shouldBe` Just (object ["content" .= ("hello" :: Text)]) + + describe "updateComment endpoint shape (OpenSearch 3)" $ do + it "updateComment PUTs to /_plugins/_alerting/comments/{commentId} with a body" $ do + let req = OS3Requests.updateComment (OS3A.CommentId "c-1") (OS3A.UpdateCommentRequest "updated") + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "comments", "c-1"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + let body = fromJust (bhRequestBody req) + decode body `shouldBe` Just (object ["content" .= ("updated" :: Text)]) + + describe "searchComments endpoint shape (OpenSearch 3)" $ do + it "searchComments GETs /_plugins/_alerting/comments/_search with a body" $ do + let req = OS3Requests.searchComments Nothing + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "comments", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldSatisfy` isJust + + it "searchComments with Nothing emits an empty-body {} JSON" $ do + let req = OS3Requests.searchComments Nothing + let body = fromJust (bhRequestBody req) + decode body `shouldBe` Just (Object mempty) + + describe "deleteComment endpoint shape (OpenSearch 3)" $ do + it "deleteComment DELETEs /_plugins/_alerting/comments/{commentId} with no body" $ do + let req = OS3Requests.deleteComment (OS3A.CommentId "c-1") + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_alerting", "comments", "c-1"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + -- =========================================================== -- + -- Cross-backend parity for the new endpoints (ee2). -- + -- =========================================================== -- + describe "cross-backend parity (new endpoints)" $ do + let did1 = OS1A.DestinationId "shared-dest" + did2 = OS2A.DestinationId "shared-dest" + did3 = OS3A.DestinationId "shared-dest" + cid2 = OS2A.CommentId "shared-comment" + cid3 = OS3A.CommentId "shared-comment" + + it "getDestination: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.getDestination did1)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.getDestination did2)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.getDestination did2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.getDestination did3)) + bhRequestMethod (OS1Requests.getDestination did1) + `shouldBe` bhRequestMethod (OS3Requests.getDestination did3) + + it "searchEmailAccounts: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.searchEmailAccounts Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.searchEmailAccounts Nothing)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.searchEmailAccounts Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.searchEmailAccounts Nothing)) + bhRequestMethod (OS1Requests.searchEmailAccounts Nothing) + `shouldBe` bhRequestMethod (OS3Requests.searchEmailAccounts Nothing) + + it "searchEmailGroups: OS1, OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.searchEmailGroups Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.searchEmailGroups Nothing)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.searchEmailGroups Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.searchEmailGroups Nothing)) + bhRequestMethod (OS1Requests.searchEmailGroups Nothing) + `shouldBe` bhRequestMethod (OS3Requests.searchEmailGroups Nothing) + + it "searchFindings: OS2 and OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.searchFindings Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.searchFindings Nothing)) + bhRequestMethod (OS2Requests.searchFindings Nothing) + `shouldBe` bhRequestMethod (OS3Requests.searchFindings Nothing) + + it "createComment: OS2 and OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.createComment "x" (OS2A.CreateCommentRequest "c"))) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.createComment "x" (OS3A.CreateCommentRequest "c"))) + bhRequestMethod (OS2Requests.createComment "x" (OS2A.CreateCommentRequest "c")) + `shouldBe` bhRequestMethod (OS3Requests.createComment "x" (OS3A.CreateCommentRequest "c")) + + it "updateComment: OS2 and OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.updateComment cid2 (OS2A.UpdateCommentRequest "c"))) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.updateComment cid3 (OS3A.UpdateCommentRequest "c"))) + bhRequestMethod (OS2Requests.updateComment cid2 (OS2A.UpdateCommentRequest "c")) + `shouldBe` bhRequestMethod (OS3Requests.updateComment cid3 (OS3A.UpdateCommentRequest "c")) + + it "searchComments: OS2 and OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.searchComments Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.searchComments Nothing)) + bhRequestMethod (OS2Requests.searchComments Nothing) + `shouldBe` bhRequestMethod (OS3Requests.searchComments Nothing) + + it "deleteComment: OS2 and OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteComment cid2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteComment cid3)) + bhRequestMethod (OS2Requests.deleteComment cid2) + `shouldBe` bhRequestMethod (OS3Requests.deleteComment cid3) + + -- =========================================================== -- + -- Decoder tests for the new types (ee2). -- + -- =========================================================== -- + describe "SearchEmailAccountsResponse decoding" $ do + it "decodes a documented search response fixture" $ do + let wire = + LBS.pack + "{\"took\":5,\"timed_out\":false,\"_shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"hits\":{\"total\":{\"value\":1,\"relation\":\"eq\"},\"max_score\":1.0,\"hits\":[{\"_index\":\".opendistro-alerting-config\",\"_id\":\"email_account_1\",\"_version\":1,\"_seq_no\":0,\"_primary_term\":1,\"_score\":1.0,\"_source\":{\"name\":\"example_account\",\"email\":\"example@email.com\",\"host\":\"smtp.email.com\",\"port\":465,\"method\":\"ssl\"}}]}}" + let decoded = decode wire :: Maybe OS3A.SearchEmailAccountsResponse + decoded `shouldSatisfy` isJust + let resp = fromJust decoded + OS3A.searchEmailAccountsResponseTook resp `shouldBe` 5 + OS3A.searchEmailAccountsResponseTotal resp + `shouldBe` OS3A.MonitorsTotal {OS3A.monitorsTotalValue = 1, OS3A.monitorsTotalRelation = OS3A.MonitorsTotalRelationEq} + length (OS3A.searchEmailAccountsResponseHits resp) `shouldBe` 1 + let hit = head (OS3A.searchEmailAccountsResponseHits resp) + OS3A.emailAccountSearchHitId hit `shouldBe` "email_account_1" + OS3A.emailAccountName (OS3A.emailAccountSearchHitSource hit) `shouldBe` "example_account" + + describe "SearchEmailGroupsResponse decoding" $ do + it "decodes a documented search response fixture" $ do + let wire = + LBS.pack + "{\"took\":3,\"timed_out\":false,\"_shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"hits\":{\"total\":{\"value\":1,\"relation\":\"eq\"},\"max_score\":1.0,\"hits\":[{\"_index\":\".opendistro-alerting-config\",\"_id\":\"email_group_1\",\"_score\":1.0,\"_source\":{\"name\":\"example_email_group\",\"emails\":[{\"email\":\"example@email.com\"}]}}]}}" + let decoded = decode wire :: Maybe OS3A.SearchEmailGroupsResponse + decoded `shouldSatisfy` isJust + let resp = fromJust decoded + OS3A.searchEmailGroupsResponseTook resp `shouldBe` 3 + length (OS3A.searchEmailGroupsResponseHits resp) `shouldBe` 1 + let hit = head (OS3A.searchEmailGroupsResponseHits resp) + OS3A.emailGroupSearchHitId hit `shouldBe` "email_group_1" + OS3A.emailGroupName (OS3A.emailGroupSearchHitSource hit) `shouldBe` "example_email_group" + + describe "SearchFindingsResponse decoding" $ do + it "decodes a response with total_findings and opaque findings list" $ do + let wire = + LBS.pack + "{\"total_findings\":2,\"findings\":[{\"id\":\"f-1\",\"related_doc_ids\":[\"doc-1\"]},{\"id\":\"f-2\",\"related_doc_ids\":[\"doc-2\"]}]}" + let decoded = decode wire :: Maybe OS3A.SearchFindingsResponse + decoded `shouldSatisfy` isJust + let resp = fromJust decoded + OS3A.searchFindingsResponseTotalFindings resp `shouldBe` 2 + + it "decodes a response with missing total_findings (defaults to 0)" $ do + let wire = LBS.pack "{\"findings\":[]}" + let decoded = decode wire :: Maybe OS3A.SearchFindingsResponse + decoded `shouldSatisfy` isJust + OS3A.searchFindingsResponseTotalFindings (fromJust decoded) `shouldBe` 0 + + describe "Comment decoding" $ do + it "decodes a full comment fixture" $ do + let wire = + LBS.pack + "{\"entity_id\":\"alert-1\",\"entity_type\":\"alert\",\"content\":\"This is a comment\",\"created_time\":1603943261722,\"last_updated_time\":1603943261723,\"user\":\"admin\"}" + let decoded = decode wire :: Maybe OS3A.Comment + decoded `shouldSatisfy` isJust + let c = fromJust decoded + OS3A.commentEntityId c `shouldBe` "alert-1" + OS3A.commentEntityType c `shouldBe` "alert" + OS3A.commentContent c `shouldBe` "This is a comment" + OS3A.commentCreatedTime c `shouldBe` Just 1603943261722 + OS3A.commentLastUpdatedTime c `shouldBe` Just 1603943261723 + OS3A.commentUser c `shouldBe` Just "admin" + + it "round-trips through encode/decode losslessly on typed fields" $ do + let c = + OS3A.Comment + { OS3A.commentEntityId = "alert-1", + OS3A.commentEntityType = "alert", + OS3A.commentContent = "hello", + OS3A.commentCreatedTime = Just 100, + OS3A.commentLastUpdatedTime = Nothing, + OS3A.commentUser = Nothing, + OS3A.commentOther = Null + } + let encoded = encode c + let decoded = decode encoded :: Maybe OS3A.Comment + decoded `shouldSatisfy` isJust + OS3A.commentContent (fromJust decoded) `shouldBe` "hello" + OS3A.commentEntityId (fromJust decoded) `shouldBe` "alert-1" + + describe "CommentResponse decoding" $ do + it "decodes a create-comment response fixture" $ do + let wire = + LBS.pack + "{\"_id\":\"comment-1\",\"_seq_no\":0,\"_primary_term\":1,\"comment\":{\"entity_id\":\"alert-1\",\"entity_type\":\"alert\",\"content\":\"This is a comment\"}}" + let decoded = decode wire :: Maybe OS3A.CommentResponse + decoded `shouldSatisfy` isJust + let resp = fromJust decoded + OS3A.commentResponseId resp `shouldBe` "comment-1" + OS3A.commentResponseSeqNo resp `shouldBe` 0 + OS3A.commentResponsePrimaryTerm resp `shouldBe` 1 + OS3A.commentContent (OS3A.commentResponseComment resp) `shouldBe` "This is a comment" + + describe "DeleteCommentResponse decoding" $ do + it "decodes the bare {_id: ...} fixture" $ do + let wire = LBS.pack "{\"_id\":\"comment-1\"}" + let decoded = decode wire :: Maybe OS3A.DeleteCommentResponse + decoded `shouldSatisfy` isJust + OS3A.deleteCommentResponseId (fromJust decoded) `shouldBe` "comment-1" + + describe "SearchCommentsResponse decoding" $ do + it "decodes a response with a comment hit" $ do + let wire = + LBS.pack + "{\"took\":2,\"timed_out\":false,\"_shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"hits\":{\"total\":{\"value\":1,\"relation\":\"eq\"},\"max_score\":1.0,\"hits\":[{\"_index\":\".opensearch-alerting-comments-history-2024\",\"_id\":\"comment-1\",\"_score\":1.0,\"_source\":{\"entity_id\":\"alert-1\",\"entity_type\":\"alert\",\"content\":\"A comment\",\"created_time\":1603943261722,\"last_updated_time\":1603943261723,\"user\":\"admin\"}}]}}" + let decoded = decode wire :: Maybe OS3A.SearchCommentsResponse + decoded `shouldSatisfy` isJust + let resp = fromJust decoded + OS3A.searchCommentsResponseTook resp `shouldBe` 2 + length (OS3A.searchCommentsResponseHits resp) `shouldBe` 1 + let hit = head (OS3A.searchCommentsResponseHits resp) + OS3A.commentSearchHitId hit `shouldBe` "comment-1" + OS3A.commentContent (OS3A.commentSearchHitSource hit) `shouldBe` "A comment" + + describe "CreateCommentRequest encoding" $ + it "encodes content as {\"content\": \"...\"}" $ do + let req = OS3A.CreateCommentRequest "my comment" + encode req `shouldBe` LBS.pack "{\"content\":\"my comment\"}" + + describe "UpdateCommentRequest encoding" $ + it "encodes content as {\"content\": \"...\"}" $ do + let req = OS3A.UpdateCommentRequest "updated text" + encode req `shouldBe` LBS.pack "{\"content\":\"updated text\"}" + + describe "FindingsSearchOptions query params" $ do + it "defaultFindingsSearchOptions renders no params" $ do + OS3A.findingsSearchOptionsParams OS3A.defaultFindingsSearchOptions `shouldBe` [] + + it "renders findingId, size, sortOrder as query params" $ do + let opts = + OS3A.defaultFindingsSearchOptions + { OS3A.findingsSearchOptionsFindingId = Just "f-1", + OS3A.findingsSearchOptionsSize = Just 50, + OS3A.findingsSearchOptionsSortOrder = Just OS3A.DestinationSortOrderDesc + } + let params = OS3A.findingsSearchOptionsParams opts + lookup "findingId" params `shouldBe` Just (Just "f-1") + lookup "size" params `shouldBe` Just (Just "50") + lookup "sortOrder" params `shouldBe` Just (Just "desc") + + -- =========================================================== -- + -- Live round-trip: gated per-OS with os{n}OnlyIT (the -- + -- 'Test.NeuralClearCacheSpec' pattern). Wire shapes -- + -- live-verified on OS 1.3.19, 2.19.5 and 3.7.0 (bead -- + -- bloodhound-z5j). -- + -- -- + -- The DELETE-monitor response shape is version-dependent: OS -- + -- 1.3.x returns the full bare ES delete-document body (with -- + -- @_index@, @_shards@, @_seq_no@, ...); OS 2.x/3.x return only -- + -- @{_id,_version}@. The per-OS assertions pin that contract so -- + -- a regression to the old over-strict decoder (which failed on -- + -- OS 2.x/3.x) is caught immediately. -- + -- =========================================================== -- + describe "deleteMonitor live round-trip (version-dependent shape)" $ do + os1It <- runIO os1OnlyIT + os2It <- runIO os2OnlyIT + os3It <- runIO os3OnlyIT + + os1It "OS1: create -> delete returns the full ES delete-document body" $ + withTestEnv $ do + resp <- OS1.Client.createMonitor os1SampleMonitor + let mid = OS1A.MonitorId (OS1A.monitorResponseId resp) + del <- OS1.Client.deleteMonitor mid + liftIO $ do + OS1A.deleteMonitorResponseId del `shouldBe` OS1A.monitorResponseId resp + OS1A.deleteMonitorResponseVersion del `shouldSatisfy` (>= 1) + OS1A.deleteMonitorResponseIndex del `shouldSatisfy` isJust + OS1A.deleteMonitorResponseShards del `shouldSatisfy` isJust + OS1A.deleteMonitorResponseResult del `shouldBe` Just "deleted" + + os2It "OS2: create -> delete returns the minimal {_id,_version} body" $ + withTestEnv $ do + resp <- OS2.Client.createMonitor os2SampleMonitor + let mid = OS2A.MonitorId (OS2A.monitorResponseId resp) + del <- OS2.Client.deleteMonitor mid + liftIO $ do + OS2A.deleteMonitorResponseId del `shouldBe` OS2A.monitorResponseId resp + OS2A.deleteMonitorResponseVersion del `shouldSatisfy` (>= 1) + OS2A.deleteMonitorResponseIndex del `shouldBe` Nothing + OS2A.deleteMonitorResponseShards del `shouldBe` Nothing + OS2A.deleteMonitorResponseResult del `shouldBe` Nothing + + os3It "OS3: create -> delete returns the minimal {_id,_version} body" $ + withTestEnv $ do + resp <- OS3.Client.createMonitor os3SampleMonitor + let mid = OS3A.MonitorId (OS3A.monitorResponseId resp) + del <- OS3.Client.deleteMonitor mid + liftIO $ do + OS3A.deleteMonitorResponseId del `shouldBe` OS3A.monitorResponseId resp + OS3A.deleteMonitorResponseVersion del `shouldSatisfy` (>= 1) + OS3A.deleteMonitorResponseIndex del `shouldBe` Nothing + OS3A.deleteMonitorResponseShards del `shouldBe` Nothing + OS3A.deleteMonitorResponseResult del `shouldBe` Nothing + +-- ---------------------------------------------------------------- -- +-- Sample fixtures (structurally identical across OS1/OS2/OS3; -- +-- nominally distinct types, so one per backend). -- +-- ---------------------------------------------------------------- -- + +os3SampleMonitor :: OS3A.Monitor +os3SampleMonitor = + OS3A.Monitor + { OS3A.monitorName = "test-monitor", + OS3A.monitorType = Just OS3A.AlertTypeMonitor, + OS3A.monitorMonitorType = Just OS3A.MonitorTypeQueryLevel, + OS3A.monitorEnabled = Just True, + OS3A.monitorEnabledTime = Nothing, + OS3A.monitorLastUpdateTime = Nothing, + OS3A.monitorSchemaVersion = Nothing, + OS3A.monitorSchedule = OS3A.PeriodSchedule (OS3A.SchedulePeriod 1 "MINUTES"), + OS3A.monitorInputs = [], + OS3A.monitorTriggers = [], + OS3A.monitorUser = Nothing, + OS3A.monitorRbacRoles = Nothing, + OS3A.monitorOther = Null + } + +os1SampleMonitor :: OS1A.Monitor +os1SampleMonitor = + OS1A.Monitor + { OS1A.monitorName = "test-monitor", + OS1A.monitorType = Just OS1A.AlertTypeMonitor, + OS1A.monitorMonitorType = Just OS1A.MonitorTypeQueryLevel, + OS1A.monitorEnabled = Just True, + OS1A.monitorEnabledTime = Nothing, + OS1A.monitorLastUpdateTime = Nothing, + OS1A.monitorSchemaVersion = Nothing, + OS1A.monitorSchedule = OS1A.PeriodSchedule (OS1A.SchedulePeriod 1 "MINUTES"), + OS1A.monitorInputs = [], + OS1A.monitorTriggers = [], + OS1A.monitorUser = Nothing, + OS1A.monitorRbacRoles = Nothing, + OS1A.monitorOther = Null + } + +os2SampleMonitor :: OS2A.Monitor +os2SampleMonitor = + OS2A.Monitor + { OS2A.monitorName = "test-monitor", + OS2A.monitorType = Just OS2A.AlertTypeMonitor, + OS2A.monitorMonitorType = Just OS2A.MonitorTypeQueryLevel, + OS2A.monitorEnabled = Just True, + OS2A.monitorEnabledTime = Nothing, + OS2A.monitorLastUpdateTime = Nothing, + OS2A.monitorSchemaVersion = Nothing, + OS2A.monitorSchedule = OS2A.PeriodSchedule (OS2A.SchedulePeriod 1 "MINUTES"), + OS2A.monitorInputs = [], + OS2A.monitorTriggers = [], + OS2A.monitorUser = Nothing, + OS2A.monitorRbacRoles = Nothing, + OS2A.monitorOther = Null + } + +-- | Helper assertion: the given wire string decodes to the expected +-- 'MonitorType'. +decodesMonitorTypeTo :: Text -> OS3A.MonitorType -> Expectation +decodesMonitorTypeTo wire expected = + decode (encode wire) `shouldBe` Just expected + +-- | Helper assertion: the given wire string decodes to the expected +-- 'DestinationType'. +decodesDestinationTypeTo :: Text -> OS3A.DestinationType -> Expectation +decodesDestinationTypeTo wire expected = + decode (encode wire) `shouldBe` Just expected + +-- | Sample 'Destination' for round-trip tests. Mirrors the structure +-- of the documented Slack fixture but is built as a Haskell value so +-- the encode direction is also exercised. +os3SampleSlackDestination :: OS3A.Destination +os3SampleSlackDestination = + OS3A.Destination + { OS3A.destinationId = "sample-id", + OS3A.destinationType = OS3A.DestinationTypeSlack, + OS3A.destinationName = "sample-destination", + OS3A.destinationSchemaVersion = 3, + OS3A.destinationSeqNo = 0, + OS3A.destinationPrimaryTerm = 6, + OS3A.destinationLastUpdateTime = Just 1603943261722, + OS3A.destinationUser = Nothing, + OS3A.destinationBody = object ["url" .= ("https://example.com" :: Text)], + OS3A.destinationOther = Null + } + +-- | Sample 'EmailAccount' for round-trip / endpoint-shape tests. +os3SampleEmailAccount :: OS3A.EmailAccount +os3SampleEmailAccount = + OS3A.EmailAccount + { OS3A.emailAccountName = "example_account", + OS3A.emailAccountEmail = "example@email.com", + OS3A.emailAccountHost = "smtp.email.com", + OS3A.emailAccountPort = 465, + OS3A.emailAccountMethod = "ssl", + OS3A.emailAccountSchemaVersion = Just 2, + OS3A.emailAccountOther = Null + } + +-- | Sample 'EmailGroup' for round-trip / endpoint-shape tests. +os3SampleEmailGroup :: OS3A.EmailGroup +os3SampleEmailGroup = + OS3A.EmailGroup + { OS3A.emailGroupName = "example_email_group", + OS3A.emailGroupEmails = + [ OS3A.EmailGroupRecipient + { OS3A.emailGroupRecipientEmail = "example@email.com", + OS3A.emailGroupRecipientOther = Null + } + ], + OS3A.emailGroupSchemaVersion = Just 2, + OS3A.emailGroupOther = Null + } diff --git a/tests/Test/AnalyzeSpec.hs b/tests/Test/AnalyzeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/AnalyzeSpec.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-x-partial #-} + +module Test.AnalyzeSpec (spec) where + +import Data.Aeson.Key (fromText) +import Data.Aeson.Types (parseMaybe) +import Data.ByteString.Lazy.Char8 qualified as BL8 +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + describe "Analyze JSON round-trip" $ do + let lookupField :: Value -> Text -> Maybe Value + lookupField json field = parseMaybe (withObject "req" $ \o -> o .: fromText field) json + + it "encodes a minimal AnalyzeRequest (text only)" $ + let req = + AnalyzeRequest + { analyzeRequestText = ["foo"], + analyzeRequestAnalyzer = Just "standard", + analyzeRequestTokenizer = Nothing, + analyzeRequestFilter = Nothing, + analyzeRequestCharFilter = Nothing, + analyzeRequestField = Nothing, + analyzeRequestNormalizer = Nothing + } + json = toJSON req + in do + lookupField json "text" `shouldBe` Just (toJSON ["foo" :: Text]) + lookupField json "analyzer" `shouldBe` Just (String "standard") + + it "omits optional fields that are Nothing" $ + let req = + AnalyzeRequest + { analyzeRequestText = ["foo"], + analyzeRequestAnalyzer = Nothing, + analyzeRequestTokenizer = Nothing, + analyzeRequestFilter = Nothing, + analyzeRequestCharFilter = Nothing, + analyzeRequestField = Nothing, + analyzeRequestNormalizer = Nothing + } + json = toJSON req + in do + lookupField json "tokenizer" `shouldBe` (Nothing :: Maybe Value) + lookupField json "analyzer" `shouldBe` (Nothing :: Maybe Value) + lookupField json "filter" `shouldBe` (Nothing :: Maybe Value) + + it "includes filter, char_filter and field when provided" $ + let req = + AnalyzeRequest + { analyzeRequestText = ["foo"], + analyzeRequestAnalyzer = Nothing, + analyzeRequestTokenizer = Just "standard", + analyzeRequestFilter = Just ["lowercase", "stop"], + analyzeRequestCharFilter = Just ["html_strip"], + analyzeRequestField = Just (FieldName "message"), + analyzeRequestNormalizer = Nothing + } + json = toJSON req + in do + lookupField json "filter" `shouldBe` Just (toJSON ["lowercase", "stop" :: Text]) + lookupField json "char_filter" `shouldBe` Just (toJSON ["html_strip" :: Text]) + lookupField json "field" `shouldBe` Just (String "message") + + it "includes normalizer when provided" $ + let req = + AnalyzeRequest + { analyzeRequestText = ["foo"], + analyzeRequestAnalyzer = Nothing, + analyzeRequestTokenizer = Nothing, + analyzeRequestFilter = Nothing, + analyzeRequestCharFilter = Nothing, + analyzeRequestField = Nothing, + analyzeRequestNormalizer = Just "lowercase" + } + json = toJSON req + in lookupField json "normalizer" `shouldBe` Just (String "lowercase") + + it "decodes an Elasticsearch AnalyzeResponse with tokens" $ + let bytes = + BL8.pack + "{\"tokens\":[{\"token\":\"foo\",\"start_offset\":0,\"end_offset\":3,\"type\":\"\",\"position\":0},{\"token\":\"bar\",\"start_offset\":4,\"end_offset\":7,\"type\":\"\",\"position\":1}]}" + Just resp = decode bytes + in do + length (analyzeResponseTokens resp) `shouldBe` 2 + analyzeTokenToken (head (analyzeResponseTokens resp)) `shouldBe` "foo" + analyzeTokenPosition (analyzeResponseTokens resp !! 1) `shouldBe` 1 + + it "decodes an OpenSearch-style token with a kind field" $ + let bytes = + BL8.pack + "{\"tokens\":[{\"token\":\"foo\",\"start_offset\":0,\"end_offset\":3,\"type\":\"ALPHANUM\",\"position\":0,\"kind\":\"WORD\"}]}" + Just resp = decode bytes + in analyzeTokenKind (head (analyzeResponseTokens resp)) `shouldBe` TokenKindWord + + it "decodes an unknown kind value as TokenKindOther preserving the string" $ + let bytes = + BL8.pack + "{\"tokens\":[{\"token\":\"foo\",\"start_offset\":0,\"end_offset\":3,\"type\":\"ALPHANUM\",\"position\":0,\"kind\":\"CUSTOM\"}]}" + Just resp = decode bytes + in analyzeTokenKind (head (analyzeResponseTokens resp)) `shouldBe` TokenKindOther "CUSTOM" + + describe "Analyze endpoint" $ do + it "analyzes text with the built-in standard analyzer (lowercases) via POST /_analyze" $ + withTestEnv $ do + let req = + AnalyzeRequest + { analyzeRequestText = ["Foo Bar"], + analyzeRequestAnalyzer = Just "standard", + analyzeRequestTokenizer = Nothing, + analyzeRequestFilter = Nothing, + analyzeRequestCharFilter = Nothing, + analyzeRequestField = Nothing, + analyzeRequestNormalizer = Nothing + } + resp <- performBHRequest $ analyzeText Nothing req + let toks = analyzeResponseTokens resp + liftIO $ do + length toks `shouldBe` 2 + map analyzeTokenToken toks `shouldBe` ["foo", "bar"] + map analyzeTokenPosition toks `shouldBe` [0, 1] + map analyzeTokenStartOffset toks `shouldBe` [0, 4] + map analyzeTokenEndOffset toks `shouldBe` [3, 7] + + it "preserves case with the whitespace analyzer via POST /_analyze" $ + withTestEnv $ do + let req = + AnalyzeRequest + { analyzeRequestText = ["Foo Bar"], + analyzeRequestAnalyzer = Just "whitespace", + analyzeRequestTokenizer = Nothing, + analyzeRequestFilter = Nothing, + analyzeRequestCharFilter = Nothing, + analyzeRequestField = Nothing, + analyzeRequestNormalizer = Nothing + } + resp <- performBHRequest $ analyzeText Nothing req + let toks = analyzeResponseTokens resp + liftIO $ map analyzeTokenToken toks `shouldBe` ["Foo", "Bar"] + + it "analyzes text with a lowercase filter chain via POST /_analyze" $ + withTestEnv $ do + let req = + AnalyzeRequest + { analyzeRequestText = ["Foo Bar"], + analyzeRequestAnalyzer = Nothing, + analyzeRequestTokenizer = Just "standard", + analyzeRequestFilter = Just ["lowercase"], + analyzeRequestCharFilter = Nothing, + analyzeRequestField = Nothing, + analyzeRequestNormalizer = Nothing + } + resp <- performBHRequest $ analyzeText Nothing req + let toks = analyzeResponseTokens resp + liftIO $ do + length toks `shouldBe` 2 + map analyzeTokenToken toks `shouldBe` ["foo", "bar"] + + it "returns no tokens for an empty text value" $ + withTestEnv $ do + let req = + AnalyzeRequest + { analyzeRequestText = [""], + analyzeRequestAnalyzer = Just "standard", + analyzeRequestTokenizer = Nothing, + analyzeRequestFilter = Nothing, + analyzeRequestCharFilter = Nothing, + analyzeRequestField = Nothing, + analyzeRequestNormalizer = Nothing + } + resp <- performBHRequest $ analyzeText Nothing req + liftIO $ analyzeResponseTokens resp `shouldBe` [] + + it "analyzes text via POST /{index}/_analyze against an existing index" $ + withTestEnv $ do + _ <- createExampleIndex + let req = + AnalyzeRequest + { analyzeRequestText = ["Foo Bar"], + analyzeRequestAnalyzer = Just "standard", + analyzeRequestTokenizer = Nothing, + analyzeRequestFilter = Nothing, + analyzeRequestCharFilter = Nothing, + analyzeRequestField = Nothing, + analyzeRequestNormalizer = Nothing + } + resp <- performBHRequest $ analyzeText (Just testIndex) req + _ <- deleteExampleIndex + let toks = analyzeResponseTokens resp + liftIO $ do + length toks `shouldBe` 2 + map analyzeTokenToken toks `shouldBe` ["foo", "bar"] diff --git a/tests/Test/AnomalyDetectionSpec.hs b/tests/Test/AnomalyDetectionSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/AnomalyDetectionSpec.hs @@ -0,0 +1,1372 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.AnomalyDetectionSpec (spec) where + +import Control.Concurrent (threadDelay) +import Control.Monad (void) +import Control.Monad.Catch (bracket_) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value (..), decode, encode, object, (.=)) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Fixed (Pico) +import Data.List qualified as L +import Data.Maybe (isJust) +import Data.Text qualified as T +import Data.Time.Calendar (toGregorian) +import Data.Time.Clock (UTCTime (..)) +import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime) +import Data.Time.LocalTime (TimeOfDay (..), timeToTimeOfDay) +import Database.Bloodhound.OpenSearch1.Client qualified as OS1Client +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch1.Types qualified as OS1Types +import Database.Bloodhound.OpenSearch2.Client qualified as OS2Client +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2Types +import Database.Bloodhound.OpenSearch3.Client qualified as OS3Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types qualified as OS3Types +import TestsUtils.Common + ( os1OnlyIT, + os2OnlyIT, + os3OnlyIT, + withTestEnv, + ) +import TestsUtils.Import +import Prelude + +-- --------------------------------------------------------------------------- +-- Sample fixtures, drawn verbatim from the OS Anomaly Detection plugin docs +-- (). +-- --------------------------------------------------------------------------- + +-- | A bare-bones single-entity detector body — exactly the shape the docs +-- show for @POST /_plugins/_anomaly_detection/detectors@ (a name, a +-- @time_field@, the target indices, one feature aggregation, and a +-- detection interval). Used to build both the request 'OS1Types.Detector' +-- and the expected inner @anomaly_detector@ of a decoded response. +sampleSingleEntityDetectorJson :: LBS.ByteString +sampleSingleEntityDetectorJson = + "{\ + \ \"name\": \"test-detector\",\ + \ \"description\": \"Test detector\",\ + \ \"time_field\": \"timestamp\",\ + \ \"indices\": [\"anomaly-test\"],\ + \ \"feature_attributes\": [\ + \ {\ + \ \"feature_name\": \"value\",\ + \ \"feature_enabled\": true,\ + \ \"aggregation_query\": {\ + \ \"value\": { \"avg\": { \"field\": \"value\" } }\ + \ }\ + \ }\ + \ ],\ + \ \"detection_interval\": {\ + \ \"period\": { \"interval\": 1, \"unit\": \"Minutes\" }\ + \ },\ + \ \"window_delay\": {\ + \ \"period\": { \"interval\": 1, \"unit\": \"Minutes\" }\ + \ }\ + \}" + +-- | The create-response envelope returned by the plugin. Captured live +-- against OS 3.7.0 with an OS-generated @rules@ array (a default +-- @IGNORE_ANOMALY@ rule the docs do not enumerate). Carries every +-- server-injected bookkeeping field we model. +sampleCreateResponseJson :: LBS.ByteString +sampleCreateResponseJson = + "{\ + \ \"_id\": \"VEHKTXwBwf_U8gjUXY2s\",\ + \ \"_version\": 1,\ + \ \"_seq_no\": 0,\ + \ \"_primary_term\": 1,\ + \ \"anomaly_detector\": {\ + \ \"name\": \"test-detector\",\ + \ \"description\": \"Test detector\",\ + \ \"time_field\": \"timestamp\",\ + \ \"indices\": [\"anomaly-test\"],\ + \ \"filter_query\": { \"match_all\": { \"boost\": 1.0 } },\ + \ \"window_delay\": {\ + \ \"period\": { \"interval\": 1, \"unit\": \"Minutes\" }\ + \ },\ + \ \"shingle_size\": 8,\ + \ \"schema_version\": 0,\ + \ \"feature_attributes\": [\ + \ {\ + \ \"feature_id\": \"U0HKTXwBwf_U8gjUXY2m\",\ + \ \"feature_name\": \"value\",\ + \ \"feature_enabled\": true,\ + \ \"aggregation_query\": {\ + \ \"value\": { \"avg\": { \"field\": \"value\" } }\ + \ }\ + \ }\ + \ ],\ + \ \"recency_emphasis\": 2560,\ + \ \"history\": 40,\ + \ \"last_update_time\": 1633392680364,\ + \ \"detection_interval\": {\ + \ \"period\": { \"interval\": 1, \"unit\": \"Minutes\" }\ + \ },\ + \ \"detector_type\": \"SINGLE_ENTITY\",\ + \ \"rules\": [\ + \ {\ + \ \"action\": \"IGNORE_ANOMALY\",\ + \ \"conditions\": [\ + \ {\ + \ \"feature_name\": \"value\",\ + \ \"threshold_type\": \"ACTUAL_OVER_EXPECTED_RATIO\",\ + \ \"operator\": \"LTE\",\ + \ \"value\": 0.2\ + \ }\ + \ ]\ + \ }\ + \ ]\ + \ }\ + \}" + +-- | A high-cardinality / multi-entity detector body. Differs from the +-- single-entity sample only by adding @category_field@; the server +-- derives @detector_type = "MULTI_ENTITY"@ from its presence. +sampleMultiEntityDetectorJson :: LBS.ByteString +sampleMultiEntityDetectorJson = + "{\ + \ \"name\": \"test-detector-multi\",\ + \ \"description\": \"Multi-entity\",\ + \ \"time_field\": \"timestamp\",\ + \ \"indices\": [\"anomaly-test\"],\ + \ \"category_field\": [\"ip\"],\ + \ \"feature_attributes\": [\ + \ {\ + \ \"feature_name\": \"value\",\ + \ \"feature_enabled\": true,\ + \ \"aggregation_query\": {\ + \ \"value\": { \"avg\": { \"field\": \"value\" } }\ + \ }\ + \ }\ + \ ],\ + \ \"detection_interval\": {\ + \ \"period\": { \"interval\": 1, \"unit\": \"Minutes\" }\ + \ }\ + \}" + +-- | The @_start@ / @_stop@ response body — the small +-- write-acknowledgment envelope returned by the detector job lifecycle +-- endpoints (@_id@, @_version@, @_seq_no@, @_primary_term@). Drawn +-- verbatim from the Start Detector Job example response in the OS AD +-- API docs. +sampleDetectorJobAcknowledgmentJson :: LBS.ByteString +sampleDetectorJobAcknowledgmentJson = + "{\ + \ \"_id\": \"VEHKTXwBwf_U8gjUXY2s\",\ + \ \"_version\": 3,\ + \ \"_seq_no\": 6,\ + \ \"_primary_term\": 1\ + \}" + +-- | A 'Value'-typed feature aggregation body, used by both the +-- 'OS1Types.Detector' request sample and the expected +-- 'OS1Types.DetectorResponse' inner object. +sampleAggregationQuery :: Value +sampleAggregationQuery = + object + [ "value" + .= object ["avg" .= object ["field" .= String "value"]] + ] + +-- | Haskell-side single-entity 'OS1Types.Detector' mirror of +-- 'sampleSingleEntityDetectorJson'. Used for round-trip equality +-- assertions. +os1SampleDetector :: OS1Types.Detector +os1SampleDetector = + OS1Types.Detector + { OS1Types.detectorName = "test-detector", + OS1Types.detectorDescription = Just "Test detector", + OS1Types.detectorTimeField = "timestamp", + OS1Types.detectorIndices = ["anomaly-test"], + OS1Types.detectorFeatureAttributes = + [ OS1Types.FeatureAttribute + { OS1Types.featureAttributeId = Nothing, + OS1Types.featureAttributeName = "value", + OS1Types.featureAttributeEnabled = True, + OS1Types.featureAttributeAggregationQuery = sampleAggregationQuery + } + ], + OS1Types.detectorFilterQuery = Nothing, + OS1Types.detectorDetectionInterval = + OS1Types.WindowPeriod + { OS1Types.windowPeriodPeriod = + OS1Types.Period + { OS1Types.periodInterval = 1, + OS1Types.periodUnit = OS1Types.PeriodUnitMinutes + } + }, + OS1Types.detectorWindowDelay = + Just + ( OS1Types.WindowPeriod + { OS1Types.windowPeriodPeriod = + OS1Types.Period + { OS1Types.periodInterval = 1, + OS1Types.periodUnit = OS1Types.PeriodUnitMinutes + } + } + ), + OS1Types.detectorCategoryField = Nothing, + OS1Types.detectorResultIndex = Nothing + } + +spec :: Spec +spec = do + -- ======================================================================= + -- DetectorId newtype + -- ======================================================================= + describe "AnomalyDetection DetectorId JSON" $ do + it "encodes DetectorId as a bare JSON string" $ do + encode (OS1Types.DetectorId "abc-123") + `shouldBe` "\"abc-123\"" + + it "decodes a bare JSON string into DetectorId" $ do + decode "\"abc-123\"" `shouldBe` Just (OS1Types.DetectorId "abc-123") + + it "round-trips DetectorId through encode -> decode" $ do + let original = OS1Types.DetectorId "round-trip-id" + (decode . encode) original `shouldBe` Just original + + -- ======================================================================= + -- PeriodUnit enum + -- ======================================================================= + describe "AnomalyDetection PeriodUnit JSON" $ do + let cases = + [ (OS1Types.PeriodUnitMinutes, "Minutes"), + (OS1Types.PeriodUnitHours, "Hours"), + (OS1Types.PeriodUnitSeconds, "Seconds"), + (OS1Types.PeriodUnitDays, "Days"), + (OS1Types.PeriodUnitWeeks, "Weeks"), + (OS1Types.PeriodUnitMonths, "Months") + ] + forM_ cases $ \(u, wire) -> do + it ("encodes " <> show wire <> " to the documented wire string") $ do + encode u `shouldBe` "\"" <> LBS.fromStrict wire <> "\"" + it ("decodes the documented wire string " <> show wire) $ do + (decode ("\"" <> LBS.fromStrict wire <> "\"") :: Maybe OS1Types.PeriodUnit) + `shouldBe` Just u + + it "decodes an unknown unit into PeriodUnitCustom" $ do + (decode "\"Decades\"" :: Maybe OS1Types.PeriodUnit) + `shouldBe` Just (OS1Types.PeriodUnitCustom "Decades") + + it "round-trips PeriodUnit through ToJSON/FromJSON (known)" $ do + let u = OS1Types.PeriodUnitMinutes + (decode . encode) u `shouldBe` Just u + + -- ======================================================================= + -- DetectorType enum + -- ======================================================================= + describe "AnomalyDetection DetectorType JSON" $ do + let cases = + [ (OS1Types.DetectorTypeSingleEntity, "SINGLE_ENTITY"), + (OS1Types.DetectorTypeMultiEntity, "MULTI_ENTITY") + ] + forM_ cases $ \(t, wire) -> do + it ("encodes " <> show wire) $ do + encode t `shouldBe` "\"" <> LBS.fromStrict wire <> "\"" + it ("decodes " <> show wire) $ do + (decode ("\"" <> LBS.fromStrict wire <> "\"") :: Maybe OS1Types.DetectorType) + `shouldBe` Just t + + it "decodes an unknown detector_type into DetectorTypeCustom" $ do + (decode "\"HYBRID\"" :: Maybe OS1Types.DetectorType) + `shouldBe` Just (OS1Types.DetectorTypeCustom "HYBRID") + + -- ======================================================================= + -- Detector (request body) JSON + -- ======================================================================= + describe "AnomalyDetection Detector JSON" $ do + it "decodes the documented single-entity request body" $ do + let decoded = decode sampleSingleEntityDetectorJson :: Maybe OS1Types.Detector + decoded `shouldBe` Just os1SampleDetector + + it "round-trips the single-entity Detector through encode -> decode" $ do + (decode . encode) os1SampleDetector `shouldBe` Just os1SampleDetector + + it "decodes a multi-entity request body (carries category_field)" $ do + let decoded = decode sampleMultiEntityDetectorJson :: Maybe OS1Types.Detector + decoded `shouldSatisfy` isJust + let Just d = decoded + OS1Types.detectorCategoryField d `shouldBe` Just ["ip"] + + it "encodes a Detector omitting nulls (no description, no filter_query)" $ do + let minimal = + os1SampleDetector + { OS1Types.detectorDescription = Nothing, + OS1Types.detectorWindowDelay = Nothing + } + let encoded = encode minimal + encodedStr = LBS.unpack encoded + -- @description@ and @window_delay@ should NOT appear in the wire form. + encodedStr `shouldSatisfy` not . L.isInfixOf "\"description\"" + encodedStr `shouldSatisfy` not . L.isInfixOf "\"window_delay\"" + -- @detection_interval@ always appears (required field). + encodedStr `shouldSatisfy` L.isInfixOf "\"detection_interval\"" + + -- ======================================================================= + -- CreateDetectorResponse JSON (envelope + inner DetectorResponse) + -- ======================================================================= + describe "AnomalyDetection CreateDetectorResponse JSON" $ do + it "decodes the documented single-entity response envelope (OS1)" $ do + let decoded = decode sampleCreateResponseJson :: Maybe OS1Types.CreateDetectorResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.createDetectorResponseId r `shouldBe` "VEHKTXwBwf_U8gjUXY2s" + OS1Types.createDetectorResponseSeqNo r `shouldBe` 0 + OS1Types.createDetectorResponsePrimaryTerm r `shouldBe` 1 + let inner = OS1Types.createDetectorResponseDetector r + OS1Types.detectorResponseName inner `shouldBe` "test-detector" + OS1Types.detectorResponseShingleSize inner `shouldBe` Just 8 + OS1Types.detectorResponseSchemaVersion inner `shouldBe` Just 0 + OS1Types.detectorResponseDetectorType inner + `shouldBe` Just OS1Types.DetectorTypeSingleEntity + OS1Types.detectorResponseRules inner `shouldSatisfy` isJust + + it "decodes the same response envelope identically across OS1/OS2/OS3" $ do + let r1 = decode sampleCreateResponseJson :: Maybe OS1Types.CreateDetectorResponse + r2 = decode sampleCreateResponseJson :: Maybe OS2Types.CreateDetectorResponse + r3 = decode sampleCreateResponseJson :: Maybe OS3Types.CreateDetectorResponse + r1 `shouldSatisfy` isJust + r2 `shouldSatisfy` isJust + r3 `shouldSatisfy` isJust + + it "round-trips the response envelope through encode -> decode" $ do + let decoded = decode sampleCreateResponseJson :: Maybe OS1Types.CreateDetectorResponse + Just r <- pure decoded + (decode . encode) r `shouldBe` Just r + + it "rejects a response missing the anomaly_detector key" $ do + let bad = "{\"_id\":\"x\",\"_version\":1,\"_seq_no\":0,\"_primary_term\":1}" + (decode bad :: Maybe OS1Types.CreateDetectorResponse) `shouldBe` Nothing + + -- ======================================================================= + -- GetDetectorResponse + GetDetectorParams — the ?job/?task flag surface + -- (bloodhound-ae1). Fixtures drawn from the OS AD Get Detector docs. + -- ======================================================================= + describe "AnomalyDetection getDetector request wiring" $ do + let did = OS1Types.DetectorId "abc" + mkParams jobFlag taskFlag = + OS1Types.GetDetectorParams + { OS1Types.getDetectorParamsJob = jobFlag, + OS1Types.getDetectorParamsTask = taskFlag + } + queriesOf = getRawEndpointQueries . bhRequestEndpoint . OS1Requests.getDetector did + it "default params produce a bare GET with no job/task query" $ + queriesOf OS1Types.defaultGetDetectorParams `shouldBe` [] + it "?job=true only" $ + queriesOf (mkParams True False) `shouldBe` [("job", Just "true")] + it "?task=true only" $ + queriesOf (mkParams False True) `shouldBe` [("task", Just "true")] + it "?job=true&task=true together" $ + queriesOf (mkParams True True) + `shouldBe` [("job", Just "true"), ("task", Just "true")] + + describe "AnomalyDetection GetDetectorResponse JSON" $ do + let baseBody = + "{\ + \ \"_id\": \"VEHKTXwBwf_U8gjUXY2s\",\ + \ \"_version\": 1,\ + \ \"_primary_term\": 1,\ + \ \"_seq_no\": 5,\ + \ \"anomaly_detector\": {\ + \ \"name\": \"test-detector\",\ + \ \"time_field\": \"timestamp\",\ + \ \"indices\": [\"anomaly-test\"],\ + \ \"detection_interval\": {\ + \ \"period\": {\"interval\": 1, \"unit\": \"Minutes\"}\ + \ }\ + \ }\ + \}" + it "decodes the bare response with job/tasks as Nothing" $ do + let decoded = decode baseBody :: Maybe OS1Types.GetDetectorResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.getDetectorResponseId r `shouldBe` "VEHKTXwBwf_U8gjUXY2s" + OS1Types.getDetectorResponseJob r `shouldBe` Nothing + OS1Types.getDetectorResponseRealtimeTask r `shouldBe` Nothing + OS1Types.getDetectorResponseHistoricalTask r `shouldBe` Nothing + + it "decodes ?job=true response with only the job populated" $ do + let body = + "{\ + \ \"_id\": \"VEHKTXwBwf_U8gjUXY2s\",\ + \ \"_version\": 1,\ + \ \"_primary_term\": 1,\ + \ \"_seq_no\": 5,\ + \ \"anomaly_detector\": {\ + \ \"name\": \"test-detector\",\ + \ \"time_field\": \"timestamp\",\ + \ \"indices\": [\"anomaly-test\"],\ + \ \"detection_interval\": {\ + \ \"period\": {\"interval\": 1, \"unit\": \"Minutes\"}\ + \ }\ + \ },\ + \ \"anomaly_detector_job\": {\ + \ \"name\": \"VEHKTXwBwf_U8gjUXY2s\",\ + \ \"enabled\": true,\ + \ \"enabled_time\": 1633393656357,\ + \ \"lock_duration_seconds\": 60,\ + \ \"schedule\": {\ + \ \"interval\": {\ + \ \"start_time\": 1633393656357,\ + \ \"period\": 1,\ + \ \"unit\": \"Minutes\"\ + \ }\ + \ }\ + \ }\ + \}" + decoded = decode body :: Maybe OS1Types.GetDetectorResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.detectorJobEnabled <$> OS1Types.getDetectorResponseJob r `shouldBe` Just (Just True) + OS1Types.detectorJobLockDurationSeconds <$> OS1Types.getDetectorResponseJob r `shouldBe` Just (Just 60) + -- schedule typed as the documented {interval:{start_time,period,unit}} form + job <- pure (OS1Types.getDetectorResponseJob r) + OS1Types.detectorJobScheduleIntervalPeriod + <$> (OS1Types.detectorJobScheduleInterval <$> (OS1Types.detectorJobSchedule =<< job)) + `shouldBe` Just 1 + OS1Types.getDetectorResponseRealtimeTask r `shouldBe` Nothing + OS1Types.getDetectorResponseHistoricalTask r `shouldBe` Nothing + + it "decodes ?task=true response with both tasks populated and no job" $ do + let body = + "{\ + \ \"_id\": \"VEHKTXwBwf_U8gjUXY2s\",\ + \ \"_version\": 1,\ + \ \"_primary_term\": 1,\ + \ \"_seq_no\": 5,\ + \ \"anomaly_detector\": {\ + \ \"name\": \"test-detector\",\ + \ \"time_field\": \"timestamp\",\ + \ \"indices\": [\"anomaly-test\"],\ + \ \"detection_interval\": {\ + \ \"period\": {\"interval\": 1, \"unit\": \"Minutes\"}\ + \ }\ + \ },\ + \ \"realtime_detection_task\": {\ + \ \"task_id\": \"rt-1\",\ + \ \"task_type\": \"REALTIME_SINGLE_ENTITY\",\ + \ \"state\": \"RUNNING\",\ + \ \"task_progress\": 0,\ + \ \"is_latest\": true\ + \ },\ + \ \"historical_analysis_task\": {\ + \ \"task_id\": \"hist-1\",\ + \ \"task_type\": \"HISTORICAL_SINGLE_ENTITY\",\ + \ \"state\": \"RUNNING\",\ + \ \"task_progress\": 0.89285713,\ + \ \"current_piece\": 1633328940000,\ + \ \"detection_date_range\": {\ + \ \"start_time\": 1632788951329,\ + \ \"end_time\": 1633393751329\ + \ },\ + \ \"worker_node\": \"node-x\",\ + \ \"is_latest\": true\ + \ }\ + \}" + decoded = decode body :: Maybe OS1Types.GetDetectorResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.getDetectorResponseJob r `shouldBe` Nothing + -- Real-time task: integer task_progress (0) decodes as Scientific. + rt <- pure (OS1Types.getDetectorResponseRealtimeTask r) + OS1Types.detectionTaskTaskId <$> rt `shouldBe` Just "rt-1" + OS1Types.detectionTaskType + <$> rt + `shouldBe` Just (Just OS1Types.DetectionTaskTypeRealtimeSingleEntity) + -- Historical task: fractional task_progress + historical-only fields. + hist <- pure (OS1Types.getDetectorResponseHistoricalTask r) + OS1Types.detectionTaskTaskId <$> hist `shouldBe` Just "hist-1" + OS1Types.detectionTaskCurrentPiece <$> hist `shouldBe` Just (Just 1633328940000) + OS1Types.detectionTaskWorkerNode <$> hist `shouldBe` Just (Just "node-x") + -- detection_date_range is a historical-only sibling of the task. + ddr <- pure (OS1Types.detectionTaskDetectionDateRange =<< hist) + OS1Types.detectionDateRangeStartTime <$> ddr `shouldBe` Just (Just 1632788951329) + OS1Types.detectionDateRangeEndTime <$> ddr `shouldBe` Just (Just 1633393751329) + + it "round-trips the bare response through encode -> decode" $ do + let decoded = decode baseBody :: Maybe OS1Types.GetDetectorResponse + Just r <- pure decoded + (decode . encode) r `shouldBe` Just r + + -- ======================================================================= + -- DetectionTaskType — enum round-trip + forward-compat escape hatch + -- ======================================================================= + describe "AnomalyDetection DetectionTaskType JSON" $ do + let cases = + [ (OS1Types.DetectionTaskTypeRealtimeSingleEntity, "REALTIME_SINGLE_ENTITY"), + (OS1Types.DetectionTaskTypeHistoricalSingleEntity, "HISTORICAL_SINGLE_ENTITY"), + (OS1Types.DetectionTaskTypeRealtimeMultiEntity, "REALTIME_MULTI_ENTITY"), + (OS1Types.DetectionTaskTypeHistoricalMultiEntity, "HISTORICAL_MULTI_ENTITY") + ] + it "encodes each documented constructor to its wire string" $ + mapM_ + ( \(con, wire) -> + encode con `shouldBe` "\"" <> LBS.pack wire <> "\"" + ) + cases + it "decodes each documented wire string" $ + mapM_ + ( \(con, wire) -> + (decode (LBS.pack ("\"" <> wire <> "\"")) :: Maybe OS1Types.DetectionTaskType) + `shouldBe` Just con + ) + cases + it "round-trips an unknown value through the Custom escape hatch" $ do + let custom = OS1Types.DetectionTaskTypeCustom "REALTIME_NEW_KIND" + (decode . encode) custom `shouldBe` Just custom + + -- ======================================================================= + -- DetectorJobAcknowledgment — the _start/_stop job lifecycle response + -- ======================================================================= + describe "AnomalyDetection DetectorJobAcknowledgment JSON" $ do + it "decodes the documented @_start@ / @_stop@ envelope" $ do + let decoded = decode sampleDetectorJobAcknowledgmentJson :: Maybe OS1Types.DetectorJobAcknowledgment + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.detectorJobAcknowledgmentId r `shouldBe` "VEHKTXwBwf_U8gjUXY2s" + OS1Types.detectorJobAcknowledgmentSeqNo r `shouldBe` 6 + OS1Types.detectorJobAcknowledgmentPrimaryTerm r `shouldBe` 1 + + it "round-trips through ToJSON / FromJSON (covers @_version@)" $ do + let Just ack = decode sampleDetectorJobAcknowledgmentJson :: Maybe OS1Types.DetectorJobAcknowledgment + (decode . encode) ack `shouldBe` Just (ack :: OS1Types.DetectorJobAcknowledgment) + + it "decodes the documented @_stop@ response with zeroed bookkeeping fields" $ do + -- @_version@ is @0@ here; this pins down why the field is 'Int' + -- rather than 'DocVersion' (whose minBound is 1). + let stopResp = + "{\ + \ \"_id\": \"VEHKTXwBwf_U8gjUXY2s\",\ + \ \"_version\": 0,\ + \ \"_seq_no\": 0,\ + \ \"_primary_term\": 0\ + \}" + decoded = decode stopResp :: Maybe OS1Types.DetectorJobAcknowledgment + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.detectorJobAcknowledgmentId r `shouldBe` "VEHKTXwBwf_U8gjUXY2s" + OS1Types.detectorJobAcknowledgmentVersion r `shouldBe` 0 + OS1Types.detectorJobAcknowledgmentSeqNo r `shouldBe` 0 + OS1Types.detectorJobAcknowledgmentPrimaryTerm r `shouldBe` 0 + + it "tolerates an envelope missing @_primary_term@ (OS start/stop acks)" $ do + -- OS 1/2/3 only return @_id@ in start/stop job acknowledgments; + -- the @_version@, @_seq_no@, @_primary_term@ fields are absent. + -- The parser defaults them to 0 to tolerate that wire shape. + let partial = "{\"_id\":\"x\",\"_version\":0,\"_seq_no\":0}" + Just r = decode partial :: Maybe OS1Types.DetectorJobAcknowledgment + OS1Types.detectorJobAcknowledgmentId r `shouldBe` "x" + OS1Types.detectorJobAcknowledgmentPrimaryTerm r `shouldBe` 0 + + -- ======================================================================= + -- StartDetectorJobRequest JSON (historical-analysis body for _start) + -- ======================================================================= + describe "AnomalyDetection StartDetectorJobRequest JSON" $ do + it "encodes the documented @start_time@ / @end_time@ field names" $ do + let req = + OS1Types.StartDetectorJobRequest + { OS1Types.startDetectorJobRequestStartTime = 1633048868000, + OS1Types.startDetectorJobRequestEndTime = 1633394468000 + } + encoded = LBS.unpack (encode req) + encoded `shouldSatisfy` L.isInfixOf "\"start_time\":1633048868000" + encoded `shouldSatisfy` L.isInfixOf "\"end_time\":1633394468000" + (decode . encode) req `shouldBe` Just req + + it "decodes the documented historical @_start@ body" $ do + let body = + "{\ + \ \"start_time\": 1633048868000,\ + \ \"end_time\": 1633394468000\ + \}" + decoded = decode body :: Maybe OS1Types.StartDetectorJobRequest + decoded + `shouldBe` Just + ( OS1Types.StartDetectorJobRequest + { OS1Types.startDetectorJobRequestStartTime = 1633048868000, + OS1Types.startDetectorJobRequestEndTime = 1633394468000 + } + ) + + -- ======================================================================= + -- PreviewRequest / PreviewResponse JSON + -- ======================================================================= + describe "AnomalyDetection PreviewRequest JSON" $ do + it "round-trips period_start / period_end (no detector)" $ do + let req = + OS1Types.PreviewRequest + { OS1Types.previewRequestPeriodStart = 1633048868000, + OS1Types.previewRequestPeriodEnd = 1633394468000, + OS1Types.previewRequestDetector = Nothing, + OS1Types.previewRequestDetectorId = Nothing + } + (decode . encode) req `shouldBe` Just req + + it "encodes only the period fields when no detector is set (backward compat)" $ do + let req = + OS1Types.PreviewRequest + { OS1Types.previewRequestPeriodStart = 1, + OS1Types.previewRequestPeriodEnd = 2, + OS1Types.previewRequestDetector = Nothing, + OS1Types.previewRequestDetectorId = Nothing + } + encoded = LBS.unpack (encode req) + encoded `shouldSatisfy` L.isInfixOf "\"period_start\":1" + encoded `shouldSatisfy` L.isInfixOf "\"period_end\":2" + -- The two new optional fields must NOT appear when 'Nothing', so a + -- plain {id}-in-path preview round-trips exactly as before. + encoded `shouldNotSatisfy` L.isInfixOf "\"detector\"" + encoded `shouldNotSatisfy` L.isInfixOf "\"detector_id\"" + + it "encodes an inline detector (unpersisted config preview)" $ do + let det = + OS1Types.Detector + { OS1Types.detectorName = "test-detector", + OS1Types.detectorDescription = Nothing, + OS1Types.detectorTimeField = "timestamp", + OS1Types.detectorIndices = ["server_log*"], + OS1Types.detectorFeatureAttributes = [], + OS1Types.detectorFilterQuery = Nothing, + OS1Types.detectorDetectionInterval = + OS1Types.WindowPeriod + (OS1Types.Period 1 OS1Types.PeriodUnitMinutes), + OS1Types.detectorWindowDelay = Nothing, + OS1Types.detectorCategoryField = Nothing, + OS1Types.detectorResultIndex = Nothing + } + req = + OS1Types.PreviewRequest + { OS1Types.previewRequestPeriodStart = 1, + OS1Types.previewRequestPeriodEnd = 2, + OS1Types.previewRequestDetector = Just det, + OS1Types.previewRequestDetectorId = Nothing + } + encoded = LBS.unpack (encode req) + encoded `shouldSatisfy` L.isInfixOf "\"detector\":{" + -- detector_id must remain absent in the inline form. + encoded `shouldNotSatisfy` L.isInfixOf "\"detector_id\"" + (decode . encode) req `shouldBe` Just req + + it "encodes a body detector_id (no-id-in-path preview)" $ do + let req = + OS1Types.PreviewRequest + { OS1Types.previewRequestPeriodStart = 1, + OS1Types.previewRequestPeriodEnd = 2, + OS1Types.previewRequestDetector = Nothing, + OS1Types.previewRequestDetectorId = Just (OS1Types.DetectorId "VEHKTXwBwf_U8gjUXY2s") + } + encoded = LBS.unpack (encode req) + encoded `shouldSatisfy` L.isInfixOf "\"detector_id\":\"VEHKTXwBwf_U8gjUXY2s\"" + encoded `shouldNotSatisfy` L.isInfixOf "\"detector\":{" + (decode . encode) req `shouldBe` Just req + + it "decodes the documented inline-detector preview body" $ do + let body = + "{\ + \ \"period_start\": 1633048868000,\ + \ \"period_end\": 1633394468000,\ + \ \"detector_id\": \"VEHKTXwBwf_U8gjUXY2s\"\ + \}" + decoded = decode body :: Maybe OS1Types.PreviewRequest + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.previewRequestDetectorId r `shouldBe` Just (OS1Types.DetectorId "VEHKTXwBwf_U8gjUXY2s") + OS1Types.previewRequestDetector r `shouldBe` Nothing + + describe "AnomalyDetection PreviewResponse JSON" $ do + it "decodes a sparse response (empty anomaly_result list)" $ do + let body = + "{\ + \ \"anomaly_result\": [],\ + \ \"anomaly_detector\": {\ + \ \"name\": \"d\",\ + \ \"time_field\": \"ts\",\ + \ \"detection_interval\": {\ + \ \"period\": {\"interval\": 1, \"unit\": \"Minutes\"}\ + \ }\ + \ }\ + \}" + decoded = decode body :: Maybe OS1Types.PreviewResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.previewResponseAnomalyResult r `shouldBe` [] + OS1Types.detectorResponseName (OS1Types.previewResponseAnomalyDetector r) + `shouldBe` "d" + + -- ======================================================================= + -- Lifecycle response/request JSON: delete / job / validate / search / + -- top-anomalies. Fixtures drawn from the OS AD API reference. + -- ======================================================================= + describe "AnomalyDetection DeleteDetectorResponse JSON" $ do + it "decodes the bare ES delete-document envelope (NOT acknowledged)" $ do + let body = + "{\ + \ \"_index\": \".opensearch-anomaly-detectors\",\ + \ \"_id\": \"70TxTXwBwf_U8gjUXY2s\",\ + \ \"_version\": 2,\ + \ \"result\": \"deleted\",\ + \ \"forced_refresh\": true,\ + \ \"_shards\": {\"total\": 2, \"successful\": 2, \"skipped\": 0, \"failed\": 0},\ + \ \"_seq_no\": 9,\ + \ \"_primary_term\": 1\ + \}" + decoded = decode body :: Maybe OS1Types.DeleteDetectorResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.deleteDetectorResponseIndex r `shouldBe` ".opensearch-anomaly-detectors" + OS1Types.deleteDetectorResponseId r `shouldBe` "70TxTXwBwf_U8gjUXY2s" + OS1Types.deleteDetectorResponseResult r `shouldBe` "deleted" + OS1Types.deleteDetectorResponseForcedRefresh r `shouldBe` True + OS1Types.anomalyShardsFailed (OS1Types.deleteDetectorResponseShards r) `shouldBe` 0 + OS1Types.deleteDetectorResponseSeqNo r `shouldBe` 9 + + it "round-trips through encode -> decode" $ do + let decoded = decode "{ \"_index\":\"i\", \"_id\":\"x\", \"_version\":1, \"result\":\"deleted\", \"_shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0}, \"_seq_no\":0, \"_primary_term\":1}" :: Maybe OS1Types.DeleteDetectorResponse + Just r <- pure decoded + (decode . encode) r `shouldBe` Just r + + -- \| 'DeletedDocuments' is the response type of both @DELETE \/_delete_by_query@ + -- and the AD plugin's @DELETE \/_plugins\/_anomaly_detection\/detectors\/results@. + -- We pin the decoder here against the example body in the AD API reference + -- (), + -- so a future change to the shared 'DeletedDocuments' decoder that breaks + -- the AD contract surfaces in this spec. + describe "AnomalyDetection DeleteDetectorResults response (DeletedDocuments) JSON" $ do + it "decodes the _delete_by_query envelope from the AD docs example" $ do + let body = + "{\ + \ \"took\": 48,\ + \ \"timed_out\": false,\ + \ \"total\": 28,\ + \ \"updated\": 0,\ + \ \"created\": 0,\ + \ \"deleted\": 28,\ + \ \"batches\": 1,\ + \ \"version_conflicts\": 0,\ + \ \"noops\": 0,\ + \ \"retries\": {\ + \ \"bulk\": 0,\ + \ \"search\": 0\ + \ },\ + \ \"throttled_millis\": 0,\ + \ \"requests_per_second\": -1,\ + \ \"throttled_until_millis\": 0,\ + \ \"failures\": []\ + \}" + decoded = decode body :: Maybe OS1Types.DeletedDocuments + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.delDocsTook r `shouldBe` 48 + OS1Types.delDocsTimedOut r `shouldBe` False + OS1Types.delDocsTotal r `shouldBe` 28 + OS1Types.delDocsDeleted r `shouldBe` 28 + OS1Types.delDocsBatches r `shouldBe` 1 + OS1Types.delDocsVersionConflicts r `shouldBe` 0 + OS1Types.delDocsNoops r `shouldBe` 0 + OS1Types.delDocsRetriesBulk (OS1Types.delDocsRetries r) `shouldBe` 0 + OS1Types.delDocsRetriesSearch (OS1Types.delDocsRetries r) `shouldBe` 0 + OS1Types.delDocsThrottledMillis r `shouldBe` 0 + OS1Types.delDocsRequestsPerSecond r `shouldBe` -1.0 + OS1Types.delDocsThrottledUntilMillis r `shouldBe` 0 + OS1Types.delDocsFailures r `shouldBe` [] + -- The @updated@ / @created@ fields in the docs example are ignored by + -- the shared decoder (always 0 for a delete_by_query); the fields the + -- AD contract relies on are the ones asserted above. + + describe "AnomalyDetection ValidateDetectorResponse JSON" $ do + it "decodes the empty-object success body" $ do + let decoded = decode "{}" :: Maybe OS1Types.ValidateDetectorResponse + decoded `shouldSatisfy` isJust + it "decodes a detector-issue body losslessly as Value" $ do + let body = "{\"detector\":{\"feature_attributes\":{\"message\":\"bad\"}}}" + decoded = decode body :: Maybe OS1Types.ValidateDetectorResponse + decoded `shouldSatisfy` isJust + + describe "AnomalyDetection TopAnomalies JSON" $ do + it "round-trips a TopAnomaliesRequest omitting nulls" $ do + let req = + ( OS1Types.defaultTopAnomaliesRequest + 123456789000 + 987654321000 + ) + { OS1Types.topAnomaliesRequestSize = Just 3, + OS1Types.topAnomaliesRequestOrder = Just OS1Types.TopAnomaliesOrderSeverity + } + encoded = LBS.unpack (encode req) + encoded `shouldSatisfy` L.isInfixOf "\"start_time_ms\":123456789000" + encoded `shouldSatisfy` L.isInfixOf "\"end_time_ms\":987654321000" + encoded `shouldSatisfy` L.isInfixOf "\"order\":\"severity\"" + -- category_field / task_id are Nothing → omitted. + encoded `shouldNotSatisfy` L.isInfixOf "\"task_id\"" + (decode . encode) req `shouldBe` Just req + + it "decodes the documented top-anomalies response buckets" $ do + let body = + "{\ + \ \"buckets\": [\ + \ {\"key\": {\"ip\": \"1.2.3.4\"}, \"doc_count\": 10, \"max_anomaly_grade\": 0.8},\ + \ {\"key\": {\"ip\": \"5.6.7.8\"}, \"doc_count\": 12, \"max_anomaly_grade\": 0.6}\ + \ ]\ + \}" + decoded = decode body :: Maybe OS1Types.TopAnomaliesResponse + Just r <- pure decoded + length (OS1Types.topAnomaliesResponseBuckets r) `shouldBe` 2 + let first = head (OS1Types.topAnomaliesResponseBuckets r) + OS1Types.topAnomalyBucketDocCount first `shouldBe` 10 + OS1Types.topAnomalyBucketMaxAnomalyGrade first `shouldBe` 0.8 + + describe "AnomalyDetection SearchDetectorsResponse JSON" $ do + it "decodes a standard search envelope with a typed DetectorResponse _source" $ do + let body = + "{\ + \ \"took\": 5,\ + \ \"timed_out\": false,\ + \ \"_shards\": {\"total\": 1, \"successful\": 1, \"skipped\": 0, \"failed\": 0},\ + \ \"hits\": {\ + \ \"total\": {\"value\": 1, \"relation\": \"eq\"},\ + \ \"max_score\": 1.0,\ + \ \"hits\": [\ + \ {\ + \ \"_index\": \".opensearch-anomaly-detectors\",\ + \ \"_id\": \"det-1\",\ + \ \"_score\": 1.0,\ + \ \"_source\": {\ + \ \"name\": \"test-detector\",\ + \ \"time_field\": \"timestamp\",\ + \ \"detection_interval\": {\"period\": {\"interval\": 1, \"unit\": \"Minutes\"}}\ + \ }\ + \ }\ + \ ]\ + \ }\ + \}" + decoded = decode body :: Maybe OS1Types.SearchDetectorsResponse + Just r <- pure decoded + OS1Types.anomalySearchResponseTook r `shouldBe` 5 + OS1Types.anomalySearchTotalValue (OS1Types.anomalySearchResponseTotal r) `shouldBe` 1 + length (OS1Types.anomalySearchResponseHits r) `shouldBe` 1 + let onlySource = head (OS1Types.anomalySearchResponseSources r) + OS1Types.detectorResponseName onlySource `shouldBe` "test-detector" + + -- ======================================================================= + -- Endpoint shape: verify the new AD lifecycle endpoints hit the + -- documented method/path across OS1/OS2/OS3 (the three backends are + -- wire-compatible mirrors — see the ISM mirror convention). + -- ======================================================================= + describe "AnomalyDetection lifecycle endpoint shape" $ do + let did1 = OS1Types.DetectorId "d1" + did2 = OS2Types.DetectorId "d2" + did3 = OS3Types.DetectorId "d3" + + it "deleteDetector DELETEs /_plugins/_anomaly_detection/detectors/{id} with no body" $ do + bhRequestMethod (OS1Requests.deleteDetector did1) `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint (OS1Requests.deleteDetector did1)) + `shouldBe` ["_plugins", "_anomaly_detection", "detectors", "d1"] + bhRequestBody (OS1Requests.deleteDetector did1) `shouldBe` Nothing + + it "updateDetector PUTs /detectors/{id} with the encoded body" $ do + bhRequestMethod (OS1Requests.updateDetector did1 os1SampleDetector) `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint (OS1Requests.updateDetector did1 os1SampleDetector)) + `shouldBe` ["_plugins", "_anomaly_detection", "detectors", "d1"] + getRawEndpointQueries (bhRequestEndpoint (OS1Requests.updateDetector did1 os1SampleDetector)) + `shouldBe` [] + + it "updateDetectorWith emits if_seq_no / if_primary_term query params" $ do + let req = OS1Requests.updateDetectorWith did1 os1SampleDetector (Just (7, 4)) + L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [("if_primary_term", Just "4"), ("if_seq_no", Just "7")] + + it "startDetector POSTs /detectors/{id}/_start; empty body for real-time" $ do + bhRequestMethod (OS1Requests.startDetector did1 Nothing) `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint (OS1Requests.startDetector did1 Nothing)) + `shouldBe` ["_plugins", "_anomaly_detection", "detectors", "d1", "_start"] + bhRequestBody (OS1Requests.startDetector did1 Nothing) `shouldBe` Just "" + + it "stopDetector POSTs /detectors/{id}/_stop; adds ?historical=true when historical" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.stopDetector did1 False)) + `shouldBe` ["_plugins", "_anomaly_detection", "detectors", "d1", "_stop"] + getRawEndpointQueries (bhRequestEndpoint (OS1Requests.stopDetector did1 False)) `shouldBe` [] + getRawEndpointQueries (bhRequestEndpoint (OS1Requests.stopDetector did1 True)) + `shouldBe` [("historical", Just "true")] + + it "validateDetector POSTs /detectors/_validate (detector) or /_validate/model" $ do + getRawEndpoint (bhRequestEndpoint (OS1Requests.validateDetector OS1Types.ValidateDetector os1SampleDetector)) + `shouldBe` ["_plugins", "_anomaly_detection", "detectors", "_validate"] + getRawEndpoint (bhRequestEndpoint (OS1Requests.validateDetector OS1Types.ValidateModel os1SampleDetector)) + `shouldBe` ["_plugins", "_anomaly_detection", "detectors", "_validate", "model"] + + it "topAnomalies GETs /detectors/{id}/results/_topAnomalies with ?historical=" $ do + let treq = OS1Types.defaultTopAnomaliesRequest 1 2 + bhRequestMethod (OS1Requests.topAnomalies did1 False treq) `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint (OS1Requests.topAnomalies did1 False treq)) + `shouldBe` ["_plugins", "_anomaly_detection", "detectors", "d1", "results", "_topAnomalies"] + getRawEndpointQueries (bhRequestEndpoint (OS1Requests.topAnomalies did1 True treq)) + `shouldBe` [("historical", Just "true")] + + it "deleteDetector: OS1, OS2, OS3 produce the same path and method" $ do + let same = "same-id" + one = OS1Types.DetectorId same + two = OS2Types.DetectorId same + three = OS3Types.DetectorId same + getRawEndpoint (bhRequestEndpoint (OS1Requests.deleteDetector one)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteDetector two)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteDetector two)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteDetector three)) + bhRequestMethod (OS1Requests.deleteDetector one) + `shouldBe` bhRequestMethod (OS3Requests.deleteDetector three) + + it "deleteDetectorResults DELETEs /_plugins/_anomaly_detection/detectors/results with the encoded body" $ do + let q = object ["query" .= object ["match_all" .= object []]] + req = OS1Requests.deleteDetectorResults q + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_anomaly_detection", "detectors", "results"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + -- The body is the aeson-encoded query DSL, not defaulted to {}. + decode (maybe "" id (bhRequestBody req)) + `shouldBe` Just q + + it "deleteDetectorResults: OS1, OS2, OS3 produce the same path, method and body" $ do + let q = object ["query" .= object ["term" .= object ["detector_id" .= object ["value" .= String "dX"]]]] + one = OS1Requests.deleteDetectorResults q + two = OS2Requests.deleteDetectorResults q + three = OS3Requests.deleteDetectorResults q + getRawEndpoint (bhRequestEndpoint one) + `shouldBe` getRawEndpoint (bhRequestEndpoint two) + getRawEndpoint (bhRequestEndpoint two) + `shouldBe` getRawEndpoint (bhRequestEndpoint three) + bhRequestMethod one `shouldBe` bhRequestMethod three + bhRequestBody one `shouldBe` bhRequestBody three + + it "startDetector / stopDetector: OS1, OS2, OS3 produce the same path and method" $ do + let one = OS1Types.DetectorId "x" + two = OS2Types.DetectorId "x" + three = OS3Types.DetectorId "x" + getRawEndpoint (bhRequestEndpoint (OS1Requests.startDetector one Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.startDetector two Nothing)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.startDetector two Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.startDetector three Nothing)) + bhRequestMethod (OS1Requests.stopDetector one False) + `shouldBe` bhRequestMethod (OS3Requests.stopDetector three False) + + it "previewDetectorInline POSTs /detectors/_preview (no id in path)" $ do + let req = OS1Requests.previewDetectorInline (OS1Types.PreviewRequest 1 2 Nothing Nothing) + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_anomaly_detection", "detectors", "_preview"] + + it "profileDetector: Nothing emits a bodyless GET (backward compat)" $ do + let req = OS1Requests.profileDetector did1 [] False Nothing + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_anomaly_detection", "detectors", "d1", "_profile"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "profileDetector: Just entities emits {\"entity\":[...]} as a GET-with-body" $ do + let entities = [OS1Types.Entity {OS1Types.entityName = "host", OS1Types.entityValue = "i-00f"}] + req = OS1Requests.profileDetector did1 [] False (Just entities) + bhRequestMethod req `shouldBe` "GET" + -- No ?_all when allFlag is False; the entity filter is the only extra. + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + -- The body is the documented {"entity":[{"name":...,"value":...}]}. + let Just body = bhRequestBody req + decode body + `shouldBe` Just + ( object + [ "entity" + .= [ object ["name" .= ("host" :: T.Text), "value" .= ("i-00f" :: T.Text)] + ] + ] + ) + + it "profileDetector: OS1, OS2, OS3 produce the same path, method and entity body" $ do + let one = OS1Requests.profileDetector (OS1Types.DetectorId "d") [] False (Just [OS1Types.Entity "host" "x"]) + two = OS2Requests.profileDetector (OS2Types.DetectorId "d") [] False (Just [OS2Types.Entity "host" "x"]) + three = OS3Requests.profileDetector (OS3Types.DetectorId "d") [] False (Just [OS3Types.Entity "host" "x"]) + getRawEndpoint (bhRequestEndpoint one) + `shouldBe` getRawEndpoint (bhRequestEndpoint two) + getRawEndpoint (bhRequestEndpoint two) + `shouldBe` getRawEndpoint (bhRequestEndpoint three) + bhRequestMethod one `shouldBe` bhRequestMethod three + bhRequestBody one `shouldBe` bhRequestBody three + + -- ======================================================================= + -- Live integration: create → get → preview → run round-trip, gated per + -- OS major version. The AD plugin ships with OS 1.0+. Each backend has + -- its own Client/Types module (twin types), so we write one test per + -- backend, gated via osNOnlyIT. A timestamp-suffixed name avoids + -- collisions across runs; bracket_ guarantees the index is torn down + -- even on assertion failure. + -- ======================================================================= + describe "AnomalyDetection plugin live round-trip" $ do + os1It <- runIO os1OnlyIT + os1It "create -> get -> preview -> start -> stop (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let indexNameText = T.pack ("bloodhound_test_ad_index_os1_" <> suffix) + detectorNameText = T.pack ("bloodhound_test_ad_det_os1_" <> suffix) + let Right indexName = mkIndexName indexNameText + bracket_ + (adSetupIndex indexName) + (void $ performBHRequest $ deleteIndex indexName) + $ do + let detector = + OS1Types.Detector + { OS1Types.detectorName = detectorNameText, + OS1Types.detectorDescription = Just "bloodhound live test", + OS1Types.detectorTimeField = "timestamp", + OS1Types.detectorIndices = [indexNameText], + OS1Types.detectorFeatureAttributes = + [ OS1Types.FeatureAttribute + { OS1Types.featureAttributeId = Nothing, + OS1Types.featureAttributeName = "value", + OS1Types.featureAttributeEnabled = True, + OS1Types.featureAttributeAggregationQuery = + object ["value" .= object ["avg" .= object ["field" .= String "value"]]] + } + ], + OS1Types.detectorFilterQuery = Nothing, + OS1Types.detectorDetectionInterval = + OS1Types.WindowPeriod + { OS1Types.windowPeriodPeriod = + OS1Types.Period + { OS1Types.periodInterval = 1, + OS1Types.periodUnit = OS1Types.PeriodUnitMinutes + } + }, + OS1Types.detectorWindowDelay = Nothing, + OS1Types.detectorCategoryField = Nothing, + OS1Types.detectorResultIndex = Nothing + } + createResp <- OS1Client.createDetector detector + case createResp of + Left e -> + liftIO $ + expectationFailure + ("createDetector failed: " <> T.unpack (errorMessage e)) + Right r -> do + let detectorId = OS1Types.DetectorId (OS1Types.createDetectorResponseId r) + getResp <- OS1Client.getDetector detectorId OS1Types.defaultGetDetectorParams + liftIO $ + case getResp of + Left e -> + expectationFailure + ("getDetector failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + nowMs <- liftIO $ round . (* 1000) <$> getPOSIXTime :: BH IO Integer + let previewReq = OS1Types.PreviewRequest (nowMs - 600000) nowMs Nothing Nothing + previewResp <- OS1Client.previewDetector detectorId previewReq + liftIO $ + case previewResp of + Left e -> + expectationFailure + ("previewDetector failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + startResp <- OS1Client.startDetector detectorId Nothing + liftIO $ + case startResp of + Left e -> + expectationFailure + ("startDetector failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + stopResp <- stopDetectorWithRetry (OS1Client.stopDetector detectorId False) + liftIO $ + case stopResp of + Left e -> + expectationFailure + ("stopDetector failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + -- Lifecycle: update (no job running yet) -> start -> stop -> delete. + updateResp <- OS1Client.updateDetector detectorId detector + liftIO $ expectationFailureOnLeft updateResp "updateDetector failed:" + startResp <- OS1Client.startDetector detectorId Nothing + liftIO $ expectationFailureOnLeft startResp "startDetector failed:" + stopResp <- stopDetectorWithRetry (OS1Client.stopDetector detectorId False) + liftIO $ expectationFailureOnLeft stopResp "stopDetector failed:" + delResp <- deleteDetectorWithRetry (OS1Client.deleteDetector detectorId) + liftIO $ expectationFailureOnLeft delResp "deleteDetector failed:" + + os2It <- runIO os2OnlyIT + os2It "create -> get -> preview -> start -> stop (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let indexNameText = T.pack ("bloodhound_test_ad_index_os2_" <> suffix) + detectorNameText = T.pack ("bloodhound_test_ad_det_os2_" <> suffix) + let Right indexName = mkIndexName indexNameText + bracket_ + (adSetupIndex indexName) + (void $ performBHRequest $ deleteIndex indexName) + $ do + let detector = + OS2Types.Detector + { OS2Types.detectorName = detectorNameText, + OS2Types.detectorDescription = Just "bloodhound live test", + OS2Types.detectorTimeField = "timestamp", + OS2Types.detectorIndices = [indexNameText], + OS2Types.detectorFeatureAttributes = + [ OS2Types.FeatureAttribute + { OS2Types.featureAttributeId = Nothing, + OS2Types.featureAttributeName = "value", + OS2Types.featureAttributeEnabled = True, + OS2Types.featureAttributeAggregationQuery = + object ["value" .= object ["avg" .= object ["field" .= String "value"]]] + } + ], + OS2Types.detectorFilterQuery = Nothing, + OS2Types.detectorDetectionInterval = + OS2Types.WindowPeriod + { OS2Types.windowPeriodPeriod = + OS2Types.Period + { OS2Types.periodInterval = 1, + OS2Types.periodUnit = OS2Types.PeriodUnitMinutes + } + }, + OS2Types.detectorWindowDelay = Nothing, + OS2Types.detectorCategoryField = Nothing, + OS2Types.detectorResultIndex = Nothing + } + createResp <- OS2Client.createDetector detector + case createResp of + Left e -> + liftIO $ + expectationFailure + ("createDetector failed: " <> T.unpack (errorMessage e)) + Right r -> do + let detectorId = OS2Types.DetectorId (OS2Types.createDetectorResponseId r) + getResp <- OS2Client.getDetector detectorId OS2Types.defaultGetDetectorParams + liftIO $ + case getResp of + Left e -> + expectationFailure + ("getDetector failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + nowMs <- liftIO $ round . (* 1000) <$> getPOSIXTime :: BH IO Integer + let previewReq = OS2Types.PreviewRequest (nowMs - 600000) nowMs Nothing Nothing + previewResp <- OS2Client.previewDetector detectorId previewReq + liftIO $ + case previewResp of + Left e -> + expectationFailure + ("previewDetector failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + startResp <- OS2Client.startDetector detectorId Nothing + liftIO $ + case startResp of + Left e -> + expectationFailure + ("startDetector failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + stopResp <- stopDetectorWithRetry (OS2Client.stopDetector detectorId False) + liftIO $ + case stopResp of + Left e -> + expectationFailure + ("stopDetector failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + -- Lifecycle: update (no job running yet) -> start -> stop -> delete. + updateResp <- OS2Client.updateDetector detectorId detector + liftIO $ expectationFailureOnLeft updateResp "updateDetector failed:" + startResp <- OS2Client.startDetector detectorId Nothing + liftIO $ expectationFailureOnLeft startResp "startDetector failed:" + stopResp <- stopDetectorWithRetry (OS2Client.stopDetector detectorId False) + liftIO $ expectationFailureOnLeft stopResp "stopDetector failed:" + delResp <- deleteDetectorWithRetry (OS2Client.deleteDetector detectorId) + liftIO $ expectationFailureOnLeft delResp "deleteDetector failed:" + + os3It <- runIO os3OnlyIT + os3It "create -> get -> preview -> start -> stop (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let indexNameText = T.pack ("bloodhound_test_ad_index_os3_" <> suffix) + detectorNameText = T.pack ("bloodhound_test_ad_det_os3_" <> suffix) + let Right indexName = mkIndexName indexNameText + bracket_ + (adSetupIndex indexName) + (void $ performBHRequest $ deleteIndex indexName) + $ do + let detector = + OS3Types.Detector + { OS3Types.detectorName = detectorNameText, + OS3Types.detectorDescription = Just "bloodhound live test", + OS3Types.detectorTimeField = "timestamp", + OS3Types.detectorIndices = [indexNameText], + OS3Types.detectorFeatureAttributes = + [ OS3Types.FeatureAttribute + { OS3Types.featureAttributeId = Nothing, + OS3Types.featureAttributeName = "value", + OS3Types.featureAttributeEnabled = True, + OS3Types.featureAttributeAggregationQuery = + object ["value" .= object ["avg" .= object ["field" .= String "value"]]] + } + ], + OS3Types.detectorFilterQuery = Nothing, + OS3Types.detectorDetectionInterval = + OS3Types.WindowPeriod + { OS3Types.windowPeriodPeriod = + OS3Types.Period + { OS3Types.periodInterval = 1, + OS3Types.periodUnit = OS3Types.PeriodUnitMinutes + } + }, + OS3Types.detectorWindowDelay = Nothing, + OS3Types.detectorCategoryField = Nothing, + OS3Types.detectorResultIndex = Nothing + } + createResp <- OS3Client.createDetector detector + case createResp of + Left e -> + liftIO $ + expectationFailure + ("createDetector failed: " <> T.unpack (errorMessage e)) + Right r -> do + let detectorId = OS3Types.DetectorId (OS3Types.createDetectorResponseId r) + getResp <- OS3Client.getDetector detectorId OS3Types.defaultGetDetectorParams + liftIO $ + case getResp of + Left e -> + expectationFailure + ("getDetector failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + nowMs <- liftIO $ round . (* 1000) <$> getPOSIXTime :: BH IO Integer + let previewReq = OS3Types.PreviewRequest (nowMs - 600000) nowMs Nothing Nothing + previewResp <- OS3Client.previewDetector detectorId previewReq + liftIO $ + case previewResp of + Left e -> + expectationFailure + ("previewDetector failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + startResp <- OS3Client.startDetector detectorId Nothing + liftIO $ + case startResp of + Left e -> + expectationFailure + ("startDetector failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + stopResp <- stopDetectorWithRetry (OS3Client.stopDetector detectorId False) + liftIO $ + case stopResp of + Left e -> + expectationFailure + ("stopDetector failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + -- Lifecycle: update (no job running yet) -> start -> stop -> delete. + updateResp <- OS3Client.updateDetector detectorId detector + liftIO $ expectationFailureOnLeft updateResp "updateDetector failed:" + startResp <- OS3Client.startDetector detectorId Nothing + liftIO $ expectationFailureOnLeft startResp "startDetector failed:" + stopResp <- stopDetectorWithRetry (OS3Client.stopDetector detectorId False) + liftIO $ expectationFailureOnLeft stopResp "stopDetector failed:" + delResp <- deleteDetectorWithRetry (OS3Client.deleteDetector detectorId) + liftIO $ expectationFailureOnLeft delResp "deleteDetector failed:" + +-- | Create the target index, seed it with one document, and refresh. +-- The AD plugin refuses to create a detector on an empty index +-- (@Can't create anomaly detector as no document is found in the +-- indices: [...]@), and requires @time_field@ to be mapped as a date. +-- We send @timestamp@ as an ISO-8601 string so the cluster auto-maps it +-- to @date@ on first insert — no explicit mapping PUT needed. +adSetupIndex :: IndexName -> BH IO () +adSetupIndex indexName = do + _ <- + performBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + indexName + nowMs <- liftIO $ round . (* 1000) <$> getPOSIXTime :: BH IO Integer + let ts = nowMs - 60000 + -- ES auto-detects ISO-8601 strings as @date@. + iso = T.pack (iso8601FromEpochMs ts) + _ <- + performBHRequest $ + indexDocument + indexName + defaultIndexDocumentSettings + (object ["timestamp" .= String iso, "value" .= Number 1]) + (DocId "1") + _ <- performBHRequest $ refreshIndex indexName + pure () + +-- | Render epoch-ms as an ISO-8601 UTC string. The cluster's date parser +-- accepts this format out of the box, so the @timestamp@ field auto-maps +-- to @date@ on first insert (no explicit PUT _mapping needed). +iso8601FromEpochMs :: Integer -> String +iso8601FromEpochMs ms = + let secs = ms `div` 1000 + -- Build the components manually to avoid pulling in time-formatting + -- deps beyond what the test already uses. + UTCTime day secsOfDay = posixSecondsToUTCTime (fromIntegral secs) + (y, m, d) = toGregorian day + TimeOfDay hh mm ss = timeToTimeOfDay secsOfDay + pad2 n = let s = show n in if length s == 1 then "0" <> s else s + pad4 n = let s = show n in replicate (max 0 (4 - length s)) '0' <> s + in pad4 (fromIntegral y) + <> "-" + <> pad2 m + <> "-" + <> pad2 d + <> "T" + <> pad2 hh + <> ":" + <> pad2 mm + <> ":" + <> pad2 (floor @Pico ss) + <> "Z" + +-- | Fail the test (with a prefix and the cluster error message) when a +-- 'ParsedEsResponse' is 'Left'. Used by the AD live lifecycle assertions +-- so each new endpoint gets a uniform non-Left assertion. +expectationFailureOnLeft :: Either EsError a -> String -> IO () +expectationFailureOnLeft r prefix = + case r of + Left e -> expectationFailure (prefix <> " " <> T.unpack (errorMessage e)) + Right _ -> pure () + +-- | Tolerate the Anomaly Detection plugin's start\/stop race: +-- 'startDetector' returns as soon as it acknowledges the start, but the +-- real-time job is registered asynchronously in the +-- @.opendistro-anomaly-detector-jobs@ index, so an immediate +-- 'stopDetector' can transiently receive "Fail to stop detector" from the +-- server. Retry only that specific error, bounded so a genuine failure +-- still surfaces. Mirrors the 'waitFor' idiom in "Test.CCRSpec". +stopDetectorWithRetry :: + (MonadIO m) => + m (Either EsError a) -> + m (Either EsError a) +stopDetectorWithRetry stop = go (0 :: Int) + where + go n = do + r <- stop + case r of + Left e + | "Fail to stop detector" `T.isInfixOf` errorMessage e && n < 10 -> + liftIO (threadDelay 1000000) >> go (n + 1) + _ -> pure r + +-- | Tolerate the Anomaly Detection plugin's stop\/delete race: +-- 'stopDetector' returns as soon as it acknowledges the stop, but the +-- real-time job document is removed from +-- @.opendistro-anomaly-detector-jobs@ asynchronously, so an immediate +-- 'deleteDetector' can transiently receive "Failed to delete all tasks" +-- from the server (observed on OpenSearch 3.7.0). Retry only that +-- specific error, bounded so a genuine failure still surfaces. Mirrors +-- 'stopDetectorWithRetry'. +deleteDetectorWithRetry :: + (MonadIO m) => + m (Either EsError a) -> + m (Either EsError a) +deleteDetectorWithRetry del = go (0 :: Int) + where + go n = do + r <- del + case r of + Left e + | "Failed to delete all tasks" `T.isInfixOf` errorMessage e && n < 15 -> + liftIO (threadDelay 1000000) >> go (n + 1) + _ -> pure r diff --git a/tests/Test/AsyncSearchSpec.hs b/tests/Test/AsyncSearchSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/AsyncSearchSpec.hs @@ -0,0 +1,528 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.AsyncSearchSpec (spec) where + +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List (sort) +import Data.Map.Strict qualified as M +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- | Fixture mimicking a still-running async search (no @id@ yet, no +-- @took@\/@_shards@\/@hits@). Adapted from the example at +-- . +sampleRunningResponse :: LBS.ByteString +sampleRunningResponse = + "{\ + \ \"is_running\": true,\ + \ \"is_partial\": true,\ + \ \"start_time_in_millis\": 1584726301000,\ + \ \"expiration_time_in_millis\": 1584812701000\ + \}" + +-- | Fixture mimicking a completed async search: full @hits@, @took@, +-- @_shards@, an @id@ for polling, and a single-bucket @aggregations@ block. +-- The @hit._source@ values are typed as 'Value' so the test does not need a +-- domain model. +sampleCompletedResponse :: LBS.ByteString +sampleCompletedResponse = + "{\ + \ \"id\": \"FmRleEctRXJtaVNZQ1I2UkJoTDJfQkEAAAAAAAAUX0Q2UkRLNEVBYlhVZ19VUUZmeld3ZwAAAAAAAAAUX0Q2UkRLNEVBYlhVZ19VUUZmeld3Zw==\",\ + \ \"is_running\": false,\ + \ \"is_partial\": false,\ + \ \"start_time_in_millis\": 1584726301000,\ + \ \"expiration_time_in_millis\": 1584812701000,\ + \ \"took\": 5,\ + \ \"timed_out\": false,\ + \ \"num_reduce_phases\": 1,\ + \ \"_shards\": {\"total\": 1, \"successful\": 1, \"skipped\": 0, \"failed\": 0},\ + \ \"hits\": {\ + \ \"total\": {\"value\": 2, \"relation\": \"eq\"},\ + \ \"max_score\": 1.0,\ + \ \"hits\": [\ + \ {\"_index\": \"my-index-000001\", \"_id\": \"1\", \"_score\": 1.0, \"_source\": {\"user\": \"bob\"}},\ + \ {\"_index\": \"my-index-000001\", \"_id\": \"2\", \"_score\": 1.0, \"_source\": {\"user\": \"ana\"}}\ + \ ]\ + \ },\ + \ \"aggregations\": {\"by_user\": {\"doc_count_error_upper_bound\": 0, \"sum_other_doc_count\": 0, \"buckets\": []}}\ + \}" + +-- | Fixture mimicking the body returned by Elasticsearch 8.x\/9.x (and +-- modern 7.x patches) once the async search has completed: the search +-- payload (@took@, @_shards@, @hits@, @aggregations@, ...) is nested +-- under a top-level @response@ object, and the scheduling fields +-- (@id@, @is_running@, ...) plus @completion_time_in_millis@ sit at the +-- top level. Same data as 'sampleCompletedResponse' so the two shapes are +-- directly comparable. OpenSearch returns the flat shape instead. +sampleCompletedResponseNested :: LBS.ByteString +sampleCompletedResponseNested = + "{\ + \ \"id\": \"FmRleEctRXJtaVNZQ1I2UkJoTDJfQkEAAAAAAAAUX0Q2UkRLNEVBYlhVZ19VUUZmeld3ZwAAAAAAAAAUX0Q2UkRLNEVBYlhVZ19VUUZmeld3Zw==\",\ + \ \"is_running\": false,\ + \ \"is_partial\": false,\ + \ \"start_time_in_millis\": 1584726301000,\ + \ \"expiration_time_in_millis\": 1584812701000,\ + \ \"completion_time_in_millis\": 1584726302000,\ + \ \"response\": {\ + \ \"took\": 5,\ + \ \"timed_out\": false,\ + \ \"num_reduce_phases\": 1,\ + \ \"_shards\": {\"total\": 1, \"successful\": 1, \"skipped\": 0, \"failed\": 0},\ + \ \"hits\": {\ + \ \"total\": {\"value\": 2, \"relation\": \"eq\"},\ + \ \"max_score\": 1.0,\ + \ \"hits\": [\ + \ {\"_index\": \"my-index-000001\", \"_id\": \"1\", \"_score\": 1.0, \"_source\": {\"user\": \"bob\"}},\ + \ {\"_index\": \"my-index-000001\", \"_id\": \"2\", \"_score\": 1.0, \"_source\": {\"user\": \"ana\"}}\ + \ ]\ + \ },\ + \ \"aggregations\": {\"by_user\": {\"doc_count_error_upper_bound\": 0, \"sum_other_doc_count\": 0, \"buckets\": []}}\ + \ }\ + \}" + +-- | Fixture mimicking the body returned by @GET /_async_search/status/{id}@ +-- while the search is still running: only the running\/partial flags and +-- the two scheduling timestamps, no @id@, @took@, @_shards@, @hits@ or +-- @aggregations@. Adapted from +-- . +sampleRunningStatusResponse :: LBS.ByteString +sampleRunningStatusResponse = + "{\ + \ \"is_running\": true,\ + \ \"is_partial\": true,\ + \ \"start_time_in_millis\": 1584726301000,\ + \ \"expiration_time_in_millis\": 1584812701000\ + \}" + +-- | Fixture mimicking the status body once the async search has completed. +sampleCompletedStatusResponse :: LBS.ByteString +sampleCompletedStatusResponse = + "{\ + \ \"is_running\": false,\ + \ \"is_partial\": false,\ + \ \"start_time_in_millis\": 1584726301000,\ + \ \"expiration_time_in_millis\": 1584812701000,\ + \ \"completion_status\": 200\ + \}" + +-- | Fixture mimicking the status body once the async search has completed, +-- including the @completion_time_in_millis@ timestamp the server stamps on +-- completion (alongside @completion_status@). +sampleCompletedStatusResponseWithCompletionTime :: LBS.ByteString +sampleCompletedStatusResponseWithCompletionTime = + "{\ + \ \"is_running\": false,\ + \ \"is_partial\": false,\ + \ \"start_time_in_millis\": 1584726301000,\ + \ \"expiration_time_in_millis\": 1584812701000,\ + \ \"completion_time_in_millis\": 1584726302000,\ + \ \"completion_status\": 200\ + \}" + +spec :: Spec +spec = describe "Async Search API" $ do + describe "deleteAsyncSearch endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "DELETEs /_async_search/{id} when given an AsyncSearchId" $ do + let req = Common.deleteAsyncSearch (AsyncSearchId "FmRleEct") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_async_search", "FmRleEct"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "does not attach a body (DELETE semantics)" $ do + let req = Common.deleteAsyncSearch (AsyncSearchId "FmRleEct") + bhRequestBody req `shouldBe` Nothing + + it "uses a distinct id in the path when given a different AsyncSearchId" $ do + let req = Common.deleteAsyncSearch (AsyncSearchId "other-id") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_async_search", "other-id"] + + describe "getAsyncSearch endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "GETs /_async_search/{id} when given an AsyncSearchId" $ do + let req = Common.getAsyncSearch @Value (AsyncSearchId "FmRleEct") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_async_search", "FmRleEct"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses GET and attaches no body" $ do + let req = Common.getAsyncSearch @Value (AsyncSearchId "FmRleEct") + bhRequestMethod req `shouldBe` "GET" + bhRequestBody req `shouldBe` Nothing + + it "keeps the id as a single opaque path segment" $ do + let req = Common.getAsyncSearch @Value (AsyncSearchId "Fm_==_RxD_123") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_async_search", "Fm_==_RxD_123"] + + describe "getAsyncSearchStatus endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "GETs /_async_search/status/{id} when given an AsyncSearchId" $ do + let req = Common.getAsyncSearchStatus (AsyncSearchId "FmRleEct") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_async_search", "status", "FmRleEct"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses GET and attaches no body" $ do + let req = Common.getAsyncSearchStatus (AsyncSearchId "FmRleEct") + bhRequestMethod req `shouldBe` "GET" + bhRequestBody req `shouldBe` Nothing + + it "uses a distinct id in the path when given a different AsyncSearchId" $ do + let req = Common.getAsyncSearchStatus (AsyncSearchId "other-id") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_async_search", "status", "other-id"] + + it "keeps the id as a single opaque path segment" $ do + let req = Common.getAsyncSearchStatus (AsyncSearchId "Fm_==_RxD_123") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_async_search", "status", "Fm_==_RxD_123"] + + describe "getAsyncSearchStatus (live)" $ do + it' <- runIO esOnlyIT + it' "surfaces a server error for a non-existent async search id" $ + withTestEnv $ do + -- ES rejects malformed ids with 400 (it validates the id format) + -- rather than 404, so we only assert that an EsError is surfaced + -- and no bogus status is returned. + result <- + tryEsError + ( performBHRequest $ + Common.getAsyncSearchStatus + (AsyncSearchId "bloodhound-no-such-async-search-04f-5-1-3") + ) + case result of + Left _err -> pure () + Right r -> + liftIO $ + expectationFailure $ + "expected EsError for missing async search, got: " <> show r + + describe "AsyncSearchStatus JSON" $ do + it "decodes a running status body (no timing fields omitted here)" $ do + let Just (decoded :: AsyncSearchStatus) = decode sampleRunningStatusResponse + asyncSearchStatusIsRunning decoded `shouldBe` True + asyncSearchStatusIsPartial decoded `shouldBe` True + asyncSearchStatusStartTimeInMillis decoded `shouldBe` Just 1584726301000 + asyncSearchStatusExpirationTimeInMillis decoded `shouldBe` Just 1584812701000 + -- A still-running search has not produced an HTTP completion code, + -- so completion_status is omitted by the server and decodes to Nothing. + asyncSearchStatusCompletionStatus decoded `shouldBe` Nothing + + it "decodes a completed status body" $ do + let Just (decoded :: AsyncSearchStatus) = decode sampleCompletedStatusResponse + asyncSearchStatusIsRunning decoded `shouldBe` False + asyncSearchStatusIsPartial decoded `shouldBe` False + asyncSearchStatusCompletionStatus decoded `shouldBe` Just 200 + -- This fixture omits completion_time_in_millis, so the new field + -- decodes to Nothing (the field appears only on completion). + asyncSearchStatusCompletionTimeInMillis decoded `shouldBe` Nothing + + it "decodes a non-2xx completion_status (search finished with an error)" $ do + -- completion_status is a plain HTTP code, so a failed-completion + -- body surfaces e.g. 404 verbatim rather than collapsing to Nothing. + let body = + "{\ + \ \"is_running\": false,\ + \ \"is_partial\": false,\ + \ \"completion_status\": 404\ + \}" + Just (decoded :: AsyncSearchStatus) = decode body + asyncSearchStatusCompletionStatus decoded `shouldBe` Just 404 + + it "decodes an empty {} response with the documented defaults" $ do + -- is_running defaults to False and is_partial to True, mirroring the + -- AsyncSearchResult FromJSON. The two timing fields and the + -- completion_status field (only present once the search completes, + -- since ES 7.13) all stay at Nothing. + let Just (decoded :: AsyncSearchStatus) = decode "{}" + asyncSearchStatusIsRunning decoded `shouldBe` False + asyncSearchStatusIsPartial decoded `shouldBe` True + asyncSearchStatusStartTimeInMillis decoded `shouldBe` Nothing + asyncSearchStatusExpirationTimeInMillis decoded `shouldBe` Nothing + asyncSearchStatusCompletionStatus decoded `shouldBe` Nothing + + it "tolerates unknown extra fields in the body" $ do + let Just (decoded :: AsyncSearchStatus) = + decode "{ \"is_running\": true, \"future_field\": \"whatever\" }" + asyncSearchStatusIsRunning decoded `shouldBe` True + + describe "getAsyncSearch (live)" $ do + it' <- runIO esOnlyIT + it' "surfaces a server error for a non-existent async search id" $ + withTestEnv $ do + -- ES rejects malformed ids with 400 (it validates the id format) + -- rather than 404, so we only assert that an EsError is surfaced + -- and no bogus result is returned. + result <- + tryEsError + ( performBHRequest $ + Common.getAsyncSearch @Value + (AsyncSearchId "bloodhound-no-such-async-search-04f-5-1-2") + ) + case result of + Left _err -> pure () + Right r -> + liftIO $ + expectationFailure $ + "expected EsError for missing async search, got: " <> show r + + describe "submitAsyncSearch endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "POSTs to /_async_search with no query string" $ do + let search = mkSearch (Just (MatchAllQuery Nothing)) Nothing + req = Common.submitAsyncSearch @Value search + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_async_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches the encoded Search as the JSON body" $ do + let search = mkSearch (Just (MatchAllQuery Nothing)) Nothing + req = Common.submitAsyncSearch @Value search + bhRequestBody req `shouldBe` Just (encode search) + + it "tracks the input Search: a different query yields a different body" $ do + let reqA = Common.submitAsyncSearch @Value (mkSearch (Just (MatchAllQuery Nothing)) Nothing) + reqB = Common.submitAsyncSearch @Value (mkSearch (Just (TermQuery (Term "user" "bob") Nothing)) Nothing) + bhRequestBody reqA `shouldNotBe` bhRequestBody reqB + + describe "submitAsyncSearchWith URI parameters" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + -- The order of query parameters is unspecified (see the + -- 'asyncSearchSubmitOptionsParams' docs), so any test asserting more + -- than one parameter sorts both sides before comparing. + let search = mkSearch (Just (MatchAllQuery Nothing)) Nothing + + it "defaultAsyncSearchSubmitOptions emits no params" $ do + let req = Common.submitAsyncSearchWith @Value defaultAsyncSearchSubmitOptions search + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "defaultAsyncSearchSubmitOptions is byte-identical to submitAsyncSearch" $ do + let reqPlain = Common.submitAsyncSearch @Value search + reqDef = Common.submitAsyncSearchWith @Value defaultAsyncSearchSubmitOptions search + bhRequestMethod reqPlain `shouldBe` bhRequestMethod reqDef + getRawEndpoint (bhRequestEndpoint reqPlain) `shouldBe` getRawEndpoint (bhRequestEndpoint reqDef) + getRawEndpointQueries (bhRequestEndpoint reqPlain) `shouldBe` getRawEndpointQueries (bhRequestEndpoint reqDef) + bhRequestBody reqPlain `shouldBe` bhRequestBody reqDef + + it "forwards wait_for_completion=true" $ do + let opts = defaultAsyncSearchSubmitOptions {assoWaitForCompletion = Just True} + req = Common.submitAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("wait_for_completion", Just "true")] + + it "forwards wait_for_completion=false" $ do + let opts = defaultAsyncSearchSubmitOptions {assoWaitForCompletion = Just False} + req = Common.submitAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("wait_for_completion", Just "false")] + + it "forwards keep_on_completion=true" $ do + let opts = defaultAsyncSearchSubmitOptions {assoKeepOnCompletion = Just True} + req = Common.submitAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("keep_on_completion", Just "true")] + + it "forwards keep_alive as the KeepAlive wire format" $ do + let opts = defaultAsyncSearchSubmitOptions {assoKeepAlive = Just (keepAliveDays 5)} + req = Common.submitAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("keep_alive", Just "5d")] + + it "forwards batched_reduce_size as a decimal string" $ do + let opts = defaultAsyncSearchSubmitOptions {assoBatchedReduceSize = Just 12} + req = Common.submitAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("batched_reduce_size", Just "12")] + + it "renders batched_reduce_size=0 faithfully (no off-by-one)" $ do + let opts = defaultAsyncSearchSubmitOptions {assoBatchedReduceSize = Just 0} + req = Common.submitAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("batched_reduce_size", Just "0")] + + it "forwards ccs_minimize_roundtrips=true" $ do + let opts = defaultAsyncSearchSubmitOptions {assoCcsMinimizeRoundtrips = Just True} + req = Common.submitAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("ccs_minimize_roundtrips", Just "true")] + + it "forwards every parameter at once (set semantics — order-insensitive)" $ do + let opts = + defaultAsyncSearchSubmitOptions + { assoWaitForCompletion = Just True, + assoKeepOnCompletion = Just True, + assoKeepAlive = Just (keepAliveHours 1), + assoBatchedReduceSize = Just 3, + assoCcsMinimizeRoundtrips = Just False + } + req = Common.submitAsyncSearchWith @Value opts search + sort (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sort + [ ("wait_for_completion", Just "true"), + ("keep_on_completion", Just "true"), + ("keep_alive", Just "1h"), + ("batched_reduce_size", Just "3"), + ("ccs_minimize_roundtrips", Just "false") + ] + + describe "deleteAsyncSearch response decode" $ do + it "decodes {\"acknowledged\": true} as Acknowledged True" $ do + -- Pins the response type advertised by 'deleteAsyncSearch'. + decode "{\"acknowledged\": true}" `shouldBe` Just (Acknowledged True) + + describe "AsyncSearchId JSON" $ do + it "decodes a bare string" $ do + decode "\"FmRleEct\"" `shouldBe` Just (AsyncSearchId "FmRleEct") + + it "encodes back to a bare string" $ do + encode (AsyncSearchId "FmRleEct") `shouldBe` "\"FmRleEct\"" + + it "round-trips through ToJSON/FromJSON" $ do + let original = AsyncSearchId "FmRleEct" + (decode . encode) original `shouldBe` Just original + + describe "AsyncSearchResult JSON" $ do + it "decodes a still-running response (no id, no hits/took)" $ do + let Just (decoded :: AsyncSearchResult Value) = decode sampleRunningResponse + asyncSearchId decoded `shouldBe` Nothing + asyncSearchIsRunning decoded `shouldBe` True + asyncSearchIsPartial decoded `shouldBe` True + asyncSearchStartTimeInMillis decoded `shouldBe` Just 1584726301000 + asyncSearchExpirationTimeInMillis decoded `shouldBe` Just 1584812701000 + asyncSearchTook decoded `shouldBe` Nothing + asyncSearchShards decoded `shouldBe` Nothing + asyncSearchHits decoded `shouldBe` Nothing + + it "decodes a completed response with full hits and aggregations" $ do + let Just (decoded :: AsyncSearchResult Value) = decode sampleCompletedResponse + unAsyncSearchId + <$> asyncSearchId decoded + `shouldBe` Just "FmRleEctRXJtaVNZQ1I2UkJoTDJfQkEAAAAAAAAUX0Q2UkRLNEVBYlhVZ19VUUZmeld3ZwAAAAAAAAAUX0Q2UkRLNEVBYlhVZ19VUUZmeld3Zw==" + asyncSearchIsRunning decoded `shouldBe` False + asyncSearchIsPartial decoded `shouldBe` False + asyncSearchTook decoded `shouldBe` Just 5 + asyncSearchTimedOut decoded `shouldBe` Just False + asyncSearchNumReducePhases decoded `shouldBe` Just 1 + asyncSearchShards decoded `shouldBe` Just (ShardResult 1 1 0 0) + -- Two hits, both with the typed _source + (fmap (length . hits) . asyncSearchHits) decoded `shouldBe` Just 2 + let sources = case asyncSearchHits decoded of + Just sh -> [maybe Null id (hitSource h) | h <- hits sh] + Nothing -> [] + userOf (Object o) = KM.lookup "user" o + userOf _ = Nothing + sort [s | Just (String s) <- userOf <$> sources] `shouldBe` ["ana", "bob"] + asyncSearchAggregations decoded `shouldSatisfy` maybe False hasByUserKey + + it "decodes a completed response with the search payload nested under 'response' (ES8+/ES9)" $ do + -- Elasticsearch 8.x/9.x (and modern 7.x patches) wrap the search + -- payload under a top-level "response" object. The decode must read + -- took/_shards/hits/aggregations from there, not the top level. + let Just (decoded :: AsyncSearchResult Value) = decode sampleCompletedResponseNested + unAsyncSearchId + <$> asyncSearchId decoded + `shouldBe` Just "FmRleEctRXJtaVNZQ1I2UkJoTDJfQkEAAAAAAAAUX0Q2UkRLNEVBYlhVZ19VUUZmeld3ZwAAAAAAAAAUX0Q2UkRLNEVBYlhVZ19VUUZmeld3Zw==" + asyncSearchIsRunning decoded `shouldBe` False + asyncSearchIsPartial decoded `shouldBe` False + asyncSearchCompletionTimeInMillis decoded `shouldBe` Just 1584726302000 + asyncSearchTook decoded `shouldBe` Just 5 + asyncSearchTimedOut decoded `shouldBe` Just False + asyncSearchNumReducePhases decoded `shouldBe` Just 1 + asyncSearchShards decoded `shouldBe` Just (ShardResult 1 1 0 0) + (fmap (length . hits) . asyncSearchHits) decoded `shouldBe` Just 2 + asyncSearchAggregations decoded `shouldSatisfy` maybe False hasByUserKey + + it "decodes a nested 'response' that omits hits (partial reduce) without error" $ do + -- While the final reduce phase has not run, the nested "response" + -- object may carry took/_shards but no hits/aggregations. Decoding + -- must not fail and the absent fields stay at Nothing. + let body = + "{\ + \ \"is_running\": false,\ + \ \"is_partial\": true,\ + \ \"response\": {\"took\": 3, \"_shards\": {\"total\": 1, \"successful\": 1, \"skipped\": 0, \"failed\": 0}}\ + \}" + Just (decoded :: AsyncSearchResult Value) = decode body + asyncSearchIsPartial decoded `shouldBe` True + asyncSearchTook decoded `shouldBe` Just 3 + asyncSearchShards decoded `shouldBe` Just (ShardResult 1 1 0 0) + asyncSearchHits decoded `shouldBe` Nothing + asyncSearchAggregations decoded `shouldBe` Nothing + + it "reads search fields from the top level when 'response' is absent (OpenSearch shape)" $ do + -- The flat shape (no "response" key) is what OpenSearch emits and + -- what the legacy sampleCompletedResponse fixture documents; the + -- dual-parse fallback must still surface those fields. + let Just (flat :: AsyncSearchResult Value) = decode sampleCompletedResponse + Just (nested :: AsyncSearchResult Value) = decode sampleCompletedResponseNested + -- The two fixtures carry identical hit/aggregation data, so every + -- search-result field must agree structurally — except + -- completion_time_in_millis (only the nested fixture carries it). + asyncSearchTook flat `shouldBe` asyncSearchTook nested + asyncSearchTimedOut flat `shouldBe` asyncSearchTimedOut nested + asyncSearchNumReducePhases flat `shouldBe` asyncSearchNumReducePhases nested + asyncSearchShards flat `shouldBe` asyncSearchShards nested + asyncSearchHits flat `shouldBe` asyncSearchHits nested + asyncSearchAggregations flat `shouldBe` asyncSearchAggregations nested + asyncSearchCompletionTimeInMillis flat `shouldBe` Nothing + + it "treats 'response': null the same as an absent 'response' (flat fallback)" $ do + -- aeson's '.:?' collapses JSON null to Nothing, so a null response + -- falls through to the top-level fields just like a missing key. + let body = + "{\ + \ \"is_running\": false,\ + \ \"is_partial\": false,\ + \ \"response\": null,\ + \ \"took\": 4,\ + \ \"_shards\": {\"total\": 1, \"successful\": 1, \"skipped\": 0, \"failed\": 0}\ + \}" + Just (decoded :: AsyncSearchResult Value) = decode body + asyncSearchTook decoded `shouldBe` Just 4 + asyncSearchShards decoded `shouldBe` Just (ShardResult 1 1 0 0) + + it "rejects a present-but-non-object 'response' as a contract violation" $ do + -- Neither ES nor OpenSearch ever emits a non-object 'response'; a + -- malformed value is surfaced as a parse failure rather than + -- silently decoding to an all-Nothing search payload. + let body = "{\"is_running\": false, \"response\": \"not-an-object\"}" + decoded = decode body :: Maybe (AsyncSearchResult Value) + decoded `shouldBe` Nothing + + it "decodes a completed status body carrying completion_time_in_millis" $ do + let Just (decoded :: AsyncSearchStatus) = + decode sampleCompletedStatusResponseWithCompletionTime + asyncSearchStatusCompletionStatus decoded `shouldBe` Just 200 + asyncSearchStatusCompletionTimeInMillis decoded `shouldBe` Just 1584726302000 + + it "decodes an empty {} response with the documented defaults" $ do + -- is_running defaults to False and is_partial to True (per the + -- AsyncSearchResult FromJSON), so {} decodes successfully and every + -- optional field stays at Nothing. + let Just (decoded :: AsyncSearchResult Value) = decode "{}" + asyncSearchIsRunning decoded `shouldBe` False + asyncSearchIsPartial decoded `shouldBe` True + asyncSearchId decoded `shouldBe` Nothing + + it "round-trips through decode twice (deterministic parse)" $ do + -- AsyncSearchResult is decode-only (no ToJSON, by precedent with + -- SearchResult). Pin that two decodes of the same body agree field + -- by field instead. + let firstDecoded = decode sampleCompletedResponse :: Maybe (AsyncSearchResult Value) + secondDecoded = decode sampleCompletedResponse :: Maybe (AsyncSearchResult Value) + case (firstDecoded, secondDecoded) of + (Just a, Just b) -> do + a `shouldBe` b + -- Sanity: the parsed value is actually non-trivial. + asyncSearchTook a `shouldBe` Just 5 + _ -> expectationFailure "decode returned Nothing" + + it "tolerates unknown extra fields in the body" $ do + -- The wire shape will grow new fields over time; decode must not + -- reject bodies just because ES added a key we don't model yet. + let Just (decoded :: AsyncSearchResult Value) = + decode "{ \"is_running\": true, \"future_field\": \"whatever\" }" + asyncSearchIsRunning decoded `shouldBe` True + +-- | True iff the given aggregations map contains a @by_user@ key. +hasByUserKey :: AggregationResults -> Bool +hasByUserKey results = M.member "by_user" results diff --git a/tests/Test/AutoscalingSpec.hs b/tests/Test/AutoscalingSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/AutoscalingSpec.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.AutoscalingSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Maybe (fromJust, isNothing) +import TestsUtils.Import +import Prelude + +------------------------------------------------------------------------------ +-- Policy samples +------------------------------------------------------------------------------ + +-- | The PUT body from the ES 7.17 docs example: a @fixed@ decider governing +-- the @data_hot@ node role. +samplePolicyDocsBytes :: LBS.ByteString +samplePolicyDocsBytes = + "{\ + \ \"roles\": [\"data_hot\"],\ + \ \"deciders\": {\ + \ \"fixed\": {}\ + \ }\ + \}" + +-- | A policy with empty @roles@ and several deciders; both are valid wire +-- shapes the decoder must accept. +samplePolicyEmptyRolesBytes :: LBS.ByteString +samplePolicyEmptyRolesBytes = + "{\ + \ \"roles\": [],\ + \ \"deciders\": {\ + \ \"proactive_storage\": {},\ + \ \"decider_two\": {\"some\": \"setting\"}\ + \ }\ + \}" + +-- | A policy carrying an unknown sibling field (@description@) that the +-- @apExtras@ catch-all must preserve across @encode . decode@. +samplePolicyWithExtrasBytes :: LBS.ByteString +samplePolicyWithExtrasBytes = + "{\ + \ \"roles\": [\"data_hot\", \"data_content\"],\ + \ \"deciders\": {\"fixed\": {}},\ + \ \"description\": \"tier autoscaling\"\ + \}" + +------------------------------------------------------------------------------ +-- Capacity samples +------------------------------------------------------------------------------ + +-- | @GET /_autoscaling/capacity@ with no policies configured — the empty-map +-- shape the docs use as their worked example. +sampleCapacityEmptyBytes :: LBS.ByteString +sampleCapacityEmptyBytes = + "{\ + \ \"policies\": {}\ + \}" + +-- | A full nested capacity response: required\/current capacity, two +-- current_nodes (one with an unknown sibling field), a decider result with +-- @reason_summary@ and @reason_details@, plus an unknown top-level policy +-- field — exercising every typed field and every @extras@ catch-all. +sampleCapacityFullBytes :: LBS.ByteString +sampleCapacityFullBytes = + "{\ + \ \"policies\": {\ + \ \"my_policy\": {\ + \ \"required_capacity\": {\ + \ \"node\": {\"storage\": 1000, \"memory\": 2000},\ + \ \"total\": {\"storage\": 5000, \"memory\": 10000}\ + \ },\ + \ \"current_capacity\": {\ + \ \"node\": {\"storage\": 800, \"memory\": 1600},\ + \ \"total\": {\"storage\": 4000, \"memory\": 8000}\ + \ },\ + \ \"current_nodes\": [\ + \ {\"name\": \"node-1\"},\ + \ {\"name\": \"node-2\", \"foo\": \"bar\"}\ + \ ],\ + \ \"deciders\": {\ + \ \"proactive_storage\": {\ + \ \"required_capacity\": {\ + \ \"node\": {\"storage\": 1000},\ + \ \"total\": {\"storage\": 5000}\ + \ },\ + \ \"reason_summary\": \"need more space\",\ + \ \"reason_details\": {\"shard\": {\"index\": \"logs\", \"size\": 1234}}\ + \ }\ + \ },\ + \ \"unknown_policy_field\": 42\ + \ }\ + \ }\ + \}" + +-- | A large byte count (just under 1 EiB) — guards that @storage@\/@memory@ +-- parse as Int64 without overflow. +sampleLargeResourceBytes :: LBS.ByteString +sampleLargeResourceBytes = + "{\ + \ \"storage\": 9223372036854775000,\ + \ \"memory\": 0\ + \}" + +spec :: Spec +spec = describe "Autoscaling API" $ do + describe "AutoscalingPolicyName JSON" $ do + it "round-trips as a bare JSON string" $ do + let Just decoded = decode "\"my-policy\"" :: Maybe AutoscalingPolicyName + unAutoscalingPolicyName decoded `shouldBe` "my-policy" + encode (AutoscalingPolicyName "my-policy") `shouldBe` "\"my-policy\"" + + it "rejects a non-string value" $ do + let decoded = decode "42" :: Maybe AutoscalingPolicyName + decoded `shouldSatisfy` isNothing + + describe "AutoscalingPolicy JSON" $ do + it "decodes the docs example into typed roles and deciders" $ do + let Just p = decode samplePolicyDocsBytes :: Maybe AutoscalingPolicy + apRoles p `shouldBe` ["data_hot"] + KM.keys (apDeciders p) `shouldSatisfy` elem "fixed" + apExtras p `shouldBe` KM.empty + + it "decodes empty roles and multiple deciders" $ do + let Just p = decode samplePolicyEmptyRolesBytes :: Maybe AutoscalingPolicy + apRoles p `shouldBe` [] + length (KM.toList (apDeciders p)) `shouldBe` 2 + + it "preserves unknown sibling fields in apExtras" $ do + let Just p = decode samplePolicyWithExtrasBytes :: Maybe AutoscalingPolicy + apRoles p `shouldBe` ["data_hot", "data_content"] + KM.lookup "description" (apExtras p) `shouldBe` Just (String "tier autoscaling") + + it "round-trips through encode . decode (extras survive)" $ do + let Just p = decode samplePolicyWithExtrasBytes :: Maybe AutoscalingPolicy + let Just again = decode (encode p) :: Maybe AutoscalingPolicy + again `shouldBe` p + + it "rejects a non-object policy body" $ do + let decoded = decode "[1,2,3]" :: Maybe AutoscalingPolicy + decoded `shouldSatisfy` isNothing + + describe "AutoscalingCapacity JSON" $ do + it "decodes the empty-policies response" $ do + let Just c = decode sampleCapacityEmptyBytes :: Maybe AutoscalingCapacity + acPolicies c `shouldBe` KM.empty + + it "decodes a full nested response into typed fields" $ do + let Just c = decode sampleCapacityFullBytes :: Maybe AutoscalingCapacity + acPolicies c `shouldSatisfy` (not . KM.null) + let policy = fromJust (KM.lookup "my_policy" (acPolicies c)) + -- required_capacity.node.memory is typed and present + let reqCap = fromJust (acpRequiredCapacity policy) + arMemory (fromJust (capNode reqCap)) `shouldBe` Just 2000 + arStorage (fromJust (capTotal reqCap)) `shouldBe` Just 5000 + -- current_nodes: two entries, the second carrying an unknown field + let nodes = fromJust (acpCurrentNodes policy) + length nodes `shouldBe` 2 + acndName (nodes !! 1) `shouldBe` "node-2" + KM.lookup "foo" (acndExtras (nodes !! 1)) `shouldBe` Just (String "bar") + -- deciders: reason_summary typed, reason_details opaque, preserved + let deciders = fromJust (acpDeciders policy) + let decider = fromJust (KM.lookup "proactive_storage" deciders) + adrReasonSummary decider `shouldBe` Just "need more space" + let Just (Object details) = adrReasonDetails decider + KM.size details `shouldBe` 1 + -- unknown top-level policy field survives in extras + KM.lookup "unknown_policy_field" (acpExtras policy) `shouldBe` Just (Number 42) + + it "round-trips a full response through encode . decode" $ do + let Just c = decode sampleCapacityFullBytes :: Maybe AutoscalingCapacity + let Just again = decode (encode c) :: Maybe AutoscalingCapacity + again `shouldBe` c + + it "rejects a non-object capacity body" $ do + let decoded = decode "\"oops\"" :: Maybe AutoscalingCapacity + decoded `shouldSatisfy` isNothing + + describe "AutoscalingResource JSON" $ do + it "decodes large byte counts without overflow" $ do + let Just r = decode sampleLargeResourceBytes :: Maybe AutoscalingResource + arStorage r `shouldBe` Just 9223372036854775000 + arMemory r `shouldBe` Just 0 + + it "current_nodes element rejects a missing name" $ do + let decoded = decode "{\"foo\": \"bar\"}" :: Maybe AutoscalingCurrentNode + decoded `shouldSatisfy` isNothing diff --git a/tests/Test/BehavioralAnalyticsSpec.hs b/tests/Test/BehavioralAnalyticsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/BehavioralAnalyticsSpec.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.BehavioralAnalyticsSpec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List (sort) +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch8.Requests qualified as RequestsES8 +import Database.Bloodhound.ElasticSearch8.Types qualified as Types +import TestsUtils.Common +import TestsUtils.Import + +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + +spec :: Spec +spec = + describe "Behavioral Analytics API (/_application/analytics*)" $ do + describe "AnalyticsCollectionName / AnalyticsEventType JSON" $ do + it "round-trips an AnalyticsCollectionName as a bare string" $ do + let n = Types.AnalyticsCollectionName "my-collection" + decode (encode n) `shouldBe` Just n + it "exposes the known event types" $ do + Types.unAnalyticsEventType Types.analyticsEventTypeSearch + `shouldBe` ("search" :: Text) + Types.unAnalyticsEventType Types.analyticsEventTypeSearchClick + `shouldBe` ("search_click" :: Text) + Types.unAnalyticsEventType Types.analyticsEventTypePageView + `shouldBe` ("page_view" :: Text) + it "round-trips an AnalyticsEventType via IsString" $ + decode (encode (Types.AnalyticsEventType "custom_event" :: Types.AnalyticsEventType)) + `shouldBe` Just (Types.AnalyticsEventType "custom_event") + + describe "AnalyticsCollectionsResponse (GET list) decoding" $ do + it "flattens a name-keyed map into a list of AnalyticsCollection" $ do + let raw = + LBS.pack + "{\"clicks\":{\"name\":\"clicks\"},\"searches\":{}}" + case decode raw :: Maybe Types.AnalyticsCollectionsResponse of + Just resp -> do + length (Types.unAnalyticsCollectionsResponse resp) `shouldBe` 2 + let names = Types.acName <$> Types.unAnalyticsCollectionsResponse resp + sort names `shouldBe` ["clicks", "searches"] + Nothing -> + expectationFailure "failed to decode AnalyticsCollectionsResponse" + it "decodes an empty map as []" $ + decode "{}" `shouldBe` Just (Types.AnalyticsCollectionsResponse []) + + describe "AnalyticsCollectionPutResponse JSON" $ do + it "decodes {acknowledged, name}" $ + decode "{\"acknowledged\":true,\"name\":\"clicks\"}" + `shouldBe` Just + ( Types.AnalyticsCollectionPutResponse + { Types.acprAcknowledged = True, + Types.acprName = "clicks" + } + ) + it "defaults missing fields" $ + decode "{}" + `shouldBe` Just + ( Types.AnalyticsCollectionPutResponse + { Types.acprAcknowledged = False, + Types.acprName = "" + } + ) + + describe "AnalyticsEventResponse JSON" $ do + it "decodes {accepted, event}" $ do + let raw = LBS.pack "{\"accepted\":true,\"event\":{\"q\":\"shirt\"}}" + case decode raw :: Maybe Types.AnalyticsEventResponse of + Just resp -> do + Types.aerAccepted resp `shouldBe` True + Nothing -> expectationFailure "failed to decode AnalyticsEventResponse" + it "defaults missing event to Null" $ + decode "{\"accepted\":false}" + `shouldBe` Just + ( Types.AnalyticsEventResponse + { Types.aerAccepted = False, + Types.aerEvent = Null + } + ) + + describe "analyticsEventOptionsParams URI rendering" $ do + it "defaultAnalyticsEventOptions emits no params" $ + Types.analyticsEventOptionsParams Types.defaultAnalyticsEventOptions + `shouldBe` [] + it "renders debug=true" $ + Types.analyticsEventOptionsParams + Types.defaultAnalyticsEventOptions {Types.aeoDebug = Just True} + `shouldBe` [("debug", Just "true")] + + describe "endpoint shape" $ do + it "GETs /_application/analytics with no body (list all)" $ do + let req = RequestsES8.getAnalyticsCollections Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "analytics"] + bhRequestBody req `shouldSatisfy` isNothing + it "GETs /_application/analytics/ (single)" $ do + let req = RequestsES8.getAnalyticsCollections (Just "clicks") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "analytics", "clicks"] + bhRequestBody req `shouldSatisfy` isNothing + it "PUTs /_application/analytics/ with an empty body" $ do + let req = RequestsES8.putAnalyticsCollection "clicks" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "analytics", "clicks"] + bhRequestBody req `shouldSatisfy` isJust + it "DELETEs /_application/analytics/" $ do + let req = RequestsES8.deleteAnalyticsCollection "clicks" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "analytics", "clicks"] + bhRequestBody req `shouldSatisfy` isNothing + it "POSTs .../event/ with a JSON body" $ do + let payload = object ["q" .= ("shirt" :: Text)] + req = + RequestsES8.postAnalyticsEvent + "clicks" + Types.analyticsEventTypeSearchClick + payload + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "analytics", "clicks", "event", "search_click"] + bhRequestBody req `shouldSatisfy` isJust + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "postAnalyticsEventWith appends debug" $ do + let payload = object ["q" .= ("shirt" :: Text)] + req = + RequestsES8.postAnalyticsEventWith + Types.defaultAnalyticsEventOptions {Types.aeoDebug = Just True} + "clicks" + Types.analyticsEventTypePageView + payload + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "analytics", "clicks", "event", "page_view"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("debug", Just "true")] + + describe "live integration (requires ES8+ backend)" $ + backendSpecific [ElasticSearch8] $ do + it "round-trips a behavioral analytics collection via PUT then GET then DELETE" $ + withTestEnv $ do + let name = Types.AnalyticsCollectionName "bloodhound-test-ba" + _ <- tryPerformBHRequest $ RequestsES8.deleteAnalyticsCollection name + putResp <- tryEsError (ClientES8.putAnalyticsCollection name) + case putResp of + Left e + | errorStatus e == Just 403 + || "privilege" `T.isInfixOf` T.toLower (errorMessage e) -> + liftIO $ + pendingWith + "behavioral analytics requires manage_behavioral_analytics \ + \privilege; skip on locked-down clusters" + Left e -> + liftIO $ + expectationFailure $ + "unexpected PUT error: " <> show e + Right _ -> do + cols <- ClientES8.getAnalyticsCollections (Just name) + liftIO $ length cols `shouldBe` 1 + _ <- ClientES8.deleteAnalyticsCollection name + pure () diff --git a/tests/Test/BulkAPISpec.hs b/tests/Test/BulkAPISpec.hs --- a/tests/Test/BulkAPISpec.hs +++ b/tests/Test/BulkAPISpec.hs @@ -1,12 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Test.BulkAPISpec (spec) where -import qualified Data.Aeson.KeyMap as X -import qualified Data.Aeson.Optics as LMA -import qualified Data.Vector as V -import Optics +import Data.Aeson.KeyMap qualified as X +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Vector qualified as V +import Data.Word (Word64) import TestsUtils.Common import TestsUtils.Import @@ -63,6 +65,162 @@ spec :: Spec spec = describe "Bulk API" $ do + describe "BulkItem response fields" $ do + let minimalItemJson :: Value + minimalItemJson = + object + [ "_index" .= ("test-idx" :: Text), + "_id" .= ("1" :: Text), + "status" .= (404 :: Int), + "error" + .= object + [ "type" .= ("document_missing_exception" :: Text), + "reason" .= ("doc not found" :: Text) + ] + ] + + fullItemJson :: Value + fullItemJson = + object + [ "_index" .= ("test-idx" :: Text), + "_id" .= ("1" :: Text), + "status" .= (201 :: Int), + "_seq_no" .= (0 :: Int), + "_primary_term" .= (1 :: Int), + "_version" .= (1 :: Int), + "_shards" + .= object + [ "total" .= (1 :: Int), + "successful" .= (1 :: Int), + "skipped" .= (0 :: Int), + "failed" .= (0 :: Int) + ], + "result" .= ("created" :: Text) + ] + + expectedMinimal :: BulkItem + expectedMinimal = + BulkItem + { biIndex = "test-idx", + biId = Just "1", + biStatus = Just 404, + biError = + Just $ + BulkError + { beType = "document_missing_exception", + beReason = "doc not found" + }, + biSeqNo = Nothing, + biPrimaryTerm = Nothing, + biVersion = Nothing, + biShards = Nothing, + biResult = Nothing + } + + expectedFull :: BulkItem + expectedFull = + BulkItem + { biIndex = "test-idx", + biId = Just "1", + biStatus = Just 201, + biError = Nothing, + biSeqNo = Just 0, + biPrimaryTerm = Just 1, + biVersion = Just 1, + biShards = + Just $ + ShardResult + { shardTotal = 1, + shardsSuccessful = 1, + shardsSkipped = 0, + shardsFailed = 0 + }, + biResult = Just "created" + } + + it "decodes a fully-populated per-item result" $ + decode (encode fullItemJson) `shouldBe` Just expectedFull + + it "decodes a minimal per-item result (new fields default to Nothing)" $ + decode (encode minimalItemJson) `shouldBe` Just expectedMinimal + + it "parses _shards into ShardResult with skipped/failed present" $ do + let jsonWithSkippedFailed :: Value + jsonWithSkippedFailed = + object + [ "_index" .= ("test-idx" :: Text), + "_id" .= ("1" :: Text), + "_shards" + .= object + [ "total" .= (3 :: Int), + "successful" .= (2 :: Int), + "skipped" .= (1 :: Int), + "failed" .= (0 :: Int) + ] + ] + case decode (encode jsonWithSkippedFailed) of + Just (bi :: BulkItem) -> + biShards bi + `shouldBe` Just + ShardResult + { shardTotal = 3, + shardsSuccessful = 2, + shardsSkipped = 1, + shardsFailed = 0 + } + _ -> expectationFailure "expected BulkItem decode to succeed" + + it "propagates per-item shard failures via biShards (failed > 0)" $ do + -- This is the motivating bug for the bead: callers previously could + -- not see per-item shard failures. Verify shardsFailed round-trips. + let jsonWithFailedShard :: Value + jsonWithFailedShard = + object + [ "_index" .= ("test-idx" :: Text), + "_id" .= ("1" :: Text), + "status" .= (200 :: Int), + "_version" .= (3 :: Int), + "result" .= ("updated" :: Text), + "_shards" + .= object + [ "total" .= (2 :: Int), + "successful" .= (1 :: Int), + "skipped" .= (0 :: Int), + "failed" .= (1 :: Int) + ] + ] + case decode (encode jsonWithFailedShard) of + Just (bi :: BulkItem) -> + (biShards bi >>= Just . shardsFailed) `shouldBe` Just 1 + _ -> expectationFailure "expected BulkItem decode to succeed" + + it "decodes a delete result (no _shards, no _seq_no, no _primary_term)" $ do + -- ES bulk delete items return _version and result="deleted" but + -- typically omit _shards, _seq_no, _primary_term. The new fields + -- must decode safely as Nothing. + let deleteItemJson :: Value + deleteItemJson = + object + [ "_index" .= ("test-idx" :: Text), + "_id" .= ("1" :: Text), + "status" .= (200 :: Int), + "_version" .= (7 :: Int), + "result" .= ("deleted" :: Text) + ] + decode (encode deleteItemJson) + `shouldBe` Just + BulkItem + { biIndex = "test-idx", + biId = Just "1", + biStatus = Just 200, + biError = Nothing, + biSeqNo = Nothing, + biPrimaryTerm = Nothing, + biVersion = Just 7, + biShards = Nothing, + biResult = Just "deleted" + } + it "upsert operations" $ withTestEnv $ do _ <- insertData @@ -91,7 +249,8 @@ Script { scriptLanguage = Just $ ScriptLanguage "painless", scriptSource = ScriptInline "ctx._source.counter += params.count", - scriptParams = Just $ ScriptParams $ X.fromList [("count", Number 2)] + scriptParams = Just $ ScriptParams $ X.fromList [("count", Number 2)], + scriptOptions = Nothing } upsertDocs (UpsertScript False script) batch @@ -107,7 +266,8 @@ Script { scriptLanguage = Just $ ScriptLanguage "painless", scriptSource = ScriptInline "ctx._source.counter += params.count", - scriptParams = Just $ ScriptParams $ X.fromList [("count", Number 2)] + scriptParams = Just $ ScriptParams $ X.fromList [("count", Number 2)], + scriptOptions = Nothing } -- Without "script_upsert" flag new documents are simply inserted and are not handled by the script @@ -124,7 +284,8 @@ Script { scriptLanguage = Just $ ScriptLanguage "painless", scriptSource = ScriptInline "ctx._source.counter += params.count", - scriptParams = Just $ ScriptParams $ X.fromList [("count", Number 2)] + scriptParams = Just $ ScriptParams $ X.fromList [("count", Number 2)], + scriptOptions = Nothing } -- Without "script_upsert" flag new documents are simply inserted and are not handled by the script @@ -141,11 +302,11 @@ let thirdTest = BulkTest "graffle" let fourthTest = BulkTest "garabadoo" let fifthTest = BulkTest "serenity" - let firstDoc = BulkIndex testIndex (DocId "2") (toJSON firstTest) - let secondDoc = BulkCreate testIndex (DocId "3") (toJSON secondTest) - let thirdDoc = BulkCreateEncoding testIndex (DocId "4") (toEncoding thirdTest) - let fourthDoc = BulkIndexAuto testIndex (toJSON fourthTest) - let fifthDoc = BulkIndexEncodingAuto testIndex (toEncoding fifthTest) + let firstDoc = BulkIndex testIndex (DocId "2") (toJSON firstTest) [] + let secondDoc = BulkCreate testIndex (DocId "3") (toJSON secondTest) [] + let thirdDoc = BulkCreateEncoding testIndex (DocId "4") (toEncoding thirdTest) [] + let fourthDoc = BulkIndexAuto testIndex (toJSON fourthTest) [] + let fifthDoc = BulkIndexEncodingAuto testIndex (toEncoding fifthTest) [] let stream = V.fromList [firstDoc, secondDoc, thirdDoc, fourthDoc, fifthDoc] bulkResponse <- performBHRequest $ bulk @StatusDependant stream -- liftIO $ pPrint bulkResp @@ -167,22 +328,200 @@ bulkActionItems bulkResponse `shouldSatisfy` all ((== "bloodhound-tests-twitter-1") . biIndex . baiItem) bulkActionItems bulkResponse `shouldSatisfy` all ((== Just 201) . biStatus . baiItem) bulkActionItems bulkResponse `shouldSatisfy` all ((== Nothing) . biError . baiItem) + -- Per-item enrichment: a successful create/update carries + -- _seq_no, _primary_term, _version, _shards, and result on every backend. + bulkActionItems bulkResponse `shouldSatisfy` all (isJust . biSeqNo . baiItem) + bulkActionItems bulkResponse `shouldSatisfy` all (isJust . biPrimaryTerm . baiItem) + bulkActionItems bulkResponse `shouldSatisfy` all (isJust . biVersion . baiItem) + bulkActionItems bulkResponse `shouldSatisfy` all (isJust . biShards . baiItem) + bulkActionItems bulkResponse `shouldSatisfy` all (isJust . biResult . baiItem) + -- The first op is BulkIndex (upsert) on a fresh doc id, the next two + -- are creates, the last two are index-auto (also upserts). + (biResult . baiItem <$> bulkActionItems bulkResponse) + `shouldSatisfy` all (`elem` [Just "created", Just "updated"]) + (biVersion . baiItem <$> bulkActionItems bulkResponse) + `shouldSatisfy` all (>= Just 1) -- Since we can't get the docs by doc id, we check for their existence in -- a match all query. let query = MatchAllQuery Nothing let search = mkSearch (Just query) Nothing sr <- performBHRequest $ searchByIndex @Value testIndex search liftIO $ - hitsTotal (searchHits sr) `shouldBe` HitsTotal 6 HTR_EQ + hitsTotal (searchHits sr) `shouldBe` Just (HitsTotal 6 HTR_EQ) let nameList :: [Text] nameList = - hits (searchHits sr) - ^.. traversed - % to hitSource - % _Just - % LMA.key "name" - % LMA._String + [ name' + | h <- hits (searchHits sr), + Just v <- [hitSource h], + Object o <- [v], + Just (String name') <- [X.lookup "name" o] + ] liftIO $ nameList `shouldBe` ["blah", "bloo", "graffle", "garabadoo", "serenity"] + + it "bulkWith passes URI params (refresh=wait_for) to the server" $ + withTestEnv $ do + _ <- insertData + let doc = BulkTest "bulkwith-refresh" + -- bsRefresh = RefreshWaitFor forces the server to acknowledge + -- a refresh before responding, so the doc is immediately + -- searchable without an explicit refreshIndex call. + let op = BulkIndex testIndex (DocId "bw-1") (toJSON doc) [] + _ <- + performBHRequest $ + bulkWith @StatusDependant defaultBulkSettings {bsRefresh = Just RefreshWaitFor} (V.singleton op) + -- No refreshIndex here — bsRefresh did the work. + maybeDoc <- performBHRequest $ getDocument @BulkTest testIndex (DocId "bw-1") + liftIO $ getSource maybeDoc `shouldBe` Just doc + + it "bulkWith respects per-op _routing metadata end-to-end" $ + withTestEnv $ do + _ <- insertData + let doc = BulkTest "routing-end-to-end" + -- Custom routing places the doc on a specific shard; a follow-up + -- getDocument *without* routing would miss it on a multi-shard + -- index. testIndex is single-shard (see TestsUtils.Common), so we + -- verify the round-trip via the bulk response rather than shard + -- placement: the response should report no errors and a created + -- result. + let op = + BulkIndex + testIndex + (DocId "rt-1") + (toJSON doc) + [UA_Routing "custom-route-1"] + bulkResponse <- + performBHRequest $ + bulkWith @StatusDependant defaultBulkSettings (V.singleton op) + _ <- performBHRequest $ refreshIndex testIndex + liftIO $ do + bulkErrors bulkResponse `shouldBe` False + length (bulkActionItems bulkResponse) `shouldBe` 1 + (biResult . baiItem <$> bulkActionItems bulkResponse) + `shouldSatisfy` all (`elem` [Just "created", Just "updated"]) + + describe "Per-op metadata (UpsertActionMetadata)" $ do + it "renders every constructor to the expected wire pair" $ do + buildUpsertActionMetadata (UA_Routing "user-1") + `shouldBe` "routing" + .= ("user-1" :: Text) + buildUpsertActionMetadata (UA_Version 7) + `shouldBe` "version" + .= (7 :: Int) + buildUpsertActionMetadata (UA_VersionType VersionTypeExternalGTE) + `shouldBe` "version_type" + .= ("external_gte" :: Text) + buildUpsertActionMetadata (UA_IfSeqNo 12) + `shouldBe` "if_seq_no" + .= (12 :: Word64) + buildUpsertActionMetadata (UA_IfPrimaryTerm 3) + `shouldBe` "if_primary_term" + .= (3 :: Word64) + buildUpsertActionMetadata (UA_RequireAlias True) + `shouldBe` "require_alias" + .= True + buildUpsertActionMetadata (UA_RetryOnConflict 5) + `shouldBe` "retry_on_conflict" + .= (5 :: Int) + + it "encodes a BulkIndex op with metadata into the correct NDJSON line" $ do + let op = + BulkIndex + [qqIndexName|twitter|] + (DocId "1") + (toJSON (BulkTest "blah")) + [ UA_Routing "user-1", + UA_IfSeqNo 5, + UA_IfPrimaryTerm 2, + UA_VersionType VersionTypeExternal + ] + -- aeson sorts object keys alphabetically, so the rendered line is stable. + encodeBulkOperation op + `shouldBe` "{\"index\":{\"_id\":\"1\",\"_index\":\"twitter\",\"if_primary_term\":2,\"if_seq_no\":5,\"routing\":\"user-1\",\"version_type\":\"external\"}}\n{\"name\":\"blah\"}" + + it "encodes a BulkDelete op with metadata into the correct NDJSON line" $ do + let op = + BulkDelete + [qqIndexName|twitter|] + (DocId "1") + [UA_Routing "user-1"] + encodeBulkOperation op + `shouldBe` "{\"delete\":{\"_id\":\"1\",\"_index\":\"twitter\",\"routing\":\"user-1\"}}" + + it "encodes a BulkUpdate op with metadata into the correct NDJSON line" $ do + let op = + BulkUpdate + [qqIndexName|twitter|] + (DocId "1") + (toJSON (BulkTest "blah")) + [UA_RequireAlias True] + encodeBulkOperation op + `shouldBe` "{\"update\":{\"_id\":\"1\",\"_index\":\"twitter\",\"require_alias\":true}}\n{\"doc\":{\"name\":\"blah\"}}" + + it "encodes a BulkIndexAuto op with metadata into the correct NDJSON line" $ do + let op = + BulkIndexAuto + [qqIndexName|twitter|] + (toJSON (BulkTest "blah")) + [UA_Routing "user-1"] + encodeBulkOperation op + `shouldBe` "{\"index\":{\"_index\":\"twitter\",\"routing\":\"user-1\"}}\n{\"name\":\"blah\"}" + + it "encodes a BulkCreateEncoding op with metadata into the correct NDJSON line" $ do + let op = + BulkCreateEncoding + [qqIndexName|twitter|] + (DocId "1") + (toEncoding (BulkTest "blah")) + [UA_IfPrimaryTerm 1, UA_IfSeqNo 2] + encodeBulkOperation op + `shouldBe` "{\"create\":{\"_id\":\"1\",\"_index\":\"twitter\",\"if_primary_term\":1,\"if_seq_no\":2}}\n{\"name\":\"blah\"}" + + it "is byte-for-byte identical whether metadata is [] or omitted-style (empty list)" $ do + -- Regression: pre-refactor BulkIndex ix id val produced exactly + -- this string; the refactored BulkIndex ix id val [] must match. + let opOldShape = BulkIndex [qqIndexName|twitter|] (DocId "2") (toJSON (BulkTest "blah")) [] + encodeBulkOperation opOldShape + `shouldBe` "{\"index\":{\"_id\":\"2\",\"_index\":\"twitter\"}}\n{\"name\":\"blah\"}" + + describe "BulkSettings (URI params)" $ do + it "defaultBulkSettings emits no query parameters" $ + bulkSettingsParams defaultBulkSettings `shouldBe` [] + + it "renders refresh / wait_for_active_shards as bare values" $ do + let opts = + defaultBulkSettings + { bsRefresh = Just RefreshWaitFor, + bsWaitForActiveShards = Just AllActiveShards + } + bulkSettingsParams opts + `shouldBe` [("refresh", Just "wait_for"), ("wait_for_active_shards", Just "all")] + + it "renders booleans as true/false strings" $ do + let opts = + defaultBulkSettings + { bsSource = Just False, + bsRequireAlias = Just True + } + bulkSettingsParams opts + `shouldBe` [("_source", Just "false"), ("require_alias", Just "true")] + + it "renders text params verbatim" $ do + let opts = + defaultBulkSettings + { bsTimeout = Just "5s", + bsRouting = Just "user-1", + bsPipeline = Just "enrich", + bsSourceIncludes = Just "metadata.*,name", + bsSourceExcludes = Just "internal.*" + } + params = bulkSettingsParams opts + -- Order of the rendered list is unspecified (callers should treat + -- it as a set), so verify per-key rather than as a sublist. + lookup "timeout" params `shouldBe` Just (Just "5s") + lookup "routing" params `shouldBe` Just (Just "user-1") + lookup "pipeline" params `shouldBe` Just (Just "enrich") + lookup "_source_includes" params `shouldBe` Just (Just "metadata.*,name") + lookup "_source_excludes" params `shouldBe` Just (Just "internal.*") diff --git a/tests/Test/CCRSpec.hs b/tests/Test/CCRSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/CCRSpec.hs @@ -0,0 +1,735 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.CCRSpec (spec) where + +import Control.Concurrent (threadDelay) +import Control.Monad.Catch (bracket_) +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List qualified as L +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Time.Clock.POSIX (getPOSIXTime) +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch1.Types qualified as OS1Types +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2Types +import Database.Bloodhound.OpenSearch3.Client qualified as OS3Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types +import Database.Bloodhound.OpenSearch3.Types qualified as OS3Types +import System.Environment (lookupEnv) +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- --------------------------------------------------------------------------- +-- Sample bodies, drawn verbatim from the OpenSearch CCR plugin docs +-- (). +-- --------------------------------------------------------------------------- + +-- | The canonical start-replication body with Security roles. +sampleStartRequestJson :: LBS.ByteString +sampleStartRequestJson = + "{\ + \ \"leader_alias\": \"my-connection\",\ + \ \"leader_index\": \"leader-01\",\ + \ \"use_roles\": {\ + \ \"leader_cluster_role\": \"leader_role\",\ + \ \"follower_cluster_role\": \"follower_role\"\ + \ }\ + \}" + +-- | A start-replication body without @use_roles@ (Security plugin disabled). +sampleStartRequestNoRolesJson :: LBS.ByteString +sampleStartRequestNoRolesJson = + "{\ + \ \"leader_alias\": \"my-connection\",\ + \ \"leader_index\": \"leader-01\"\ + \}" + +-- | The update-settings body carrying two index settings. +sampleUpdateSettingsJson :: LBS.ByteString +sampleUpdateSettingsJson = + "{\ + \ \"settings\": {\ + \ \"index.number_of_shards\": 4,\ + \ \"index.number_of_replicas\": 2\ + \ }\ + \}" + +-- | A create auto-follow pattern body. +sampleCreateAutoFollowJson :: LBS.ByteString +sampleCreateAutoFollowJson = + "{\ + \ \"leader_alias\": \"my-connection\",\ + \ \"name\": \"my-rule\",\ + \ \"pattern\": \"leader-*\",\ + \ \"use_roles\": {\ + \ \"leader_cluster_role\": \"leader_role\",\ + \ \"follower_cluster_role\": \"follower_role\"\ + \ }\ + \}" + +-- | A delete auto-follow pattern body. +sampleDeleteAutoFollowJson :: LBS.ByteString +sampleDeleteAutoFollowJson = + "{\ + \ \"leader_alias\": \"my-connection\",\ + \ \"name\": \"my-rule\"\ + \}" + +-- | The status response body while syncing (includes syncing_details). +sampleStatusSyncingJson :: LBS.ByteString +sampleStatusSyncingJson = + "{\ + \ \"status\": \"SYNCING\",\ + \ \"reason\": \"User initiated\",\ + \ \"leader_alias\": \"my-connection\",\ + \ \"leader_index\": \"leader-01\",\ + \ \"follower_index\": \"follower-01\",\ + \ \"syncing_details\": {\ + \ \"leader_checkpoint\": 19,\ + \ \"follower_checkpoint\": 19,\ + \ \"seq_no\": 0\ + \ }\ + \}" + +-- | The status response body when replication is not in progress. +sampleStatusNotInProgressJson :: LBS.ByteString +sampleStatusNotInProgressJson = + "{\ + \ \"status\": \"REPLICATION NOT IN PROGRESS\",\ + \ \"reason\": \"User initiated\",\ + \ \"leader_alias\": \"my-connection\",\ + \ \"leader_index\": \"leader-01\",\ + \ \"follower_index\": \"follower-01\"\ + \}" + +spec :: Spec +spec = describe "Cross-Cluster Replication (CCR) plugin" $ do + -- ======================================================================= + -- ReplicationStatus enum + -- ======================================================================= + describe "ReplicationStatus JSON" $ do + let cases = + [ (ReplicationStatusSyncing, "SYNCING"), + (ReplicationStatusBootstrapping, "BOOTSTRAPPING"), + (ReplicationStatusPaused, "PAUSED"), + (ReplicationStatusNotInProgress, "REPLICATION NOT IN PROGRESS") + ] + forM_ cases $ \(t, wire) -> do + it ("encodes " <> show wire <> " to the documented wire string") $ do + encode t `shouldBe` "\"" <> LBS.fromStrict wire <> "\"" + it ("decodes the documented wire string " <> show wire) $ do + decode ("\"" <> LBS.fromStrict wire <> "\"" :: LBS.ByteString) + `shouldBe` Just t + + it "round-trips an unknown status through ReplicationStatusOther" $ do + let t = ReplicationStatusOther "NEW_FUTURE_STATE" + (decode . encode) t `shouldBe` Just t + + it "replicationStatusText round-trips with ToJSON/FromJSON" $ + property $ \(t :: ReplicationStatus) -> + (decode . encode) t === Just t + + -- ======================================================================= + -- ReplicationUseRoles + -- ======================================================================= + describe "ReplicationUseRoles JSON" $ do + it "round-trips both roles" $ do + let t = ReplicationUseRoles "leader_role" "follower_role" + (decode . encode) t `shouldBe` Just t + + it "encodes to the documented wire shape" $ + (decode (encode (ReplicationUseRoles "lr" "fr")) :: Maybe Value) + `shouldBe` decode "{\"leader_cluster_role\":\"lr\",\"follower_cluster_role\":\"fr\"}" + + it "decodes the documented fixture" $ + (decode sampleStartRequestJson :: Maybe StartReplicationRequest) + `shouldSatisfy` isJust + + -- ======================================================================= + -- StartReplicationRequest + -- ======================================================================= + describe "StartReplicationRequest JSON" $ do + it "decodes a body with use_roles" $ do + let Just req = decode sampleStartRequestJson + startReplicationRequestLeaderAlias req `shouldBe` "my-connection" + startReplicationRequestLeaderIndex req `shouldBe` "leader-01" + startReplicationRequestUseRoles req `shouldSatisfy` isJust + + it "decodes a body without use_roles" $ do + let Just req = decode sampleStartRequestNoRolesJson + startReplicationRequestUseRoles req `shouldBe` Nothing + + it "round-trips through ToJSON/FromJSON" $ + property $ \(req :: StartReplicationRequest) -> + (decode . encode) req === Just req + + it "omits use_roles when absent" $ do + let req = + StartReplicationRequest "a" "i" Nothing + LBS.toStrict (encode req) `shouldSatisfy` not . BS.isInfixOf "use_roles" + + -- ======================================================================= + -- UpdateReplicationSettingsRequest + -- ======================================================================= + describe "UpdateReplicationSettingsRequest JSON" $ do + it "decodes the documented fixture" $ do + let Just req = decode sampleUpdateSettingsJson + Map.size (updateReplicationSettingsRequestSettings req) `shouldBe` 2 + + it "round-trips a concrete settings map" $ do + let m = + Map.fromList + [ ("index.number_of_replicas", toJSON (2 :: Int)), + ("index.number_of_shards", toJSON (4 :: Int)) + ] + req = UpdateReplicationSettingsRequest m + (decode . encode) req `shouldBe` Just req + + -- ======================================================================= + -- CreateAutoFollowPatternRequest / DeleteAutoFollowPatternRequest + -- ======================================================================= + describe "CreateAutoFollowPatternRequest JSON" $ do + it "decodes the documented fixture" $ do + let Just req = decode sampleCreateAutoFollowJson + createAutoFollowPatternRequestName req `shouldBe` "my-rule" + createAutoFollowPatternRequestPattern req `shouldBe` "leader-*" + + it "round-trips through ToJSON/FromJSON" $ + property $ \(req :: CreateAutoFollowPatternRequest) -> + (decode . encode) req === Just req + + describe "DeleteAutoFollowPatternRequest JSON" $ do + it "decodes the documented fixture" $ do + let Just req = decode sampleDeleteAutoFollowJson + deleteAutoFollowPatternRequestName req `shouldBe` "my-rule" + + it "round-trips through ToJSON/FromJSON" $ + property $ \(req :: DeleteAutoFollowPatternRequest) -> + (decode . encode) req === Just req + + -- ======================================================================= + -- SyncingDetails / ReplicationStatusResponse + -- ======================================================================= + describe "SyncingDetails JSON" $ do + it "round-trips through ToJSON/FromJSON" $ + property $ \(d :: SyncingDetails) -> + (decode . encode) d === Just d + + describe "ReplicationStatusResponse JSON" $ do + it "decodes a SYNCING body with syncing_details" $ do + let Just resp = decode sampleStatusSyncingJson + replicationStatusResponseStatus resp `shouldBe` ReplicationStatusSyncing + replicationStatusResponseSyncingDetails resp `shouldSatisfy` isJust + + it "decodes a not-in-progress body without syncing_details" $ do + let Just resp = decode sampleStatusNotInProgressJson + replicationStatusResponseStatus resp `shouldBe` ReplicationStatusNotInProgress + replicationStatusResponseSyncingDetails resp `shouldBe` Nothing + + it "round-trips through ToJSON/FromJSON" $ + property $ \(resp :: ReplicationStatusResponse) -> + (decode . encode) resp === Just resp + + -- ======================================================================= + -- Stats responses + -- ======================================================================= + describe "LeaderIndexStats JSON" $ do + it "round-trips through ToJSON/FromJSON" $ + property $ \(s :: LeaderIndexStats) -> + (decode . encode) s === Just s + + describe "LeaderStatsResponse JSON" $ do + it "decodes with an empty index_stats default when omitted" $ do + let fixture = + "{\ + \ \"num_replicated_indices\": 0,\ + \ \"operations_read\": 0,\ + \ \"translog_size_bytes\": 0,\ + \ \"operations_read_lucene\": 0,\ + \ \"operations_read_translog\": 0,\ + \ \"total_read_time_lucene_millis\": 0,\ + \ \"total_read_time_translog_millis\": 0,\ + \ \"bytes_read\": 0\ + \}" + Just resp = decode fixture + leaderStatsResponseIndexStats resp `shouldBe` mempty + + it "round-trips through ToJSON/FromJSON" $ + property $ \(resp :: LeaderStatsResponse) -> + (decode . encode) resp === Just resp + + describe "FollowerIndexStats JSON" $ do + it "round-trips through ToJSON/FromJSON" $ + property $ \(s :: FollowerIndexStats) -> + (decode . encode) s === Just s + + describe "FollowerStatsResponse JSON" $ do + it "round-trips through ToJSON/FromJSON" $ + property $ \(resp :: FollowerStatsResponse) -> + (decode . encode) resp === Just resp + + describe "AutoFollowRuleStats JSON" $ do + it "round-trips through ToJSON/FromJSON" $ + property $ \(s :: AutoFollowRuleStats) -> + (decode . encode) s === Just s + + describe "AutoFollowStatsResponse JSON" $ do + it "decodes with empty defaults for failed_indices and autofollow_stats" $ do + let fixture = + "{\ + \ \"num_success_start_replication\": 0,\ + \ \"num_failed_start_replication\": 0,\ + \ \"num_failed_leader_calls\": 0\ + \}" + Just resp = decode fixture + autoFollowStatsResponseFailedIndices resp `shouldBe` [] + autoFollowStatsResponseAutoFollowStats resp `shouldBe` [] + + it "round-trips through ToJSON/FromJSON" $ + property $ \(resp :: AutoFollowStatsResponse) -> + (decode . encode) resp === Just resp + + -- ======================================================================= + -- Endpoint shape tests (OpenSearch 3) + -- ======================================================================= + describe "startReplication endpoint shape (OpenSearch 3)" $ do + let req = + StartReplicationRequest + { startReplicationRequestLeaderAlias = "conn", + startReplicationRequestLeaderIndex = "leader-01", + startReplicationRequestUseRoles = + Just (ReplicationUseRoles "lr" "fr") + } + it "PUTs to /_plugins/_replication/{follower}/_start" $ do + let r = OS3Requests.startReplication "follower-01" req + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_replication", "follower-01", "_start"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + it "uses PUT and attaches the encoded body" $ do + let r = OS3Requests.startReplication "follower-01" req + bhRequestMethod r `shouldBe` "PUT" + bhRequestBody r `shouldSatisfy` isJust + + describe "stopReplication endpoint shape (OpenSearch 3)" $ do + it "POSTs to /_plugins/_replication/{follower}/_stop with an empty body" $ do + let r = OS3Requests.stopReplication "follower-01" + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_replication", "follower-01", "_stop"] + bhRequestBody r `shouldBe` Just "{}" + + describe "pauseReplication endpoint shape (OpenSearch 3)" $ do + it "POSTs to /_plugins/_replication/{follower}/_pause with an empty body" $ do + let r = OS3Requests.pauseReplication "follower-01" + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_replication", "follower-01", "_pause"] + bhRequestBody r `shouldBe` Just "{}" + + describe "resumeReplication endpoint shape (OpenSearch 3)" $ do + it "POSTs to /_plugins/_replication/{follower}/_resume with an empty body" $ do + let r = OS3Requests.resumeReplication "follower-01" + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_replication", "follower-01", "_resume"] + bhRequestBody r `shouldBe` Just "{}" + + describe "updateReplicationSettings endpoint shape (OpenSearch 3)" $ do + let req = + UpdateReplicationSettingsRequest $ + Map.fromList [("index.number_of_replicas", toJSON (2 :: Int))] + it "PUTs to /_plugins/_replication/{follower}/_update" $ do + let r = OS3Requests.updateReplicationSettings "follower-01" req + bhRequestMethod r `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_replication", "follower-01", "_update"] + bhRequestBody r `shouldSatisfy` isJust + + describe "getReplicationStatus endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_replication/{follower}/_status with no query" $ do + let r = OS3Requests.getReplicationStatus "follower-01" + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_replication", "follower-01", "_status"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + bhRequestBody r `shouldBe` Nothing + + describe "getReplicationStatusWith endpoint shape (OpenSearch 3)" $ do + it "forwards verbose=true as a query parameter" $ do + let opts = defaultReplicationStatusOptions {replicationStatusOptionsVerbose = Just True} + r = OS3Requests.getReplicationStatusWith opts "follower-01" + getRawEndpointQueries (bhRequestEndpoint r) + `shouldBe` [("verbose", Just "true")] + it "default options produce no query string" $ do + let r = OS3Requests.getReplicationStatusWith defaultReplicationStatusOptions "follower-01" + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + + describe "getLeaderStats endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_replication/leader_stats with no body" $ do + let r = OS3Requests.getLeaderStats + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_replication", "leader_stats"] + bhRequestBody r `shouldBe` Nothing + + describe "getFollowerStats endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_replication/follower_stats with no body" $ do + let r = OS3Requests.getFollowerStats + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_replication", "follower_stats"] + bhRequestBody r `shouldBe` Nothing + + describe "getAutoFollowStats endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_replication/autofollow_stats with no body" $ do + let r = OS3Requests.getAutoFollowStats + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_replication", "autofollow_stats"] + bhRequestBody r `shouldBe` Nothing + + describe "createAutoFollowPattern endpoint shape (OpenSearch 3)" $ do + let req = + CreateAutoFollowPatternRequest + { createAutoFollowPatternRequestLeaderAlias = "conn", + createAutoFollowPatternRequestName = "rule", + createAutoFollowPatternRequestPattern = "leader-*", + createAutoFollowPatternRequestUseRoles = Nothing + } + it "POSTs to /_plugins/_replication/_autofollow with a body" $ do + let r = OS3Requests.createAutoFollowPattern req + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_replication", "_autofollow"] + bhRequestBody r `shouldSatisfy` isJust + + describe "deleteAutoFollowPattern endpoint shape (OpenSearch 3)" $ do + let req = + DeleteAutoFollowPatternRequest + { deleteAutoFollowPatternRequestLeaderAlias = "conn", + deleteAutoFollowPatternRequestName = "rule" + } + it "DELETEs /_plugins/_replication/_autofollow with a body" $ do + let r = OS3Requests.deleteAutoFollowPattern req + bhRequestMethod r `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_replication", "_autofollow"] + bhRequestBody r `shouldSatisfy` isJust + + -- ======================================================================= + -- Cross-version parity (OS1 vs OS2 vs OS3) + -- ======================================================================= + describe "cross-version parity (OS1/OS2/OS3)" $ do + let mkOS1Start :: OS1Types.StartReplicationRequest + mkOS1Start = + OS1Types.StartReplicationRequest + { OS1Types.startReplicationRequestLeaderAlias = "conn", + OS1Types.startReplicationRequestLeaderIndex = "leader-01", + OS1Types.startReplicationRequestUseRoles = Nothing + } + mkOS2Start :: OS2Types.StartReplicationRequest + mkOS2Start = + OS2Types.StartReplicationRequest + { OS2Types.startReplicationRequestLeaderAlias = "conn", + OS2Types.startReplicationRequestLeaderIndex = "leader-01", + OS2Types.startReplicationRequestUseRoles = Nothing + } + mkOS3Start :: StartReplicationRequest + mkOS3Start = + StartReplicationRequest + { startReplicationRequestLeaderAlias = "conn", + startReplicationRequestLeaderIndex = "leader-01", + startReplicationRequestUseRoles = Nothing + } + + it "startReplication emits identical paths/methods across OS1/OS2/OS3" $ do + let r1 = OS1Requests.startReplication "f" mkOS1Start + r2 = OS2Requests.startReplication "f" mkOS2Start + r3 = OS3Requests.startReplication "f" mkOS3Start + getRawEndpoint (bhRequestEndpoint r1) `shouldBe` getRawEndpoint (bhRequestEndpoint r2) + getRawEndpoint (bhRequestEndpoint r2) `shouldBe` getRawEndpoint (bhRequestEndpoint r3) + bhRequestMethod r1 `shouldBe` bhRequestMethod r3 + + it "stopReplication emits identical empty-body POSTs across OS1/OS2/OS3" $ do + let r1 = OS1Requests.stopReplication "f" + r2 = OS2Requests.stopReplication "f" + r3 = OS3Requests.stopReplication "f" + map bhRequestMethod [r1, r2, r3] `shouldBe` ["POST", "POST", "POST"] + map bhRequestBody [r1, r2, r3] `shouldBe` [Just "{}", Just "{}", Just "{}"] + length (L.nub (map (getRawEndpoint . bhRequestEndpoint) [r1, r2, r3])) `shouldBe` 1 + + it "pause/resume emit identical requests across OS1/OS2/OS3" $ do + let pause1 = OS1Requests.pauseReplication "f" + pause3 = OS3Requests.pauseReplication "f" + resume1 = OS1Requests.resumeReplication "f" + resume3 = OS3Requests.resumeReplication "f" + bhRequestMethod pause1 `shouldBe` bhRequestMethod pause3 + bhRequestBody pause1 `shouldBe` bhRequestBody pause3 + bhRequestMethod resume1 `shouldBe` bhRequestMethod resume3 + bhRequestBody resume1 `shouldBe` bhRequestBody resume3 + + it "getLeaderStats/getFollowerStats/getAutoFollowStats emit identical GETs across OS1/OS2/OS3" $ do + let leader1 = OS1Requests.getLeaderStats + leader3 = OS3Requests.getLeaderStats + follower1 = OS1Requests.getFollowerStats + follower3 = OS3Requests.getFollowerStats + auto1 = OS1Requests.getAutoFollowStats + auto3 = OS3Requests.getAutoFollowStats + getRawEndpoint (bhRequestEndpoint leader1) `shouldBe` getRawEndpoint (bhRequestEndpoint leader3) + getRawEndpoint (bhRequestEndpoint follower1) `shouldBe` getRawEndpoint (bhRequestEndpoint follower3) + getRawEndpoint (bhRequestEndpoint auto1) `shouldBe` getRawEndpoint (bhRequestEndpoint auto3) + + it "createAutoFollowPattern emits identical POSTs across OS1/OS2/OS3" $ do + let mkOS1Pattern = + OS1Types.CreateAutoFollowPatternRequest + { OS1Types.createAutoFollowPatternRequestLeaderAlias = "conn", + OS1Types.createAutoFollowPatternRequestName = "rule", + OS1Types.createAutoFollowPatternRequestPattern = "leader-*", + OS1Types.createAutoFollowPatternRequestUseRoles = Nothing + } + mkOS3Pattern = + CreateAutoFollowPatternRequest + { createAutoFollowPatternRequestLeaderAlias = "conn", + createAutoFollowPatternRequestName = "rule", + createAutoFollowPatternRequestPattern = "leader-*", + createAutoFollowPatternRequestUseRoles = Nothing + } + r1 = OS1Requests.createAutoFollowPattern mkOS1Pattern + r3 = OS3Requests.createAutoFollowPattern mkOS3Pattern + getRawEndpoint (bhRequestEndpoint r1) `shouldBe` getRawEndpoint (bhRequestEndpoint r3) + bhRequestMethod r1 `shouldBe` bhRequestMethod r3 + + -- ======================================================================= + -- Live integration tests (gated: requires a CCR-configured follower cluster) + -- ======================================================================= + describe "CCR live round-trip" $ do + ccrIt <- runIO ccrOnlyIT + ccrIt "auto-follow pattern create -> stats -> delete (OpenSearch)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let ruleName = T.pack ("bloodhound_test_ccr_" <> suffix) + createReq = + CreateAutoFollowPatternRequest + { createAutoFollowPatternRequestLeaderAlias = "bloodhound-test-conn", + createAutoFollowPatternRequestName = ruleName, + createAutoFollowPatternRequestPattern = "bloodhound-ccr-*", + createAutoFollowPatternRequestUseRoles = Nothing + } + bracket_ + ( do + resp <- OS3Client.createAutoFollowPattern createReq + liftIO $ + case resp of + Left e -> expectationFailure ("createAutoFollowPattern failed: " <> show e) + Right _ -> pure () + ) + ( do + void $ + OS3Client.deleteAutoFollowPattern $ + DeleteAutoFollowPatternRequest "bloodhound-test-conn" ruleName + ) + $ do + statsResult <- + waitFor $ do + resp <- OS3Client.getAutoFollowStats + pure $ case resp of + Right stats -> + Right + ( ruleName + `elem` map autoFollowRuleStatsName (autoFollowStatsResponseAutoFollowStats stats) + ) + Left e -> Left e + liftIO $ + case statsResult of + Right True -> pure () + Right False -> + expectationFailure + ("auto-follow rule " <> T.unpack ruleName <> " not found in getAutoFollowStats after polling") + Left e -> + expectationFailure ("getAutoFollowStats failed during polling: " <> show e) + +-- | Gate live CCR tests on an explicit opt-in env var. The CCR plugin +-- needs a follower cluster with the plugin installed and a configured +-- leader connection; set @BLOODHOUND_CCR_LIVE=1@ (and point +-- @ES_TEST_SERVER@ at the follower cluster) to enable. Skips otherwise. +ccrOnlyIT :: (HasCallStack, Example a) => IO (String -> a -> SpecWith (Arg a)) +ccrOnlyIT = do + enabled <- lookupEnv "BLOODHOUND_CCR_LIVE" + return $ case enabled of + Just _ -> it + Nothing -> xit + +-- | Poll a predicate up to ~5s (10 x 500ms) to absorb the CCR plugin's +-- async refresh delay after a create\/delete. +waitFor :: (MonadIO m) => m (Either EsError Bool) -> m (Either EsError Bool) +waitFor check = go (0 :: Int) + where + go n = do + result <- check + case result of + Right True -> pure result + _ + | n >= 9 -> pure result + | otherwise -> do + liftIO $ threadDelay 500000 + go (n + 1) + +-- --------------------------------------------------------------------------- +-- QuickCheck instances +-- --------------------------------------------------------------------------- + +instance Arbitrary ReplicationStatus where + arbitrary = + oneof + [ pure ReplicationStatusSyncing, + pure ReplicationStatusBootstrapping, + pure ReplicationStatusPaused, + pure ReplicationStatusNotInProgress, + ReplicationStatusOther . T.pack <$> listOf1 (elements ['A' .. 'Z']) + ] + +instance Arbitrary ReplicationUseRoles where + arbitrary = + ReplicationUseRoles + <$> (T.pack <$> listOf1 (elements ['a' .. 'z'])) + <*> (T.pack <$> listOf1 (elements ['a' .. 'z'])) + +instance Arbitrary SyncingDetails where + arbitrary = + SyncingDetails + <$> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary StartReplicationRequest where + arbitrary = + StartReplicationRequest + <$> (T.pack <$> listOf1 (elements ('a' : ['0' .. '9']))) + <*> (T.pack <$> listOf1 (elements ('a' : ['0' .. '9']))) + <*> arbitrary + +instance Arbitrary CreateAutoFollowPatternRequest where + arbitrary = + CreateAutoFollowPatternRequest + <$> (T.pack <$> listOf1 (elements ('a' : ['0' .. '9']))) + <*> (T.pack <$> listOf1 (elements ['a' .. 'z'])) + <*> (T.pack <$> listOf1 (elements (['a' .. 'z'] ++ "*"))) + <*> arbitrary + +instance Arbitrary DeleteAutoFollowPatternRequest where + arbitrary = + DeleteAutoFollowPatternRequest + <$> (T.pack <$> listOf1 (elements ('a' : ['0' .. '9']))) + <*> (T.pack <$> listOf1 (elements ['a' .. 'z'])) + +instance Arbitrary LeaderIndexStats where + arbitrary = + LeaderIndexStats + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary FollowerIndexStats where + arbitrary = + FollowerIndexStats + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary AutoFollowRuleStats where + arbitrary = + AutoFollowRuleStats + <$> (T.pack <$> listOf1 (elements ['a' .. 'z'])) + <*> (T.pack <$> listOf1 (elements ('*' : ['a' .. 'z']))) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> listOf (T.pack <$> listOf1 (elements ['a' .. 'z'])) + +instance Arbitrary LeaderStatsResponse where + arbitrary = do + keys <- listOf (T.pack <$> listOf1 (elements ['a' .. 'z'])) + vals <- listOf arbitrary + LeaderStatsResponse + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> pure (Map.fromList (zip keys vals)) + shrink (LeaderStatsResponse a b c d e f g h m) = + [ LeaderStatsResponse a b c d e f g h (Map.fromList smaller) + | smaller <- shrinkList (const []) (Map.toList m) + ] + +instance Arbitrary FollowerStatsResponse where + arbitrary = do + keys <- listOf (T.pack <$> listOf1 (elements ['a' .. 'z'])) + vals <- listOf arbitrary + FollowerStatsResponse + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> pure (Map.fromList (zip keys vals)) + shrink (FollowerStatsResponse a b c d e f g h i j k l m n o m') = + [ FollowerStatsResponse a b c d e f g h i j k l m n o (Map.fromList smaller) + | smaller <- shrinkList (const []) (Map.toList m') + ] + +instance Arbitrary ReplicationStatusResponse where + arbitrary = + ReplicationStatusResponse + <$> arbitrary + <*> (T.pack <$> listOf1 (elements ('a' : ['A' .. 'Z'] ++ " "))) + <*> (T.pack <$> listOf1 (elements ('a' : ['0' .. '9']))) + <*> (T.pack <$> listOf1 (elements ('a' : ['0' .. '9']))) + <*> (T.pack <$> listOf1 (elements ('a' : ['0' .. '9']))) + <*> arbitrary + +instance Arbitrary AutoFollowStatsResponse where + arbitrary = do + failed <- listOf (T.pack <$> listOf1 (elements ['a' .. 'z'])) + rules <- listOf arbitrary + AutoFollowStatsResponse + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> pure failed + <*> pure rules + shrink (AutoFollowStatsResponse a b c f r) = + [ AutoFollowStatsResponse a b c f' r + | f' <- shrinkList (const []) f + ] + ++ [ AutoFollowStatsResponse a b c f r' + | r' <- shrinkList (const []) r + ] diff --git a/tests/Test/CatSpec.hs b/tests/Test/CatSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/CatSpec.hs @@ -0,0 +1,3774 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.CatSpec (spec) where + +import Control.Monad.Catch (bracket_) +import Data.Aeson.Key (fromText) +import Data.Aeson.KeyMap qualified as KM +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.Common.Client qualified as Client +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- Pure rendering + decoding tests for the cat indices option type and +-- response row. Mirrors the structure of "Test.ClusterHealthSpec": a +-- "URI rendering" describe block that does not need a running ES, plus +-- a JSON-parsing describe block driven by realistic cat wire payloads. +spec :: Spec +spec = do + -- ------------------------------------------------------------------ -- + -- catIndicesOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catIndicesOptionsParams URI rendering" $ do + it "defaultCatIndicesOptions emits only format=json" $ + catIndicesOptionsParams defaultCatIndicesOptions + `shouldBe` [("format", Just "json")] + + it "renders bytes via catBytesSizeText" $ do + let opts = defaultCatIndicesOptions {catoBytes = Just CatBytesKb} + catIndicesOptionsParams opts + `shouldContain` [("bytes", Just "kb")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatIndicesOptions + { catoColumns = Just (CatColIndex :| [CatColDocsCount, CatColStoreSize]) + } + catIndicesOptionsParams opts + `shouldContain` [("h", Just "index,docs.count,store.size")] + + it "renders unknown columns verbatim" $ do + let opts = + defaultCatIndicesOptions + { catoColumns = Just (CatColOther "rep.throttle.time" :| []) + } + catIndicesOptionsParams opts + `shouldContain` [("h", Just "rep.throttle.time")] + + it "renders expand_wildcards as a comma-joined list" $ do + let opts = + defaultCatIndicesOptions + { catoExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + catIndicesOptionsParams opts + `shouldContain` [("expand_wildcards", Just "open,closed")] + + it "renders health via catHealthFilterText" $ do + let opts = defaultCatIndicesOptions {catoHealth = Just CatHealthFilterYellow} + catIndicesOptionsParams opts + `shouldContain` [("health", Just "yellow")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatIndicesOptions + { catoHelp = Just True, + catoIncludeUnloadedSegments = Just False, + catoLocal = Just True, + catoPri = Just False, + catoVerbose = Just True + } + let ps = catIndicesOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("include_unloaded_segments", Just "false")] + ps `shouldContain` [("local", Just "true")] + ps `shouldContain` [("pri", Just "false")] + ps `shouldContain` [("v", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatIndicesOptions {catoMasterTimeout = Just (TimeUnitSeconds, 30)} + catIndicesOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + it "renders sort specs as comma-joined column[:direction] terms" $ do + let opts = + defaultCatIndicesOptions + { catoSort = + Just + ( CatSortSpec CatColDocsCount (Just CatSortDesc) + :| [CatSortSpec CatColIndex Nothing] + ) + } + catIndicesOptionsParams opts + `shouldContain` [("s", Just "docs.count:desc,index")] + + -- ------------------------------------------------------------------ -- + -- Renderer sanity for the leaf sum types -- + -- ------------------------------------------------------------------ -- + describe "CatBytesSize rendering" $ + it "covers every documented unit" $ + map + catBytesSizeText + [ CatBytesBytes, + CatBytesK, + CatBytesKb, + CatBytesM, + CatBytesMb, + CatBytesG, + CatBytesGb, + CatBytesT, + CatBytesTb, + CatBytesP, + CatBytesPb + ] + `shouldBe` ["b", "k", "kb", "m", "mb", "g", "gb", "t", "tb", "p", "pb"] + + -- ------------------------------------------------------------------ -- + -- CatIndicesRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatIndicesRow FromJSON" $ do + let fullRow = + "{\ + \ \"health\":\"green\",\ + \ \"status\":\"open\",\ + \ \"index\":\"bloodhound-tests-cat\",\ + \ \"uuid\":\"XYZ123\",\ + \ \"pri\":\"1\",\ + \ \"rep\":\"1\",\ + \ \"docs.count\":\"42\",\ + \ \"docs.deleted\":\"3\",\ + \ \"store.size\":\"5kb\",\ + \ \"pri.store.size\":\"5kb\",\ + \ \"dataset\":\"time-series\"\ + \}" + minimalRow = + "{\ + \ \"index\":\"bloodhound-tests-cat\"\ + \}" + subsetRow = + "{\ + \ \"index\":\"bloodhound-tests-cat\",\ + \ \"docs.count\":\"100\",\ + \ \"docs.deleted\":\"0\"\ + \}" + fractionalRow = + "{\ + \ \"index\":\"bloodhound-tests-cat\",\ + \ \"store.size\":\"5.2gb\",\ + \ \"pri.store.size\":\"5.2gb\"\ + \}" + bareRow = + "{\ + \ \"index\":\"bloodhound-tests-cat\",\ + \ \"store.size\":\"208\",\ + \ \"pri.store.size\":\"208\"\ + \}" + unknownStatusRow = + "{\ + \ \"index\":\"bloodhound-tests-cat\",\ + \ \"status\":\"warm\"\ + \}" + extraColumnRow = + "{\ + \ \"index\":\"bloodhound-tests-cat\",\ + \ \"memory.total\":\"1gb\"\ + \}" + badUnitRow = + "{\ + \ \"index\":\"bloodhound-tests-cat\",\ + \ \"store.size\":\"5qb\"\ + \}" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String CatIndicesRow of + Right row -> do + cirHealth row `shouldBe` Just CatIndexHealthGreen + cirStatus row `shouldBe` Just CatIndexStatusOpen + cirIndex row `shouldBe` [qqIndexName|bloodhound-tests-cat|] + cirUuid row `shouldBe` Just "XYZ123" + cirPrimaryShards row `shouldBe` Just 1 + cirReplicaCount row `shouldBe` Just 1 + cirDocsCount row `shouldBe` Just 42 + cirDocsDeleted row `shouldBe` Just 3 + cirStoreSize row `shouldBe` Just (Bytes 5, CatBytesKb) + cirPrimaryStoreSize row `shouldBe` Just (Bytes 5, CatBytesKb) + cirDataset row `shouldBe` Just "time-series" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only `index`" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String CatIndicesRow of + Right row -> do + cirIndex row `shouldBe` [qqIndexName|bloodhound-tests-cat|] + cirHealth row `shouldBe` Nothing + cirStatus row `shouldBe` Nothing + cirDocsCount row `shouldBe` Nothing + cirStoreSize row `shouldBe` Nothing + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a column-subset row (as produced by h=index,docs.count,docs.deleted)" $ + case parseEither parseJSON =<< eitherDecode subsetRow :: Either String CatIndicesRow of + Right row -> do + cirIndex row `shouldBe` [qqIndexName|bloodhound-tests-cat|] + cirDocsCount row `shouldBe` Just 100 + cirDocsDeleted row `shouldBe` Just 0 + cirStoreSize row `shouldBe` Nothing + Left e -> expectationFailure ("expected parse, got " <> e) + + it "rounds fractional magnitudes to the nearest whole byte" $ + case parseEither parseJSON =<< eitherDecode fractionalRow :: Either String CatIndicesRow of + Right row -> do + cirStoreSize row `shouldBe` Just (Bytes 5, CatBytesGb) + cirPrimaryStoreSize row `shouldBe` Just (Bytes 5, CatBytesGb) + Left e -> expectationFailure ("expected parse, got " <> e) + + it "treats a bare number as CatBytesBytes" $ + case parseEither parseJSON =<< eitherDecode bareRow :: Either String CatIndicesRow of + Right row -> + cirStoreSize row `shouldBe` Just (Bytes 208, CatBytesBytes) + Left e -> expectationFailure ("expected parse, got " <> e) + + it "preserves unknown status values via CatIndexStatusOther" $ + case parseEither parseJSON =<< eitherDecode unknownStatusRow :: Either String CatIndicesRow of + Right row -> cirStatus row `shouldBe` Just (CatIndexStatusOther "warm") + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in cirOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String CatIndicesRow of + Right row -> + -- 'cirOther' is the original JSON object with every key the + -- server sent, including ones we model and ones we don't. + case cirOther row of + Object o -> KM.keys o `shouldContain` ["index", "memory.total"] + _ -> expectationFailure "expected cirOther to be an Object" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "rejects an unrecognised byte-size suffix" $ + case parseEither parseJSON =<< eitherDecode badUnitRow :: Either String CatIndicesRow of + Right row -> expectationFailure ("expected parse failure, got " <> show row) + Left _ -> return () + + -- Defensive coverage: if OpenSearch emits a native JSON number for + -- an integer column (instead of the usual string), the parser + -- should still succeed by stringifying the integer-valued + -- Scientific without a trailing ".0". See 'parseAsString'. + it "tolerates a native JSON number for an integer column" $ + case parseEither parseJSON =<< eitherDecode "{\"index\":\"x\",\"docs.count\":42}" :: Either String CatIndicesRow of + Right row -> cirDocsCount row `shouldBe` Just 42 + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for store.size (treated as bare bytes)" $ + case parseEither parseJSON =<< eitherDecode "{\"index\":\"x\",\"store.size\":208}" :: Either String CatIndicesRow of + Right row -> cirStoreSize row `shouldBe` Just (Bytes 208, CatBytesBytes) + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catSizeInBytes -- + -- ------------------------------------------------------------------ -- + describe "catSizeInBytes" $ do + it "treats bare bytes as identity" $ + catSizeInBytes (Bytes 208, CatBytesBytes) `shouldBe` Bytes 208 + + it "applies the base-10 multiplier for k/m/g" $ do + catSizeInBytes (Bytes 5, CatBytesK) `shouldBe` Bytes 5000 + catSizeInBytes (Bytes 5, CatBytesM) `shouldBe` Bytes 5000000 + catSizeInBytes (Bytes 5, CatBytesG) `shouldBe` Bytes 5000000000 + + it "applies the base-2 multiplier for kb/mb/gb" $ do + catSizeInBytes (Bytes 5, CatBytesKb) `shouldBe` Bytes 5120 + catSizeInBytes (Bytes 5, CatBytesMb) `shouldBe` Bytes 5242880 + catSizeInBytes (Bytes 5, CatBytesGb) `shouldBe` Bytes 5368709120 + + -- ------------------------------------------------------------------ -- + -- Smoke test against a real backend (mirrors Test.ClusterHealthSpec) -- + -- ------------------------------------------------------------------ -- + describe "catIndicesWith integration" $ do + it "returns a row for an index we just created" $ + withTestEnv $ + withCatIndex [qqIndexName|bloodhound-tests-cat-indices|] $ \idx -> do + rows <- Client.catIndicesWith defaultCatIndicesOptions + liftIO $ + case filter ((== idx) . cirIndex) rows of + (row : _) -> do + cirIndex row `shouldBe` idx + cirStatus row `shouldSatisfy` (`elem` [Just CatIndexStatusOpen, Just CatIndexStatusClosed]) + [] -> + expectationFailure "expected at least one row for the freshly-created index" + + it "honours the h= parameter and leaves unrequested columns absent" $ + withTestEnv $ + withCatIndex [qqIndexName|bloodhound-tests-cat-indices-col|] $ \idx -> do + let opts = + defaultCatIndicesOptions + { catoColumns = Just (CatColIndex :| [CatColDocsCount]) + } + rows <- Client.catIndicesWith opts + liftIO $ + case filter ((== idx) . cirIndex) rows of + (row : _) -> do + cirIndex row `shouldBe` idx + cirDocsCount row `shouldSatisfy` isJust + -- Columns we did not request should be absent: + cirHealth row `shouldBe` Nothing + cirUuid row `shouldBe` Nothing + cirStoreSize row `shouldBe` Nothing + [] -> + expectationFailure "expected at least one row for the freshly-created index" + + -- ------------------------------------------------------------------ -- + -- catAliasesOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catAliasesOptionsParams URI rendering" $ do + it "defaultCatAliasesOptions emits only format=json" $ + catAliasesOptionsParams defaultCatAliasesOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatAliasesOptions + { caaColumns = Just (CatAliasColAlias :| [CatAliasColIndex, CatAliasColIsWriteIndex]) + } + catAliasesOptionsParams opts + `shouldContain` [("h", Just "alias,index,is_write_index")] + + it "renders unknown columns verbatim" $ do + let opts = + defaultCatAliasesOptions + { caaColumns = Just (CatAliasColOther "ts" :| []) + } + catAliasesOptionsParams opts + `shouldContain` [("h", Just "ts")] + + it "renders expand_wildcards as a comma-joined list" $ do + let opts = + defaultCatAliasesOptions + { caaExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + catAliasesOptionsParams opts + `shouldContain` [("expand_wildcards", Just "open,closed")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatAliasesOptions + { caaHelp = Just True, + caaLocal = Just False, + caaVerbose = Just True + } + let ps = catAliasesOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "false")] + ps `shouldContain` [("v", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatAliasesOptions {caaMasterTimeout = Just (TimeUnitSeconds, 30)} + catAliasesOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + it "renders sort specs as comma-joined column[:direction] terms" $ do + let opts = + defaultCatAliasesOptions + { caaSort = + Just + ( CatAliasesSortSpec CatAliasColAlias (Just CatSortDesc) + :| [CatAliasesSortSpec CatAliasColIndex Nothing] + ) + } + catAliasesOptionsParams opts + `shouldContain` [("s", Just "alias:desc,index")] + + -- ------------------------------------------------------------------ -- + -- Renderer sanity for the leaf sum types -- + -- ------------------------------------------------------------------ -- + describe "catAliasesColumnText rendering" $ + it "covers every documented column" $ + map + catAliasesColumnText + [ CatAliasColAlias, + CatAliasColIndex, + CatAliasColFilter, + CatAliasColRoutingIndex, + CatAliasColRoutingSearch, + CatAliasColIsWriteIndex + ] + `shouldBe` ["alias", "index", "filter", "routing.index", "routing.search", "is_write_index"] + + describe "catAliasesIsWriteIndexToText / FromText round-trip" $ do + it "encodes Nothing as \"-\"" $ + catAliasesIsWriteIndexToText Nothing `shouldBe` "-" + it "encodes Just True / Just False as \"true\" / \"false\"" $ do + catAliasesIsWriteIndexToText (Just True) `shouldBe` "true" + catAliasesIsWriteIndexToText (Just False) `shouldBe` "false" + it "round-trips every documented sentinel through FromText" $ do + catAliasesIsWriteIndexFromText "-" `shouldBe` Just Nothing + catAliasesIsWriteIndexFromText "true" `shouldBe` Just (Just True) + catAliasesIsWriteIndexFromText "false" `shouldBe` Just (Just False) + it "rejects unknown sentinels" $ + catAliasesIsWriteIndexFromText "maybe" `shouldBe` Nothing + + -- ------------------------------------------------------------------ -- + -- CatAliasesRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatAliasesRow FromJSON" $ do + let fullRow = + "{\ + \ \"alias\":\"bloodhound-tests-cat-alias-full\",\ + \ \"index\":\"bloodhound-tests-cat-aliases-src\",\ + \ \"filter\":\"*-*\",\ + \ \"routing.index\":\"1\",\ + \ \"routing.search\":\"2\",\ + \ \"is_write_index\":\"true\"\ + \}" + minimalRow = + "{\ + \ \"alias\":\"bloodhound-tests-cat-alias-min\",\ + \ \"index\":\"bloodhound-tests-cat-aliases-src\"\ + \}" + noWriteIndexRow = + "{\ + \ \"alias\":\"bloodhound-tests-cat-alias-nowrite\",\ + \ \"index\":\"bloodhound-tests-cat-aliases-src\",\ + \ \"is_write_index\":\"-\"\ + \}" + falseWriteIndexRow = + "{\ + \ \"alias\":\"bloodhound-tests-cat-alias-false\",\ + \ \"index\":\"bloodhound-tests-cat-aliases-src\",\ + \ \"is_write_index\":\"false\"\ + \}" + nativeBoolRow = + "{\ + \ \"alias\":\"bloodhound-tests-cat-alias-native\",\ + \ \"index\":\"bloodhound-tests-cat-aliases-src\",\ + \ \"is_write_index\":true\ + \}" + extraColumnRow = + "{\ + \ \"alias\":\"bloodhound-tests-cat-alias-extra\",\ + \ \"index\":\"bloodhound-tests-cat-aliases-src\",\ + \ \"ts\":\"1700000000000\"\ + \}" + badWriteIndexRow = + "{\ + \ \"alias\":\"bloodhound-tests-cat-alias-bad\",\ + \ \"index\":\"bloodhound-tests-cat-aliases-src\",\ + \ \"is_write_index\":\"maybe\"\ + \}" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String CatAliasesRow of + Right row -> do + carAlias row `shouldBe` [qqIndexName|bloodhound-tests-cat-alias-full|] + carIndex row `shouldBe` [qqIndexName|bloodhound-tests-cat-aliases-src|] + carFilter row `shouldBe` Just "*-*" + carRoutingIndex row `shouldBe` Just "1" + carRoutingSearch row `shouldBe` Just "2" + carIsWriteIndex row `shouldBe` Just True + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only alias and index" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String CatAliasesRow of + Right row -> do + carAlias row `shouldBe` [qqIndexName|bloodhound-tests-cat-alias-min|] + carIndex row `shouldBe` [qqIndexName|bloodhound-tests-cat-aliases-src|] + carFilter row `shouldBe` Nothing + carRoutingIndex row `shouldBe` Nothing + carRoutingSearch row `shouldBe` Nothing + carIsWriteIndex row `shouldBe` Nothing + Left e -> expectationFailure ("expected parse, got " <> e) + + it "decodes the \"-\" sentinel for is_write_index as Nothing" $ + case parseEither parseJSON =<< eitherDecode noWriteIndexRow :: Either String CatAliasesRow of + Right row -> carIsWriteIndex row `shouldBe` Nothing + Left e -> expectationFailure ("expected parse, got " <> e) + + it "decodes \"false\" for is_write_index as Just False" $ + case parseEither parseJSON =<< eitherDecode falseWriteIndexRow :: Either String CatAliasesRow of + Right row -> carIsWriteIndex row `shouldBe` Just False + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON bool for is_write_index" $ + case parseEither parseJSON =<< eitherDecode nativeBoolRow :: Either String CatAliasesRow of + Right row -> carIsWriteIndex row `shouldBe` Just True + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in carOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String CatAliasesRow of + Right row -> + case carOther row of + Object o -> KM.keys o `shouldContain` ["alias", "index", "ts"] + _ -> expectationFailure "expected carOther to be an Object" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "rejects an unrecognised is_write_index string" $ + case parseEither parseJSON =<< eitherDecode badWriteIndexRow :: Either String CatAliasesRow of + Right row -> expectationFailure ("expected parse failure, got " <> show row) + Left _ -> return () + + -- ------------------------------------------------------------------ -- + -- catAliasesWith integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catAliasesWith integration" $ do + it "returns a row for an alias we just created" + $ withTestEnv + $ withCatAlias + [qqIndexName|bloodhound-tests-cat-aliases-src|] + [qqIndexName|bloodhound-tests-cat-alias|] + $ \idx alias -> do + rows <- Client.catAliases + liftIO $ + case filter ((== alias) . carAlias) rows of + (row : _) -> do + carAlias row `shouldBe` alias + carIndex row `shouldBe` idx + carIsWriteIndex row `shouldSatisfy` isJust + [] -> + expectationFailure "expected at least one row for the freshly-created alias" + + it "filters by alias name via the / path segment" + $ withTestEnv + $ withCatAlias + [qqIndexName|bloodhound-tests-cat-aliases-filter-src|] + [qqIndexName|bloodhound-tests-cat-alias-filter|] + $ \_idx alias -> do + rows <- Client.catAliasesWith (Just (AliasName alias)) defaultCatAliasesOptions + liftIO $ do + -- At least one row matches the filter, and every returned + -- row points at our alias (the path-segment filter narrows + -- the result to a single name). + rows `shouldSatisfy` not . null + map carAlias rows `shouldSatisfy` all (== alias) + + it "honours the h= parameter and leaves unrequested columns absent" + $ withTestEnv + $ withCatAlias + [qqIndexName|bloodhound-tests-cat-aliases-col-src|] + [qqIndexName|bloodhound-tests-cat-alias-col|] + $ \idx alias -> do + let opts = + defaultCatAliasesOptions + { caaColumns = Just (CatAliasColAlias :| [CatAliasColIndex]) + } + rows <- Client.catAliasesWith (Just (AliasName alias)) opts + liftIO $ + case filter ((== alias) . carAlias) rows of + (row : _) -> do + -- Requested columns come back populated: + carAlias row `shouldBe` alias + carIndex row `shouldBe` idx + -- Columns we did not request should be absent: + carFilter row `shouldBe` Nothing + carRoutingIndex row `shouldBe` Nothing + carRoutingSearch row `shouldBe` Nothing + [] -> + expectationFailure "expected at least one row for the freshly-created alias" + + -- ------------------------------------------------------------------ -- + -- catAllocationOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catAllocationOptionsParams URI rendering" $ do + it "defaultCatAllocationOptions emits only format=json" $ + catAllocationOptionsParams defaultCatAllocationOptions + `shouldBe` [("format", Just "json")] + + it "renders bytes via catBytesSizeText" $ do + let opts = defaultCatAllocationOptions {caloBytes = Just CatBytesKb} + catAllocationOptionsParams opts + `shouldContain` [("bytes", Just "kb")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatAllocationOptions + { caloColumns = Just (CatAllocColNode :| [CatAllocColShards, CatAllocColDiskUsed]) + } + catAllocationOptionsParams opts + `shouldContain` [("h", Just "node,shards,disk.used")] + + it "renders unknown columns verbatim" $ do + let opts = + defaultCatAllocationOptions + { caloColumns = Just (CatAllocColOther "di" :| []) + } + catAllocationOptionsParams opts + `shouldContain` [("h", Just "di")] + + it "renders expand_wildcards as a comma-joined list" $ do + let opts = + defaultCatAllocationOptions + { caloExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + catAllocationOptionsParams opts + `shouldContain` [("expand_wildcards", Just "open,closed")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatAllocationOptions + { caloHelp = Just True, + caloLocal = Just False, + caloVerbose = Just True + } + let ps = catAllocationOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "false")] + ps `shouldContain` [("v", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatAllocationOptions {caloMasterTimeout = Just (TimeUnitSeconds, 30)} + catAllocationOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + it "renders sort specs as comma-joined column[:direction] terms" $ do + let opts = + defaultCatAllocationOptions + { caloSort = + Just + ( CatAllocationSortSpec CatAllocColShards (Just CatSortDesc) + :| [CatAllocationSortSpec CatAllocColNode Nothing] + ) + } + catAllocationOptionsParams opts + `shouldContain` [("s", Just "shards:desc,node")] + + -- ------------------------------------------------------------------ -- + -- Renderer sanity for the leaf sum types -- + -- ------------------------------------------------------------------ -- + describe "catAllocationColumnText rendering" $ + it "covers every documented column" $ + map + catAllocationColumnText + [ CatAllocColShards, + CatAllocColShardsUndesired, + CatAllocColWriteLoadForecast, + CatAllocColDiskIndicesForecast, + CatAllocColDiskIndices, + CatAllocColDiskUsed, + CatAllocColDiskAvail, + CatAllocColDiskTotal, + CatAllocColDiskPercent, + CatAllocColHost, + CatAllocColIp, + CatAllocColNode, + CatAllocColNodeRole + ] + `shouldBe` [ "shards", + "shards.undesired", + "write_load.forecast", + "disk.indices.forecast", + "disk.indices", + "disk.used", + "disk.avail", + "disk.total", + "disk.percent", + "host", + "ip", + "node", + "node.role" + ] + + describe "catShardsUndesiredFromText / ToText round-trip" $ do + it "decodes \"-1\" as NotApplicable" $ + catShardsUndesiredFromText "-1" `shouldBe` Just CatShardsUndesiredNotApplicable + it "decodes non-negative integers as Count" $ do + catShardsUndesiredFromText "0" `shouldBe` Just (CatShardsUndesiredCount 0) + catShardsUndesiredFromText "42" `shouldBe` Just (CatShardsUndesiredCount 42) + it "rejects non-sentinel negative values and garbage" $ do + catShardsUndesiredFromText "-2" `shouldBe` (Nothing :: Maybe CatShardsUndesired) + catShardsUndesiredFromText "abc" `shouldBe` (Nothing :: Maybe CatShardsUndesired) + it "round-trips every constructor through ToText" $ do + catShardsUndesiredToText CatShardsUndesiredNotApplicable `shouldBe` "-1" + catShardsUndesiredToText (CatShardsUndesiredCount 7) `shouldBe` "7" + + -- ------------------------------------------------------------------ -- + -- CatAllocationRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatAllocationRow FromJSON" $ do + let fullRow = + "{\ + \ \"shards\":\"1\",\ + \ \"shards.undesired\":\"0\",\ + \ \"write_load.forecast\":\"0.0\",\ + \ \"disk.indices.forecast\":\"260b\",\ + \ \"disk.indices\":\"260b\",\ + \ \"disk.used\":\"47.3gb\",\ + \ \"disk.avail\":\"43.4gb\",\ + \ \"disk.total\":\"100.7gb\",\ + \ \"disk.percent\":\"46\",\ + \ \"host\":\"127.0.0.1\",\ + \ \"ip\":\"127.0.0.1\",\ + \ \"node\":\"CSUXak2\",\ + \ \"node.role\":\"himrst\"\ + \}" + minimalRow = + "{\ + \ \"node\":\"bloodhound-tests-cat-node\"\ + \}" + subsetRow = + "{\ + \ \"node\":\"bloodhound-tests-cat-node\",\ + \ \"shards\":\"4\",\ + \ \"disk.indices\":\"100kb\"\ + \}" + sentinelRow = + "{\ + \ \"node\":\"bloodhound-tests-cat-node\",\ + \ \"shards.undesired\":\"-1\"\ + \}" + fractionalRow = + "{\ + \ \"node\":\"bloodhound-tests-cat-node\",\ + \ \"disk.used\":\"5.2gb\",\ + \ \"disk.avail\":\"5.2gb\"\ + \}" + bareRow = + "{\ + \ \"node\":\"bloodhound-tests-cat-node\",\ + \ \"disk.used\":\"208\",\ + \ \"disk.avail\":\"208\"\ + \}" + extraColumnRow = + "{\ + \ \"node\":\"bloodhound-tests-cat-node\",\ + \ \"ragney.future\":\"xyz\"\ + \}" + badUnitRow = + "{\ + \ \"node\":\"bloodhound-tests-cat-node\",\ + \ \"disk.used\":\"5qb\"\ + \}" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String CatAllocationRow of + Right row -> do + calrShards row `shouldBe` Just 1 + calrShardsUndesired row `shouldBe` Just (CatShardsUndesiredCount 0) + calrWriteLoadForecast row `shouldBe` Just 0.0 + calrDiskIndicesForecast row `shouldBe` Just (Bytes 260, CatBytesBytes) + calrDiskIndices row `shouldBe` Just (Bytes 260, CatBytesBytes) + calrDiskUsed row `shouldBe` Just (Bytes 47, CatBytesGb) + calrDiskAvail row `shouldBe` Just (Bytes 43, CatBytesGb) + calrDiskTotal row `shouldBe` Just (Bytes 101, CatBytesGb) + calrDiskPercent row `shouldBe` Just 46 + calrHost row `shouldBe` Just "127.0.0.1" + calrIp row `shouldBe` Just "127.0.0.1" + calrNode row `shouldBe` "CSUXak2" + calrNodeRole row `shouldBe` Just "himrst" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only `node`" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String CatAllocationRow of + Right row -> do + calrNode row `shouldBe` "bloodhound-tests-cat-node" + calrShards row `shouldBe` Nothing + calrDiskUsed row `shouldBe` Nothing + calrDiskPercent row `shouldBe` Nothing + calrNodeRole row `shouldBe` Nothing + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a column-subset row (as produced by h=node,shards,disk.indices)" $ + case parseEither parseJSON =<< eitherDecode subsetRow :: Either String CatAllocationRow of + Right row -> do + calrNode row `shouldBe` "bloodhound-tests-cat-node" + calrShards row `shouldBe` Just 4 + calrDiskIndices row `shouldBe` Just (Bytes 100, CatBytesKb) + calrDiskUsed row `shouldBe` Nothing + Left e -> expectationFailure ("expected parse, got " <> e) + + it "decodes the \"-1\" sentinel for shards.undesired as NotApplicable" $ + case parseEither parseJSON =<< eitherDecode sentinelRow :: Either String CatAllocationRow of + Right row -> calrShardsUndesired row `shouldBe` Just CatShardsUndesiredNotApplicable + Left e -> expectationFailure ("expected parse, got " <> e) + + it "rounds fractional disk magnitudes to the nearest whole byte" $ + case parseEither parseJSON =<< eitherDecode fractionalRow :: Either String CatAllocationRow of + Right row -> do + calrDiskUsed row `shouldBe` Just (Bytes 5, CatBytesGb) + calrDiskAvail row `shouldBe` Just (Bytes 5, CatBytesGb) + Left e -> expectationFailure ("expected parse, got " <> e) + + it "treats a bare number as CatBytesBytes" $ + case parseEither parseJSON =<< eitherDecode bareRow :: Either String CatAllocationRow of + Right row -> do + calrDiskUsed row `shouldBe` Just (Bytes 208, CatBytesBytes) + calrDiskAvail row `shouldBe` Just (Bytes 208, CatBytesBytes) + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in calrOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String CatAllocationRow of + Right row -> + case calrOther row of + Object o -> KM.keys o `shouldContain` ["node", "ragney.future"] + _ -> expectationFailure "expected calrOther to be an Object" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "rejects an unrecognised byte-size suffix" $ + case parseEither parseJSON =<< eitherDecode badUnitRow :: Either String CatAllocationRow of + Right row -> expectationFailure ("expected parse failure, got " <> show row) + Left _ -> return () + + -- Defensive coverage: native JSON numbers should be tolerated for + -- the integer columns, matching the CatIndicesRow precedent. + it "tolerates a native JSON number for an integer column (shards)" $ + case parseEither parseJSON =<< eitherDecode "{\"node\":\"x\",\"shards\":7}" :: Either String CatAllocationRow of + Right row -> calrShards row `shouldBe` Just 7 + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for disk.percent" $ + case parseEither parseJSON =<< eitherDecode "{\"node\":\"x\",\"disk.percent\":50}" :: Either String CatAllocationRow of + Right row -> calrDiskPercent row `shouldBe` Just 50 + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for disk.used (treated as bare bytes)" $ + case parseEither parseJSON =<< eitherDecode "{\"node\":\"x\",\"disk.used\":208}" :: Either String CatAllocationRow of + Right row -> calrDiskUsed row `shouldBe` Just (Bytes 208, CatBytesBytes) + Left e -> expectationFailure ("expected parse, got " <> e) + + -- Real-world shape: ES emits a synthetic "UNASSIGNED" pseudo-row + -- for unassigned shards, with the disk columns null. Locks in that + -- the parser tolerates the null disk values and preserves the + -- documented pseudo-node name verbatim. + it "parses the UNASSIGNED pseudo-node row with null disk columns" $ + case parseEither parseJSON =<< eitherDecode "{\"node\":\"UNASSIGNED\",\"shards\":\"3\",\"disk.percent\":null}" :: Either String CatAllocationRow of + Right row -> do + calrNode row `shouldBe` "UNASSIGNED" + calrShards row `shouldBe` Just 3 + calrDiskPercent row `shouldBe` Nothing + calrDiskUsed row `shouldBe` Nothing + calrDiskIndices row `shouldBe` Nothing + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON -1 for shards.undesired as NotApplicable" $ + case parseEither parseJSON =<< eitherDecode "{\"node\":\"x\",\"shards.undesired\":-1}" :: Either String CatAllocationRow of + Right row -> calrShardsUndesired row `shouldBe` Just CatShardsUndesiredNotApplicable + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for write_load.forecast (fractional)" $ + case parseEither parseJSON =<< eitherDecode "{\"node\":\"x\",\"write_load.forecast\":1.5}" :: Either String CatAllocationRow of + Right row -> calrWriteLoadForecast row `shouldBe` Just 1.5 + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catAllocationWith integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catAllocationWith integration" $ do + it "returns at least one row after creating an index" $ + withTestEnv $ + withCatIndex [qqIndexName|bloodhound-tests-cat-allocation|] $ + \_idx -> do + rows <- Client.catAllocation + liftIO $ + rows `shouldSatisfy` (not . null) + + it "filters by node name via the / path segment" $ + withTestEnv $ + withCatIndex [qqIndexName|bloodhound-tests-cat-allocation-filter|] $ + \_idx -> do + allRows <- Client.catAllocation + -- Exclude the synthetic UNASSIGNED pseudo-row, which has no + -- real node name to filter by and would produce an empty + -- (and confusing) result if pinned. + case filter (\r -> calrNode r /= "UNASSIGNED") allRows of + [] -> liftIO $ expectationFailure "expected at least one data node row" + (firstRow : _) -> do + let name = calrNode firstRow + filtered <- Client.catAllocationWith (Just (NodeName name)) defaultCatAllocationOptions + -- OpenSearch's /_cat/allocation/ includes the + -- synthetic UNASSIGNED pseudo-row even when filtering by + -- node id (ES does not); strip it before asserting so + -- the test passes on both families. + let realFiltered = filter (\r -> calrNode r /= "UNASSIGNED") filtered + liftIO $ do + realFiltered `shouldSatisfy` (not . null) + map calrNode realFiltered `shouldSatisfy` all (== name) + + -- ------------------------------------------------------------------ -- + -- catCountOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catCountOptionsParams URI rendering" $ do + it "defaultCatCountOptions emits only format=json" $ + catCountOptionsParams defaultCatCountOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatCountOptions + { ccoColumns = Just (CatCountColEpoch :| [CatCountColCount]) + } + catCountOptionsParams opts + `shouldContain` [("h", Just "epoch,count")] + + it "renders unknown columns verbatim" $ do + let opts = + defaultCatCountOptions + { ccoColumns = Just (CatCountColOther "t" :| []) + } + catCountOptionsParams opts + `shouldContain` [("h", Just "t")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatCountOptions + { ccoHelp = Just True, + ccoLocal = Just False, + ccoVerbose = Just True + } + let ps = catCountOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "false")] + ps `shouldContain` [("v", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatCountOptions {ccoMasterTimeout = Just (TimeUnitSeconds, 30)} + catCountOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + describe "catCountColumnText rendering" $ + it "covers every documented column" $ + map + catCountColumnText + [CatCountColEpoch, CatCountColTimestamp, CatCountColCount] + `shouldBe` ["epoch", "timestamp", "count"] + + -- ------------------------------------------------------------------ -- + -- CatCountRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatCountRow FromJSON" $ do + let fullRow = + "[{\"epoch\":\"1782112550\",\"timestamp\":\"07:15:50\",\"count\":\"1217\"}]" + minimalRow = "[{\"count\":\"0\"}]" + extraColumnRow = "[{\"count\":\"5\",\"ragney.future\":\"xyz\"}]" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatCountRow] of + Right (row : _) -> do + ccrEpoch row `shouldBe` Just 1782112550 + ccrTimestamp row `shouldBe` Just "07:15:50" + ccrCount row `shouldBe` Just 1217 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only count" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String [CatCountRow] of + Right (row : _) -> ccrCount row `shouldBe` Just 0 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in ccrOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatCountRow] of + Right (row : _) -> + case ccrOther row of + Object o -> KM.keys o `shouldContain` ["count", "ragney.future"] + _ -> expectationFailure "expected ccrOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for count" $ + case parseEither parseJSON =<< eitherDecode "[{\"count\":42}]" :: Either String [CatCountRow] of + Right (row : _) -> ccrCount row `shouldBe` Just 42 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for epoch" $ + case parseEither parseJSON =<< eitherDecode "[{\"epoch\":1782112550}]" :: Either String [CatCountRow] of + Right (row : _) -> ccrEpoch row `shouldBe` Just 1782112550 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catCountWith integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catCountWith integration" $ + it "returns a count row after creating an index" $ + withTestEnv $ + withCatIndex [qqIndexName|bloodhound-tests-cat-count|] $ + \_idx -> do + rows <- Client.catCount + liftIO $ + rows `shouldSatisfy` (not . null) + + -- ------------------------------------------------------------------ -- + -- catMasterOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catMasterOptionsParams URI rendering" $ do + it "defaultCatMasterOptions emits only format=json" $ + catMasterOptionsParams defaultCatMasterOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatMasterOptions + { cmoColumns = Just (CatMasterColId :| [CatMasterColNode]) + } + catMasterOptionsParams opts + `shouldContain` [("h", Just "id,node")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatMasterOptions + { cmoHelp = Just True, + cmoLocal = Just True + } + let ps = catMasterOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatMasterOptions {cmoMasterTimeout = Just (TimeUnitSeconds, 30)} + catMasterOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + describe "catMasterColumnText rendering" $ + it "covers every documented column" $ + map + catMasterColumnText + [CatMasterColId, CatMasterColHost, CatMasterColIp, CatMasterColNode] + `shouldBe` ["id", "host", "ip", "node"] + + -- ------------------------------------------------------------------ -- + -- CatMasterRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatMasterRow FromJSON" $ do + let fullRow = + "[{\"id\":\"CBH3C4RiQcK3CxFvPJyFtQ\",\"host\":\"172.19.0.7\",\"ip\":\"172.19.0.7\",\"node\":\"elasticsearch1\"}]" + minimalRow = "[{\"node\":\"bloodhound-tests-cat-node\"}]" + extraColumnRow = "[{\"node\":\"x\",\"ragney.future\":\"xyz\"}]" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatMasterRow] of + Right (row : _) -> do + cmrId row `shouldBe` Just (FullNodeId "CBH3C4RiQcK3CxFvPJyFtQ") + cmrHost row `shouldBe` Just "172.19.0.7" + cmrIp row `shouldBe` Just "172.19.0.7" + cmrNode row `shouldBe` Just "elasticsearch1" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only node" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String [CatMasterRow] of + Right (row : _) -> do + cmrNode row `shouldBe` Just "bloodhound-tests-cat-node" + cmrId row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in cmrOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatMasterRow] of + Right (row : _) -> + case cmrOther row of + Object o -> KM.keys o `shouldContain` ["node", "ragney.future"] + _ -> expectationFailure "expected cmrOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catMasterWith integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catMasterWith integration" $ + it "returns at least one master row" $ + withTestEnv $ do + rows <- Client.catMaster + liftIO $ + rows `shouldSatisfy` (not . null) + + -- ------------------------------------------------------------------ -- + -- catHealthOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catHealthOptionsParams URI rendering" $ do + it "defaultCatHealthOptions emits only format=json" $ + catHealthOptionsParams defaultCatHealthOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatHealthOptions + { chtoColumns = Just (CatHealthColCluster :| [CatHealthColStatus]) + } + catHealthOptionsParams opts + `shouldContain` [("h", Just "cluster,status")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatHealthOptions + { chtoHelp = Just True, + chtoLocal = Just False, + chtoTs = Just True, + chtoVerbose = Just True + } + let ps = catHealthOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "false")] + ps `shouldContain` [("ts", Just "true")] + ps `shouldContain` [("v", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatHealthOptions {chtoMasterTimeout = Just (TimeUnitSeconds, 30)} + catHealthOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + describe "catHealthColumnText rendering" $ + it "covers every documented column" $ + map + catHealthColumnText + [ CatHealthColEpoch, + CatHealthColTimestamp, + CatHealthColCluster, + CatHealthColStatus, + CatHealthColNodeTotal, + CatHealthColNodeData, + CatHealthColShards, + CatHealthColPri, + CatHealthColRelo, + CatHealthColInit, + CatHealthColUnassign, + CatHealthColPendingTasks, + CatHealthColMaxTaskWaitTime, + CatHealthColActiveShardsPercent + ] + `shouldBe` [ "epoch", + "timestamp", + "cluster", + "status", + "node.total", + "node.data", + "shards", + "pri", + "relo", + "init", + "unassign", + "pending_tasks", + "max_task_wait_time", + "active_shards_percent" + ] + + describe "catHealthStatusFromText / ToText round-trip" $ do + it "decodes green/yellow/red" $ do + catHealthStatusFromText "green" `shouldBe` Just CatHealthStatusGreen + catHealthStatusFromText "yellow" `shouldBe` Just CatHealthStatusYellow + catHealthStatusFromText "red" `shouldBe` Just CatHealthStatusRed + it "rejects unknown values" $ + catHealthStatusFromText "purple" `shouldBe` (Nothing :: Maybe CatHealthStatus) + it "round-trips every constructor through ToText" $ do + catHealthStatusText CatHealthStatusGreen `shouldBe` "green" + catHealthStatusText CatHealthStatusYellow `shouldBe` "yellow" + catHealthStatusText CatHealthStatusRed `shouldBe` "red" + + -- ------------------------------------------------------------------ -- + -- CatHealthRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatHealthRow FromJSON" $ do + let fullRow = + "[{\"epoch\":\"1782112550\",\"timestamp\":\"07:15:50\",\"cluster\":\"docker-cluster\",\"status\":\"green\",\"node.total\":\"1\",\"node.data\":\"1\",\"shards\":\"14\",\"pri\":\"14\",\"relo\":\"0\",\"init\":\"0\",\"unassign\":\"0\",\"pending_tasks\":\"0\",\"max_task_wait_time\":\"-\",\"active_shards_percent\":\"100.0%\"}]" + minimalRow = "[{\"cluster\":\"bloodhound-tests\"}]" + extraColumnRow = "[{\"cluster\":\"x\",\"ragney.future\":\"xyz\"}]" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatHealthRow] of + Right (row : _) -> do + chrEpoch row `shouldBe` Just 1782112550 + chrTimestamp row `shouldBe` Just "07:15:50" + chrCluster row `shouldBe` Just "docker-cluster" + chrStatus row `shouldBe` Just CatHealthStatusGreen + chrNodeTotal row `shouldBe` Just 1 + chrNodeData row `shouldBe` Just 1 + chrShards row `shouldBe` Just 14 + chrPri row `shouldBe` Just 14 + chrRelo row `shouldBe` Just 0 + chrInit row `shouldBe` Just 0 + chrUnassign row `shouldBe` Just 0 + chrPendingTasks row `shouldBe` Just 0 + chrMaxTaskWaitTime row `shouldBe` Just "-" + chrActiveShardsPercent row `shouldBe` Just "100.0%" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only cluster" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String [CatHealthRow] of + Right (row : _) -> do + chrCluster row `shouldBe` Just "bloodhound-tests" + chrStatus row `shouldBe` Nothing + chrShards row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in chrOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatHealthRow] of + Right (row : _) -> + case chrOther row of + Object o -> KM.keys o `shouldContain` ["cluster", "ragney.future"] + _ -> expectationFailure "expected chrOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for shards" $ + case parseEither parseJSON =<< eitherDecode "[{\"cluster\":\"x\",\"shards\":14}]" :: Either String [CatHealthRow] of + Right (row : _) -> chrShards row `shouldBe` Just 14 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "rejects an unrecognised status value" $ + case parseEither parseJSON =<< eitherDecode "[{\"cluster\":\"x\",\"status\":\"purple\"}]" :: Either String [CatHealthRow] of + Right _ -> expectationFailure "expected parse failure" + Left _ -> return () + + -- ------------------------------------------------------------------ -- + -- catHealthWith integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catHealthWith integration" $ + it "returns at least one health row" $ + withTestEnv $ do + rows <- Client.catHealth + liftIO $ + rows `shouldSatisfy` (not . null) + + -- ------------------------------------------------------------------ -- + -- catPendingTasksOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catPendingTasksOptionsParams URI rendering" $ do + it "defaultCatPendingTasksOptions emits only format=json" $ + catPendingTasksOptionsParams defaultCatPendingTasksOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatPendingTasksOptions + { cptoColumns = Just (CatPendingTasksColPriority :| [CatPendingTasksColSource]) + } + catPendingTasksOptionsParams opts + `shouldContain` [("h", Just "priority,source")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatPendingTasksOptions + { cptoHelp = Just True, + cptoLocal = Just True + } + let ps = catPendingTasksOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatPendingTasksOptions {cptoMasterTimeout = Just (TimeUnitSeconds, 30)} + catPendingTasksOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + describe "catPendingTasksColumnText rendering" $ + it "covers every documented column" $ + map + catPendingTasksColumnText + [ CatPendingTasksColInsertOrder, + CatPendingTasksColTimeInQueue, + CatPendingTasksColPriority, + CatPendingTasksColSource + ] + `shouldBe` ["insertOrder", "timeInQueue", "priority", "source"] + + -- ------------------------------------------------------------------ -- + -- CatPendingTasksRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatPendingTasksRow FromJSON" $ do + let fullRow = + "[{\"insertOrder\":\"1\",\"timeInQueue\":\"500ms\",\"priority\":\"URGENT\",\"source\":\"create-index [foo]\"}]" + minimalRow = "[{\"source\":\"x\"}]" + extraColumnRow = "[{\"source\":\"x\",\"ragney.future\":\"xyz\"}]" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatPendingTasksRow] of + Right (row : _) -> do + cptrInsertOrder row `shouldBe` Just 1 + cptrTimeInQueue row `shouldBe` Just "500ms" + cptrPriority row `shouldBe` Just PendingTaskUrgent + cptrSource row `shouldBe` Just "create-index [foo]" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only source" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String [CatPendingTasksRow] of + Right (row : _) -> do + cptrSource row `shouldBe` Just "x" + cptrPriority row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in cptrOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatPendingTasksRow] of + Right (row : _) -> + case cptrOther row of + Object o -> do + KM.keys o `shouldContain` ["source"] + KM.keys o `shouldContain` ["ragney.future"] + _ -> expectationFailure "expected cptrOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for insertOrder" $ + case parseEither parseJSON =<< eitherDecode "[{\"insertOrder\":42}]" :: Either String [CatPendingTasksRow] of + Right (row : _) -> cptrInsertOrder row `shouldBe` Just 42 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses an empty pending-tasks list" $ + case parseEither parseJSON =<< eitherDecode "[]" :: Either String [CatPendingTasksRow] of + Right rows -> rows `shouldBe` [] + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catPendingTasksWith integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catPendingTasksWith integration" $ + it "parses the pending-tasks list without error" $ + withTestEnv $ do + _rows <- Client.catPendingTasks + return () + + -- ------------------------------------------------------------------ -- + -- catPluginsOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catPluginsOptionsParams URI rendering" $ do + it "defaultCatPluginsOptions emits only format=json" $ + catPluginsOptionsParams defaultCatPluginsOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatPluginsOptions + { cpoColumns = Just (CatPluginsColComponent :| [CatPluginsColVersion]) + } + catPluginsOptionsParams opts + `shouldContain` [("h", Just "component,version")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatPluginsOptions + { cpoHelp = Just True, + cpoLocal = Just True + } + let ps = catPluginsOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatPluginsOptions {cpoMasterTimeout = Just (TimeUnitSeconds, 30)} + catPluginsOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + describe "catPluginsColumnText rendering" $ + it "covers every documented column" $ + map + catPluginsColumnText + [ CatPluginsColId, + CatPluginsColName, + CatPluginsColComponent, + CatPluginsColVersion, + CatPluginsColDescription, + CatPluginsColType + ] + `shouldBe` ["id", "name", "component", "version", "description", "type"] + + -- ------------------------------------------------------------------ -- + -- CatPluginsRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatPluginsRow FromJSON" $ do + let fullRow = + "[{\"id\":\"CBH3C4RiQcK3CxFvPJyFtQ\",\"name\":\"elasticsearch1\",\"component\":\"analysis-icu\",\"version\":\"7.17.25\",\"description\":\"The ICU Analysis plugin\",\"type\":\"isolated\"}]" + minimalRow = "[{\"component\":\"x\"}]" + extraColumnRow = "[{\"component\":\"x\",\"ragney.future\":\"xyz\"}]" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatPluginsRow] of + Right (row : _) -> do + cprId row `shouldBe` Just (FullNodeId "CBH3C4RiQcK3CxFvPJyFtQ") + cprName row `shouldBe` Just "elasticsearch1" + cprComponent row `shouldBe` Just "analysis-icu" + cprVersion row `shouldBe` Just "7.17.25" + cprDescription row `shouldBe` Just "The ICU Analysis plugin" + cprType row `shouldBe` Just "isolated" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only component" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String [CatPluginsRow] of + Right (row : _) -> do + cprComponent row `shouldBe` Just "x" + cprId row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in cprOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatPluginsRow] of + Right (row : _) -> + case cprOther row of + Object o -> KM.keys o `shouldContain` ["component", "ragney.future"] + _ -> expectationFailure "expected cprOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catPluginsWith integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catPluginsWith integration" $ + it "parses the plugins list without error" $ + withTestEnv $ do + _rows <- Client.catPlugins + return () + + -- ------------------------------------------------------------------ -- + -- catTemplatesOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catTemplatesOptionsParams URI rendering" $ do + it "defaultCatTemplatesOptions emits only format=json" $ + catTemplatesOptionsParams defaultCatTemplatesOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatTemplatesOptions + { ctmoColumns = Just (CatTemplatesColName :| [CatTemplatesColOrder]) + } + catTemplatesOptionsParams opts + `shouldContain` [("h", Just "name,order")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatTemplatesOptions + { ctmoHelp = Just True, + ctmoLocal = Just True + } + let ps = catTemplatesOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatTemplatesOptions {ctmoMasterTimeout = Just (TimeUnitSeconds, 30)} + catTemplatesOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + describe "catTemplatesColumnText rendering" $ + it "covers every documented column" $ + map + catTemplatesColumnText + [ CatTemplatesColName, + CatTemplatesColIndexPatterns, + CatTemplatesColOrder, + CatTemplatesColVersion, + CatTemplatesColComposedOf + ] + `shouldBe` ["name", "index_patterns", "order", "version", "composed_of"] + + -- ------------------------------------------------------------------ -- + -- CatTemplatesRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatTemplatesRow FromJSON" $ do + let fullRow = + "[{\"name\":\".monitoring-beats\",\"index_patterns\":\"[.monitoring-beats-7-*]\",\"order\":\"0\",\"version\":\"7140099\",\"composed_of\":\"\"}]" + minimalRow = "[{\"name\":\"bloodhound-tests\"}]" + extraColumnRow = "[{\"name\":\"x\",\"ragney.future\":\"xyz\"}]" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatTemplatesRow] of + Right (row : _) -> do + ctprName row `shouldBe` Just ".monitoring-beats" + ctprIndexPatterns row `shouldBe` Just "[.monitoring-beats-7-*]" + ctprOrder row `shouldBe` Just 0 + ctprVersion row `shouldBe` Just 7140099 + ctprComposedOf row `shouldBe` Just "" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only name" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String [CatTemplatesRow] of + Right (row : _) -> do + ctprName row `shouldBe` Just "bloodhound-tests" + ctprOrder row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in ctprOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatTemplatesRow] of + Right (row : _) -> + case ctprOther row of + Object o -> KM.keys o `shouldContain` ["name", "ragney.future"] + _ -> expectationFailure "expected ctprOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for order" $ + case parseEither parseJSON =<< eitherDecode "[{\"name\":\"x\",\"order\":3}]" :: Either String [CatTemplatesRow] of + Right (row : _) -> ctprOrder row `shouldBe` Just 3 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for version" $ + case parseEither parseJSON =<< eitherDecode "[{\"name\":\"x\",\"version\":7140099}]" :: Either String [CatTemplatesRow] of + Right (row : _) -> ctprVersion row `shouldBe` Just 7140099 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catTemplatesWith integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catTemplatesWith integration" $ + it "returns at least one template row" $ + withTestEnv $ do + let tplName = TemplateName "bloodhound-tests-cat-templates" + TemplateName tplText = tplName + bracket_ + ( void $ + performBHRequest $ + putTemplate + (IndexTemplate [IndexPattern "bloodhound-tests-cat-templates-*"] Nothing (object [])) + tplName + ) + (void $ tryPerformBHRequest $ deleteTemplate tplName) + $ do + rows <- Client.catTemplates + liftIO $ + map ctprName rows `shouldSatisfy` elem (Just tplText) + + -- ------------------------------------------------------------------ -- + -- catThreadPoolOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catThreadPoolOptionsParams URI rendering" $ do + it "defaultCatThreadPoolOptions emits only format=json" $ + catThreadPoolOptionsParams defaultCatThreadPoolOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatThreadPoolOptions + { ctpoColumns = Just (CatThreadPoolColName :| [CatThreadPoolColActive]) + } + catThreadPoolOptionsParams opts + `shouldContain` [("h", Just "name,active")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatThreadPoolOptions + { ctpoHelp = Just True, + ctpoLocal = Just True + } + let ps = catThreadPoolOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatThreadPoolOptions {ctpoMasterTimeout = Just (TimeUnitSeconds, 30)} + catThreadPoolOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + describe "catThreadPoolColumnText rendering" $ + it "covers every documented column" $ + map + catThreadPoolColumnText + [ CatThreadPoolColNodeName, + CatThreadPoolColNodeId, + CatThreadPoolColEphemeralNodeId, + CatThreadPoolColPid, + CatThreadPoolColHost, + CatThreadPoolColIp, + CatThreadPoolColPort, + CatThreadPoolColName, + CatThreadPoolColType, + CatThreadPoolColActive, + CatThreadPoolColPoolSize, + CatThreadPoolColQueue, + CatThreadPoolColQueueSize, + CatThreadPoolColRejected, + CatThreadPoolColLargest, + CatThreadPoolColCompleted, + CatThreadPoolColCore, + CatThreadPoolColMax, + CatThreadPoolColSize, + CatThreadPoolColKeepAlive + ] + `shouldBe` [ "node_name", + "node_id", + "ephemeral_node_id", + "pid", + "host", + "ip", + "port", + "name", + "type", + "active", + "pool_size", + "queue", + "queue_size", + "rejected", + "largest", + "completed", + "core", + "max", + "size", + "keep_alive" + ] + + -- ------------------------------------------------------------------ -- + -- CatThreadPoolRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatThreadPoolRow FromJSON" $ do + let fullRow = + "[{\"node_name\":\"elasticsearch1\",\"node_id\":\"CBH3C4RiQcK3CxFvPJyFtQ\",\"ephemeral_node_id\":\"2rK7\",\"pid\":\"8\",\"host\":\"172.19.0.7\",\"ip\":\"172.19.0.7\",\"port\":\"9300\",\"name\":\"analyze\",\"type\":\"fixed\",\"active\":\"0\",\"pool_size\":\"1\",\"queue\":\"0\",\"queue_size\":\"16\",\"rejected\":\"0\",\"largest\":\"1\",\"completed\":\"5\",\"core\":null,\"max\":null,\"size\":\"1\",\"keep_alive\":null}]" + minimalRow = "[{\"name\":\"analyze\"}]" + extraColumnRow = "[{\"name\":\"x\",\"ragney.future\":\"xyz\"}]" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatThreadPoolRow] of + Right (row : _) -> do + ctprlNodeName row `shouldBe` Just "elasticsearch1" + ctprlNodeId row `shouldBe` Just "CBH3C4RiQcK3CxFvPJyFtQ" + ctprlEphemeralNodeId row `shouldBe` Just "2rK7" + ctprlPid row `shouldBe` Just 8 + ctprlHost row `shouldBe` Just "172.19.0.7" + ctprlIp row `shouldBe` Just "172.19.0.7" + ctprlPort row `shouldBe` Just 9300 + ctprlName row `shouldBe` Just "analyze" + ctprlType row `shouldBe` Just "fixed" + ctprlActive row `shouldBe` Just 0 + ctprlPoolSize row `shouldBe` Just 1 + ctprlQueue row `shouldBe` Just 0 + ctprlQueueSize row `shouldBe` Just 16 + ctprlRejected row `shouldBe` Just 0 + ctprlLargest row `shouldBe` Just 1 + ctprlCompleted row `shouldBe` Just 5 + ctprlCore row `shouldBe` Nothing + ctprlMax row `shouldBe` Nothing + ctprlSize row `shouldBe` Just 1 + ctprlKeepAlive row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only name" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String [CatThreadPoolRow] of + Right (row : _) -> do + ctprlName row `shouldBe` Just "analyze" + ctprlActive row `shouldBe` Nothing + ctprlPid row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in ctprlOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatThreadPoolRow] of + Right (row : _) -> + case ctprlOther row of + Object o -> KM.keys o `shouldContain` ["name", "ragney.future"] + _ -> expectationFailure "expected ctprlOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for active" $ + case parseEither parseJSON =<< eitherDecode "[{\"name\":\"x\",\"active\":3}]" :: Either String [CatThreadPoolRow] of + Right (row : _) -> ctprlActive row `shouldBe` Just 3 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catThreadPoolWith integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catThreadPoolWith integration" $ + it "returns at least one thread-pool row" $ + withTestEnv $ do + rows <- Client.catThreadPool + liftIO $ + rows `shouldSatisfy` (not . null) + + -- ------------------------------------------------------------------ -- + -- catFielddataOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catFielddataOptionsParams URI rendering" $ do + it "defaultCatFielddataOptions emits only format=json" $ + catFielddataOptionsParams defaultCatFielddataOptions + `shouldBe` [("format", Just "json")] + + it "renders bytes via catBytesSizeText" $ do + let opts = defaultCatFielddataOptions {cfdoBytes = Just CatBytesKb} + catFielddataOptionsParams opts + `shouldContain` [("bytes", Just "kb")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatFielddataOptions + { cfdoColumns = Just (CatFielddataColNode :| [CatFielddataColField, CatFielddataColSize]) + } + catFielddataOptionsParams opts + `shouldContain` [("h", Just "node,field,size")] + + it "renders unknown columns verbatim" $ do + let opts = + defaultCatFielddataOptions + { cfdoColumns = Just (CatFielddataColOther "description" :| []) + } + catFielddataOptionsParams opts + `shouldContain` [("h", Just "description")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatFielddataOptions + { cfdoHelp = Just True, + cfdoLocal = Just False, + cfdoVerbose = Just True + } + let ps = catFielddataOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "false")] + ps `shouldContain` [("v", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatFielddataOptions {cfdoMasterTimeout = Just (TimeUnitSeconds, 30)} + catFielddataOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + it "renders sort specs as comma-joined column[:direction] terms" $ do + let opts = + defaultCatFielddataOptions + { cfdoSort = + Just + ( CatFielddataSortSpec CatFielddataColSize (Just CatSortDesc) + :| [CatFielddataSortSpec CatFielddataColField Nothing] + ) + } + catFielddataOptionsParams opts + `shouldContain` [("s", Just "size:desc,field")] + + -- ------------------------------------------------------------------ -- + -- Renderer sanity for the leaf sum types -- + -- ------------------------------------------------------------------ -- + describe "catFielddataColumnText rendering" $ + it "covers every documented column" $ + map + catFielddataColumnText + [ CatFielddataColId, + CatFielddataColHost, + CatFielddataColIp, + CatFielddataColNode, + CatFielddataColField, + CatFielddataColSize + ] + `shouldBe` ["id", "host", "ip", "node", "field", "size"] + + -- ------------------------------------------------------------------ -- + -- CatFielddataRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatFielddataRow FromJSON" $ do + let fullRow = + "{\ + \ \"id\":\"Qk6MnTpSQ9CZ-Q\",\ + \ \"host\":\"127.0.0.1\",\ + \ \"ip\":\"127.0.0.1\",\ + \ \"node\":\"bloodhound-tests-node\",\ + \ \"field\":\"message\",\ + \ \"size\":\"5kb\"\ + \}" + minimalRow = + "{\ + \ \"node\":\"bloodhound-tests-cat-node\",\ + \ \"field\":\"message\"\ + \}" + fractionalRow = + "{\ + \ \"node\":\"bloodhound-tests-cat-node\",\ + \ \"field\":\"message\",\ + \ \"size\":\"5.2gb\"\ + \}" + bareRow = + "{\ + \ \"node\":\"bloodhound-tests-cat-node\",\ + \ \"field\":\"message\",\ + \ \"size\":\"208\"\ + \}" + extraColumnRow = + "{\ + \ \"node\":\"bloodhound-tests-cat-node\",\ + \ \"field\":\"message\",\ + \ \"ragney.future\":\"xyz\"\ + \}" + badUnitRow = + "{\ + \ \"node\":\"bloodhound-tests-cat-node\",\ + \ \"field\":\"message\",\ + \ \"size\":\"5qb\"\ + \}" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String CatFielddataRow of + Right row -> do + cfdrId row `shouldBe` Just "Qk6MnTpSQ9CZ-Q" + cfdrHost row `shouldBe` Just "127.0.0.1" + cfdrIp row `shouldBe` Just "127.0.0.1" + cfdrNode row `shouldBe` "bloodhound-tests-node" + cfdrField row `shouldBe` "message" + cfdrSize row `shouldBe` Just (Bytes 5, CatBytesKb) + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only node and field" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String CatFielddataRow of + Right row -> do + cfdrNode row `shouldBe` "bloodhound-tests-cat-node" + cfdrField row `shouldBe` "message" + cfdrSize row `shouldBe` Nothing + cfdrHost row `shouldBe` Nothing + Left e -> expectationFailure ("expected parse, got " <> e) + + it "rounds fractional size magnitudes to the nearest whole byte" $ + case parseEither parseJSON =<< eitherDecode fractionalRow :: Either String CatFielddataRow of + Right row -> cfdrSize row `shouldBe` Just (Bytes 5, CatBytesGb) + Left e -> expectationFailure ("expected parse, got " <> e) + + it "treats a bare number as CatBytesBytes" $ + case parseEither parseJSON =<< eitherDecode bareRow :: Either String CatFielddataRow of + Right row -> cfdrSize row `shouldBe` Just (Bytes 208, CatBytesBytes) + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in cfdrOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String CatFielddataRow of + Right row -> + case cfdrOther row of + Object o -> do + KM.keys o `shouldContain` ["ragney.future"] + KM.keys o `shouldContain` ["field"] + KM.keys o `shouldContain` ["node"] + _ -> expectationFailure "expected cfdrOther to be an Object" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "rejects an unrecognised byte-size suffix" $ + case parseEither parseJSON =<< eitherDecode badUnitRow :: Either String CatFielddataRow of + Right row -> expectationFailure ("expected parse failure, got " <> show row) + Left _ -> return () + + it "tolerates a native JSON number for size (treated as bare bytes)" $ + case parseEither parseJSON =<< eitherDecode "{\"node\":\"x\",\"field\":\"f\",\"size\":208}" :: Either String CatFielddataRow of + Right row -> cfdrSize row `shouldBe` Just (Bytes 208, CatBytesBytes) + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catFielddataWith integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catFielddataWith integration" $ do + it "returns a row for a field after loading its fielddata" + $ withTestEnv + $ withCatFielddata + [qqIndexName|bloodhound-tests-cat-fielddata|] + (FieldName "message") + $ \idx field -> do + let loadSearch = + (mkSearch Nothing Nothing) + { sortBody = Just [DefaultSortSpec (mkSort field Ascending)] + } + _ <- tryPerformBHRequest $ searchByIndex @Value idx loadSearch + rows <- Client.catFielddata + liftIO $ + case filter ((== unFieldName field) . cfdrField) rows of + (row : _) -> cfdrField row `shouldBe` unFieldName field + [] -> + expectationFailure "expected a fielddata row for the freshly-loaded field" + + it "honours the h= parameter and leaves unrequested columns absent" + $ withTestEnv + $ withCatFielddata + [qqIndexName|bloodhound-tests-cat-fielddata-h|] + (FieldName "message") + $ \idx field -> do + let loadSearch = + (mkSearch Nothing Nothing) + { sortBody = Just [DefaultSortSpec (mkSort field Ascending)] + } + _ <- tryPerformBHRequest $ searchByIndex @Value idx loadSearch + let opts = + defaultCatFielddataOptions + { cfdoColumns = Just (CatFielddataColNode :| [CatFielddataColField]) + } + rows <- Client.catFielddataWith Nothing opts + liftIO $ + case filter ((== "message") . cfdrField) rows of + (row : _) -> do + cfdrField row `shouldBe` "message" + cfdrNode row `shouldNotBe` "" + cfdrSize row `shouldBe` Nothing + [] -> + expectationFailure "expected a fielddata row for the freshly-loaded field" + + it "filters by field name via the / path segment" + $ withTestEnv + $ withCatFielddata + [qqIndexName|bloodhound-tests-cat-fielddata-filter|] + (FieldName "message") + $ \idx field -> do + let loadSearch = + (mkSearch Nothing Nothing) + { sortBody = Just [DefaultSortSpec (mkSort field Ascending)] + } + _ <- tryPerformBHRequest $ searchByIndex @Value idx loadSearch + rows <- Client.catFielddataWith (Just field) defaultCatFielddataOptions + liftIO $ do + rows `shouldSatisfy` (not . null) + map cfdrField rows `shouldSatisfy` all (== "message") + + -- ------------------------------------------------------------------ -- + -- catNodeattrsOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catNodeattrsOptionsParams URI rendering" $ do + it "defaultCatNodeattrsOptions emits only format=json" $ + catNodeattrsOptionsParams defaultCatNodeattrsOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatNodeattrsOptions + { cnaoColumns = Just (CatNodeattrsColNode :| [CatNodeattrsColAttr, CatNodeattrsColValue]) + } + catNodeattrsOptionsParams opts + `shouldContain` [("h", Just "node,attr,value")] + + it "renders unknown columns verbatim" $ do + let opts = + defaultCatNodeattrsOptions + { cnaoColumns = Just (CatNodeattrsColOther "attr.name" :| []) + } + catNodeattrsOptionsParams opts + `shouldContain` [("h", Just "attr.name")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatNodeattrsOptions + { cnaoHelp = Just True, + cnaoLocal = Just False, + cnaoVerbose = Just True + } + let ps = catNodeattrsOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "false")] + ps `shouldContain` [("v", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatNodeattrsOptions {cnaoMasterTimeout = Just (TimeUnitSeconds, 30)} + catNodeattrsOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + it "renders sort specs as comma-joined column[:direction] terms" $ do + let opts = + defaultCatNodeattrsOptions + { cnaoSort = + Just + ( CatNodeattrsSortSpec CatNodeattrsColNode (Just CatSortDesc) + :| [CatNodeattrsSortSpec CatNodeattrsColAttr Nothing] + ) + } + catNodeattrsOptionsParams opts + `shouldContain` [("s", Just "node:desc,attr")] + + -- ------------------------------------------------------------------ -- + -- Renderer sanity for the leaf sum types -- + -- ------------------------------------------------------------------ -- + describe "catNodeattrsColumnText rendering" $ + it "covers every documented column" $ + map + catNodeattrsColumnText + [ CatNodeattrsColNode, + CatNodeattrsColId, + CatNodeattrsColPid, + CatNodeattrsColHost, + CatNodeattrsColIp, + CatNodeattrsColPort, + CatNodeattrsColAttr, + CatNodeattrsColValue + ] + `shouldBe` ["node", "id", "pid", "host", "ip", "port", "attr", "value"] + + -- ------------------------------------------------------------------ -- + -- CatNodeattrsRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatNodeattrsRow FromJSON" $ do + let fullRow = + "[{\"node\":\"elasticsearch1\",\"id\":\"CBH3C4RiQcK3CxFvPJyFtQ\",\"pid\":\"42\",\"host\":\"172.19.0.7\",\"ip\":\"172.19.0.7\",\"port\":\"9300\",\"attr\":\"box_type\",\"value\":\"hot\"}]" + defaultRow = + "[{\"node\":\"elasticsearch1\",\"host\":\"172.19.0.7\",\"ip\":\"172.19.0.7\",\"attr\":\"box_type\",\"value\":\"hot\"}]" + extraColumnRow = "[{\"node\":\"x\",\"attr\":\"a\",\"value\":\"v\",\"ragney.future\":\"xyz\"}]" + + it "parses a fully-populated row (all 8 documented columns)" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatNodeattrsRow] of + Right (row : _) -> do + cnarNode row `shouldBe` Just "elasticsearch1" + cnarId row `shouldBe` Just "CBH3C4RiQcK3CxFvPJyFtQ" + cnarPid row `shouldBe` Just 42 + cnarHost row `shouldBe` Just "172.19.0.7" + cnarIp row `shouldBe` Just "172.19.0.7" + cnarPort row `shouldBe` Just 9300 + cnarAttr row `shouldBe` Just "box_type" + cnarValue row `shouldBe` Just "hot" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a default-column row (id/pid/port absent)" $ + case parseEither parseJSON =<< eitherDecode defaultRow :: Either String [CatNodeattrsRow] of + Right (row : _) -> do + cnarNode row `shouldBe` Just "elasticsearch1" + cnarHost row `shouldBe` Just "172.19.0.7" + cnarAttr row `shouldBe` Just "box_type" + cnarValue row `shouldBe` Just "hot" + cnarId row `shouldBe` Nothing + cnarPid row `shouldBe` Nothing + cnarPort row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in cnarOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatNodeattrsRow] of + Right (row : _) -> + case cnarOther row of + Object o -> do + KM.keys o `shouldContain` ["node"] + KM.keys o `shouldContain` ["attr"] + KM.keys o `shouldContain` ["value"] + KM.keys o `shouldContain` ["ragney.future"] + _ -> expectationFailure "expected cnarOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates native JSON numbers for pid and port (some OS builds)" $ + case parseEither parseJSON =<< eitherDecode "[{\"node\":\"x\",\"pid\":42,\"port\":9300}]" :: Either String [CatNodeattrsRow] of + Right (row : _) -> do + cnarPid row `shouldBe` Just 42 + cnarPort row `shouldBe` Just 9300 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catNodeattrs integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catNodeattrs integration" $ + it "returns a (possibly empty) list without throwing" $ + withTestEnv $ do + _ <- Client.catNodeattrs + pure () + + -- ------------------------------------------------------------------ -- + -- catRepositoriesOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catRepositoriesOptionsParams URI rendering" $ do + it "defaultCatRepositoriesOptions emits only format=json" $ + catRepositoriesOptionsParams defaultCatRepositoriesOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatRepositoriesOptions + { creoColumns = Just (CatRepositoriesColId :| [CatRepositoriesColType]) + } + catRepositoriesOptionsParams opts + `shouldContain` [("h", Just "id,type")] + + it "renders unknown columns verbatim" $ do + let opts = + defaultCatRepositoriesOptions + { creoColumns = Just (CatRepositoriesColOther "alias" :| []) + } + catRepositoriesOptionsParams opts + `shouldContain` [("h", Just "alias")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatRepositoriesOptions + { creoHelp = Just False, + creoLocal = Just True, + creoVerbose = Just True + } + let ps = catRepositoriesOptionsParams opts + ps `shouldContain` [("help", Just "false")] + ps `shouldContain` [("local", Just "true")] + ps `shouldContain` [("v", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatRepositoriesOptions {creoMasterTimeout = Just (TimeUnitMinutes, 1)} + catRepositoriesOptionsParams opts + `shouldContain` [("master_timeout", Just "1m")] + + it "renders sort specs as comma-joined column[:direction] terms" $ do + let opts = + defaultCatRepositoriesOptions + { creoSort = + Just + ( CatRepositoriesSortSpec CatRepositoriesColId (Just CatSortAsc) + :| [CatRepositoriesSortSpec CatRepositoriesColType Nothing] + ) + } + catRepositoriesOptionsParams opts + `shouldContain` [("s", Just "id:asc,type")] + + -- ------------------------------------------------------------------ -- + -- Renderer sanity for the leaf sum types -- + -- ------------------------------------------------------------------ -- + describe "catRepositoriesColumnText rendering" $ + it "covers every documented column" $ + map + catRepositoriesColumnText + [CatRepositoriesColId, CatRepositoriesColType] + `shouldBe` ["id", "type"] + + -- ------------------------------------------------------------------ -- + -- CatRepositoriesRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatRepositoriesRow FromJSON" $ do + let multiRow = + "[{\"id\":\"repo1\",\"type\":\"fs\"},{\"id\":\"repo2\",\"type\":\"s3\"}]" + extraColumnRow = "[{\"id\":\"repo1\",\"type\":\"fs\",\"alias\":\"backup\"}]" + + it "parses a multi-row response" $ + case parseEither parseJSON =<< eitherDecode multiRow :: Either String [CatRepositoriesRow] of + Right rows -> do + rows `shouldSatisfy` ((== 2) . length) + crrId (head rows) `shouldBe` Just "repo1" + crrType (head rows) `shouldBe` Just "fs" + crrId (rows !! 1) `shouldBe` Just "repo2" + crrType (rows !! 1) `shouldBe` Just "s3" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses an empty response as []" $ + case parseEither parseJSON =<< eitherDecode "[]" :: Either String [CatRepositoriesRow] of + Right rows -> rows `shouldBe` [] + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in crrOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatRepositoriesRow] of + Right (row : _) -> + case crrOther row of + Object o -> do + KM.keys o `shouldContain` ["id"] + KM.keys o `shouldContain` ["type"] + KM.keys o `shouldContain` ["alias"] + _ -> expectationFailure "expected crrOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catRepositories integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catRepositories integration" $ + it "returns a (possibly empty) list without throwing" $ + withTestEnv $ do + _ <- Client.catRepositories + pure () + + -- ------------------------------------------------------------------ -- + -- catShardsOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catShardsOptionsParams URI rendering" $ do + it "defaultCatShardsOptions emits only format=json" $ + catShardsOptionsParams defaultCatShardsOptions + `shouldBe` [("format", Just "json")] + + it "renders bytes via catBytesSizeText" $ do + let opts = defaultCatShardsOptions {cshoBytes = Just CatBytesKb} + catShardsOptionsParams opts + `shouldContain` [("bytes", Just "kb")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatShardsOptions + { cshoColumns = Just (CatShardsColIndex :| [CatShardsColShard, CatShardsColNode]) + } + catShardsOptionsParams opts + `shouldContain` [("h", Just "index,shard,node")] + + it "renders unknown columns verbatim" $ do + let opts = + defaultCatShardsOptions + { cshoColumns = Just (CatShardsColOther "unassigned.reason" :| []) + } + catShardsOptionsParams opts + `shouldContain` [("h", Just "unassigned.reason")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatShardsOptions + { cshoHelp = Just False, + cshoLocal = Just True, + cshoVerbose = Just True + } + let ps = catShardsOptionsParams opts + ps `shouldContain` [("help", Just "false")] + ps `shouldContain` [("local", Just "true")] + ps `shouldContain` [("v", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatShardsOptions {cshoMasterTimeout = Just (TimeUnitMinutes, 1)} + catShardsOptionsParams opts + `shouldContain` [("master_timeout", Just "1m")] + + it "renders time via timeUnitsSuffix" $ do + let opts = defaultCatShardsOptions {cshoTime = Just (TimeUnitSeconds, 5)} + catShardsOptionsParams opts + `shouldContain` [("time", Just "5s")] + + it "renders sort specs as comma-joined column[:direction] terms" $ do + let opts = + defaultCatShardsOptions + { cshoSort = + Just + ( CatShardsSortSpec CatShardsColIndex (Just CatSortAsc) + :| [CatShardsSortSpec CatShardsColShard Nothing] + ) + } + catShardsOptionsParams opts + `shouldContain` [("s", Just "index:asc,shard")] + + -- ------------------------------------------------------------------ -- + -- catSegmentsOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catSegmentsOptionsParams URI rendering" $ do + it "defaultCatSegmentsOptions emits only format=json" $ + catSegmentsOptionsParams defaultCatSegmentsOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatSegmentsOptions + { csgoColumns = Just (CatSegmentsColIndex :| [CatSegmentsColShard, CatSegmentsColSegment]) + } + catSegmentsOptionsParams opts + `shouldContain` [("h", Just "index,shard,segment")] + + it "renders unknown columns verbatim" $ do + let opts = + defaultCatSegmentsOptions + { csgoColumns = Just (CatSegmentsColOther "size" :| []) + } + catSegmentsOptionsParams opts + `shouldContain` [("h", Just "size")] + + it "renders bytes via catBytesSizeText" $ do + let opts = defaultCatSegmentsOptions {csgoBytes = Just CatBytesKb} + catSegmentsOptionsParams opts + `shouldContain` [("bytes", Just "kb")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatSegmentsOptions + { csgoHelp = Just False, + csgoLocal = Just True, + csgoVerbose = Just True + } + let ps = catSegmentsOptionsParams opts + ps `shouldContain` [("help", Just "false")] + ps `shouldContain` [("local", Just "true")] + ps `shouldContain` [("v", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatSegmentsOptions {csgoMasterTimeout = Just (TimeUnitMinutes, 1)} + catSegmentsOptionsParams opts + `shouldContain` [("master_timeout", Just "1m")] + + it "renders sort specs as comma-joined column[:direction] terms" $ do + let opts = + defaultCatSegmentsOptions + { csgoSort = + Just + ( CatSegmentsSortSpec CatSegmentsColIndex (Just CatSortAsc) + :| [CatSegmentsSortSpec CatSegmentsColShard Nothing] + ) + } + catSegmentsOptionsParams opts + `shouldContain` [("s", Just "index:asc,shard")] + + -- ------------------------------------------------------------------ -- + -- Renderer sanity for the leaf sum types -- + -- ------------------------------------------------------------------ -- + describe "catShardsColumnText rendering" $ + it "covers every documented default column" $ + map + catShardsColumnText + [ CatShardsColIndex, + CatShardsColShard, + CatShardsColPrirep, + CatShardsColState, + CatShardsColDocs, + CatShardsColStore, + CatShardsColDataset, + CatShardsColNode + ] + `shouldBe` ["index", "shard", "prirep", "state", "docs", "store", "dataset", "node"] + + -- ------------------------------------------------------------------ -- + -- CatShardsRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatShardsRow FromJSON" $ do + let multiRow = + "[{\"index\":\"logs\",\"shard\":\"0\",\"prirep\":\"p\",\"state\":\"STARTED\",\"docs\":\"42\",\"store\":\"5kb\",\"dataset\":\"tsdb\",\"node\":\"node-1\"},\ + \{\"index\":\"logs\",\"shard\":\"1\",\"prirep\":\"r\",\"state\":\"STARTED\",\"docs\":\"42\",\"store\":\"5kb\",\"node\":\"node-2\"}]" + unassignedRow = + "[{\"index\":\"logs\",\"shard\":\"0\",\"prirep\":\"p\",\"state\":\"UNASSIGNED\",\"docs\":\"-\",\"store\":\"-\",\"node\":\"-\"}]" + extraColumnRow = + "[{\"index\":\"logs\",\"shard\":\"0\",\"prirep\":\"p\",\"state\":\"STARTED\",\"docs\":\"42\",\"store\":\"5kb\",\"node\":\"node-1\",\"sync_id\":\"abc\"}]" + nativeNumberRow = + "[{\"index\":\"logs\",\"shard\":0,\"prirep\":\"p\",\"state\":\"STARTED\",\"docs\":42,\"store\":\"5kb\",\"node\":\"node-1\"}]" + + it "parses a multi-row response" $ + case parseEither parseJSON =<< eitherDecode multiRow :: Either String [CatShardsRow] of + Right rows -> do + rows `shouldSatisfy` ((== 2) . length) + let r0 = head rows + csrIndex r0 `shouldBe` Just "logs" + csrShard r0 `shouldBe` Just 0 + csrPrirep r0 `shouldBe` Just "p" + csrState r0 `shouldBe` Just "STARTED" + csrDocs r0 `shouldBe` Just 42 + csrDataset r0 `shouldBe` Just "tsdb" + csrNode r0 `shouldBe` Just "node-1" + case csrStore r0 of + Just (Bytes n, CatBytesKb) -> n `shouldBe` 5 + other -> expectationFailure ("expected 5kb store, got " <> show other) + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses an empty response as []" $ + case parseEither parseJSON =<< eitherDecode "[]" :: Either String [CatShardsRow] of + Right rows -> rows `shouldBe` [] + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates the \"-\" sentinel for unassigned shards" $ + case parseEither parseJSON =<< eitherDecode unassignedRow :: Either String [CatShardsRow] of + Right (row : _) -> do + csrState row `shouldBe` Just "UNASSIGNED" + csrDocs row `shouldBe` Nothing + csrStore row `shouldBe` Nothing + csrNode row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in csrOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatShardsRow] of + Right (row : _) -> + case csrOther row of + Object o -> do + KM.keys o `shouldContain` ["index"] + KM.keys o `shouldContain` ["sync_id"] + _ -> expectationFailure "expected csrOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates native JSON numbers (OpenSearch parity)" $ + case parseEither parseJSON =<< eitherDecode nativeNumberRow :: Either String [CatShardsRow] of + Right (row : _) -> do + csrShard row `shouldBe` Just 0 + csrDocs row `shouldBe` Just 42 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catShards integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catShards integration" $ do + it "returns a (possibly empty) list without throwing" $ + withTestEnv $ do + _ <- Client.catShards + pure () + + it "narrows by index via catShardsWith" $ + withTestEnv $ + withCatIndex [qqIndexName|bloodhound-cat-shards-spec|] $ \idx -> do + rows <- Client.catShardsWith (Just idx) defaultCatShardsOptions + liftIO $ do + rows `shouldSatisfy` (not . null) + rows `shouldSatisfy` all ((== Just (unIndexName idx)) . csrIndex) + + -- ------------------------------------------------------------------ -- + -- catTasksOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catTasksOptionsParams URI rendering" $ do + it "defaultCatTasksOptions emits only format=json" $ + catTasksOptionsParams defaultCatTasksOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatTasksOptions + { cttoColumns = Just (CatTasksColAction :| [CatTasksColTaskId]) + } + catTasksOptionsParams opts + `shouldContain` [("h", Just "action,task_id")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatTasksOptions + { cttoDetailed = Just True, + cttoHelp = Just True, + cttoLocal = Just True + } + let ps = catTasksOptionsParams opts + ps `shouldContain` [("detailed", Just "true")] + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatTasksOptions {cttoMasterTimeout = Just (TimeUnitSeconds, 30)} + catTasksOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + it "renders actions and nodes as comma-joined lists" $ do + let opts = + defaultCatTasksOptions + { cttoActions = Just ("cluster:monitor/tasks/lists" :| []), + cttoNodes = Just ("node-1" :| ["node-2"]) + } + let ps = catTasksOptionsParams opts + ps `shouldContain` [("actions", Just "cluster:monitor/tasks/lists")] + ps `shouldContain` [("nodes", Just "node-1,node-2")] + + it "renders parent_task_id verbatim" $ do + let opts = defaultCatTasksOptions {cttoParentTaskId = Just "oTUltX4IQMOUUVeiohTt8A:123"} + catTasksOptionsParams opts + `shouldContain` [("parent_task_id", Just "oTUltX4IQMOUUVeiohTt8A:123")] + + it "renders sort specifiers (s) as column[:direction]" $ do + let opts = + defaultCatTasksOptions + { cttoSort = + Just + ( CatTasksSortSpec CatTasksColAction Nothing + :| [CatTasksSortSpec CatTasksColStartTime (Just CatSortDesc)] + ) + } + catTasksOptionsParams opts + `shouldContain` [("s", Just "action,start_time:desc")] + + describe "catTasksColumnText rendering" $ + it "covers every documented column" $ + map + catTasksColumnText + [ CatTasksColId, + CatTasksColAction, + CatTasksColTaskId, + CatTasksColParentTaskId, + CatTasksColType, + CatTasksColStartTime, + CatTasksColTimestamp, + CatTasksColRunningTime, + CatTasksColRunningTimeNs, + CatTasksColNodeId, + CatTasksColIp, + CatTasksColPort, + CatTasksColNode, + CatTasksColVersion, + CatTasksColXOpaqueId, + CatTasksColDescription + ] + `shouldBe` [ "id", + "action", + "task_id", + "parent_task_id", + "type", + "start_time", + "timestamp", + "running_time", + "running_time_ns", + "node_id", + "ip", + "port", + "node", + "version", + "x_opaque_id", + "description" + ] + + -- ------------------------------------------------------------------ -- + -- CatTasksRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatTasksRow FromJSON" $ do + let fullRow = + "[{\"action\":\"cluster:monitor/tasks/lists[n]\",\"task_id\":\"oTUltX4IQMOUUVeiohTt8A:124\",\"parent_task_id\":\"oTUltX4IQMOUUVeiohTt8A:123\",\"type\":\"direct\",\"start_time\":\"1458585884904\",\"timestamp\":\"01:48:24\",\"running_time\":\"44.1micros\",\"ip\":\"127.0.0.1:9300\",\"node\":\"oTUltX4IQMOUUVeiohTt8A\"}]" + minimalRow = "[{\"action\":\"x\"}]" + extraColumnRow = "[{\"action\":\"x\",\"future.column\":\"xyz\"}]" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatTasksRow] of + Right (row : _) -> do + ctrrAction row `shouldBe` Just "cluster:monitor/tasks/lists[n]" + ctrrTaskId row `shouldBe` Just "oTUltX4IQMOUUVeiohTt8A:124" + ctrrParentTaskId row `shouldBe` Just "oTUltX4IQMOUUVeiohTt8A:123" + ctrrType row `shouldBe` Just "direct" + ctrrStartTime row `shouldBe` Just "1458585884904" + ctrrTimestamp row `shouldBe` Just "01:48:24" + ctrrRunningTime row `shouldBe` Just "44.1micros" + ctrrIp row `shouldBe` Just "127.0.0.1:9300" + ctrrNode row `shouldBe` Just "oTUltX4IQMOUUVeiohTt8A" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only action" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String [CatTasksRow] of + Right (row : _) -> do + ctrrAction row `shouldBe` Just "x" + ctrrTaskId row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in ctrrOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatTasksRow] of + Right (row : _) -> + case ctrrOther row of + Object o -> do + KM.keys o `shouldContain` ["action"] + KM.keys o `shouldContain` ["future.column"] + _ -> expectationFailure "expected ctrrOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses an empty tasks list" $ + case parseEither parseJSON =<< eitherDecode "[]" :: Either String [CatTasksRow] of + Right rows -> rows `shouldBe` [] + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catTasksWith integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catTasksWith integration" $ + it "parses the tasks list without error" $ + withTestEnv $ do + _rows <- Client.catTasks + return () + + -- ------------------------------------------------------------------ -- + -- catSnapshotsOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catSnapshotsOptionsParams URI rendering" $ do + it "defaultCatSnapshotsOptions emits only format=json" $ + catSnapshotsOptionsParams defaultCatSnapshotsOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatSnapshotsOptions + { csnoColumns = Just (CatSnapshotsColId :| [CatSnapshotsColStatus, CatSnapshotsColRepository]) + } + catSnapshotsOptionsParams opts + `shouldContain` [("h", Just "id,status,repository")] + + it "renders ignore_unavailable as true/false" $ do + let opts = defaultCatSnapshotsOptions {csnoIgnoreUnavailable = Just True} + catSnapshotsOptionsParams opts + `shouldContain` [("ignore_unavailable", Just "true")] + + it "renders booleans (help, local) as true/false" $ do + let opts = + defaultCatSnapshotsOptions + { csnoHelp = Just True, + csnoLocal = Just True + } + let ps = catSnapshotsOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatSnapshotsOptions {csnoMasterTimeout = Just (TimeUnitSeconds, 30)} + catSnapshotsOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + it "renders sort specifiers (s) as column[:direction]" $ do + let opts = + defaultCatSnapshotsOptions + { csnoSort = + Just + ( CatSnapshotsSortSpec CatSnapshotsColStartEpoch Nothing + :| [CatSnapshotsSortSpec CatSnapshotsColDuration (Just CatSortDesc)] + ) + } + catSnapshotsOptionsParams opts + `shouldContain` [("s", Just "start_epoch,duration:desc")] + + describe "catSnapshotsColumnText rendering" $ + it "covers every documented column" $ + map + catSnapshotsColumnText + [ CatSnapshotsColId, + CatSnapshotsColRepository, + CatSnapshotsColStatus, + CatSnapshotsColStartEpoch, + CatSnapshotsColStartTime, + CatSnapshotsColEndEpoch, + CatSnapshotsColEndTime, + CatSnapshotsColDuration, + CatSnapshotsColIndices, + CatSnapshotsColSuccessfulShards, + CatSnapshotsColFailedShards, + CatSnapshotsColTotalShards, + CatSnapshotsColReason + ] + `shouldBe` [ "id", + "repository", + "status", + "start_epoch", + "start_time", + "end_epoch", + "end_time", + "duration", + "indices", + "successful_shards", + "failed_shards", + "total_shards", + "reason" + ] + + -- ------------------------------------------------------------------ -- + -- CatSnapshotsRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatSnapshotsRow FromJSON" $ do + let fullRow = + "[{\"id\":\"snap1\",\"repository\":\"repo1\",\"status\":\"FAILED\",\"start_epoch\":\"1445616705\",\"start_time\":\"18:11:45\",\"end_epoch\":\"1445616978\",\"end_time\":\"18:16:18\",\"duration\":\"4.6m\",\"indices\":\"1\",\"successful_shards\":\"4\",\"failed_shards\":\"1\",\"total_shards\":\"5\"}]" + minimalRow = "[{\"id\":\"snap1\"}]" + extraColumnRow = "[{\"id\":\"snap1\",\"future.column\":\"xyz\"}]" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatSnapshotsRow] of + Right (row : _) -> do + csnrId row `shouldBe` Just "snap1" + csnrRepository row `shouldBe` Just "repo1" + csnrStatus row `shouldBe` Just "FAILED" + csnrStartEpoch row `shouldBe` Just "1445616705" + csnrStartTime row `shouldBe` Just "18:11:45" + csnrEndEpoch row `shouldBe` Just "1445616978" + csnrEndTime row `shouldBe` Just "18:16:18" + csnrDuration row `shouldBe` Just "4.6m" + csnrIndices row `shouldBe` Just "1" + csnrSuccessfulShards row `shouldBe` Just "4" + csnrFailedShards row `shouldBe` Just "1" + csnrTotalShards row `shouldBe` Just "5" + csnrReason row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only id" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String [CatSnapshotsRow] of + Right (row : _) -> do + csnrId row `shouldBe` Just "snap1" + csnrStatus row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in csnrOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatSnapshotsRow] of + Right (row : _) -> + case csnrOther row of + Object o -> do + KM.keys o `shouldContain` ["id"] + KM.keys o `shouldContain` ["future.column"] + _ -> expectationFailure "expected csnrOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses an empty snapshots list" $ + case parseEither parseJSON =<< eitherDecode "[]" :: Either String [CatSnapshotsRow] of + Right rows -> rows `shouldBe` [] + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catSnapshots integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catSnapshots integration" $ + it "returns a (possibly empty) list without throwing" $ + withTestEnv $ do + -- The cat snapshots endpoint requires a registered snapshot + -- repository; @GET /_cat/snapshots@ with no repo returns HTTP + -- 400 "repository is missing" on every supported backend. The + -- docker-compose test cluster doesn't configure @path.repo@, + -- so an fs repository cannot be registered from the test + -- either. Skip the live check when no repo is available, + -- rather than failing on infrastructure the test cannot + -- provision. + repoResult <- + tryPerformBHRequest $ + catSnapshotsWith + (Just (SnapshotRepoName "_all")) + defaultCatSnapshotsOptions + case repoResult of + Right rows -> liftIO $ rows `shouldSatisfy` (\_ -> True) + Left e + | "repository" `T.isInfixOf` errorMessage e + || "no such" `T.isInfixOf` errorMessage e + || "missing" `T.isInfixOf` errorMessage e -> + liftIO $ pendingWith "no snapshot repository registered on this cluster" + Left e -> liftIO $ expectationFailure ("catSnapshots failed unexpectedly: " <> show e) + + -- ------------------------------------------------------------------ -- + -- catNodesOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catNodesOptionsParams URI rendering" $ do + it "defaultCatNodesOptions emits only format=json" $ + catNodesOptionsParams defaultCatNodesOptions + `shouldBe` [("format", Just "json")] + + it "renders bytes via catBytesSizeText" $ do + let opts = defaultCatNodesOptions {cnoBytes = Just CatBytesKb} + catNodesOptionsParams opts + `shouldContain` [("bytes", Just "kb")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatNodesOptions + { cnoColumns = Just (CatNodesColName :| [CatNodesColHeapPercent, CatNodesColCpu]) + } + catNodesOptionsParams opts + `shouldContain` [("h", Just "name,heap.percent,cpu")] + + it "renders unknown columns verbatim" $ do + let opts = + defaultCatNodesOptions + { cnoColumns = Just (CatNodesColOther "uptime" :| []) + } + catNodesOptionsParams opts + `shouldContain` [("h", Just "uptime")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatNodesOptions + { cnoHelp = Just True, + cnoLocal = Just False, + cnoVerbose = Just True + } + let ps = catNodesOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "false")] + ps `shouldContain` [("v", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatNodesOptions {cnoMasterTimeout = Just (TimeUnitSeconds, 30)} + catNodesOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + it "renders time via timeUnitsSuffix" $ do + let opts = defaultCatNodesOptions {cnoTime = Just (TimeUnitMinutes, 5)} + catNodesOptionsParams opts + `shouldContain` [("time", Just "5m")] + + it "renders sort specs as comma-joined column[:direction] terms" $ do + let opts = + defaultCatNodesOptions + { cnoSort = + Just + ( CatNodesSortSpec CatNodesColName (Just CatSortAsc) + :| [CatNodesSortSpec CatNodesColCpu Nothing] + ) + } + catNodesOptionsParams opts + `shouldContain` [("s", Just "name:asc,cpu")] + + describe "catSegmentsColumnText rendering" $ + it "covers every documented column" $ + map + catSegmentsColumnText + [ CatSegmentsColIndex, + CatSegmentsColShard, + CatSegmentsColPrirep, + CatSegmentsColIp, + CatSegmentsColSegment, + CatSegmentsColId, + CatSegmentsColGeneration, + CatSegmentsColDocsCount, + CatSegmentsColDocsDeleted, + CatSegmentsColSize, + CatSegmentsColSizeMemory, + CatSegmentsColCommitted, + CatSegmentsColSearchable, + CatSegmentsColVersion, + CatSegmentsColCompound + ] + `shouldBe` [ "index", + "shard", + "prirep", + "ip", + "segment", + "id", + "generation", + "docs.count", + "docs.deleted", + "size", + "size.memory", + "committed", + "searchable", + "version", + "compound" + ] + + -- ------------------------------------------------------------------ -- + -- CatSegmentsRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatSegmentsRow FromJSON" $ do + let fullRow = + "[{\"index\":\"test\",\"shard\":\"0\",\"prirep\":\"p\",\"ip\":\"127.0.0.1\",\"segment\":\"_0\",\"id\":\"abc123\",\"generation\":\"0\",\"docs.count\":\"42\",\"docs.deleted\":\"5\",\"size\":\"5kb\",\"size.memory\":\"208\",\"committed\":\"true\",\"searchable\":\"true\",\"version\":\"9.0.0\",\"compound\":\"true\"}]" + minimalRow = "[{\"index\":\"test\",\"shard\":\"0\"}]" + extraColumnRow = "[{\"index\":\"x\",\"custom.col\":\"xyz\"}]" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatSegmentsRow] of + Right (row : _) -> do + cserIndex row `shouldBe` Just "test" + cserShard row `shouldBe` Just 0 + cserPrirep row `shouldBe` Just "p" + cserIp row `shouldBe` Just "127.0.0.1" + cserSegment row `shouldBe` Just "_0" + cserId row `shouldBe` Just "abc123" + cserGeneration row `shouldBe` Just 0 + cserDocsCount row `shouldBe` Just 42 + cserDocsDeleted row `shouldBe` Just 5 + cserCommitted row `shouldBe` Just True + cserSearchable row `shouldBe` Just True + cserVersion row `shouldBe` Just "9.0.0" + cserCompound row `shouldBe` Just True + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only index and shard" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String [CatSegmentsRow] of + Right (row : _) -> do + cserIndex row `shouldBe` Just "test" + cserShard row `shouldBe` Just 0 + cserCompound row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in cserOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatSegmentsRow] of + Right (row : _) -> + case cserOther row of + Object o -> do + KM.keys o `shouldContain` ["index"] + KM.keys o `shouldContain` ["custom.col"] + _ -> expectationFailure "expected cserOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates native JSON numbers for shard and generation" $ + case parseEither parseJSON =<< eitherDecode "[{\"shard\":3,\"generation\":7,\"docs.count\":100}]" :: Either String [CatSegmentsRow] of + Right (row : _) -> do + cserShard row `shouldBe` Just 3 + cserGeneration row `shouldBe` Just 7 + cserDocsCount row `shouldBe` Just 100 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates native JSON booleans for committed/searchable/compound" $ + case parseEither parseJSON =<< eitherDecode "[{\"committed\":false,\"searchable\":true,\"compound\":false}]" :: Either String [CatSegmentsRow] of + Right (row : _) -> do + cserCommitted row `shouldBe` Just False + cserSearchable row `shouldBe` Just True + cserCompound row `shouldBe` Just False + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses an empty segments list" $ + case parseEither parseJSON =<< eitherDecode "[]" :: Either String [CatSegmentsRow] of + Right rows -> rows `shouldBe` [] + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catSegments integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catSegments integration" $ + it "returns a (possibly empty) list without throwing" $ + withTestEnv $ do + _ <- Client.catSegments + pure () + + -- ------------------------------------------------------------------ -- + -- catRecoveryOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "catRecoveryOptionsParams URI rendering" $ do + it "defaultCatRecoveryOptions emits format=json and bytes=b" $ + catRecoveryOptionsParams defaultCatRecoveryOptions + `shouldBe` [("format", Just "json"), ("bytes", Just "b")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatRecoveryOptions + { cryoColumns = Just (CatRecoveryColIndex :| [CatRecoveryColShard, CatRecoveryColStage]) + } + catRecoveryOptionsParams opts + `shouldContain` [("h", Just "index,shard,stage")] + + it "renders bytes via catBytesSizeText" $ do + let opts = defaultCatRecoveryOptions {cryoBytes = Just CatBytesMb} + catRecoveryOptionsParams opts + `shouldContain` [("bytes", Just "mb")] + + it "renders active_only as true" $ do + let opts = defaultCatRecoveryOptions {cryoActiveOnly = Just True} + catRecoveryOptionsParams opts + `shouldContain` [("active_only", Just "true")] + + it "renders detailed as true" $ do + let opts = defaultCatRecoveryOptions {cryoDetailed = Just True} + catRecoveryOptionsParams opts + `shouldContain` [("detailed", Just "true")] + + it "renders booleans as true/false" $ do + let opts = + defaultCatRecoveryOptions + { cryoHelp = Just False, + cryoLocal = Just True, + cryoVerbose = Just True + } + let ps = catRecoveryOptionsParams opts + ps `shouldContain` [("help", Just "false")] + ps `shouldContain` [("local", Just "true")] + ps `shouldContain` [("v", Just "true")] + + it "renders master_timeout via timeUnitsSuffix" $ do + let opts = defaultCatRecoveryOptions {cryoMasterTimeout = Just (TimeUnitSeconds, 30)} + catRecoveryOptionsParams opts + `shouldContain` [("master_timeout", Just "30s")] + + it "renders sort specs as comma-joined column[:direction] terms" $ do + let opts = + defaultCatRecoveryOptions + { cryoSort = + Just + ( CatRecoverySortSpec CatRecoveryColIndex (Just CatSortAsc) + :| [CatRecoverySortSpec CatRecoveryColStage Nothing] + ) + } + catRecoveryOptionsParams opts + `shouldContain` [("s", Just "index:asc,stage")] + + -- ------------------------------------------------------------------ -- + -- Renderer sanity for the leaf sum types -- + -- ------------------------------------------------------------------ -- + describe "catNodesColumnText rendering" $ + it "covers every documented column" $ + map + catNodesColumnText + [ CatNodesColIp, + CatNodesColPort, + CatNodesColHost, + CatNodesColName, + CatNodesColId, + CatNodesColPid, + CatNodesColMaster, + CatNodesColNodeRole, + CatNodesColHeapPercent, + CatNodesColRamPercent, + CatNodesColCpu, + CatNodesColLoad1m, + CatNodesColLoad5m, + CatNodesColLoad15m, + CatNodesColHeapCurrent, + CatNodesColHeapMax, + CatNodesColRamCurrent, + CatNodesColRamMax, + CatNodesColDiskUsedPercent, + CatNodesColDiskUsed, + CatNodesColDiskAvail, + CatNodesColDiskTotal, + CatNodesColFileDescPercent, + CatNodesColFileDescCurrent, + CatNodesColFileDescMax + ] + `shouldBe` [ "ip", + "port", + "host", + "name", + "id", + "pid", + "master", + "node.role", + "heap.percent", + "ram.percent", + "cpu", + "load_1m", + "load_5m", + "load_15m", + "heap.current", + "heap.max", + "ram.current", + "ram.max", + "disk.used_percent", + "disk.used", + "disk.avail", + "disk.total", + "file_desc.percent", + "file_desc.current", + "file_desc.max" + ] + + describe "catNodesMasterFromText / ToText round-trip" $ do + it "decodes \"*\" as the elected master" $ + catNodesMasterFromText "*" `shouldBe` Just CatNodesMasterTrue + it "decodes \"-\" as a non-master node" $ + catNodesMasterFromText "-" `shouldBe` Just CatNodesMasterFalse + it "rejects unknown sentinels" $ + catNodesMasterFromText "maybe" `shouldBe` (Nothing :: Maybe CatNodesMaster) + it "round-trips every constructor through ToText" $ do + catNodesMasterToText CatNodesMasterTrue `shouldBe` "*" + catNodesMasterToText CatNodesMasterFalse `shouldBe` "-" + + -- ------------------------------------------------------------------ -- + -- CatNodesRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatNodesRow FromJSON" $ do + let fullRow = + "{\ + \ \"ip\":\"127.0.0.1\",\ + \ \"port\":\"9300\",\ + \ \"host\":\"127.0.0.1\",\ + \ \"name\":\"node-1\",\ + \ \"id\":\"CSUXak2TQcK3CxFvPJyFtQ\",\ + \ \"pid\":\"42\",\ + \ \"master\":\"*\",\ + \ \"node.role\":\"dimr\",\ + \ \"heap.percent\":\"45\",\ + \ \"ram.percent\":\"60\",\ + \ \"cpu\":\"12\",\ + \ \"load_1m\":\"0.07\",\ + \ \"load_5m\":\"0.10\",\ + \ \"load_15m\":\"0.15\",\ + \ \"heap.current\":\"1.4gb\",\ + \ \"heap.max\":\"4gb\",\ + \ \"ram.current\":\"6.5gb\",\ + \ \"ram.max\":\"16gb\",\ + \ \"disk.used_percent\":\"46\",\ + \ \"disk.used\":\"47.3gb\",\ + \ \"disk.avail\":\"53.4gb\",\ + \ \"disk.total\":\"100.7gb\",\ + \ \"file_desc.percent\":\"3\",\ + \ \"file_desc.current\":\"312\",\ + \ \"file_desc.max\":\"65536\"\ + \}" + minimalRow = "{\"name\":\"bloodhound-tests-cat-node\"}" + subsetRow = + "{\ + \ \"name\":\"bloodhound-tests-cat-node\",\ + \ \"heap.percent\":\"50\",\ + \ \"cpu\":\"99\"\ + \}" + nonMasterRow = + "{\ + \ \"name\":\"bloodhound-tests-cat-node\",\ + \ \"master\":\"-\"\ + \}" + fractionalRow = + "{\ + \ \"name\":\"bloodhound-tests-cat-node\",\ + \ \"heap.current\":\"5.2gb\",\ + \ \"heap.max\":\"5.2gb\"\ + \}" + bareRow = + "{\ + \ \"name\":\"bloodhound-tests-cat-node\",\ + \ \"heap.current\":\"208\",\ + \ \"heap.max\":\"208\"\ + \}" + extraColumnRow = + "{\ + \ \"name\":\"bloodhound-tests-cat-node\",\ + \ \"uptime\":\"5m\"\ + \}" + badUnitRow = + "{\ + \ \"name\":\"bloodhound-tests-cat-node\",\ + \ \"heap.current\":\"5qb\"\ + \}" + openSearchMasterRow = + "{\ + \ \"name\":\"bloodhound-tests-cat-node\",\ + \ \"cluster_manager\":\"*\"\ + \}" + bothMasterColumnsRow = + "{\ + \ \"name\":\"bloodhound-tests-cat-node\",\ + \ \"master\":\"-\",\ + \ \"cluster_manager\":\"*\"\ + \}" + invalidMasterRow = + "{\ + \ \"name\":\"bloodhound-tests-cat-node\",\ + \ \"master\":\"maybe\"\ + \}" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String CatNodesRow of + Right row -> do + cnrIp row `shouldBe` Just "127.0.0.1" + cnrPort row `shouldBe` Just 9300 + cnrHost row `shouldBe` Just "127.0.0.1" + cnrName row `shouldBe` "node-1" + cnrId row `shouldBe` Just (FullNodeId "CSUXak2TQcK3CxFvPJyFtQ") + cnrPid row `shouldBe` Just 42 + cnrMaster row `shouldBe` Just CatNodesMasterTrue + cnrNodeRole row `shouldBe` Just "dimr" + cnrHeapPercent row `shouldBe` Just 45 + cnrRamPercent row `shouldBe` Just 60 + cnrCpu row `shouldBe` Just 12 + cnrLoad1m row `shouldBe` Just 0.07 + cnrLoad5m row `shouldBe` Just 0.10 + cnrLoad15m row `shouldBe` Just 0.15 + cnrHeapCurrent row `shouldBe` Just (Bytes 1, CatBytesGb) + cnrHeapMax row `shouldBe` Just (Bytes 4, CatBytesGb) + cnrRamCurrent row `shouldBe` Just (Bytes 6, CatBytesGb) + cnrRamMax row `shouldBe` Just (Bytes 16, CatBytesGb) + cnrDiskUsedPercent row `shouldBe` Just 46 + cnrDiskUsed row `shouldBe` Just (Bytes 47, CatBytesGb) + cnrDiskAvail row `shouldBe` Just (Bytes 53, CatBytesGb) + cnrDiskTotal row `shouldBe` Just (Bytes 101, CatBytesGb) + cnrFileDescPercent row `shouldBe` Just 3 + cnrFileDescCurrent row `shouldBe` Just 312 + cnrFileDescMax row `shouldBe` Just 65536 + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only `name`" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String CatNodesRow of + Right row -> do + cnrName row `shouldBe` "bloodhound-tests-cat-node" + cnrIp row `shouldBe` Nothing + cnrMaster row `shouldBe` Nothing + cnrHeapPercent row `shouldBe` Nothing + cnrCpu row `shouldBe` Nothing + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a column-subset row (as produced by h=name,heap.percent,cpu)" $ + case parseEither parseJSON =<< eitherDecode subsetRow :: Either String CatNodesRow of + Right row -> do + cnrName row `shouldBe` "bloodhound-tests-cat-node" + cnrHeapPercent row `shouldBe` Just 50 + cnrCpu row `shouldBe` Just 99 + -- Columns we did not request should be absent: + cnrRamPercent row `shouldBe` Nothing + cnrLoad1m row `shouldBe` Nothing + Left e -> expectationFailure ("expected parse, got " <> e) + + it "decodes the \"-\" sentinel for master as CatNodesMasterFalse" $ + case parseEither parseJSON =<< eitherDecode nonMasterRow :: Either String CatNodesRow of + Right row -> cnrMaster row `shouldBe` Just CatNodesMasterFalse + Left e -> expectationFailure ("expected parse, got " <> e) + + it "falls back to the cluster_manager column when master is absent (OpenSearch)" $ + case parseEither parseJSON =<< eitherDecode openSearchMasterRow :: Either String CatNodesRow of + Right row -> cnrMaster row `shouldBe` Just CatNodesMasterTrue + Left e -> expectationFailure ("expected parse, got " <> e) + + -- OS3 emits both @master@ (when explicitly requested via @h=master@) + -- and @cluster_manager@ in default output. Locks in that the ES + -- column name wins when both are present, so the parser is + -- deterministic regardless of which alias the server happens to + -- emit. + it "prefers master over cluster_manager when both are present" $ + case parseEither parseJSON =<< eitherDecode bothMasterColumnsRow :: Either String CatNodesRow of + Right row -> cnrMaster row `shouldBe` Just CatNodesMasterFalse + Left e -> expectationFailure ("expected parse, got " <> e) + + it "rejects an unrecognised master sentinel" $ + case parseEither parseJSON =<< eitherDecode invalidMasterRow :: Either String CatNodesRow of + Right row -> expectationFailure ("expected parse failure, got " <> show row) + Left _ -> return () + + it "rounds fractional heap magnitudes to the nearest whole byte" $ + case parseEither parseJSON =<< eitherDecode fractionalRow :: Either String CatNodesRow of + Right row -> do + cnrHeapCurrent row `shouldBe` Just (Bytes 5, CatBytesGb) + cnrHeapMax row `shouldBe` Just (Bytes 5, CatBytesGb) + Left e -> expectationFailure ("expected parse, got " <> e) + + it "treats a bare number as CatBytesBytes" $ + case parseEither parseJSON =<< eitherDecode bareRow :: Either String CatNodesRow of + Right row -> do + cnrHeapCurrent row `shouldBe` Just (Bytes 208, CatBytesBytes) + cnrHeapMax row `shouldBe` Just (Bytes 208, CatBytesBytes) + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in cnrOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String CatNodesRow of + Right row -> + case cnrOther row of + Object o -> KM.keys o `shouldContain` ["name", "uptime"] + _ -> expectationFailure "expected cnrOther to be an Object" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "rejects an unrecognised byte-size suffix" $ + case parseEither parseJSON =<< eitherDecode badUnitRow :: Either String CatNodesRow of + Right row -> expectationFailure ("expected parse failure, got " <> show row) + Left _ -> return () + + -- Defensive coverage: if OpenSearch emits a native JSON number for + -- an integer column (instead of the usual string), the parser + -- should still succeed by stringifying the integer-valued + -- Scientific without a trailing ".0". See 'parseAsString'. + it "tolerates a native JSON number for an integer column (cpu)" $ + case parseEither parseJSON =<< eitherDecode "{\"name\":\"x\",\"cpu\":99}" :: Either String CatNodesRow of + Right row -> cnrCpu row `shouldBe` Just 99 + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for heap.percent" $ + case parseEither parseJSON =<< eitherDecode "{\"name\":\"x\",\"heap.percent\":50}" :: Either String CatNodesRow of + Right row -> cnrHeapPercent row `shouldBe` Just 50 + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for load_1m (fractional)" $ + case parseEither parseJSON =<< eitherDecode "{\"name\":\"x\",\"load_1m\":0.07}" :: Either String CatNodesRow of + Right row -> cnrLoad1m row `shouldBe` Just 0.07 + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates a native JSON number for heap.current (treated as bare bytes)" $ + case parseEither parseJSON =<< eitherDecode "{\"name\":\"x\",\"heap.current\":208}" :: Either String CatNodesRow of + Right row -> cnrHeapCurrent row `shouldBe` Just (Bytes 208, CatBytesBytes) + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catNodesWith integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catNodesWith integration" $ do + it "returns at least one node row" $ + withTestEnv $ do + rows <- Client.catNodes + liftIO $ + rows `shouldSatisfy` (not . null) + + -- @_cat\/nodes@ does not accept a path-segment filter on either ES + -- or OS (unlike @_cat\/allocation@). Locks in that we see exactly + -- one elected master in the default output, so the @master@ column + -- round-trips the @"*"@ sentinel through 'CatNodesMaster' and the + -- parser doesn't accidentally mark every node as master. + it "exposes exactly one elected master via the master sentinel" $ + withTestEnv $ do + rows <- Client.catNodes + liftIO $ + length (filter ((== Just CatNodesMasterTrue) . cnrMaster) rows) `shouldBe` 1 + + it "honours the h= parameter and leaves unrequested columns absent" $ + withTestEnv $ do + allRows <- Client.catNodes + case allRows of + [] -> liftIO $ expectationFailure "expected at least one node row" + (firstRow : _) -> do + let name = cnrName firstRow + opts = + defaultCatNodesOptions + { cnoColumns = Just (CatNodesColName :| [CatNodesColCpu]) + } + filtered <- Client.catNodesWith opts + liftIO $ + case filter ((== name) . cnrName) filtered of + (row : _) -> do + -- Requested columns come back populated: + cnrName row `shouldBe` name + cnrCpu row `shouldSatisfy` isJust + -- Columns we did not request should be absent: + cnrIp row `shouldBe` Nothing + cnrHost row `shouldBe` Nothing + cnrHeapPercent row `shouldBe` Nothing + [] -> + expectationFailure "expected at least one row for the freshly-listed node" + + describe "catRecoveryColumnText rendering" $ + it "covers every documented column" $ + map + catRecoveryColumnText + [ CatRecoveryColIndex, + CatRecoveryColShard, + CatRecoveryColStartTime, + CatRecoveryColStartTimeMillis, + CatRecoveryColStopTime, + CatRecoveryColStopTimeMillis, + CatRecoveryColTime, + CatRecoveryColType, + CatRecoveryColStage, + CatRecoveryColSourceHost, + CatRecoveryColSourceNode, + CatRecoveryColTargetHost, + CatRecoveryColTargetNode, + CatRecoveryColRepository, + CatRecoveryColSnapshot, + CatRecoveryColFiles, + CatRecoveryColFilesRecovered, + CatRecoveryColFilesPercent, + CatRecoveryColFilesTotal, + CatRecoveryColBytes, + CatRecoveryColBytesRecovered, + CatRecoveryColBytesPercent, + CatRecoveryColBytesTotal, + CatRecoveryColTranslogOps, + CatRecoveryColTranslogOpsRecovered, + CatRecoveryColTranslogOpsPercent + ] + `shouldBe` [ "index", + "shard", + "start_time", + "start_time_millis", + "stop_time", + "stop_time_millis", + "time", + "type", + "stage", + "source_host", + "source_node", + "target_host", + "target_node", + "repository", + "snapshot", + "files", + "files_recovered", + "files_percent", + "files_total", + "bytes", + "bytes_recovered", + "bytes_percent", + "bytes_total", + "translog_ops", + "translog_ops_recovered", + "translog_ops_percent" + ] + + -- ------------------------------------------------------------------ -- + -- CatRecoveryRow JSON decoding -- + -- ------------------------------------------------------------------ -- + describe "CatRecoveryRow FromJSON" $ do + let fullRow = + "[{\"index\":\"test\",\"shard\":\"0\",\"start_time\":\"2024-01-01T00:00:00.000Z\",\"start_time_millis\":\"1704067200000\",\"stop_time\":\"2024-01-01T00:00:05.000Z\",\"stop_time_millis\":\"1704067205000\",\"time\":\"5s\",\"type\":\"store\",\"stage\":\"DONE\",\"source_host\":\"10.0.0.1\",\"source_node\":\"node-1\",\"target_host\":\"10.0.0.2\",\"target_node\":\"node-2\",\"repository\":\"repo1\",\"snapshot\":\"snap1\",\"files\":\"10\",\"files_recovered\":\"10\",\"files_percent\":\"100.0%\",\"files_total\":\"10\",\"bytes\":\"2048\",\"bytes_recovered\":\"2048\",\"bytes_percent\":\"100.0%\",\"bytes_total\":\"2048\",\"translog_ops\":\"5\",\"translog_ops_recovered\":\"5\",\"translog_ops_percent\":\"100.0%\"}]" + minimalRow = "[{\"index\":\"test\",\"shard\":\"0\"}]" + extraColumnRow = "[{\"index\":\"x\",\"custom.col\":\"xyz\"}]" + + it "parses a fully-populated default row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatRecoveryRow] of + Right (row : _) -> do + cryrIndex row `shouldBe` Just "test" + cryrShard row `shouldBe` Just 0 + cryrStartTime row `shouldBe` Just "2024-01-01T00:00:00.000Z" + cryrStartTimeMillis row `shouldBe` Just 1704067200000 + cryrStopTime row `shouldBe` Just "2024-01-01T00:00:05.000Z" + cryrStopTimeMillis row `shouldBe` Just 1704067205000 + cryrTime row `shouldBe` Just "5s" + cryrType row `shouldBe` Just "store" + cryrStage row `shouldBe` Just "DONE" + cryrSourceHost row `shouldBe` Just "10.0.0.1" + cryrSourceNode row `shouldBe` Just "node-1" + cryrTargetHost row `shouldBe` Just "10.0.0.2" + cryrTargetNode row `shouldBe` Just "node-2" + cryrRepository row `shouldBe` Just "repo1" + cryrSnapshot row `shouldBe` Just "snap1" + cryrFiles row `shouldBe` Just 10 + cryrFilesRecovered row `shouldBe` Just 10 + cryrFilesPercent row `shouldBe` Just "100.0%" + cryrFilesTotal row `shouldBe` Just 10 + cryrBytes row `shouldBe` Just 2048 + cryrBytesRecovered row `shouldBe` Just 2048 + cryrBytesPercent row `shouldBe` Just "100.0%" + cryrBytesTotal row `shouldBe` Just 2048 + cryrTranslogOps row `shouldBe` Just 5 + cryrTranslogOpsRecovered row `shouldBe` Just 5 + cryrTranslogOpsPercent row `shouldBe` Just "100.0%" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses a minimal row containing only index and shard" $ + case parseEither parseJSON =<< eitherDecode minimalRow :: Either String [CatRecoveryRow] of + Right (row : _) -> do + cryrIndex row `shouldBe` Just "test" + cryrShard row `shouldBe` Just 0 + cryrStage row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in cryrOther" $ + case parseEither parseJSON =<< eitherDecode extraColumnRow :: Either String [CatRecoveryRow] of + Right (row : _) -> + case cryrOther row of + Object o -> do + KM.keys o `shouldContain` ["index"] + KM.keys o `shouldContain` ["custom.col"] + _ -> expectationFailure "expected cryrOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates native JSON numbers for shard and bytes" $ + case parseEither parseJSON =<< eitherDecode "[{\"shard\":3,\"bytes\":4096,\"start_time_millis\":1704067200000}]" :: Either String [CatRecoveryRow] of + Right (row : _) -> do + cryrShard row `shouldBe` Just 3 + cryrBytes row `shouldBe` Just 4096 + cryrStartTimeMillis row `shouldBe` Just 1704067200000 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "parses an empty recovery list" $ + case parseEither parseJSON =<< eitherDecode "[]" :: Either String [CatRecoveryRow] of + Right rows -> rows `shouldBe` [] + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catRecovery integration (live ES) -- + -- ------------------------------------------------------------------ -- + describe "catRecovery integration" $ + it "returns a (possibly empty) list without throwing" $ + withTestEnv $ do + _ <- Client.catRecovery + pure () + + -- ------------------------------------------------------------------ -- + -- catComponentTemplatesOptionsParams: pure URI rendering -- + -- ------------------------------------------------------------------ -- + describe "catComponentTemplatesOptionsParams URI rendering" $ do + it "default emits only format=json" $ + catComponentTemplatesOptionsParams defaultCatComponentTemplatesOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatComponentTemplatesOptions + { cctoColumns = Just (CatComponentTemplatesColName :| [CatComponentTemplatesColIncludedIn]) + } + catComponentTemplatesOptionsParams opts + `shouldContain` [("h", Just "name,included_in")] + + it "renders sort (s) as a comma-joined list" $ do + let opts = defaultCatComponentTemplatesOptions {cctoSort = Just ("name" :| ["version:desc"])} + catComponentTemplatesOptionsParams opts + `shouldContain` [("s", Just "name,version:desc")] + + it "renders booleans and master_timeout" $ do + let opts = + defaultCatComponentTemplatesOptions + { cctoHelp = Just True, + cctoLocal = Just False, + cctoVerbose = Just True, + cctoMasterTimeout = Just (TimeUnitSeconds, 30) + } + let ps = catComponentTemplatesOptionsParams opts + ps `shouldContain` [("help", Just "true")] + ps `shouldContain` [("local", Just "false")] + ps `shouldContain` [("v", Just "true")] + ps `shouldContain` [("master_timeout", Just "30s")] + + describe "catComponentTemplatesColumnText rendering" $ + it "covers documented columns" $ + map + catComponentTemplatesColumnText + [CatComponentTemplatesColName, CatComponentTemplatesColAliasCount, CatComponentTemplatesColIncludedIn] + `shouldBe` ["name", "alias_count", "included_in"] + + describe "CatComponentTemplatesRow FromJSON" $ do + let fullRow = + "[{\"name\":\"my-template-1\",\"version\":\"null\",\"alias_count\":\"0\",\ + \\"mapping_count\":\"0\",\"settings_count\":\"1\",\"metadata_count\":\"0\",\ + \\"included_in\":\"[my-index-template]\"}]" + + it "parses a fully-populated row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatComponentTemplatesRow] of + Right (row : _) -> do + cctrName row `shouldBe` Just "my-template-1" + cctrVersion row `shouldBe` Just "null" + cctrAliasCount row `shouldBe` Just 0 + cctrSettingsCount row `shouldBe` Just 1 + cctrIncludedIn row `shouldBe` Just "[my-index-template]" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "maps a native JSON null version to Nothing" $ + case parseEither parseJSON =<< eitherDecode "[{\"name\":\"t2\",\"version\":null}]" :: Either String [CatComponentTemplatesRow] of + Right (row : _) -> cctrVersion row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in cctrOther" $ + case parseEither parseJSON =<< eitherDecode "[{\"name\":\"t3\",\"future.col\":\"x\"}]" :: Either String [CatComponentTemplatesRow] of + Right (row : _) -> + case cctrOther row of + Object o -> do + KM.keys o `shouldSatisfy` ("name" `elem`) + KM.keys o `shouldSatisfy` ("future.col" `elem`) + _ -> expectationFailure "expected cctrOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates native JSON numbers for counts" $ + case parseEither parseJSON =<< eitherDecode "[{\"alias_count\":5,\"mapping_count\":2}]" :: Either String [CatComponentTemplatesRow] of + Right (row : _) -> do + cctrAliasCount row `shouldBe` Just 5 + cctrMappingCount row `shouldBe` Just 2 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + describe "catComponentTemplates integration" $ + backendSpecific [ElasticSearch8, ElasticSearch9] $ + it "returns a (possibly empty) list without throwing" $ + withTestEnv $ do + _ <- Client.catComponentTemplates + pure () + + -- ------------------------------------------------------------------ -- + -- catCircuitBreakersOptionsParams: pure URI rendering -- + -- ------------------------------------------------------------------ -- + describe "catCircuitBreakersOptionsParams URI rendering" $ do + it "default emits only format=json" $ + catCircuitBreakersOptionsParams defaultCatCircuitBreakersOptions + `shouldBe` [("format", Just "json")] + + it "renders columns (h) as a comma-joined list" $ do + let opts = + defaultCatCircuitBreakersOptions + { ccboColumns = Just (CatCircuitBreakersColBreaker :| [CatCircuitBreakersColTripped]) + } + catCircuitBreakersOptionsParams opts + `shouldContain` [("h", Just "breaker,tripped")] + + it "renders booleans and master_timeout" $ do + let opts = + defaultCatCircuitBreakersOptions + { ccboLocal = Just True, + ccboMasterTimeout = Just (TimeUnitMinutes, 1) + } + let ps = catCircuitBreakersOptionsParams opts + ps `shouldContain` [("local", Just "true")] + ps `shouldContain` [("master_timeout", Just "1m")] + + describe "CatCircuitBreakersRow FromJSON" $ do + let fullRow = + "[{\"node_id\":\"ozKxpP9oS3SL0Sp-Mfxc6w\",\"node_name\":\"node-1\",\ + \\"breaker\":\"request\",\"limit\":\"614.3mb\",\"limit_bytes\":\"644245094\",\ + \\"estimated\":\"0b\",\"estimated_bytes\":\"0\",\"tripped\":\"0\",\"overhead\":\"1.03\"}]" + + it "parses a fully-populated row" $ + case parseEither parseJSON =<< eitherDecode fullRow :: Either String [CatCircuitBreakersRow] of + Right (row : _) -> do + ccbrBreaker row `shouldBe` Just "request" + ccbrLimit row `shouldBe` Just "614.3mb" + ccbrLimitBytes row `shouldBe` Just 644245094 + ccbrEstimatedBytes row `shouldBe` Just 0 + ccbrTripped row `shouldBe` Just 0 + ccbrOverhead row `shouldBe` Just "1.03" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates native JSON numbers for bytes/tripped" $ + case parseEither parseJSON =<< eitherDecode "[{\"tripped\":3,\"limit_bytes\":1024}]" :: Either String [CatCircuitBreakersRow] of + Right (row : _) -> do + ccbrTripped row `shouldBe` Just 3 + ccbrLimitBytes row `shouldBe` Just 1024 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "captures unknown columns verbatim in ccbrOther" $ + case parseEither parseJSON =<< eitherDecode "[{\"breaker\":\"x\",\"future.col\":\"y\"}]" :: Either String [CatCircuitBreakersRow] of + Right (row : _) -> + case ccbrOther row of + Object o -> do + KM.keys o `shouldSatisfy` ("breaker" `elem`) + KM.keys o `shouldSatisfy` ("future.col" `elem`) + _ -> expectationFailure "expected ccbrOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + describe "catCircuitBreakers integration" $ + backendSpecific [ElasticSearch9] $ + it "returns a non-empty list on any cluster" $ + withTestEnv $ do + rows <- Client.catCircuitBreakers + liftIO $ rows `shouldSatisfy` (not . null) + + -- ------------------------------------------------------------------ -- + -- catMlJobsOptionsParams / CatMlJobsRow -- + -- ------------------------------------------------------------------ -- + describe "catMlJobsOptionsParams URI rendering" $ do + it "default emits only format=json" $ + catMlJobsOptionsParams defaultCatMlJobsOptions + `shouldBe` [("format", Just "json")] + + it "renders allow_no_match and columns" $ do + let opts = + defaultCatMlJobsOptions + { cmjoAllowNoMatch = Just True, + cmjoColumns = Just (CatMlJobsColId :| [CatMlJobsColState]) + } + let ps = catMlJobsOptionsParams opts + ps `shouldContain` [("allow_no_match", Just "true")] + ps `shouldContain` [("h", Just "id,state")] + + describe "CatMlJobsRow FromJSON" $ do + it "parses a row with dotted keys" $ + case parseEither parseJSON =<< eitherDecode "[{\"id\":\"high_sum_total_sales\",\"state\":\"closed\",\"data.processed_records\":\"14022\",\"model.bytes\":\"1600000\"}]" :: Either String [CatMlJobsRow] of + Right (row : _) -> do + cmjrId row `shouldBe` Just "high_sum_total_sales" + cmjrState row `shouldBe` Just "closed" + cmjrDataProcessedRecords row `shouldBe` Just 14022 + cmjrModelBytes row `shouldBe` Just 1600000 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "tolerates native JSON numbers and captures extras in cmjrOther" $ + case parseEither parseJSON =<< eitherDecode "[{\"id\":\"j\",\"buckets.count\":10,\"model.memory_status\":\"ok\",\"future.col\":\"z\"}]" :: Either String [CatMlJobsRow] of + Right (row : _) -> do + cmjrBucketsCount row `shouldBe` Just 10 + cmjrModelMemoryStatus row `shouldBe` Just "ok" + case cmjrOther row of + Object o -> KM.keys o `shouldContain` ["future.col"] + _ -> expectationFailure "expected cmjrOther to be an Object" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catMlDataFrameAnalyticsOptionsParams / CatMlDataFrameAnalyticsRow -- + -- ------------------------------------------------------------------ -- + describe "catMlDataFrameAnalyticsOptionsParams URI rendering" $ + it "renders allow_no_match" $ do + let opts = defaultCatMlDataFrameAnalyticsOptions {cmfaoAllowNoMatch = Just False} + catMlDataFrameAnalyticsOptionsParams opts + `shouldContain` [("allow_no_match", Just "false")] + + describe "CatMlDataFrameAnalyticsRow FromJSON" $ + it "parses a documented row" $ + case parseEither parseJSON =<< eitherDecode "[{\"id\":\"classifier_job_1\",\"type\":\"classification\",\"create_time\":\"2020-02-12T11:49:09.594Z\",\"state\":\"stopped\"}]" :: Either String [CatMlDataFrameAnalyticsRow] of + Right (row : _) -> do + cmfaId row `shouldBe` Just "classifier_job_1" + cmfaType row `shouldBe` Just "classification" + cmfaState row `shouldBe` Just "stopped" + cmfaCreateTime row `shouldBe` Just "2020-02-12T11:49:09.594Z" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catMlDatafeedsOptionsParams / CatMlDatafeedsRow -- + -- ------------------------------------------------------------------ -- + describe "catMlDatafeedsOptionsParams URI rendering" $ + it "renders sort" $ do + let opts = defaultCatMlDatafeedsOptions {cmdfoSort = Just ("id" :| [])} + catMlDatafeedsOptionsParams opts + `shouldContain` [("s", Just "id")] + + describe "CatMlDatafeedsRow FromJSON" $ + it "parses dotted search/buckets keys" $ + case parseEither parseJSON =<< eitherDecode "[{\"id\":\"datafeed-high_sum_total_sales\",\"state\":\"stopped\",\"buckets.count\":\"743\",\"search.count\":\"7\"}]" :: Either String [CatMlDatafeedsRow] of + Right (row : _) -> do + cmdfId row `shouldBe` Just "datafeed-high_sum_total_sales" + cmdfBucketsCount row `shouldBe` Just 743 + cmdfSearchCount row `shouldBe` Just 7 + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catMlTrainedModelsOptionsParams / CatMlTrainedModelsRow -- + -- ------------------------------------------------------------------ -- + describe "catMlTrainedModelsOptionsParams URI rendering" $ do + it "renders from/size pagination" $ do + let opts = + defaultCatMlTrainedModelsOptions + { cmtoFrom = Just 10, + cmtoSize = Just 25 + } + let ps = catMlTrainedModelsOptionsParams opts + ps `shouldContain` [("from", Just "10")] + ps `shouldContain` [("size", Just "25")] + + describe "CatMlTrainedModelsRow FromJSON" $ + it "parses a documented row including the __none__ sentinel" $ + case parseEither parseJSON =<< eitherDecode "[{\"id\":\"lang_ident_model_1\",\"heap_size\":\"1mb\",\"operations\":\"39629\",\"create_time\":\"2019-12-05T12:28:34.594Z\",\"type\":\"lang_ident\",\"ingest.pipelines\":\"0\",\"data_frame.id\":\"__none__\"}]" :: Either String [CatMlTrainedModelsRow] of + Right (row : _) -> do + ctmrId row `shouldBe` Just "lang_ident_model_1" + ctmrHeapSize row `shouldBe` Just "1mb" + ctmrType row `shouldBe` Just "lang_ident" + ctmrIngestPipelines row `shouldBe` Just "0" + ctmrDataFrameId row `shouldBe` Just "__none__" + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catTransformsOptionsParams / CatTransformsRow -- + -- ------------------------------------------------------------------ -- + describe "catTransformsOptionsParams URI rendering" $ + it "renders from/size pagination" $ do + let opts = defaultCatTransformsOptions {ctxoSize = Just 50} + catTransformsOptionsParams opts + `shouldContain` [("size", Just "50")] + + describe "CatTransformsRow FromJSON" $ do + it "parses a documented row" $ + case parseEither parseJSON =<< eitherDecode "[{\"id\":\"ecommerce_transform\",\"state\":\"started\",\"checkpoint\":\"1\",\"documents_processed\":\"705\",\"checkpoint_progress\":\"100.00\",\"changes_last_detection_time\":null}]" :: Either String [CatTransformsRow] of + Right (row : _) -> do + ctxrId row `shouldBe` Just "ecommerce_transform" + ctxrState row `shouldBe` Just "started" + ctxrCheckpoint row `shouldBe` Just "1" + ctxrDocumentsProcessed row `shouldBe` Just 705 + ctxrCheckpointProgress row `shouldBe` Just "100.00" + ctxrChangesLastDetectionTime row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + it "maps a native JSON null last_search_time to Nothing" $ + case parseEither parseJSON =<< eitherDecode "[{\"id\":\"t\",\"last_search_time\":null}]" :: Either String [CatTransformsRow] of + Right (row : _) -> ctxrLastSearchTime row `shouldBe` Nothing + Right [] -> expectationFailure "expected at least one row" + Left e -> expectationFailure ("expected parse, got " <> e) + + -- ------------------------------------------------------------------ -- + -- catHelp: plain-text meta endpoint (no params, non-JSON body) -- + -- ------------------------------------------------------------------ -- + describe "catHelp endpoint shape" $ do + let path req = getRawEndpoint (bhRequestEndpoint req) + queries req = getRawEndpointQueries (bhRequestEndpoint req) + it "targets /_cat (the cross-version help root)" $ + path catHelp `shouldBe` ["_cat"] + it "carries no query string" $ + queries catHelp `shouldBe` [] + + describe "catHelp integration" $ + it "returns a non-empty plain-text help listing" $ + withTestEnv $ do + help <- Client.catHelp + liftIO $ help `shouldSatisfy` (not . T.null) + where + -- \| Create a freshly-emptied cat-test index, run the action with + -- the index name, and delete the index afterwards even if the + -- action throws (so a failing assertion cannot leak the index into + -- subsequent runs). + withCatIndex :: IndexName -> (IndexName -> BH IO a) -> BH IO a + withCatIndex idx action = bracket_ setup teardown (action idx) + where + setup = do + _ <- tryPerformBHRequest $ deleteIndex idx + void $ + performBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + idx + teardown = void $ tryPerformBHRequest $ deleteIndex idx + + -- \| Create a freshly-emptied source index and a write-index alias on + -- top of it, run the action with both names, and tear the alias and + -- the index down afterwards even if the action throws. Mirrors + -- 'withCatIndex' but additionally wires up 'createIndexAlias' / + -- 'deleteIndexAlias' so the @_cat\/aliases@ smoke test always has a + -- concrete alias to look for. + withCatAlias :: IndexName -> IndexName -> (IndexName -> IndexName -> BH IO a) -> BH IO a + withCatAlias idx alias action = + bracket_ setup teardown (action idx alias) + where + aliasName = IndexAliasName alias + writeCreate = defaultIndexAliasCreate {aliasCreateIsWriteIndex = Just True} + setup = do + _ <- tryPerformBHRequest $ deleteIndexAlias aliasName + _ <- tryPerformBHRequest $ deleteIndex idx + void $ + performBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + idx + void $ performBHRequest $ createIndexAlias idx aliasName writeCreate + teardown = do + _ <- tryPerformBHRequest $ deleteIndexAlias aliasName + void $ tryPerformBHRequest $ deleteIndex idx + + -- \| Create a freshly-emptied cat-test index whose mapping enables + -- fielddata on a text field, index a single document populating that + -- field, and refresh. The fielddata cache itself is loaded lazily by + -- the caller (via a sort on the field); the helper only sets up the + -- precondition. Mirrors 'withCatIndex' / 'withCatAlias'. + withCatFielddata :: IndexName -> FieldName -> (IndexName -> FieldName -> BH IO a) -> BH IO a + withCatFielddata idx field action = + bracket_ setup teardown (action idx field) + where + setup = do + _ <- tryPerformBHRequest $ deleteIndex idx + void $ + performBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + idx + void $ + performBHRequest $ + putMapping @Value idx mappingBody + void $ + performBHRequest $ + indexDocument idx defaultIndexDocumentSettings docBody (DocId "1") + void $ performBHRequest $ refreshIndex idx + teardown = void $ tryPerformBHRequest $ deleteIndex idx + mappingBody = + object + [ "properties" + .= object + [ fromText (unFieldName field) + .= object + [ "type" .= ("text" :: Text), + "fielddata" .= True + ] + ] + ] + docBody = object [fromText (unFieldName field) .= ("hello world" :: Text)] diff --git a/tests/Test/ClusterAllocationExplainSpec.hs b/tests/Test/ClusterAllocationExplainSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ClusterAllocationExplainSpec.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.ClusterAllocationExplainSpec where + +import Data.Aeson (decode, encode) +import Data.Aeson.Types (parseEither) +import Data.ByteString.Lazy.Char8 qualified as L +import Data.Text qualified as T +import Database.Bloodhound.Common.Client qualified as Client +import TestsUtils.Common +import TestsUtils.Import + +-- | A captured sample of the ES response for an allocation-explain +-- call that targeted a specific shard. Real responses from +-- @GET\/POST /_cluster/allocation/explain@ vary in which fields appear +-- (the server omits @current_node@ for unassigned shards and +-- @unassigned_info@ for assigned ones), so this sample exercises the +-- lenient @.?:@ decoder on every typed field. +sampleExplanation :: L.ByteString +sampleExplanation = + "{\ + \ \"index\": \"bloodhound-tests-allocation-explain\",\ + \ \"shard\": 0,\ + \ \"primary\": true,\ + \ \"current_state\": \"STARTED\",\ + \ \"current_node\": {\ + \ \"id\": \"node-1\",\ + \ \"name\": \"node-1\",\ + \ \"transport_address\": \"127.0.0.1:9300\",\ + \ \"attributes\": {}\ + \ },\ + \ \"relocating_node\": null,\ + \ \"shard_state\": \"STARTED\",\ + \ \"unassigned_info\": null,\ + \ \"allocate_droning\": false,\ + \ \"cluster_info\": {\ + \ \"nodes\": {},\ + \ \"shard_sizes\": {}\ + \ },\ + \ \"nodes\": {},\ + \ \"decisions\": [\ + \ {\ + \ \"decider\": \"same_shard\",\ + \ \"decision\": \"YES\",\ + \ \"explanation\": \"the shard is not allocated to the same node\"\ + \ }\ + \ ]\ + \}" + +-- | A captured sample of the modern (ES 7.x+) allocation-explain +-- response carrying the richer top-level diagnostics that live in +-- 'aeOther': the @can_*@ and @rebalance_explanation@ scalars plus a +-- @node_allocation_decisions@ array whose per-node entries nest a +-- @deciders@ list. The deciders entries share their shape with the +-- legacy top-level @decisions@ array, so 'AllocationDecision' decodes +-- both. +sampleModernExplanation :: L.ByteString +sampleModernExplanation = + "{\ + \ \"index\": \"bloodhound-tests-allocation-explain\",\ + \ \"shard\": 0,\ + \ \"primary\": false,\ + \ \"current_state\": \"UNASSIGNED\",\ + \ \"can_remain_on_current_node\": \"no\",\ + \ \"can_rebalance_cluster\": \"yes\",\ + \ \"can_rebalance_to_other_node\": \"no\",\ + \ \"rebalance_explanation\": \"cannot rebalance because no target node exists\",\ + \ \"node_allocation_decisions\": [\ + \ {\ + \ \"node_id\": \"node-1\",\ + \ \"node_name\": \"node-1\",\ + \ \"transport_address\": \"127.0.0.1:9300\",\ + \ \"roles\": [\"data\", \"master\"],\ + \ \"node_attributes\": {\"data\": \"hot\"},\ + \ \"node_decision\": \"NO\",\ + \ \"weight_ranking\": 1,\ + \ \"deciders\": [\ + \ {\"decider\": \"filter\", \"decision\": \"NO\", \"explanation\": \"node does not match filter\"}\ + \ ]\ + \ }\ + \ ]\ + \}" + +spec :: Spec +spec = do + -- ------------------------------------------------------------------ -- + -- Pure JSON decoding / encoding (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "AllocationExplanation FromJSON" $ do + it "decodes the captured sample into typed top-level fields" $ do + let decoded = decode sampleExplanation :: Maybe AllocationExplanation + decoded `shouldSatisfy` isJust + let Just ex = decoded + aeIndex ex `shouldBe` Just [qqIndexName|bloodhound-tests-allocation-explain|] + aeShard ex `shouldBe` Just (ShardId 0) + aePrimary ex `shouldBe` Just True + aeCurrentState ex `shouldBe` "STARTED" + aeAllocateDroning ex `shouldBe` Just False + + it "preserves nested blobs (current_node, decisions) as Value" $ do + let Just ex = decode sampleExplanation :: Maybe AllocationExplanation + aeCurrentNode ex `shouldSatisfy` isJust + aeDecisions ex `shouldSatisfy` isJust + + it "tolerates a body-less response missing index/shard/primary" $ do + let minimal = "{\"current_state\":\"STARTED\"}" :: L.ByteString + let decoded = decode minimal :: Maybe AllocationExplanation + decoded `shouldSatisfy` isJust + let Just ex = decoded + aeIndex ex `shouldBe` Nothing + aeShard ex `shouldBe` Nothing + aePrimary ex `shouldBe` Nothing + aeCurrentState ex `shouldBe` "STARTED" + + it "rejects a payload missing current_state" $ do + let bad = "{\"index\":\"foo\"}" :: L.ByteString + let decoded = decode bad :: Maybe AllocationExplanation + decoded `shouldBe` Nothing + + it "FromJSON/parseEither yields a value with the right current_state" $ do + case decode sampleExplanation :: Maybe Value of + Nothing -> expectationFailure "decode produced Nothing" + Just v -> + case parseEither parseJSON v :: Either String AllocationExplanation of + Left e -> expectationFailure e + Right ex -> aeCurrentState ex `shouldBe` "STARTED" + + describe "AllocationExplanation typed views" $ do + -- The maintainer's record keeps current_node / unassigned_info / + -- decisions as opaque Value blobs. The typed-view helpers lift + -- them into dedicated records (AllocationCurrentNode, + -- AllocationUnassignedInfo, AllocationDecision) so callers can + -- access fields without manually decoding aeson. + + it "aeCurrentNodeTyped decodes id/name (modern ES shape)" $ do + let Just ex = decode sampleExplanation :: Maybe AllocationExplanation + case aeCurrentNodeTyped ex of + Just cn -> do + acnId cn `shouldBe` Just "node-1" + acnName cn `shouldBe` Just "node-1" + acnTransportAddress cn `shouldBe` Just "127.0.0.1:9300" + Nothing -> expectationFailure "expected typed current_node" + + it "aeCurrentNodeTyped falls back to node_id/node_name (legacy ES shape)" $ do + let payload = + "{\"current_state\":\"STARTED\",\ + \ \"current_node\":{\"node_id\":\"legacy-id\",\"node_name\":\"legacy-name\"}}" + Just ex = decode payload :: Maybe AllocationExplanation + case aeCurrentNodeTyped ex of + Just cn -> do + acnId cn `shouldBe` Just "legacy-id" + acnName cn `shouldBe` Just "legacy-name" + Nothing -> expectationFailure "expected typed current_node" + + it "aeCurrentNodeTyped returns Nothing when current_node is absent" $ do + let payload = "{\"current_state\":\"UNASSIGNED\"}" + Just ex = decode payload :: Maybe AllocationExplanation + aeCurrentNodeTyped ex `shouldBe` Nothing + + it "aeDecisionsTyped decodes the decider/decision/explanation trio" $ do + let Just ex = decode sampleExplanation :: Maybe AllocationExplanation + case aeDecisionsTyped ex of + Just (d : _) -> do + adDecider d `shouldBe` Just "same_shard" + adDecision d `shouldBe` Just "YES" + adExplanation d `shouldBe` Just "the shard is not allocated to the same node" + other -> expectationFailure ("expected non-empty decisions, got " <> show other) + + it "aeUnassignedInfoTyped returns Nothing on the assigned-shard sample" $ do + let Just ex = decode sampleExplanation :: Maybe AllocationExplanation + aeUnassignedInfoTyped ex `shouldBe` Nothing + + it "aeUnassignedInfoTyped decodes reason / last_allocation_status when present" $ do + let payload = + "{\"current_state\":\"UNASSIGNED\",\ + \ \"unassigned_info\":{\ + \ \"reason\":\"NODE_LEFT\",\ + \ \"at\":\"2024-01-01T00:00:00.000Z\",\ + \ \"last_allocation_status\":\"no\"}}" + Just ex = decode payload :: Maybe AllocationExplanation + case aeUnassignedInfoTyped ex of + Just ui -> do + auiReason ui `shouldBe` Just "NODE_LEFT" + auiAt ui `shouldBe` Just "2024-01-01T00:00:00.000Z" + auiLastAllocationStatus ui `shouldBe` Just "no" + Nothing -> expectationFailure "expected typed unassigned_info" + + it "typed records round-trip through ToJSON/FromJSON without dropping fields" $ + let Just ex = decode sampleExplanation :: Maybe AllocationExplanation + in case aeCurrentNodeTyped ex of + Just cn -> + case decode (encode cn) :: Maybe AllocationCurrentNode of + Just again -> again `shouldBe` cn + Nothing -> expectationFailure "typed current_node did not round-trip" + Nothing -> expectationFailure "expected typed current_node" + + describe "AllocationExplanation aeOther capture and modern typed views" $ do + -- ES 7.x+ emits can_* / rebalance_explanation scalars plus a + -- node_allocation_decisions[] array alongside the legacy fields. + -- The bead's acceptance is: round-trip preserves a real ES7+ + -- node_allocation_decisions payload, and the new typed accessors + -- expose can_remain_on_current_node and the per-node decisions + -- array. + + it "aeOther captures the modern diagnostics verbatim" $ do + let Just ex = decode sampleModernExplanation :: Maybe AllocationExplanation + aeCurrentState ex `shouldBe` "UNASSIGNED" + case aeOther ex of + Object _ -> pure () + other -> expectationFailure ("aeOther should be an Object, got " <> show other) + + it "aeCanRemainOnCurrentNodeTyped exposes the can_remain_on_current_node scalar" $ do + let Just ex = decode sampleModernExplanation :: Maybe AllocationExplanation + aeCanRemainOnCurrentNodeTyped ex `shouldBe` Just "no" + + it "aeCanRebalanceClusterTyped / aeCanRebalanceToOtherNodeTyped expose the rebalance scalars" $ do + let Just ex = decode sampleModernExplanation :: Maybe AllocationExplanation + aeCanRebalanceClusterTyped ex `shouldBe` Just "yes" + aeCanRebalanceToOtherNodeTyped ex `shouldBe` Just "no" + + it "aeRebalanceExplanationTyped exposes the rebalance_explanation scalar" $ do + let Just ex = decode sampleModernExplanation :: Maybe AllocationExplanation + aeRebalanceExplanationTyped ex `shouldBe` Just "cannot rebalance because no target node exists" + + it "aeCanRemainOnCurrentNodeTyped returns Nothing when the key is absent" $ do + let Just ex = decode sampleExplanation :: Maybe AllocationExplanation + aeCanRemainOnCurrentNodeTyped ex `shouldBe` Nothing + aeCanRebalanceClusterTyped ex `shouldBe` Nothing + aeCanRebalanceToOtherNodeTyped ex `shouldBe` Nothing + aeRebalanceExplanationTyped ex `shouldBe` Nothing + + it "aeNodeAllocationDecisionsTyped decodes the per-node array with nested deciders" $ do + let Just ex = decode sampleModernExplanation :: Maybe AllocationExplanation + case aeNodeAllocationDecisionsTyped ex of + Just (nad : _) -> do + nadNodeId nad `shouldBe` Just "node-1" + nadNodeName nad `shouldBe` Just "node-1" + nadTransportAddress nad `shouldBe` Just "127.0.0.1:9300" + nadNodeDecision nad `shouldBe` Just "NO" + nadWeightRanking nad `shouldBe` Just 1 + case nadDeciders nad of + Just (d : _) -> do + adDecider d `shouldBe` Just "filter" + adDecision d `shouldBe` Just "NO" + adExplanation d `shouldBe` Just "node does not match filter" + other -> expectationFailure ("expected non-empty deciders, got " <> show other) + other -> expectationFailure ("expected non-empty node_allocation_decisions, got " <> show other) + + it "aeNodeAllocationDecisionsTyped returns Nothing when the key is absent" $ do + let Just ex = decode sampleExplanation :: Maybe AllocationExplanation + aeNodeAllocationDecisionsTyped ex `shouldBe` Nothing + + it "NodeAllocationDecision decodes legacy id/name keys (pre-7.x node decision shape)" $ do + let payload = + "[{\"id\":\"legacy-id\",\"name\":\"legacy-name\",\ + \ \"transport_address\":\"127.0.0.1:9301\",\ + \ \"node_decision\":\"YES\"}]" + case decode payload :: Maybe [NodeAllocationDecision] of + Just (nad : _) -> do + nadNodeId nad `shouldBe` Just "legacy-id" + nadNodeName nad `shouldBe` Just "legacy-name" + other -> expectationFailure ("expected non-empty list, got " <> show other) + + it "AllocationExplanation round-trip preserves the typed top-level fields and aeOther" $ do + let Just ex = decode sampleModernExplanation :: Maybe AllocationExplanation + Just again = decode (encode ex) :: Maybe AllocationExplanation + aeCurrentState again `shouldBe` "UNASSIGNED" + aeShard again `shouldBe` Just (ShardId 0) + aePrimary again `shouldBe` Just False + aeCanRemainOnCurrentNodeTyped again `shouldBe` Just "no" + aeNodeAllocationDecisionsTyped again `shouldSatisfy` isJust + case aeNodeAllocationDecisionsTyped again of + Just (nad : _) -> nadNodeId nad `shouldBe` Just "node-1" + Nothing -> expectationFailure "node_allocation_decisions lost on round-trip" + + describe "AllocationExplainRequest ToJSON" $ do + it "mkAllocationExplainRequest renders index/shard/primary" $ do + let req = + mkAllocationExplainRequest + [qqIndexName|my-index|] + (ShardId 0) + True + -- Structural comparison: avoids coupling to aeson's KeyMap ordering. + decode (encode req) `shouldBe` (Just $ object ["index" .= ("my-index" :: Text), "primary" .= True, "shard" .= (0 :: Int)]) + + it "defaultAllocationExplainRequest renders the empty body {}" $ do + encode defaultAllocationExplainRequest `shouldBe` "{}" + + it "a request with current_node renders it alongside the others" $ do + let req = + ( mkAllocationExplainRequest + [qqIndexName|my-index|] + (ShardId 2) + False + ) + { aerCurrentNode = Just "node-42" + } + decode (encode req) + `shouldBe` ( Just $ + object + [ "current_node" .= ("node-42" :: Text), + "index" .= ("my-index" :: Text), + "primary" .= False, + "shard" .= (2 :: Int) + ] + ) + + -- ------------------------------------------------------------------ -- + -- Live cluster (requires ES_TEST_SERVER) -- + -- ------------------------------------------------------------------ -- + describe "cluster allocation explain API" $ do + -- The body-less form asks the server to explain a randomly-chosen + -- unassigned shard. When the cluster has no unassigned shards ES + -- returns HTTP 400 with the documented "No shard was specified" + -- message; both outcomes are valid end-to-end behaviour, so the + -- test asserts that one of them happens. + it "explainAllocation Nothing either explains an unassigned shard or 400s" $ + withTestEnv $ do + result <- tryEsError (Client.explainAllocation Nothing) + case result of + Left e -> + liftIO $ errorStatus e `shouldBe` Just 400 + Right explanation -> + liftIO $ + aeCurrentState explanation + `shouldSatisfy` (not . T.null) + + it "explainAllocation (Just ...) targets a specific shard" $ + withTestEnv $ do + let idx = [qqIndexName|bloodhound-tests-allocation-explain|] + _ <- tryPerformBHRequest $ deleteIndex idx + _ <- + performBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + idx + explanation <- + Client.explainAllocation + (Just (mkAllocationExplainRequest idx (ShardId 0) True)) + liftIO $ aeIndex explanation `shouldBe` Just idx + liftIO $ aeShard explanation `shouldBe` Just (ShardId 0) + liftIO $ aePrimary explanation `shouldBe` Just True + liftIO $ + aeCurrentState explanation + `shouldSatisfy` (not . T.null) + _ <- tryPerformBHRequest $ deleteIndex idx + pure () diff --git a/tests/Test/ClusterHealthSpec.hs b/tests/Test/ClusterHealthSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ClusterHealthSpec.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.ClusterHealthSpec where + +import Data.List qualified as L +import Data.Text qualified as T +import Database.Bloodhound.Common.Client qualified as Client +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + describe "cluster health API" $ do + it "returns cluster health information" $ + withTestEnv $ do + health <- Client.getClusterHealth + liftIO $ clusterHealthClusterName health `shouldSatisfy` (not . T.null) + liftIO $ clusterHealthNumberOfNodes health `shouldSatisfy` (> 0) + liftIO $ clusterHealthNumberOfDataNodes health `shouldSatisfy` (> 0) + + it "returns valid health status" $ + withTestEnv $ do + health <- Client.getClusterHealth + liftIO $ clusterHealthStatus health `shouldSatisfy` (`elem` [ClusterHealthGreen, ClusterHealthYellow, ClusterHealthRed]) + + it "returns shard information" $ + withTestEnv $ do + health <- Client.getClusterHealth + liftIO $ clusterHealthActivePrimaryShards health `shouldSatisfy` (>= 0) + liftIO $ clusterHealthActiveShards health `shouldSatisfy` (>= 0) + + -- ------------------------------------------------------------------ -- + -- Per-index + options (bloodhound-04f.4.1.7) -- + -- ------------------------------------------------------------------ -- + it "getClusterHealthForIndex returns health for a specific index" $ + withTestEnv $ do + let idx = [qqIndexName|bloodhound-tests-cluster-health-per-index|] + _ <- tryPerformBHRequest $ deleteIndex idx + _ <- + performBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + idx + health <- Client.getClusterHealthForIndex idx + liftIO $ clusterHealthStatus health `shouldSatisfy` (`elem` [ClusterHealthGreen, ClusterHealthYellow, ClusterHealthRed]) + liftIO $ clusterHealthActivePrimaryShards health `shouldSatisfy` (>= 0) + _ <- tryPerformBHRequest $ deleteIndex idx + pure () + + it "getClusterHealthWith defaultClusterHealthOptions returns a usable response" $ + withTestEnv $ do + health <- Client.getClusterHealthWith defaultClusterHealthOptions + liftIO $ clusterHealthClusterName health `shouldSatisfy` (not . T.null) + + it "getClusterHealthWith accepts level=indices (passthrough)" $ + withTestEnv $ do + let opts = + defaultClusterHealthOptions + { choLevel = Just ClusterHealthLevelIndices + } + health <- Client.getClusterHealthWith opts + -- The base fields are always present regardless of level; the + -- indices/shards breakdown is accepted but not modelled yet. + liftIO $ clusterHealthNumberOfNodes health `shouldSatisfy` (> 0) + + it "waitForYellowIndex still returns a health record (regression)" $ + withTestEnv $ do + let idx = [qqIndexName|bloodhound-tests-cluster-health-wait-yellow|] + _ <- tryPerformBHRequest $ deleteIndex idx + _ <- + performBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + idx + status <- performBHRequest $ waitForYellowIndex idx + liftIO $ healthStatusStatus status `shouldSatisfy` (`elem` ["green", "yellow"]) + _ <- tryPerformBHRequest $ deleteIndex idx + pure () + + -- ------------------------------------------------------------------ -- + -- clusterHealthOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "clusterHealthOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultClusterHealthOptions emits no params" $ + clusterHealthOptionsParams defaultClusterHealthOptions + `shouldBe` [] + + it "renders level via renderClusterHealthLevel" $ do + let opts = + defaultClusterHealthOptions + { choLevel = Just ClusterHealthLevelShards + } + clusterHealthOptionsParams opts + `shouldBe` [("level", Just "shards")] + + it "renders wait_for_status as the status string" $ do + let opts = + defaultClusterHealthOptions + { choWaitForStatus = Just ClusterHealthGreen + } + clusterHealthOptionsParams opts + `shouldBe` [("wait_for_status", Just "green")] + + it "renders wait_for_active_shards via ActiveShardCount" $ do + let opts = + defaultClusterHealthOptions + { choWaitForActiveShards = Just AllActiveShards + } + clusterHealthOptionsParams opts + `shouldBe` [("wait_for_active_shards", Just "all")] + + it "renders wait_for_nodes verbatim" $ do + let opts = + defaultClusterHealthOptions + { choWaitForNodes = Just "ge(2)" + } + clusterHealthOptionsParams opts + `shouldBe` [("wait_for_nodes", Just "ge(2)")] + + it "renders booleans as lowercase true/false" $ do + let opts = + defaultClusterHealthOptions + { choWaitForNoRelocatingShards = Just True, + choWaitForNoInitializingShards = Just False, + choLocal = Just True + } + normalize (clusterHealthOptionsParams opts) + `shouldBe` [ ("local", Just "true"), + ("wait_for_no_initializing_shards", Just "false"), + ("wait_for_no_relocating_shards", Just "true") + ] + + it "renders master_timeout and timeout as " $ do + let opts = + defaultClusterHealthOptions + { choMasterTimeout = Just (TimeUnitSeconds, 30), + choTimeout = Just (TimeUnitMilliseconds, 500) + } + normalize (clusterHealthOptionsParams opts) + `shouldBe` [ ("master_timeout", Just "30s"), + ("timeout", Just "500ms") + ] + + it "emits every param together when all are set" $ do + let opts = + defaultClusterHealthOptions + { choLevel = Just ClusterHealthLevelIndices, + choLocal = Just True, + choMasterTimeout = Just (TimeUnitMinutes, 1), + choWaitForStatus = Just ClusterHealthYellow, + choWaitForActiveShards = Just (ActiveShards 2), + choWaitForNodes = Just "le(3)", + choWaitForNoRelocatingShards = Just True, + choWaitForNoInitializingShards = Just True, + choTimeout = Just (TimeUnitSeconds, 10) + } + normalize (clusterHealthOptionsParams opts) + `shouldBe` [ ("level", Just "indices"), + ("local", Just "true"), + ("master_timeout", Just "1m"), + ("timeout", Just "10s"), + ("wait_for_active_shards", Just "2"), + ("wait_for_no_initializing_shards", Just "true"), + ("wait_for_no_relocating_shards", Just "true"), + ("wait_for_nodes", Just "le(3)"), + ("wait_for_status", Just "yellow") + ] diff --git a/tests/Test/ClusterRemoteInfoSpec.hs b/tests/Test/ClusterRemoteInfoSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ClusterRemoteInfoSpec.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.ClusterRemoteInfoSpec where + +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as AKM +import Data.HashMap.Strict qualified as HM +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + -- ---------------------------------------------------------------- -- + -- RemoteClusterInfo JSON: pure, no ES required. -- + -- Locks in the typed fields and the *Other catch-all that lets the -- + -- decoder tolerate future ES additions without failing. -- + -- ---------------------------------------------------------------- -- + describe "RemoteClusterInfo JSON" $ do + let minimalBytes = + Aeson.object + [ "seeds" .= ([] :: [Text]), + "connected" .= False, + "num_nodes_connected" .= (0 :: Int), + "max_connections_per_cluster" .= (0 :: Int) + ] + + it "decodes the minimal ES response shape (no optional fields)" $ do + let decoded = Aeson.decode' (Aeson.encode minimalBytes) :: Maybe RemoteClusterInfo + decoded + `shouldBe` Just + ( RemoteClusterInfo + { remoteClusterInfoSeeds = [], + remoteClusterInfoConnected = False, + remoteClusterInfoNumNodesConnected = 0, + remoteClusterInfoMaxConnectionsPerCluster = 0, + remoteClusterInfoMode = Nothing, + remoteClusterInfoSkipUnavailable = Nothing, + -- The *Other field captures whatever was on the + -- wire (here: exactly the four typed fields). + remoteClusterInfoOther = + Aeson.object + [ "seeds" .= ([] :: [Text]), + "connected" .= False, + "num_nodes_connected" .= (0 :: Int), + "max_connections_per_cluster" .= (0 :: Int) + ] + } + ) + + it "decodes the documented full fixture (sniff mode)" $ do + let bytes = + Aeson.object + [ "seeds" .= ["127.0.0.1:9400" :: Text], + "connected" .= True, + "num_nodes_connected" .= (3 :: Int), + "max_connections_per_cluster" .= (3 :: Int), + "initial_connect_timeout" .= ("30s" :: Text), + "skip_unavailable" .= False, + "mode" .= ("sniff" :: Text), + "proxy_address" .= Null, + "server_name" .= Null, + "has_proxy" .= False + ] + decoded = Aeson.decode' (Aeson.encode bytes) :: Maybe RemoteClusterInfo + decoded + `shouldSatisfy` \case + Just rci -> + remoteClusterInfoConnected rci + && remoteClusterInfoNumNodesConnected rci == 3 + && remoteClusterInfoMaxConnectionsPerCluster rci == 3 + && remoteClusterInfoMode rci == Just RemoteClusterModeSniff + && remoteClusterInfoSkipUnavailable rci == Just False + && remoteClusterInfoSeeds rci == ["127.0.0.1:9400"] + _ -> False + + it "decodes the documented proxy-mode fixture" $ do + let bytes = + Aeson.object + [ "connected" .= True, + "num_nodes_connected" .= (1 :: Int), + "max_connections_per_cluster" .= (3 :: Int), + "mode" .= ("proxy" :: Text), + "proxy_address" .= ("my.proxy:443" :: Text), + "server_name" .= ("es.example.com" :: Text), + "skip_unavailable" .= True + ] + decoded = Aeson.decode' (Aeson.encode bytes) :: Maybe RemoteClusterInfo + remoteClusterInfoMode <$> decoded `shouldBe` Just (Just RemoteClusterModeProxy) + + it "round-trips a fully-populated RemoteClusterInfo" $ do + let rci = + RemoteClusterInfo + { remoteClusterInfoSeeds = ["host:9300"], + remoteClusterInfoConnected = True, + remoteClusterInfoNumNodesConnected = 2, + remoteClusterInfoMaxConnectionsPerCluster = 3, + remoteClusterInfoMode = Just RemoteClusterModeSniff, + remoteClusterInfoSkipUnavailable = Just False, + remoteClusterInfoOther = Aeson.object [] + } + encoded = Aeson.encode rci + decoded = Aeson.decode' encoded :: Maybe RemoteClusterInfo + -- Equality ignores *Other, so we round-trip via the typed + -- fields. The catch-all preserves whatever wire keys survived + -- the typed extraction. + decoded `shouldSatisfy` isJust + let Just rci' = decoded + remoteClusterInfoSeeds rci' `shouldBe` remoteClusterInfoSeeds rci + remoteClusterInfoConnected rci' `shouldBe` remoteClusterInfoConnected rci + remoteClusterInfoNumNodesConnected rci' `shouldBe` remoteClusterInfoNumNodesConnected rci + remoteClusterInfoMaxConnectionsPerCluster rci' + `shouldBe` remoteClusterInfoMaxConnectionsPerCluster rci + remoteClusterInfoMode rci' `shouldBe` remoteClusterInfoMode rci + remoteClusterInfoSkipUnavailable rci' `shouldBe` remoteClusterInfoSkipUnavailable rci + + it "preserves unknown keys in the *Other field" $ do + let bytes = + Aeson.object + [ "connected" .= True, + "future_field" .= ("unknown value" :: Text), + "another_unknown" .= (42 :: Int) + ] + decoded = Aeson.decode' (Aeson.encode bytes) :: Maybe RemoteClusterInfo + decoded `shouldSatisfy` isJust + let Just rci = decoded + case remoteClusterInfoOther rci of + Aeson.Object o -> do + -- Unknown keys survive. + AKM.lookup "future_field" o `shouldBe` Just (Aeson.String "unknown value") + AKM.lookup "another_unknown" o `shouldBe` Just (Aeson.Number 42) + -- Typed keys also remain in the *Other capture (per the + -- pendingTask precedent: 'pure (Object o)' on the original + -- object). Pinned here so a future refactor that switches + -- to a delete-filtered *Other is caught. + AKM.lookup "connected" o `shouldBe` Just (Aeson.Bool True) + _ -> expectationFailure "Expected *Other to be an Object" + + it "RemoteClusterMode rejects unknown values" $ do + Aeson.decode' "\"rrf\"" `shouldBe` (Nothing :: Maybe RemoteClusterMode) + + it "RemoteClusterMode round-trips sniff and proxy" $ do + Aeson.decode' (Aeson.encode RemoteClusterModeSniff) `shouldBe` Just RemoteClusterModeSniff + Aeson.decode' (Aeson.encode RemoteClusterModeProxy) `shouldBe` Just RemoteClusterModeProxy + + -- ---------------------------------------------------------------- -- + -- RemoteClustersInfo JSON: pure, no ES required. -- + -- The wire shape is an object keyed by remote-cluster alias; the -- + -- empty case (@{}@) decodes to mempty. -- + -- ---------------------------------------------------------------- -- + describe "RemoteClustersInfo JSON" $ do + it "decodes the empty response (no remotes configured)" $ do + let decoded = Aeson.decode' "{}" :: Maybe RemoteClustersInfo + decoded `shouldBe` Just (RemoteClustersInfo HM.empty) + + it "decodes a multi-alias response" $ do + let bytes = + Aeson.object + [ "cluster_a" + .= Aeson.object + [ "connected" .= True, + "num_nodes_connected" .= (1 :: Int), + "mode" .= ("sniff" :: Text) + ], + "cluster_b" + .= Aeson.object + [ "connected" .= False, + "num_nodes_connected" .= (0 :: Int) + ] + ] + decoded = Aeson.decode' (Aeson.encode bytes) :: Maybe RemoteClustersInfo + decoded `shouldSatisfy` isJust + let Just (RemoteClustersInfo m) = decoded + HM.size m `shouldBe` 2 + HM.lookup "cluster_a" m `shouldSatisfy` (\(Just rci) -> remoteClusterInfoConnected rci) + HM.lookup "cluster_b" m `shouldSatisfy` (\(Just rci) -> not (remoteClusterInfoConnected rci)) + + it "round-trips an empty RemoteClustersInfo back to {}" $ do + let encoded = Aeson.encode (RemoteClustersInfo HM.empty) + Aeson.decode' encoded `shouldBe` Just (Aeson.object []) + + it "round-trips a populated RemoteClustersInfo (alias-keyed)" $ do + let rci = + RemoteClusterInfo + { remoteClusterInfoSeeds = ["host:9300"], + remoteClusterInfoConnected = True, + remoteClusterInfoNumNodesConnected = 1, + remoteClusterInfoMaxConnectionsPerCluster = 3, + remoteClusterInfoMode = Just RemoteClusterModeSniff, + remoteClusterInfoSkipUnavailable = Just False, + remoteClusterInfoOther = Aeson.object [] + } + input = RemoteClustersInfo (HM.singleton "rc_a" rci) + encoded = Aeson.encode input + decoded = Aeson.decode' encoded :: Maybe RemoteClustersInfo + decoded `shouldSatisfy` isJust + let Just (RemoteClustersInfo m) = decoded + HM.size m `shouldBe` 1 + -- The alias survives the KeyMap <-> HashMap round-trip + -- (exercises KM.toHashMapText / fromHashMapText symmetry). + HM.lookup "rc_a" m `shouldSatisfy` isJust + let Just rci' = HM.lookup "rc_a" m + remoteClusterInfoConnected rci' `shouldBe` True + remoteClusterInfoNumNodesConnected rci' `shouldBe` 1 + + -- ---------------------------------------------------------------- -- + -- getRemoteClusterInfo endpoint shape: pure checks against the -- + -- BHRequest value; no live backend needed. Mirrors the -- + -- updateClusterSettings shape tests in Test.ClusterSettingsSpec. -- + -- ---------------------------------------------------------------- -- + describe "getRemoteClusterInfo endpoint shape" $ do + it "GETs /_remote/info with no queries and no body" $ do + let req = Common.getRemoteClusterInfo + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_remote", "info"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + -- ---------------------------------------------------------------- -- + -- Live integration: gated via 'backendSpecific' so it runs only -- + -- against the Elasticsearch backends that expose @/_remote/info@ -- + -- (OpenSearch has no such endpoint — it 404s). Auto-skips (pending) -- + -- when no server is reachable, keeping the local @cabal test@ gate -- + -- green. On a fresh cluster with no remote clusters configured the -- + -- server returns @{}@, which decodes to 'RemoteClustersInfo' -- + -- 'HM.empty'. The path @/_remote/info@ is the documented URL on -- + -- every supported ES version (7.x / 8.x / 9.x). -- + -- ---------------------------------------------------------------- -- + describe "getRemoteClusterInfo live" $ + backendSpecific [ElasticSearch7, ElasticSearch8, ElasticSearch9] $ + it "returns an empty map on a fresh cluster" $ + withTestEnv $ do + info <- performBHRequest Common.getRemoteClusterInfo + liftIO $ info `shouldBe` RemoteClustersInfo HM.empty diff --git a/tests/Test/ClusterSettingsSpec.hs b/tests/Test/ClusterSettingsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ClusterSettingsSpec.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.ClusterSettingsSpec where + +import Control.Monad.Catch (bracket_) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as AKM +import Data.HashMap.Strict qualified as HM +import Data.List qualified as L +import Data.Text qualified as T +import Database.Bloodhound.Common.Client qualified as Client +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + describe "cluster settings API" $ do + it "getClusterSettings decodes persistent and transient maps" $ + withTestEnv $ do + settings <- Client.getClusterSettings + -- Persistent and transient are always present in the response + -- (they may be empty on a fresh cluster, but the keys exist). + -- Defaults absent because include_defaults was not sent. + liftIO $ clusterSettingsDefaults settings `shouldBe` Nothing + + it "getClusterSettingsWith defaultClusterSettingsOptions matches the bare call" $ + withTestEnv $ do + bare <- Client.getClusterSettings + withOpts <- Client.getClusterSettingsWith defaultClusterSettingsOptions + liftIO $ clusterSettingsPersistent bare `shouldBe` clusterSettingsPersistent withOpts + liftIO $ clusterSettingsTransient bare `shouldBe` clusterSettingsTransient withOpts + -- Defaults are not requested in either call. + liftIO $ clusterSettingsDefaults bare `shouldBe` Nothing + liftIO $ clusterSettingsDefaults withOpts `shouldBe` Nothing + + it "getClusterSettingsWith include_defaults=True populates the defaults layer" $ + withTestEnv $ do + let opts = defaultClusterSettingsOptions {csoIncludeDefaults = Just True} + settings <- Client.getClusterSettingsWith opts + -- ES always ships a large built-in defaults map. + liftIO $ clusterSettingsDefaults settings `shouldSatisfy` isJust + liftIO $ + clusterSettingsDefaults settings + `shouldSatisfy` maybe False (not . null) + + it "getClusterSettingsWith flat_settings=True still decodes" $ + withTestEnv $ do + let opts = defaultClusterSettingsOptions {csoFlatSettings = Just True} + settings <- Client.getClusterSettingsWith opts + -- With flat_settings the keys are dotted strings, but the + -- outer shape (persistent + transient) is unchanged. + liftIO $ clusterSettingsDefaults settings `shouldBe` Nothing + + it "getClusterSettingsWith include_defaults+flat_settings=True populates flat defaults" $ + withTestEnv $ do + let opts = + defaultClusterSettingsOptions + { csoIncludeDefaults = Just True, + csoFlatSettings = Just True + } + settings <- Client.getClusterSettingsWith opts + liftIO $ + clusterSettingsDefaults settings + `shouldSatisfy` maybe False (not . null) + + -- ------------------------------------------------------------------ -- + -- clusterSettingsOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "clusterSettingsOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultClusterSettingsOptions emits no params" $ + clusterSettingsOptionsParams defaultClusterSettingsOptions + `shouldBe` [] + + it "renders flat_settings as lowercase true/false" $ do + let opts = defaultClusterSettingsOptions {csoFlatSettings = Just True} + clusterSettingsOptionsParams opts `shouldBe` [("flat_settings", Just "true")] + let opts' = defaultClusterSettingsOptions {csoFlatSettings = Just False} + clusterSettingsOptionsParams opts' `shouldBe` [("flat_settings", Just "false")] + + it "renders include_defaults as lowercase true/false" $ do + let opts = defaultClusterSettingsOptions {csoIncludeDefaults = Just True} + clusterSettingsOptionsParams opts `shouldBe` [("include_defaults", Just "true")] + + it "renders master_timeout as " $ do + let opts = defaultClusterSettingsOptions {csoMasterTimeout = Just (TimeUnitSeconds, 30)} + clusterSettingsOptionsParams opts `shouldBe` [("master_timeout", Just "30s")] + + it "emits every param together when all are set" $ do + let opts = + defaultClusterSettingsOptions + { csoFlatSettings = Just True, + csoMasterTimeout = Just (TimeUnitMilliseconds, 500), + csoIncludeDefaults = Just False + } + normalize (clusterSettingsOptionsParams opts) + `shouldBe` [ ("flat_settings", Just "true"), + ("include_defaults", Just "false"), + ("master_timeout", Just "500ms") + ] + + -- ------------------------------------------------------------------ -- + -- ClusterSettings JSON roundtrip: pure, no ES required. -- + -- Locks in the conditional emission of the "defaults" key (only when -- + -- Just) and the unconditional emission of persistent/transient. -- + -- ------------------------------------------------------------------ -- + describe "ClusterSettings JSON roundtrip" $ do + let singleton k v = HM.singleton k (Aeson.String v) + decodeAsObject :: Aeson.Value -> Maybe Aeson.Object + decodeAsObject (Aeson.Object o) = Just o + decodeAsObject _ = Nothing + + it "roundtrips when defaults is Nothing (no defaults key emitted)" $ do + let cs = + ClusterSettings + { clusterSettingsPersistent = singleton "cluster.routing.allocation.enable" "all", + clusterSettingsTransient = HM.empty, + clusterSettingsDefaults = Nothing + } + encoded = Aeson.encode cs + decoded = Aeson.decode' encoded :: Maybe ClusterSettings + decoded `shouldBe` Just cs + -- Confirm the defaults key is genuinely absent from the wire form. + let wireObject = Aeson.decode' encoded >>= decodeAsObject + wireObject `shouldSatisfy` maybe False (not . AKM.member "defaults") + + it "roundtrips when defaults is Just (defaults key present, even if empty)" $ do + let cs = + ClusterSettings + { clusterSettingsPersistent = HM.empty, + clusterSettingsTransient = HM.empty, + clusterSettingsDefaults = Just HM.empty + } + encoded = Aeson.encode cs + decoded = Aeson.decode' encoded :: Maybe ClusterSettings + decoded `shouldBe` Just cs + let wireObject = Aeson.decode' encoded >>= decodeAsObject + wireObject `shouldSatisfy` maybe False (AKM.member "defaults") + + it "decodes the minimal ES response shape" $ do + let bytes = "{\"persistent\":{},\"transient\":{}}" + decoded = Aeson.decode' bytes :: Maybe ClusterSettings + decoded + `shouldBe` Just + ( ClusterSettings + { clusterSettingsPersistent = HM.empty, + clusterSettingsTransient = HM.empty, + clusterSettingsDefaults = Nothing + } + ) + + -- ------------------------------------------------------------------ -- + -- ClusterSettingsUpdate ToJSON: pure, no ES required. -- + -- Locks in the conditional emission of persistent/transient (only -- + -- when Just) so a Nothing layer is omitted entirely, and that Null -- + -- values survive encoding (clear semantics). -- + -- ------------------------------------------------------------------ -- + describe "ClusterSettingsUpdate ToJSON" $ do + it "defaultClusterSettingsUpdate encodes to the empty object" $ + encode defaultClusterSettingsUpdate `shouldBe` "{}" + + it "emits both layers when both are Just" $ do + let update = + ClusterSettingsUpdate + { clusterSettingsUpdatePersistent = Just (HM.singleton "a" (String "p")), + clusterSettingsUpdateTransient = Just (HM.singleton "b" (String "t")) + } + encode update + `shouldBe` "{\"persistent\":{\"a\":\"p\"},\"transient\":{\"b\":\"t\"}}" + + it "emits an empty object for a Just mempty layer (distinct from Nothing)" $ do + -- ES treats "persistent":{} and an absent persistent key + -- differently w.r.t. clearing, so the distinction must survive + -- encoding. + let update = + defaultClusterSettingsUpdate + { clusterSettingsUpdatePersistent = Just mempty + } + encode update `shouldBe` "{\"persistent\":{}}" + + it "omits Nothing layers and emits Just layers" $ do + let update = + ClusterSettingsUpdate + { clusterSettingsUpdatePersistent = + Just (HM.singleton "cluster.routing.allocation.enable" (String "all")), + clusterSettingsUpdateTransient = Nothing + } + encode update + `shouldBe` "{\"persistent\":{\"cluster.routing.allocation.enable\":\"all\"}}" + + it "emits only the transient layer when persistent is Nothing" $ do + let update = + defaultClusterSettingsUpdate + { clusterSettingsUpdateTransient = + Just (HM.singleton "cluster.routing.allocation.enable" (String "none")) + } + encode update + `shouldBe` "{\"transient\":{\"cluster.routing.allocation.enable\":\"none\"}}" + + it "round-trips Null values (clear semantics preserved)" $ do + let update = + defaultClusterSettingsUpdate + { clusterSettingsUpdateTransient = + Just + ( HM.singleton + "cluster.routing.allocation.disk.threshold.enabled" + Null + ) + } + encode update + `shouldBe` "{\"transient\":{\"cluster.routing.allocation.disk.threshold.enabled\":null}}" + + -- ------------------------------------------------------------------ -- + -- clusterSettingsUpdateOptionsParams: pure URI rendering (no ES). -- + -- Mirrors the GET counterpart but covers only the parameters PUT -- + -- accepts (no include_defaults). -- + -- ------------------------------------------------------------------ -- + describe "clusterSettingsUpdateOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultClusterSettingsUpdateOptions emits no params" $ + clusterSettingsUpdateOptionsParams defaultClusterSettingsUpdateOptions + `shouldBe` [] + + it "renders flat_settings as lowercase true/false" $ do + let opts = defaultClusterSettingsUpdateOptions {csuoFlatSettings = Just True} + clusterSettingsUpdateOptionsParams opts `shouldBe` [("flat_settings", Just "true")] + let opts' = defaultClusterSettingsUpdateOptions {csuoFlatSettings = Just False} + clusterSettingsUpdateOptionsParams opts' `shouldBe` [("flat_settings", Just "false")] + + it "renders master_timeout as " $ do + let opts = defaultClusterSettingsUpdateOptions {csuoMasterTimeout = Just (TimeUnitSeconds, 30)} + clusterSettingsUpdateOptionsParams opts `shouldBe` [("master_timeout", Just "30s")] + + it "emits every param together when all are set" $ do + let opts = + defaultClusterSettingsUpdateOptions + { csuoFlatSettings = Just True, + csuoMasterTimeout = Just (TimeUnitMilliseconds, 500) + } + normalize (clusterSettingsUpdateOptionsParams opts) + `shouldBe` [ ("flat_settings", Just "true"), + ("master_timeout", Just "500ms") + ] + + -- ------------------------------------------------------------------ -- + -- updateClusterSettings endpoint shape: pure checks against the -- + -- BHRequest value; no live backend needed. Mirrors the putILMPolicy -- + -- shape tests in Test.ILMSpec. -- + -- ------------------------------------------------------------------ -- + describe "updateClusterSettings endpoint shape" $ do + it "PUTs /_cluster/settings with no queries by default" $ do + let req = Common.updateClusterSettings defaultClusterSettingsUpdate + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_cluster", "settings"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches the encoded update as the request body" $ do + let update = + defaultClusterSettingsUpdate + { clusterSettingsUpdatePersistent = + Just (HM.singleton "cluster.routing.allocation.enable" (String "all")) + } + req = Common.updateClusterSettings update + bhRequestBody req `shouldBe` Just (encode update) + + it "forwards flat_settings and master_timeout via updateClusterSettingsWith" $ do + let opts = + defaultClusterSettingsUpdateOptions + { csuoFlatSettings = Just True, + csuoMasterTimeout = Just (TimeUnitSeconds, 30) + } + req = Common.updateClusterSettingsWith opts defaultClusterSettingsUpdate + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_cluster", "settings"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("flat_settings", Just "true"), ("master_timeout", Just "30s")] + + -- ------------------------------------------------------------------ -- + -- updateClusterSettings live round-trip: set a harmless transient -- + -- setting, verify it landed, then clear it (PUT null). The bracket_ -- + -- guarantees the clear runs even if an assertion fails mid-way, so -- + -- cluster state is never left dirty. -- + -- ------------------------------------------------------------------ -- + describe "updateClusterSettings live round-trip" $ do + -- Only the transient layer is exercised live: it is cleared on a + -- full cluster restart, so a stuck/crashed test can never leave + -- persistent state behind. The persistent layer is covered by the + -- pure ToJSON tests above (it shares the encoder branch). + -- + -- cluster.routing.allocation.enable is a core setting recognised on + -- every ES/OpenSearch cluster. Setting it transiently to its default + -- value "all" is a true no-op behaviourally, yet ES still records + -- the explicit assignment in the transient layer — which is exactly + -- what lets the test observe the write without perturbing the + -- cluster. The PUT null in the cleanup erases the transient entry. + let key = "cluster.routing.allocation.enable" + setUpdate = + defaultClusterSettingsUpdate + { clusterSettingsUpdateTransient = Just (HM.singleton key (String "all")) + } + clearUpdate = + defaultClusterSettingsUpdate + { clusterSettingsUpdateTransient = Just (HM.singleton key Null) + } + + it "sets a transient setting, reads it back, then clears it" + $ withTestEnv + $ bracket_ + (void $ Client.updateClusterSettings setUpdate) + (void $ Client.updateClusterSettings clearUpdate) + $ do + -- flat_settings=true so the transient map uses dotted keys + -- (cluster.routing.allocation.enable) rather than a nested + -- object tree — matching the flat lookup below. + let flat = defaultClusterSettingsOptions {csoFlatSettings = Just True} + beforeClear <- Client.getClusterSettingsWith flat + liftIO $ + HM.lookup key (clusterSettingsTransient beforeClear) + `shouldBe` Just (String "all") + -- Explicitly clear mid-test so we can also assert the + -- post-clear state. The bracket_ cleanup is idempotent. + void $ Client.updateClusterSettings clearUpdate + afterClear <- Client.getClusterSettingsWith flat + liftIO $ + HM.member key (clusterSettingsTransient afterClear) + `shouldBe` False diff --git a/tests/Test/ClusterStateSpec.hs b/tests/Test/ClusterStateSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ClusterStateSpec.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.ClusterStateSpec where + +import Data.List qualified as L +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Database.Bloodhound.Common.Client qualified as Client +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + describe "cluster state API" $ do + it "returns cluster state information" $ + withTestEnv $ do + state <- Client.getClusterState + liftIO $ clusterStateClusterName state `shouldSatisfy` (not . T.null) + liftIO $ clusterStateClusterUuid state `shouldSatisfy` (not . T.null) + liftIO $ clusterStateVersion state `shouldSatisfy` (> 0) + + it "returns nodes information" $ + withTestEnv $ do + state <- Client.getClusterState + liftIO $ clusterStateNodes state `shouldSatisfy` (not . null) + + -- ------------------------------------------------------------------ -- + -- renderClusterStateMetric: pure wire-name rendering (no ES required). -- + -- Locks in the exact text ES/OS expect for each metric so a typo or -- + -- rename surfaces here rather than as a silent 400 from the server. -- + -- ------------------------------------------------------------------ -- + describe "renderClusterStateMetric" $ do + it "renders every constructor at its canonical wire name" $ + L.sort (map renderClusterStateMetric [minBound .. maxBound]) + `shouldBe` L.sort + [ "blocks", + "custom_metadata", + "master_node", + "metadata", + "nodes", + "routing_nodes", + "routing_table", + "settings", + "version" + ] + + it "renderClusterStateMetric is injective across constructors" $ + -- Catches a copy/paste typo where two constructors render to the + -- same wire name (would silently collapse the metric filter). + noDuplicates (map renderClusterStateMetric [minBound .. maxBound]) + + -- ------------------------------------------------------------------ -- + -- clusterStateOptionsPathSegments + clusterStateOptionsParams: -- + -- pure URI rendering, no live backend needed. Mirrors the -- + -- ClusterSettingsSpec "URI rendering" block. -- + -- ------------------------------------------------------------------ -- + describe "ClusterStateOptions URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultClusterStateOptions emits no path segments and no params" $ do + clusterStateOptionsPathSegments defaultClusterStateOptions `shouldBe` [] + clusterStateOptionsParams defaultClusterStateOptions `shouldBe` [] + + it "renders a single metric as a path segment" $ do + let opts = defaultClusterStateOptions {cstoMetrics = Just (NE.fromList [ClusterStateMetricMetadata])} + clusterStateOptionsPathSegments opts `shouldBe` ["metadata"] + + it "renders multiple metrics as a comma-joined path segment" $ do + let opts = + defaultClusterStateOptions + { cstoMetrics = + Just $ + NE.fromList [ClusterStateMetricMetadata, ClusterStateMetricNodes] + } + clusterStateOptionsPathSegments opts `shouldBe` ["metadata,nodes"] + + it "renders multi-metric then multi-index as two CSV path segments, in order" $ do + -- Locks in the path-segment ordering when both filters carry + -- multiple values: the comma-joined metric segment precedes + -- the comma-joined index segment. A regression that swaps the + -- order, or flattens both into one CSV, surfaces here. + let opts = + defaultClusterStateOptions + { cstoMetrics = + Just $ + NE.fromList [ClusterStateMetricMetadata, ClusterStateMetricVersion], + cstoIndices = Just (NE.fromList [testIndex, otherIndex]) + } + clusterStateOptionsPathSegments opts + `shouldBe` [ "metadata,version", + unIndexName testIndex <> "," <> unIndexName otherIndex + ] + + it "renders the index filter only when a metric filter is also set" $ do + -- Without a metric segment, GET /_cluster/state//foo is a 400. + -- The renderer must drop a lone index filter rather than emit + -- an empty path segment. + let withMetrics = + defaultClusterStateOptions + { cstoMetrics = Just (NE.fromList [ClusterStateMetricMetadata]), + cstoIndices = Just (NE.fromList [testIndex]) + } + withoutMetrics = + defaultClusterStateOptions + { cstoIndices = Just (NE.fromList [testIndex]) + } + clusterStateOptionsPathSegments withMetrics + `shouldBe` ["metadata", unIndexName testIndex] + clusterStateOptionsPathSegments withoutMetrics `shouldBe` [] + + it "renders multiple indices as a comma-joined path segment" $ do + let opts = + defaultClusterStateOptions + { cstoMetrics = Just (NE.fromList [ClusterStateMetricRoutingTable]), + cstoIndices = Just (NE.fromList [testIndex, otherIndex]) + } + clusterStateOptionsPathSegments opts + `shouldBe` ["routing_table", unIndexName testIndex <> "," <> unIndexName otherIndex] + + it "renders local as lowercase true/false" $ do + let trueOpts = defaultClusterStateOptions {cstoLocal = Just True} + falseOpts = defaultClusterStateOptions {cstoLocal = Just False} + clusterStateOptionsParams trueOpts `shouldBe` [("local", Just "true")] + clusterStateOptionsParams falseOpts `shouldBe` [("local", Just "false")] + + it "renders master_timeout as " $ do + let opts = defaultClusterStateOptions {cstoMasterTimeout = Just (TimeUnitSeconds, 30)} + clusterStateOptionsParams opts `shouldBe` [("master_timeout", Just "30s")] + + it "renders wait_for_metadata_version as a decimal" $ do + let opts = defaultClusterStateOptions {cstoWaitForMetadataVersion = Just 42} + clusterStateOptionsParams opts + `shouldBe` [("wait_for_metadata_version", Just "42")] + + it "renders filter_path as a comma-joined list" $ do + let opts = + defaultClusterStateOptions + { cstoFilterPath = Just (NE.fromList ["cluster_name", "metadata.indices.*"]) + } + clusterStateOptionsParams opts + `shouldBe` [("filter_path", Just "cluster_name,metadata.indices.*")] + + it "emits path segments and query params together when all are set" $ do + let opts = + defaultClusterStateOptions + { cstoMetrics = Just (NE.fromList [ClusterStateMetricMetadata]), + cstoIndices = Just (NE.fromList [testIndex]), + cstoLocal = Just True, + cstoMasterTimeout = Just (TimeUnitMilliseconds, 500), + cstoWaitForMetadataVersion = Just 7, + cstoFilterPath = Just (NE.fromList ["metadata.indices.*"]) + } + clusterStateOptionsPathSegments opts + `shouldBe` ["metadata", unIndexName testIndex] + normalize (clusterStateOptionsParams opts) + `shouldBe` [ ("filter_path", Just "metadata.indices.*"), + ("local", Just "true"), + ("master_timeout", Just "500ms"), + ("wait_for_metadata_version", Just "7") + ] + + -- ------------------------------------------------------------------ -- + -- getClusterStateWith endpoint shape: pure checks against the -- + -- BHRequest value, no live backend needed. Mirrors the -- + -- updateClusterSettings shape tests in Test.ClusterSettingsSpec. -- + -- ------------------------------------------------------------------ -- + describe "getClusterStateWith endpoint shape" $ do + it "GETs /_cluster/state with no extra path or query by default" $ do + let req = Common.getClusterStateWith defaultClusterStateOptions + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_cluster", "state"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "forwards metric and index filters as additional path segments" $ do + let opts = + defaultClusterStateOptions + { cstoMetrics = Just (NE.fromList [ClusterStateMetricNodes]), + cstoIndices = Just (NE.fromList [testIndex]) + } + req = Common.getClusterStateWith opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_cluster", "state", "nodes", unIndexName testIndex] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "forwards local, master_timeout and filter_path via the query string" $ do + let opts = + defaultClusterStateOptions + { cstoLocal = Just True, + cstoMasterTimeout = Just (TimeUnitSeconds, 30), + cstoFilterPath = Just (NE.fromList ["master_node"]) + } + req = Common.getClusterStateWith opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_cluster", "state"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [ ("local", Just "true"), + ("master_timeout", Just "30s"), + ("filter_path", Just "master_node") + ] + +-- | Local-only fixture index name so the spec doesn't depend on the +-- cluster's test-index bootstrap beyond 'testIndex'. Pure tests only +-- ever render this to text, never send it. +otherIndex :: IndexName +otherIndex = [qqIndexName|bloodhound-tests-twitter-2|] diff --git a/tests/Test/ClusterStatsSpec.hs b/tests/Test/ClusterStatsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ClusterStatsSpec.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.ClusterStatsSpec where + +import Data.Aeson.KeyMap qualified as KM +import Data.Text qualified as T +import Database.Bloodhound.Common.Client qualified as Client +import Database.Bloodhound.Common.Types +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + describe "cluster stats API" $ do + it "getClusterStats returns typed top-level fields" $ + withTestEnv $ do + stats <- Client.getClusterStats + liftIO $ clusterStatsClusterName stats `shouldSatisfy` (not . T.null) + liftIO $ clusterStatsClusterUuid stats `shouldSatisfy` (not . T.null) + liftIO $ clusterStatsStatus stats `shouldSatisfy` (`elem` [ClusterHealthGreen, ClusterHealthYellow, ClusterHealthRed]) + liftIO $ clusterStatsTimestamp stats `shouldSatisfy` (> 0) + + it "exposes _nodes summary with total >= successful" $ + withTestEnv $ do + stats <- Client.getClusterStats + let summary = clusterStatsNodesSummary stats + liftIO $ clusterStatsNodeSummaryTotal summary `shouldSatisfy` (>= 1) + liftIO $ clusterStatsNodeSummarySuccessful summary `shouldSatisfy` (>= 1) + liftIO $ clusterStatsNodeSummaryFailed summary `shouldSatisfy` (>= 0) + + it "exposes indices count >= 0 and a versions list" $ + withTestEnv $ do + stats <- Client.getClusterStats + let indices = clusterStatsIndices stats + liftIO $ clusterStatsIndicesCount indices `shouldSatisfy` (>= 0) + let versionStrings = clusterStatsIndexVersionVersion <$> clusterStatsIndicesVersions indices + liftIO $ versionStrings `shouldSatisfy` all (not . T.null) + + it "exposes indices.shards summary with non-negative totals" $ + withTestEnv $ do + stats <- Client.getClusterStats + let shards = clusterStatsIndicesShards (clusterStatsIndices stats) + liftIO $ clusterStatsShardsTotal shards `shouldSatisfy` (>= 0) + liftIO $ clusterStatsShardsPrimaries shards `shouldSatisfy` (>= 0) + + it "preserves untyped indices sections as a JSON object" $ + withTestEnv $ do + stats <- Client.getClusterStats + case clusterStatsIndicesOther (clusterStatsIndices stats) of + Object _ -> pure () + other -> liftIO $ expectationFailure $ "expected indices object, got " <> show other + + it "exposes nodes count total >= 1 and at least one version" $ + withTestEnv $ do + stats <- Client.getClusterStats + let nodes = clusterStatsNodes stats + count = clusterStatsNodesCount nodes + liftIO $ clusterStatsNodeCountTotal count `shouldSatisfy` (>= 1) + liftIO $ clusterStatsNodesVersions nodes `shouldSatisfy` (not . null) + + it "preserves untyped nodes sections as a JSON object" $ + withTestEnv $ do + stats <- Client.getClusterStats + case clusterStatsNodesOther (clusterStatsNodes stats) of + Object _ -> pure () + other -> liftIO $ expectationFailure $ "expected nodes object, got " <> show other + + -- ------------------------------------------------------------------ -- + -- Pure FromJSON/ToJSON round-trip (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "ClusterStats JSON codec" $ do + let samplePayload :: Value + samplePayload = + object + [ "timestamp" .= (1718000000000 :: Int), + "cluster_name" .= ("bloodhound-test" :: Text), + "cluster_uuid" .= ("abc-123" :: Text), + "status" .= ("green" :: Text), + "_nodes" + .= object + [ "total" .= (1 :: Int), + "successful" .= (1 :: Int), + "failed" .= (0 :: Int) + ], + "indices" + .= object + [ "count" .= (3 :: Int), + "shards" + .= object + [ "total" .= (6 :: Int), + "primaries" .= (3 :: Int), + "replication" .= (1.0 :: Double) + ], + "docs" .= object ["count" .= (42 :: Int), "deleted" .= (1 :: Int)], + "store" .= object ["size_in_bytes" .= (2048 :: Int)], + "versions" .= ["8.17.0" :: Text], + "segments" .= object ["count" .= (12 :: Int)] + ], + "nodes" + .= object + [ "count" + .= object + [ "total" .= (1 :: Int), + "data" .= (1 :: Int), + "master" .= (1 :: Int) + ], + "versions" .= ["8.17.0" :: Text], + "jvm" .= object ["max_uptime_in_millis" .= (60000 :: Int)] + ] + ] + + it "round-trips a representative ES payload without dropping untyped fields" $ + case fromJSON @ClusterStats samplePayload of + Success decoded -> + case toJSON decoded of + Object reencoded -> + case fromJSON @ClusterStats (Object reencoded) of + Success again -> do + clusterStatsIndicesCount (clusterStatsIndices again) `shouldBe` 3 + -- The verbatim 'segments' sub-object (not modelled as a + -- typed field) must survive the round-trip via + -- 'clusterStatsIndicesOther'. + case otherObject (clusterStatsIndices again) of + Just o + | KM.member "segments" o -> pure () + _ -> expectationFailure "segments dropped from indices round-trip" + Error err -> expectationFailure ("re-decode failed: " <> err) + other -> expectationFailure ("re-encode produced non-object: " <> show other) + Error err -> expectationFailure ("initial decode failed: " <> err) + + it "decodes the modern object-form of indices.versions" $ do + let payload = + object + [ "version" .= ("8.17.0" :: Text), + "index_count" .= (12 :: Int), + "primary_shard_count" .= (24 :: Int), + "total_primary_bytes" .= (4096 :: Int) + ] + case fromJSON @ClusterStatsIndexVersion payload of + Success v -> do + clusterStatsIndexVersionVersion v `shouldBe` "8.17.0" + clusterStatsIndexVersionIndexCount v `shouldBe` Just 12 + clusterStatsIndexVersionPrimaryShardCount v `shouldBe` Just 24 + clusterStatsIndexVersionTotalPrimaryBytes v `shouldBe` Just 4096 + Error err -> expectationFailure ("decode failed: " <> err) + + it "decodes the legacy bare-string form of indices.versions" $ do + case fromJSON @ClusterStatsIndexVersion (String "7.10.0") of + Success v -> do + clusterStatsIndexVersionVersion v `shouldBe` "7.10.0" + clusterStatsIndexVersionIndexCount v `shouldBe` Nothing + clusterStatsIndexVersionPrimaryShardCount v `shouldBe` Nothing + clusterStatsIndexVersionTotalPrimaryBytes v `shouldBe` Nothing + Error err -> expectationFailure ("decode failed: " <> err) + + it "captures nodes.count by-role entries beyond `total`" $ do + let payload = + object + [ "total" .= (1 :: Int), + "data" .= (1 :: Int), + "master" .= (1 :: Int), + "ingest" .= (0 :: Int) + ] + case fromJSON @ClusterStatsNodeCount payload of + Success count -> do + clusterStatsNodeCountTotal count `shouldBe` 1 + lookup "data" (clusterStatsNodeCountByRole count) `shouldBe` Just 1 + lookup "master" (clusterStatsNodeCountByRole count) `shouldBe` Just 1 + lookup "ingest" (clusterStatsNodeCountByRole count) `shouldBe` Just 0 + Error err -> expectationFailure ("decode failed: " <> err) + + it "decodes a minimal payload (missing optional fields)" $ do + let payload = + object + [ "cluster_name" .= ("x" :: Text), + "cluster_uuid" .= ("y" :: Text), + "status" .= ("yellow" :: Text) + ] + case fromJSON @ClusterStats payload of + Success stats -> clusterStatsStatus stats `shouldBe` ClusterHealthYellow + Error err -> expectationFailure ("decode failed: " <> err) + +-- | Project the @*Other@ 'Value' as a 'KM.KeyMap' when it carries an +-- 'Object'; used by the round-trip test to verify that untyped sections +-- are preserved through 'toJSON'. +otherObject :: ClusterStatsIndices -> Maybe (KM.KeyMap Value) +otherObject ci = + case clusterStatsIndicesOther ci of + Object o -> Just o + _ -> Nothing diff --git a/tests/Test/ConnectorsSpec.hs b/tests/Test/ConnectorsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ConnectorsSpec.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Test.ConnectorsSpec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List (sort) +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch8.Requests qualified as RequestsES8 +import Database.Bloodhound.ElasticSearch8.Types qualified as Types +import TestsUtils.Common +import TestsUtils.Import + +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + +spec :: Spec +spec = + describe "Connectors API (/_connector*)" $ do + describe "ConnectorId / ConnectorSyncJobId JSON" $ do + it "round-trips a ConnectorId as a bare string" $ + decode (encode (Types.ConnectorId "my-conn" :: Types.ConnectorId)) + `shouldBe` Just (Types.ConnectorId "my-conn") + it "round-trips a ConnectorSyncJobId" $ + decode (encode (Types.ConnectorSyncJobId "job-1")) + `shouldBe` Just (Types.ConnectorSyncJobId "job-1") + + describe "Connector (GET entity) decoding" $ do + it "decodes the typed scalar fields and parks the rest in extras" $ do + let raw = + LBS.pack + "{\"id\":\"c1\",\"name\":\"wiki\",\"index_name\":\"wiki-index\",\ + \\"is_native\":false,\"service_type\":\"sharepoint\",\"status\":\"configured\",\ + \\"configuration\":{\"foo\":\"bar\"},\"last_seen\":\"2024-01-01\"}" + case decode raw :: Maybe Types.Connector of + Just c -> do + Types.cId c `shouldBe` Just "c1" + Types.cName c `shouldBe` Just "wiki" + Types.cIndexName c `shouldBe` Just "wiki-index" + Types.cIsNative c `shouldBe` Just False + Types.cServiceType c `shouldBe` Just "sharepoint" + Types.cStatus c `shouldBe` Just "configured" + -- extras carries configuration + last_seen + case Types.cExtras c of + Just _ -> pure () + Nothing -> expectationFailure "extras should retain untyped fields" + Nothing -> expectationFailure "failed to decode Connector" + it "round-trips a Connector (typed fields survive, extras merge)" $ do + let c = + Types.Connector + { Types.cId = Just "c1", + Types.cName = Just "wiki", + Types.cDescription = Nothing, + Types.cIndexName = Just "wiki-index", + Types.cIsNative = Just False, + Types.cLanguage = Nothing, + Types.cServiceType = Just "sharepoint", + Types.cStatus = Just "configured", + Types.cError = Nothing, + Types.cApiKeyId = Nothing, + Types.cApiKeySecretId = Nothing, + Types.cSyncNow = Nothing, + Types.cExtras = Nothing + } + decode (encode c) `shouldBe` Just c + + describe "envelope responses" $ do + it "ConnectorMutationResult decodes {result}" $ + decode "{\"result\":\"created\"}" + `shouldBe` Just (Types.ConnectorMutationResult (Just "created")) + it "ConnectorCreateResponse decodes {result, id}" $ + decode "{\"result\":\"created\",\"id\":\"abc\"}" + `shouldBe` Just + ( Types.ConnectorCreateResponse + { Types.ccrResult = Just "created", + Types.ccrId = Just "abc" + } + ) + it "ConnectorSyncJobCreateResponse decodes bare {id} (no result)" $ + decode "{\"id\":\"job-7\"}" + `shouldBe` Just + (Types.ConnectorSyncJobCreateResponse {Types.sjcrId = Just "job-7"}) + it "ConnectorListResponse decodes {count, results}" $ do + let raw = + LBS.pack + "{\"count\":1,\"results\":[{\"id\":\"c1\",\"name\":\"wiki\"}]}" + case decode raw :: Maybe Types.ConnectorListResponse of + Just resp -> do + Types.clrCount resp `shouldBe` Just 1 + length (Types.clrResults resp) `shouldBe` 1 + Nothing -> expectationFailure "failed to decode ConnectorListResponse" + + describe "connectorListOptionsParams URI rendering" $ do + it "default emits no params" $ + Types.connectorListOptionsParams Types.defaultConnectorListOptions + `shouldBe` [] + it "renders from/size and the filters" $ do + let opts = + Types.defaultConnectorListOptions + { Types.cloFrom = Just 0, + Types.cloSize = Just 25, + Types.cloServiceType = Just "sharepoint", + Types.cloQuery = Just "wiki" + } + normalize (Types.connectorListOptionsParams opts) + `shouldBe` sort + [ ("from", Just "0"), + ("size", Just "25"), + ("service_type", Just "sharepoint"), + ("q", Just "wiki") + ] + + describe "CreateConnectorRequest JSON" $ do + it "omits Nothing fields" $ do + let req = + Types.defaultCreateConnectorRequest + { Types.ccrName = Just "wiki", + Types.ccrIndexName = Just "wiki-index", + Types.ccrServiceType = Just "sharepoint" + } + encode req + `shouldBe` "{\"index_name\":\"wiki-index\",\"name\":\"wiki\",\"service_type\":\"sharepoint\"}" + decode (encode req) `shouldBe` Just req + + describe "endpoint shape (core CRUD)" $ do + it "POSTs /_connector with a JSON body" $ do + let req = + RequestsES8.createConnector + Types.defaultCreateConnectorRequest + { Types.ccrName = Just "wiki" + } + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_connector"] + bhRequestBody req `shouldSatisfy` isJust + it "PUTs /_connector/ with a body" $ do + let req = + RequestsES8.putConnector + "c1" + Types.defaultCreateConnectorRequest + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_connector", "c1"] + bhRequestBody req `shouldSatisfy` isJust + it "GETs /_connector/ with no body" $ do + let req = RequestsES8.getConnector "c1" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_connector", "c1"] + bhRequestBody req `shouldSatisfy` isNothing + it "DELETEs /_connector/ (no params by default)" $ do + let req = RequestsES8.deleteConnector "c1" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_connector", "c1"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "deleteConnectorWith appends delete_sync_jobs" $ do + let req = RequestsES8.deleteConnectorWith (Just True) "c1" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_connector", "c1"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("delete_sync_jobs", Just "true")] + it "listConnectorsWith appends query params" $ do + let req = + RequestsES8.listConnectorsWith + Types.defaultConnectorListOptions {Types.cloSize = Just 10} + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_connector"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("size", Just "10")] + + describe "endpoint shape (connector actions)" $ do + it "PUTs /_connector//_check_in with empty body" $ do + let req = RequestsES8.checkInConnector "c1" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_connector", "c1", "_check_in"] + bhRequestBody req `shouldSatisfy` isJust + it "PUTs /_connector//_filtering/_validation" $ do + let req = + RequestsES8.updateConnectorDraftFilteringValidation + "c1" + (Types.UpdateConnectorFilteringValidationRequest Nothing) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_connector", "c1", "_filtering", "_validation"] + it "PUTs /_connector//_filtering/_activate (no body)" $ do + let req = RequestsES8.activateConnectorDraftFiltering "c1" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_connector", "c1", "_filtering", "_activate"] + bhRequestBody req `shouldSatisfy` isJust + + describe "endpoint shape (sync jobs)" $ do + it "POSTs /_connector/_sync_job with a body" $ do + let req = + RequestsES8.createConnectorSyncJob + ( Types.CreateConnectorSyncJobRequest + { Types.csjrId = Just "c1", + Types.csjrJobType = Just "full", + Types.csjrTriggerMethod = Just "on_demand" + } + ) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_connector", "_sync_job"] + bhRequestBody req `shouldSatisfy` isJust + it "GETs /_connector/_sync_job/" $ do + let req = RequestsES8.getConnectorSyncJob "job-1" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_connector", "_sync_job", "job-1"] + bhRequestBody req `shouldSatisfy` isNothing + it "DELETEs /_connector/_sync_job/" $ do + let req = RequestsES8.deleteConnectorSyncJob "job-1" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_connector", "_sync_job", "job-1"] + it "PUTs /_connector/_sync_job//_cancel" $ do + let req = RequestsES8.cancelConnectorSyncJob "job-1" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_connector", "_sync_job", "job-1", "_cancel"] + it "PUTs /_connector/_sync_job//_claim with a body" $ do + let req = + RequestsES8.claimConnectorSyncJob + "job-1" + (Types.ClaimConnectorSyncJobRequest Nothing Nothing) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_connector", "_sync_job", "job-1", "_claim"] + bhRequestBody req `shouldSatisfy` isJust + + describe "live integration (requires ES8+ backend)" $ + backendSpecific [ElasticSearch8] $ do + it "round-trips a connector via POST then GET then DELETE" $ + withTestEnv $ do + let cid = Types.ConnectorId "bloodhound-test-connector" + body = + Types.defaultCreateConnectorRequest + { Types.ccrName = Just "bloodhound-test-connector", + Types.ccrIndexName = Just "bloodhound-test-connector", + Types.ccrServiceType = Just "sharepoint" + } + _ <- tryPerformBHRequest $ RequestsES8.deleteConnector cid + createResp <- tryEsError (ClientES8.createConnector body) + case createResp of + Left e + | errorStatus e == Just 403 -> + liftIO $ + pendingWith + "connectors API requires the edit_connectors \ + \cluster privilege; skip on locked-down clusters" + | "privilege" `T.isInfixOf` T.toLower (errorMessage e) -> + liftIO $ + pendingWith + "connectors API rejected the request for missing \ + \privilege on this cluster" + | errorStatus e == Just 404 -> + liftIO $ + pendingWith + "connectors API returned 404 on POST /_connector; \ + \feature not provisioned on this cluster" + | "not found" `T.isInfixOf` T.toLower (errorMessage e) -> + liftIO $ + pendingWith + "connectors API reported 'not found' on create; \ + \endpoint unavailable on this cluster" + Left e -> + liftIO $ + expectationFailure ("unexpected POST error: " <> show e) + Right resp -> do + -- The ES Connectors API auto-generates the connector _id + -- on POST; the @name@ / @index_name@ we send in the body + -- are *not* the id. Prefer the id the server returned in + -- 'ConnectorCreateResponse' and only fall back to the + -- caller-supplied @cid@ if the server omitted it. + let lookupId = fromMaybe cid (Types.ccrId resp) + fetched <- tryPerformBHRequest $ RequestsES8.getConnector lookupId + case fetched of + Right c -> liftIO $ Types.cName c `shouldBe` Just "bloodhound-test-connector" + Left _ -> liftIO $ pure () + -- Best-effort cleanup: a 404 here (e.g. the connector was + -- already reaped by a prior run, or the server returned no + -- id and the fallback cid does not match) must not fail + -- the test. + _ <- tryEsError (ClientES8.deleteConnector lookupId) + pure () diff --git a/tests/Test/CountSpec.hs b/tests/Test/CountSpec.hs --- a/tests/Test/CountSpec.hs +++ b/tests/Test/CountSpec.hs @@ -1,17 +1,241 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Test.CountSpec (spec) where +import Data.List (sort) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Maybe (isJust) +import Data.Text (Text) +import Database.Bloodhound.Common.Types +import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe, shouldSatisfy) import TestsUtils.Common import TestsUtils.Import +-- | Stable ordering for equality: 'withQueries' preserves the order in +-- which params are emitted, but the tests compare the @Set@ of params +-- to avoid coupling to internal field ordering of 'CountOptions'. +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + spec :: Spec -spec = - describe "Count" $ - it "returns count of a query" $ +spec = do + describe "CountOptions URI param rendering" $ do + it "defaultCountOptions emits no params" $ + countOptionsParams defaultCountOptions `shouldBe` [] + + it "renders every Bool field as true/false strings" $ do + let opts = + defaultCountOptions + { coAllowNoIndices = Just True, + coIgnoreUnavailable = Just False + } + normalize (countOptionsParams opts) + `shouldBe` [ ("allow_no_indices", Just "true"), + ("ignore_unavailable", Just "false") + ] + + it "renders expand_wildcards as a comma-separated list of values" $ do + let opts = + defaultCountOptions + { coExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + countOptionsParams opts + `shouldBe` [("expand_wildcards", Just "open,closed")] + + it "renders a single expand_wildcards value without a trailing comma" $ do + let opts = + defaultCountOptions + { coExpandWildcards = Just (ExpandWildcardsAll :| []) + } + countOptionsParams opts + `shouldBe` [("expand_wildcards", Just "all")] + + it "renders min_score as a decimal number" $ do + let mk v = countOptionsParams defaultCountOptions {coMinScore = Just v} + mk 0 `shouldBe` [("min_score", Just "0.0")] + mk 1.5 `shouldBe` [("min_score", Just "1.5")] + + it "renders preference and routing verbatim" $ do + let opts = + defaultCountOptions + { coPreference = Just "_only_local", + coRouting = Just "route1,route2" + } + normalize (countOptionsParams opts) + `shouldBe` [ ("preference", Just "_only_local"), + ("routing", Just "route1,route2") + ] + + it "emits the full param set when every field is populated" $ do + let opts = + defaultCountOptions + { coAllowNoIndices = Just True, + coExpandWildcards = Just (ExpandWildcardsOpen :| []), + coIgnoreUnavailable = Just True, + coMinScore = Just 0, + coPreference = Just "_local", + coRouting = Just "r1" + } + let rendered = countOptionsParams opts + length rendered `shouldBe` 6 + rendered `shouldSatisfy` all (isJust . snd) + sort (map fst rendered) + `shouldBe` [ "allow_no_indices", + "expand_wildcards", + "ignore_unavailable", + "min_score", + "preference", + "routing" + ] + + describe "Count endpoint" $ do + -- Pure JSON decoder tests for CountShards. The @skipped@ field was + -- added in bloodhound-kc1 (mirroring ShardResult); older servers omit + -- it, so the decoder defaults to 0. Pin both paths so the lenient + -- parsing stays intact. + it "parses CountShards with an explicit skipped field" $ do + let Just (cs :: CountShards) = + decode + "{\"total\":2,\"successful\":2,\"skipped\":1,\"failed\":0}" + cs `shouldBe` CountShards {csTotal = 2, csSuccessful = 2, csSkipped = 1, csFailed = 0} + + it "defaults CountShards.skipped to 0 when absent (legacy server)" $ do + let Just (cs :: CountShards) = + decode "{\"total\":1,\"successful\":1,\"failed\":0}" + csSkipped cs `shouldBe` 0 + + it "parses CountShards leniently when only total is present" $ do + -- The server always returns total/successful/failed, but the + -- decoder accepts the minimal shape too (defaults all to 0). + let Just (cs :: CountShards) = decode "{\"total\":3}" + csTotal cs `shouldBe` 3 + csSuccessful cs `shouldBe` 0 + csSkipped cs `shouldBe` 0 + csFailed cs `shouldBe` 0 + + it "countByIndex returns count of a query" $ withTestEnv $ do _ <- insertData let query = MatchAllQuery Nothing count = CountQuery query c <- performBHRequest $ countByIndex testIndex count liftIO $ crCount c `shouldBe` 1 + + it "countAll returns a cluster-wide count without an index segment" $ + withTestEnv $ do + _ <- insertData + c <- performBHRequest $ countAll (CountQuery (MatchAllQuery Nothing)) + liftIO $ crCount c `shouldSatisfy` (>= 1) + + it "countByIndexWith Nothing matches countAll" $ + withTestEnv $ do + _ <- insertData + let q = CountQuery (MatchAllQuery Nothing) + a <- performBHRequest $ countAll q + b <- performBHRequest $ countByIndexWith Nothing defaultCountOptions q + liftIO $ crCount a `shouldBe` crCount b + + it "countByIndexWith (Just []) matches countAll" $ + withTestEnv $ do + _ <- insertData + let q = CountQuery (MatchAllQuery Nothing) + a <- performBHRequest $ countAll q + b <- performBHRequest $ countByIndexWith (Just []) defaultCountOptions q + liftIO $ crCount a `shouldBe` crCount b + + it "countByIndexWith (Just [testIndex]) matches countByIndex" $ + withTestEnv $ do + _ <- insertData + let q = CountQuery (MatchAllQuery Nothing) + a <- performBHRequest $ countByIndex testIndex q + b <- performBHRequest $ countByIndexWith (Just [testIndex]) defaultCountOptions q + liftIO $ crCount a `shouldBe` crCount b + + it "countByIndexWith accepts multiple comma-joined indices" $ + withTestEnv $ do + _ <- insertData + c <- + performBHRequest $ + countByIndexWith + (Just [testIndex, testIndex]) + defaultCountOptions + (CountQuery (MatchAllQuery Nothing)) + liftIO $ crCount c `shouldBe` 1 + + it "countByIndexWith forwards ignore_unavailable for a missing index" $ + withTestEnv $ do + _ <- insertData + let missing = [qqIndexName|bloodhound-missing-index-count-spec|] + -- With ignore_unavailable=true a missing index in the list is + -- silently dropped, so the request succeeds and reports the + -- count from the existing testIndex. + c <- + performBHRequest $ + countByIndexWith + (Just [missing, testIndex]) + defaultCountOptions {coIgnoreUnavailable = Just True} + (CountQuery (MatchAllQuery Nothing)) + liftIO $ crCount c `shouldBe` 1 + + it "countByIndexWith forwards expand_wildcards against the test index" $ + withTestEnv $ do + _ <- insertData + c <- + performBHRequest $ + countByIndexWith + (Just [testIndex]) + defaultCountOptions + { coExpandWildcards = Just (ExpandWildcardsOpen :| []) + } + (CountQuery (MatchAllQuery Nothing)) + liftIO $ crCount c `shouldBe` 1 + + it "countByIndexWith forwards min_score without server rejection" $ + withTestEnv $ do + _ <- insertData + -- min_score=0 admits every document, so the live count must + -- match the unfiltered countByIndex. This guards against a + -- regression where the wrong URI key is sent (the server + -- rejects unrecognised parameters with HTTP 400). + baseline <- performBHRequest $ countByIndex testIndex (CountQuery (MatchAllQuery Nothing)) + c <- + performBHRequest $ + countByIndexWith + (Just [testIndex]) + defaultCountOptions {coMinScore = Just 0.0} + (CountQuery (MatchAllQuery Nothing)) + liftIO $ crCount c `shouldBe` crCount baseline + + it "countByIndexWith forwards allow_no_indices, preference and routing together" $ + withTestEnv $ do + _ <- insertData + c <- + performBHRequest $ + countByIndexWith + (Just [testIndex]) + defaultCountOptions + { coAllowNoIndices = Just True, + coPreference = Just "_local", + -- The test index is single-shard with no custom + -- routing, so any value here exercises the plumbing + -- without changing the result. + coRouting = Just "1" + } + (CountQuery (MatchAllQuery Nothing)) + liftIO $ crCount c `shouldBe` 1 + + it "countByIndexWith surfaces an EsError for a missing index without ignore_unavailable" $ do + let missing = [qqIndexName|bloodhound-missing-index-count-spec|] + result <- + withTestEnv $ + tryEsError + ( performBHRequest $ + countByIndexWith + (Just [missing]) + defaultCountOptions + (CountQuery (MatchAllQuery Nothing)) + ) + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected EsError for missing index, got success" diff --git a/tests/Test/DataStreamsSpec.hs b/tests/Test/DataStreamsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/DataStreamsSpec.hs @@ -0,0 +1,1671 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.DataStreamsSpec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Int (Int64) +import Data.List (isInfixOf, sort) +import Data.Map.Strict qualified as M +import Database.Bloodhound.ElasticSearch7.Requests qualified as ES7 +import Database.Bloodhound.ElasticSearch8.Requests qualified as ES8 +import Database.Bloodhound.ElasticSearch9.Requests qualified as ES9 +import TestsUtils.Import +import Prelude + +-- | Fixture mimicking the @GET /_data_stream@ response (two streams). +-- Adapted from the shape documented at +-- https://www.elastic.co/guide/en/elasticsearch/reference/current/data-stream-apis.html#get-data-streams. +sampleListResponse :: LBS.ByteString +sampleListResponse = + "{\ + \ \"data_streams\": [\ + \ {\ + \ \"name\": \"logs-foobar\",\ + \ \"timestamp_field\": { \"name\": \"@timestamp\" },\ + \ \"indices\": [\ + \ { \"index_name\": \".ds-logs-foobar-2024.01.01-000001\", \"index_uuid\": \"uuid-a\" }\ + \ ],\ + \ \"generation\": 1,\ + \ \"status\": \"GREEN\",\ + \ \"template\": \"logs-foobar-template\",\ + \ \"hidden\": false\ + \ },\ + \ {\ + \ \"name\": \"metrics-hidden\",\ + \ \"timestamp_field\": { \"name\": \"ts\" },\ + \ \"indices\": [],\ + \ \"generation\": 5,\ + \ \"status\": \"YELLOW\",\ + \ \"template\": \"metrics-template\",\ + \ \"ilm_policy\": \"logs-policy\",\ + \ \"hidden\": true\ + \ }\ + \ ]\ + \}" + +-- | Fixture mimicking the @GET /_data_stream@ response when a stream is +-- missing the optional @ilm_policy@ field (the common case for streams +-- not backed by ILM). +sampleNoIlmPolicyResponse :: LBS.ByteString +sampleNoIlmPolicyResponse = + "{\ + \ \"data_streams\": [\ + \ {\ + \ \"name\": \"plain-stream\",\ + \ \"timestamp_field\": { \"name\": \"@timestamp\" },\ + \ \"indices\": [],\ + \ \"generation\": 1,\ + \ \"status\": \"GREEN\",\ + \ \"template\": \"plain-template\",\ + \ \"hidden\": false\ + \ }\ + \ ]\ + \}" + +streamName :: DataStream -> Text +streamName = (\(DataStreamName n) -> n) . dataStreamName + +-- | Construct an 'IndexName' at the value level for tests. Uses +-- 'mkIndexNameSystem' (not the stricter 'mkIndexName') because backing +-- index names start with @.@ (e.g. @.ds-stream-2024.01.01-000001@), +-- which the value-level 'FromJSON' instance accepts but 'qqIndexName' +-- rejects. +mkIdx :: Text -> IndexName +mkIdx = either (error . ("bad IndexName: " <>) . show) id . mkIndexNameSystem + +-- | Build a minimal 'ExplainDataStreamLifecycleIndex' for round-trip +-- tests: only the required fields (@index@ and @managed_by_lifecycle@) +-- are populated; optionals are 'Nothing'. +minimalExplainEntry :: IndexName -> ExplainDataStreamLifecycleIndex +minimalExplainEntry name = + ExplainDataStreamLifecycleIndex + { explainDataStreamLifecycleIndexIndex = name, + explainDataStreamLifecycleIndexManagedByLifecycle = True, + explainDataStreamLifecycleIndexCreationDateMillis = Nothing, + explainDataStreamLifecycleIndexTimeSinceIndexCreation = Nothing, + explainDataStreamLifecycleIndexRolloverDateMillis = Nothing, + explainDataStreamLifecycleIndexTimeSinceRollover = Nothing, + explainDataStreamLifecycleIndexLifecycle = Nothing, + explainDataStreamLifecycleIndexGenerationTime = Nothing, + explainDataStreamLifecycleIndexError = Nothing + } + +-- | Fixture mimicking the @GET /_data_stream/_stats@ response with a +-- single data stream. Adapted from the shape documented at +-- https://www.elastic.co/guide/en/elasticsearch/reference/current/data-stream-apis.html#get-data-stream-stats. +sampleStatsResponse :: LBS.ByteString +sampleStatsResponse = + "{\ + \ \"_shards\": { \"total\": 2, \"successful\": 2, \"skipped\": 0, \"failed\": 0 },\ + \ \"data_stream_count\": 1,\ + \ \"backing_indices\": 2,\ + \ \"total_store_size_bytes\": 786432,\ + \ \"total_store_size\": \"786kb\",\ + \ \"data_streams\": [\ + \ {\ + \ \"data_stream\": \"logs-foobar\",\ + \ \"backing_indices\": 2,\ + \ \"store_size_bytes\": 786432,\ + \ \"store_size\": \"786kb\",\ + \ \"maximum_timestamp\": 1716854400000\ + \ }\ + \ ]\ + \}" + +spec :: Spec +spec = describe "Data Streams API" $ do + describe "DataStream JSON" $ do + it "decodes a single stream with all fields populated" $ do + let decoded = decode "{ \"name\": \"ds\", \"timestamp_field\": { \"name\": \"@timestamp\" }, \"indices\": [], \"generation\": 1, \"status\": \"GREEN\", \"template\": \"tpl\", \"hidden\": false }" :: Maybe DataStream + streamName <$> decoded `shouldBe` Just "ds" + dataStreamGeneration <$> decoded `shouldBe` Just 1 + dataStreamStatus <$> decoded `shouldBe` Just Green + dataStreamHidden <$> decoded `shouldBe` Just False + dataStreamIlmPolicy <$> decoded `shouldBe` Just Nothing + + it "decodes ilm_policy when present" $ do + let decoded = decode "{ \"name\": \"ds\", \"timestamp_field\": { \"name\": \"@timestamp\" }, \"indices\": [], \"generation\": 1, \"status\": \"GREEN\", \"template\": \"tpl\", \"ilm_policy\": \"my-policy\", \"hidden\": true }" :: Maybe DataStream + dataStreamIlmPolicy <$> decoded `shouldBe` Just (Just "my-policy") + dataStreamHidden <$> decoded `shouldBe` Just True + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode "{ \"name\": \"ds\", \"timestamp_field\": { \"name\": \"@timestamp\" }, \"indices\": [], \"generation\": 1, \"status\": \"GREEN\", \"template\": \"tpl\", \"hidden\": false }" :: Maybe DataStream + (decode . encode) decoded `shouldBe` Just decoded + + it "decodes system/replicated/_meta when present" $ do + let decoded = decode "{ \"name\": \"ds\", \"timestamp_field\": { \"name\": \"@timestamp\" }, \"indices\": [], \"generation\": 1, \"status\": \"GREEN\", \"template\": \"tpl\", \"hidden\": false, \"system\": true, \"replicated\": false, \"_meta\": { \"my-meta-field\": \"foo\" } }" :: Maybe DataStream + expectedMeta = decode "{ \"my-meta-field\": \"foo\" }" :: Maybe Object + dataStreamSystem <$> decoded `shouldBe` Just (Just True) + dataStreamReplicated <$> decoded `shouldBe` Just (Just False) + dataStreamMeta <$> decoded `shouldBe` Just expectedMeta + + it "rejects a non-object _meta (object is the documented wire type)" $ do + let decoded = decode "{ \"name\": \"ds\", \"timestamp_field\": { \"name\": \"@timestamp\" }, \"indices\": [], \"generation\": 1, \"status\": \"GREEN\", \"template\": \"tpl\", \"hidden\": false, \"_meta\": \"not-an-object\" }" :: Maybe DataStream + decoded `shouldBe` Nothing + + it "decodes absent system/replicated/_meta as Nothing" $ do + let decoded = decode "{ \"name\": \"ds\", \"timestamp_field\": { \"name\": \"@timestamp\" }, \"indices\": [], \"generation\": 1, \"status\": \"GREEN\", \"template\": \"tpl\", \"hidden\": false }" :: Maybe DataStream + dataStreamSystem <$> decoded `shouldBe` Just Nothing + dataStreamReplicated <$> decoded `shouldBe` Just Nothing + dataStreamMeta <$> decoded `shouldBe` Just Nothing + + it "decodes explicit null system/replicated/_meta as Nothing" $ do + let decoded = decode "{ \"name\": \"ds\", \"timestamp_field\": { \"name\": \"@timestamp\" }, \"indices\": [], \"generation\": 1, \"status\": \"GREEN\", \"template\": \"tpl\", \"hidden\": false, \"system\": null, \"replicated\": null, \"_meta\": null }" :: Maybe DataStream + dataStreamSystem <$> decoded `shouldBe` Just Nothing + dataStreamReplicated <$> decoded `shouldBe` Just Nothing + dataStreamMeta <$> decoded `shouldBe` Just Nothing + + it "round-trips a fully-populated stream through ToJSON/FromJSON" $ do + let Just decoded = decode "{ \"name\": \"ds\", \"timestamp_field\": { \"name\": \"@timestamp\" }, \"indices\": [], \"generation\": 1, \"status\": \"GREEN\", \"template\": \"tpl\", \"ilm_policy\": \"my-policy\", \"hidden\": false, \"system\": true, \"replicated\": false, \"_meta\": { \"my-meta-field\": \"foo\" } }" :: Maybe DataStream + (decode . encode) decoded `shouldBe` Just decoded + + it "preserves system/replicated/_meta as Nothing on the existing two-stream fixture" $ do + let Just decoded = decode sampleListResponse :: Maybe GetDataStreamsResponse + [s1, s2] = dataStreams decoded + dataStreamSystem s1 `shouldBe` Nothing + dataStreamReplicated s1 `shouldBe` Nothing + dataStreamMeta s1 `shouldBe` Nothing + dataStreamSystem s2 `shouldBe` Nothing + dataStreamReplicated s2 `shouldBe` Nothing + dataStreamMeta s2 `shouldBe` Nothing + + it "rejects a body missing the required 'name' field" $ do + let decoded = decode "{ \"generation\": 1 }" :: Maybe DataStream + decoded `shouldBe` Nothing + + it "decodes a stream carrying a lowercase / degenerate status through the full record" $ do + let decoded = decode "{ \"name\": \"ds\", \"timestamp_field\": { \"name\": \"@timestamp\" }, \"indices\": [], \"generation\": 1, \"status\": \"unknown\", \"template\": \"tpl\", \"hidden\": false }" :: Maybe DataStream + dataStreamStatus <$> decoded `shouldBe` Just Unknown + + it "decodes DataStreamStatus variants (uppercase)" $ do + decode "\"GREEN\"" `shouldBe` Just Green + decode "\"YELLOW\"" `shouldBe` Just Yellow + decode "\"RED\"" `shouldBe` Just Red + + it "decodes DataStreamStatus variants (lowercase)" $ do + decode "\"green\"" `shouldBe` Just Green + decode "\"yellow\"" `shouldBe` Just Yellow + decode "\"red\"" `shouldBe` Just Red + + it "decodes unknown/unavailable health states" $ do + decode "\"unknown\"" `shouldBe` Just Unknown + decode "\"unavailable\"" `shouldBe` Just Unavailable + + it "round-trips Unknown and Unavailable" $ do + (decode . encode) Unknown `shouldBe` Just Unknown + (decode . encode) Unavailable `shouldBe` Just Unavailable + + it "still rejects truly invalid status values" $ + (decode "\"purple\"" :: Maybe DataStreamStatus) `shouldBe` Nothing + + describe "GetDataStreamsResponse JSON" $ do + it "decodes the list-all response with two streams" $ do + let Just decoded = decode sampleListResponse :: Maybe GetDataStreamsResponse + length (dataStreams decoded) `shouldBe` 2 + sort (map streamName (dataStreams decoded)) + `shouldBe` ["logs-foobar", "metrics-hidden"] + + it "preserves ilm_policy on the stream that has one" $ do + let Just decoded = decode sampleListResponse :: Maybe GetDataStreamsResponse + hiddenStream = head [s | s <- dataStreams decoded, streamName s == "metrics-hidden"] + dataStreamIlmPolicy hiddenStream `shouldBe` Just "logs-policy" + dataStreamHidden hiddenStream `shouldBe` True + + it "decodes the response missing ilm_policy as Nothing" $ do + let Just decoded = decode sampleNoIlmPolicyResponse :: Maybe GetDataStreamsResponse + [plainStream] = dataStreams decoded + dataStreamIlmPolicy plainStream `shouldBe` Nothing + + it "decodes an empty data_streams array as the empty list" $ do + let decoded = decode "{ \"data_streams\": [] }" :: Maybe GetDataStreamsResponse + (dataStreams <$> decoded) `shouldBe` Just [] + + it "rejects a top-level array (the response must be a keyed object)" $ do + let decoded = decode "[]" :: Maybe GetDataStreamsResponse + decoded `shouldBe` Nothing + + it "rejects malformed JSON" $ do + let decoded = decode "{ this is not json" :: Maybe GetDataStreamsResponse + decoded `shouldBe` Nothing + + describe "getDataStreams endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "GETs /_data_stream when given Nothing" $ do + let req = ES7.getDataStreams Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream when given Just [] (empty list collapses to all)" $ do + let req = ES7.getDataStreams (Just []) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/{name} when given a single-element list" $ do + let req = ES7.getDataStreams (Just [DataStreamName "logs-foobar"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "logs-foobar"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/{a,b,c} when given a multi-element list (comma-joined)" $ do + let req = ES7.getDataStreams (Just [DataStreamName "a", DataStreamName "b", DataStreamName "c"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "a,b,c"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "does not attach a body (GET semantics)" $ do + let req = ES7.getDataStreams Nothing + bhRequestBody req `shouldBe` Nothing + + describe "createDataStream endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "PUTs /_data_stream/{name} for the given data stream" $ do + let req = ES7.createDataStream (DataStreamName "logs-foobar") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "logs-foobar"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the PUT method" $ do + let req = ES7.createDataStream (DataStreamName "logs-foobar") + bhRequestMethod req `shouldBe` "PUT" + + it "sends an empty body (ES derives the config from the index template)" $ do + let req = ES7.createDataStream (DataStreamName "logs-foobar") + bhRequestBody req `shouldBe` Just "" + + describe "deleteDataStream endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "DELETEs /_data_stream/{name} for the given data stream" $ do + let req = ES7.deleteDataStream (DataStreamName "logs-foobar") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "logs-foobar"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the DELETE method" $ do + let req = ES7.deleteDataStream (DataStreamName "logs-foobar") + bhRequestMethod req `shouldBe` "DELETE" + + it "does not attach a body (DELETE semantics)" $ do + let req = ES7.deleteDataStream (DataStreamName "logs-foobar") + bhRequestBody req `shouldBe` Nothing + + describe "migrateToDataStream endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "POSTs /_data_stream/_migrate/{alias} for the given alias" $ do + let req = ES7.migrateToDataStream (IndexAliasName [qqIndexName|logs-alias|]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_migrate", "logs-alias"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the POST method" $ do + let req = ES7.migrateToDataStream (IndexAliasName [qqIndexName|logs-alias|]) + bhRequestMethod req `shouldBe` "POST" + + it "sends an empty body (ES derives the config from the alias and its write index)" $ do + let req = ES7.migrateToDataStream (IndexAliasName [qqIndexName|logs-alias|]) + bhRequestBody req `shouldBe` Just "" + + describe "promoteDataStream endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "POSTs /_data_stream/_promote/{name} for the given data stream" $ do + let req = ES7.promoteDataStream (DataStreamName "logs-foobar") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_promote", "logs-foobar"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the POST method" $ do + let req = ES7.promoteDataStream (DataStreamName "logs-foobar") + bhRequestMethod req `shouldBe` "POST" + + it "sends an empty body (ES promotes the stream in place)" $ do + let req = ES7.promoteDataStream (DataStreamName "logs-foobar") + bhRequestBody req `shouldBe` Just "" + + describe "DataStreamStat JSON" $ do + it "decodes a stat with all fields populated" $ do + let decoded = decode "{ \"data_stream\": \"logs-foobar\", \"backing_indices\": 2, \"store_size_bytes\": 786432, \"store_size\": \"786kb\", \"maximum_timestamp\": 1716854400000 }" :: Maybe DataStreamStat + (dataStreamStatName <$> decoded) `shouldBe` Just (DataStreamName "logs-foobar") + (dataStreamStatBackingIndices <$> decoded) `shouldBe` Just 2 + (dataStreamStatStoreSizeBytes <$> decoded) `shouldBe` Just (786432 :: Int64) + (dataStreamStatStoreSize <$> decoded) `shouldBe` Just (Just "786kb") + (dataStreamStatMaximumTimestamp <$> decoded) `shouldBe` Just 1716854400000 + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode "{ \"data_stream\": \"ds\", \"backing_indices\": 1, \"store_size_bytes\": 1024, \"store_size\": \"1kb\", \"maximum_timestamp\": 1700000000 }" :: Maybe DataStreamStat + (decode . encode) decoded `shouldBe` Just decoded + + it "rejects a body missing the required 'data_stream' field" $ do + let decoded = decode "{ \"backing_indices\": 1 }" :: Maybe DataStreamStat + decoded `shouldBe` Nothing + + it "rejects a per-stream stat using 'name' instead of 'data_stream'" $ do + let decoded = decode "{ \"name\": \"logs-foobar\", \"backing_indices\": 2, \"store_size_bytes\": 786432, \"store_size\": \"786kb\", \"maximum_timestamp\": 1716854400000 }" :: Maybe DataStreamStat + decoded `shouldBe` Nothing + + it "decodes a stat missing the human-only 'store_size' as Nothing (human=false)" $ do + let decoded = decode "{ \"data_stream\": \"ds\", \"backing_indices\": 1, \"store_size_bytes\": 1024, \"maximum_timestamp\": 1700000000 }" :: Maybe DataStreamStat + dataStreamStatStoreSize <$> decoded `shouldBe` Just Nothing + (dataStreamStatStoreSizeBytes <$> decoded) `shouldBe` Just (1024 :: Int64) + + it "decodes a stat whose 'store_size' is explicitly null as Nothing" $ do + let decoded = decode "{ \"data_stream\": \"ds\", \"backing_indices\": 1, \"store_size_bytes\": 1024, \"store_size\": null, \"maximum_timestamp\": 1700000000 }" :: Maybe DataStreamStat + dataStreamStatStoreSize <$> decoded `shouldBe` Just Nothing + + it "round-trips a stat without store_size (encodes the field as null)" $ do + let Just decoded = decode "{ \"data_stream\": \"ds\", \"backing_indices\": 1, \"store_size_bytes\": 1024, \"maximum_timestamp\": 1700000000 }" :: Maybe DataStreamStat + (decode . encode) decoded `shouldBe` Just decoded + LBS.unpack (encode decoded) `shouldSatisfy` isInfixOf "\"store_size\":null" + + describe "DataStreamStats JSON" $ do + it "decodes the full response with one data stream" $ do + let Just decoded = decode sampleStatsResponse :: Maybe DataStreamStats + dataStreamStatsCount decoded `shouldBe` 1 + dataStreamStatsBackingIndices decoded `shouldBe` 2 + dataStreamStatsTotalStoreSizeBytes decoded `shouldBe` (786432 :: Int64) + dataStreamStatsTotalStoreSize decoded `shouldBe` Just "786kb" + length (dataStreamStatsDataStreams decoded) `shouldBe` 1 + + it "decodes the _shards summary into a ShardResult" $ do + let Just decoded = decode sampleStatsResponse :: Maybe DataStreamStats + dataStreamStatsShards decoded `shouldBe` ShardResult 2 2 0 0 + + it "preserves per-stream fields through decode" $ do + let Just decoded = decode sampleStatsResponse :: Maybe DataStreamStats + [stat] = dataStreamStatsDataStreams decoded + dataStreamStatName stat `shouldBe` DataStreamName "logs-foobar" + dataStreamStatStoreSize stat `shouldBe` Just "786kb" + dataStreamStatMaximumTimestamp stat `shouldBe` 1716854400000 + + it "decodes multiple data streams in the data_streams array" $ do + let payload = + "{ \"_shards\": { \"total\": 4, \"successful\": 4, \"skipped\": 0, \"failed\": 0 }" + <> ", \"data_stream_count\": 2, \"backing_indices\": 4, \"total_store_size_bytes\": 1000, \"total_store_size\": \"1kb\"" + <> ", \"data_streams\": [" + <> " { \"data_stream\": \"a\", \"backing_indices\": 2, \"store_size_bytes\": 500, \"store_size\": \"500b\", \"maximum_timestamp\": 1 }," + <> " { \"data_stream\": \"b\", \"backing_indices\": 2, \"store_size_bytes\": 500, \"store_size\": \"500b\", \"maximum_timestamp\": 2 }" + <> "] }" + Just decoded = decode payload :: Maybe DataStreamStats + length (dataStreamStatsDataStreams decoded) `shouldBe` 2 + sort (map (\s -> (\(DataStreamName n) -> n) (dataStreamStatName s)) (dataStreamStatsDataStreams decoded)) + `shouldBe` ["a", "b"] + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode sampleStatsResponse :: Maybe DataStreamStats + (decode . encode) decoded `shouldBe` Just decoded + + it "decodes an empty data_streams array as the empty list" $ do + let decoded = decode "{ \"_shards\": { \"total\": 0, \"successful\": 0, \"skipped\": 0, \"failed\": 0 }, \"data_stream_count\": 0, \"backing_indices\": 0, \"total_store_size_bytes\": 0, \"total_store_size\": \"0b\", \"data_streams\": [] }" :: Maybe DataStreamStats + (dataStreamStatsDataStreams <$> decoded) `shouldBe` Just [] + + it "rejects a response missing the _shards field" $ do + let decoded = decode "{ \"data_stream_count\": 0, \"backing_indices\": 0, \"total_store_size_bytes\": 0, \"total_store_size\": \"0b\", \"data_streams\": [] }" :: Maybe DataStreamStats + decoded `shouldBe` Nothing + + it "decodes a response missing the human-only 'total_store_size' as Nothing (human=false)" $ do + let payload = + "{ \"_shards\": { \"total\": 1, \"successful\": 1, \"skipped\": 0, \"failed\": 0 }" + <> ", \"data_stream_count\": 0, \"backing_indices\": 0, \"total_store_size_bytes\": 0, \"data_streams\": [] }" + Just decoded = decode payload :: Maybe DataStreamStats + dataStreamStatsTotalStoreSize decoded `shouldBe` Nothing + dataStreamStatsTotalStoreSizeBytes decoded `shouldBe` (0 :: Int64) + + it "round-trips a response without total_store_size (encodes the field as null)" $ do + let payload = + "{ \"_shards\": { \"total\": 1, \"successful\": 1, \"skipped\": 0, \"failed\": 0 }" + <> ", \"data_stream_count\": 0, \"backing_indices\": 0, \"total_store_size_bytes\": 0, \"data_streams\": [] }" + Just decoded = decode payload :: Maybe DataStreamStats + (decode . encode) decoded `shouldBe` Just decoded + LBS.unpack (encode decoded) `shouldSatisfy` isInfixOf "\"total_store_size\":null" + + it "rejects a top-level array (the response must be a keyed object)" $ do + let decoded = decode "[]" :: Maybe DataStreamStats + decoded `shouldBe` Nothing + + it "rejects malformed JSON" $ do + let decoded = decode "{ this is not json" :: Maybe DataStreamStats + decoded `shouldBe` Nothing + + describe "getDataStreamStats endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "GETs /_data_stream/_stats when given Nothing" $ do + let req = ES7.getDataStreamStats Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/_stats when given Just [] (empty list collapses to all)" $ do + let req = ES7.getDataStreamStats (Just []) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/{name}/_stats when given a single-element list" $ do + let req = ES7.getDataStreamStats (Just [DataStreamName "logs-foobar"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "logs-foobar", "_stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/{a,b,c}/_stats when given a multi-element list (comma-joined)" $ do + let req = ES7.getDataStreamStats (Just [DataStreamName "a", DataStreamName "b", DataStreamName "c"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "a,b,c", "_stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "does not attach a body (GET semantics)" $ do + let req = ES7.getDataStreamStats Nothing + bhRequestBody req `shouldBe` Nothing + + -- ============================================================ + -- Data Stream Lifecycle (ES 8.x+, back-filled to ES 7.17.x) + -- ============================================================ + + describe "DataStreamLifecycleDownsampling JSON" $ do + it "decodes a fully-populated downsampling entry" $ do + let decoded = decode "{ \"after\": \"10d\", \"fixed_interval\": \"1h\" }" :: Maybe DataStreamLifecycleDownsampling + dataStreamLifecycleDownsamplingAfter <$> decoded `shouldBe` Just (Just "10d") + dataStreamLifecycleDownsamplingFixedInterval <$> decoded `shouldBe` Just (Just "1h") + + it "decodes an empty object as both fields Nothing" $ do + let decoded = decode "{}" :: Maybe DataStreamLifecycleDownsampling + decoded `shouldBe` Just (DataStreamLifecycleDownsampling Nothing Nothing) + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode "{ \"after\": \"10d\", \"fixed_interval\": \"1h\" }" :: Maybe DataStreamLifecycleDownsampling + (decode . encode) decoded `shouldBe` Just decoded + + it "omits Nothing fields on encode (clean wire form)" $ do + let value = DataStreamLifecycleDownsampling (Just "10d") Nothing + encode value `shouldBe` "{\"after\":\"10d\"}" + + describe "SamplingMethod JSON (data-stream downsampling method)" $ do + it "decodes aggregate" $ decode "\"aggregate\"" `shouldBe` Just Aggregate + it "decodes last_value" $ decode "\"last_value\"" `shouldBe` Just LastValue + it "rejects an unknown method" $ (decode "\"average\"" :: Maybe SamplingMethod) `shouldBe` Nothing + it "round-trips both variants" $ do + (decode . encode) Aggregate `shouldBe` Just Aggregate + (decode . encode) LastValue `shouldBe` Just LastValue + + describe "DataStreamLifecycle JSON" $ do + it "decodes a fully-populated lifecycle" $ do + let payload = + "{ \"data_retention\": \"30d\"" + <> ", \"enabled\": true" + <> ", \"downsampling\": [{ \"after\": \"10d\", \"fixed_interval\": \"1h\" }]" + <> ", \"downsampling_method\": \"aggregate\" }" + Just decoded = decode payload :: Maybe DataStreamLifecycle + dataStreamLifecycleDataRetention decoded `shouldBe` Just "30d" + dataStreamLifecycleEnabled decoded `shouldBe` Just True + dataStreamLifecycleDownsampling decoded `shouldBe` Just [DataStreamLifecycleDownsampling (Just "10d") (Just "1h")] + dataStreamLifecycleDownsamplingMethod decoded `shouldBe` Just Aggregate + + it "decodes an empty object as the all-Nothing lifecycle" $ do + let decoded = decode "{}" :: Maybe DataStreamLifecycle + decoded `shouldBe` Just (DataStreamLifecycle Nothing Nothing Nothing Nothing Nothing Nothing) + + it "decodes data_retention-only as the rest Nothing" $ do + let decoded = decode "{ \"data_retention\": \"7d\" }" :: Maybe DataStreamLifecycle + dataStreamLifecycleDataRetention <$> decoded `shouldBe` Just (Just "7d") + dataStreamLifecycleEnabled <$> decoded `shouldBe` Just Nothing + + it "round-trips a fully-populated lifecycle" $ do + let Just decoded = decode "{ \"data_retention\": \"30d\", \"enabled\": true, \"downsampling\": [{ \"after\": \"10d\", \"fixed_interval\": \"1h\" }], \"downsampling_method\": \"aggregate\" }" :: Maybe DataStreamLifecycle + (decode . encode) decoded `shouldBe` Just decoded + + it "omits Nothing fields on encode (clean PUT body)" $ do + let value = DataStreamLifecycle (Just "7d") Nothing Nothing Nothing Nothing Nothing + encode value `shouldBe` "{\"data_retention\":\"7d\"}" + + it "encodes the all-Nothing lifecycle as an empty object" $ do + encode (DataStreamLifecycle Nothing Nothing Nothing Nothing Nothing Nothing) `shouldBe` "{}" + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe DataStreamLifecycle + decoded `shouldBe` Nothing + + describe "DataStreamLifecycleInfo JSON" $ do + it "decodes a managed stream with a populated lifecycle" $ do + let payload = + "{ \"name\": \"logs-app\"" + <> ", \"lifecycle\": { \"data_retention\": \"7d\", \"enabled\": true } }" + Just decoded = decode payload :: Maybe DataStreamLifecycleInfo + dataStreamLifecycleInfoName decoded `shouldBe` DataStreamName "logs-app" + dataStreamLifecycleInfoLifecycle decoded `shouldSatisfy` isJust + + it "decodes an unmanaged stream with lifecycle:null as Nothing" $ do + let Just decoded = decode "{ \"name\": \"logs-app\", \"lifecycle\": null }" :: Maybe DataStreamLifecycleInfo + dataStreamLifecycleInfoName decoded `shouldBe` DataStreamName "logs-app" + dataStreamLifecycleInfoLifecycle decoded `shouldBe` Nothing + + it "decodes an unmanaged stream with lifecycle absent as Nothing" $ do + let Just decoded = decode "{ \"name\": \"logs-app\" }" :: Maybe DataStreamLifecycleInfo + dataStreamLifecycleInfoLifecycle decoded `shouldBe` Nothing + + it "round-trips a managed stream" $ do + let Just decoded = decode "{ \"name\": \"ds\", \"lifecycle\": { \"data_retention\": \"7d\" } }" :: Maybe DataStreamLifecycleInfo + (decode . encode) decoded `shouldBe` Just decoded + + it "rejects an info missing the data_stream field" $ do + let decoded = decode "{ \"lifecycle\": { \"data_retention\": \"7d\" } }" :: Maybe DataStreamLifecycleInfo + decoded `shouldBe` Nothing + + describe "GetDataStreamLifecyclesResponse JSON" $ do + it "decodes a response with two managed streams" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"a\", \"lifecycle\": { \"data_retention\": \"1d\" } }," + <> " { \"name\": \"b\", \"lifecycle\": { \"data_retention\": \"2d\" } } ] }" + Just decoded = decode payload :: Maybe GetDataStreamLifecyclesResponse + length (dataStreamLifecycles decoded) `shouldBe` 2 + + it "decodes a stream with lifecycle:null alongside a managed one" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"managed\", \"lifecycle\": { \"data_retention\": \"1d\" } }," + <> " { \"name\": \"unmanaged\", \"lifecycle\": null } ] }" + Just decoded = decode payload :: Maybe GetDataStreamLifecyclesResponse + length (dataStreamLifecycles decoded) `shouldBe` 2 + let unmanaged = head [i | i <- dataStreamLifecycles decoded, (\(DataStreamName n) -> n) (dataStreamLifecycleInfoName i) == "unmanaged"] + dataStreamLifecycleInfoLifecycle unmanaged `shouldBe` Nothing + + it "decodes an empty data_streams array" $ do + let decoded = decode "{ \"data_streams\": [] }" :: Maybe GetDataStreamLifecyclesResponse + (dataStreamLifecycles <$> decoded) `shouldBe` Just [] + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode "{ \"data_streams\": [{ \"name\": \"a\", \"lifecycle\": { \"data_retention\": \"1d\" } }] }" :: Maybe GetDataStreamLifecyclesResponse + (decode . encode) decoded `shouldBe` Just decoded + + it "rejects a response missing the data_streams field" $ do + let decoded = decode "{}" :: Maybe GetDataStreamLifecyclesResponse + decoded `shouldBe` Nothing + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe GetDataStreamLifecyclesResponse + decoded `shouldBe` Nothing + + describe "putDataStreamLifecycle endpoint shape" $ do + it "PUTs /_data_stream/{name}/_lifecycle for the given stream" $ do + let req = ES8.putDataStreamLifecycle (DataStreamName "logs-foobar") (DataStreamLifecycle (Just "7d") Nothing Nothing Nothing Nothing Nothing) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "logs-foobar", "_lifecycle"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the PUT method" $ do + let req = ES8.putDataStreamLifecycle (DataStreamName "logs-foobar") (DataStreamLifecycle Nothing Nothing Nothing Nothing Nothing Nothing) + bhRequestMethod req `shouldBe` "PUT" + + it "sends the encoded DataStreamLifecycle as the body" $ do + let req = ES8.putDataStreamLifecycle (DataStreamName "logs-foobar") (DataStreamLifecycle (Just "7d") Nothing Nothing Nothing Nothing Nothing) + bhRequestBody req `shouldBe` Just "{\"data_retention\":\"7d\"}" + + it "sends an empty object body when the lifecycle is all-Nothing" $ do + let req = ES8.putDataStreamLifecycle (DataStreamName "logs-foobar") (DataStreamLifecycle Nothing Nothing Nothing Nothing Nothing Nothing) + bhRequestBody req `shouldBe` Just "{}" + + describe "getDataStreamLifecycle endpoint shape" $ do + it "GETs /_data_stream/_lifecycle when given Nothing" $ do + let req = ES8.getDataStreamLifecycle Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_lifecycle"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/_lifecycle when given Just [] (empty list collapses to all)" $ do + let req = ES8.getDataStreamLifecycle (Just []) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_lifecycle"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/{name}/_lifecycle when given a single-element list" $ do + let req = ES8.getDataStreamLifecycle (Just [DataStreamName "logs-foobar"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "logs-foobar", "_lifecycle"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/{a,b,c}/_lifecycle when given a multi-element list (comma-joined)" $ do + let req = ES8.getDataStreamLifecycle (Just [DataStreamName "a", DataStreamName "b", DataStreamName "c"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "a,b,c", "_lifecycle"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "does not attach a body (GET semantics)" $ do + let req = ES8.getDataStreamLifecycle Nothing + bhRequestBody req `shouldBe` Nothing + + describe "deleteDataStreamLifecycle endpoint shape" $ do + it "DELETEs /_data_stream/{name}/_lifecycle for the given stream" $ do + let req = ES8.deleteDataStreamLifecycle (DataStreamName "logs-foobar") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "logs-foobar", "_lifecycle"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the DELETE method" $ do + let req = ES8.deleteDataStreamLifecycle (DataStreamName "logs-foobar") + bhRequestMethod req `shouldBe` "DELETE" + + it "does not attach a body (DELETE semantics)" $ do + let req = ES8.deleteDataStreamLifecycle (DataStreamName "logs-foobar") + bhRequestBody req `shouldBe` Nothing + + describe "DataStreamLifecycle read-only fields (effective_retention, retention_determined_by)" $ do + it "decodes effective_retention on a GET response" $ do + let payload = "{ \"data_retention\": \"7d\", \"effective_retention\": \"7d\", \"retention_determined_by\": \"data_stream_configuration\" }" + Just decoded = decode payload :: Maybe DataStreamLifecycle + dataStreamLifecycleEffectiveRetention decoded `shouldBe` Just "7d" + dataStreamLifecycleRetentionDeterminedBy decoded `shouldBe` Just "data_stream_configuration" + + it "decodes retention_determined_by=max_global_retention when global retention caps the stream" $ do + let Just decoded = decode "{ \"data_retention\": \"365d\", \"effective_retention\": \"30d\", \"retention_determined_by\": \"max_global_retention\" }" :: Maybe DataStreamLifecycle + dataStreamLifecycleRetentionDeterminedBy decoded `shouldBe` Just "max_global_retention" + + it "round-trips a lifecycle with read-only fields populated" $ do + let Just decoded = decode "{ \"data_retention\": \"7d\", \"effective_retention\": \"7d\", \"retention_determined_by\": \"data_stream_configuration\" }" :: Maybe DataStreamLifecycle + (decode . encode) decoded `shouldBe` Just decoded + + it "omits read-only fields on PUT when they are Nothing (clean wire form)" $ do + let value = DataStreamLifecycle (Just "7d") Nothing Nothing Nothing Nothing Nothing + encode value `shouldBe` "{\"data_retention\":\"7d\"}" + + describe "DataStreamGlobalRetention JSON" $ do + it "decodes a fully-populated global_retention object" $ do + let Just decoded = decode "{ \"max_retention\": \"365d\", \"default_retention\": \"30d\" }" :: Maybe DataStreamGlobalRetention + dataStreamGlobalRetentionMaxRetention decoded `shouldBe` Just "365d" + dataStreamGlobalRetentionDefaultRetention decoded `shouldBe` Just "30d" + + it "decodes an empty object as both fields Nothing" $ do + let decoded = decode "{}" :: Maybe DataStreamGlobalRetention + decoded `shouldBe` Just (DataStreamGlobalRetention Nothing Nothing) + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode "{ \"max_retention\": \"365d\", \"default_retention\": \"30d\" }" :: Maybe DataStreamGlobalRetention + (decode . encode) decoded `shouldBe` Just decoded + + describe "S6: omitNulls collapse of empty downsampling list" $ do + -- Pins the documented behavior: Just [] and Nothing are indistinguishable + -- on the wire (both omit the field), because omitNulls drops empty arrays. + it "encodes Just [] downsampling the same as Nothing downsampling" $ do + let withEmptyList = DataStreamLifecycle Nothing Nothing (Just []) Nothing Nothing Nothing + withNothing = DataStreamLifecycle Nothing Nothing Nothing Nothing Nothing Nothing + encode withEmptyList `shouldBe` encode withNothing + encode withEmptyList `shouldBe` "{}" + + describe "GetDataStreamLifecyclesResponse with global_retention" $ do + it "decodes a response carrying global_retention" $ do + let payload = + "{ \"data_streams\": [{ \"name\": \"a\", \"lifecycle\": { \"data_retention\": \"1d\" } }]" + <> ", \"global_retention\": { \"max_retention\": \"365d\", \"default_retention\": \"30d\" } }" + Just decoded = decode payload :: Maybe GetDataStreamLifecyclesResponse + length (dataStreamLifecycles decoded) `shouldBe` 1 + dataStreamLifecyclesGlobalRetention decoded `shouldSatisfy` isJust + let Just gr = dataStreamLifecyclesGlobalRetention decoded + dataStreamGlobalRetentionMaxRetention gr `shouldBe` Just "365d" + dataStreamGlobalRetentionDefaultRetention gr `shouldBe` Just "30d" + + it "decodes a response without global_retention as Nothing" $ do + let Just decoded = decode "{ \"data_streams\": [] }" :: Maybe GetDataStreamLifecyclesResponse + dataStreamLifecyclesGlobalRetention decoded `shouldBe` Nothing + + it "round-trips a response with global_retention" $ do + let payload = + "{ \"data_streams\": [{ \"name\": \"a\", \"lifecycle\": { \"data_retention\": \"1d\" } }]" + <> ", \"global_retention\": { \"max_retention\": \"365d\", \"default_retention\": \"30d\" } }" + Just decoded = decode payload :: Maybe GetDataStreamLifecyclesResponse + (decode . encode) decoded `shouldBe` Just decoded + + describe "GET /_data_stream/{name}/_lifecycle verbatim ES docs example" $ do + -- Anchor: payload lifted verbatim from the ES 8.x REST docs page + -- operation-indices-get-data-lifecycle response example. + it "decodes the two-stream example from the official docs" $ do + let docsExample = + "{ \"data_streams\": [" + <> " { \"name\": \"my-data-stream-1\", \"lifecycle\": { \"enabled\": true, \"data_retention\": \"7d\" } }," + <> " { \"name\": \"my-data-stream-2\", \"lifecycle\": { \"enabled\": true, \"data_retention\": \"7d\" } } ] }" + Just decoded = decode docsExample :: Maybe GetDataStreamLifecyclesResponse + length (dataStreamLifecycles decoded) `shouldBe` 2 + let names = [(\(DataStreamName n) -> n) (dataStreamLifecycleInfoName i) | i <- dataStreamLifecycles decoded] + names `shouldBe` ["my-data-stream-1", "my-data-stream-2"] + let firstStream = head (dataStreamLifecycles decoded) + Just firstLifecycle = dataStreamLifecycleInfoLifecycle firstStream + dataStreamLifecycleEnabled firstLifecycle `shouldBe` Just True + dataStreamLifecycleDataRetention firstLifecycle `shouldBe` Just "7d" + + -- ============================================================ + -- Modify data stream (POST /_data_stream/_modify, ES 7.16+) + -- ============================================================ + + describe "ModifyDataStreamAction JSON" $ do + it "decodes an add_backing_index action" $ do + let decoded = decode "{ \"add_backing_index\": { \"data_stream\": \"logs\", \"index\": \".ds-logs-000001\" } }" :: Maybe ModifyDataStreamAction + case decoded of + Just (AddBackingIndex (DataStreamName "logs") _) -> pure () + other -> expectationFailure ("expected AddBackingIndex, got " <> show other) + + it "decodes a remove_backing_index action" $ do + let decoded = decode "{ \"remove_backing_index\": { \"data_stream\": \"logs\", \"index\": \".ds-logs-000001\" } }" :: Maybe ModifyDataStreamAction + case decoded of + Just (RemoveBackingIndex (DataStreamName "logs") _) -> pure () + other -> expectationFailure ("expected RemoveBackingIndex, got " <> show other) + + it "round-trips add_backing_index through ToJSON/FromJSON" $ do + let value = AddBackingIndex (DataStreamName "s") [qqIndexName|i|] + (decode . encode) value `shouldBe` Just value + + it "round-trips remove_backing_index through ToJSON/FromJSON" $ do + let value = RemoveBackingIndex (DataStreamName "s") [qqIndexName|i|] + (decode . encode) value `shouldBe` Just value + + it "encodes add_backing_index as a single-key object with nested target" $ do + let value = AddBackingIndex (DataStreamName "s") [qqIndexName|i|] + encode value `shouldBe` "{\"add_backing_index\":{\"data_stream\":\"s\",\"index\":\"i\"}}" + + it "encodes remove_backing_index as a single-key object with nested target" $ do + let value = RemoveBackingIndex (DataStreamName "s") [qqIndexName|i|] + encode value `shouldBe` "{\"remove_backing_index\":{\"data_stream\":\"s\",\"index\":\"i\"}}" + + it "decodes the verbatim ES docs add_backing_index target (dot-prefixed index name)" $ do + -- From the official curl example at + -- https://www.elastic.co/docs/api/doc/elasticsearch/operation/operation-indices-modify-data-stream + let decoded = decode "{ \"add_backing_index\": { \"data_stream\": \"my-data-stream\", \"index\": \".ds-my-data-stream-2023.07.26-000001-downsample\" } }" :: Maybe ModifyDataStreamAction + case decoded of + Just (AddBackingIndex (DataStreamName "my-data-stream") ix) + | unIndexName ix == ".ds-my-data-stream-2023.07.26-000001-downsample" -> pure () + other -> expectationFailure ("verbatim add_backing_index did not decode, got " <> show other) + + it "rejects an action with no discriminator key" $ do + let decoded = decode "{ \"data_stream\": \"s\", \"index\": \"i\" }" :: Maybe ModifyDataStreamAction + decoded `shouldBe` Nothing + + it "rejects a non-object action" $ do + let decoded = decode "[]" :: Maybe ModifyDataStreamAction + decoded `shouldBe` Nothing + + it "rejects an action whose target is missing 'index'" $ do + let decoded = decode "{ \"add_backing_index\": { \"data_stream\": \"s\" } }" :: Maybe ModifyDataStreamAction + decoded `shouldBe` Nothing + + it "rejects an action carrying both discriminator keys (server-side they are mutually exclusive)" $ do + let both = + decode + "{ \"add_backing_index\": { \"data_stream\": \"a\", \"index\": \"x\" }, \"remove_backing_index\": { \"data_stream\": \"r\", \"index\": \"y\" } }" :: + Maybe ModifyDataStreamAction + both `shouldBe` Nothing + + describe "ModifyDataStreamRequest JSON" $ do + it "decodes a request with multiple actions" $ do + let payload = + "{ \"actions\": [" + <> " { \"remove_backing_index\": { \"data_stream\": \"my-data-stream\", \"index\": \".ds-my-data-stream-2023.07.26-000001\" } }," + <> " { \"add_backing_index\": { \"data_stream\": \"my-data-stream\", \"index\": \".ds-my-data-stream-2023.07.26-000001-downsample\" } } ] }" + decoded = decode payload :: Maybe ModifyDataStreamRequest + length . modifyDataStreamActions <$> decoded `shouldBe` Just 2 + + it "decodes an empty actions array as the empty list" $ do + let decoded = decode "{ \"actions\": [] }" :: Maybe ModifyDataStreamRequest + (modifyDataStreamActions <$> decoded) `shouldBe` Just [] + + it "round-trips through ToJSON/FromJSON" $ do + let value = ModifyDataStreamRequest [AddBackingIndex (DataStreamName "s") [qqIndexName|i|]] + (decode . encode) value `shouldBe` Just value + + it "encodes the two-action example verbatim from the ES docs curl" $ do + -- The IndexName constructor is not exported, so build the request via + -- 'decode' of the verbatim docs payload (which goes through + -- mkIndexNameSystem and accepts the dot-prefixed backing-index names), + -- then assert that re-encoding reproduces the exact byte-for-byte body. + let payload = + "{ \"actions\": [" + <> " { \"remove_backing_index\": { \"data_stream\": \"my-data-stream\", \"index\": \".ds-my-data-stream-2023.07.26-000001\" } }," + <> " { \"add_backing_index\": { \"data_stream\": \"my-data-stream\", \"index\": \".ds-my-data-stream-2023.07.26-000001-downsample\" } } ] }" + Just value = decode payload :: Maybe ModifyDataStreamRequest + encode value + `shouldBe` "{\"actions\":[{\"remove_backing_index\":{\"data_stream\":\"my-data-stream\",\"index\":\".ds-my-data-stream-2023.07.26-000001\"}},{\"add_backing_index\":{\"data_stream\":\"my-data-stream\",\"index\":\".ds-my-data-stream-2023.07.26-000001-downsample\"}}]}" + + it "rejects a request missing the actions field" $ do + let decoded = decode "{}" :: Maybe ModifyDataStreamRequest + decoded `shouldBe` Nothing + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe ModifyDataStreamRequest + decoded `shouldBe` Nothing + + describe "modifyDataStream endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "POSTs /_data_stream/_modify with no stream name in the path" $ do + let req = ES7.modifyDataStream (ModifyDataStreamRequest [AddBackingIndex (DataStreamName "logs") [qqIndexName|logs-000001|]]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_modify"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the POST method" $ do + let req = ES7.modifyDataStream (ModifyDataStreamRequest [RemoveBackingIndex (DataStreamName "logs") [qqIndexName|logs-000001|]]) + bhRequestMethod req `shouldBe` "POST" + + it "sends the encoded ModifyDataStreamRequest as the body" $ do + let req = ES7.modifyDataStream (ModifyDataStreamRequest [AddBackingIndex (DataStreamName "logs") [qqIndexName|logs-000001|]]) + bhRequestBody req `shouldBe` Just "{\"actions\":[{\"add_backing_index\":{\"data_stream\":\"logs\",\"index\":\"logs-000001\"}}]}" + + it "sends a multi-action body when given multiple actions" $ do + let req = + ES7.modifyDataStream + ( ModifyDataStreamRequest + [ RemoveBackingIndex (DataStreamName "a") [qqIndexName|ds-a-000001|], + AddBackingIndex (DataStreamName "b") [qqIndexName|ds-b-000001|] + ] + ) + bhRequestBody req + `shouldBe` Just + "{\"actions\":[{\"remove_backing_index\":{\"data_stream\":\"a\",\"index\":\"ds-a-000001\"}},{\"add_backing_index\":{\"data_stream\":\"b\",\"index\":\"ds-b-000001\"}}]}" + + -- ============================================================ + -- dataStreamExists (HEAD /_data_stream/{name}) + -- ============================================================ + + describe "dataStreamExists endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "HEADs /_data_stream/{name} for the given data stream" $ do + let req = ES7.dataStreamExists (DataStreamName "logs-foobar") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "logs-foobar"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the HEAD method" $ do + let req = ES7.dataStreamExists (DataStreamName "logs-foobar") + bhRequestMethod req `shouldBe` "HEAD" + + it "does not attach a body (HEAD semantics)" $ do + let req = ES7.dataStreamExists (DataStreamName "logs-foobar") + bhRequestBody req `shouldBe` Nothing + + -- ============================================================ + -- PutDataStreamsLifecycleRequest (bulk PUT /_data_stream/_lifecycle) + -- ============================================================ + + describe "PutDataStreamsLifecycleRequest JSON" $ do + it "decodes a request with two lifecycle entries" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"a\", \"lifecycle\": { \"data_retention\": \"1d\" } }," + <> " { \"name\": \"b\", \"lifecycle\": { \"data_retention\": \"2d\" } } ] }" + Just decoded = decode payload :: Maybe PutDataStreamsLifecycleRequest + length (putDataStreamsLifecycleRequestStreams decoded) `shouldBe` 2 + + it "decodes an empty data_streams array" $ do + let decoded = decode "{ \"data_streams\": [] }" :: Maybe PutDataStreamsLifecycleRequest + (putDataStreamsLifecycleRequestStreams <$> decoded) `shouldBe` Just [] + + it "round-trips through ToJSON/FromJSON" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"a\", \"lifecycle\": { \"data_retention\": \"1d\" } } ] }" + Just decoded = decode payload :: Maybe PutDataStreamsLifecycleRequest + (decode . encode) decoded `shouldBe` Just decoded + + it "round-trips an entry whose lifecycle is Nothing (disables management)" $ do + let value = + PutDataStreamsLifecycleRequest + [DataStreamLifecycleInfo (DataStreamName "unmanaged") Nothing] + (decode . encode) value `shouldBe` Just value + + it "encodes as a {\"data_streams\":[...]} object" $ do + let value = + PutDataStreamsLifecycleRequest + [ DataStreamLifecycleInfo + (DataStreamName "ds") + (Just (DataStreamLifecycle (Just "7d") Nothing Nothing Nothing Nothing Nothing)) + ] + encode value + `shouldBe` "{\"data_streams\":[{\"lifecycle\":{\"data_retention\":\"7d\"},\"name\":\"ds\"}]}" + + it "encodes an empty request as {\"data_streams\":[]}" $ do + encode (PutDataStreamsLifecycleRequest []) `shouldBe` "{\"data_streams\":[]}" + + it "rejects a request missing the data_streams field" $ do + let decoded = decode "{}" :: Maybe PutDataStreamsLifecycleRequest + decoded `shouldBe` Nothing + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe PutDataStreamsLifecycleRequest + decoded `shouldBe` Nothing + + describe "putDataStreamsLifecycle endpoint shape" $ do + it "PUTs /_data_stream/_lifecycle for the bulk lifecycle update" $ do + let req = + ES8.putDataStreamsLifecycle + ( PutDataStreamsLifecycleRequest + [ DataStreamLifecycleInfo + (DataStreamName "logs-foobar") + (Just (DataStreamLifecycle (Just "7d") Nothing Nothing Nothing Nothing Nothing)) + ] + ) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_lifecycle"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the PUT method" $ do + let req = ES8.putDataStreamsLifecycle (PutDataStreamsLifecycleRequest []) + bhRequestMethod req `shouldBe` "PUT" + + it "sends the encoded PutDataStreamsLifecycleRequest as the body" $ do + let req = + ES8.putDataStreamsLifecycle + ( PutDataStreamsLifecycleRequest + [ DataStreamLifecycleInfo + (DataStreamName "ds") + (Just (DataStreamLifecycle (Just "7d") Nothing Nothing Nothing Nothing Nothing)) + ] + ) + bhRequestBody req `shouldBe` Just "{\"data_streams\":[{\"lifecycle\":{\"data_retention\":\"7d\"},\"name\":\"ds\"}]}" + + it "sends an empty data_streams array body when given no entries" $ do + let req = ES8.putDataStreamsLifecycle (PutDataStreamsLifecycleRequest []) + bhRequestBody req `shouldBe` Just "{\"data_streams\":[]}" + + -- ============================================================ + -- Data Stream Options (GET/PUT/DELETE /_data_stream/{name}/_options, ES 8.19+) + -- ============================================================ + + describe "DataStreamFailureStoreLifecycle JSON" $ do + it "decodes a fully-populated lifecycle" $ do + let decoded = decode "{ \"data_retention\": \"7d\", \"enabled\": true }" :: Maybe DataStreamFailureStoreLifecycle + decoded `shouldBe` Just (DataStreamFailureStoreLifecycle (Just "7d") (Just True)) + + it "decodes an empty object as all-Nothing" $ do + let decoded = decode "{}" :: Maybe DataStreamFailureStoreLifecycle + decoded `shouldBe` Just (DataStreamFailureStoreLifecycle Nothing Nothing) + + it "round-trips through ToJSON/FromJSON" $ do + let value = DataStreamFailureStoreLifecycle (Just "30d") (Just False) + (decode . encode) value `shouldBe` Just value + + it "encodes {} for the all-Nothing value (omitNulls)" $ do + encode (DataStreamFailureStoreLifecycle Nothing Nothing) `shouldBe` "{}" + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe DataStreamFailureStoreLifecycle + decoded `shouldBe` Nothing + + describe "DataStreamFailureStore JSON" $ do + it "decodes the verbatim ES docs example (enabled + lifecycle)" $ do + let decoded = decode "{ \"enabled\": true, \"lifecycle\": { \"data_retention\": \"string\", \"enabled\": true } }" :: Maybe DataStreamFailureStore + decoded + `shouldBe` Just + ( DataStreamFailureStore + (Just True) + (Just (DataStreamFailureStoreLifecycle (Just "string") (Just True))) + ) + + it "decodes a store with only `enabled` set" $ do + let decoded = decode "{ \"enabled\": false }" :: Maybe DataStreamFailureStore + decoded `shouldBe` Just (DataStreamFailureStore (Just False) Nothing) + + it "decodes an empty object as all-Nothing" $ do + let decoded = decode "{}" :: Maybe DataStreamFailureStore + decoded `shouldBe` Just (DataStreamFailureStore Nothing Nothing) + + it "round-trips through ToJSON/FromJSON" $ do + let value = + DataStreamFailureStore + (Just True) + (Just (DataStreamFailureStoreLifecycle (Just "7d") Nothing)) + (decode . encode) value `shouldBe` Just value + + it "encodes the verbatim ES docs curl --data body" $ do + let value = + DataStreamFailureStore + (Just True) + (Just (DataStreamFailureStoreLifecycle (Just "string") (Just True))) + encode value `shouldBe` "{\"enabled\":true,\"lifecycle\":{\"data_retention\":\"string\",\"enabled\":true}}" + + it "encodes {} for the all-Nothing value (omitNulls)" $ do + encode (DataStreamFailureStore Nothing Nothing) `shouldBe` "{}" + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe DataStreamFailureStore + decoded `shouldBe` Nothing + + describe "UpdateDataStreamOptionsRequest JSON" $ do + it "decodes a request with failure_store populated" $ do + let decoded = decode "{ \"failure_store\": { \"enabled\": true } }" :: Maybe UpdateDataStreamOptionsRequest + decoded + `shouldBe` Just + (UpdateDataStreamOptionsRequest (Just (DataStreamFailureStore (Just True) Nothing))) + + it "decodes a request with no failure_store key as Nothing" $ do + let decoded = decode "{}" :: Maybe UpdateDataStreamOptionsRequest + decoded `shouldBe` Just (UpdateDataStreamOptionsRequest Nothing) + + it "decodes a request with explicit null failure_store as Nothing" $ do + let decoded = decode "{ \"failure_store\": null }" :: Maybe UpdateDataStreamOptionsRequest + decoded `shouldBe` Just (UpdateDataStreamOptionsRequest Nothing) + + it "round-trips through ToJSON/FromJSON" $ do + let value = + UpdateDataStreamOptionsRequest + (Just (DataStreamFailureStore (Just False) Nothing)) + (decode . encode) value `shouldBe` Just value + + it "round-trips a Nothing failure_store through ToJSON/FromJSON" $ do + let value = UpdateDataStreamOptionsRequest Nothing + (decode . encode) value `shouldBe` Just value + + it "encodes the verbatim ES docs curl body (failure_store wrapping the docs example)" $ do + let value = + UpdateDataStreamOptionsRequest + ( Just + ( DataStreamFailureStore + (Just True) + (Just (DataStreamFailureStoreLifecycle (Just "string") (Just True))) + ) + ) + encode value `shouldBe` "{\"failure_store\":{\"enabled\":true,\"lifecycle\":{\"data_retention\":\"string\",\"enabled\":true}}}" + + it "encodes a Nothing failure_store as {} (omitNulls)" $ do + encode (UpdateDataStreamOptionsRequest Nothing) `shouldBe` "{}" + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe UpdateDataStreamOptionsRequest + decoded `shouldBe` Nothing + + describe "DataStreamOptions JSON" $ do + it "decodes an options object with failure_store" $ do + let decoded = decode "{ \"failure_store\": { \"enabled\": false } }" :: Maybe DataStreamOptions + decoded `shouldBe` Just (DataStreamOptions (Just (DataStreamFailureStore (Just False) Nothing))) + + it "decodes an empty object as all-Nothing" $ do + let decoded = decode "{}" :: Maybe DataStreamOptions + decoded `shouldBe` Just (DataStreamOptions Nothing) + + it "round-trips through ToJSON/FromJSON" $ do + let value = DataStreamOptions (Just (DataStreamFailureStore (Just True) Nothing)) + (decode . encode) value `shouldBe` Just value + + it "decodes an options object with unknown future keys (forward-compat)" $ do + -- The `options` object is open-ended on the server side; unknown keys + -- must decode without breaking the client. + let decoded = decode "{ \"failure_store\": { \"enabled\": true }, \"future_field\": 42 }" :: Maybe DataStreamOptions + decoded `shouldBe` Just (DataStreamOptions (Just (DataStreamFailureStore (Just True) Nothing))) + + describe "DataStreamOptionsEntry JSON" $ do + it "decodes an entry with options" $ do + let decoded = decode "{ \"name\": \"logs\", \"options\": { \"failure_store\": { \"enabled\": true } } }" :: Maybe DataStreamOptionsEntry + decoded + `shouldBe` Just + ( DataStreamOptionsEntry + (DataStreamName "logs") + (Just (DataStreamOptions (Just (DataStreamFailureStore (Just True) Nothing)))) + ) + + it "decodes an entry whose options key is absent (unmanaged stream)" $ do + let decoded = decode "{ \"name\": \"plain\" }" :: Maybe DataStreamOptionsEntry + decoded `shouldBe` Just (DataStreamOptionsEntry (DataStreamName "plain") Nothing) + + it "decodes an entry whose options key is explicitly null as Nothing" $ do + let decoded = decode "{ \"name\": \"plain\", \"options\": null }" :: Maybe DataStreamOptionsEntry + decoded `shouldBe` Just (DataStreamOptionsEntry (DataStreamName "plain") Nothing) + + it "round-trips an entry with options through ToJSON/FromJSON" $ do + let value = + DataStreamOptionsEntry + (DataStreamName "ds") + (Just (DataStreamOptions (Just (DataStreamFailureStore (Just True) Nothing)))) + (decode . encode) value `shouldBe` Just value + + it "round-trips an entry with no options through ToJSON/FromJSON" $ do + let value = DataStreamOptionsEntry (DataStreamName "ds") Nothing + (decode . encode) value `shouldBe` Just value + + it "rejects an entry missing the name field" $ do + let decoded = decode "{ \"options\": {} }" :: Maybe DataStreamOptionsEntry + decoded `shouldBe` Nothing + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe DataStreamOptionsEntry + decoded `shouldBe` Nothing + + describe "GetDataStreamOptionsResponse JSON" $ do + it "decodes a response with multiple entries" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"a\", \"options\": { \"failure_store\": { \"enabled\": true } } }," + <> " { \"name\": \"b\" } ] }" + decoded = decode payload :: Maybe GetDataStreamOptionsResponse + length . getDataStreamOptionsResponseDataStreams <$> decoded `shouldBe` Just 2 + + it "decodes an empty data_streams array" $ do + let decoded = decode "{ \"data_streams\": [] }" :: Maybe GetDataStreamOptionsResponse + (getDataStreamOptionsResponseDataStreams <$> decoded) `shouldBe` Just [] + + it "round-trips through ToJSON/FromJSON" $ do + let value = + GetDataStreamOptionsResponse + [ DataStreamOptionsEntry + (DataStreamName "ds") + (Just (DataStreamOptions (Just (DataStreamFailureStore (Just True) Nothing)))) + ] + (decode . encode) value `shouldBe` Just value + + it "rejects a response missing the data_streams field" $ do + let decoded = decode "{}" :: Maybe GetDataStreamOptionsResponse + decoded `shouldBe` Nothing + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe GetDataStreamOptionsResponse + decoded `shouldBe` Nothing + + describe "getDataStreamOptions endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "GETs /_data_stream/_options when given Nothing" $ do + let req = ES8.getDataStreamOptions Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_options"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/_options when given Just []" $ do + let req = ES8.getDataStreamOptions (Just []) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_options"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/{a,b,c}/_options for multiple names" $ do + let req = ES8.getDataStreamOptions (Just [DataStreamName "a", DataStreamName "b", DataStreamName "c"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "a,b,c", "_options"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/{name}/_options for a single name" $ do + let req = ES8.getDataStreamOptions (Just [DataStreamName "logs"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "logs", "_options"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the GET method" $ do + let req = ES8.getDataStreamOptions (Just [DataStreamName "logs"]) + bhRequestMethod req `shouldBe` "GET" + + it "does not attach a body (GET semantics)" $ do + let req = ES8.getDataStreamOptions Nothing + bhRequestBody req `shouldBe` Nothing + + describe "updateDataStreamOptions endpoint shape" $ do + it "PUTs /_data_stream/{name}/_options for a single name" $ do + let req = ES8.updateDataStreamOptions (Just [DataStreamName "logs"]) (UpdateDataStreamOptionsRequest Nothing) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "logs", "_options"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "PUTs /_data_stream/{a,b}/_options for multiple names" $ do + let req = ES8.updateDataStreamOptions (Just [DataStreamName "a", DataStreamName "b"]) (UpdateDataStreamOptionsRequest Nothing) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "a,b", "_options"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "PUTs /_data_stream/*/_options when given Nothing (server resolves wildcard)" $ do + let req = ES8.updateDataStreamOptions Nothing (UpdateDataStreamOptionsRequest Nothing) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "*", "_options"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "PUTs /_data_stream/*/_options when given Just [] (server resolves wildcard)" $ do + let req = ES8.updateDataStreamOptions (Just []) (UpdateDataStreamOptionsRequest Nothing) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "*", "_options"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the PUT method" $ do + let req = ES8.updateDataStreamOptions (Just [DataStreamName "logs"]) (UpdateDataStreamOptionsRequest Nothing) + bhRequestMethod req `shouldBe` "PUT" + + it "sends the encoded UpdateDataStreamOptionsRequest as the body" $ do + let req = + ES8.updateDataStreamOptions + (Just [DataStreamName "logs"]) + ( UpdateDataStreamOptionsRequest + (Just (DataStreamFailureStore (Just True) Nothing)) + ) + bhRequestBody req `shouldBe` Just "{\"failure_store\":{\"enabled\":true}}" + + it "sends {} as the body when failure_store is Nothing (omitNulls)" $ do + let req = ES8.updateDataStreamOptions (Just [DataStreamName "logs"]) (UpdateDataStreamOptionsRequest Nothing) + bhRequestBody req `shouldBe` Just "{}" + + describe "deleteDataStreamOptions endpoint shape" $ do + it "DELETEs /_data_stream/{name}/_options for a single name" $ do + let req = ES8.deleteDataStreamOptions (Just [DataStreamName "logs"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "logs", "_options"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "DELETEs /_data_stream/{a,b}/_options for multiple names" $ do + let req = ES8.deleteDataStreamOptions (Just [DataStreamName "a", DataStreamName "b"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "a,b", "_options"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "DELETEs /_data_stream/*/_options when given Nothing (server resolves wildcard)" $ do + let req = ES8.deleteDataStreamOptions Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "*", "_options"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "DELETEs /_data_stream/*/_options when given Just [] (server resolves wildcard)" $ do + let req = ES8.deleteDataStreamOptions (Just []) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "*", "_options"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the DELETE method" $ do + let req = ES8.deleteDataStreamOptions (Just [DataStreamName "logs"]) + bhRequestMethod req `shouldBe` "DELETE" + + it "does not attach a body (DELETE semantics)" $ do + let req = ES8.deleteDataStreamOptions (Just [DataStreamName "logs"]) + bhRequestBody req `shouldBe` Nothing + + -- ===================================================================== + -- GET /_lifecycle/stats (indices-get-data-lifecycle-stats) + -- ===================================================================== + + describe "getDataStreamLifecycleStats JSON" $ do + it "decodes the verbatim ES docs example with data_streams_count (plural)" $ do + let payload = + "{ \"last_run_duration_in_millis\": 2" + <> ", \"last_run_duration\": \"2ms\"" + <> ", \"time_between_starts_in_millis\": 9998" + <> ", \"time_between_starts\": \"9.99s\"" + <> ", \"data_streams_count\": 2" + <> ", \"data_streams\": [" + <> " { \"name\": \"my-data-stream\", \"backing_indices_in_total\": 2, \"backing_indices_in_error\": 0 }," + <> " { \"name\": \"my-other-stream\", \"backing_indices_in_total\": 2, \"backing_indices_in_error\": 1 } ] }" + Just decoded = decode payload :: Maybe DataStreamLifecycleStats + dataStreamLifecycleStatsCount decoded `shouldBe` 2 + dataStreamLifecycleStatsLastRunDurationInMillis decoded `shouldBe` Just 2 + dataStreamLifecycleStatsLastRunDuration decoded `shouldBe` Just "2ms" + dataStreamLifecycleStatsTimeBetweenStartsInMillis decoded `shouldBe` Just 9998 + dataStreamLifecycleStatsTimeBetweenStarts decoded `shouldBe` Just "9.99s" + length (dataStreamLifecycleStatsDataStreams decoded) `shouldBe` 2 + + it "also accepts data_stream_count (singular schema form)" $ do + let Just decoded = decode "{ \"data_stream_count\": 0, \"data_streams\": [] }" :: Maybe DataStreamLifecycleStats + dataStreamLifecycleStatsCount decoded `shouldBe` 0 + + it "rejects a payload missing both count keys" $ do + let decoded = decode "{ \"data_streams\": [] }" :: Maybe DataStreamLifecycleStats + decoded `shouldBe` Nothing + + it "decodes a per-stream entry" $ do + let Just decoded = decode "{ \"name\": \"ds\", \"backing_indices_in_total\": 5, \"backing_indices_in_error\": 2 }" :: Maybe DataStreamLifecycleStatsEntry + dataStreamLifecycleStatsEntryName decoded `shouldBe` DataStreamName "ds" + dataStreamLifecycleStatsEntryBackingIndicesInTotal decoded `shouldBe` 5 + dataStreamLifecycleStatsEntryBackingIndicesInError decoded `shouldBe` 2 + + it "round-trips a fully-populated stats response" $ do + let value = + DataStreamLifecycleStats + { dataStreamLifecycleStatsLastRunDurationInMillis = Just 2, + dataStreamLifecycleStatsLastRunDuration = Just "2ms", + dataStreamLifecycleStatsTimeBetweenStartsInMillis = Just 9998, + dataStreamLifecycleStatsTimeBetweenStarts = Just "9.99s", + dataStreamLifecycleStatsCount = 1, + dataStreamLifecycleStatsDataStreams = + [ DataStreamLifecycleStatsEntry (DataStreamName "ds") 2 0 + ] + } + (decode . encode) value `shouldBe` Just value + + it "encodes count as data_streams_count (plural, matching the docs example)" $ do + let value = + DataStreamLifecycleStats + { dataStreamLifecycleStatsLastRunDurationInMillis = Nothing, + dataStreamLifecycleStatsLastRunDuration = Nothing, + dataStreamLifecycleStatsTimeBetweenStartsInMillis = Nothing, + dataStreamLifecycleStatsTimeBetweenStarts = Nothing, + dataStreamLifecycleStatsCount = 0, + dataStreamLifecycleStatsDataStreams = [] + } + -- omitNulls drops the empty data_streams array (documented + -- behaviour — see "S6: omitNulls collapse of empty downsampling + -- list"); the count survives because 0 is not null. + encode value `shouldBe` "{\"data_streams_count\":0}" + + it "round-trips the empty case (omitNulls drops data_streams, FromJSON tolerates its absence)" $ do + let value = + DataStreamLifecycleStats + { dataStreamLifecycleStatsLastRunDurationInMillis = Nothing, + dataStreamLifecycleStatsLastRunDuration = Nothing, + dataStreamLifecycleStatsTimeBetweenStartsInMillis = Nothing, + dataStreamLifecycleStatsTimeBetweenStarts = Nothing, + dataStreamLifecycleStatsCount = 0, + dataStreamLifecycleStatsDataStreams = [] + } + -- encode drops data_streams, decode tolerates its absence (.!= []) + (decode . encode) value `shouldBe` Just value + + describe "getDataStreamLifecycleStats endpoint shape (ES8)" $ do + it "GETs /_lifecycle/stats" $ do + let req = ES8.getDataStreamLifecycleStats + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_lifecycle", "stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the GET method" $ do + let req = ES8.getDataStreamLifecycleStats + bhRequestMethod req `shouldBe` "GET" + + it "does not attach a body" $ do + let req = ES8.getDataStreamLifecycleStats + bhRequestBody req `shouldBe` Nothing + + describe "getDataStreamLifecycleStats endpoint shape (ES9 delegates to ES8)" $ do + it "GETs /_lifecycle/stats" $ do + let req = ES9.getDataStreamLifecycleStats + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_lifecycle", "stats"] + + -- ===================================================================== + -- GET /{index}/_lifecycle/explain (indices-explain-data-lifecycle) + -- ===================================================================== + + describe "explainDataStreamLifecycle JSON" $ do + it "decodes the verbatim ES docs example (single managed backing index)" $ do + let payload = + "{ \"indices\": {" + <> " \".ds-metrics-2023.03.22-000001\": {" + <> " \"index\": \".ds-metrics-2023.03.22-000001\"," + <> " \"managed_by_lifecycle\": true," + <> " \"index_creation_date_millis\": 1679475563571," + <> " \"time_since_index_creation\": \"843ms\"," + <> " \"rollover_date_millis\": 1679475564293," + <> " \"time_since_rollover\": \"121ms\"," + <> " \"lifecycle\": {}," + <> " \"generation_time\": \"121ms\" } } }" + Just decoded = decode payload :: Maybe ExplainDataStreamLifecycleResponse + M.size (explainDataStreamLifecycleResponseIndices decoded) `shouldBe` 1 + + it "decodes an entry with an error string" $ do + let payload = + "{ \"indices\": {" + <> " \".ds-broken-000001\": {" + <> " \"index\": \".ds-broken-000001\"," + <> " \"managed_by_lifecycle\": true," + <> " \"error\": \"something went wrong\" } } }" + Just decoded = decode payload :: Maybe ExplainDataStreamLifecycleResponse + let entry = (M.elems . explainDataStreamLifecycleResponseIndices) decoded + length entry `shouldBe` 1 + explainDataStreamLifecycleIndexError (head entry) `shouldBe` Just "something went wrong" + explainDataStreamLifecycleIndexManagedByLifecycle (head entry) `shouldBe` True + + it "round-trips a fully-populated entry" $ do + let value = + ExplainDataStreamLifecycleIndex + { explainDataStreamLifecycleIndexIndex = mkIdx ".ds-foo-000001", + explainDataStreamLifecycleIndexManagedByLifecycle = True, + explainDataStreamLifecycleIndexCreationDateMillis = Just 1679475563571, + explainDataStreamLifecycleIndexTimeSinceIndexCreation = Just "843ms", + explainDataStreamLifecycleIndexRolloverDateMillis = Just 1679475564293, + explainDataStreamLifecycleIndexTimeSinceRollover = Just "121ms", + explainDataStreamLifecycleIndexLifecycle = Nothing, + explainDataStreamLifecycleIndexGenerationTime = Just "121ms", + explainDataStreamLifecycleIndexError = Nothing + } + (decode . encode) value `shouldBe` Just value + + it "round-trips the top-level response with a Map" $ do + let key = mkIdx ".ds-foo-000001" + value = ExplainDataStreamLifecycleResponse (M.singleton key (minimalExplainEntry key)) + (decode . encode) value `shouldBe` Just value + + it "rejects a response missing the indices field" $ do + let decoded = decode "{}" :: Maybe ExplainDataStreamLifecycleResponse + decoded `shouldBe` Nothing + + describe "explainDataStreamLifecycle endpoint shape (ES8)" $ do + it "GETs /_lifecycle/explain when given Nothing" $ do + let req = ES8.explainDataStreamLifecycle Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_lifecycle", "explain"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_lifecycle/explain when given Just []" $ do + let req = ES8.explainDataStreamLifecycle (Just []) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_lifecycle", "explain"] + + it "GETs /{index}/_lifecycle/explain for a single index" $ do + let req = ES8.explainDataStreamLifecycle (Just [mkIdx ".ds-foo-000001"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` [".ds-foo-000001", "_lifecycle", "explain"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /{a,b}/_lifecycle/explain for multiple indices (comma-joined)" $ do + let req = ES8.explainDataStreamLifecycle (Just [mkIdx ".ds-a-000001", mkIdx ".ds-b-000001"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` [".ds-a-000001,.ds-b-000001", "_lifecycle", "explain"] + + it "does not attach a body" $ do + let req = ES8.explainDataStreamLifecycle Nothing + bhRequestBody req `shouldBe` Nothing + + it "emits include_defaults=true when set" $ do + let opts = defaultExplainDataStreamLifecycleOptions {explainDataStreamLifecycleOptionsIncludeDefaults = Just True} + req = ES8.explainDataStreamLifecycleWith (Just [mkIdx ".ds-foo-000001"]) opts + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("include_defaults", Just "true")] + + it "emits master_timeout when set" $ do + let opts = defaultExplainDataStreamLifecycleOptions {explainDataStreamLifecycleOptionsMasterTimeout = Just "30s"} + req = ES8.explainDataStreamLifecycleWith Nothing opts + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("master_timeout", Just "30s")] + + it "emits both params when both are set" $ do + let opts = + defaultExplainDataStreamLifecycleOptions + { explainDataStreamLifecycleOptionsIncludeDefaults = Just False, + explainDataStreamLifecycleOptionsMasterTimeout = Just "1m" + } + req = ES8.explainDataStreamLifecycleWith Nothing opts + sort (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sort [("include_defaults", Just "false"), ("master_timeout", Just "1m")] + + describe "explainDataStreamLifecycle endpoint shape (ES9 delegates to ES8)" $ do + it "GETs /_lifecycle/explain when given Nothing" $ do + let req = ES9.explainDataStreamLifecycle Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_lifecycle", "explain"] + + it "GETs /{index}/_lifecycle/explain for a single index" $ do + let req = ES9.explainDataStreamLifecycle (Just [mkIdx ".ds-foo-000001"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` [".ds-foo-000001", "_lifecycle", "explain"] + + -- ===================================================================== + -- GET/PUT /_data_stream/{name}/_mappings + -- (indices-get/put-data-stream-mappings) — ES9 only + -- ===================================================================== + + describe "getDataStreamMappings JSON" $ do + it "decodes the verbatim ES docs example" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"my-data-stream\"," + <> " \"mappings\": { \"properties\": { \"field1\": { \"type\": \"ip\" } } }," + <> " \"effective_mappings\": { \"properties\": { \"field1\": { \"type\": \"ip\" }, \"field2\": { \"type\": \"text\" } } } } ] }" + Just decoded = decode payload :: Maybe GetDataStreamMappingsResponse + length (getDataStreamMappingsResponseDataStreams decoded) `shouldBe` 1 + let entry = head (getDataStreamMappingsResponseDataStreams decoded) + getDataStreamMappingsEntryName entry `shouldBe` DataStreamName "my-data-stream" + + it "round-trips a fully-populated response" $ do + let value = + GetDataStreamMappingsResponse + [ GetDataStreamMappingsEntry + (DataStreamName "ds") + (object ["properties" .= object ["foo" .= object ["type" .= ("text" :: Text)]]]) + (object ["properties" .= object ["foo" .= object ["type" .= ("text" :: Text)]]]) + ] + (decode . encode) value `shouldBe` Just value + + it "rejects a response missing data_streams" $ do + let decoded = decode "{}" :: Maybe GetDataStreamMappingsResponse + decoded `shouldBe` Nothing + + describe "updateDataStreamMappings JSON" $ do + it "decodes a successful PUT response (applied_to_data_stream=true)" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"ds\"," + <> " \"applied_to_data_stream\": true," + <> " \"mappings\": { \"properties\": {} }," + <> " \"effective_mappings\": { \"properties\": {} } } ] }" + Just decoded = decode payload :: Maybe UpdateDataStreamMappingsResponse + let entry = head (updateDataStreamMappingsResponseDataStreams decoded) + updateDataStreamMappingsEntryAppliedToDataStream entry `shouldBe` True + updateDataStreamMappingsEntryError entry `shouldBe` Nothing + + it "decodes a failed PUT response (applied_to_data_stream=false) with error" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"ds\"," + <> " \"applied_to_data_stream\": false," + <> " \"error\": \"Cannot set setting X\" } ] }" + Just decoded = decode payload :: Maybe UpdateDataStreamMappingsResponse + let entry = head (updateDataStreamMappingsResponseDataStreams decoded) + updateDataStreamMappingsEntryAppliedToDataStream entry `shouldBe` False + updateDataStreamMappingsEntryError entry `shouldBe` Just "Cannot set setting X" + + it "tolerates missing mappings/effective_mappings (decode as empty objects)" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"ds\", \"applied_to_data_stream\": false, \"error\": \"x\" } ] }" + Just decoded = decode payload :: Maybe UpdateDataStreamMappingsResponse + let entry = head (updateDataStreamMappingsResponseDataStreams decoded) + updateDataStreamMappingsEntryMappings entry `shouldBe` object [] + + describe "getDataStreamMappings endpoint shape (ES9)" $ do + it "GETs /_data_stream/_mappings when given Nothing" $ do + let req = ES9.getDataStreamMappings Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_mappings"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/_mappings when given Just []" $ do + let req = ES9.getDataStreamMappings (Just []) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_mappings"] + + it "GETs /_data_stream/{a,b}/_mappings for multiple names" $ do + let req = ES9.getDataStreamMappings (Just [DataStreamName "a", DataStreamName "b"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "a,b", "_mappings"] + + it "emits master_timeout when set" $ do + let opts = defaultGetDataStreamMappingsOptions {getDataStreamMappingsOptionsMasterTimeout = Just "30s"} + req = ES9.getDataStreamMappingsWith (Just [DataStreamName "ds"]) opts + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("master_timeout", Just "30s")] + + describe "putDataStreamMappings endpoint shape (ES9)" $ do + it "PUTs /_data_stream/{name}/_mappings for a single name" $ do + let req = ES9.putDataStreamMappings (Just [DataStreamName "ds"]) (object ["properties" .= object []]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "ds", "_mappings"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "PUTs /_data_stream/*/_mappings when given Nothing (wildcard fan-out)" $ do + let req = ES9.putDataStreamMappings Nothing (object ["properties" .= object []]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "*", "_mappings"] + + it "PUTs /_data_stream/*/_mappings when given Just [] (wildcard fan-out)" $ do + let req = ES9.putDataStreamMappings (Just []) (object ["properties" .= object []]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "*", "_mappings"] + + it "uses the PUT method" $ do + let req = ES9.putDataStreamMappings (Just [DataStreamName "ds"]) (object []) + bhRequestMethod req `shouldBe` "PUT" + + it "encodes the mapping object as the body" $ do + let req = ES9.putDataStreamMappings (Just [DataStreamName "ds"]) (object ["properties" .= object ["foo" .= object ["type" .= ("text" :: Text)]]]) + bhRequestBody req `shouldBe` Just "{\"properties\":{\"foo\":{\"type\":\"text\"}}}" + + it "emits dry_run=true when set" $ do + let opts = defaultUpdateDataStreamMappingsOptions {updateDataStreamMappingsOptionsDryRun = Just True} + req = ES9.putDataStreamMappingsWith (Just [DataStreamName "ds"]) (object []) opts + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("dry_run", Just "true")] + + -- ===================================================================== + -- GET/PUT /_data_stream/{name}/_settings + -- (indices-get/put-data-stream-settings) — ES9 only + -- ===================================================================== + + describe "getDataStreamSettings JSON" $ do + it "decodes the verbatim ES docs example (numeric-as-string)" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"my-data-stream\"," + <> " \"settings\": { \"index\": { \"lifecycle\": { \"name\": \"policy\" }, \"number_of_shards\": \"11\" } }," + <> " \"effective_settings\": { \"index\": { \"lifecycle\": { \"name\": \"policy\" }, \"number_of_shards\": \"11\", \"number_of_replicas\": \"0\" } } } ] }" + Just decoded = decode payload :: Maybe GetDataStreamSettingsResponse + length (getDataStreamSettingsResponseDataStreams decoded) `shouldBe` 1 + + it "round-trips a fully-populated response" $ do + let value = + GetDataStreamSettingsResponse + [ GetDataStreamSettingsEntry + (DataStreamName "ds") + (object ["index" .= object ["number_of_shards" .= ("11" :: Text)]]) + (object ["index" .= object ["number_of_shards" .= ("11" :: Text)]]) + ] + (decode . encode) value `shouldBe` Just value + + describe "updateDataStreamSettings JSON" $ do + it "decodes a successful PUT response with index_settings_results" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"ds\"," + <> " \"applied_to_data_stream\": true," + <> " \"settings\": { \"index\": { \"number_of_shards\": \"11\" } }," + <> " \"effective_settings\": { \"index\": { \"number_of_shards\": \"11\" } }," + <> " \"index_settings_results\": {" + <> " \"applied_to_data_stream_only\": [\"index.number_of_shards\"]," + <> " \"applied_to_data_stream_and_backing_indices\": [\"index.lifecycle.name\"] } } ] }" + Just decoded = decode payload :: Maybe UpdateDataStreamSettingsResponse + let entry = head (updateDataStreamSettingsResponseDataStreams decoded) + updateDataStreamSettingsEntryAppliedToDataStream entry `shouldBe` True + let Just results = updateDataStreamSettingsEntryIndexSettingsResults entry + indexSettingsResultsAppliedToDataStreamOnly results `shouldBe` ["index.number_of_shards"] + indexSettingsResultsAppliedToDataStreamAndBackingIndices results `shouldBe` ["index.lifecycle.name"] + indexSettingsResultsErrors results `shouldBe` [] + + it "decodes a partial-failure response with per-index errors" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"ds\"," + <> " \"applied_to_data_stream\": true," + <> " \"settings\": {}, \"effective_settings\": {}," + <> " \"index_settings_results\": {" + <> " \"applied_to_data_stream_only\": []," + <> " \"applied_to_data_stream_and_backing_indices\": []," + <> " \"errors\": [ { \"index\": \".ds-ds-000001\", \"error\": \"blocked by FORBIDDEN/9\" } ] } } ] }" + Just decoded = decode payload :: Maybe UpdateDataStreamSettingsResponse + let entry = head (updateDataStreamSettingsResponseDataStreams decoded) + Just results = updateDataStreamSettingsEntryIndexSettingsResults entry + length (indexSettingsResultsErrors results) `shouldBe` 1 + indexSettingErrorIndex (head (indexSettingsResultsErrors results)) `shouldBe` ".ds-ds-000001" + + it "decodes a total-failure response (applied_to_data_stream=false)" $ do + let payload = + "{ \"data_streams\": [" + <> " { \"name\": \"ds\"," + <> " \"applied_to_data_stream\": false," + <> " \"error\": \"Cannot set the following settings\"," + <> " \"settings\": {}, \"effective_settings\": {}," + <> " \"index_settings_results\": { \"applied_to_data_stream_only\": [], \"applied_to_data_stream_and_backing_indices\": [] } } ] }" + Just decoded = decode payload :: Maybe UpdateDataStreamSettingsResponse + let entry = head (updateDataStreamSettingsResponseDataStreams decoded) + updateDataStreamSettingsEntryAppliedToDataStream entry `shouldBe` False + updateDataStreamSettingsEntryError entry `shouldBe` Just "Cannot set the following settings" + + it "round-trips an IndexSettingError" $ do + let value = IndexSettingError ".ds-ds-000001" "blocked" + (decode . encode) value `shouldBe` Just value + + describe "getDataStreamSettings endpoint shape (ES9)" $ do + it "GETs /_data_stream/_settings when given Nothing" $ do + let req = ES9.getDataStreamSettings Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "_settings"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_data_stream/{name}/_settings for a single name" $ do + let req = ES9.getDataStreamSettings (Just [DataStreamName "ds"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "ds", "_settings"] + + it "emits master_timeout when set" $ do + let opts = defaultGetDataStreamSettingsOptions {getDataStreamSettingsOptionsMasterTimeout = Just "1m"} + req = ES9.getDataStreamSettingsWith Nothing opts + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("master_timeout", Just "1m")] + + describe "putDataStreamSettings endpoint shape (ES9)" $ do + it "PUTs /_data_stream/{name}/_settings for a single name" $ do + let req = ES9.putDataStreamSettings (Just [DataStreamName "ds"]) (object ["index.lifecycle.name" .= ("policy" :: Text)]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "ds", "_settings"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "PUTs /_data_stream/*/_settings when given Nothing (wildcard fan-out)" $ do + let req = ES9.putDataStreamSettings Nothing (object []) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_data_stream", "*", "_settings"] + + it "uses the PUT method" $ do + let req = ES9.putDataStreamSettings (Just [DataStreamName "ds"]) (object []) + bhRequestMethod req `shouldBe` "PUT" + + it "encodes the settings object as the body" $ do + let req = ES9.putDataStreamSettings (Just [DataStreamName "ds"]) (object ["index.number_of_shards" .= (11 :: Int)]) + bhRequestBody req `shouldBe` Just "{\"index.number_of_shards\":11}" + + it "emits dry_run=false when set to False" $ do + let opts = defaultUpdateDataStreamSettingsOptions {updateDataStreamSettingsOptionsDryRun = Just False} + req = ES9.putDataStreamSettingsWith (Just [DataStreamName "ds"]) (object []) opts + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("dry_run", Just "false")] + + it "emits both dry_run and timeout when set" $ do + let opts = + defaultUpdateDataStreamSettingsOptions + { updateDataStreamSettingsOptionsDryRun = Just True, + updateDataStreamSettingsOptionsTimeout = Just "5s" + } + req = ES9.putDataStreamSettingsWith Nothing (object []) opts + sort (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sort [("dry_run", Just "true"), ("timeout", Just "5s")] diff --git a/tests/Test/DiskUsageSpec.hs b/tests/Test/DiskUsageSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/DiskUsageSpec.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Test.DiskUsageSpec (spec) where + +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as LBS +import Data.List (sort) +import Database.Bloodhound.Common.Types +import Optics (set, view) +import TestsUtils.Common +import TestsUtils.Import + +-- | Stable ordering for equality. +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + +-- | A trimmed but faithful slice of the documented response: @\"_shards\"@ +-- plus a single index key carrying store sizes, an @all_fields@ aggregate +-- and one per-field entry. +sampleResponseBytes :: LBS.ByteString +sampleResponseBytes = + "{\"_shards\":{\"total\":1,\"successful\":1,\"failed\":0},\ + \\"my-index-000001\":{\ + \\"store_size\":\"929mb\",\ + \\"store_size_in_bytes\":974192723,\ + \\"all_fields\":{\"total\":\"928.9mb\",\"total_in_bytes\":973977084,\ + \\"inverted_index\":{\"total\":\"107.8mb\",\"total_in_bytes\":113128526}},\ + \\"fields\":{\"_id\":{\"total\":\"49.3mb\",\"total_in_bytes\":51709993,\ + \\"doc_values\":\"0b\",\"doc_values_in_bytes\":0}}}}" + +spec :: Spec +spec = do + -- ------------------------------------------------------------------ -- + -- Pure JSON decoder tests (no ES required). -- + -- ------------------------------------------------------------------ -- + describe "DiskUsageResponse JSON parsing" $ do + it "peels _shards and keeps the rest as a per-index KeyMap" $ do + let Just (r :: DiskUsageResponse) = decode sampleResponseBytes + shardTotal (durShards r) `shouldBe` 1 + shardsSuccessful (durShards r) `shouldBe` 1 + case KM.lookup "my-index-000001" (durIndices r) of + Just ix -> do + duiStoreSize ix `shouldBe` Just "929mb" + duiStoreSizeInBytes ix `shouldBe` Just 974192723 + case duiAllFields ix of + Just af -> do + dufbTotal af `shouldBe` Just "928.9mb" + dufbTotalInBytes af `shouldBe` Just 973977084 + case dufbInvertedIndex af of + Just ii -> do + duiiTotal ii `shouldBe` Just "107.8mb" + duiiTotalInBytes ii `shouldBe` Just 113128526 + Nothing -> expectationFailure "expected inverted_index" + Nothing -> expectationFailure "expected all_fields" + case duiFields ix of + Just fields -> case KM.lookup "_id" fields of + Just fb -> do + dufbTotalInBytes fb `shouldBe` Just 51709993 + dufbDocValuesInBytes fb `shouldBe` Just 0 + Nothing -> expectationFailure "expected _id field" + Nothing -> expectationFailure "expected fields map" + Nothing -> expectationFailure "expected my-index-000001 entry" + + it "round-trips the documented response via ToJSON/FromJSON" $ do + let Just (original :: DiskUsageResponse) = decode sampleResponseBytes + reDecoded = decode (encode original) :: Maybe DiskUsageResponse + Just original `shouldBe` reDecoded + + it "tolerates a response with only _shards (empty index map)" $ do + let Just (r :: DiskUsageResponse) = + decode "{\"_shards\":{\"total\":0,\"successful\":0,\"failed\":0}}" + durIndices r `shouldBe` mempty + + describe "DiskUsageFieldBreakdown JSON parsing" $ do + let bare = "{\"total\":\"1b\",\"total_in_bytes\":1}" + it "parses a minimal breakdown (no structural components)" $ do + let Just (fb :: DiskUsageFieldBreakdown) = decode bare + dufbTotal fb `shouldBe` Just "1b" + dufbTotalInBytes fb `shouldBe` Just 1 + dufbInvertedIndex fb `shouldBe` Nothing + dufbStoredFieldsInBytes fb `shouldBe` Nothing + + it "round-trips via ToJSON/FromJSON" $ do + let Just (original :: DiskUsageFieldBreakdown) = decode bare + reDecoded = decode (encode original) :: Maybe DiskUsageFieldBreakdown + Just original `shouldBe` reDecoded + + -- ------------------------------------------------------------------ -- + -- Optics. -- + -- ------------------------------------------------------------------ -- + describe "DiskUsage lenses" $ do + it "duiStoreSizeInBytesLens is a lawful get/set" $ do + let ix = DiskUsageIndex {duiStoreSize = Nothing, duiStoreSizeInBytes = Nothing, duiAllFields = Nothing, duiFields = Nothing} + ix' = set duiStoreSizeInBytesLens (Just 42) ix + view duiStoreSizeInBytesLens ix' `shouldBe` Just 42 + + it "duoRunExpensiveTasksLens is a lawful get/set" $ do + let opts = set duoRunExpensiveTasksLens False defaultDiskUsageOptions + view duoRunExpensiveTasksLens opts `shouldBe` False + + -- ------------------------------------------------------------------ -- + -- Options rendering. -- + -- ------------------------------------------------------------------ -- + describe "DiskUsageOptions URI param rendering" $ do + it "defaultDiskUsageOptions emits only run_expensive_tasks=true" $ + diskUsageOptionsParams defaultDiskUsageOptions + `shouldBe` [("run_expensive_tasks", Just "true")] + + it "always renders run_expensive_tasks, even when False" $ do + let opts = defaultDiskUsageOptions {duoRunExpensiveTasks = False} + lookup "run_expensive_tasks" (diskUsageOptionsParams opts) + `shouldBe` Just (Just "false") + + it "renders the optional params when set" $ do + let opts = + defaultDiskUsageOptions + { duoFlush = Just False, + duoIgnoreUnavailable = Just True, + duoExpandWildcards = Just (ExpandWildcardsOpen :| []) + } + normalize (diskUsageOptionsParams opts) + `shouldBe` [ ("expand_wildcards", Just "open"), + ("flush", Just "false"), + ("ignore_unavailable", Just "true"), + ("run_expensive_tasks", Just "true") + ] + + -- ------------------------------------------------------------------ -- + -- Endpoint shape (BHRequest, no ES required). -- + -- ------------------------------------------------------------------ -- + describe "diskUsage endpoint shape" $ do + let idx = [qqIndexName|my-idx|] + + it "POSTs /{index}/_disk_usage with run_expensive_tasks=true by default" $ do + let req = diskUsage idx + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["my-idx", "_disk_usage"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("run_expensive_tasks", Just "true")] + + it "sends an empty body" $ do + let req = diskUsage idx + bhRequestBody req `shouldBe` Just "" + + it "forwards run_expensive_tasks=false via the With variant" $ do + let opts = defaultDiskUsageOptions {duoRunExpensiveTasks = False} + req = diskUsageWith opts idx + lookup "run_expensive_tasks" (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` Just (Just "false") diff --git a/tests/Test/DocumentOptionsSpec.hs b/tests/Test/DocumentOptionsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/DocumentOptionsSpec.hs @@ -0,0 +1,650 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.DocumentOptionsSpec (spec) where + +import Data.Aeson (Value (..), encode, object, (.=)) +import Data.List (sort) +import Data.Text qualified as T +import Database.Bloodhound.Common.Types +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +-- | Stable ordering for equality. The renderers preserve field-declaration +-- order but tests should compare the set of params, not the order. +normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] +normalize = sort + +-- | Boolean helpers rendered as @true@/@false@ strings. +boolTrue :: Maybe T.Text +boolTrue = Just "true" + +boolFalse :: Maybe T.Text +boolFalse = Just "false" + +spec :: Spec +spec = do + describe "GetDocumentOptions URI param rendering" $ do + it "defaultGetDocumentOptions emits no params" $ + getDocumentOptionsParams defaultGetDocumentOptions + `shouldBe` [] + + describe "_source" $ do + it "Just True renders as _source=true" $ do + let opts = defaultGetDocumentOptions {gdoSource = Just True} + getDocumentOptionsParams opts `shouldBe` [("_source", boolTrue)] + it "Just False renders as _source=false" $ do + let opts = defaultGetDocumentOptions {gdoSource = Just False} + getDocumentOptionsParams opts `shouldBe` [("_source", boolFalse)] + + it "_source_includes renders verbatim" $ do + let opts = defaultGetDocumentOptions {gdoSourceIncludes = Just "metadata.*,name"} + getDocumentOptionsParams opts + `shouldBe` [("_source_includes", Just "metadata.*,name")] + + it "_source_excludes renders verbatim" $ do + let opts = defaultGetDocumentOptions {gdoSourceExcludes = Just "internal.*"} + getDocumentOptionsParams opts + `shouldBe` [("_source_excludes", Just "internal.*")] + + it "stored_fields renders verbatim" $ do + let opts = defaultGetDocumentOptions {gdoStoredFields = Just "user,location"} + getDocumentOptionsParams opts + `shouldBe` [("stored_fields", Just "user,location")] + + it "preference renders verbatim" $ do + let opts = defaultGetDocumentOptions {gdoPreference = Just "_local"} + getDocumentOptionsParams opts + `shouldBe` [("preference", Just "_local")] + + describe "realtime" $ do + it "Just True renders as realtime=true" $ do + let opts = defaultGetDocumentOptions {gdoRealtime = Just True} + getDocumentOptionsParams opts `shouldBe` [("realtime", boolTrue)] + it "Just False renders as realtime=false" $ do + let opts = defaultGetDocumentOptions {gdoRealtime = Just False} + getDocumentOptionsParams opts `shouldBe` [("realtime", boolFalse)] + + describe "refresh" $ do + it "Just True renders as refresh=true" $ do + let opts = defaultGetDocumentOptions {gdoRefresh = Just True} + getDocumentOptionsParams opts `shouldBe` [("refresh", boolTrue)] + it "Just False renders as refresh=false" $ do + let opts = defaultGetDocumentOptions {gdoRefresh = Just False} + getDocumentOptionsParams opts `shouldBe` [("refresh", boolFalse)] + + it "routing renders verbatim" $ do + let opts = defaultGetDocumentOptions {gdoRouting = Just "user-42"} + getDocumentOptionsParams opts `shouldBe` [("routing", Just "user-42")] + + it "version renders the Word64 as a decimal string" $ do + let opts = defaultGetDocumentOptions {gdoVersion = Just 7} + getDocumentOptionsParams opts `shouldBe` [("version", Just "7")] + + describe "version_type" $ do + it "renders internal" $ do + let opts = defaultGetDocumentOptions {gdoVersionType = Just VersionTypeInternal} + getDocumentOptionsParams opts + `shouldBe` [("version_type", Just "internal")] + it "renders external_gte" $ do + let opts = defaultGetDocumentOptions {gdoVersionType = Just VersionTypeExternalGTE} + getDocumentOptionsParams opts + `shouldBe` [("version_type", Just "external_gte")] + + it "renders every field together when all are populated" $ do + let opts = + defaultGetDocumentOptions + { gdoSource = Just False, + gdoSourceIncludes = Just "a,b", + gdoSourceExcludes = Just "c", + gdoStoredFields = Just "s", + gdoPreference = Just "_local", + gdoRealtime = Just True, + gdoRefresh = Just False, + gdoRouting = Just "r", + gdoVersion = Just 9, + gdoVersionType = Just VersionTypeExternal + } + let rendered = getDocumentOptionsParams opts + length rendered `shouldBe` 10 + rendered `shouldSatisfy` all (isJust . snd) + normalize rendered + `shouldBe` sort + [ ("_source", Just "false"), + ("_source_excludes", Just "c"), + ("_source_includes", Just "a,b"), + ("preference", Just "_local"), + ("realtime", Just "true"), + ("refresh", Just "false"), + ("routing", Just "r"), + ("stored_fields", Just "s"), + ("version", Just "9"), + ("version_type", Just "external") + ] + + describe "GetDocumentSourceOptions URI param rendering" $ do + it "defaultGetDocumentSourceOptions emits no params" $ + getDocumentSourceOptionsParams defaultGetDocumentSourceOptions + `shouldBe` [] + + it "_source_includes renders verbatim" $ do + let opts = defaultGetDocumentSourceOptions {gdsoSourceIncludes = Just "metadata.*,name"} + getDocumentSourceOptionsParams opts + `shouldBe` [("_source_includes", Just "metadata.*,name")] + + it "_source_excludes renders verbatim" $ do + let opts = defaultGetDocumentSourceOptions {gdsoSourceExcludes = Just "internal.*"} + getDocumentSourceOptionsParams opts + `shouldBe` [("_source_excludes", Just "internal.*")] + + it "preference renders verbatim" $ do + let opts = defaultGetDocumentSourceOptions {gdsoPreference = Just "_local"} + getDocumentSourceOptionsParams opts + `shouldBe` [("preference", Just "_local")] + + describe "realtime" $ do + it "Just True renders as realtime=true" $ do + let opts = defaultGetDocumentSourceOptions {gdsoRealtime = Just True} + getDocumentSourceOptionsParams opts `shouldBe` [("realtime", boolTrue)] + it "Just False renders as realtime=false" $ do + let opts = defaultGetDocumentSourceOptions {gdsoRealtime = Just False} + getDocumentSourceOptionsParams opts `shouldBe` [("realtime", boolFalse)] + + describe "refresh" $ do + it "Just True renders as refresh=true" $ do + let opts = defaultGetDocumentSourceOptions {gdsoRefresh = Just True} + getDocumentSourceOptionsParams opts `shouldBe` [("refresh", boolTrue)] + it "Just False renders as refresh=false" $ do + let opts = defaultGetDocumentSourceOptions {gdsoRefresh = Just False} + getDocumentSourceOptionsParams opts `shouldBe` [("refresh", boolFalse)] + + it "routing renders verbatim" $ do + let opts = defaultGetDocumentSourceOptions {gdsoRouting = Just "user-42"} + getDocumentSourceOptionsParams opts `shouldBe` [("routing", Just "user-42")] + + it "version renders the Word64 as a decimal string" $ do + let opts = defaultGetDocumentSourceOptions {gdsoVersion = Just 7} + getDocumentSourceOptionsParams opts `shouldBe` [("version", Just "7")] + + describe "version_type" $ do + it "renders internal" $ do + let opts = defaultGetDocumentSourceOptions {gdsoVersionType = Just VersionTypeInternal} + getDocumentSourceOptionsParams opts + `shouldBe` [("version_type", Just "internal")] + it "renders external_gte" $ do + let opts = defaultGetDocumentSourceOptions {gdsoVersionType = Just VersionTypeExternalGTE} + getDocumentSourceOptionsParams opts + `shouldBe` [("version_type", Just "external_gte")] + + it "renders every field together when all are populated" $ do + let opts = + defaultGetDocumentSourceOptions + { gdsoSourceIncludes = Just "a,b", + gdsoSourceExcludes = Just "c", + gdsoPreference = Just "_local", + gdsoRealtime = Just True, + gdsoRefresh = Just False, + gdsoRouting = Just "r", + gdsoVersion = Just 9, + gdsoVersionType = Just VersionTypeExternal + } + let rendered = getDocumentSourceOptionsParams opts + length rendered `shouldBe` 8 + rendered `shouldSatisfy` all (isJust . snd) + normalize rendered + `shouldBe` sort + [ ("_source_excludes", Just "c"), + ("_source_includes", Just "a,b"), + ("preference", Just "_local"), + ("realtime", Just "true"), + ("refresh", Just "false"), + ("routing", Just "r"), + ("version", Just "9"), + ("version_type", Just "external") + ] + + describe "DeleteDocumentOptions URI param rendering" $ do + it "defaultDeleteDocumentOptions emits no params" $ + deleteDocumentOptionsParams defaultDeleteDocumentOptions + `shouldBe` [] + + describe "wait_for_active_shards" $ do + it "AllActiveShards renders as wait_for_active_shards=all" $ do + let opts = defaultDeleteDocumentOptions {ddoWaitForActiveShards = Just AllActiveShards} + deleteDocumentOptionsParams opts + `shouldBe` [("wait_for_active_shards", Just "all")] + it "ActiveShards n renders as wait_for_active_shards=" $ do + let opts = defaultDeleteDocumentOptions {ddoWaitForActiveShards = Just (ActiveShards 3)} + deleteDocumentOptionsParams opts + `shouldBe` [("wait_for_active_shards", Just "3")] + + describe "refresh" $ do + it "RefreshTrue renders as refresh=true" $ do + let opts = defaultDeleteDocumentOptions {ddoRefresh = Just RefreshTrue} + deleteDocumentOptionsParams opts `shouldBe` [("refresh", Just "true")] + it "RefreshFalse renders as refresh=false" $ do + let opts = defaultDeleteDocumentOptions {ddoRefresh = Just RefreshFalse} + deleteDocumentOptionsParams opts `shouldBe` [("refresh", Just "false")] + it "RefreshWaitFor renders as refresh=wait_for" $ do + let opts = defaultDeleteDocumentOptions {ddoRefresh = Just RefreshWaitFor} + deleteDocumentOptionsParams opts `shouldBe` [("refresh", Just "wait_for")] + + it "routing renders verbatim" $ do + let opts = defaultDeleteDocumentOptions {ddoRouting = Just "user-42"} + deleteDocumentOptionsParams opts `shouldBe` [("routing", Just "user-42")] + + it "timeout renders verbatim" $ do + let opts = defaultDeleteDocumentOptions {ddoTimeout = Just "5s"} + deleteDocumentOptionsParams opts `shouldBe` [("timeout", Just "5s")] + + it "version renders the Word64 as a decimal string" $ do + let opts = defaultDeleteDocumentOptions {ddoVersion = Just 7} + deleteDocumentOptionsParams opts `shouldBe` [("version", Just "7")] + + describe "version_type" $ do + it "renders internal" $ do + let opts = defaultDeleteDocumentOptions {ddoVersionType = Just VersionTypeInternal} + deleteDocumentOptionsParams opts + `shouldBe` [("version_type", Just "internal")] + it "renders external" $ do + let opts = defaultDeleteDocumentOptions {ddoVersionType = Just VersionTypeExternal} + deleteDocumentOptionsParams opts + `shouldBe` [("version_type", Just "external")] + it "renders external_gte" $ do + let opts = defaultDeleteDocumentOptions {ddoVersionType = Just VersionTypeExternalGTE} + deleteDocumentOptionsParams opts + `shouldBe` [("version_type", Just "external_gte")] + + describe "if_seq_no / if_primary_term" $ do + it "emits both when both are set" $ do + let opts = + defaultDeleteDocumentOptions + { ddoIfSeqNo = Just 7, + ddoIfPrimaryTerm = Just 2 + } + normalize (deleteDocumentOptionsParams opts) + `shouldBe` [ ("if_primary_term", Just "2"), + ("if_seq_no", Just "7") + ] + -- As with IndexDocumentSettings, each member of the OCC pair is + -- emitted independently: a half-set pair is passed through to + -- Elasticsearch's HTTP 400 rather than being silently dropped. + it "emits if_seq_no alone when only if_seq_no is set" $ do + let opts = defaultDeleteDocumentOptions {ddoIfSeqNo = Just 7} + deleteDocumentOptionsParams opts + `shouldBe` [("if_seq_no", Just "7")] + it "emits if_primary_term alone when only if_primary_term is set" $ do + let opts = defaultDeleteDocumentOptions {ddoIfPrimaryTerm = Just 2} + deleteDocumentOptionsParams opts + `shouldBe` [("if_primary_term", Just "2")] + + it "renders every field together when all are populated" $ do + let opts = + defaultDeleteDocumentOptions + { ddoWaitForActiveShards = Just AllActiveShards, + ddoRefresh = Just RefreshWaitFor, + ddoRouting = Just "r", + ddoTimeout = Just "5s", + ddoVersion = Just 9, + ddoVersionType = Just VersionTypeExternal, + ddoIfSeqNo = Just 10, + ddoIfPrimaryTerm = Just 1 + } + let rendered = deleteDocumentOptionsParams opts + length rendered `shouldBe` 8 + rendered `shouldSatisfy` all (isJust . snd) + normalize rendered + `shouldBe` sort + [ ("if_primary_term", Just "1"), + ("if_seq_no", Just "10"), + ("refresh", Just "wait_for"), + ("routing", Just "r"), + ("timeout", Just "5s"), + ("version", Just "9"), + ("version_type", Just "external"), + ("wait_for_active_shards", Just "all") + ] + + describe "DocumentExistsOptions URI param rendering" $ do + it "defaultDocumentExistsOptions emits no params" $ + documentExistsOptionsParams defaultDocumentExistsOptions + `shouldBe` [] + + it "stored_fields renders verbatim" $ do + let opts = defaultDocumentExistsOptions {deoStoredFields = Just "user,location"} + documentExistsOptionsParams opts + `shouldBe` [("stored_fields", Just "user,location")] + + it "preference renders verbatim" $ do + let opts = defaultDocumentExistsOptions {deoPreference = Just "_local"} + documentExistsOptionsParams opts + `shouldBe` [("preference", Just "_local")] + + describe "realtime" $ do + it "Just True renders as realtime=true" $ do + let opts = defaultDocumentExistsOptions {deoRealtime = Just True} + documentExistsOptionsParams opts `shouldBe` [("realtime", boolTrue)] + it "Just False renders as realtime=false" $ do + let opts = defaultDocumentExistsOptions {deoRealtime = Just False} + documentExistsOptionsParams opts `shouldBe` [("realtime", boolFalse)] + + describe "refresh" $ do + it "Just True renders as refresh=true" $ do + let opts = defaultDocumentExistsOptions {deoRefresh = Just True} + documentExistsOptionsParams opts `shouldBe` [("refresh", boolTrue)] + it "Just False renders as refresh=false" $ do + let opts = defaultDocumentExistsOptions {deoRefresh = Just False} + documentExistsOptionsParams opts `shouldBe` [("refresh", boolFalse)] + + it "routing renders verbatim" $ do + let opts = defaultDocumentExistsOptions {deoRouting = Just "user-42"} + documentExistsOptionsParams opts `shouldBe` [("routing", Just "user-42")] + + it "version renders the Word64 as a decimal string" $ do + let opts = defaultDocumentExistsOptions {deoVersion = Just 7} + documentExistsOptionsParams opts `shouldBe` [("version", Just "7")] + + describe "version_type" $ do + it "renders internal" $ do + let opts = defaultDocumentExistsOptions {deoVersionType = Just VersionTypeInternal} + documentExistsOptionsParams opts + `shouldBe` [("version_type", Just "internal")] + it "renders external" $ do + let opts = defaultDocumentExistsOptions {deoVersionType = Just VersionTypeExternal} + documentExistsOptionsParams opts + `shouldBe` [("version_type", Just "external")] + it "renders external_gte" $ do + let opts = defaultDocumentExistsOptions {deoVersionType = Just VersionTypeExternalGTE} + documentExistsOptionsParams opts + `shouldBe` [("version_type", Just "external_gte")] + + it "renders every field together when all are populated" $ do + let opts = + defaultDocumentExistsOptions + { deoStoredFields = Just "s", + deoPreference = Just "_local", + deoRealtime = Just True, + deoRefresh = Just False, + deoRouting = Just "r", + deoVersion = Just 9, + deoVersionType = Just VersionTypeExternal + } + let rendered = documentExistsOptionsParams opts + length rendered `shouldBe` 7 + rendered `shouldSatisfy` all (isJust . snd) + normalize rendered + `shouldBe` sort + [ ("preference", Just "_local"), + ("realtime", Just "true"), + ("refresh", Just "false"), + ("routing", Just "r"), + ("stored_fields", Just "s"), + ("version", Just "9"), + ("version_type", Just "external") + ] + + describe "DocumentSourceExistsOptions URI param rendering" $ do + it "defaultDocumentSourceExistsOptions emits no params" $ + documentSourceExistsParams defaultDocumentSourceExistsOptions + `shouldBe` [] + + it "preference renders verbatim" $ do + let opts = defaultDocumentSourceExistsOptions {dseoPreference = Just "_local"} + documentSourceExistsParams opts + `shouldBe` [("preference", Just "_local")] + + describe "realtime" $ do + it "Just True renders as realtime=true" $ do + let opts = defaultDocumentSourceExistsOptions {dseoRealtime = Just True} + documentSourceExistsParams opts `shouldBe` [("realtime", boolTrue)] + it "Just False renders as realtime=false" $ do + let opts = defaultDocumentSourceExistsOptions {dseoRealtime = Just False} + documentSourceExistsParams opts `shouldBe` [("realtime", boolFalse)] + + describe "refresh" $ do + it "Just True renders as refresh=true" $ do + let opts = defaultDocumentSourceExistsOptions {dseoRefresh = Just True} + documentSourceExistsParams opts `shouldBe` [("refresh", boolTrue)] + it "Just False renders as refresh=false" $ do + let opts = defaultDocumentSourceExistsOptions {dseoRefresh = Just False} + documentSourceExistsParams opts `shouldBe` [("refresh", boolFalse)] + + it "routing renders verbatim" $ do + let opts = defaultDocumentSourceExistsOptions {dseoRouting = Just "user-42"} + documentSourceExistsParams opts `shouldBe` [("routing", Just "user-42")] + + it "version renders the Word64 as a decimal string" $ do + let opts = defaultDocumentSourceExistsOptions {dseoVersion = Just 7} + documentSourceExistsParams opts `shouldBe` [("version", Just "7")] + + describe "version_type" $ do + it "renders internal" $ do + let opts = defaultDocumentSourceExistsOptions {dseoVersionType = Just VersionTypeInternal} + documentSourceExistsParams opts + `shouldBe` [("version_type", Just "internal")] + it "renders external_gte" $ do + let opts = defaultDocumentSourceExistsOptions {dseoVersionType = Just VersionTypeExternalGTE} + documentSourceExistsParams opts + `shouldBe` [("version_type", Just "external_gte")] + + it "renders every field together when all are populated" $ do + let opts = + defaultDocumentSourceExistsOptions + { dseoPreference = Just "_local", + dseoRealtime = Just True, + dseoRefresh = Just False, + dseoRouting = Just "r", + dseoVersion = Just 9, + dseoVersionType = Just VersionTypeExternal + } + let rendered = documentSourceExistsParams opts + length rendered `shouldBe` 6 + rendered `shouldSatisfy` all (isJust . snd) + normalize rendered + `shouldBe` sort + [ ("preference", Just "_local"), + ("realtime", Just "true"), + ("refresh", Just "false"), + ("routing", Just "r"), + ("version", Just "9"), + ("version_type", Just "external") + ] + + describe "ByQueryOptions URI param rendering" $ do + it "defaultByQueryOptions emits no params" $ + byQueryOptionsParams defaultByQueryOptions + `shouldBe` [] + + describe "conflicts" $ do + it "ConflictsProceed renders as conflicts=proceed" $ do + let opts = defaultByQueryOptions {bqoConflicts = Just ConflictsProceed} + byQueryOptionsParams opts `shouldBe` [("conflicts", Just "proceed")] + it "ConflictsAbort renders as conflicts=abort" $ do + let opts = defaultByQueryOptions {bqoConflicts = Just ConflictsAbort} + byQueryOptionsParams opts `shouldBe` [("conflicts", Just "abort")] + + describe "wait_for_completion" $ do + it "Just True renders as wait_for_completion=true" $ do + let opts = defaultByQueryOptions {bqoWaitForCompletion = Just True} + byQueryOptionsParams opts `shouldBe` [("wait_for_completion", boolTrue)] + it "Just False renders as wait_for_completion=false" $ do + let opts = defaultByQueryOptions {bqoWaitForCompletion = Just False} + byQueryOptionsParams opts `shouldBe` [("wait_for_completion", boolFalse)] + + it "refresh renders via RefreshPolicy" $ do + let opts = defaultByQueryOptions {bqoRefresh = Just RefreshTrue} + byQueryOptionsParams opts `shouldBe` [("refresh", Just "true")] + + it "timeout renders verbatim" $ do + let opts = defaultByQueryOptions {bqoTimeout = Just "5s"} + byQueryOptionsParams opts `shouldBe` [("timeout", Just "5s")] + + it "scroll renders verbatim" $ do + let opts = defaultByQueryOptions {bqoScroll = Just "1m"} + byQueryOptionsParams opts `shouldBe` [("scroll", Just "1m")] + + it "scroll_size renders as decimal" $ do + let opts = defaultByQueryOptions {bqoScrollSize = Just 500} + byQueryOptionsParams opts `shouldBe` [("scroll_size", Just "500")] + + describe "slices" $ do + it "SlicesAuto renders as slices=auto" $ do + let opts = defaultByQueryOptions {bqoSlices = Just SlicesAuto} + byQueryOptionsParams opts `shouldBe` [("slices", Just "auto")] + it "SlicesCount n renders as slices=" $ do + let opts = defaultByQueryOptions {bqoSlices = Just (SlicesCount 4)} + byQueryOptionsParams opts `shouldBe` [("slices", Just "4")] + + it "routing renders verbatim" $ do + let opts = defaultByQueryOptions {bqoRouting = Just "user-1"} + byQueryOptionsParams opts `shouldBe` [("routing", Just "user-1")] + + it "max_docs renders as decimal" $ do + let opts = defaultByQueryOptions {bqoMaxDocs = Just 100} + byQueryOptionsParams opts `shouldBe` [("max_docs", Just "100")] + + describe "request_cache" $ do + it "Just True renders as request_cache=true" $ do + let opts = defaultByQueryOptions {bqoRequestCache = Just True} + byQueryOptionsParams opts `shouldBe` [("request_cache", boolTrue)] + it "Just False renders as request_cache=false" $ do + let opts = defaultByQueryOptions {bqoRequestCache = Just False} + byQueryOptionsParams opts `shouldBe` [("request_cache", boolFalse)] + + it "pipeline renders verbatim" $ do + let opts = defaultByQueryOptions {bqoPipeline = Just "my-pipe"} + byQueryOptionsParams opts `shouldBe` [("pipeline", Just "my-pipe")] + + it "renders every field together when all are populated" $ do + let opts = + defaultByQueryOptions + { bqoConflicts = Just ConflictsProceed, + bqoWaitForCompletion = Just True, + bqoRefresh = Just RefreshWaitFor, + bqoTimeout = Just "5s", + bqoScroll = Just "1m", + bqoScrollSize = Just 100, + bqoSlices = Just (SlicesCount 3), + bqoRouting = Just "r", + bqoMaxDocs = Just 50, + bqoRequestCache = Just False, + bqoPipeline = Just "p" + } + let rendered = byQueryOptionsParams opts + length rendered `shouldBe` 11 + rendered `shouldSatisfy` all (isJust . snd) + normalize rendered + `shouldBe` sort + [ ("conflicts", Just "proceed"), + ("max_docs", Just "50"), + ("pipeline", Just "p"), + ("refresh", Just "wait_for"), + ("request_cache", Just "false"), + ("routing", Just "r"), + ("scroll", Just "1m"), + ("scroll_size", Just "100"), + ("slices", Just "3"), + ("timeout", Just "5s"), + ("wait_for_completion", Just "true") + ] + + describe "UpdateBody JSON encoding" $ do + describe "UpdateDoc" $ do + it "encodes as {\"doc\": ...} with no extras" $ do + let body = mkUpdateDoc (object ["counter" .= (1 :: Int)]) + encode body + `shouldBe` encode (object ["doc" .= object ["counter" .= (1 :: Int)]]) + it "includes doc_as_upsert when set to Just True" $ do + let body = + UpdateDoc + { ubDoc = object ["name" .= String "x"], + ubDocAsUpsert = Just True + } + encode body + `shouldBe` encode + ( object + [ "doc" .= object ["name" .= String "x"], + "doc_as_upsert" .= Bool True + ] + ) + it "omits doc_as_upsert when Nothing" $ do + let body = mkUpdateDoc (object ["name" .= String "x"]) + encode body + `shouldBe` encode (object ["doc" .= object ["name" .= String "x"]]) + it "omits doc_as_upsert when Just False is NOT set — Nothing is the only omit" $ + -- doc_as_upsert=Just False is a real value the caller might want to + -- send; we should NOT collapse it. The omission is only for Nothing. + do + let body = + UpdateDoc + { ubDoc = object ["name" .= String "x"], + ubDocAsUpsert = Just False + } + encode body + `shouldBe` encode + ( object + [ "doc" .= object ["name" .= String "x"], + "doc_as_upsert" .= Bool False + ] + ) + + describe "UpdateScript" $ do + it "encodes the script as a top-level \"script\" key without double-wrapping" $ do + let script = + Script + { scriptLanguage = Just (ScriptLanguage "painless"), + scriptSource = ScriptInline "ctx._source.counter += 1", + scriptParams = Nothing, + scriptOptions = Nothing + } + body = mkUpdateScript script + encode body + `shouldBe` encode + ( object + [ "script" + .= object + [ "lang" .= String "painless", + "source" .= String "ctx._source.counter += 1" + ] + ] + ) + it "includes upsert when set" $ do + let script = + Script Nothing (ScriptInline "ctx._source.x = 1") Nothing Nothing + body = + UpdateScript + { ubScript = script, + ubUpsert = Just (object ["x" .= (0 :: Int)]), + ubScriptedUpsert = Nothing + } + encode body + `shouldBe` encode + ( object + [ "script" .= object ["source" .= String "ctx._source.x = 1"], + "upsert" .= object ["x" .= (0 :: Int)] + ] + ) + it "includes scripted_upsert when set to Just True" $ do + let script = + Script Nothing (ScriptInline "ctx._source.x = 1") Nothing Nothing + body = + UpdateScript + { ubScript = script, + ubUpsert = Nothing, + ubScriptedUpsert = Just True + } + encode body + `shouldBe` encode + ( object + [ "script" .= object ["source" .= String "ctx._source.x = 1"], + "scripted_upsert" .= Bool True + ] + ) + it "uses 'id' (not 'source') for stored scripts" $ do + let script = + Script Nothing (ScriptId "my-stored-script") Nothing Nothing + body = mkUpdateScript script + encode body + `shouldBe` encode + (object ["script" .= object ["id" .= String "my-stored-script"]]) + where + isJust (Just _) = True + isJust Nothing = False diff --git a/tests/Test/DocumentsSpec.hs b/tests/Test/DocumentsSpec.hs --- a/tests/Test/DocumentsSpec.hs +++ b/tests/Test/DocumentsSpec.hs @@ -1,7 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Test.DocumentsSpec where +import Control.Concurrent (threadDelay) +import Data.List (isInfixOf) +import Data.Word (Word64) +import Numeric.Natural import TestsUtils.Common import TestsUtils.Import @@ -28,27 +33,32 @@ it "can use optimistic concurrency control" $ withTestEnv $ do - let ev = ExternalDocVersion minBound - let cfg = defaultIndexDocumentSettings {idsVersionControl = ExternalGT ev} + -- ExternalGTE only conflicts when the supplied version is + -- strictly lower than the stored one (@external_gt@, which + -- conflicted on equality, was removed in bloodhound-41e), so + -- seed the doc with a higher version then re-index a stale + -- (lower) one to trigger the 409. + let cfg = defaultIndexDocumentSettings {idsVersionControl = ExternalGTE (ExternalDocVersion (succ minBound))} + let cfgStale = defaultIndexDocumentSettings {idsVersionControl = ExternalGTE (ExternalDocVersion minBound)} resetIndex (res, _) <- insertData' cfg liftIO $ isCreated res `shouldBe` True - insertedConflict <- tryEsError $ insertData' cfg + insertedConflict <- tryEsError $ insertData' cfgStale case insertedConflict of Right (res', _) -> liftIO $ isVersionConflict res' `shouldBe` True Left e -> liftIO $ errorStatus e `shouldBe` Just 409 it "can use predicates on the response" $ withTestEnv $ do - let ev = ExternalDocVersion minBound - let cfg = defaultIndexDocumentSettings {idsVersionControl = ExternalGT ev} + let cfg = defaultIndexDocumentSettings {idsVersionControl = ExternalGTE (ExternalDocVersion (succ minBound))} + let cfgStale = defaultIndexDocumentSettings {idsVersionControl = ExternalGTE (ExternalDocVersion minBound)} resetIndex (res, _) <- insertData' cfg liftIO $ isCreated res `shouldBe` True liftIO $ isSuccess res `shouldBe` True liftIO $ isVersionConflict res `shouldBe` False - res' <- insertData'' cfg + res' <- insertData'' cfgStale liftIO $ isCreated res' `shouldBe` False liftIO $ isSuccess res' `shouldBe` False liftIO $ isVersionConflict res' `shouldBe` True @@ -70,7 +80,8 @@ let search = mkSearch (Just query) Nothing response <- performBHRequest $ searchByIndex @Value testIndex search - liftIO $ hitsTotal (searchHits response) `shouldBe` HitsTotal 1 HTR_EQ + liftIO $ + hitsTotal (searchHits response) `shouldBe` Just (HitsTotal 1 HTR_EQ) it "updates documents by query" $ withTestEnv $ do _ <- insertData @@ -82,6 +93,7 @@ (Just (ScriptLanguage "painless")) (ScriptInline "ctx._source.age *= 2") Nothing + Nothing _ <- performBHRequest $ updateByQuery @Value testIndex query (Just script) _ <- performBHRequest $ refreshIndex testIndex let search = mkSearch (Just query) Nothing @@ -94,3 +106,532 @@ map (fmap age . hitSource) (hits (searchHits sr)) liftIO $ results `shouldBe` [Just $ age exampleTweet * 2, Just $ age tweetWithExtra * 2] + + describe "IndexDocumentSettings URI params" $ do + it "op_type=create succeeds when the document does not exist yet" $ + withTestEnv $ do + resetIndex + let cfg = defaultIndexDocumentSettings {idsOpType = Just OpCreate} + res <- performBHRequest $ indexDocument testIndex cfg exampleTweet (DocId "op-create-1") + liftIO $ idxDocResult res `shouldBe` "created" + + it "op_type=create yields a 409 version-conflict on an existing doc" $ + withTestEnv $ do + resetIndex + let cfg = defaultIndexDocumentSettings {idsOpType = Just OpCreate} + _ <- performBHRequest $ indexDocument testIndex cfg exampleTweet (DocId "op-create-2") + secondAttempt <- tryEsError $ dispatch $ indexDocument testIndex cfg exampleTweet (DocId "op-create-2") + case secondAttempt of + Right resp -> + liftIO $ isVersionConflict resp `shouldBe` True + Left e -> + liftIO $ errorStatus e `shouldBe` Just 409 + + it "refresh=wait_for makes the doc searchable without an explicit refresh" $ + withTestEnv $ do + resetIndex + let cfg = defaultIndexDocumentSettings {idsRefresh = Just RefreshWaitFor} + _ <- performBHRequest $ indexDocument testIndex cfg exampleTweet (DocId "wait-for-1") + -- No refreshIndex call here — RefreshWaitFor should make the doc + -- visible to the search below. + let search = mkSearch (Just (TermQuery (Term "user" "bitemyapp") Nothing)) Nothing + result <- searchTweets search + case result of + Left e -> + liftIO $ expectationFailure ("Search failed after refresh=wait_for: " <> show e) + Right sr -> + liftIO $ hitsTotal (searchHits sr) `shouldBe` Just (HitsTotal 1 HTR_EQ) + + it "wait_for_active_shards=all succeeds on a single-shard index" $ + withTestEnv $ do + resetIndex + let cfg = + defaultIndexDocumentSettings + { idsWaitForActiveShards = Just AllActiveShards + } + res <- performBHRequest $ indexDocument testIndex cfg exampleTweet (DocId "wfas-1") + liftIO $ idxDocResult res `shouldBe` "created" + + it "if_seq_no/if_primary_term rejects a stale sequence number with 409" $ + withTestEnv $ do + resetIndex + -- First write succeeds and gives us the current seq_no/primary_term. + let createCfg = defaultIndexDocumentSettings {idsOpType = Just OpCreate} + first' <- performBHRequest $ indexDocument testIndex createCfg exampleTweet (DocId "seqno-1") + -- Now attempt a second write with a deliberately stale seq_no + -- (offset by +1 from the actual one); the server must reject + -- the write with HTTP 409. + let staleSeqNo = fromIntegral (idxDocSeqNo first') + 1 + staleTerm = fromIntegral (idxDocPrimaryTerm first') + staleCfg = + defaultIndexDocumentSettings + { idsIfSeqNo = Just staleSeqNo, + idsIfPrimaryTerm = Just staleTerm + } + conflict <- tryEsError $ dispatch $ indexDocument testIndex staleCfg exampleTweet (DocId "seqno-1") + case conflict of + Right resp -> + liftIO $ isVersionConflict resp `shouldBe` True + Left e -> + liftIO $ errorStatus e `shouldBe` Just 409 + + it "if_seq_no/if_primary_term accepts the current sequence number" $ + withTestEnv $ do + resetIndex + let createCfg = defaultIndexDocumentSettings {idsOpType = Just OpCreate} + first' <- performBHRequest $ indexDocument testIndex createCfg exampleTweet (DocId "seqno-2") + let currSeqNo = fromIntegral (idxDocSeqNo first') + currTerm = fromIntegral (idxDocPrimaryTerm first') + matchingCfg = + defaultIndexDocumentSettings + { idsIfSeqNo = Just currSeqNo, + idsIfPrimaryTerm = Just currTerm + } + res <- performBHRequest $ indexDocument testIndex matchingCfg exampleTweet (DocId "seqno-2") + liftIO $ idxDocResult res `shouldBe` "updated" + + it "if_seq_no without if_primary_term is rejected by the server (not silently dropped)" $ + withTestEnv $ do + resetIndex + let halfSetCfg = defaultIndexDocumentSettings {idsIfSeqNo = Just 0} + result <- tryEsError $ dispatch $ indexDocument testIndex halfSetCfg exampleTweet (DocId "seqno-half") + case result of + Right resp -> + -- Server should reject the half-set request rather than + -- silently indexing without OCC. + liftIO $ isSuccess resp `shouldBe` False + Left e -> + liftIO $ errorStatus e `shouldBe` Just 400 + + describe "GetDocumentOptions URI params" $ do + it "_source=false returns a found document with no source" $ + withTestEnv $ do + _ <- insertData + let opts = defaultGetDocumentOptions {gdoSource = Just False} + result <- performBHRequest $ getDocumentWith @Tweet opts testIndex (DocId "1") + -- With _source=false, ES omits the _source key. The parser + -- therefore cannot build an EsResultFound, so foundResult is + -- Nothing even though the document exists (HTTP 200, _id set). + liftIO $ getSource result `shouldBe` Nothing + + it "_source=true preserves the full source (byte-identical to default)" $ + withTestEnv $ do + _ <- insertData + let opts = defaultGetDocumentOptions {gdoSource = Just True} + result <- performBHRequest $ getDocumentWith @Tweet opts testIndex (DocId "1") + liftIO $ getSource result `shouldBe` Just exampleTweet + + it "defaultGetDocumentOptions matches the parameterless getDocument" $ + withTestEnv $ do + _ <- insertData + withOpts <- performBHRequest $ getDocumentWith @Tweet defaultGetDocumentOptions testIndex (DocId "1") + withoutOpts <- performBHRequest $ getDocument @Tweet testIndex (DocId "1") + liftIO $ getSource withOpts `shouldBe` getSource withoutOpts + + it "routing param targets a routed document" $ + withTestEnv $ do + resetIndex + let routed = defaultIndexDocumentSettings {idsJoinRelation = Just (ParentDocument (FieldName "reply_join") (RelationName "message"))} + _ <- performBHRequest $ putMapping @Value testIndex ConversationMapping + _ <- performBHRequest $ indexDocument testIndex routed exampleTweet (DocId "rt-1") + -- Without routing, the GET would miss the shard; with the + -- matching routing it must find the document. + let opts = defaultGetDocumentOptions {gdoRouting = Just "rt-1"} + result <- performBHRequest $ getDocumentWith @Tweet opts testIndex (DocId "rt-1") + liftIO $ foundResult result `shouldSatisfy` isJust + -- bloodhound-65e: the parsed EsResultFound must surface the + -- _routing the document was indexed with, so callers can feed + -- it back into follow-up writes on the same shard. + let Just found = foundResult result + liftIO $ _routing found `shouldBe` Just "rt-1" + + it "surfaces _seq_no and _primary_term on a fresh GET (65e)" $ + withTestEnv $ do + (_, doc) <- insertData' defaultIndexDocumentSettings + result <- performBHRequest $ getDocument @Tweet testIndex (DocId "1") + let Just found = foundResult result + liftIO $ do + -- _seq_no / _primary_term must round-trip from the + -- IndexedDocument write response to the GET response so + -- callers can use them for if_seq_no / if_primary_term. + _seq_no found `shouldBe` Just (idxDocSeqNo doc) + _primary_term found `shouldBe` Just (idxDocPrimaryTerm doc) + + describe "getDocumentSource (GET /{index}/_source/{id})" $ do + it "returns the source of an existing document as Just" $ + withTestEnv $ do + _ <- insertData + source <- performBHRequest $ getDocumentSource @Tweet testIndex (DocId "1") + liftIO $ source `shouldBe` Just exampleTweet + + it "returns Nothing for a missing document" $ + withTestEnv $ do + _ <- insertData + -- The source-only endpoint responds with HTTP 404 (no + -- {\"found\": false} envelope) when the document does not + -- exist. The custom parser must therefore surface + -- 'Nothing' rather than throw an EsError. + source <- performBHRequest $ getDocumentSource @Tweet testIndex (DocId "bogus") + liftIO $ source `shouldBe` Nothing + + it "404 surfaces as Right Nothing through tryPerformBHRequest" $ + withTestEnv $ do + _ <- insertData + parsed <- tryPerformBHRequest $ getDocumentSource @Tweet testIndex (DocId "bogus") + liftIO $ parsed `shouldBe` Right (Nothing :: Maybe Tweet) + + it "defaultGetDocumentSourceOptions matches the parameterless getDocumentSource" $ + withTestEnv $ do + _ <- insertData + withOpts <- performBHRequest $ getDocumentSourceWith @Tweet defaultGetDocumentSourceOptions testIndex (DocId "1") + withoutOpts <- performBHRequest $ getDocumentSource @Tweet testIndex (DocId "1") + liftIO $ withOpts `shouldBe` withoutOpts + + it "_source_includes filters the returned source fields" $ + withTestEnv $ do + _ <- insertData + -- Parse as Value so we can inspect the partial source + -- without requiring every Tweet field to be present + -- (deriveJSON defaultOptions would otherwise reject a + -- source missing the @age@, @message@, etc. fields). + let opts = defaultGetDocumentSourceOptions {gdsoSourceIncludes = Just "user"} + source <- performBHRequest $ getDocumentSourceWith @Value opts testIndex (DocId "1") + liftIO $ source `shouldSatisfy` isJust + case source of + Just v -> + liftIO $ do + show v `shouldSatisfy` isInfixOf "\"user\"" + -- With _source_includes=user, the server returns a + -- source object containing only the "user" field. + show v `shouldSatisfy` not . isInfixOf "\"age\"" + show v `shouldSatisfy` not . isInfixOf "\"message\"" + Nothing -> + liftIO $ expectationFailure "expected a source" + + it "routing param targets a routed document" $ + withTestEnv $ do + resetIndex + let routed = defaultIndexDocumentSettings {idsJoinRelation = Just (ParentDocument (FieldName "reply_join") (RelationName "message"))} + _ <- performBHRequest $ putMapping @Value testIndex ConversationMapping + _ <- performBHRequest $ indexDocument testIndex routed exampleTweet (DocId "rt-src-1") + -- Without routing, the source GET would miss the shard + -- (HTTP 404 → Nothing); with the matching routing it must + -- find the document. + let opts = defaultGetDocumentSourceOptions {gdsoRouting = Just "rt-src-1"} + source <- performBHRequest $ getDocumentSourceWith @Tweet opts testIndex (DocId "rt-src-1") + liftIO $ source `shouldBe` Just exampleTweet + + describe "documentSourceExists (HEAD /{index}/_source/{id})" $ do + it "returns True when the document has a _source" $ + withTestEnv $ do + _ <- insertData + present <- performBHRequest $ documentSourceExists testIndex (DocId "1") + liftIO $ present `shouldBe` True + + it "returns False for a document that never existed" $ + withTestEnv $ do + _ <- insertData + present <- performBHRequest $ documentSourceExists testIndex (DocId "bogus") + liftIO $ present `shouldBe` False + + it "returns False after the document is deleted" $ + withTestEnv $ do + _ <- insertData + _ <- performBHRequest $ deleteDocument testIndex (DocId "1") + present <- performBHRequest $ documentSourceExists testIndex (DocId "1") + liftIO $ present `shouldBe` False + + describe "deleteDocumentWith (DELETE /{index}/_doc/{id} URI params)" $ do + it "refresh=Just RefreshTrue makes the deletion immediately visible" $ + withTestEnv $ do + _ <- insertData + -- No manual refreshIndex: the refresh=True URI param should + -- make the delete visible to the immediately-following HEAD. + let opts = defaultDeleteDocumentOptions {ddoRefresh = Just RefreshTrue} + _ <- performBHRequest $ deleteDocumentWith opts testIndex (DocId "1") + present <- performBHRequest $ documentSourceExists testIndex (DocId "1") + liftIO $ present `shouldBe` False + + it "if_seq_no/if_primary_term: stale pair yields a 409 version conflict" $ + withTestEnv $ do + resetIndex + -- First index: capture the document's initial seq_no and + -- primary_term straight from the 'IndexedDocument' body. + (_, doc) <- insertData' defaultIndexDocumentSettings + let initialSeqNo = fromIntegral (idxDocSeqNo doc) :: Word64 + initialPrimaryTerm = fromIntegral (idxDocPrimaryTerm doc) :: Word64 + -- Second index of the same id advances seq_no, so the + -- stale pair must no longer match the live document. + _ <- performBHRequest $ indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1") + let staleOpts = + defaultDeleteDocumentOptions + { ddoIfSeqNo = Just initialSeqNo, + ddoIfPrimaryTerm = Just initialPrimaryTerm + } + result <- + tryEsError $ dispatch $ deleteDocumentWith staleOpts testIndex (DocId "1") + case result of + Left e -> liftIO $ errorStatus e `shouldBe` Just 409 + Right resp -> liftIO $ isVersionConflict resp `shouldBe` True + + describe "documentExistsWith (HEAD /{index}/_doc/{id} URI params)" $ do + it "refresh=Just True makes a just-indexed document immediately visible" $ + withTestEnv $ do + resetIndex + -- Index without a manual refreshIndex: the refresh=True URI + -- param on the HEAD should force the shard to see the write. + _ <- + performBHRequest $ + indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1") + let opts = defaultDocumentExistsOptions {deoRefresh = Just True} + present <- performBHRequest $ documentExistsWith opts testIndex (DocId "1") + liftIO $ present `shouldBe` True + + it "accepts a routing URI parameter and resolves the document" $ + withTestEnv $ do + resetIndex + _ <- performBHRequest $ indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "rt-ex-1") + -- testIndex is single-shard, so this is a wire-acceptance + -- smoke test (routing param rendered and accepted, HEAD + -- resolves the document) rather than a shard-selection proof; + -- the routing renderer itself is pinned by the + -- DocumentExistsOptions unit tests. + let opts = defaultDocumentExistsOptions {deoRouting = Just "user-42"} + present <- performBHRequest $ documentExistsWith opts testIndex (DocId "rt-ex-1") + liftIO $ present `shouldBe` True + + it "default options are byte-for-byte equivalent to documentExists" $ + withTestEnv $ do + _ <- insertData + withOpts <- performBHRequest $ documentExistsWith defaultDocumentExistsOptions testIndex (DocId "1") + withoutOpts <- performBHRequest $ documentExists testIndex (DocId "1") + liftIO $ withOpts `shouldBe` withoutOpts + + describe "documentSourceExistsWith (HEAD /{index}/_source/{id} URI params)" $ do + it "refresh=Just True makes a just-indexed document's source immediately visible" $ + withTestEnv $ do + resetIndex + _ <- + performBHRequest $ + indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1") + let opts = defaultDocumentSourceExistsOptions {dseoRefresh = Just True} + present <- performBHRequest $ documentSourceExistsWith opts testIndex (DocId "1") + liftIO $ present `shouldBe` True + + it "default options are byte-for-byte equivalent to documentSourceExists" $ + withTestEnv $ do + _ <- insertData + withOpts <- performBHRequest $ documentSourceExistsWith defaultDocumentSourceExistsOptions testIndex (DocId "1") + withoutOpts <- performBHRequest $ documentSourceExists testIndex (DocId "1") + liftIO $ withOpts `shouldBe` withoutOpts + + describe "ByQueryOptions URI params" $ do + it "updateByQueryWith accepts conflicts=proceed + slices=auto" $ + withTestEnv $ do + _ <- insertData + _ <- insertExtra + let query = TermQuery (Term "user" "bitemyapp") Nothing + script = + Script + (Just (ScriptLanguage "painless")) + (ScriptInline "ctx._source.age *= 2") + Nothing + Nothing + opts = + defaultByQueryOptions + { bqoConflicts = Just ConflictsProceed, + bqoWaitForCompletion = Just True, + bqoSlices = Just SlicesAuto, + bqoRefresh = Just RefreshTrue + } + _ <- tryPerformBHRequest $ updateByQueryWith @Value opts testIndex query (Just script) + parsed <- searchTweets (mkSearch (Just query) Nothing) + case parsed of + Left e -> + liftIO $ expectationFailure ("updateByQueryWith failed: " <> show e) + Right sr -> do + let results = map (fmap age . hitSource) (hits (searchHits sr)) + liftIO $ + results `shouldBe` [Just $ age exampleTweet * 2, Just $ age tweetWithExtra * 2] + + it "deleteByQueryWith respects max_docs=1" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + let query = MatchAllQuery Nothing + opts = defaultByQueryOptions {bqoMaxDocs = Just 1, bqoRefresh = Just RefreshTrue} + _ <- tryPerformBHRequest $ deleteByQueryWith @DeletedDocuments opts testIndex query + -- max_docs=1 should delete only one of the two documents. + let search = mkSearch (Just (MatchAllQuery Nothing)) Nothing + parsed <- searchTweets search + case parsed of + Left e -> + liftIO $ expectationFailure ("search after deleteByQueryWith failed: " <> show e) + Right sr -> + liftIO $ hitsTotal (searchHits sr) `shouldBe` Just (HitsTotal 1 HTR_EQ) + + it "updateByQueryWith defaultByQueryOptions succeeds (equivalent to updateByQuery)" $ + withTestEnv $ do + _ <- insertData + let query = TermQuery (Term "user" "bitemyapp") Nothing + script = + Script + (Just (ScriptLanguage "painless")) + (ScriptInline "ctx._source.age = 99") + Nothing + Nothing + res <- tryPerformBHRequest $ updateByQueryWith @Value defaultByQueryOptions testIndex query (Just script) + liftIO $ res `shouldSatisfy` isRight + + it "rethrottleUpdateByQuery unthrottles an in-progress async update_by_query" $ + withTestEnv $ do + -- Use a dedicated index so that an in-flight by-query task + -- cannot race with the next test's @insertData -> resetIndex@ + -- on the shared @testIndex@. Mirrors the @rethrottleReindex@ + -- test's @newIndex@ pattern. + let idx = [qqIndexName|bloodhound-tests-twitter-rethrottle-ubq|] + _ <- tryPerformBHRequest $ deleteIndex idx + _ <- + performBHRequest $ + createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) idx + _ <- performBHRequest $ indexDocument idx defaultIndexDocumentSettings exampleTweet (DocId "1") + _ <- performBHRequest $ refreshIndex idx + let query = TermQuery (Term "user" "bitemyapp") Nothing + script = + Script + (Just (ScriptLanguage "painless")) + (ScriptInline "ctx._source.age = 99") + Nothing + Nothing + -- wait_for_completion=false so the request returns + -- immediately with a TaskNodeId instead of blocking. + opts = defaultByQueryOptions {bqoWaitForCompletion = Just False} + taskNodeId <- + assertRight =<< tryPerformBHRequest (updateByQueryWith @TaskNodeId opts idx query (Just script)) + -- Race window: the single-doc update_by_query may finish + -- before the rethrottle reaches the server, in which case + -- the response carries an empty node list (the docstring on + -- 'rethrottleUpdateByQuery' spells this out). When the task + -- is still running the rethrottle response lists it + -- (>= 1 node). Either outcome is acceptable here — the + -- test exercises the wire path and decoder regardless. + _ <- performBHRequest $ rethrottleUpdateByQuery taskNodeId RethrottleUnlimited + _ <- waitForByQueryTaskToComplete 10 taskNodeId + _ <- performBHRequest $ refreshIndex idx + let search = mkSearch (Just query) Nothing + searchResult <- assertRight =<< tryPerformBHRequest (searchByIndex @Tweet idx search) + liftIO $ + map (fmap age . hitSource) (hits (searchHits searchResult)) `shouldBe` [Just (99 :: Int)] + + it "rethrottleDeleteByQuery unthrottles an in-progress async delete_by_query" $ + withTestEnv $ do + let idx = [qqIndexName|bloodhound-tests-twitter-rethrottle-dbq|] + _ <- tryPerformBHRequest $ deleteIndex idx + _ <- + performBHRequest $ + createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) idx + _ <- performBHRequest $ indexDocument idx defaultIndexDocumentSettings exampleTweet (DocId "1") + _ <- performBHRequest $ refreshIndex idx + let query = TermQuery (Term "user" "bitemyapp") Nothing + opts = defaultByQueryOptions {bqoWaitForCompletion = Just False} + taskNodeId <- + assertRight =<< tryPerformBHRequest (deleteByQueryWith @TaskNodeId opts idx query) + -- Same race window as 'rethrottleUpdateByQuery' above: an + -- empty node list in the response means the delete had + -- already finished. Either outcome exercises the wire path. + _ <- performBHRequest $ rethrottleDeleteByQuery taskNodeId RethrottleUnlimited + _ <- waitForByQueryTaskToComplete 10 taskNodeId + _ <- performBHRequest $ refreshIndex idx + let search = mkSearch (Just query) Nothing + searchResult <- assertRight =<< tryPerformBHRequest (searchByIndex @Tweet idx search) + liftIO $ hitsTotal (searchHits searchResult) `shouldBe` Just (HitsTotal 0 HTR_EQ) + + describe "UpdateBody (updateDocumentWith)" $ do + it "UpdateDoc with doc_as_upsert=true creates a missing document" $ + withTestEnv $ do + resetIndex + let body = + UpdateDoc + { ubDoc = toJSON exampleTweet, + ubDocAsUpsert = Just True + } + res <- performBHRequest $ updateDocumentWith testIndex defaultIndexDocumentSettings body (DocId "upsert-1") + liftIO $ idxDocResult res `shouldBe` "created" + -- Verify the document was actually created with the supplied content. + fetched <- performBHRequest $ getDocument @Tweet testIndex (DocId "upsert-1") + liftIO $ getSource fetched `shouldBe` Just exampleTweet + + it "UpdateDoc without doc_as_upsert fails on a missing document" $ + withTestEnv $ do + resetIndex + let body = mkUpdateDoc (toJSON (exampleTweet {user = "patched"})) + result <- tryEsError $ dispatch $ updateDocumentWith testIndex defaultIndexDocumentSettings body (DocId "no-upsert-1") + case result of + Right resp -> liftIO $ isSuccess resp `shouldBe` False + Left e -> liftIO $ errorStatus e `shouldBe` Just 404 + + it "UpdateScript modifies an existing document via painless" $ + withTestEnv $ do + _ <- insertData + let script = + Script + (Just (ScriptLanguage "painless")) + (ScriptInline "ctx._source.age += 10") + Nothing + Nothing + body = mkUpdateScript script + _ <- performBHRequest $ updateDocumentWith testIndex defaultIndexDocumentSettings body (DocId "1") + fetched <- performBHRequest $ getDocument @Tweet testIndex (DocId "1") + liftIO $ (fmap age . getSource) fetched `shouldBe` Just (age exampleTweet + 10) + + it "UpdateScript with upsert creates a missing document via script" $ + withTestEnv $ do + resetIndex + let script = + Script + (Just (ScriptLanguage "painless")) + (ScriptInline "ctx._source.counter = 0") + Nothing + Nothing + body = + UpdateScript + { ubScript = script, + ubUpsert = Just (object ["counter" .= (0 :: Int)]), + ubScriptedUpsert = Just True + } + res <- performBHRequest $ updateDocumentWith testIndex defaultIndexDocumentSettings body (DocId "script-upsert-1") + liftIO $ idxDocResult res `shouldBe` "created" + + it "updateDocument (legacy) remains byte-for-byte equivalent to updateDocumentWith (mkUpdateDoc)" $ + withTestEnv $ do + _ <- insertData + -- Legacy path: updateDocument with a patch. + let patch = exampleTweet {user = "legacy"} + _ <- performBHRequest $ updateDocument testIndex defaultIndexDocumentSettings patch (DocId "1") + legacyFetched <- performBHRequest $ getDocument @Tweet testIndex (DocId "1") + -- Reset and try the With path with the same patch. + _ <- insertData + _ <- performBHRequest $ updateDocumentWith testIndex defaultIndexDocumentSettings (mkUpdateDoc (toJSON patch)) (DocId "1") + withFetched <- performBHRequest $ getDocument @Tweet testIndex (DocId "1") + liftIO $ getSource legacyFetched `shouldBe` getSource withFetched + +assertRight :: (Show a, MonadFail m) => Either a b -> m b +assertRight (Left x) = fail $ "Expected Right, got Left: " <> show x +assertRight (Right x) = pure x + +-- | Poll 'getTask' until 'taskResponseCompleted' is true, bounded by a +-- number of 100ms ticks. Mirrors the helper in "Test.ReindexSpec". Used +-- to wait out an asynchronous @*_by_query@ task started with +-- @bqoWaitForCompletion = Just False@. +waitForByQueryTaskToComplete :: + (MonadBH m, MonadFail m) => + Natural -> + TaskNodeId -> + m (TaskResponse Value) +waitForByQueryTaskToComplete 0 taskNodeId = + fail $ "Timed out waiting for by-query task to complete, taskNodeId = " <> show taskNodeId +waitForByQueryTaskToComplete n taskNodeId = do + task <- assertRight =<< tryPerformBHRequest (getTask taskNodeId) + if taskResponseCompleted task + then pure task + else liftIO (threadDelay 100000) >> waitForByQueryTaskToComplete (n - 1) taskNodeId diff --git a/tests/Test/DownsampleSpec.hs b/tests/Test/DownsampleSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/DownsampleSpec.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.DownsampleSpec (spec) where + +import Data.Aeson +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import Database.Bloodhound.ElasticSearch9.Types qualified as Types +import TestsUtils.Import + +spec :: Spec +spec = describe "Downsample index API (/{index}/_downsample/{target_index})" $ do + describe "DownsampleRequest JSON" $ do + it "encodes a minimal request (no sampling_method)" $ do + let req = Types.DownsampleRequest (FixedInterval 1 Hours) Nothing + encode req `shouldBe` "{\"fixed_interval\":\"1h\"}" + + it "round-trips a minimal request" $ do + let req = Types.DownsampleRequest (FixedInterval 1 Hours) Nothing + decode (encode req) `shouldBe` Just req + + it "encodes sampling_method: aggregate as a JSON string" $ do + let req = + Types.DownsampleRequest + (FixedInterval 1 Hours) + (Just Types.Aggregate) + -- Inspect the wire form (order-independent via Object equality): + -- \"aggregate\" must be a string. + decode (encode req) + `shouldBe` Just + ( object + [ "fixed_interval" .= String "1h", + "sampling_method" .= String "aggregate" + ] + ) + + it "encodes sampling_method: last_value as a JSON string" $ do + let req = + Types.DownsampleRequest + (FixedInterval 30 Minutes) + (Just Types.LastValue) + decode (encode req) + `shouldBe` Just + ( object + [ "fixed_interval" .= String "30m", + "sampling_method" .= String "last_value" + ] + ) + + it "round-trips a request with sampling_method" $ do + let req = + Types.DownsampleRequest + (FixedInterval 30 Minutes) + (Just Types.LastValue) + decode (encode req) `shouldBe` Just req + + it "decodes a fully-populated request body" $ do + let raw = + LBS.pack + "{\"fixed_interval\":\"1h\",\"sampling_method\":\"last_value\"}" + case decode raw :: Maybe Types.DownsampleRequest of + Just req -> do + Types.downsampleRequestSamplingMethod req + `shouldBe` Just Types.LastValue + Nothing -> + expectationFailure "failed to decode DownsampleRequest" + + it "decodes a body without sampling_method (server default aggregate)" $ do + let raw = LBS.pack "{\"fixed_interval\":\"1h\"}" + case decode raw :: Maybe Types.DownsampleRequest of + Just req -> + Types.downsampleRequestSamplingMethod req + `shouldBe` (Nothing :: Maybe Types.SamplingMethod) + Nothing -> + expectationFailure "failed to decode DownsampleRequest" + + it "rejects an unknown sampling_method value" $ do + let raw = LBS.pack "{\"fixed_interval\":\"1h\",\"sampling_method\":\"bogus\"}" + decode raw `shouldBe` (Nothing :: Maybe Types.DownsampleRequest) + + describe "DownsampleResponse JSON" $ do + it "round-trips an acknowledged response" $ do + let resp = Types.DownsampleResponse True True + decode (encode resp) `shouldBe` Just resp + + it "decodes {acknowledged, shards_acknowledged} both true" $ + decode (LBS.pack "{\"acknowledged\":true,\"shards_acknowledged\":true}") + `shouldBe` Just (Types.DownsampleResponse True True) + + it "defaults shards_acknowledged to False when absent" $ + decode (LBS.pack "{\"acknowledged\":true}") + `shouldBe` Just (Types.DownsampleResponse True False) + + it "decodes an empty object as both False" $ + decode (LBS.pack "{}") + `shouldBe` Just (Types.DownsampleResponse False False) + + describe "downsampleOptionsParams URI rendering" $ do + it "defaultDownsampleOptions emits no params" $ + Types.downsampleOptionsParams Types.defaultDownsampleOptions + `shouldBe` [] + + it "renders wait_for_active_shards: all as \"all\"" $ do + let opts = + Types.defaultDownsampleOptions + { Types.downsampleOptionsWaitForActiveShards = Just AllActiveShards + } + Types.downsampleOptionsParams opts + `shouldBe` [("wait_for_active_shards", Just "all")] + + it "renders wait_for_active_shards: n as a bare number" $ do + let opts = + Types.defaultDownsampleOptions + { Types.downsampleOptionsWaitForActiveShards = Just (ActiveShards 2) + } + Types.downsampleOptionsParams opts + `shouldBe` [("wait_for_active_shards", Just "2")] + + it "renders master_timeout and timeout" $ do + let opts = + Types.defaultDownsampleOptions + { Types.downsampleOptionsMasterTimeout = Just "30s", + Types.downsampleOptionsTimeout = Just "1m" + } + Types.downsampleOptionsParams opts + `shouldBe` [("master_timeout", Just "30s"), ("timeout", Just "1m")] + + it "renders only the set field" $ do + let opts = + Types.defaultDownsampleOptions + { Types.downsampleOptionsTimeout = Just "5s" + } + Types.downsampleOptionsParams opts + `shouldBe` [("timeout", Just "5s")] + + it "renders all three params together in canonical order" $ do + let opts = + Types.defaultDownsampleOptions + { Types.downsampleOptionsWaitForActiveShards = Just AllActiveShards, + Types.downsampleOptionsMasterTimeout = Just "10s", + Types.downsampleOptionsTimeout = Just "1m" + } + Types.downsampleOptionsParams opts + `shouldBe` [ ("wait_for_active_shards", Just "all"), + ("master_timeout", Just "10s"), + ("timeout", Just "1m") + ] + + describe "endpoint shape" $ do + let body = Types.DownsampleRequest (FixedInterval 1 Hours) Nothing + Right idx = mkIndexName "metrics" + Right target = mkIndexName "metrics-downsample" + + it "POSTs //_downsample/ with a body" $ do + let req = RequestsES9.downsampleIndex idx target body + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["metrics", "_downsample", "metrics-downsample"] + bhRequestBody req `shouldSatisfy` isJust + + it "downsampleIndexWith appends timeout query params" $ do + let opts = + Types.defaultDownsampleOptions + { Types.downsampleOptionsMasterTimeout = Just "10s" + } + req = RequestsES9.downsampleIndexWith idx target body opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["metrics", "_downsample", "metrics-downsample"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("master_timeout", Just "10s")] + + it "downsampleIndexWith forwards wait_for_active_shards as a query param" $ do + let opts = + Types.defaultDownsampleOptions + { Types.downsampleOptionsWaitForActiveShards = Just AllActiveShards + } + req = RequestsES9.downsampleIndexWith idx target body opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["metrics", "_downsample", "metrics-downsample"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("wait_for_active_shards", Just "all")] + + it "the request body round-trips through the DownsampleRequest type" $ do + let req = RequestsES9.downsampleIndex idx target body + case bhRequestBody req of + Just bs -> case decode bs :: Maybe Types.DownsampleRequest of + Just decoded -> + decoded `shouldBe` body + Nothing -> + expectationFailure "request body did not decode as DownsampleRequest" + Nothing -> + expectationFailure "downsampleIndex should carry a request body" diff --git a/tests/Test/EnrichSpec.hs b/tests/Test/EnrichSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/EnrichSpec.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.EnrichSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import TestsUtils.Import +import Prelude + +-- | A canonical @match@ policy body matching the ES 7.17 docs example. +sampleMatchPolicyBytes :: LBS.ByteString +sampleMatchPolicyBytes = + "{\ + \ \"match\": {\ + \ \"indices\": [\"users\"],\ + \ \"match_field\": \"email\",\ + \ \"enrich_fields\": [\"first_name\", \"last_name\"]\ + \ }\ + \}" + +-- | A @geo_match@ policy that exercises a non-default 'EnrichPolicyType' +-- and a bare-string @indices@ (ES accepts a single string there). +sampleGeoPolicyBytes :: LBS.ByteString +sampleGeoPolicyBytes = + "{\ + \ \"geo_match\": {\ + \ \"indices\": \"users-geo-*\",\ + \ \"match_field\": \"geo_location\",\ + \ \"enrich_fields\": \"city\"\ + \ }\ + \}" + +-- | A policy carrying an optional @query@ and an unknown sibling field +-- (@description@) which the @epcExtras@ catch-all must preserve. +samplePolicyWithExtrasBytes :: LBS.ByteString +samplePolicyWithExtrasBytes = + "{\ + \ \"range\": {\ + \ \"indices\": [\"orders\"],\ + \ \"match_field\": \"customer_id\",\ + \ \"enrich_fields\": [\"tier\"],\ + \ \"query\": {\"term\": {\"active\": true}},\ + \ \"description\": \"customer-tier lookup\"\ + \ }\ + \}" + +-- | Full @GET /_enrich/policy@ response with two entries. +sampleListResponseBytes :: LBS.ByteString +sampleListResponseBytes = + "{\ + \ \"policies\": [\ + \ {\ + \ \"name\": \"users-policy\",\ + \ \"config\": {\ + \ \"match\": {\ + \ \"indices\": [\"users\"],\ + \ \"match_field\": \"email\",\ + \ \"enrich_fields\": [\"first_name\"]\ + \ }\ + \ }\ + \ },\ + \ {\ + \ \"name\": \"geo-policy\",\ + \ \"config\": {\ + \ \"geo_match\": {\ + \ \"indices\": [\"geodata\"],\ + \ \"match_field\": \"location\",\ + \ \"enrich_fields\": [\"city\", \"state\"]\ + \ }\ + \ }\ + \ }\ + \ ]\ + \}" + +-- | @GET /_enrich/_execute_stats@ response, ES 7.x shape: +-- @last_execution_time@ as epoch-millis number. +sampleExecuteStatsEpochMillisBytes :: LBS.ByteString +sampleExecuteStatsEpochMillisBytes = + "{\ + \ \"executor_pool\": \"generic\",\ + \ \"execute_stats\": [\ + \ {\ + \ \"policy\": \"users-policy\",\ + \ \"last_execution_time\": 1719394582880,\ + \ \"running_policy_index_search\": false,\ + \ \"phase\": \"ENDED\"\ + \ }\ + \ ]\ + \}" + +-- | @GET /_enrich/_execute_stats@ response, ES 8.x\/9.x shape: +-- @last_execution_time@ as an ISO-8601 string, plus an unknown sibling +-- field (@remote_indices@) that the @eseeExtras@ catch-all must keep. +sampleExecuteStatsIsoBytes :: LBS.ByteString +sampleExecuteStatsIsoBytes = + "{\ + \ \"executor_pool\": \"generic\",\ + \ \"execute_stats\": [\ + \ {\ + \ \"policy\": \"geo-policy\",\ + \ \"last_execution_time\": \"2024-06-26T10:16:22.880Z\",\ + \ \"phase\": \"RUNNING\",\ + \ \"remote_indices\": [\"remote:geodata\"]\ + \ }\ + \ ]\ + \}" + +spec :: Spec +spec = describe "Enrich policy API" $ do + describe "EnrichPolicyId JSON" $ do + it "round-trips as a bare JSON string" $ do + let Just decoded = decode "\"my-policy\"" :: Maybe EnrichPolicyId + unEnrichPolicyId decoded `shouldBe` "my-policy" + encode (EnrichPolicyId "my-policy") `shouldBe` "\"my-policy\"" + + it "rejects a non-string value" $ do + let decoded = decode "42" :: Maybe EnrichPolicyId + decoded `shouldBe` Nothing + + describe "EnrichPolicyType JSON" $ do + it "'enrichPolicyTypeText' spells the documented keys" $ do + enrichPolicyTypeText EnrichPolicyTypeMatch `shouldBe` "match" + enrichPolicyTypeText EnrichPolicyTypeGeoMatch `shouldBe` "geo_match" + enrichPolicyTypeText EnrichPolicyTypeRange `shouldBe` "range" + + it "absorbs an unknown policy type into the Custom branch" $ do + let Just (EnrichPolicyTypeCustom t) = + decode "\"mismatch\"" :: Maybe EnrichPolicyType + t `shouldBe` "mismatch" + + describe "EnrichPolicy JSON (PUT body)" $ do + it "decodes a canonical match policy" $ do + let Just decoded = decode sampleMatchPolicyBytes :: Maybe EnrichPolicy + epTypeTag decoded `shouldBe` EnrichPolicyTypeMatch + let cfg = epConfig decoded + NE.toList (epcIndices cfg) `shouldBe` [IndexPattern "users"] + epcMatchField cfg `shouldBe` FieldName "email" + NE.toList (epcEnrichFields cfg) + `shouldBe` [FieldName "first_name", FieldName "last_name"] + epcQuery cfg `shouldBe` Nothing + epcExtras cfg `shouldBe` KM.empty + + it "decodes a geo_match policy with bare-string indices/enrich_fields" $ do + let Just decoded = decode sampleGeoPolicyBytes :: Maybe EnrichPolicy + epTypeTag decoded `shouldBe` EnrichPolicyTypeGeoMatch + let cfg = epConfig decoded + -- A bare string is normalised to a singleton list. + NE.toList (epcIndices cfg) `shouldBe` [IndexPattern "users-geo-*"] + NE.toList (epcEnrichFields cfg) `shouldBe` [FieldName "city"] + + it "preserves an optional query and unknown sibling fields in extras" $ do + let Just decoded = decode samplePolicyWithExtrasBytes :: Maybe EnrichPolicy + cfg = epConfig decoded + epTypeTag decoded `shouldBe` EnrichPolicyTypeRange + -- The @query@ body is carried as an opaque Value. + epcQuery cfg `shouldSatisfy` isJust + -- The unknown @description@ key survives in the extras catch-all. + KM.lookup "description" (epcExtras cfg) `shouldSatisfy` isJust + + it "encodes the type-tagged shape with array indices/enrich_fields" $ do + let Just decoded = decode sampleMatchPolicyBytes :: Maybe EnrichPolicy + encoded = encode decoded + Just roundTripped = decode encoded :: Maybe EnrichPolicy + -- Round-trip is stable. + epTypeTag roundTripped `shouldBe` EnrichPolicyTypeMatch + NE.toList (epcEnrichFields (epConfig roundTripped)) + `shouldBe` [FieldName "first_name", FieldName "last_name"] + + it "round-trips a policy with extras through encode . decode" $ do + let Just decoded = decode samplePolicyWithExtrasBytes :: Maybe EnrichPolicy + Just roundTripped = decode (encode decoded) :: Maybe EnrichPolicy + cfg = epConfig roundTripped + KM.lookup "description" (epcExtras cfg) `shouldSatisfy` isJust + -- The known @query@ key is NOT duplicated into extras. + KM.lookup "query" (epcExtras cfg) `shouldBe` Nothing + + it "rejects an empty object body" $ do + let decoded = decode "{}" :: Maybe EnrichPolicy + decoded `shouldBe` Nothing + + it "rejects a multi-key body" $ do + let decoded = + decode "{\"match\":{},\"geo_match\":{}}" :: Maybe EnrichPolicy + decoded `shouldBe` Nothing + + it "rejects a policy missing required 'indices'" $ do + let decoded = + decode + "{\"match\":{\"match_field\":\"email\",\"enrich_fields\":[\"x\"]}}" :: + Maybe EnrichPolicy + decoded `shouldBe` Nothing + + it "rejects a policy with an empty 'enrich_fields' array" $ do + let decoded = + decode + "{\"match\":{\"indices\":[\"u\"],\"match_field\":\"e\",\"enrich_fields\":[]}}" :: + Maybe EnrichPolicy + decoded `shouldBe` Nothing + + it "rejects a policy with an empty 'indices' array" $ do + let decoded = + decode + "{\"match\":{\"indices\":[],\"match_field\":\"e\",\"enrich_fields\":[\"x\"]}}" :: + Maybe EnrichPolicy + decoded `shouldBe` Nothing + + describe "EnrichPoliciesResponse JSON (GET response)" $ do + it "decodes the {policies: [...]} envelope" $ do + let Just decoded = + decode sampleListResponseBytes :: Maybe EnrichPoliciesResponse + length (unEnrichPoliciesResponse decoded) `shouldBe` 2 + let firstInfo = head (unEnrichPoliciesResponse decoded) + epiName firstInfo `shouldBe` EnrichPolicyId "users-policy" + epTypeTag (epiPolicy firstInfo) + `shouldBe` EnrichPolicyTypeMatch + let secondInfo = unEnrichPoliciesResponse decoded !! 1 + epTypeTag (epiPolicy secondInfo) + `shouldBe` EnrichPolicyTypeGeoMatch + + it "re-encodes to the same envelope shape" $ do + let Just decoded = + decode sampleListResponseBytes :: Maybe EnrichPoliciesResponse + reEncoded = encode decoded + Just reparsed = + decode reEncoded :: Maybe EnrichPoliciesResponse + length (unEnrichPoliciesResponse reparsed) `shouldBe` 2 + + describe "EnrichPolicyPhase JSON" $ do + it "decodes documented values" $ do + decode "\"ENDED\"" `shouldBe` Just EnrichPolicyPhaseEnded + decode "\"RUNNING\"" `shouldBe` Just EnrichPolicyPhaseRunning + + it "encodes documented values back to the wire spelling" $ do + encode EnrichPolicyPhaseEnded `shouldBe` "\"ENDED\"" + encode EnrichPolicyPhaseRunning `shouldBe` "\"RUNNING\"" + + it "absorbs an unknown phase into the Custom branch" $ do + let Just (EnrichPolicyPhaseCustom t) = + decode "\"WAITING_FOR_LEADER\"" :: Maybe EnrichPolicyPhase + t `shouldBe` "WAITING_FOR_LEADER" + + describe "EnrichExecuteStatsResponse JSON" $ do + it "decodes the ES 7.x epoch-millis shape" $ do + let Just decoded = + decode sampleExecuteStatsEpochMillisBytes :: + Maybe EnrichExecuteStatsResponse + eesrExecutorPool decoded `shouldBe` Just "generic" + length (eesrStats decoded) `shouldBe` 1 + let entry = head (eesrStats decoded) + eseePolicy entry `shouldBe` EnrichPolicyId "users-policy" + eseeRunningPolicyIndexSearch entry `shouldBe` Just False + eseePhase entry `shouldBe` Just EnrichPolicyPhaseEnded + -- @last_execution_time@ is carried as an opaque Value (epoch millis). + eseeLastExecutionTime entry `shouldSatisfy` isJust + + it "decodes the ES 8.x/9.x ISO-8601 shape and preserves unknown fields" $ do + let Just decoded = + decode sampleExecuteStatsIsoBytes :: + Maybe EnrichExecuteStatsResponse + let entry = head (eesrStats decoded) + eseePolicy entry `shouldBe` EnrichPolicyId "geo-policy" + eseePhase entry `shouldBe` Just EnrichPolicyPhaseRunning + -- The unknown @remote_indices@ sibling is preserved in extras. + KM.lookup "remote_indices" (eseeExtras entry) `shouldSatisfy` isJust + -- @running_policy_index_search@ is absent on the wire, so it is Nothing. + eseeRunningPolicyIndexSearch entry `shouldBe` Nothing + + it "round-trips the execute-stats response" $ do + let Just decoded = + decode sampleExecuteStatsEpochMillisBytes :: + Maybe EnrichExecuteStatsResponse + Just roundTripped = + decode (encode decoded) :: Maybe EnrichExecuteStatsResponse + length (eesrStats roundTripped) `shouldBe` 1 + + it "preserves unknown execute-stats fields through encode . decode" $ do + let Just decoded = + decode sampleExecuteStatsIsoBytes :: + Maybe EnrichExecuteStatsResponse + Just roundTripped = + decode (encode decoded) :: Maybe EnrichExecuteStatsResponse + entry = head (eesrStats roundTripped) + -- The @remote_indices@ extra survives the round-trip. + KM.lookup "remote_indices" (eseeExtras entry) `shouldSatisfy` isJust + + describe "EnrichExecuteOptions params" $ do + it "default options render no query string" $ do + enrichExecuteOptionsParams defaultEnrichExecuteOptions + `shouldBe` [] + + it "wait_for_completion is rendered as a bool string" $ do + let opts = + defaultEnrichExecuteOptions + { eeoWaitForCompletion = Just False + } + enrichExecuteOptionsParams opts + `shouldBe` [("wait_for_completion", Just "false")] + + it "wait_for_completion=True renders 'true'" $ do + let opts = + defaultEnrichExecuteOptions + { eeoWaitForCompletion = Just True + } + enrichExecuteOptionsParams opts + `shouldBe` [("wait_for_completion", Just "true")] + + describe "defaultEnrichPolicyConfig" $ do + it "builds a minimal config with single-element lists" $ do + let cfg = + defaultEnrichPolicyConfig + (IndexPattern "users") + (FieldName "email") + (FieldName "first_name" :| []) + NE.toList (epcIndices cfg) `shouldBe` [IndexPattern "users"] + epcMatchField cfg `shouldBe` FieldName "email" + NE.toList (epcEnrichFields cfg) `shouldBe` [FieldName "first_name"] + epcQuery cfg `shouldBe` Nothing + epcExtras cfg `shouldBe` KM.empty diff --git a/tests/Test/EsQueryLanguageSpec.hs b/tests/Test/EsQueryLanguageSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/EsQueryLanguageSpec.hs @@ -0,0 +1,977 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.EsQueryLanguageSpec (spec) where + +import Data.Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Maybe (isJust, isNothing) +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch8.Requests qualified as RequestsES8 +import Database.Bloodhound.ElasticSearch8.Types qualified as ES8Types +import Database.Bloodhound.ElasticSearch9.Client qualified as ClientES9 +import Database.Bloodhound.ElasticSearch9.Types qualified as ES9Types +import TestsUtils.Common +import TestsUtils.Import + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +-- | A minimal 'ESQLRequest' with every optional field set to 'Nothing'. +-- Produces a body containing only the @query@ key. +minimalReq :: Text -> ES8Types.ESQLRequest +minimalReq q = + ES8Types.ESQLRequest + { esqlQuery = q, + esqlLocale = Nothing, + esqlFilter = Nothing, + esqlParams = Nothing, + esqlColumnar = Nothing, + esqlProfile = Nothing, + esqlTables = Nothing, + esqlIncludeCcsMetadata = Nothing + } + +minimalES9Req :: Text -> ES9Types.ESQLRequest +minimalES9Req q = + ES9Types.ESQLRequest + { esqlQuery = q, + esqlLocale = Nothing, + esqlTimeZone = Nothing, + esqlFilter = Nothing, + esqlParams = Nothing, + esqlColumnar = Nothing, + esqlProfile = Nothing, + esqlTables = Nothing, + esqlIncludeCcsMetadata = Nothing, + esqlIncludeExecutionMetadata = Nothing + } + +spec :: Spec +spec = describe "ES|QL Query API (POST /_query)" $ do + describe "ESQLRequest JSON" $ do + it "serializes the required query field" $ do + let json = encode (minimalReq "FROM logs | LIMIT 10") + json `shouldSatisfy` hasKey "query" + + it "omits all optional Nothing fields" $ do + let json = encode (minimalReq "FROM logs | LIMIT 10") + json `shouldNotSatisfy` hasKey "locale" + json `shouldNotSatisfy` hasKey "time_zone" + json `shouldNotSatisfy` hasKey "filter" + json `shouldNotSatisfy` hasKey "params" + json `shouldNotSatisfy` hasKey "columnar" + json `shouldNotSatisfy` hasKey "profile" + json `shouldNotSatisfy` hasKey "tables" + json `shouldNotSatisfy` hasKey "include_ccs_metadata" + json `shouldNotSatisfy` hasKey "include_execution_metadata" + + it "never emits the removed field_multi_value_leniency key" $ do + let json = encode (minimalReq "FROM logs | LIMIT 10") + json `shouldNotSatisfy` hasKey "field_multi_value_leniency" + + it "includes the original optional fields when set" $ do + let req = + ES8Types.ESQLRequest + { esqlQuery = "FROM logs | LIMIT 10", + esqlLocale = Just "en-US", + esqlFilter = Just (Filter (TermQuery (Term "user" "alice") Nothing)), + esqlParams = Just [toJSON ("foo" :: Text), toJSON (42 :: Int)], + esqlColumnar = Nothing, + esqlProfile = Nothing, + esqlTables = Nothing, + esqlIncludeCcsMetadata = Nothing + } + let json = encode req + json `shouldSatisfy` hasKey "locale" + json `shouldSatisfy` hasKey "filter" + json `shouldSatisfy` hasKey "params" + + it "includes the new body fields when set" $ do + let req = + ES8Types.ESQLRequest + { esqlQuery = "FROM logs | LIMIT 10", + esqlLocale = Nothing, + esqlFilter = Nothing, + esqlParams = Nothing, + esqlColumnar = Just True, + esqlProfile = Just True, + esqlTables = Just (object ["colors" .= [object ["id" .= (1 :: Int), "name" .= ("red" :: Text)]]]), + esqlIncludeCcsMetadata = Just True + } + let json = encode req + json `shouldSatisfy` hasKey "columnar" + json `shouldSatisfy` hasKey "profile" + json `shouldSatisfy` hasKey "tables" + json `shouldSatisfy` hasKey "include_ccs_metadata" + + it "round-trips a minimal request through ToJSON/FromJSON" $ do + let req = minimalReq "FROM logs | LIMIT 10" + decode (encode req) `shouldBe` Just req + + it "round-trips a fully-populated request through ToJSON/FromJSON" $ do + let req = + ES8Types.ESQLRequest + { esqlQuery = "FROM logs | LIMIT 10", + esqlLocale = Just "en-US", + esqlFilter = Just (Filter (TermQuery (Term "user" "alice") Nothing)), + esqlParams = Just [toJSON ("foo" :: Text), toJSON (42 :: Int)], + esqlColumnar = Just True, + esqlProfile = Just False, + esqlTables = Just (object ["colors" .= [object ["id" .= (1 :: Int)]]]), + esqlIncludeCcsMetadata = Just True + } + decode (encode req) `shouldBe` Just req + + describe "ES9 ESQLRequest JSON (time_zone + include_execution_metadata)" $ do + it "ES9: omits time_zone and include_execution_metadata when Nothing" $ do + let json = encode (minimalES9Req "FROM logs | LIMIT 10") + json `shouldNotSatisfy` hasKey "time_zone" + json `shouldNotSatisfy` hasKey "include_execution_metadata" + json `shouldSatisfy` hasKey "query" + + it "ES9: emits time_zone when set" $ do + let req = (minimalES9Req "FROM x") {ES9Types.esqlTimeZone = Just "UTC"} + encode req `shouldSatisfy` hasKey "time_zone" + + it "ES9: emits include_execution_metadata when set" $ do + let req = (minimalES9Req "FROM x") {ES9Types.esqlIncludeExecutionMetadata = Just True} + encode req `shouldSatisfy` hasKey "include_execution_metadata" + + it "ES9: round-trips a fully-populated request through ToJSON/FromJSON" $ do + let req = + ES9Types.ESQLRequest + { esqlQuery = "FROM logs | LIMIT 10", + esqlLocale = Just "en-US", + esqlTimeZone = Just "UTC", + esqlFilter = Just (Filter (TermQuery (Term "user" "alice") Nothing)), + esqlParams = Just [toJSON ("foo" :: Text), toJSON (42 :: Int)], + esqlColumnar = Just True, + esqlProfile = Just False, + esqlTables = Just (object ["colors" .= [object ["id" .= (1 :: Int)]]]), + esqlIncludeCcsMetadata = Just True, + esqlIncludeExecutionMetadata = Just True + } + decode (encode req) `shouldBe` Just req + + it "ES9: AsyncESQLRequest forwards time_zone and include_execution_metadata" $ do + let base = + (minimalES9Req "FROM logs | LIMIT 10") + { ES9Types.esqlTimeZone = Just "UTC", + ES9Types.esqlIncludeExecutionMetadata = Just True + } + areq = + (ES9Types.mkAsyncESQLRequest base) + { ES9Types.asyncESQLRequestWaitForCompletionTimeout = Just "5s" + } + json = encode areq + json `shouldSatisfy` hasKey "query" + json `shouldSatisfy` hasKey "time_zone" + json `shouldSatisfy` hasKey "include_execution_metadata" + json `shouldSatisfy` hasKey "wait_for_completion_timeout" + + describe "ESQLResult JSON" $ do + it "decodes a complete synchronous response with all spec fields" $ do + let raw = + LBS.pack + "{\"is_partial\":false,\"all_columns\":true,\"columns\":[{\"name\":\"user\",\"type\":\"keyword\"},{\"name\":\"age\",\"type\":\"long\"}],\"values\":[[\"alice\",30],[\"bob\",40]],\"took\":5}" + let expected = + ES8Types.ESQLResult + { esqlIsPartial = False, + esqlAllColumns = Just True, + esqlColumns = + [ ES8Types.ESQLColumn "user" "keyword", + ES8Types.ESQLColumn "age" "long" + ], + esqlValues = [[String "alice", Number 30], [String "bob", Number 40]], + esqlClusters = Nothing, + esqlProfileValue = Nothing, + esqlTook = Just 5 + } + decode raw `shouldBe` Just expected + + it "decodes a response carrying _clusters and profile" $ do + let raw = + LBS.pack + "{\"is_partial\":false,\"columns\":[{\"name\":\"user\",\"type\":\"keyword\"}],\"values\":[[\"alice\"]],\"_clusters\":{\"total\":1,\"successful\":1,\"skipped\":0},\"profile\":{\"parsed\":{}},\"took\":7}" + let Just result = decode raw + ES8Types.esqlIsPartial result `shouldBe` False + ES8Types.esqlClusters result `shouldSatisfy` isJust + ES8Types.esqlProfileValue result `shouldSatisfy` isJust + let Just clusters = ES8Types.esqlClusters result + ES8Types.esqlClustersTotal clusters `shouldBe` 1 + ES8Types.esqlClustersSuccessful clusters `shouldBe` 1 + ES8Types.esqlClustersSkipped clusters `shouldBe` 0 + -- The bare {"parsed":{}}} shape is captured verbatim in + -- esqlProfileOther since ES marks the profile payload as + -- unstable (no typed projections apply). + let Just profile = ES8Types.esqlProfileValue result + ES8Types.esqlProfileOther profile `shouldBe` object ["parsed" .= object []] + ES8Types.esqlTook result `shouldBe` Just 7 + + it "rejects a response missing the required is_partial key" $ do + let raw = + LBS.pack + "{\"columns\":[{\"name\":\"user\",\"type\":\"text\"}],\"values\":[[\"bitemyapp\"]]}" + decode raw `shouldSatisfy` (isNothing :: Maybe ES8Types.ESQLResult -> Bool) + + it "rejects a response missing the required columns key" $ do + let raw = + LBS.pack "{\"is_partial\":false,\"values\":[]}" + decode raw `shouldSatisfy` (isNothing :: Maybe ES8Types.ESQLResult -> Bool) + + it "rejects a response missing the required values key" $ do + let raw = + LBS.pack + "{\"is_partial\":false,\"columns\":[{\"name\":\"user\",\"type\":\"text\"}]}" + decode raw `shouldSatisfy` (isNothing :: Maybe ES8Types.ESQLResult -> Bool) + + it "round-trips ESQLColumn through ToJSON/FromJSON" $ do + let col = ES8Types.ESQLColumn "user" "keyword" + decode (encode col) `shouldBe` Just col + + it "never emits the removed total_rows or is_running keys" $ do + let r = + ES8Types.ESQLResult + { esqlIsPartial = False, + esqlAllColumns = Nothing, + esqlColumns = [ES8Types.ESQLColumn "user" "keyword"], + esqlValues = [[String "alice"]], + esqlClusters = Nothing, + esqlProfileValue = Nothing, + esqlTook = Just 5 + } + json = encode r + json `shouldNotSatisfy` hasKey "total_rows" + json `shouldNotSatisfy` hasKey "is_running" + + it "round-trips a fully-populated ESQLResult through ToJSON/FromJSON" $ do + -- The @_clusters@/@profile@ records use the forward-compat @Other + -- Value@ pattern (see 'Database.Bloodhound.Internal.Versions.Common.Types.ClusterStats'): + -- decode captures the whole input object in @*Other@, so the pair + -- is idempotent (decode . encode . decode == decode) rather than + -- equality-preserving from a hand-built value. Assert idempotency + -- plus typed-field survival, mirroring 'Test.ClusterStatsSpec'. + let raw = + LBS.pack + "{\"is_partial\":false,\"all_columns\":true,\"columns\":[{\"name\":\"user\",\"type\":\"keyword\"}],\"values\":[[\"alice\",30]],\"_clusters\":{\"total\":2,\"successful\":1,\"running\":0,\"skipped\":0,\"partial\":0,\"failed\":1,\"details\":{\"remote_one\":{\"status\":\"successful\",\"indices\":\"logs-*\"}},\"future_key\":99},\"profile\":{\"parsed\":{}},\"took\":5}" + case decode raw of + Nothing -> expectationFailure "initial decode failed" + Just (firstDecode :: ES8Types.ESQLResult) -> + case decode (encode firstDecode) of + Nothing -> expectationFailure "re-decode failed" + Just again -> do + ES8Types.esqlIsPartial again `shouldBe` False + ES8Types.esqlTook again `shouldBe` Just 5 + -- Typed _clusters fields survive. + let Just clusters = ES8Types.esqlClusters again + ES8Types.esqlClustersTotal clusters `shouldBe` 2 + ES8Types.esqlClustersFailed clusters `shouldBe` 1 + -- Forward-compat key preserved via esqlClustersOther. + case ES8Types.esqlClustersOther clusters of + Object o + | KM.member "future_key" o -> pure () + _ -> expectationFailure "future_key dropped from _clusters round-trip" + -- Profile payload preserved verbatim. + let Just profile = ES8Types.esqlProfileValue again + case ES8Types.esqlProfileOther profile of + Object o + | KM.member "parsed" o -> pure () + _ -> expectationFailure "parsed dropped from profile round-trip" + + describe "EsqlClusters JSON" $ do + it "decodes the full documented shape (6 counters + details map)" $ do + let raw = + LBS.pack + "{\"total\":3,\"successful\":2,\"running\":0,\"skipped\":1,\"partial\":0,\"failed\":0,\"details\":{\"remote_one\":{\"status\":\"successful\",\"indices\":\"logs-*\",\"_shards\":{\"total\":4,\"successful\":4,\"skipped\":0,\"failed\":0}},\"remote_two\":{\"status\":\"skipped\",\"indices\":\"audit-*\"}}}" + Just clusters = decode raw + ES8Types.esqlClustersTotal clusters `shouldBe` 3 + ES8Types.esqlClustersSuccessful clusters `shouldBe` 2 + ES8Types.esqlClustersRunning clusters `shouldBe` 0 + ES8Types.esqlClustersSkipped clusters `shouldBe` 1 + ES8Types.esqlClustersPartial clusters `shouldBe` 0 + ES8Types.esqlClustersFailed clusters `shouldBe` 0 + -- Per-cluster entries decode in document order. + let details = ES8Types.esqlClustersDetails clusters + length details `shouldBe` 2 + fst (head details) `shouldBe` "remote_one" + snd (head details) + `shouldBe` ES8Types.EsqlClusterDetails + { esqlClusterDetailsStatus = Just ES8Types.EsqlClusterStatusSuccessful, + esqlClusterDetailsIndices = Just "logs-*", + esqlClusterDetailsShards = + Just + ( ShardResult + { shardTotal = 4, + shardsSuccessful = 4, + shardsSkipped = 0, + shardsFailed = 0 + } + ), + esqlClusterDetailsFailures = Nothing, + esqlClusterDetailsOther = + object + [ "status" .= ("successful" :: Text), + "indices" .= ("logs-*" :: Text), + "_shards" + .= object + [ "total" .= (4 :: Int), + "successful" .= (4 :: Int), + "skipped" .= (0 :: Int), + "failed" .= (0 :: Int) + ] + ] + } + + it "decodes a minimal clusters object (missing counters and details default to 0/[])" $ do + let raw = LBS.pack "{\"total\":1,\"successful\":1,\"skipped\":0}" + Just clusters = decode raw + ES8Types.esqlClustersRunning clusters `shouldBe` 0 + ES8Types.esqlClustersPartial clusters `shouldBe` 0 + ES8Types.esqlClustersFailed clusters `shouldBe` 0 + ES8Types.esqlClustersDetails clusters `shouldBe` [] + + it "preserves forward-compat keys through esqlClustersOther on a round trip" $ do + let raw = + LBS.pack + "{\"total\":1,\"successful\":1,\"running\":0,\"skipped\":0,\"partial\":0,\"failed\":0,\"details\":{},\"future_key\":42}" + Just clusters = decode raw :: Maybe ES8Types.EsqlClusters + -- Re-encoding must keep the unknown @future_key@ (captured in Other). + let roundTripped = encode clusters + roundTripped `shouldSatisfy` hasKey "future_key" + -- And the typed counters stay authoritative. + decode roundTripped `shouldBe` Just clusters + + it "round-trips a fully-populated EsqlClusters (idempotent decode . encode . decode)" $ do + -- See the ESQLResult round-trip note: the forward-compat @Other + -- Value@ pattern is idempotent after the first decode, so we + -- verify (decode . encode . decode == decode) rather than + -- equality with a hand-built value. + let raw = + LBS.pack + "{\"total\":2,\"successful\":1,\"running\":0,\"skipped\":0,\"partial\":0,\"failed\":1,\"details\":{\"remote_one\":{\"status\":\"successful\",\"indices\":\"logs-*\"}},\"future_key\":99}" + case decode raw of + Nothing -> expectationFailure "initial decode failed" + Just (firstDecode :: ES8Types.EsqlClusters) -> do + case decode (encode firstDecode) of + Nothing -> expectationFailure "re-decode failed" + Just again -> do + again `shouldBe` firstDecode + ES8Types.esqlClustersTotal again `shouldBe` 2 + ES8Types.esqlClustersFailed again `shouldBe` 1 + case ES8Types.esqlClustersOther again of + Object o + | KM.member "future_key" o -> pure () + _ -> expectationFailure "future_key dropped from round-trip" + + describe "EsqlClusterStatus JSON" $ do + it "decodes every documented enum value" $ do + decode (encode ES8Types.EsqlClusterStatusRunning) + `shouldBe` Just ES8Types.EsqlClusterStatusRunning + decode (encode ES8Types.EsqlClusterStatusSuccessful) + `shouldBe` Just ES8Types.EsqlClusterStatusSuccessful + decode (encode ES8Types.EsqlClusterStatusPartial) + `shouldBe` Just ES8Types.EsqlClusterStatusPartial + decode (encode ES8Types.EsqlClusterStatusSkipped) + `shouldBe` Just ES8Types.EsqlClusterStatusSkipped + decode (encode ES8Types.EsqlClusterStatusFailed) + `shouldBe` Just ES8Types.EsqlClusterStatusFailed + + it "encodes enum values as the documented wire strings" $ do + encode ES8Types.EsqlClusterStatusRunning `shouldBe` "\"running\"" + encode ES8Types.EsqlClusterStatusSuccessful `shouldBe` "\"successful\"" + encode ES8Types.EsqlClusterStatusPartial `shouldBe` "\"partial\"" + encode ES8Types.EsqlClusterStatusSkipped `shouldBe` "\"skipped\"" + encode ES8Types.EsqlClusterStatusFailed `shouldBe` "\"failed\"" + + it "round-trips an unknown status through OtherEsqlClusterStatus" $ do + let s = ES8Types.OtherEsqlClusterStatus "queued" + decode (encode s) `shouldBe` Just s + encode s `shouldBe` "\"queued\"" + + describe "EsqlProfile JSON" $ do + it "captures an unstable-shape payload verbatim in esqlProfileOther" $ do + let raw = LBS.pack "{\"parsed\":{\"query_type\":\"command\"}}" + Just profile = decode raw + ES8Types.esqlProfileShards profile `shouldBe` Nothing + ES8Types.esqlProfileProfiles profile `shouldBe` Nothing + ES8Types.esqlProfileOther profile + `shouldBe` object ["parsed" .= object ["query_type" .= ("command" :: Text)]] + + it "decodes the documented Lucene-style projections when present" $ do + let raw = + LBS.pack + "{\"shards\":[{\"id\":0}],\"profiles\":[{\"phase\":\"query\",\"description\":\"compute\",\"time\":\"1ms\",\"children\":[]}]}" + Just profile = decode raw + ES8Types.esqlProfileShards profile `shouldBe` Just [object ["id" .= (0 :: Int)]] + let Just sections = ES8Types.esqlProfileProfiles profile + length sections `shouldBe` 1 + let section = head sections + ES8Types.esqlProfileSectionPhase section `shouldBe` Just "query" + ES8Types.esqlProfileSectionDescription section `shouldBe` Just "compute" + ES8Types.esqlProfileSectionChildren section `shouldBe` Just [] + + it "round-trips an EsqlProfile preserving both typed and Other keys" $ do + let profile = + ES8Types.EsqlProfile + { esqlProfileShards = Nothing, + esqlProfileProfiles = Nothing, + esqlProfileOther = object ["parsed" .= object []] + } + decode (encode profile) `shouldBe` Just profile + + it "preserves populated typed projections through a decode/encode cycle" $ do + -- Exercises the encode path when esqlProfileProfiles is populated + -- (the decode-only test above does not re-encode). Uses the + -- idempotency property of the Other-Value pattern. + let raw = + LBS.pack + "{\"shards\":[{\"id\":0}],\"profiles\":[{\"phase\":\"query\",\"description\":\"compute\",\"time\":\"1ms\",\"children\":[{\"phase\":\"aggregation\",\"description\":\"stats\",\"time\":\"0ms\",\"children\":[]}]}]}" + case decode raw of + Nothing -> expectationFailure "initial decode failed" + Just (firstDecode :: ES8Types.EsqlProfile) -> do + case decode (encode firstDecode) of + Nothing -> expectationFailure "re-decode failed" + Just again -> do + again `shouldBe` firstDecode + -- Recursive children survive the round trip with their + -- typed projections intact. + case ES8Types.esqlProfileProfiles again of + Just (topSection : _) + | Just (child : _) <- ES8Types.esqlProfileSectionChildren topSection -> + ES8Types.esqlProfileSectionPhase child `shouldBe` Just "aggregation" + _ -> expectationFailure "expected nested profile children" + + describe "EsqlClusterDetails JSON" $ do + it "preserves a populated _shards block through a decode/encode cycle" $ do + -- Exercises the encode path for the ShardResult projection (the + -- parent EsqlClusters decode test covers decode only). + let raw = + LBS.pack + "{\"status\":\"successful\",\"indices\":\"logs-*\",\"_shards\":{\"total\":4,\"successful\":3,\"skipped\":0,\"failed\":1},\"failures\":[{\"type\":\"shard_failed\",\"reason\":\"corrupt\"}]}" + case decode raw of + Nothing -> expectationFailure "initial decode failed" + Just (firstDecode :: ES8Types.EsqlClusterDetails) -> do + case decode (encode firstDecode) of + Nothing -> expectationFailure "re-decode failed" + Just again -> do + again `shouldBe` firstDecode + ES8Types.esqlClusterDetailsStatus again `shouldBe` Just ES8Types.EsqlClusterStatusSuccessful + let Just shards = ES8Types.esqlClusterDetailsShards again + shardsFailed shards `shouldBe` 1 + ES8Types.esqlClusterDetailsFailures again + `shouldBe` Just [object ["type" .= ("shard_failed" :: Text), "reason" .= ("corrupt" :: Text)]] + + it "re-encodes an empty details map as an empty object (not dropped)" $ do + let clusters = + ES8Types.EsqlClusters + { esqlClustersTotal = 0, + esqlClustersSuccessful = 0, + esqlClustersRunning = 0, + esqlClustersSkipped = 0, + esqlClustersPartial = 0, + esqlClustersFailed = 0, + esqlClustersDetails = [], + esqlClustersOther = object ["details" .= object []] + } + encoded = encode clusters + encoded `shouldSatisfy` hasKey "details" + case decode encoded of + Just (again :: ES8Types.EsqlClusters) -> + ES8Types.esqlClustersDetails again `shouldBe` [] + Nothing -> expectationFailure "re-decode failed" + + describe "endpoint shape" $ do + it "esql POSTs to /_query with no query string" $ do + let req = RequestsES8.esql (minimalReq "FROM x") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_query"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "esql embeds the query field in the body" $ do + let req = RequestsES8.esql (minimalReq "FROM x | LIMIT 1") + let body = bhRequestBody req + body `shouldSatisfy` isJust + let Just bodyBytes = body + hasKey "query" bodyBytes `shouldBe` True + + it "esqlWith with default options is byte-identical to esql (no query string)" $ do + let r1 = RequestsES8.esql (minimalReq "FROM x") + let r2 = RequestsES8.esqlWith (minimalReq "FROM x") ES8Types.defaultESQLQueryOptions + getRawEndpoint (bhRequestEndpoint r1) `shouldBe` getRawEndpoint (bhRequestEndpoint r2) + getRawEndpointQueries (bhRequestEndpoint r1) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint r2) + bhRequestBody r1 `shouldBe` bhRequestBody r2 + + it "esqlWith emits delimiter as a query parameter" $ do + let opts = + ES8Types.defaultESQLQueryOptions + { ES8Types.esqloDelimiter = Just "|" + } + let req = RequestsES8.esqlWith (minimalReq "FROM x") opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_query"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("delimiter", Just "|")] + + it "esqlWith renders booleans as true/false strings" $ do + let opts = + ES8Types.defaultESQLQueryOptions + { ES8Types.esqloDropNullColumns = Just True, + ES8Types.esqloAllowPartialResults = Just False + } + let req = RequestsES8.esqlWith (minimalReq "FROM x") opts + getRawEndpointQueries (bhRequestEndpoint req) + `shouldContain` [("drop_null_columns", Just "true")] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldContain` [("allow_partial_results", Just "false")] + + describe "live integration (requires ES8+ backend)" $ + backendSpecific [ElasticSearch8, ElasticSearch9] $ do + it "returns rows from an indexed document" $ + withTestEnv $ do + _ <- insertData + result <- do + backend <- liftIO detectBackendType + let q = "FROM \"" <> unIndexName testIndex <> "\" | LIMIT 5" + if backend == Just ElasticSearch9 + then ClientES9.esql (minimalES9Req q) + else ClientES8.esql (minimalReq q) + case result of + Left e -> liftIO $ expectationFailure $ "esql failed: " <> show e + Right esqlResult -> liftIO $ do + ES8Types.esqlIsPartial esqlResult `shouldBe` False + ES8Types.esqlColumns esqlResult `shouldNotBe` [] + let values = ES8Types.esqlValues esqlResult + values `shouldNotBe` [] + -- Canned tweet is `user = "bitemyapp"`; assert it appears in the rows + let flattened = concat values + flattened `shouldContain` [String "bitemyapp"] + + describe "Async ES|QL API (POST/GET/DELETE /_query/async)" $ do + describe "AsyncESQLId JSON" $ do + it "round-trips as a bare JSON string" $ do + let i = ES8Types.AsyncESQLId "FmRleEct" + decode (encode i) `shouldBe` Just i + encode i `shouldBe` "\"FmRleEct\"" + + describe "AsyncESQLRequest JSON" $ do + it "merges async-only fields onto the base ESQLRequest body" $ do + let areq = + (ES8Types.mkAsyncESQLRequest (minimalReq "FROM logs | LIMIT 10")) + { ES8Types.asyncESQLRequestWaitForCompletionTimeout = Just "5s", + ES8Types.asyncESQLRequestKeepAlive = Just "10d", + ES8Types.asyncESQLRequestKeepOnCompletion = Just True + } + json = encode areq + json `shouldSatisfy` hasKey "query" + json `shouldSatisfy` hasKey "wait_for_completion_timeout" + json `shouldSatisfy` hasKey "keep_alive" + json `shouldSatisfy` hasKey "keep_on_completion" + + it "omits async fields when they are Nothing" $ do + let areq = ES8Types.mkAsyncESQLRequest (minimalReq "FROM logs | LIMIT 10") + json = encode areq + json `shouldNotSatisfy` hasKey "wait_for_completion_timeout" + json `shouldNotSatisfy` hasKey "keep_alive" + json `shouldNotSatisfy` hasKey "keep_on_completion" + + it "forwards base body fields (columnar/profile/ccs) onto the async body" $ do + let base = + ES8Types.ESQLRequest + { esqlQuery = "FROM logs | LIMIT 10", + esqlLocale = Nothing, + esqlFilter = Nothing, + esqlParams = Nothing, + esqlColumnar = Just True, + esqlProfile = Just True, + esqlTables = Nothing, + esqlIncludeCcsMetadata = Just True + } + areq = ES8Types.mkAsyncESQLRequest base + json = encode areq + json `shouldSatisfy` hasKey "columnar" + json `shouldSatisfy` hasKey "profile" + json `shouldSatisfy` hasKey "include_ccs_metadata" + + it "round-trips a fully-populated AsyncESQLRequest" $ do + let base = + ES8Types.ESQLRequest + { esqlQuery = "FROM logs | LIMIT 10", + esqlLocale = Just "en-US", + esqlFilter = Just (Filter (TermQuery (Term "user" "alice") Nothing)), + esqlParams = Just [toJSON ("foo" :: Text), toJSON (42 :: Int)], + esqlColumnar = Just True, + esqlProfile = Just True, + esqlTables = Nothing, + esqlIncludeCcsMetadata = Just True + } + areq = + (ES8Types.mkAsyncESQLRequest base) + { ES8Types.asyncESQLRequestWaitForCompletionTimeout = Just "5s", + ES8Types.asyncESQLRequestKeepAlive = Just "10d", + ES8Types.asyncESQLRequestKeepOnCompletion = Just True + } + decode (encode areq) `shouldBe` Just areq + + describe "AsyncESQLResult JSON" $ do + it "decodes a deferred submission (id present, query still running)" $ do + let raw = + LBS.pack + "{\"id\":\"FmRleEct\",\"is_running\":true,\"documents_found\":0,\"values_loaded\":0,\"start_time_in_millis\":1700000000000,\"expiration_time_in_millis\":1700000060000,\"columns\":[],\"values\":[]}" + Just result = decode raw + ES8Types.asyncESQLResultId result + `shouldBe` Just (ES8Types.AsyncESQLId "FmRleEct") + ES8Types.asyncESQLResultIsRunning result `shouldBe` True + ES8Types.asyncESQLResultStartTimeInMillis result `shouldBe` Just 1700000000000 + ES8Types.asyncESQLResultExpirationTimeInMillis result `shouldBe` Just 1700000060000 + ES8Types.asyncESQLResultDocumentsFound result `shouldBe` Just 0 + ES8Types.asyncESQLResultValuesLoaded result `shouldBe` Just 0 + ES8Types.asyncESQLResultCompletionTimeInMillis result `shouldSatisfy` isNothing + + it "decodes a completed result with columns, values, completion_time and counters" $ do + let raw = + LBS.pack + "{\"id\":\"FmRleEct\",\"is_running\":false,\"is_partial\":false,\"completion_time_in_millis\":1700000010000,\"took\":42,\"documents_found\":2,\"values_loaded\":4,\"start_time_in_millis\":1700000000000,\"expiration_time_in_millis\":1700000060000,\"columns\":[{\"name\":\"user\",\"type\":\"keyword\"}],\"values\":[[\"alice\"]]}" + Just result = decode raw + ES8Types.asyncESQLResultIsRunning result `shouldBe` False + ES8Types.asyncESQLResultIsPartial result `shouldBe` False + ES8Types.asyncESQLResultCompletionTimeInMillis result `shouldBe` Just 1700000010000 + ES8Types.asyncESQLResultTook result `shouldBe` Just 42 + ES8Types.asyncESQLResultDocumentsFound result `shouldBe` Just 2 + ES8Types.asyncESQLResultValuesLoaded result `shouldBe` Just 4 + ES8Types.asyncESQLResultColumns result + `shouldBe` Just [ES8Types.ESQLColumn "user" "keyword"] + ES8Types.asyncESQLResultValues result `shouldBe` Just [[String "alice"]] + + it "decodes a wait_for_completion_timeout synchronous-completion response (no id)" $ do + let raw = + LBS.pack + "{\"is_running\":false,\"is_partial\":false,\"completion_time_in_millis\":1700000010000,\"took\":7,\"documents_found\":1,\"values_loaded\":1,\"start_time_in_millis\":1700000000000,\"expiration_time_in_millis\":1700000060000,\"columns\":[{\"name\":\"user\",\"type\":\"keyword\"}],\"values\":[[\"bob\"]]}" + Just result = decode raw + ES8Types.asyncESQLResultId result `shouldSatisfy` isNothing + ES8Types.asyncESQLResultIsRunning result `shouldBe` False + ES8Types.asyncESQLResultValues result `shouldBe` Just [[String "bob"]] + + it "decodes a profile section when one is attached" $ do + let raw = + LBS.pack + "{\"is_running\":false,\"is_partial\":false,\"took\":1,\"columns\":[],\"values\":[],\"profile\":{\"query\":{\"took_millis\":1}}}" + Just result = decode raw + ES8Types.asyncESQLResultProfile result + `shouldSatisfy` (isJust :: Maybe ES8Types.EsqlProfile -> Bool) + -- The {"query": {...}} payload has no typed projections (ES|QL + -- marks profile as unstable) so it round-trips via esqlProfileOther. + let Just profile = ES8Types.asyncESQLResultProfile result + ES8Types.esqlProfileOther profile + `shouldBe` object ["query" .= object ["took_millis" .= (1 :: Int)]] + + it "decodes an attached _clusters object (async get CCS metadata)" $ do + let raw = + LBS.pack + "{\"is_running\":false,\"is_partial\":false,\"took\":1,\"columns\":[],\"values\":[],\"_clusters\":{\"total\":2,\"successful\":2,\"running\":0,\"skipped\":0,\"partial\":0,\"failed\":0,\"details\":{\"remote_one\":{\"status\":\"successful\",\"indices\":\"logs-*\"}}}}" + Just result = decode raw + let Just clusters = ES8Types.asyncESQLResultClusters result + ES8Types.esqlClustersTotal clusters `shouldBe` 2 + ES8Types.esqlClustersSuccessful clusters `shouldBe` 2 + ES8Types.esqlClustersDetails clusters + `shouldBe` [ ( "remote_one", + ES8Types.EsqlClusterDetails + { esqlClusterDetailsStatus = Just ES8Types.EsqlClusterStatusSuccessful, + esqlClusterDetailsIndices = Just "logs-*", + esqlClusterDetailsShards = Nothing, + esqlClusterDetailsFailures = Nothing, + esqlClusterDetailsOther = + object + [ "status" .= ("successful" :: Text), + "indices" .= ("logs-*" :: Text) + ] + } + ) + ] + + it "defaults is_running to False and is_partial to True when keys are absent" $ do + let raw = LBS.pack "{\"id\":\"Fm_==_RxD_123\"}" + Just result = decode raw + ES8Types.asyncESQLResultIsRunning result `shouldBe` False + ES8Types.asyncESQLResultIsPartial result `shouldBe` True + + it "rejects malformed input (non-object)" $ + decode (LBS.pack "[1,2,3]") `shouldSatisfy` (isNothing :: Maybe ES8Types.AsyncESQLResult -> Bool) + + describe "endpoint shape" $ do + it "esqlAsync POSTs to /_query/async with no query string (params go in the body)" $ do + let req = + RequestsES8.esqlAsync $ + ES8Types.mkAsyncESQLRequest $ + minimalReq "FROM x" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_query", "async"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "esqlAsync embeds wait_for_completion_timeout in the body when set" $ do + let areq = + ( ES8Types.mkAsyncESQLRequest $ + minimalReq "FROM x" + ) + { ES8Types.asyncESQLRequestWaitForCompletionTimeout = Just "5s" + } + req = RequestsES8.esqlAsync areq + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_query", "async"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + let Just bodyBytes = bhRequestBody req + hasKey "wait_for_completion_timeout" bodyBytes `shouldBe` True + + it "esqlAsync embeds the query field in the body" $ do + let req = + RequestsES8.esqlAsync $ + ES8Types.mkAsyncESQLRequest $ + minimalReq "FROM x | LIMIT 1" + let Just bodyBytes = bhRequestBody req + hasKey "query" bodyBytes `shouldBe` True + + it "esqlAsyncWith with default options is byte-identical to esqlAsync (no query string)" $ do + let base = ES8Types.mkAsyncESQLRequest (minimalReq "FROM x") + r1 = RequestsES8.esqlAsync base + r2 = RequestsES8.esqlAsyncWith base ES8Types.defaultESQLQueryOptions + getRawEndpoint (bhRequestEndpoint r1) `shouldBe` getRawEndpoint (bhRequestEndpoint r2) + getRawEndpointQueries (bhRequestEndpoint r1) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint r2) + bhRequestBody r1 `shouldBe` bhRequestBody r2 + + it "esqlAsyncWith emits delimiter/drop_null_columns/allow_partial_results as query params" $ do + let opts = + ES8Types.defaultESQLQueryOptions + { ES8Types.esqloDelimiter = Just "|", + ES8Types.esqloDropNullColumns = Just True, + ES8Types.esqloAllowPartialResults = Just False + } + req = + RequestsES8.esqlAsyncWith + (ES8Types.mkAsyncESQLRequest (minimalReq "FROM x")) + opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_query", "async"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldContain` [("delimiter", Just "|")] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldContain` [("drop_null_columns", Just "true")] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldContain` [("allow_partial_results", Just "false")] + + it "getAsyncESQL GETs /_query/async/{id} with no query when timeout is Nothing" $ do + let req = RequestsES8.getAsyncESQL (ES8Types.AsyncESQLId "Fm_==_RxD_123") Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_query", "async", "Fm_==_RxD_123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "getAsyncESQL forwards wait_for_completion_timeout as a query string" $ do + let req = RequestsES8.getAsyncESQL (ES8Types.AsyncESQLId "abc") (Just "5s") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_query", "async", "abc"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("wait_for_completion_timeout", Just "5s")] + + it "getAsyncESQLWith with default options matches getAsyncESQL with no timeout" $ do + let r1 = RequestsES8.getAsyncESQL (ES8Types.AsyncESQLId "abc") Nothing + r2 = RequestsES8.getAsyncESQLWith (ES8Types.AsyncESQLId "abc") ES8Types.defaultGetAsyncESQLOptions + getRawEndpoint (bhRequestEndpoint r1) `shouldBe` getRawEndpoint (bhRequestEndpoint r2) + getRawEndpointQueries (bhRequestEndpoint r1) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint r2) + + it "getAsyncESQLWith forwards wait_for_completion_timeout from the options record" $ do + let opts = ES8Types.defaultGetAsyncESQLOptions {ES8Types.gaesqloWaitForCompletionTimeout = Just "5s"} + req = RequestsES8.getAsyncESQLWith (ES8Types.AsyncESQLId "abc") opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_query", "async", "abc"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("wait_for_completion_timeout", Just "5s")] + + it "getAsyncESQLWith emits keep_alive and drop_null_columns as query params" $ do + let opts = + ES8Types.defaultGetAsyncESQLOptions + { ES8Types.gaesqloKeepAlive = Just "10d", + ES8Types.gaesqloDropNullColumns = Just True + } + req = RequestsES8.getAsyncESQLWith (ES8Types.AsyncESQLId "abc") opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_query", "async", "abc"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldContain` [("keep_alive", Just "10d")] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldContain` [("drop_null_columns", Just "true")] + + it "deleteAsyncESQL DELETEs /_query/async/{id} with no query" $ do + let req = RequestsES8.deleteAsyncESQL (ES8Types.AsyncESQLId "FmRleEct") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_query", "async", "FmRleEct"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "stopAsyncESQL POSTs /_query/async/{id}/stop with no query" $ do + let req = RequestsES8.stopAsyncESQL (ES8Types.AsyncESQLId "FmRleEct") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_query", "async", "FmRleEct", "stop"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "live integration (requires ES8+ backend)" $ + backendSpecific [ElasticSearch8, ElasticSearch9] $ do + it "submit→poll→delete round-trip returns rows from an indexed document" $ + withTestEnv $ do + _ <- insertData + backend <- liftIO detectBackendType + let q = "FROM \"" <> unIndexName testIndex <> "\" | LIMIT 5" + -- wait_for_completion_timeout=5s + keep_on_completion=true so + -- the POST returns a completed result *and* stores it under + -- an id we can poll and delete. + submitted <- + if backend == Just ElasticSearch9 + then + ClientES9.esqlAsync $ + (ES9Types.mkAsyncESQLRequest (minimalES9Req q)) + { ES9Types.asyncESQLRequestWaitForCompletionTimeout = Just "5s", + ES9Types.asyncESQLRequestKeepOnCompletion = Just True + } + else + ClientES8.esqlAsync $ + (ES8Types.mkAsyncESQLRequest (minimalReq q)) + { ES8Types.asyncESQLRequestWaitForCompletionTimeout = Just "5s", + ES8Types.asyncESQLRequestKeepOnCompletion = Just True + } + case submitted of + Left e -> + liftIO $ expectationFailure $ "esqlAsync failed: " <> show e + Right sub -> do + liftIO $ ES8Types.asyncESQLResultIsRunning sub `shouldBe` False + case ES8Types.asyncESQLResultId sub of + Nothing -> + -- Server completed synchronously but did not retain the + -- result (no keep_on_completion in this branch). Nothing + -- to poll or delete; assert the rows were returned. + liftIO $ + ES8Types.asyncESQLResultValues sub + `shouldSatisfy` (isJust :: Maybe [[Value]] -> Bool) + Just asyncId -> do + polled <- + if backend == Just ElasticSearch9 + then ClientES9.getAsyncESQL asyncId (Just "5s") + else ClientES8.getAsyncESQL asyncId (Just "5s") + liftIO $ + case polled of + Left e -> + expectationFailure $ "getAsyncESQL failed: " <> show e + Right polledRes -> do + ES8Types.asyncESQLResultIsRunning polledRes `shouldBe` False + ES8Types.asyncESQLResultColumns polledRes `shouldSatisfy` isJust + del <- + if backend == Just ElasticSearch9 + then ClientES9.deleteAsyncESQL asyncId + else ClientES8.deleteAsyncESQL asyncId + liftIO $ del `shouldBe` Acknowledged True + + it "surfaces an EsError for a non-existent async ES|QL id" $ + withTestEnv $ do + -- Submit a real async query, retaining its result under an id + -- (keep_on_completion=true). DELETE it once so the id is + -- validly-formatted but purged, then DELETE the same id again: + -- a genuinely non-existent (already-purged) id yields a 404, + -- whereas a malformed id would yield a 400. This exercises the + -- real 'non-existent' path the 'StatusDependant' handler decodes. + backend <- liftIO detectBackendType + submitted <- + if backend == Just ElasticSearch9 + then + ClientES9.esqlAsync $ + (ES9Types.mkAsyncESQLRequest (minimalES9Req "ROW x = 1")) + { ES9Types.asyncESQLRequestWaitForCompletionTimeout = Just "5s", + ES9Types.asyncESQLRequestKeepOnCompletion = Just True + } + else + ClientES8.esqlAsync $ + (ES8Types.mkAsyncESQLRequest (minimalReq "ROW x = 1")) + { ES8Types.asyncESQLRequestWaitForCompletionTimeout = Just "5s", + ES8Types.asyncESQLRequestKeepOnCompletion = Just True + } + case submitted of + Left e + | endpointMissing e -> + liftIO $ pendingWith "async ES|QL requires Elasticsearch 8+" + | otherwise -> + liftIO $ expectationFailure $ "esqlAsync failed: " <> show e + Right sub -> case ES8Types.asyncESQLResultId sub of + Nothing -> + liftIO $ + pendingWith + "async submission did not retain an id (keep_on_completion=true)" + Just asyncId -> do + firstDel <- + if backend == Just ElasticSearch9 + then ClientES9.deleteAsyncESQL asyncId + else ClientES8.deleteAsyncESQL asyncId + liftIO $ firstDel `shouldBe` Acknowledged True + result <- + tryEsError $ + if backend == Just ElasticSearch9 + then ClientES9.deleteAsyncESQL asyncId + else ClientES8.deleteAsyncESQL asyncId + liftIO $ + case result of + Left err -> errorStatus err `shouldBe` Just 404 + Right r -> + expectationFailure $ + "expected EsError for purged async ES|QL id, got: " <> show r + + describe "stop running async query (requires ES8.11+)" $ + backendSpecific [ElasticSearch8, ElasticSearch9] $ do + it "submit→stop returns the final result with is_running=false" $ + withTestEnv $ do + -- Submit a long-running async query (wait_for_completion_timeout=0ms + -- forces the server to defer; keep_alive=5m retains the result under + -- an id we can stop and then clean up). + backend <- liftIO detectBackendType + submitted <- + if backend == Just ElasticSearch9 + then + ClientES9.esqlAsync $ + (ES9Types.mkAsyncESQLRequest (minimalES9Req "ROW x = 1")) + { ES9Types.asyncESQLRequestWaitForCompletionTimeout = Just "0ms", + ES9Types.asyncESQLRequestKeepAlive = Just "5m" + } + else + ClientES8.esqlAsync $ + (ES8Types.mkAsyncESQLRequest (minimalReq "ROW x = 1")) + { ES8Types.asyncESQLRequestWaitForCompletionTimeout = Just "0ms", + ES8Types.asyncESQLRequestKeepAlive = Just "5m" + } + case submitted of + Left e + | endpointMissing e -> + liftIO $ pendingWith "stopAsyncESQL requires Elasticsearch 8.11+" + | otherwise -> + liftIO $ expectationFailure $ "esqlAsync failed: " <> show e + Right sub -> case ES8Types.asyncESQLResultId sub of + Nothing -> + liftIO $ + pendingWith + "Async submission did not return an id to stop (server completed synchronously)" + Just asyncId -> do + stopResp <- + if backend == Just ElasticSearch9 + then ClientES9.stopAsyncESQL asyncId + else ClientES8.stopAsyncESQL asyncId + case stopResp of + Left e + | endpointMissing e -> + liftIO $ pendingWith "stopAsyncESQL requires Elasticsearch 8.11+" + | otherwise -> + liftIO $ expectationFailure $ "stopAsyncESQL failed: " <> show e + Right stopped -> liftIO $ do + ES8Types.asyncESQLResultIsRunning stopped `shouldBe` False + ES8Types.asyncESQLResultColumns stopped `shouldSatisfy` isJust + -- Clean up the retained async result regardless of outcome. + void $ + tryEsError $ + if backend == Just ElasticSearch9 + then ClientES9.deleteAsyncESQL asyncId + else ClientES8.deleteAsyncESQL asyncId + +-- | Detect the @no handler found for uri@ shape returned by Elasticsearch +-- when an endpoint isn't registered on this version. Mirrors the helper in +-- "Test.EsQueryViewsSpec". +endpointMissing :: EsError -> Bool +endpointMissing e = + "no handler found" `T.isInfixOf` T.toLower (errorMessage e) diff --git a/tests/Test/EsQueryViewsSpec.hs b/tests/Test/EsQueryViewsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/EsQueryViewsSpec.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.EsQueryViewsSpec (spec) where + +import Data.Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Maybe (isJust, isNothing) +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch8.Types qualified as ES8Types +import Database.Bloodhound.ElasticSearch9.Client qualified as ClientES9 +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import Database.Bloodhound.ElasticSearch9.Types qualified as ES9Types +import TestsUtils.Common +import TestsUtils.Import + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +spec :: Spec +spec = describe "ES|QL Views and running-query APIs" $ do + describe "ESQLViewName JSON" $ do + it "round-trips as a bare JSON string" $ do + let n = ES9Types.ESQLViewName "my-view" + decode (encode n) `shouldBe` Just n + encode n `shouldBe` "\"my-view\"" + + it "supports IsString literal syntax" $ do + let n = ("literal" :: ES9Types.ESQLViewName) + ES9Types.unESQLViewName n `shouldBe` "literal" + + describe "ESQLView JSON" $ do + it "encodes a minimal view (name + query required)" $ do + let v = + ES9Types.ESQLView + { esqlViewName = "logs-view", + esqlViewQuery = "FROM logs | KEEP @timestamp, message | LIMIT 10" + } + let json = encode v + json `shouldSatisfy` hasKey "name" + json `shouldSatisfy` hasKey "query" + + it "decodes the wire shape returned by GET /_query/view/{name}" $ do + let raw = + LBS.pack + "{\"name\":\"logs-view\",\"query\":\"FROM logs | LIMIT 10\"}" + let expected = + ES9Types.ESQLView + { esqlViewName = "logs-view", + esqlViewQuery = "FROM logs | LIMIT 10" + } + decode raw `shouldBe` Just expected + + it "decodes the {\"views\":[...]} envelope returned by ES 9.4+" $ do + -- GET /_query/view/{name} on ES 9.4 wraps the single view in a + -- `views` array. The parser must unwrap it transparently. + let raw = + LBS.pack + "{\"views\":[{\"name\":\"logs-view\",\"query\":\"FROM logs | LIMIT 10\"}]}" + let expected = + ES9Types.ESQLView + { esqlViewName = "logs-view", + esqlViewQuery = "FROM logs | LIMIT 10" + } + decode raw `shouldBe` Just expected + + it "rejects an empty {\"views\":[]} envelope" $ do + let raw = LBS.pack "{\"views\":[]}" + decode raw `shouldSatisfy` (isNothing :: Maybe ES9Types.ESQLView -> Bool) + + it "round-trips through ToJSON/FromJSON" $ do + let v = + ES9Types.ESQLView + { esqlViewName = "v", + esqlViewQuery = "ROW x = 1" + } + decode (encode v) `shouldBe` Just v + + it "rejects a payload missing the required query field" $ do + let raw = LBS.pack "{\"name\":\"v\"}" + decode raw `shouldSatisfy` (isNothing :: Maybe ES9Types.ESQLView -> Bool) + + it "rejects a payload missing the required name field" $ do + let raw = LBS.pack "{\"query\":\"ROW x = 1\"}" + decode raw `shouldSatisfy` (isNothing :: Maybe ES9Types.ESQLView -> Bool) + + it "rejects malformed input (non-object)" $ + decode (LBS.pack "[1,2,3]") `shouldSatisfy` (isNothing :: Maybe ES9Types.ESQLView -> Bool) + + describe "ESQLQueryInfo JSON" $ do + -- The OpenAPI spec lists id/node/coordinating_node/data_nodes as + -- required, but ES 9.3 GA omits them on single-node clusters. The + -- decoder must therefore tolerate their absence. The fields ES 9.3 + -- actually emits on this endpoint are start_time_millis, + -- running_time_nanos and query (the documents_found/values_loaded + -- counters belong to the AsyncESQLResult shape, not this one). + let observedShapeRaw = + LBS.pack + "{\"start_time_millis\":1782072118262,\"running_time_nanos\":1032189,\"query\":\"ROW x = 1\"}" + observedShapeExpected = + ES9Types.ESQLQueryInfo + { esqlQueryInfoId = Nothing, + esqlQueryInfoNode = Nothing, + esqlQueryInfoStartTimeMillis = Just 1782072118262, + esqlQueryInfoRunningTimeNanos = Just 1032189, + esqlQueryInfoQuery = "ROW x = 1", + esqlQueryInfoCoordinatingNode = Nothing, + esqlQueryInfoDataNodes = Nothing + } + -- The shape the OpenAPI spec promises — multi-node clusters or + -- future ES versions may emit it. The decoder must accept every + -- documented field. + fullSpecRaw = + LBS.pack + "{\"id\":223601,\"node\":\"node-1\",\"start_time_millis\":1782071481880,\"running_time_nanos\":1500000,\"query\":\"FROM logs | LIMIT 10\",\"coordinating_node\":\"coord-1\",\"data_nodes\":[\"data-1\",\"data-2\"]}" + fullSpecExpected = + ES9Types.ESQLQueryInfo + { esqlQueryInfoId = Just 223601, + esqlQueryInfoNode = Just "node-1", + esqlQueryInfoStartTimeMillis = Just 1782071481880, + esqlQueryInfoRunningTimeNanos = Just 1500000, + esqlQueryInfoQuery = "FROM logs | LIMIT 10", + esqlQueryInfoCoordinatingNode = Just "coord-1", + esqlQueryInfoDataNodes = Just ["data-1", "data-2"] + } + + it "decodes the wire shape observed on an ES 9.3 single-node cluster" $ + decode observedShapeRaw `shouldBe` Just observedShapeExpected + + it "decodes the full shape documented in the OpenAPI spec" $ + decode fullSpecRaw `shouldBe` Just fullSpecExpected + + it "exposes every field through its lens on the observed shape" $ do + let Just parsed = decode observedShapeRaw + ES9Types.esqlQueryInfoId parsed `shouldSatisfy` isNothing + ES9Types.esqlQueryInfoNode parsed `shouldSatisfy` isNothing + ES9Types.esqlQueryInfoStartTimeMillis parsed `shouldBe` Just 1782072118262 + ES9Types.esqlQueryInfoRunningTimeNanos parsed `shouldBe` Just 1032189 + ES9Types.esqlQueryInfoQuery parsed `shouldBe` "ROW x = 1" + ES9Types.esqlQueryInfoCoordinatingNode parsed `shouldSatisfy` isNothing + ES9Types.esqlQueryInfoDataNodes parsed `shouldSatisfy` isNothing + + it "exposes every field through its lens on the spec shape" $ do + let Just parsed = decode fullSpecRaw + ES9Types.esqlQueryInfoId parsed `shouldBe` Just 223601 + ES9Types.esqlQueryInfoNode parsed `shouldBe` Just "node-1" + ES9Types.esqlQueryInfoCoordinatingNode parsed `shouldBe` Just "coord-1" + ES9Types.esqlQueryInfoDataNodes parsed `shouldBe` Just ["data-1", "data-2"] + + it "rejects a payload missing the required query field" $ + let malformed = LBS.pack "{\"id\":1,\"node\":\"n\"}" + in decode malformed `shouldSatisfy` (isNothing :: Maybe ES9Types.ESQLQueryInfo -> Bool) + + it "rejects malformed input (non-object)" $ + decode (LBS.pack "42") `shouldSatisfy` (isNothing :: Maybe ES9Types.ESQLQueryInfo -> Bool) + + describe "ESQLQueryListResponse JSON" $ do + -- The live endpoint returns {"queries": {"": {...}}} + -- — an object keyed by async-id, NOT a bare array. The decoder + -- flattens it into [(AsyncESQLId, ESQLQueryInfo)] so callers keep the + -- id they need to act on a listed query. + let observedInfo = + ES9Types.ESQLQueryInfo + { esqlQueryInfoId = Nothing, + esqlQueryInfoNode = Nothing, + esqlQueryInfoStartTimeMillis = Just 1782072118262, + esqlQueryInfoRunningTimeNanos = Just 1032189, + esqlQueryInfoQuery = "ROW x = 1", + esqlQueryInfoCoordinatingNode = Nothing, + esqlQueryInfoDataNodes = Nothing + } + specInfo = + ES9Types.ESQLQueryInfo + { esqlQueryInfoId = Just 223601, + esqlQueryInfoNode = Just "node-1", + esqlQueryInfoStartTimeMillis = Just 1782071481880, + esqlQueryInfoRunningTimeNanos = Just 1500000, + esqlQueryInfoQuery = "FROM logs | LIMIT 10", + esqlQueryInfoCoordinatingNode = Just "coord-1", + esqlQueryInfoDataNodes = Just ["data-1", "data-2"] + } + observedJson = + "{\"start_time_millis\":1782072118262,\"running_time_nanos\":1032189,\"query\":\"ROW x = 1\"}" + specJson = + "{\"id\":223601,\"node\":\"node-1\",\"start_time_millis\":1782071481880,\"running_time_nanos\":1500000,\"query\":\"FROM logs | LIMIT 10\",\"coordinating_node\":\"coord-1\",\"data_nodes\":[\"data-1\",\"data-2\"]}" + liveAsyncId = "FmpYLUxnNVZyVE5pZ0gzNXZOdXpHYUEdZGhxczRoSWpUSWU5WEJrQ2ZaTzM0dzoxMjg1Nzc=" + it "decodes the live {\"queries\":{id:{...}}} keyed-map shape" $ + let raw = LBS.pack $ "{\"queries\":{\"" <> liveAsyncId <> "\":" <> observedJson <> "}}" + in fmap ES9Types.unESQLQueryListResponse (decode raw) + `shouldBe` Just [(ES8Types.AsyncESQLId (T.pack liveAsyncId), observedInfo)] + + it "decodes a bare keyed map (no queries wrapper)" $ + let raw = LBS.pack $ "{\"query-1\":" <> specJson <> "}" + in fmap ES9Types.unESQLQueryListResponse (decode raw) + `shouldBe` Just [(ES8Types.AsyncESQLId "query-1", specInfo)] + + it "decodes multiple entries under queries" $ + let raw = + LBS.pack $ + "{\"queries\":{\"a\":" <> observedJson <> ",\"b\":" <> specJson <> "}}" + in fmap ES9Types.unESQLQueryListResponse (decode raw) + `shouldBe` Just [(ES8Types.AsyncESQLId "a", observedInfo), (ES8Types.AsyncESQLId "b", specInfo)] + + it "decodes an empty queries object as []" $ + fmap ES9Types.unESQLQueryListResponse (decode (LBS.pack "{\"queries\":{}}")) `shouldBe` Just [] + + it "rejects a {\"queries\":[...]} array value" $ + let raw = LBS.pack "{\"queries\":[{\"query\":\"x\"}]}" + in decode raw `shouldSatisfy` (isNothing :: Maybe ES9Types.ESQLQueryListResponse -> Bool) + + it "rejects a non-object top-level payload" $ + decode (LBS.pack "\"just a string\"") + `shouldSatisfy` (isNothing :: Maybe ES9Types.ESQLQueryListResponse -> Bool) + + describe "endpoint shape" $ do + -- These endpoints (ES 9.4+ views, ES 9.1+ running-query introspection) + -- do not exist on Elasticsearch 8.x, so the canonical request builders + -- live only in "Database.Bloodhound.ElasticSearch9.Requests". The + -- endpoint/path assertions below guard against any future drift. + it "putESQLView PUTs to /_query/view/{name} with a query body (ES9)" $ do + let req = RequestsES9.putESQLView "my-view" "FROM logs | LIMIT 10" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_query", "view", "my-view"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + let Just bodyBytes = bhRequestBody req + hasKey "query" bodyBytes `shouldBe` True + -- Body must NOT carry a "name" field — name comes from the path. + hasKey "name" bodyBytes `shouldBe` False + + it "getESQLView GETs /_query/view/{name} with no body (ES9)" $ do + let req = RequestsES9.getESQLView "my-view" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_query", "view", "my-view"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldSatisfy` isNothing + + it "deleteESQLView DELETEs /_query/view/{name} with no body (ES9)" $ do + let req = RequestsES9.deleteESQLView "my-view" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_query", "view", "my-view"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldSatisfy` isNothing + + it "getESQLQuery GETs /_query/queries/{id} with no body (ES9)" $ do + let req = RequestsES9.getESQLQuery (ES8Types.AsyncESQLId "Fm_==_RxD_123") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_query", "queries", "Fm_==_RxD_123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldSatisfy` isNothing + + it "getESQLQueries GETs /_query/queries with no body (ES9)" $ do + let req = RequestsES9.getESQLQueries + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_query", "queries"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldSatisfy` isNothing + + describe "live integration (requires ES9.4+ for views; ES9.1+ for queries)" $ do + -- ES|QL views are experimental, added in 9.4.0. The current + -- docker-compose ships ES 9.3.0, where PUT/GET/DELETE /_query/view + -- return HTTP 400 "no handler found". These tests therefore + -- `pendingWith` out on backends that lack the endpoints, but + -- remain structurally valid against a 9.4+ cluster. + backendSpecific [ElasticSearch9] $ do + it "round-trips an ES|QL view via PUT then GET then DELETE" $ + withTestEnv $ do + let viewName = ES9Types.ESQLViewName "bloodhound-test-esql-view" + -- Clean up any pre-existing view from a prior run. + _ <- tryEsError $ ClientES9.deleteESQLView viewName + putResp <- tryEsError $ ClientES9.putESQLView viewName "FROM logs | LIMIT 10" + case putResp of + Left e + | endpointMissing e -> + liftIO $ pendingWith "ES|QL views require Elasticsearch 9.4+" + | otherwise -> + liftIO $ expectationFailure $ "putESQLView failed: " <> show e + Right _ -> do + getResp <- tryEsError $ ClientES9.getESQLView viewName + liftIO $ + case getResp of + Left e -> expectationFailure $ "getESQLView failed: " <> show e + Right v -> do + ES9Types.esqlViewName v `shouldBe` ES9Types.unESQLViewName viewName + ES9Types.esqlViewQuery v `shouldBe` "FROM logs | LIMIT 10" + delResp <- tryEsError $ ClientES9.deleteESQLView viewName + liftIO $ + case delResp of + Left e -> expectationFailure $ "deleteESQLView failed: " <> show e + Right _ -> pure () + + it "fetches information about a running ES|QL query" $ + withTestEnv $ do + -- Submit a long-running async query, then poll /_query/queries/{id}. + let base = + ES9Types.ESQLRequest + { esqlQuery = "ROW x = 1", + esqlLocale = Nothing, + esqlTimeZone = Nothing, + esqlFilter = Nothing, + esqlParams = Nothing, + esqlColumnar = Nothing, + esqlProfile = Nothing, + esqlTables = Nothing, + esqlIncludeCcsMetadata = Nothing, + esqlIncludeExecutionMetadata = Nothing + } + areq = + (ES9Types.mkAsyncESQLRequest base) + { ES9Types.asyncESQLRequestWaitForCompletionTimeout = Just "0ms", + ES9Types.asyncESQLRequestKeepAlive = Just "5m" + } + submitted <- ClientES9.esqlAsync areq + case submitted of + Left e + | queryNotRunning e -> + liftIO $ pendingWith "Query completed before we could introspect it" + | otherwise -> + liftIO $ expectationFailure $ "esqlAsync failed: " <> show e + Right r -> case ES8Types.asyncESQLResultId r of + Nothing -> liftIO $ pendingWith "Async submission did not return an id to poll" + Just aid -> do + infoResp <- tryEsError $ ClientES9.getESQLQuery aid + case infoResp of + Left e + | queryNotRunning e -> + liftIO $ pendingWith "Query completed before we could introspect it" + | otherwise -> + liftIO $ expectationFailure $ "getESQLQuery failed: " <> show e + Right info -> liftIO $ do + ES9Types.esqlQueryInfoQuery info `shouldBe` "ROW x = 1" + ES9Types.esqlQueryInfoStartTimeMillis info `shouldSatisfy` isJust + ES9Types.esqlQueryInfoRunningTimeNanos info `shouldSatisfy` isJust + -- Clean up. + void $ tryEsError $ ClientES9.deleteAsyncESQL aid + + it "lists a running ES|QL query via GET /_query/queries" $ + withTestEnv $ do + -- Submit a long-running async query, then list /_query/queries + -- and confirm the submitted query is among the running ones. + let base = + ES9Types.ESQLRequest + { esqlQuery = "ROW x = 1", + esqlLocale = Nothing, + esqlTimeZone = Nothing, + esqlFilter = Nothing, + esqlParams = Nothing, + esqlColumnar = Nothing, + esqlProfile = Nothing, + esqlTables = Nothing, + esqlIncludeCcsMetadata = Nothing, + esqlIncludeExecutionMetadata = Nothing + } + areq = + (ES9Types.mkAsyncESQLRequest base) + { ES9Types.asyncESQLRequestWaitForCompletionTimeout = Just "0ms", + ES9Types.asyncESQLRequestKeepAlive = Just "5m" + } + submitted <- ClientES9.esqlAsync areq + case submitted of + Left e + | queryNotRunning e -> + liftIO $ pendingWith "Query completed before we could introspect it" + | otherwise -> + liftIO $ expectationFailure $ "esqlAsync failed: " <> show e + Right r -> case ES8Types.asyncESQLResultId r of + Nothing -> liftIO $ pendingWith "Async submission did not return an id to poll" + Just aid -> do + listResp <- tryEsError $ ClientES9.getESQLQueries + case listResp of + Left e -> + liftIO $ expectationFailure $ "getESQLQueries failed: " <> show e + Right infos -> + liftIO $ + if any (("ROW x = 1" ==) . ES9Types.esqlQueryInfoQuery . snd) infos + then pure () + else + pendingWith + "Submitted query completed before appearing in GET /_query/queries" + -- Clean up. + void $ tryEsError $ ClientES9.deleteAsyncESQL aid + +-- | Detect the @no handler found for uri@shape returned by Elasticsearch +-- when an endpoint isn't registered on this version (e.g. ES|QL views +-- on 9.3.0). Used to mark the live view tests as 'pendingWith' rather +-- than failing. +endpointMissing :: EsError -> Bool +endpointMissing e = + "no handler found" `T.isInfixOf` T.toLower (errorMessage e) + +-- | Detect the @task isn't running@shape returned by +-- @GET /_query/queries/{id}@ when the queried async query has already +-- completed and been purged from the running-queries registry. Common +-- for sub-second queries; the test treats this as a soft skip. +queryNotRunning :: EsError -> Bool +queryNotRunning e = + let msg = T.toLower (errorMessage e) + in "isn't running" `T.isInfixOf` msg || "not running" `T.isInfixOf` msg diff --git a/tests/Test/EventQueryLanguageSpec.hs b/tests/Test/EventQueryLanguageSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/EventQueryLanguageSpec.hs @@ -0,0 +1,941 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.EventQueryLanguageSpec (spec) where + +import Data.Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.HashMap.Strict (singleton) +import Data.List (sortOn) +import Data.Text qualified as T +import Data.Text qualified as Text +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch7.Client qualified as ClientES7 +import Database.Bloodhound.ElasticSearch7.Requests qualified as RequestsES7 +import Database.Bloodhound.ElasticSearch7.Types qualified as ES7Types +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch8.Requests qualified as RequestsES8 +import Database.Bloodhound.ElasticSearch9.Client qualified as ClientES9 +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import TestsUtils.Common +import TestsUtils.Import + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +-- | Order-insensitive comparison helper for query-parameter lists, since +-- 'withQueries' is order-insensitive and the two param renderers do not +-- guarantee a stable inter-key ordering. Mirrors the helper in +-- "Test.PointInTimeSpec". +sortPairs :: [(Text.Text, Maybe Text.Text)] -> [(Text.Text, Maybe Text.Text)] +sortPairs = sortOn fst + +-- | Minimal request value carrying only the required 'eqlQuery' field. +minimalRequest :: ES7Types.EQLRequest +minimalRequest = + ES7Types.EQLRequest + { ES7Types.eqlQuery = "process where process.name == \"cmd.exe\"", + ES7Types.eqlWaitForCompletionTimeout = Nothing, + ES7Types.eqlKeepOnCompletion = Nothing, + ES7Types.eqlKeepAlive = Nothing, + ES7Types.eqlSize = Nothing, + ES7Types.eqlFetchSize = Nothing, + ES7Types.eqlFields = Nothing, + ES7Types.eqlFilter = Nothing, + ES7Types.eqlResultPosition = Nothing, + ES7Types.eqlTiebreakerField = Nothing, + ES7Types.eqlEventCategoryField = Nothing, + ES7Types.eqlTimestampField = Nothing, + ES7Types.eqlRuntimeMappings = Nothing, + ES7Types.eqlAllowPartialSearchResults = Nothing, + ES7Types.eqlAllowPartialSequenceResults = Nothing, + ES7Types.eqlCaseSensitive = Nothing + } + +-- | Fully-populated request value with every optional field set. +fullRequest :: ES7Types.EQLRequest +fullRequest = + ES7Types.EQLRequest + { ES7Types.eqlQuery = "process where process.name == \"cmd.exe\"", + ES7Types.eqlWaitForCompletionTimeout = Just "5s", + ES7Types.eqlKeepOnCompletion = Just True, + ES7Types.eqlKeepAlive = Just "1m", + ES7Types.eqlSize = Just 100, + ES7Types.eqlFetchSize = Just 50, + ES7Types.eqlFields = Just [toJSON ("@timestamp" :: Text)], + ES7Types.eqlFilter = Just (Filter (TermQuery (Term "user" "alice") Nothing)), + ES7Types.eqlResultPosition = Just ES7Types.EQLTail, + ES7Types.eqlTiebreakerField = Just "tiebreaker", + ES7Types.eqlEventCategoryField = Just "event.category", + ES7Types.eqlTimestampField = Just "@timestamp", + ES7Types.eqlRuntimeMappings = + Just + ( RuntimeMappings + ( singleton + "day_of_week" + (RuntimeMapping RuntimeTypeKeyword Nothing) + ) + ), + ES7Types.eqlAllowPartialSearchResults = Just True, + ES7Types.eqlAllowPartialSequenceResults = Just False, + ES7Types.eqlCaseSensitive = Just True + } + +-- | EQL async response body carrying an @id@: the search is still +-- running, so no @hits@/@total@ are present. +sampleAsyncResponseWithId :: LBS.ByteString +sampleAsyncResponseWithId = + LBS.pack + "{\"id\":\"FmRleEctRXJtaVNZQ1I2UkJoTDJfQkEAAAAAAAAUX0Q2UkRLNEVBYlhVZ19VUUZmeld3Zw==\",\"is_running\":true,\"timed_out\":false,\"took\":1}" + +spec :: Spec +spec = describe "EQL Search API (POST /{index}/_eql/search)" $ do + describe "EQLRequest JSON" $ do + it "serializes the required query field" $ do + let json = encode minimalRequest + json `shouldSatisfy` hasKey "query" + + it "omits all optional Nothing fields" $ do + let json = encode minimalRequest + json `shouldNotSatisfy` hasKey "wait_for_completion_timeout" + json `shouldNotSatisfy` hasKey "keep_on_completion" + json `shouldNotSatisfy` hasKey "keep_alive" + json `shouldNotSatisfy` hasKey "size" + json `shouldNotSatisfy` hasKey "fetch_size" + json `shouldNotSatisfy` hasKey "fields" + json `shouldNotSatisfy` hasKey "filter" + json `shouldNotSatisfy` hasKey "result_position" + json `shouldNotSatisfy` hasKey "tiebreaker_field" + json `shouldNotSatisfy` hasKey "event_category_field" + json `shouldNotSatisfy` hasKey "timestamp_field" + json `shouldNotSatisfy` hasKey "runtime_mappings" + json `shouldNotSatisfy` hasKey "allow_partial_search_results" + json `shouldNotSatisfy` hasKey "allow_partial_sequence_results" + json `shouldNotSatisfy` hasKey "case_sensitive" + + it "includes optional fields when set" $ do + let json = encode fullRequest + json `shouldSatisfy` hasKey "wait_for_completion_timeout" + json `shouldSatisfy` hasKey "keep_on_completion" + json `shouldSatisfy` hasKey "keep_alive" + json `shouldSatisfy` hasKey "size" + json `shouldSatisfy` hasKey "fetch_size" + json `shouldSatisfy` hasKey "fields" + json `shouldSatisfy` hasKey "filter" + json `shouldSatisfy` hasKey "result_position" + json `shouldSatisfy` hasKey "tiebreaker_field" + json `shouldSatisfy` hasKey "event_category_field" + json `shouldSatisfy` hasKey "timestamp_field" + json `shouldSatisfy` hasKey "runtime_mappings" + json `shouldSatisfy` hasKey "allow_partial_search_results" + json `shouldSatisfy` hasKey "allow_partial_sequence_results" + json `shouldSatisfy` hasKey "case_sensitive" + + it "encodes runtime_mappings as a bare object keyed by field name" $ do + let json = encode fullRequest + let Just (Object o) = decode json + -- runtime_mappings renders as an object whose keys are the runtime + -- field names; here we declared "day_of_week" with type keyword. + KM.lookup "runtime_mappings" o `shouldSatisfy` isJust + let Just (Object rm) = KM.lookup "runtime_mappings" o + KM.lookup "day_of_week" rm `shouldSatisfy` isJust + + it "encodes the new boolean body fields verbatim" $ do + let json = encode fullRequest + let Just (Object o) = decode json + KM.lookup "allow_partial_search_results" o `shouldBe` Just (Bool True) + KM.lookup "allow_partial_sequence_results" o `shouldBe` Just (Bool False) + KM.lookup "case_sensitive" o `shouldBe` Just (Bool True) + + it "encodes result_position as a bare string (\"head\"/\"tail\")" $ do + let json = encode fullRequest + let Just (Object obj) = decode json + KM.lookup "result_position" obj `shouldBe` Just "tail" + let headReq = fullRequest {ES7Types.eqlResultPosition = Just ES7Types.EQLHead} + let Just (Object objH) = decode (encode headReq) + KM.lookup "result_position" objH `shouldBe` Just "head" + + it "round-trips a minimal request through ToJSON/FromJSON" $ + decode (encode minimalRequest) `shouldBe` Just minimalRequest + + it "round-trips a fully-populated request through ToJSON/FromJSON" $ + decode (encode fullRequest) `shouldBe` Just fullRequest + + describe "EQLRequest body version gating (EQLRequestBodyES7 / EQLRequestBodyES8)" $ do + -- The bare 'ToJSON' instance emits the full 8.x shape (every field, + -- including the three 8.x-only booleans). The two newtype wrappers + -- give the request builders version-specific wire shapes: + -- 'EQLRequestBodyES7' drops the 8.x-only keys so the body matches the + -- 7.17 spec; 'EQLRequestBodyES8' matches the bare instance so ES8/ES9 + -- keep forwarding them. This mirrors the PIT precedent + -- ('pitOptionsParams' vs 'osPITOptionsParams'). + + it "EQLRequestBodyES7 omits the 8.x-only body keys even when set" $ do + let json = encode (ES7Types.EQLRequestBodyES7 fullRequest) + json `shouldNotSatisfy` hasKey "allow_partial_search_results" + json `shouldNotSatisfy` hasKey "allow_partial_sequence_results" + json `shouldNotSatisfy` hasKey "case_sensitive" + + it "EQLRequestBodyES7 still emits every 7.17-documented body field" $ do + let json = encode (ES7Types.EQLRequestBodyES7 fullRequest) + json `shouldSatisfy` hasKey "query" + json `shouldSatisfy` hasKey "wait_for_completion_timeout" + json `shouldSatisfy` hasKey "keep_on_completion" + json `shouldSatisfy` hasKey "keep_alive" + json `shouldSatisfy` hasKey "size" + json `shouldSatisfy` hasKey "fetch_size" + json `shouldSatisfy` hasKey "fields" + json `shouldSatisfy` hasKey "filter" + json `shouldSatisfy` hasKey "result_position" + json `shouldSatisfy` hasKey "tiebreaker_field" + json `shouldSatisfy` hasKey "event_category_field" + json `shouldSatisfy` hasKey "timestamp_field" + json `shouldSatisfy` hasKey "runtime_mappings" + + it "EQLRequestBodyES7 encodes runtime_mappings identically to the bare instance" $ do + let json = encode (ES7Types.EQLRequestBodyES7 fullRequest) + let Just (Object o) = decode json + KM.lookup "runtime_mappings" o `shouldSatisfy` isJust + let Just (Object rm) = KM.lookup "runtime_mappings" o + KM.lookup "day_of_week" rm `shouldSatisfy` isJust + + it "EQLRequestBodyES7 on a minimal request is byte-identical to the bare instance" $ + encode (ES7Types.EQLRequestBodyES7 minimalRequest) `shouldBe` encode minimalRequest + + it "EQLRequestBodyES8 emits the 8.x-only body keys verbatim" $ do + let json = encode (ES7Types.EQLRequestBodyES8 fullRequest) + let Just (Object o) = decode json + KM.lookup "allow_partial_search_results" o `shouldBe` Just (Bool True) + KM.lookup "allow_partial_sequence_results" o `shouldBe` Just (Bool False) + KM.lookup "case_sensitive" o `shouldBe` Just (Bool True) + + it "EQLRequestBodyES8 is byte-identical to the bare ToJSON instance" $ + encode (ES7Types.EQLRequestBodyES8 fullRequest) `shouldBe` encode fullRequest + + describe "eqlSearchOptionsParams7 (ES7 wire)" $ do + it "renders nothing for defaultEQLSearchOptions" $ + ES7Types.eqlSearchOptionsParams7 ES7Types.defaultEQLSearchOptions `shouldBe` [] + + it "renders allow_no_indices as a boolean string" $ + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoAllowNoIndices = Just False} + in lookup "allow_no_indices" (ES7Types.eqlSearchOptionsParams7 opts) `shouldBe` Just (Just "false") + + it "deliberately omits allow_partial_search_results even when set" $ + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoAllowPartialSearchResults = Just True} + in lookup "allow_partial_search_results" (ES7Types.eqlSearchOptionsParams7 opts) `shouldBe` Nothing + + it "deliberately omits allow_partial_sequence_results even when set" $ + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoAllowPartialSequenceResults = Just True} + in lookup "allow_partial_sequence_results" (ES7Types.eqlSearchOptionsParams7 opts) `shouldBe` Nothing + + it "renders ignore_unavailable as a boolean string" $ + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoIgnoreUnavailable = Just True} + in lookup "ignore_unavailable" (ES7Types.eqlSearchOptionsParams7 opts) `shouldBe` Just (Just "true") + + it "renders ccs_minimize_roundtrips as a boolean string" $ + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoCcsMinimizeRoundtrips = Just False} + in lookup "ccs_minimize_roundtrips" (ES7Types.eqlSearchOptionsParams7 opts) `shouldBe` Just (Just "false") + + it "renders keep_alive verbatim" $ + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoKeepAlive = Just "1m"} + in lookup "keep_alive" (ES7Types.eqlSearchOptionsParams7 opts) `shouldBe` Just (Just "1m") + + it "renders keep_on_completion as a boolean string" $ + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoKeepOnCompletion = Just True} + in lookup "keep_on_completion" (ES7Types.eqlSearchOptionsParams7 opts) `shouldBe` Just (Just "true") + + it "renders wait_for_completion_timeout verbatim" $ + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoWaitForCompletionTimeout = Just "5s"} + in lookup "wait_for_completion_timeout" (ES7Types.eqlSearchOptionsParams7 opts) `shouldBe` Just (Just "5s") + + it "renders expand_wildcards comma-joined" $ + let opts = + ES7Types.defaultEQLSearchOptions + { ES7Types.esoExpandWildcards = Just [ExpandWildcardsOpen, ExpandWildcardsClosed] + } + in lookup "expand_wildcards" (ES7Types.eqlSearchOptionsParams7 opts) + `shouldBe` Just (Just "open,closed") + + it "omits Nothing fields entirely (only sets render)" $ + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoIgnoreUnavailable = Just True} + in ES7Types.eqlSearchOptionsParams7 opts `shouldBe` [("ignore_unavailable", Just "true")] + + describe "eqlSearchOptionsParams8 (ES8/ES9 wire)" $ do + it "renders nothing for defaultEQLSearchOptions" $ + ES7Types.eqlSearchOptionsParams8 ES7Types.defaultEQLSearchOptions `shouldBe` [] + + it "renders allow_partial_search_results as a boolean string" $ + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoAllowPartialSearchResults = Just True} + in lookup "allow_partial_search_results" (ES7Types.eqlSearchOptionsParams8 opts) `shouldBe` Just (Just "true") + + it "renders allow_partial_sequence_results as a boolean string" $ + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoAllowPartialSequenceResults = Just True} + in lookup "allow_partial_sequence_results" (ES7Types.eqlSearchOptionsParams8 opts) `shouldBe` Just (Just "true") + + it "emits every parameter that params7 emits (superset)" $ + let opts = + ES7Types.defaultEQLSearchOptions + { ES7Types.esoIgnoreUnavailable = Just True, + ES7Types.esoAllowPartialSearchResults = Just False + } + in sortPairs (ES7Types.eqlSearchOptionsParams8 opts) + `shouldBe` sortPairs + [ ("ignore_unavailable", Just "true"), + ("allow_partial_search_results", Just "false") + ] + + it "renders the 7.17-documented params identically to params7" $ do + let opts = + ES7Types.defaultEQLSearchOptions + { ES7Types.esoAllowNoIndices = Just True, + ES7Types.esoExpandWildcards = Just [ExpandWildcardsOpen] + } + -- params8 is a superset of params7; when the 8.x-only fields are + -- unset the two renderers must agree byte-for-byte. + ES7Types.eqlSearchOptionsParams8 opts `shouldBe` ES7Types.eqlSearchOptionsParams7 opts + + describe "EQLResult JSON" $ do + it "decodes a complete synchronous response with one event" $ do + let raw = + LBS.pack + "{\"is_running\":false,\"timed_out\":false,\"took\":3,\"hits\":{\"total\":{\"value\":1,\"relation\":\"eq\"},\"events\":[{\"_index\":\"logs-1\",\"_id\":\"1\",\"_source\":{\"event\":{\"category\":\"process\"}},\"_version\":1,\"_seq_no\":0,\"_primary_term\":1}]}}" + let Just (result :: ES7Types.EQLResult Value) = decode raw + ES7Types.eqlIsRunning result `shouldBe` Just False + ES7Types.eqlTimedOut result `shouldBe` Just False + ES7Types.eqlTook result `shouldBe` Just 3 + let Just hits = ES7Types.eqlHits result + ES7Types.eqlHitsTotal hits + `shouldBe` Just (ES7Types.EQLTotal 1 ES7Types.EQLTotalEq) + length (ES7Types.eqlHitsEvents hits) `shouldBe` 1 + let event = head (ES7Types.eqlHitsEvents hits) + ES7Types.eqlHitIndex event `shouldBe` Just "logs-1" + ES7Types.eqlHitDocId event `shouldBe` Just "1" + ES7Types.eqlHitVersion event `shouldBe` Just 1 + ES7Types.eqlHitSeqNo event `shouldBe` Just 0 + ES7Types.eqlHitPrimaryTerm event `shouldBe` Just 1 + + it "decodes a still-running async response (no hits)" $ do + let raw = LBS.pack "{\"is_running\":true,\"timed_out\":false,\"took\":1}" + let Just (result :: ES7Types.EQLResult Value) = decode raw + ES7Types.eqlIsRunning result `shouldBe` Just True + ES7Types.eqlHits result `shouldSatisfy` isNothing + -- When the search completes synchronously the server omits the + -- @id@ key entirely; the new 'eqlId' field must decode as Nothing + -- so existing eqlSearch callers keep their pre-async semantics. + ES7Types.eqlId result `shouldBe` Nothing + + it "decodes an async-initiation response carrying the search id" $ do + -- When @wait_for_completion_timeout@ elapses, the server returns + -- @{"id": ..., "is_running": true}@ so the caller can poll the + -- deferred results via 'Requests.getEQLSearch'. The id is the + -- only piece of state that needs to round-trip to the follow-up + -- GET, so pin its decoder shape here. + let raw = + LBS.pack + "{\"id\":\"FmRleEctMW5TY2utc0MtOFk4AAAAAAAAAA==\",\"is_running\":true,\"timed_out\":false,\"took\":1}" + let Just (result :: ES7Types.EQLResult Value) = decode raw + ES7Types.eqlId result + `shouldBe` Just (ES7Types.EQLSearchId "FmRleEctMW5TY2utc0MtOFk4AAAAAAAAAA==") + ES7Types.eqlIsRunning result `shouldBe` Just True + ES7Types.eqlHits result `shouldSatisfy` isNothing + + it "ignores undocumented keys (total/did_timeout/pits from later ES versions)" $ do + -- ES 7.17 does not document top-level @total@, @did_timeout@, or + -- @pits@; later ES versions emit them. They must be silently + -- ignored so the documented fields still decode. + let raw = + LBS.pack + "{\"is_running\":false,\"timed_out\":false,\"took\":2,\"did_timeout\":false,\"total\":{\"value\":1,\"relation\":\"eq\"},\"pits\":[{\"id\":\"x\",\"keep_alive\":\"1m\"}]}" + let Just (result :: ES7Types.EQLResult Value) = decode raw + ES7Types.eqlId result `shouldBe` Nothing + ES7Types.eqlIsRunning result `shouldBe` Just False + ES7Types.eqlIsPartial result `shouldBe` Nothing + ES7Types.eqlTimedOut result `shouldBe` Just False + ES7Types.eqlTook result `shouldBe` Just 2 + ES7Types.eqlHits result `shouldSatisfy` isNothing + + describe "small types JSON" $ do + it "round-trips EQLTotal through ToJSON/FromJSON" $ do + let total = ES7Types.EQLTotal 42 ES7Types.EQLTotalEq + decode (encode total) `shouldBe` Just total + let totalGte = ES7Types.EQLTotal 100 ES7Types.EQLTotalGte + decode (encode totalGte) `shouldBe` Just totalGte + + it "round-trips EQLResultPosition through ToJSON/FromJSON" $ do + decode (encode ES7Types.EQLHead) `shouldBe` Just ES7Types.EQLHead + decode (encode ES7Types.EQLTail) `shouldBe` Just ES7Types.EQLTail + + it "round-trips EQLSearchId through ToJSON/FromJSON as a bare string" $ do + let sid = ES7Types.EQLSearchId "FmRleEctMW5TY2utc0MtOFk4AAAAAAAAAA==" + encode sid `shouldBe` "\"FmRleEctMW5TY2utc0MtOFk4AAAAAAAAAA==\"" + decode "\"FmRleEctMW5TY2utc0MtOFk4AAAAAAAAAA==\"" `shouldBe` Just sid + + it "rejects a non-string EQLSearchId payload" $ do + decode "{}" `shouldBe` (Nothing :: Maybe ES7Types.EQLSearchId) + decode "42" `shouldBe` (Nothing :: Maybe ES7Types.EQLSearchId) + + it "rejects unknown result_position strings" $ do + let raw = LBS.pack "\"sideways\"" + let parsed = decode raw :: Maybe ES7Types.EQLResultPosition + parsed `shouldBe` Nothing + + it "rejects unknown total relation strings" $ do + let raw = LBS.pack "{\"value\":1,\"relation\":\"around\"}" + let parsed = decode raw :: Maybe ES7Types.EQLTotal + parsed `shouldBe` Nothing + + describe "endpoint shape" $ do + let index = [qqIndexName|eql-shape-test|] + + it "ES7 POSTs to /{index}/_eql/search with no query string" $ do + let req = RequestsES7.eqlSearch @Value index minimalRequest + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName index, "_eql", "search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "ES7 embeds the query field in the body" $ do + let req = RequestsES7.eqlSearch @Value index minimalRequest + let body = bhRequestBody req + body `shouldSatisfy` isJust + let Just bodyBytes = body + hasKey "query" bodyBytes `shouldBe` True + + it "ES8 builds the same endpoint shape (own builder, 8.x body)" $ do + let req8 = RequestsES8.eqlSearch @Value index minimalRequest + getRawEndpoint (bhRequestEndpoint req8) + `shouldBe` [unIndexName index, "_eql", "search"] + getRawEndpointQueries (bhRequestEndpoint req8) `shouldBe` [] + + it "ES9 reuses the ES8 request builder (identical endpoint)" $ do + let req9 = RequestsES9.eqlSearch @Value index minimalRequest + getRawEndpoint (bhRequestEndpoint req9) + `shouldBe` [unIndexName index, "_eql", "search"] + getRawEndpointQueries (bhRequestEndpoint req9) `shouldBe` [] + + it "ES7 eqlSearchWith renders no query string for default options" $ do + let req = RequestsES7.eqlSearchWith @Value index ES7Types.defaultEQLSearchOptions minimalRequest + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName index, "_eql", "search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "ES7 eqlSearchWith surfaces options as query parameters" $ do + let opts = + ES7Types.defaultEQLSearchOptions + { ES7Types.esoAllowNoIndices = Just True, + ES7Types.esoExpandWildcards = Just [ExpandWildcardsOpen] + } + let req = RequestsES7.eqlSearchWith @Value index opts minimalRequest + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName index, "_eql", "search"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("allow_no_indices", Just "true"), ("expand_wildcards", Just "open")] + + it "ES7 eqlSearchWith still carries the body" $ do + let req = RequestsES7.eqlSearchWith @Value index ES7Types.defaultEQLSearchOptions minimalRequest + let Just bodyBytes = bhRequestBody req + hasKey "query" bodyBytes `shouldBe` True + + it "ES7 eqlSearchWith body omits 8.x-only keys even when the request sets them" $ do + -- The whole point of bloodhound-jbe: the ES7 wire body must not + -- carry allow_partial_search_results, + -- allow_partial_sequence_results or case_sensitive, even when the + -- caller populated them on the EQLRequest. + let req = RequestsES7.eqlSearchWith @Value index ES7Types.defaultEQLSearchOptions fullRequest + let Just bodyBytes = bhRequestBody req + hasKey "query" bodyBytes `shouldBe` True + hasKey "allow_partial_search_results" bodyBytes `shouldBe` False + hasKey "allow_partial_sequence_results" bodyBytes `shouldBe` False + hasKey "case_sensitive" bodyBytes `shouldBe` False + -- 7.17-documented fields still go through. + hasKey "runtime_mappings" bodyBytes `shouldBe` True + + it "ES8 eqlSearchWith body emits the 8.x-only keys when the request sets them" $ do + -- The ES8 builder keeps the 8.x shape, so the three keys survive + -- on the wire. This pins the complementary behaviour to the ES7 + -- test above and guards against an accidental over-eager drop. + let req = RequestsES8.eqlSearchWith @Value index ES7Types.defaultEQLSearchOptions fullRequest + let Just bodyBytes = bhRequestBody req + hasKey "allow_partial_search_results" bodyBytes `shouldBe` True + hasKey "allow_partial_sequence_results" bodyBytes `shouldBe` True + hasKey "case_sensitive" bodyBytes `shouldBe` True + + it "ES8 eqlSearchWith surfaces the 8.x-only URI params (unlike ES7)" $ do + -- Symmetric gating on the query-string side: ES8 emits + -- allow_partial_search_results / allow_partial_sequence_results + -- as URI parameters, ES7 does not. + let opts = + ES7Types.defaultEQLSearchOptions + { ES7Types.esoAllowPartialSearchResults = Just True, + ES7Types.esoAllowPartialSequenceResults = Just False + } + let req7 = RequestsES7.eqlSearchWith @Value index opts minimalRequest + let req8 = RequestsES8.eqlSearchWith @Value index opts minimalRequest + sortPairs (getRawEndpointQueries (bhRequestEndpoint req7)) `shouldBe` [] + sortPairs (getRawEndpointQueries (bhRequestEndpoint req8)) + `shouldBe` [ ("allow_partial_search_results", Just "true"), + ("allow_partial_sequence_results", Just "false") + ] + + it "ES8 eqlSearchWith uses its own builder but the 7.17 params still surface" $ do + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoIgnoreUnavailable = Just True} + let req8 = RequestsES8.eqlSearchWith @Value index opts minimalRequest + getRawEndpoint (bhRequestEndpoint req8) + `shouldBe` [unIndexName index, "_eql", "search"] + getRawEndpointQueries (bhRequestEndpoint req8) + `shouldBe` [("ignore_unavailable", Just "true")] + + it "ES9 eqlSearchWith reuses the ES8 request builder (identical query)" $ do + let opts = ES7Types.defaultEQLSearchOptions {ES7Types.esoCcsMinimizeRoundtrips = Just False} + let req9 = RequestsES9.eqlSearchWith @Value index opts minimalRequest + getRawEndpoint (bhRequestEndpoint req9) + `shouldBe` [unIndexName index, "_eql", "search"] + getRawEndpointQueries (bhRequestEndpoint req9) + `shouldBe` [("ccs_minimize_roundtrips", Just "false")] + + describe "GET /_eql/search/{id} endpoint shape" $ do + -- Async follow-up: once an EQL search returns an 'EQLSearchId', + -- callers fetch the deferred results via @GET /_eql/search\/{id}@. + -- The wire path is index-less (the id encodes the originating + -- indices server-side), which is why the bead title's + -- @/{index}/_eql/search/{id}@ form would be a 404 -- pin the + -- index-less shape here. + let sid = ES7Types.EQLSearchId "FmRleEctMW5TY2utc0MtOFk4AAAAAAAAAA==" + + it "ES7 GETs /_eql/search/{id} with no body; Nothing omits wait_for_completion_timeout" $ do + let req = RequestsES7.getEQLSearch @Value sid Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_eql", "search", unEQLSearchId sid] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "ES7 renders wait_for_completion_timeout as a query parameter when given" $ do + let req = RequestsES7.getEQLSearch @Value sid (Just "5s") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_eql", "search", unEQLSearchId sid] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("wait_for_completion_timeout", Just "5s")] + + it "ES8 reuses the ES7 request builder (identical endpoint and query)" $ do + let req8 = RequestsES8.getEQLSearch @Value sid (Just "5s") + getRawEndpoint (bhRequestEndpoint req8) + `shouldBe` ["_eql", "search", unEQLSearchId sid] + getRawEndpointQueries (bhRequestEndpoint req8) + `shouldBe` [("wait_for_completion_timeout", Just "5s")] + + it "ES9 reuses the ES8 request builder (identical endpoint and query)" $ do + let req9 = RequestsES9.getEQLSearch @Value sid (Just "5s") + getRawEndpoint (bhRequestEndpoint req9) + `shouldBe` ["_eql", "search", unEQLSearchId sid] + getRawEndpointQueries (bhRequestEndpoint req9) + `shouldBe` [("wait_for_completion_timeout", Just "5s")] + + describe "GET /_eql/search/status/{id} endpoint shape" $ do + let sid = ES7Types.EQLSearchId "FmRleEctMW5TY2utc0MtOFk4AAAAAAAAAA==" + + it "ES7 GETs /_eql/search/status/{id} with no body and no query string" $ do + let req = RequestsES7.getEQLStatus sid + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_eql", "search", "status", unEQLSearchId sid] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "ES7 uses a distinct id in the path when given a different EQLSearchId" $ do + let req = RequestsES7.getEQLStatus (ES7Types.EQLSearchId "other-id") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_eql", "search", "status", "other-id"] + + it "ES7 keeps the id as a single opaque path segment" $ do + let req = RequestsES7.getEQLStatus (ES7Types.EQLSearchId "Fm_==_RxD_123") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_eql", "search", "status", "Fm_==_RxD_123"] + + it "ES8 reuses the ES7 request builder (identical endpoint)" $ do + let req8 = RequestsES8.getEQLStatus sid + getRawEndpoint (bhRequestEndpoint req8) + `shouldBe` ["_eql", "search", "status", unEQLSearchId sid] + getRawEndpointQueries (bhRequestEndpoint req8) `shouldBe` [] + bhRequestBody req8 `shouldBe` Nothing + + it "ES9 reuses the ES8 request builder (identical endpoint)" $ do + let req9 = RequestsES9.getEQLStatus sid + getRawEndpoint (bhRequestEndpoint req9) + `shouldBe` ["_eql", "search", "status", unEQLSearchId sid] + getRawEndpointQueries (bhRequestEndpoint req9) `shouldBe` [] + bhRequestBody req9 `shouldBe` Nothing + + describe "getEQLStatus response decode" $ do + let decodeSid = ES7Types.EQLSearchId "FmRleEctMW5TY2utc0MtOFk4AAAAAAAAAA==" + + it "decodes a completed-search status response" $ do + let raw = + LBS.pack + "{\"id\":\"FmRleEctMW5TY2utc0MtOFk4AAAAAAAAAA==\",\"is_running\":false,\"is_partial\":false,\"expiration_time_in_millis\":1782109853290,\"completion_status\":200}" + let Just (status :: ES7Types.EQLStatus) = decode raw + ES7Types.eqlStatusId status `shouldBe` Just decodeSid + ES7Types.eqlStatusIsRunning status `shouldBe` Just False + ES7Types.eqlStatusIsPartial status `shouldBe` Just False + ES7Types.eqlStatusCompletionStatus status `shouldBe` Just 200 + ES7Types.eqlStatusExpirationTimeInMillis status `shouldBe` Just 1782109853290 + + it "decodes a running-search status response (no completion_status)" $ do + let raw = + LBS.pack + "{\"id\":\"FmRleEctRXJtaVNZQ1I2UkJoTDJfQkEAAAAAAAAUX0Q2UkRLNEVBYlhVZ19VUUZmeld3Zw==\",\"is_running\":true,\"is_partial\":true}" + let Just (status :: ES7Types.EQLStatus) = decode raw + ES7Types.eqlStatusId status + `shouldBe` Just + ( ES7Types.EQLSearchId + "FmRleEctRXJtaVNZQ1I2UkJoTDJfQkEAAAAAAAAUX0Q2UkRLNEVBYlhVZ19VUUZmeld3Zw==" + ) + ES7Types.eqlStatusIsRunning status `shouldBe` Just True + ES7Types.eqlStatusIsPartial status `shouldBe` Just True + ES7Types.eqlStatusCompletionStatus status `shouldBe` Nothing + + it "decodes a running-search status with start_time_in_millis" $ do + let raw = + LBS.pack + "{\"id\":\"abc\",\"is_running\":true,\"is_partial\":true,\"start_time_in_millis\":1782109853000}" + let Just (status :: ES7Types.EQLStatus) = decode raw + ES7Types.eqlStatusIsRunning status `shouldBe` Just True + ES7Types.eqlStatusStartTimeInMillis status `shouldBe` Just 1782109853000 + + it "tolerates unknown extra fields" $ do + let raw = + LBS.pack + "{\"id\":\"x\",\"is_running\":false,\"future_field\":\"value\"}" + let Just (status :: ES7Types.EQLStatus) = decode raw + ES7Types.eqlStatusId status `shouldBe` Just (ES7Types.EQLSearchId "x") + + it "completion_status is Nothing when omitted" $ do + let raw = LBS.pack "{\"is_running\":true}" + let Just (status :: ES7Types.EQLStatus) = decode raw + ES7Types.eqlStatusCompletionStatus status `shouldBe` Nothing + + describe "EQL sequence-query results" $ do + -- EQL @sequence ... with ...@ queries return matches under the + -- @hits.sequences@ array rather than @hits.events@. Without this + -- field modelled, a successful sequence query polled via + -- 'Requests.getEQLSearch' would silently look empty. + it "decodes a sequence query response (events + join_keys)" $ do + let raw = + LBS.pack + "{\"is_running\":false,\"took\":4,\"hits\":{\"total\":{\"value\":1,\"relation\":\"eq\"},\"sequences\":[{\"events\":[{\"_index\":\"logs-1\",\"_id\":\"a\",\"_source\":{\"event\":{\"category\":\"process\"}}},{\"_index\":\"logs-1\",\"_id\":\"b\",\"_source\":{\"event\":{\"category\":\"process\"}}}],\"join_keys\":[\"cmd.exe\"]}]}}" + let Just (result :: ES7Types.EQLResult Value) = decode raw + ES7Types.eqlIsPartial result `shouldBe` Nothing + let Just hits = ES7Types.eqlHits result + -- Event queries populate 'eqlHitsEvents' (defaults to []), but a + -- pure-sequence response leaves it empty; the matched events are + -- nested under each 'EQLSequence'. + ES7Types.eqlHitsEvents hits `shouldBe` [] + let Just seqs = ES7Types.eqlHitsSequences hits + length seqs `shouldBe` 1 + let s = head seqs + length (ES7Types.eqlSequenceEvents s) `shouldBe` 2 + ES7Types.eqlSequenceJoinKeys s `shouldBe` Just [toJSON ("cmd.exe" :: Text)] + + it "eqlHitsSequences is Nothing for a pure-event response" $ do + let raw = + LBS.pack + "{\"hits\":{\"total\":{\"value\":1,\"relation\":\"eq\"},\"events\":[{\"_index\":\"logs-1\",\"_id\":\"a\",\"_source\":{\"event\":{\"category\":\"process\"}}}]}}" + let Just (result :: ES7Types.EQLResult Value) = decode raw + let Just hits = ES7Types.eqlHits result + ES7Types.eqlHitsSequences hits `shouldBe` Nothing + length (ES7Types.eqlHitsEvents hits) `shouldBe` 1 + + it "decodes is_partial=true on a partial-result response" $ do + let raw = + LBS.pack + "{\"id\":\"FmRleEctMW5TY2utc0MtOFk4AAAAAAAAAA==\",\"is_running\":false,\"is_partial\":true,\"took\":1}" + let Just (result :: ES7Types.EQLResult Value) = decode raw + ES7Types.eqlIsPartial result `shouldBe` Just True + -- A partial response leaves hits absent; callers should treat + -- is_partial=true as terminal rather than retry. + ES7Types.eqlHits result `shouldSatisfy` isNothing + + it "eqlIsPartial is Nothing when the server omits the key" $ do + let raw = LBS.pack "{\"is_running\":false,\"took\":3}" + let Just (result :: ES7Types.EQLResult Value) = decode raw + ES7Types.eqlIsPartial result `shouldBe` Nothing + + describe "live integration (requires ES7.10+ backend)" $ + backendSpecific [ElasticSearch7, ElasticSearch8, ElasticSearch9] $ do + it "returns events matching an EQL predicate" $ + withTestEnv $ do + _ <- insertEqlData + result <- eqlSearchForBackend ("process where true" :: Text) + case result of + Left e -> + liftIO $ + expectationFailure $ + "eqlSearch failed: " <> show e + Right eqlResult -> liftIO $ do + ES7Types.eqlIsRunning eqlResult + `shouldSatisfy` (\x -> x == Just False || isNothing x) + let mbHits = ES7Types.eqlHits eqlResult + mbHits `shouldSatisfy` isJust + let Just hits = mbHits + length (ES7Types.eqlHitsEvents hits) + `shouldSatisfy` (\n -> n >= 1) + let total = ES7Types.eqlHitsTotal hits + total `shouldSatisfy` isJust + let Just (ES7Types.EQLTotal v _) = total + v `shouldSatisfy` (>= 1) + + describe "EQLResult id field" $ do + it "decodes the top-level id when present" $ do + let Just (result :: ES7Types.EQLResult Value) = decode sampleAsyncResponseWithId + ES7Types.eqlId result `shouldBe` Just (ES7Types.EQLSearchId "FmRleEctRXJtaVNZQ1I2UkJoTDJfQkEAAAAAAAAUX0Q2UkRLNEVBYlhVZ19VUUZmeld3Zw==") + + it "leaves eqlId at Nothing when the response has no id (synchronous)" $ do + let raw = LBS.pack "{\"is_running\":false,\"took\":3}" + let Just (result :: ES7Types.EQLResult Value) = decode raw + ES7Types.eqlId result `shouldBe` Nothing + + it "tolerates unknown extra fields alongside id" $ do + let raw = LBS.pack "{\"id\":\"abc\",\"is_running\":true,\"future_field\":\"x\"}" + let Just (result :: ES7Types.EQLResult Value) = decode raw + ES7Types.eqlId result `shouldBe` Just (ES7Types.EQLSearchId "abc") + + describe "EQLSearchId JSON" $ do + it "decodes a bare string" $ do + decode "\"FmRleEct==\"" `shouldBe` Just (ES7Types.EQLSearchId "FmRleEct==") + + it "encodes back to a bare string" $ do + encode (ES7Types.EQLSearchId "FmRleEct==") `shouldBe` "\"FmRleEct==\"" + + it "round-trips through ToJSON/FromJSON" $ do + let original = ES7Types.EQLSearchId "Fm_==_RxD_123" + (decode . encode) original `shouldBe` Just original + + describe "deleteEQLSearch endpoint shape" $ do + it "ES7 DELETEs /_eql/search/{id} when given an EQLSearchId" $ do + let req = RequestsES7.deleteEQLSearch (ES7Types.EQLSearchId "FmRleEct") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_eql", "search", "FmRleEct"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "ES7 uses DELETE and attaches no body" $ do + let req = RequestsES7.deleteEQLSearch (ES7Types.EQLSearchId "FmRleEct") + bhRequestMethod req `shouldBe` "DELETE" + bhRequestBody req `shouldBe` Nothing + + it "ES7 uses a distinct id in the path when given a different EQLSearchId" $ do + let req = RequestsES7.deleteEQLSearch (ES7Types.EQLSearchId "other-id") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_eql", "search", "other-id"] + + it "ES7 keeps the id as a single opaque path segment" $ do + let req = RequestsES7.deleteEQLSearch (ES7Types.EQLSearchId "Fm_==_RxD_123") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_eql", "search", "Fm_==_RxD_123"] + + it "ES8 reuses the ES7 request builder (identical endpoint)" $ do + let req8 = RequestsES8.deleteEQLSearch (ES7Types.EQLSearchId "FmRleEct") + getRawEndpoint (bhRequestEndpoint req8) `shouldBe` ["_eql", "search", "FmRleEct"] + getRawEndpointQueries (bhRequestEndpoint req8) `shouldBe` [] + bhRequestBody req8 `shouldBe` Nothing + + it "ES9 reuses the ES8 request builder (identical endpoint)" $ do + let req9 = RequestsES9.deleteEQLSearch (ES7Types.EQLSearchId "FmRleEct") + getRawEndpoint (bhRequestEndpoint req9) `shouldBe` ["_eql", "search", "FmRleEct"] + getRawEndpointQueries (bhRequestEndpoint req9) `shouldBe` [] + bhRequestBody req9 `shouldBe` Nothing + + describe "deleteEQLSearch response decode" $ do + it "decodes {\"acknowledged\": true} as Acknowledged True" $ do + decode "{\"acknowledged\":true}" `shouldBe` Just (Acknowledged True) + + describe "deleteEQLSearch (live)" $ + backendSpecific [ElasticSearch7, ElasticSearch8, ElasticSearch9] $ do + it "surfaces a server error for a non-existent EQL search id" $ + withTestEnv $ do + -- ES rejects unknown ids with 404 and an error body that does + -- not parse as Acknowledged, which surfaces as an EsError. + result <- + tryEsError + ( performBHRequest $ + RequestsES7.deleteEQLSearch + (ES7Types.EQLSearchId "bloodhound-no-such-eql-search-04f-5-6-4") + ) + case result of + Left _err -> pure () + Right r -> + liftIO $ + expectationFailure $ + "expected EsError for missing EQL search, got: " <> show r + + describe "getEQLStatus (live)" $ + backendSpecific [ElasticSearch7, ElasticSearch8, ElasticSearch9] $ do + it "returns the status of an async EQL search" $ + withTestEnv $ do + _ <- insertEqlData + -- Start an async EQL search: wait_for_completion_timeout="0ms" + -- forces an immediate return with an id; keep_on_completion=true + -- ensures the search context survives so status is available. + let asyncReq = + minimalRequest + { ES7Types.eqlWaitForCompletionTimeout = Just "0ms", + ES7Types.eqlKeepOnCompletion = Just True, + ES7Types.eqlKeepAlive = Just "1m" + } + searchResult <- eqlSearchAsyncForBackend asyncReq + case searchResult of + Left e -> + liftIO $ + expectationFailure $ + "async eqlSearch failed: " <> show e + Right initialResult -> do + let mSid = ES7Types.eqlId initialResult + liftIO $ mSid `shouldSatisfy` isJust + let Just sid = mSid + statusResult <- getEQLStatusForBackend sid + case statusResult of + Left e -> + liftIO $ + expectationFailure $ + "getEQLStatus failed: " <> show e + Right status -> liftIO $ do + ES7Types.eqlStatusId status `shouldBe` Just sid + ES7Types.eqlStatusIsRunning status `shouldSatisfy` isJust + -- Cleanup: delete the async search context. + _ <- tryEsError (performBHRequest $ RequestsES7.deleteEQLSearch sid) + pure () + +-- --------------------------------------------------------------------------- +-- - EQL test fixtures +-- --------------------------------------------------------------------------- + +eqlTestIndex :: IndexName +eqlTestIndex = [qqIndexName|bloodhound-tests-eql-1|] + +-- | Sample event document. The @timestamp@ and @event.category@ fields +-- are required by EQL; @message@ is included so the decoded @_source@ +-- has a recognisable value. +data EqlEvent = EqlEvent + { eqlEventTimestamp :: Text, + eqlEventEvent :: EventCategory, + eqlEventMessage :: Text + } + deriving stock (Eq, Show) + +newtype EventCategory = EventCategory {eventCategory :: Value} + deriving newtype (Eq, Show, ToJSON, FromJSON) + +instance ToJSON EqlEvent where + toJSON e = + object + [ "@timestamp" .= eqlEventTimestamp e, + "event" .= eqlEventEvent e, + "message" .= eqlEventMessage e + ] + +instance FromJSON EqlEvent where + parseJSON (Object v) = + EqlEvent + <$> v .: "@timestamp" + <*> v .: "event" + <*> v .: "message" + parseJSON _ = empty + +-- | Mapping declaring @\\@timestamp@ as a date and @event.category@ as a +-- keyword — the two fields EQL needs to order events. +eqlEventMapping :: Value +eqlEventMapping = + object + [ "properties" + .= object + [ "@timestamp" .= object ["type" .= ("date" :: Text)], + "event" + .= object + [ "properties" + .= object + ["category" .= object ["type" .= ("keyword" :: Text)]] + ], + "message" .= object ["type" .= ("keyword" :: Text)] + ] + ] + +exampleEqlEventA :: EqlEvent +exampleEqlEventA = + EqlEvent + { eqlEventTimestamp = "2020-12-06T21:00:00.000Z", + eqlEventEvent = EventCategory (object ["category" .= ("process" :: Text)]), + eqlEventMessage = "process A" + } + +exampleEqlEventB :: EqlEvent +exampleEqlEventB = + EqlEvent + { eqlEventTimestamp = "2020-12-06T21:00:01.000Z", + eqlEventEvent = EventCategory (object ["category" .= ("process" :: Text)]), + eqlEventMessage = "process B" + } + +deleteEqlExampleIndex :: BH IO (BHResponse StatusDependant Acknowledged, Acknowledged) +deleteEqlExampleIndex = + performBHRequest $ keepBHResponse $ deleteIndex eqlTestIndex + +createEqlExampleIndex :: BH IO (BHResponse StatusDependant Acknowledged, Acknowledged) +createEqlExampleIndex = do + result <- + tryPerformBHRequest + ( keepBHResponse $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + eqlTestIndex + ) + case result of + Left e + | "already exists" `T.isSuffixOf` errorMessage e -> + return (error "createEqlExampleIndex: already exists", Acknowledged False) + | otherwise -> throwEsError e + Right ack -> return ack + +-- | Reset (delete + recreate + map + seed) the EQL test index. +insertEqlData :: BH IO () +insertEqlData = do + _ <- tryEsError deleteEqlExampleIndex + _ <- createEqlExampleIndex + _ <- performBHRequest $ putMapping @Value eqlTestIndex eqlEventMapping + _ <- performBHRequest $ indexDocument eqlTestIndex defaultIndexDocumentSettings exampleEqlEventA (DocId "a") + _ <- performBHRequest $ indexDocument eqlTestIndex defaultIndexDocumentSettings exampleEqlEventB (DocId "b") + _ <- performBHRequest $ refreshIndex eqlTestIndex + pure () + +-- | Dispatch to the right eqlSearch client based on the detected backend. +-- The wire format is identical across ES 7.10+, 8.x and 9.x; the dispatch +-- exists only because each version has its own 'WithBackend' constraint. +eqlSearchForBackend :: Text -> BH IO (Either EsError (ES7Types.EQLResult EqlEvent)) +eqlSearchForBackend queryText = do + backend <- liftIO detectBackendType + let req = minimalRequest {ES7Types.eqlQuery = queryText} + case backend of + Just ElasticSearch7 -> ClientES7.eqlSearch eqlTestIndex req + Just ElasticSearch8 -> ClientES8.eqlSearch eqlTestIndex req + Just ElasticSearch9 -> ClientES9.eqlSearch eqlTestIndex req + _ -> ClientES8.eqlSearch eqlTestIndex req + +-- | Dispatch 'eqlSearch' with a caller-supplied 'EQLRequest' (used for +-- async-mode searches where @wait_for_completion_timeout@ and +-- @keep_on_completion@ differ from the minimal defaults). +eqlSearchAsyncForBackend :: ES7Types.EQLRequest -> BH IO (Either EsError (ES7Types.EQLResult EqlEvent)) +eqlSearchAsyncForBackend req = do + backend <- liftIO detectBackendType + case backend of + Just ElasticSearch7 -> ClientES7.eqlSearch eqlTestIndex req + Just ElasticSearch8 -> ClientES8.eqlSearch eqlTestIndex req + Just ElasticSearch9 -> ClientES9.eqlSearch eqlTestIndex req + _ -> ClientES8.eqlSearch eqlTestIndex req + +-- | Dispatch 'getEQLStatus' based on the detected backend. The wire +-- format is identical across ES 7.10+, 8.x and 9.x; the dispatch exists +-- only because each version has its own 'WithBackend' constraint. +getEQLStatusForBackend :: ES7Types.EQLSearchId -> BH IO (Either EsError ES7Types.EQLStatus) +getEQLStatusForBackend sid = do + backend <- liftIO detectBackendType + case backend of + Just ElasticSearch7 -> tryEsError (ClientES7.getEQLStatus sid) + Just ElasticSearch8 -> tryEsError (ClientES8.getEQLStatus sid) + Just ElasticSearch9 -> tryEsError (ClientES9.getEQLStatus sid) + _ -> tryEsError (ClientES8.getEQLStatus sid) diff --git a/tests/Test/ExplainOptionsSpec.hs b/tests/Test/ExplainOptionsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ExplainOptionsSpec.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.ExplainOptionsSpec (spec) where + +import Data.List (sort) +import Data.Text qualified as T +import Database.Bloodhound.Common.Types +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +-- | Stable ordering for equality. The renderer preserves field-declaration +-- order but tests should compare the set of params, not the order. +normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] +normalize = sort + +-- | Boolean helpers rendered as @true@/@false@ strings. +boolTrue :: Maybe T.Text +boolTrue = Just "true" + +boolFalse :: Maybe T.Text +boolFalse = Just "false" + +spec :: Spec +spec = + describe "ExplainOptions URI param rendering" $ do + it "defaultExplainOptions emits no params" $ + explainOptionsParams defaultExplainOptions + `shouldBe` [] + + it "routing renders verbatim" $ do + let opts = defaultExplainOptions {eoRouting = Just "user-42"} + explainOptionsParams opts `shouldBe` [("routing", Just "user-42")] + + it "preference renders verbatim" $ do + let opts = defaultExplainOptions {eoPreference = Just "_local"} + explainOptionsParams opts `shouldBe` [("preference", Just "_local")] + + it "stored_fields renders verbatim" $ do + let opts = defaultExplainOptions {eoStoredFields = Just "name,age"} + explainOptionsParams opts `shouldBe` [("stored_fields", Just "name,age")] + + describe "_source" $ do + it "Just True renders as _source=true" $ do + let opts = defaultExplainOptions {eoSource = Just True} + explainOptionsParams opts `shouldBe` [("_source", boolTrue)] + it "Just False renders as _source=false" $ do + let opts = defaultExplainOptions {eoSource = Just False} + explainOptionsParams opts `shouldBe` [("_source", boolFalse)] + + it "_source_includes renders verbatim" $ do + let opts = defaultExplainOptions {eoSourceIncludes = Just "name"} + explainOptionsParams opts `shouldBe` [("_source_includes", Just "name")] + + it "_source_excludes renders verbatim" $ do + let opts = defaultExplainOptions {eoSourceExcludes = Just "age"} + explainOptionsParams opts `shouldBe` [("_source_excludes", Just "age")] + + describe "lenient" $ do + it "Just True renders as lenient=true" $ do + let opts = defaultExplainOptions {eoLenient = Just True} + explainOptionsParams opts `shouldBe` [("lenient", boolTrue)] + it "Just False renders as lenient=false" $ do + let opts = defaultExplainOptions {eoLenient = Just False} + explainOptionsParams opts `shouldBe` [("lenient", boolFalse)] + + -- The ES _explain URI parameter documents AND/OR (uppercase), even + -- though BooleanOperator's JSON encoding is lowercase. Pin the + -- uppercase wire form so a future refactor that reuses ToJSON is + -- caught here. + describe "default_operator" $ do + it "And renders as default_operator=AND (uppercase)" $ do + let opts = defaultExplainOptions {eoDefaultOperator = Just And} + explainOptionsParams opts `shouldBe` [("default_operator", Just "AND")] + it "Or renders as default_operator=OR (uppercase)" $ do + let opts = defaultExplainOptions {eoDefaultOperator = Just Or} + explainOptionsParams opts `shouldBe` [("default_operator", Just "OR")] + + it "df renders verbatim" $ do + let opts = defaultExplainOptions {eoDf = Just "message"} + explainOptionsParams opts `shouldBe` [("df", Just "message")] + + it "analyzer renders verbatim" $ do + let opts = defaultExplainOptions {eoAnalyzer = Just "standard"} + explainOptionsParams opts `shouldBe` [("analyzer", Just "standard")] + + describe "analyze_wildcard" $ do + it "Just True renders as analyze_wildcard=true" $ do + let opts = defaultExplainOptions {eoAnalyzeWildcard = Just True} + explainOptionsParams opts `shouldBe` [("analyze_wildcard", boolTrue)] + it "Just False renders as analyze_wildcard=false" $ do + let opts = defaultExplainOptions {eoAnalyzeWildcard = Just False} + explainOptionsParams opts `shouldBe` [("analyze_wildcard", boolFalse)] + + it "renders every field together when all are populated" $ do + let opts = + defaultExplainOptions + { eoRouting = Just "user-42", + eoPreference = Just "_local", + eoStoredFields = Just "name,age", + eoSource = Just False, + eoSourceIncludes = Just "name", + eoSourceExcludes = Just "age", + eoLenient = Just True, + eoDefaultOperator = Just And, + eoDf = Just "message", + eoAnalyzer = Just "standard", + eoAnalyzeWildcard = Just True + } + let rendered = explainOptionsParams opts + -- Exactly the 11 documented _explain URI parameters. + length rendered `shouldBe` 11 + rendered `shouldSatisfy` all (isJust . snd) + normalize rendered + `shouldBe` sort + [ ("routing", Just "user-42"), + ("preference", Just "_local"), + ("stored_fields", Just "name,age"), + ("_source", Just "false"), + ("_source_includes", Just "name"), + ("_source_excludes", Just "age"), + ("lenient", Just "true"), + ("default_operator", Just "AND"), + ("df", Just "message"), + ("analyzer", Just "standard"), + ("analyze_wildcard", Just "true") + ] + + it "explainDocument delegates to explainDocumentWith defaultExplainOptions (no params)" $ + -- defaultExplainOptions emits an empty param list, so the base + -- endpoint is wire-identical to the legacy parameterless form. + explainOptionsParams defaultExplainOptions + `shouldBe` [] + where + isJust (Just _) = True + isJust Nothing = False diff --git a/tests/Test/ExplainSpec.hs b/tests/Test/ExplainSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ExplainSpec.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Tests for the @POST \/{index}\/_explain\/{id}@ endpoint. +-- +-- The first section is unit tests of the JSON instances for +-- 'Explanation' and 'ExplainResponse' (no live backend required). +-- The second section is live integration coverage under 'withTestEnv' +-- and only meaningful when an Elasticsearch\/OpenSearch backend is +-- reachable on 'ES_TEST_SERVER' (default @http://localhost:9200@). +module Test.ExplainSpec (spec) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Common +import TestsUtils.Import + +-- | Fixture mimicking the canonical matched-document example from the +-- ES docs at +-- https://www.elastic.co/guide/en/elasticsearch/reference/current/search-explain.html. +-- Two-level nesting is enough to exercise 'explanationDetails' parsing +-- without being brittle to server-specific scoring descriptions. +sampleMatchedExplainResponse :: LBS.ByteString +sampleMatchedExplainResponse = + "{\ + \ \"_index\": \"my-index-000001\",\ + \ \"_id\": \"0\",\ + \ \"matched\": true,\ + \ \"explanation\": {\ + \ \"value\": 1.0,\ + \ \"description\": \"weight(name:foo in 0) [PerFieldSimilarity], result of:\",\ + \ \"details\": [\ + \ {\ + \ \"value\": 1.0,\ + \ \"description\": \"score(freq=1.0), computed as score from:\",\ + \ \"details\": [\ + \ {\ + \ \"value\": 1.4,\ + \ \"description\": \"idf, computed as log(1 + (N - n + 0.5) / (n + 0.5))\",\ + \ \"details\": []\ + \ }\ + \ ]\ + \ }\ + \ ]\ + \ }\ + \}" + +-- | A minimal matched response with no nested details. +sampleLeafExplainResponse :: LBS.ByteString +sampleLeafExplainResponse = + "{\ + \ \"_index\": \"ix\",\ + \ \"_id\": \"1\",\ + \ \"matched\": true,\ + \ \"explanation\": {\ + \ \"value\": 0.5,\ + \ \"description\": \"sum of:\",\ + \ \"details\": []\ + \ }\ + \}" + +-- | Response for a document that did not match the query. The server +-- omits the @explanation@ field entirely when @matched@ is @false@; +-- only 'explainResponseMatched' distinguishes the non-match case. +sampleNonMatchedExplainResponse :: LBS.ByteString +sampleNonMatchedExplainResponse = + "{\ + \ \"_index\": \"ix\",\ + \ \"_id\": \"1\",\ + \ \"matched\": false\ + \}" + +spec :: Spec +spec = do + describe "Explanation JSON" $ do + it "decodes the canonical matched-response example, preserving two levels of detail" $ do + let Just (decoded :: ExplainResponse) = decode sampleMatchedExplainResponse + explainResponseMatched decoded `shouldBe` True + unIndexName (explainResponseIndex decoded) `shouldBe` "my-index-000001" + case explainResponseExplanation decoded of + Nothing -> + expectationFailure "expected a populated explanation on a matched response" + Just explanation -> do + explanationValue explanation `shouldBe` 1.0 + case explanationDetails explanation of + [inner] -> do + explanationValue inner `shouldBe` 1.0 + case explanationDetails inner of + [leaf] -> do + explanationValue leaf `shouldBe` 1.4 + explanationDetails leaf `shouldBe` [] + other -> + expectationFailure $ "expected a single leaf detail, got " <> show other + other -> + expectationFailure $ "expected a single inner detail, got " <> show other + + it "decodes an explanation with no details as an empty list" $ do + let Just (decoded :: ExplainResponse) = decode sampleLeafExplainResponse + let Just explanation = explainResponseExplanation decoded + explanationValue explanation `shouldBe` 0.5 + explanationDetails explanation `shouldBe` [] + + it "treats a missing 'details' field the same as an empty list" $ do + let Just (decoded :: Explanation) = + decode + "{ \"value\": 0.0\ + \, \"description\": \"leaf without details key\" }" + explanationDetails decoded `shouldBe` [] + + it "round-trips a nested Explanation through ToJSON/FromJSON" $ do + let original = + Explanation + { explanationValue = 2.0, + explanationDescription = "sum of:", + explanationDetails = + [ Explanation 1.0 "child A" [], + Explanation 1.0 "child B" [Explanation 0.5 "grandchild" []] + ] + } + (decode . encode) original `shouldBe` Just original + + it "tolerates unknown extra fields in the body" $ do + let Just (decoded :: Explanation) = + decode + "{ \"value\": 0.0\ + \, \"description\": \"ok\"\ + \, \"future_field\": \"whatever\" }" + explanationDescription decoded `shouldBe` "ok" + + it "rejects an explanation missing the required 'value' field" $ do + let decoded = + decode + "{ \"description\": \"no value\" }" :: + Maybe Explanation + decoded `shouldBe` Nothing + + it "rejects an explanation missing the required 'description' field" $ do + let decoded = + decode + "{ \"value\": 0.0 }" :: + Maybe Explanation + decoded `shouldBe` Nothing + + describe "ExplainResponse JSON" $ do + it "decodes a matched response with a populated explanation" $ do + let Just (decoded :: ExplainResponse) = decode sampleMatchedExplainResponse + explainResponseMatched decoded `shouldBe` True + unIndexName (explainResponseIndex decoded) `shouldBe` "my-index-000001" + let DocId docIdValue = explainResponseId decoded + docIdValue `shouldBe` "0" + explainResponseExplanation decoded `shouldSatisfy` isJust + + it "decodes a non-matched response, preserving the matched=false flag and omitting the explanation" $ do + let Just (decoded :: ExplainResponse) = decode sampleNonMatchedExplainResponse + explainResponseMatched decoded `shouldBe` False + explainResponseExplanation decoded `shouldBe` Nothing + + it "tolerates an explicit \"explanation\": null on a matched response" $ do + let Just (decoded :: ExplainResponse) = + decode + "{ \"_index\": \"ix\"\ + \, \"_id\": \"1\"\ + \, \"matched\": true\ + \, \"explanation\": null }" + explainResponseMatched decoded `shouldBe` True + explainResponseExplanation decoded `shouldBe` Nothing + + it "rejects a body missing the required 'matched' field" $ do + let decoded = + decode + "{ \"_index\": \"ix\"\ + \, \"_id\": \"1\"\ + \, \"explanation\": {\"value\": 0.0, \"description\": \"x\", \"details\": []} }" :: + Maybe ExplainResponse + decoded `shouldBe` Nothing + + describe "explainDocument request envelope" $ do + -- Pinning the wire shape independently of the live backend. The + -- path mirrors 'getDocument' (@\/{index}\/_doc\/{id}@) with the + -- @_doc@ segment replaced by @_explain@. + let query = TermQuery (Term "user" "bitemyapp") Nothing + req = Common.explainDocument testIndex (DocId "42") query + + it "targets /{index}/_explain/{id} with no query parameters" $ do + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [ unIndexName testIndex, + "_explain", + "42" + ] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses POST and carries the encoded query body" $ do + bhRequestBody req `shouldSatisfy` isJust + bhRequestMethod req `shouldBe` "POST" + + it "wraps the Query as {\"query\": ...} on the wire" $ do + -- Pin the exact wire shape so a future refactor that drops + -- the ExplainQuery wrapper (or changes the Query ToJSON) is + -- caught here rather than silently breaking the request body. + let q = TermQuery (Term "user" "bitemyapp") Nothing + encode (ExplainQuery q) + `shouldBe` "{\"query\":{\"term\":{\"user\":{\"value\":\"bitemyapp\"}}}}" + + it "explainDocumentWith threads ExplainOptions onto the endpoint query string" $ do + let opts = + defaultExplainOptions + { eoRouting = Just "user-42", + eoPreference = Just "_local" + } + withReq = Common.explainDocumentWith opts testIndex (DocId "42") query + getRawEndpoint (bhRequestEndpoint withReq) + `shouldBe` [ unIndexName testIndex, + "_explain", + "42" + ] + -- The renderer preserves field-declaration order; routing is + -- declared before preference in ExplainOptions. + getRawEndpointQueries (bhRequestEndpoint withReq) + `shouldBe` [ ("routing", Just "user-42"), + ("preference", Just "_local") + ] + + -- ---------------------------------------------------------------------- + -- Live integration: only meaningful when a backend is reachable. + -- The bloodhound test suite as a whole requires ES/OS on + -- ES_TEST_SERVER (see AGENTS.md); these tests follow the same + -- convention as Test.DocumentsSpec. + describe "explainDocument (integration)" $ do + it "returns matched=True for a query that matches the indexed tweet" $ + withTestEnv $ do + _ <- insertData + result <- + tryPerformBHRequest $ + Common.explainDocument + testIndex + (DocId "1") + (TermQuery (Term "user" "bitemyapp") Nothing) + case result of + Left e -> + liftIO $ + expectationFailure $ + "expected a successful explain, got EsError: " <> show e + Right resp -> + liftIO $ do + explainResponseMatched resp `shouldBe` True + explainResponseExplanation resp `shouldSatisfy` isJust + + it "returns matched=False for a query that does not match (doc still exists)" $ + withTestEnv $ do + _ <- insertData + result <- + tryPerformBHRequest $ + Common.explainDocument + testIndex + (DocId "1") + (TermQuery (Term "user" "nobody-would-pick-this-name") Nothing) + case result of + Left e -> + liftIO $ + expectationFailure $ + "expected a successful explain, got EsError: " <> show e + Right resp -> + liftIO $ do + explainResponseMatched resp `shouldBe` False + -- Server still returns a synthetic explanation when the + -- doc exists but doesn't match (typically value 0.0 + -- with a description like "no matching term"). + explainResponseExplanation resp `shouldSatisfy` isJust + + it "decodes a missing document (HTTP 404 body) as matched=False with no explanation" $ + withTestEnv $ do + _ <- insertData + result <- + tryPerformBHRequest $ + Common.explainDocument + testIndex + (DocId "does-not-exist") + (MatchAllQuery Nothing) + case result of + Left e -> + liftIO $ + expectationFailure $ + "expected a successful explain for the 404 body, got EsError: " <> show e + Right resp -> + liftIO $ do + explainResponseMatched resp `shouldBe` False + -- The missing-doc body is + -- {"_index":...,"_id":...,"matched":false} with NO + -- explanation field; the 'Maybe' type lets the caller + -- distinguish "missing doc" from "doc exists, no match". + explainResponseExplanation resp `shouldBe` Nothing + + it "explainDocumentWith accepts URI parameters (preference) without error" $ + withTestEnv $ do + _ <- insertData + result <- + tryPerformBHRequest $ + Common.explainDocumentWith + defaultExplainOptions {eoPreference = Just "_local"} + testIndex + (DocId "1") + (TermQuery (Term "user" "bitemyapp") Nothing) + case result of + Left e -> + liftIO $ + expectationFailure $ + "expected a successful explain, got EsError: " <> show e + Right resp -> + liftIO $ do + explainResponseMatched resp `shouldBe` True + explainResponseExplanation resp `shouldSatisfy` isJust diff --git a/tests/Test/FeaturesSpec.hs b/tests/Test/FeaturesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FeaturesSpec.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.FeaturesSpec (spec) where + +import Data.Aeson +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch9.Client qualified as ClientES9 +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import Database.Bloodhound.ElasticSearch9.Types qualified as ES9 +import System.Environment (lookupEnv) +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +------------------------------------------------------------------------------ +-- Sample payloads (trimmed to the wire fields decoded by the types). +------------------------------------------------------------------------------ + +-- | @GET /_features@ response matching the documented example. +sampleGetFeaturesBytes :: LBS.ByteString +sampleGetFeaturesBytes = + "{\ + \ \"features\": [\ + \ {\"name\": \"tasks\", \"description\": \"Manages task results\"},\ + \ {\"name\": \"kibana\", \"description\": \"Manages Kibana configuration and reports\"}\ + \ ]\ + \}" + +-- | @POST /_features/_reset@ response matching the documented example, +-- which uses @feature_name@/@status@ (not the @name@/@description@ the +-- schema declares). +sampleResetExampleBytes :: LBS.ByteString +sampleResetExampleBytes = + "{\ + \ \"features\": [\ + \ {\"feature_name\": \"security\", \"status\": \"SUCCESS\"},\ + \ {\"feature_name\": \"tasks\", \"status\": \"SUCCESS\"}\ + \ ]\ + \}" + +-- | The schema-declared @name@/@description@ shape, which the reset +-- endpoint may also return. +sampleResetSchemaBytes :: LBS.ByteString +sampleResetSchemaBytes = + "{\ + \ \"features\": [\ + \ {\"name\": \"tasks\", \"description\": \"Manages task results\"}\ + \ ]\ + \}" + +spec :: Spec +spec = do + -------------------------------------------------------------------------- + -- JSON (de)serialisation + -------------------------------------------------------------------------- + describe "FeaturesResponse JSON" $ do + it "decodes the GET /_features example" $ do + let decoded = eitherDecode sampleGetFeaturesBytes :: Either String ES9.FeaturesResponse + decoded `shouldSatisfy` isRight + let Right resp = decoded + length (ES9.featuresResponseFeatures resp) `shouldBe` 2 + + it "round-trips through encode/decode" $ do + let decoded = eitherDecode sampleGetFeaturesBytes :: Either String ES9.FeaturesResponse + Right resp = decoded + eitherDecode (encode resp) `shouldBe` Right resp + + describe "ResetFeaturesResponse JSON" $ do + it "decodes the documented feature_name/status example" $ do + let decoded = eitherDecode sampleResetExampleBytes :: Either String ES9.ResetFeaturesResponse + decoded `shouldSatisfy` isRight + let Right resp = decoded + length (ES9.resetFeaturesResponseFeatures resp) `shouldBe` 2 + + it "decodes the schema-declared name/description shape" $ do + let decoded = eitherDecode sampleResetSchemaBytes :: Either String ES9.ResetFeaturesResponse + decoded `shouldSatisfy` isRight + let Right resp = decoded + [item] = ES9.resetFeaturesResponseFeatures resp + ES9.rfiName item `shouldBe` Just "tasks" + + -------------------------------------------------------------------------- + -- Endpoint shape + -------------------------------------------------------------------------- + describe "getFeatures endpoint shape" $ do + let req = RequestsES9.getFeatures + + it "GETs /_features" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_features"] + + it "uses the GET method" $ do + bhRequestMethod req `shouldBe` "GET" + + it "carries no request body" $ do + bhRequestBody req `shouldBe` Nothing + + it "carries no query string by default" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "renders master_timeout via getFeaturesWith" $ do + let opts = ES9.defaultFeaturesOptions {ES9.foMasterTimeout = Just (TimeUnitSeconds, 30)} + reqWith = RequestsES9.getFeaturesWith opts + getRawEndpointQueries (bhRequestEndpoint reqWith) + `shouldBe` [("master_timeout", Just "30s")] + + describe "resetFeatures endpoint shape" $ do + let req = RequestsES9.resetFeatures + + it "POSTs /_features/_reset" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_features", "_reset"] + + it "uses the POST method" $ do + bhRequestMethod req `shouldBe` "POST" + + it "sends an empty body" $ do + bhRequestBody req `shouldBe` Just "" + + it "carries no query string by default" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + -------------------------------------------------------------------------- + -- Live integration (ES9 only; the mutating reset is gated behind + -- ES_TEST_RUN_MUTATING so cluster state is not perturbed by default). + -------------------------------------------------------------------------- + backendSpecific + [ElasticSearch9] + $ describe "Features API (live integration)" + $ do + it "getFeatures returns a parseable response" $ + withTestEnv $ do + result <- tryEsError ClientES9.getFeatures + liftIO $ + case result of + Left e + | endpointMissing e -> + pendingWith "features endpoints require Elasticsearch 9+" + _ -> pure () + case result of + Left e -> liftIO $ expectationFailure $ "getFeatures failed: " <> show e + Right resp -> + liftIO $ + ES9.featuresResponseFeatures resp `shouldSatisfy` (not . null) + + it "resetFeatures returns a parseable response when ES_TEST_RUN_MUTATING=true" $ + withTestEnv $ do + enabled <- liftIO $ lookupEnv "ES_TEST_RUN_MUTATING" + case enabled of + Just "true" -> do + result <- tryEsError ClientES9.resetFeatures + liftIO $ + case result of + Left e + | endpointMissing e -> + pendingWith "features endpoints require Elasticsearch 9+" + _ -> pure () + case result of + Left e -> liftIO $ expectationFailure $ "resetFeatures failed: " <> show e + Right resp -> + liftIO $ + ES9.resetFeaturesResponseFeatures resp `shouldSatisfy` (not . null) + _ -> + liftIO $ + pendingWith + "skipped: set ES_TEST_RUN_MUTATING=true to run this mutating test" + +-- | Detect the @no handler found for uri@shape returned by Elasticsearch +-- when an endpoint isn't registered on this version. Used to mark the +-- live tests as 'pendingWith' rather than failing. +endpointMissing :: EsError -> Bool +endpointMissing e = + "no handler found" `T.isInfixOf` T.toLower (errorMessage e) diff --git a/tests/Test/FieldCapsSpec.hs b/tests/Test/FieldCapsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FieldCapsSpec.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-x-partial #-} + +module Test.FieldCapsSpec (spec) where + +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson.Key (fromText) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as BL8 +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + describe "FieldCapsRequest JSON" $ do + it "encodes an empty body as {}" $ + let req = defaultFieldCapsRequest + Object o = toJSON req + in KM.toList o `shouldBe` [] + + it "includes index_filter and runtime_mappings when provided" $ + let req = + FieldCapsRequest + { fieldCapsRequestIndexFilter = Just (MatchAllQuery Nothing), + fieldCapsRequestRuntimeMappings = Just (KM.fromList [(fromText "rate", object ["type" .= ("double" :: Text)])]) + } + Object o = toJSON req + in do + KM.lookup (fromText "index_filter") o `shouldBe` Just (toJSON (MatchAllQuery Nothing)) + KM.member (fromText "runtime_mappings") o `shouldBe` True + KM.lookup (fromText "fields") o `shouldBe` (Nothing :: Maybe Value) + + describe "FieldCapsOptions params" $ do + it "renders fields as a comma-joined URI param" $ + let opts = + defaultFieldCapsOptions + { fcoFields = Just [FieldPattern "user", FieldPattern "geo*"] + } + in lookup "fields" (fieldCapsOptionsParams opts) `shouldBe` Just (Just "user,geo*") + + it "omits fields when Nothing" $ + lookup "fields" (fieldCapsOptionsParams defaultFieldCapsOptions) `shouldBe` Nothing + + it "renders include_unmapped as a boolean string" $ + let opts = defaultFieldCapsOptions {fcoIncludeUnmapped = Just True} + in lookup "include_unmapped" (fieldCapsOptionsParams opts) `shouldBe` Just (Just "true") + + it "renders allow_no_indices as a boolean string" $ + let opts = defaultFieldCapsOptions {fcoAllowNoIndices = Just False} + in lookup "allow_no_indices" (fieldCapsOptionsParams opts) `shouldBe` Just (Just "false") + + it "renders expand_wildcards using Search.expandWildcardsText" $ + let opts = + defaultFieldCapsOptions + { fcoExpandWildcards = Just [ExpandWildcardsOpen, ExpandWildcardsClosed] + } + in lookup "expand_wildcards" (fieldCapsOptionsParams opts) `shouldBe` Just (Just "open,closed") + + describe "FieldCapsResponse JSON" $ do + it "decodes the canonical ES doc example with multi-type field" $ + let bytes = + BL8.pack + "{\"indices\":[\"index1\",\"index2\",\"index3\",\"index4\",\"index5\"],\"fields\":{\"rating\":{\"long\":{\"type\":\"long\",\"metadata_field\":false,\"searchable\":true,\"aggregatable\":false,\"indices\":[\"index1\",\"index2\"],\"non_aggregatable_indices\":[\"index1\"]},\"keyword\":{\"type\":\"keyword\",\"metadata_field\":false,\"searchable\":false,\"aggregatable\":true,\"indices\":[\"index3\",\"index4\"],\"non_searchable_indices\":[\"index4\"]}},\"title\":{\"text\":{\"type\":\"text\",\"metadata_field\":false,\"searchable\":true,\"aggregatable\":false}}}}" + Just resp = decode bytes + fields = fieldCapsResponseFields resp + Just rating = KM.lookup (fromText "rating") fields + Just ratingLong = KM.lookup (fromText "long") rating + Just ratingKeyword = KM.lookup (fromText "keyword") rating + Just title = KM.lookup (fromText "title") fields + Just titleText = KM.lookup (fromText "text") title + in do + fieldCapsResponseIndices resp + `shouldBe` Just + [ [qqIndexName|index1|], + [qqIndexName|index2|], + [qqIndexName|index3|], + [qqIndexName|index4|], + [qqIndexName|index5|] + ] + fieldCapabilityType ratingLong `shouldBe` "long" + fieldCapabilitySearchable ratingLong `shouldBe` True + fieldCapabilityAggregatable ratingLong `shouldBe` False + fieldCapabilityIndices ratingLong + `shouldBe` Just [[qqIndexName|index1|], [qqIndexName|index2|]] + fieldCapabilityNonAggregatableIndices ratingLong + `shouldBe` Just [[qqIndexName|index1|]] + fieldCapabilityType ratingKeyword `shouldBe` "keyword" + fieldCapabilitySearchable ratingKeyword `shouldBe` False + fieldCapabilityAggregatable ratingKeyword `shouldBe` True + fieldCapabilityNonSearchableIndices ratingKeyword + `shouldBe` Just [[qqIndexName|index4|]] + fieldCapabilityType titleText `shouldBe` "text" + fieldCapabilitySearchable titleText `shouldBe` True + fieldCapabilityAggregatable titleText `shouldBe` False + fieldCapabilityIndices titleText `shouldBe` Nothing + + it "decodes a response with null indices" $ + let bytes = + BL8.pack + "{\"indices\":null,\"fields\":{\"user\":{\"text\":{\"type\":\"text\",\"searchable\":true,\"aggregatable\":false}}}}" + Just resp = decode bytes + in do + fieldCapsResponseIndices resp `shouldBe` Nothing + KM.size (fieldCapsResponseFields resp) `shouldBe` 1 + + it "decodes a capability with metadata_field and meta map" $ + let bytes = + BL8.pack + "{\"indices\":[\"idx\"],\"fields\":{\"_id\":{\"_id\":{\"type\":\"_id\",\"searchable\":true,\"aggregatable\":true,\"metadata_field\":true,\"meta\":{\"_foo\":[\"bar\"]}}}}}" + Just resp = decode bytes + fields = fieldCapsResponseFields resp + Just _id = KM.lookup (fromText "_id") fields + Just _idCap = KM.lookup (fromText "_id") _id + in do + fieldCapabilityMetadataField _idCap `shouldBe` Just True + fieldCapabilityMeta _idCap + `shouldBe` Just (KM.fromList [(fromText "_foo", [String "bar"])]) + + it "ignores unknown experimental fields (time_series_dimension etc.)" $ + let bytes = + BL8.pack + "{\"indices\":null,\"fields\":{\"metric\":{\"long\":{\"type\":\"long\",\"searchable\":true,\"aggregatable\":true,\"time_series_dimension\":true,\"time_series_metric\":\"gauge\"}}}}" + Just resp = decode bytes + fields = fieldCapsResponseFields resp + Just metric = KM.lookup (fromText "metric") fields + Just longCap = KM.lookup (fromText "long") metric + in fieldCapabilityType longCap `shouldBe` "long" + + describe "Field Caps endpoint" $ do + it "returns capabilities for a single field via POST /_field_caps" $ + withTestEnv $ do + _ <- insertData + resp <- + performBHRequest $ + getFieldCaps (Just [testIndex]) [FieldPattern "user"] + liftIO $ do + let fields = fieldCapsResponseFields resp + Just user = KM.lookup (fromText "user") fields + KM.size user `shouldBe` 1 + let Just userText = KM.lookup (fromText "text") user + -- The TweetMapping in TestsUtils.Common sets fielddata=true + -- on user, so it is both searchable and aggregatable. + fieldCapabilitySearchable userText `shouldBe` True + fieldCapabilityAggregatable userText `shouldBe` True + + it "reports integer fields as aggregatable" $ + withTestEnv $ do + _ <- insertData + resp <- + performBHRequest $ + getFieldCaps (Just [testIndex]) [FieldPattern "age"] + liftIO $ do + let fields = fieldCapsResponseFields resp + Just age = KM.lookup (fromText "age") fields + cap = + case KM.lookup (fromText "long") age of + Just c -> c + Nothing -> case KM.lookup (fromText "integer") age of + Just c -> c + Nothing -> error "expected long or integer capability for age" + fieldCapabilitySearchable cap `shouldBe` True + fieldCapabilityAggregatable cap `shouldBe` True + + it "supports glob patterns" $ + withTestEnv $ do + _ <- insertData + resp <- + performBHRequest $ + getFieldCaps (Just [testIndex]) [FieldPattern "*"] + liftIO $ + KM.size (fieldCapsResponseFields resp) `shouldSatisfy` (> 1) + + it "works without an explicit index (POST /_field_caps)" $ + withTestEnv $ do + _ <- insertData + resp <- + performBHRequest $ + getFieldCaps Nothing [FieldPattern "user"] + liftIO $ + KM.member (fromText "user") (fieldCapsResponseFields resp) `shouldBe` True + + it "passes include_unmapped via FieldCapsOptions" $ + withTestEnv $ do + _ <- insertData + resp <- + performBHRequest $ + getFieldCapsWith + (Just [testIndex]) + defaultFieldCapsOptions + { fcoIncludeUnmapped = Just True, + fcoFields = Just [FieldPattern "nonexistent_*"] + } + defaultFieldCapsRequest + liftIO $ + KM.size (fieldCapsResponseFields resp) `shouldBe` 0 + + it "accepts Just [] as equivalent to Nothing for the index list" $ + withTestEnv $ do + _ <- insertData + resp <- + performBHRequest $ + getFieldCaps (Just []) [FieldPattern "user"] + liftIO $ + KM.member (fromText "user") (fieldCapsResponseFields resp) `shouldBe` True + + it "passes expand_wildcards via FieldCapsOptions" $ + withTestEnv $ do + _ <- insertData + resp <- + performBHRequest $ + getFieldCapsWith + (Just [testIndex]) + defaultFieldCapsOptions + { fcoFields = Just [FieldPattern "user"], + fcoExpandWildcards = Just [ExpandWildcardsOpen] + } + defaultFieldCapsRequest + liftIO $ + KM.member (fromText "user") (fieldCapsResponseFields resp) `shouldBe` True + + it "accepts an index_filter in the request body" $ + withTestEnv $ do + _ <- insertData + resp <- + performBHRequest $ + getFieldCapsWith + (Just [testIndex]) + defaultFieldCapsOptions {fcoFields = Just [FieldPattern "age"]} + ( defaultFieldCapsRequest + { fieldCapsRequestIndexFilter = Just (MatchAllQuery Nothing) + } + ) + liftIO $ do + let fields = fieldCapsResponseFields resp + KM.member (fromText "age") fields `shouldBe` True diff --git a/tests/Test/FieldUsageStatsSpec.hs b/tests/Test/FieldUsageStatsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FieldUsageStatsSpec.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Test.FieldUsageStatsSpec (spec) where + +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as LBS +import Data.List (sort) +import Database.Bloodhound.Common.Types +import Optics (set, view) +import TestsUtils.Common +import TestsUtils.Import + +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + +-- | A trimmed slice of the documented response: @\"_shards\"@ + one +-- index with a single shard carrying routing and a stats object. +sampleResponseBytes :: LBS.ByteString +sampleResponseBytes = + "{\"_shards\":{\"total\":1,\"successful\":1,\"failed\":0},\ + \\"my-index-000001\":{\"shards\":[{\ + \\"tracking_id\":\"MpOl0QlTQ4SYYhEe6KgJoQ\",\ + \\"tracking_started_at_millis\":1625558985010,\ + \\"routing\":{\"state\":\"STARTED\",\"primary\":true,\"node\":\"n1\",\"relocating_node\":null},\ + \\"stats\":{\"all_fields\":{\"any\":6,\"inverted_index\":{\"terms\":1,\"postings\":1},\ + \\"stored_fields\":2,\"doc_values\":1,\"points\":0,\"norms\":1,\"term_vectors\":0},\ + \\"fields\":{\"_id\":{\"any\":1,\"stored_fields\":1}}}}]}}" + +spec :: Spec +spec = do + -- ------------------------------------------------------------------ -- + -- Pure JSON decoder tests (no ES required). -- + -- ------------------------------------------------------------------ -- + describe "FieldUsageStatsResponse JSON parsing" $ do + it "peels _shards and parses the nested shard/stats structure" $ do + let Just (r :: FieldUsageStatsResponse) = decode sampleResponseBytes + shardTotal (fusrShards r) `shouldBe` 1 + case KM.lookup "my-index-000001" (fusrIndices r) of + Just ix -> case fusiShards ix of + [s] -> do + fusTrackingId s `shouldBe` Just "MpOl0QlTQ4SYYhEe6KgJoQ" + fusTrackingStartedAtMillis s `shouldBe` Just 1625558985010 + case fusRouting s of + Just rt -> do + furState rt `shouldBe` Just "STARTED" + furPrimary rt `shouldBe` Just True + furRelocatingNode rt `shouldBe` Nothing + Nothing -> expectationFailure "expected routing" + case fusStats s of + Just st -> do + case fustatAllFields st of + Just af -> do + fubAny af `shouldBe` Just 6 + case fubInvertedIndex af of + Just ii -> fuiiTerms ii `shouldBe` Just 1 + Nothing -> expectationFailure "expected inverted_index" + Nothing -> expectationFailure "expected all_fields" + case fustatFields st of + Just fields -> case KM.lookup "_id" fields of + Just fb -> fubAny fb `shouldBe` Just 1 + Nothing -> expectationFailure "expected _id field" + Nothing -> expectationFailure "expected fields map" + Nothing -> expectationFailure "expected stats" + other -> + expectationFailure ("expected singleton shards list, got " <> show other) + Nothing -> expectationFailure "expected my-index-000001 entry" + + it "round-trips the documented response via ToJSON/FromJSON" $ do + let Just (original :: FieldUsageStatsResponse) = decode sampleResponseBytes + reDecoded = decode (encode original) :: Maybe FieldUsageStatsResponse + Just original `shouldBe` reDecoded + + describe "FieldUsageBreakdown JSON parsing" $ do + let bare = "{\"any\":3,\"doc_values\":2}" + it "parses a minimal breakdown leniently" $ do + let Just (fb :: FieldUsageBreakdown) = decode bare + fubAny fb `shouldBe` Just 3 + fubDocValues fb `shouldBe` Just 2 + fubInvertedIndex fb `shouldBe` Nothing + + it "round-trips via ToJSON/FromJSON" $ do + let Just (original :: FieldUsageBreakdown) = decode bare + reDecoded = decode (encode original) :: Maybe FieldUsageBreakdown + Just original `shouldBe` reDecoded + + -- ------------------------------------------------------------------ -- + -- Optics. -- + -- ------------------------------------------------------------------ -- + describe "FieldUsageStats lenses" $ do + it "fubAnyLens is a lawful get/set" $ do + let fb = FieldUsageBreakdown Nothing Nothing Nothing Nothing Nothing Nothing Nothing + fb' = set fubAnyLens (Just 9) fb + view fubAnyLens fb' `shouldBe` Just 9 + + it "fusoFieldsLens is a lawful get/set" $ do + let opts = set fusoFieldsLens (Just ("a" :| [])) defaultFieldUsageStatsOptions + view fusoFieldsLens opts `shouldBe` Just ("a" :| []) + + -- ------------------------------------------------------------------ -- + -- Options rendering. -- + -- ------------------------------------------------------------------ -- + describe "FieldUsageStatsOptions URI param rendering" $ do + it "defaultFieldUsageStatsOptions emits no params" $ + fieldUsageStatsOptionsParams defaultFieldUsageStatsOptions + `shouldBe` [] + + it "renders fields as a comma-separated list" $ do + let opts = + defaultFieldUsageStatsOptions + { fusoFields = Just ("_id" :| ["message", "*.keyword"]) + } + lookup "fields" (fieldUsageStatsOptionsParams opts) + `shouldBe` Just (Just "_id,message,*.keyword") + + it "renders expand_wildcards as a comma-separated list" $ do + let opts = + defaultFieldUsageStatsOptions + { fusoExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + lookup "expand_wildcards" (fieldUsageStatsOptionsParams opts) + `shouldBe` Just (Just "open,closed") + + it "renders the accepted params together" $ do + let opts = + defaultFieldUsageStatsOptions + { fusoIgnoreUnavailable = Just True, + fusoAllowNoIndices = Just False, + fusoFields = Just ("_id" :| ["message"]) + } + normalize (fieldUsageStatsOptionsParams opts) + `shouldBe` [ ("allow_no_indices", Just "false"), + ("fields", Just "_id,message"), + ("ignore_unavailable", Just "true") + ] + + -- ------------------------------------------------------------------ -- + -- Endpoint shape (BHRequest, no ES required). -- + -- ------------------------------------------------------------------ -- + describe "fieldUsageStats endpoint shape" $ do + let idx = [qqIndexName|my-idx|] + + it "GETs /{index}/_field_usage_stats with no params by default" $ do + let req = fieldUsageStats idx + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["my-idx", "_field_usage_stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "carries no request body" $ do + let req = fieldUsageStats idx + bhRequestBody req `shouldBe` Nothing + + it "forwards fields via the With variant" $ do + let opts = defaultFieldUsageStatsOptions {fusoFields = Just ("_id" :| [])} + req = fieldUsageStatsWith opts idx + lookup "fields" (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` Just (Just "_id") diff --git a/tests/Test/FleetSpec.hs b/tests/Test/FleetSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FleetSpec.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.FleetSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import TestsUtils.Import +import Prelude + +-- | Canonical @GET /{index}/_fleet/global_checkpoints@ response. +sampleGlobalCheckpointsBytes :: LBS.ByteString +sampleGlobalCheckpointsBytes = + "{\ + \ \"global_checkpoints\": [0, 42, 100],\ + \ \"timed_out\": false\ + \}" + +-- | A polling response that @timed_out@ before advancing, plus an unknown +-- sibling field (@future_field@) the @fgcrExtras@ catch-all must keep. +sampleGlobalCheckpointsWithExtrasBytes :: LBS.ByteString +sampleGlobalCheckpointsWithExtrasBytes = + "{\ + \ \"global_checkpoints\": [42],\ + \ \"timed_out\": true,\ + \ \"future_field\": \"experimental\"\ + \}" + +spec :: Spec +spec = describe "Fleet API" $ do + describe "GlobalCheckpoint JSON" $ do + it "round-trips as a JSON number" $ do + let Just decoded = decode "42" :: Maybe GlobalCheckpoint + unGlobalCheckpoint decoded `shouldBe` 42 + encode (42 :: GlobalCheckpoint) `shouldBe` "42" + + it "decodes the documented -1 'no checkpoint' sentinel" $ do + let Just decoded = decode "-1" :: Maybe GlobalCheckpoint + unGlobalCheckpoint decoded `shouldBe` (-1) + + it "rejects a non-number value" $ do + let decoded = decode "\"x\"" :: Maybe GlobalCheckpoint + decoded `shouldBe` Nothing + + describe "FleetGlobalCheckpointsResponse JSON" $ do + it "decodes the canonical shape" $ do + let Just decoded = + decode sampleGlobalCheckpointsBytes :: + Maybe FleetGlobalCheckpointsResponse + fgcrCheckpoints decoded `shouldBe` [0, 42, 100] + fgcrTimedOut decoded `shouldBe` False + fgcrExtras decoded `shouldBe` KM.empty + + it "preserves unknown sibling fields in extras" $ do + let Just decoded = + decode sampleGlobalCheckpointsWithExtrasBytes :: + Maybe FleetGlobalCheckpointsResponse + fgcrTimedOut decoded `shouldBe` True + KM.lookup "future_field" (fgcrExtras decoded) `shouldSatisfy` isJust + + it "round-trips through encode . decode" $ do + let Just decoded = + decode sampleGlobalCheckpointsWithExtrasBytes :: + Maybe FleetGlobalCheckpointsResponse + Just roundTripped = + decode (encode decoded) :: Maybe FleetGlobalCheckpointsResponse + fgcrCheckpoints roundTripped `shouldBe` [42] + fgcrTimedOut roundTripped `shouldBe` True + -- The @future_field@ extra survives the round-trip. + KM.lookup "future_field" (fgcrExtras roundTripped) `shouldSatisfy` isJust + -- The known keys are not duplicated into extras. + KM.lookup "global_checkpoints" (fgcrExtras roundTripped) `shouldBe` Nothing + + it "rejects a response missing 'global_checkpoints'" $ do + let decoded = + decode "{\"timed_out\":false}" :: + Maybe FleetGlobalCheckpointsResponse + decoded `shouldBe` Nothing + + it "decodes an empty global_checkpoints array" $ do + let Just decoded = + decode "{\"global_checkpoints\":[],\"timed_out\":false}" :: + Maybe FleetGlobalCheckpointsResponse + fgcrCheckpoints decoded `shouldBe` [] + fgcrTimedOut decoded `shouldBe` False + + describe "FleetGlobalCheckpointsOptions params" $ do + it "default options render no query string" $ do + fleetGlobalCheckpointsOptionsParams defaultFleetGlobalCheckpointsOptions + `shouldBe` [] + + it "renders boolean wait_for_advance / wait_for_index" $ do + let opts = + defaultFleetGlobalCheckpointsOptions + { fgcoWaitForAdvance = Just True, + fgcoWaitForIndex = Just False + } + fleetGlobalCheckpointsOptionsParams opts + `shouldContain` [("wait_for_advance", Just "true")] + fleetGlobalCheckpointsOptionsParams opts + `shouldContain` [("wait_for_index", Just "false")] + + it "renders checkpoints as a comma-separated list" $ do + let opts = + defaultFleetGlobalCheckpointsOptions + { fgcoCheckpoints = [1, 2, 3] + } + fleetGlobalCheckpointsOptionsParams opts + `shouldContain` [("checkpoints", Just "1,2,3")] + + it "omits an empty checkpoints list" $ do + let opts = + defaultFleetGlobalCheckpointsOptions + { fgcoCheckpoints = [] + } + fleetGlobalCheckpointsOptionsParams opts + `shouldBe` [] + + it "renders timeout as magnitude plus time-unit suffix" $ do + let opts = + defaultFleetGlobalCheckpointsOptions + { fgcoTimeout = Just (TimeUnitSeconds, 30) + } + fleetGlobalCheckpointsOptionsParams opts + `shouldContain` [("timeout", Just "30s")] + + describe "FleetSearchOptions params" $ do + it "default options render no query string" $ do + fleetSearchOptionsParams defaultFleetSearchOptions + `shouldBe` [] + + it "renders wait_for_checkpoints as a comma-separated list" $ do + let opts = + defaultFleetSearchOptions + { fsoWaitForCheckpoints = [7, 14] + } + fleetSearchOptionsParams opts + `shouldContain` [("wait_for_checkpoints", Just "7,14")] + + it "renders allow_partial_search_results as a bool string" $ do + let opts = + defaultFleetSearchOptions + { fsoAllowPartialSearchResults = Just False + } + fleetSearchOptionsParams opts + `shouldContain` [("allow_partial_search_results", Just "false")] + + it "omits an empty wait_for_checkpoints list" $ do + let opts = + defaultFleetSearchOptions + { fsoWaitForCheckpoints = [] + } + fleetSearchOptionsParams opts + `shouldNotContain` [("wait_for_checkpoints", Just "")] diff --git a/tests/Test/FlowFrameworkSpec.hs b/tests/Test/FlowFrameworkSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FlowFrameworkSpec.hs @@ -0,0 +1,784 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.FlowFrameworkSpec (spec) where + +import Data.Aeson +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List (isInfixOf) +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- --------------------------------------------------------------------------- +-- Sample bodies, drawn verbatim from the OS Flow Framework plugin docs +-- (). +-- --------------------------------------------------------------------------- + +-- | A bare-bones fire-and-forget create / provision response — just the +-- server-assigned @workflow_id@. This is the shape returned when no +-- @wait_for_completion_timeout@ is supplied. +sampleWorkflowIdResponseJson :: LBS.ByteString +sampleWorkflowIdResponseJson = "{\"workflow_id\":\"8xL8bowB8y25Tqfenm50\"}" + +-- | The richer timed create / provision response, carrying the +-- terminal @state@ and the list of @resources_created@ entries. Drawn +-- verbatim from the create-workflow docs page. +sampleTimedResponseJson :: LBS.ByteString +sampleTimedResponseJson = + "{\ + \ \"workflow_id\": \"K13IR5QBEpCfUu_-AQdU\",\ + \ \"state\": \"COMPLETED\",\ + \ \"resources_created\": [\ + \ {\"workflow_step_name\": \"create_connector\",\ + \ \"workflow_step_id\": \"create_connector_1\",\ + \ \"resource_id\": \"LF3IR5QBEpCfUu_-Awd_\",\ + \ \"resource_type\": \"connector_id\"},\ + \ {\"workflow_step_id\": \"register_model_2\",\ + \ \"workflow_step_name\": \"register_remote_model\",\ + \ \"resource_id\": \"L13IR5QBEpCfUu_-BQdI\",\ + \ \"resource_type\": \"model_id\"},\ + \ {\"workflow_step_name\": \"deploy_model\",\ + \ \"workflow_step_id\": \"deploy_model_3\",\ + \ \"resource_id\": \"L13IR5QBEpCfUu_-BQdI\",\ + \ \"resource_type\": \"model_id\"}\ + \ ]\ + \}" + +-- | The canonical \"Register and deploy a remote model\" template body — +-- exercises the three CORE step types chained via @previous_node_inputs@. +sampleRemoteModelTemplateJson :: LBS.ByteString +sampleRemoteModelTemplateJson = + "{\ + \ \"name\": \"createconnector-registerremotemodel-deploymodel\",\ + \ \"description\": \"An example of registering a remote model\",\ + \ \"use_case\": \"REMOTE_MODEL_DEPLOYMENT\",\ + \ \"version\": {\"template\": \"1.0.0\", \"compatibility\": [\"2.12.0\", \"3.0.0\"]},\ + \ \"workflows\": {\ + \ \"provision\": {\ + \ \"nodes\": [\ + \ {\"id\": \"create_connector_1\",\ + \ \"type\": \"create_connector\",\ + \ \"user_inputs\": {\ + \ \"name\": \"OpenAI Chat Connector\",\ + \ \"description\": \"Connector to public OpenAI service\",\ + \ \"version\": \"1\",\ + \ \"protocol\": \"http\",\ + \ \"parameters\": {\"endpoint\": \"https://api.openai.com/v1/chat/completions\", \"model\": \"gpt-3.5-turbo\"},\ + \ \"credential\": {\"openAI_key\": \"12345\"},\ + \ \"actions\": [{\"action_type\": \"predict\", \"method\": \"POST\", \"url\": \"https://api.openai.com/v1/chat/completions\"}]\ + \ }\ + \ },\ + \ {\"id\": \"register_model_2\",\ + \ \"type\": \"register_remote_model\",\ + \ \"previous_node_inputs\": {\"create_connector_1\": \"connector_id\"},\ + \ \"user_inputs\": {\"name\": \"remote-inference-model\", \"function_name\": \"remote\"}\ + \ },\ + \ {\"id\": \"deploy_model_3\",\ + \ \"type\": \"deploy_model\",\ + \ \"previous_node_inputs\": {\"register_model_2\": \"model_id\"}\ + \ }\ + \ ]\ + \ }\ + \ }\ + \}" + +spec :: Spec +spec = describe "Flow Framework plugin" $ do + -- ======================================================================= + -- WorkflowId newtype + -- ======================================================================= + describe "WorkflowId JSON" $ do + it "round-trips as a bare JSON string" $ do + let wid = WorkflowId "8xL8bowB8y25Tqfenm50" + (decode . encode) wid `shouldBe` Just wid + it "encodes as a bare string, not an object" $ + encode (WorkflowId "abc") `shouldBe` "\"abc\"" + + -- ======================================================================= + -- WorkflowState enum + -- ======================================================================= + describe "WorkflowState JSON" $ do + let cases = + [ (WorkflowStateNotStarted, "NOT_STARTED"), + (WorkflowStateProvisioning, "PROVISIONING"), + (WorkflowStateCompleted, "COMPLETED"), + (WorkflowStateFailed, "FAILED") + ] + forM_ cases $ \(s, wire) -> do + it ("encodes " <> show wire <> " to the documented wire string") $ + encode s `shouldBe` "\"" <> LBS.fromStrict wire <> "\"" + it ("decodes the documented wire string " <> show wire) $ + decode ("\"" <> LBS.fromStrict wire <> "\"" :: LBS.ByteString) + `shouldBe` Just s + + it "decodes an unknown state into WorkflowStateOther (forward-compat)" $ + decode "\"QUEUED\"" `shouldBe` Just (WorkflowStateOther "QUEUED") + + it "round-trips an unknown state through Other" $ do + let s = WorkflowStateOther "WEIRD" + (decode . encode) s `shouldBe` Just s + + it "rejects a non-string state" $ + decode "42" `shouldBe` (Nothing :: Maybe WorkflowState) + + it "round-trips through ToJSON/FromJSON" $ + property $ + \s -> (decode . encode) s === (Just s :: Maybe WorkflowState) + + -- ======================================================================= + -- ValidationMode enum + -- ======================================================================= + describe "ValidationMode JSON" $ do + let cases = + [ (ValidationAll, "all"), + (ValidationNone, "none") + ] + forM_ cases $ \(v, wire) -> do + it ("encodes " <> show wire) $ + encode v `shouldBe` "\"" <> LBS.fromStrict wire <> "\"" + it ("decodes " <> show wire) $ + decode ("\"" <> LBS.fromStrict wire <> "\"" :: LBS.ByteString) `shouldBe` Just v + it "rejects an unknown value" $ + decode "\"strict\"" `shouldBe` (Nothing :: Maybe ValidationMode) + + -- ======================================================================= + -- WorkflowVersion + -- ======================================================================= + describe "WorkflowVersion JSON" $ do + it "round-trips a fully-populated version" $ do + let v = WorkflowVersion (Just "1.0.0") (Just ["2.12.0", "3.0.0"]) + (decode . encode) v `shouldBe` Just v + it "round-trips an empty version" $ do + let v = WorkflowVersion Nothing Nothing + (decode . encode) v `shouldBe` Just v + it "renders as {} when fully Nothing" $ + encode (WorkflowVersion Nothing Nothing) `shouldBe` "{}" + + -- ======================================================================= + -- DeployModelUserInputs (minimal CORE variant) + -- ======================================================================= + describe "DeployModelUserInputs JSON" $ do + it "round-trips when model_id is set" $ do + let x = DeployModelUserInputs (Just "abc-123") + (decode . encode) x `shouldBe` Just x + it "round-trips when model_id is omitted (injected via previous_node_inputs)" $ do + let x = DeployModelUserInputs Nothing + (decode . encode) x `shouldBe` Just x + it "decodes {} to model_id=Nothing (matches deploy-with-injection shape)" $ + decode "{}" `shouldBe` Just (DeployModelUserInputs Nothing) + it "encodes {} when model_id is Nothing" $ + encode (DeployModelUserInputs Nothing) `shouldBe` "{}" + + -- ======================================================================= + -- CreateIndexUserInputs / CreateIngestPipelineUserInputs + -- ======================================================================= + describe "CreateIndexUserInputs JSON" $ do + it "round-trips the two-field shape" $ do + let x = CreateIndexUserInputs "my-index" "{\"mappings\":{}}" + (decode . encode) x `shouldBe` Just x + it "encodes both fields" $ do + let lbs = encode (CreateIndexUserInputs "idx" "{}") + LBS.unpack lbs `shouldSatisfy` isInfixOf "\"index_name\":\"idx\"" + LBS.unpack lbs `shouldSatisfy` isInfixOf "\"configurations\":\"{}\"" + + describe "CreateIngestPipelineUserInputs JSON" $ do + it "round-trips the two-field shape" $ do + let x = CreateIngestPipelineUserInputs "my-pipeline" "{\"processors\":[]}" + (decode . encode) x `shouldBe` Just x + it "encodes both fields" $ do + let lbs = encode (CreateIngestPipelineUserInputs "pip" "{}") + LBS.unpack lbs `shouldSatisfy` isInfixOf "\"pipeline_id\":\"pip\"" + LBS.unpack lbs `shouldSatisfy` isInfixOf "\"configurations\":\"{}\"" + + -- ======================================================================= + -- WorkflowConnectorAction (sub-record of CreateConnectorUserInputs) + -- ======================================================================= + describe "WorkflowConnectorAction JSON" $ do + it "round-trips a minimal action (required fields only)" $ do + let a = + WorkflowConnectorAction + { workflowConnectorActionType = "predict", + workflowConnectorActionMethod = "POST", + workflowConnectorActionUrl = "https://api.example.com", + workflowConnectorActionHeaders = Nothing, + workflowConnectorActionRequestBody = Nothing, + workflowConnectorActionPreProcessFunction = Nothing, + workflowConnectorActionPostProcessFunction = Nothing + } + (decode . encode) a `shouldBe` Just a + it "round-trips a fully-populated action" $ do + let a = + WorkflowConnectorAction + { workflowConnectorActionType = "predict", + workflowConnectorActionMethod = "POST", + workflowConnectorActionUrl = "https://api.example.com", + workflowConnectorActionHeaders = Just Map.empty, + workflowConnectorActionRequestBody = Just (object ["foo" .= (1 :: Int)]), + workflowConnectorActionPreProcessFunction = Just "return params;", + workflowConnectorActionPostProcessFunction = Just "return params;" + } + (decode . encode) a `shouldBe` Just a + it "omits optional fields when Nothing" $ + encode + ( WorkflowConnectorAction + { workflowConnectorActionType = "predict", + workflowConnectorActionMethod = "POST", + workflowConnectorActionUrl = "https://x", + workflowConnectorActionHeaders = Nothing, + workflowConnectorActionRequestBody = Nothing, + workflowConnectorActionPreProcessFunction = Nothing, + workflowConnectorActionPostProcessFunction = Nothing + } + ) + `shouldBe` "{\"action_type\":\"predict\",\"method\":\"POST\",\"url\":\"https://x\"}" + + -- ======================================================================= + -- CreateConnectorUserInputs (richest CORE variant) + -- ======================================================================= + describe "CreateConnectorUserInputs JSON" $ do + let sampleInputs = + CreateConnectorUserInputs + { createConnectorUserInputsName = "OpenAI Chat Connector", + createConnectorUserInputsDescription = "Connector to public OpenAI service", + createConnectorUserInputsVersion = "1", + createConnectorUserInputsProtocol = "http", + createConnectorUserInputsParameters = Map.fromList [("endpoint", "https://api.openai.com/v1"), ("model", "gpt-3.5-turbo")], + createConnectorUserInputsCredential = Map.fromList [("openAI_key", "12345")], + createConnectorUserInputsActions = + [ WorkflowConnectorAction + { workflowConnectorActionType = "predict", + workflowConnectorActionMethod = "POST", + workflowConnectorActionUrl = "https://api.openai.com/v1/chat/completions", + workflowConnectorActionHeaders = Nothing, + workflowConnectorActionRequestBody = Nothing, + workflowConnectorActionPreProcessFunction = Nothing, + workflowConnectorActionPostProcessFunction = Nothing + } + ], + createConnectorUserInputsBackendRoles = Nothing, + createConnectorUserInputsAddAllBackendRoles = Nothing, + createConnectorUserInputsAccessMode = Nothing, + createConnectorUserInputsClientConfig = Nothing, + createConnectorUserInputsUrl = Nothing, + createConnectorUserInputsHeaders = Nothing + } + it "round-trips the documented sample" $ + (decode . encode) sampleInputs `shouldBe` Just sampleInputs + it "requires the seven mandatory fields" $ do + -- Missing name -> parse fails + decode "{\"description\":\"x\",\"version\":\"1\",\"protocol\":\"http\",\"parameters\":{},\"credential\":{},\"actions\":[]}" + `shouldBe` (Nothing :: Maybe CreateConnectorUserInputs) + it "omits all optional fields when Nothing" $ do + let encoded = encode sampleInputs + -- No optional keys should appear + LBS.unpack encoded + `shouldNotSatisfy` isInfixOf "backend_roles" + LBS.unpack encoded + `shouldNotSatisfy` isInfixOf "access_mode" + + -- ======================================================================= + -- RegisterRemoteModelUserInputs (CORE variant with required + optional) + -- ======================================================================= + describe "RegisterRemoteModelUserInputs JSON" $ do + it "round-trips the documented remote-inference-model sample" $ do + let x = + RegisterRemoteModelUserInputs + { registerRemoteModelUserInputsName = "remote-inference-model", + registerRemoteModelUserInputsConnectorId = Nothing, + registerRemoteModelUserInputsFunctionName = Just "remote", + registerRemoteModelUserInputsModelGroupId = Nothing, + registerRemoteModelUserInputsDescription = Nothing, + registerRemoteModelUserInputsDeploy = Nothing, + registerRemoteModelUserInputsGuardrails = Nothing, + registerRemoteModelUserInputsInterface = Nothing, + registerRemoteModelUserInputsIsEnabled = Nothing, + registerRemoteModelUserInputsRateLimiter = Nothing, + registerRemoteModelUserInputsDeploySetting = Nothing, + registerRemoteModelUserInputsBackendRoles = Nothing, + registerRemoteModelUserInputsAddAllBackendRoles = Nothing, + registerRemoteModelUserInputsAccessMode = Nothing, + registerRemoteModelUserInputsModelNodeIds = Nothing + } + (decode . encode) x `shouldBe` Just x + it "requires name" $ + decode "{\"connector_id\":\"x\"}" `shouldBe` (Nothing :: Maybe RegisterRemoteModelUserInputs) + it "decodes the doc-sample shape (name + function_name, no connector_id)" $ do + -- The canonical "remote-inference-model" doc sample uses + -- previous_node_inputs to inject connector_id, so user_inputs + -- carries only name and function_name. Decode must succeed. + let lbs = "{\"name\":\"x\",\"function_name\":\"remote\"}" :: LBS.ByteString + decode lbs + `shouldBe` Just + ( RegisterRemoteModelUserInputs + { registerRemoteModelUserInputsName = "x", + registerRemoteModelUserInputsConnectorId = Nothing, + registerRemoteModelUserInputsFunctionName = Just "remote", + registerRemoteModelUserInputsModelGroupId = Nothing, + registerRemoteModelUserInputsDescription = Nothing, + registerRemoteModelUserInputsDeploy = Nothing, + registerRemoteModelUserInputsGuardrails = Nothing, + registerRemoteModelUserInputsInterface = Nothing, + registerRemoteModelUserInputsIsEnabled = Nothing, + registerRemoteModelUserInputsRateLimiter = Nothing, + registerRemoteModelUserInputsDeploySetting = Nothing, + registerRemoteModelUserInputsBackendRoles = Nothing, + registerRemoteModelUserInputsAddAllBackendRoles = Nothing, + registerRemoteModelUserInputsAccessMode = Nothing, + registerRemoteModelUserInputsModelNodeIds = Nothing + } + ) + + -- ======================================================================= + -- NodeInputs open sum type + -- ======================================================================= + describe "NodeInputs type tag" $ do + -- Verify each typed variant reports its wire tag correctly. + it "nodeInputsType for DeployModelInputs is \"deploy_model\"" $ + nodeInputsType (DeployModelInputs (DeployModelUserInputs (Just "x"))) + `shouldBe` "deploy_model" + it "nodeInputsType for CreateConnectorInputs is \"create_connector\"" $ + nodeInputsType (CreateConnectorInputs (error "unused" :: CreateConnectorUserInputs)) + `shouldBe` "create_connector" + it "nodeInputsType for RegisterRemoteModelInputs is \"register_remote_model\"" $ + nodeInputsType + ( RegisterRemoteModelInputs + ( RegisterRemoteModelUserInputs + { registerRemoteModelUserInputsName = "x", + registerRemoteModelUserInputsConnectorId = Nothing, + registerRemoteModelUserInputsFunctionName = Nothing, + registerRemoteModelUserInputsModelGroupId = Nothing, + registerRemoteModelUserInputsDescription = Nothing, + registerRemoteModelUserInputsDeploy = Nothing, + registerRemoteModelUserInputsGuardrails = Nothing, + registerRemoteModelUserInputsInterface = Nothing, + registerRemoteModelUserInputsIsEnabled = Nothing, + registerRemoteModelUserInputsRateLimiter = Nothing, + registerRemoteModelUserInputsDeploySetting = Nothing, + registerRemoteModelUserInputsBackendRoles = Nothing, + registerRemoteModelUserInputsAddAllBackendRoles = Nothing, + registerRemoteModelUserInputsAccessMode = Nothing, + registerRemoteModelUserInputsModelNodeIds = Nothing + } + ) + ) + `shouldBe` "register_remote_model" + it "nodeInputsType for CreateIndexInputs is \"create_index\"" $ + nodeInputsType (CreateIndexInputs (CreateIndexUserInputs "i" "{}")) + `shouldBe` "create_index" + it "nodeInputsType for CreateIngestPipelineInputs is \"create_ingest_pipeline\"" $ + nodeInputsType (CreateIngestPipelineInputs (CreateIngestPipelineUserInputs "p" "{}")) + `shouldBe` "create_ingest_pipeline" + it "nodeInputsType for OtherInputs is the captured type string" $ + nodeInputsType (OtherInputs "noop" (object [])) `shouldBe` "noop" + + -- ======================================================================= + -- WorkflowNode round-trip (id + type + user_inputs + previous_node_inputs) + -- ======================================================================= + describe "WorkflowNode JSON" $ do + it "round-trips a deploy_model node with previous_node_inputs" $ do + let n = + WorkflowNode + { workflowNodeId = "deploy_model_3", + workflowNodeInputs = DeployModelInputs (DeployModelUserInputs Nothing), + workflowNodePreviousInputs = Just (Map.fromList [("register_model_2", "model_id")]) + } + (decode . encode) n `shouldBe` Just n + + it "round-trips an OtherInputs node (untyped step)" $ do + let n = + WorkflowNode + { workflowNodeId = "noop_1", + workflowNodeInputs = OtherInputs "noop" (object ["delay" .= (5 :: Int)]), + workflowNodePreviousInputs = Nothing + } + (decode . encode) n `shouldBe` Just n + + it "decodes a node whose user_inputs is omitted (e.g. noop)" $ do + -- A noop node may omit user_inputs entirely; decode must still + -- succeed and produce OtherInputs carrying an empty object. + let lbs = "{\"id\":\"noop_1\",\"type\":\"noop\"}" :: LBS.ByteString + decode lbs + `shouldBe` Just + ( WorkflowNode + { workflowNodeId = "noop_1", + workflowNodeInputs = OtherInputs "noop" (object []), + workflowNodePreviousInputs = Nothing + } + ) + + it "encodes a node with no previous_node_inputs omitting that field" $ do + let n = + WorkflowNode + { workflowNodeId = "deploy_model_3", + workflowNodeInputs = DeployModelInputs (DeployModelUserInputs Nothing), + workflowNodePreviousInputs = Nothing + } + LBS.unpack (encode n) + `shouldNotSatisfy` isInfixOf "previous_node_inputs" + + -- ======================================================================= + -- WorkflowEdge round-trip + -- ======================================================================= + describe "WorkflowEdge JSON" $ do + it "round-trips a simple edge" $ do + let e = WorkflowEdge "a" "b" + (decode . encode) e `shouldBe` Just e + it "encodes both fields" $ do + let lbs = encode (WorkflowEdge "a" "b") + LBS.unpack lbs `shouldSatisfy` isInfixOf "\"source\":\"a\"" + LBS.unpack lbs `shouldSatisfy` isInfixOf "\"dest\":\"b\"" + + -- ======================================================================= + -- WorkflowEntry (subset of WorkflowTemplate.workflows map) + -- ======================================================================= + describe "WorkflowEntry JSON" $ do + it "round-trips a one-node, no-edges entry" $ do + let e = + WorkflowEntry + { workflowEntryUserParams = Nothing, + workflowEntryNodes = + [ WorkflowNode + { workflowNodeId = "deploy_model_3", + workflowNodeInputs = DeployModelInputs (DeployModelUserInputs Nothing), + workflowNodePreviousInputs = Nothing + } + ], + workflowEntryEdges = Nothing + } + (decode . encode) e `shouldBe` Just e + it "decodes an entry with missing nodes as an empty list (lenient)" $ do + let lbs = "{\"user_params\":{}}" :: LBS.ByteString + decode lbs + `shouldBe` Just + ( WorkflowEntry + { workflowEntryUserParams = Just mempty, + workflowEntryNodes = [], + workflowEntryEdges = Nothing + } + ) + + -- ======================================================================= + -- WorkflowTemplate round-trip (the canonical sample) + -- ======================================================================= + describe "WorkflowTemplate JSON" $ do + it "decodes the documented \"Register and deploy a remote model\" template" $ do + let decoded = decode sampleRemoteModelTemplateJson :: Maybe WorkflowTemplate + decoded `shouldSatisfy` (\x -> case x of Just _ -> True; Nothing -> False) + -- Spot-check that the typed decoder picked up the right + -- constructor for each node. + case decoded of + Just tmpl -> + case Map.lookup "provision" <$> workflowTemplateWorkflows tmpl of + Just (Just entry) -> do + length (workflowEntryNodes entry) `shouldBe` 3 + -- First node is create_connector with its typed inputs + case workflowEntryNodes entry of + (n1 : _) -> + nodeInputsType (workflowNodeInputs n1) `shouldBe` "create_connector" + _ -> expectationFailure "expected at least one node" + _ -> expectationFailure "expected a provision workflow entry" + Nothing -> expectationFailure "decode returned Nothing" + + it "encodes and re-decodes the documented template (round-trip)" $ do + let decoded = decode sampleRemoteModelTemplateJson :: Maybe WorkflowTemplate + case decoded of + Just tmpl -> (decode . encode) tmpl `shouldBe` Just tmpl + Nothing -> expectationFailure "initial decode failed" + + it "requires the name field" $ do + -- A template body with no name should fail to decode. + decode + "{\"description\":\"x\"}" + `shouldBe` (Nothing :: Maybe WorkflowTemplate) + + it "round-trips a minimal one-name template" $ do + let t = WorkflowTemplate "just-a-name" Nothing Nothing Nothing Nothing + (decode . encode) t `shouldBe` Just t + encode t `shouldBe` "{\"name\":\"just-a-name\"}" + + -- ======================================================================= + -- CreateWorkflowResponse (the create / provision response) + -- ======================================================================= + describe "CreateWorkflowResponse JSON" $ do + it "decodes the bare fire-and-forget response" $ do + let decoded = decode sampleWorkflowIdResponseJson :: Maybe CreateWorkflowResponse + decoded + `shouldBe` Just + ( CreateWorkflowResponse + { createWorkflowResponseWorkflowId = WorkflowId "8xL8bowB8y25Tqfenm50", + createWorkflowResponseState = Nothing, + createWorkflowResponseResourcesCreated = Nothing + } + ) + + it "decodes the timed response (state + resources_created)" $ do + let decoded = decode sampleTimedResponseJson :: Maybe CreateWorkflowResponse + case decoded of + Just resp -> do + unWorkflowId (createWorkflowResponseWorkflowId resp) + `shouldBe` "K13IR5QBEpCfUu_-AQdU" + createWorkflowResponseState resp `shouldBe` Just WorkflowStateCompleted + (length <$> createWorkflowResponseResourcesCreated resp) `shouldBe` Just 3 + Nothing -> expectationFailure "decode failed" + + it "round-trips the timed response" $ do + let decoded = decode sampleTimedResponseJson :: Maybe CreateWorkflowResponse + case decoded of + Just resp -> (decode . encode) resp `shouldBe` Just resp + Nothing -> expectationFailure "initial decode failed" + + it "requires workflow_id" $ + decode + "{\"state\":\"COMPLETED\"}" + `shouldBe` (Nothing :: Maybe CreateWorkflowResponse) + + -- ======================================================================= + -- ResourceCreated (the resources_created entry shape) + -- ======================================================================= + describe "ResourceCreated JSON" $ do + it "round-trips regardless of field ordering in the source JSON" $ do + -- The docs explicitly note that workflow_step_id and + -- workflow_step_name appear in either order across entries. + -- Both must decode into the same Haskell value. + let order1 = "{\"workflow_step_id\":\"a\",\"workflow_step_name\":\"b\",\"resource_id\":\"c\",\"resource_type\":\"d\"}" :: LBS.ByteString + order2 = "{\"workflow_step_name\":\"b\",\"workflow_step_id\":\"a\",\"resource_id\":\"c\",\"resource_type\":\"d\"}" :: LBS.ByteString + expected = ResourceCreated "a" "b" "c" "d" + decode order1 `shouldBe` Just expected + decode order2 `shouldBe` Just expected + + -- ======================================================================= + -- Options rendering (createWorkflowOptionsParams / provisionOptionsParams / deleteWorkflowOptionsParams) + -- ======================================================================= + describe "createWorkflowOptionsParams" $ do + it "renders nothing for the default options" $ + createWorkflowOptionsParams defaultCreateWorkflowOptions `shouldBe` [] + it "renders provision=true when set" $ + createWorkflowOptionsParams + defaultCreateWorkflowOptions {createWorkflowOptionsProvision = Just True} + `shouldBe` [("provision", Just "true")] + it "renders validation=none when set" $ + createWorkflowOptionsParams + defaultCreateWorkflowOptions {createWorkflowOptionsValidation = Just ValidationNone} + `shouldBe` [("validation", Just "none")] + it "renders use_case verbatim" $ + createWorkflowOptionsParams + defaultCreateWorkflowOptions {createWorkflowOptionsUseCase = Just "semantic_search"} + `shouldBe` [("use_case", Just "semantic_search")] + it "renders all fields together in source order" $ + createWorkflowOptionsParams + defaultCreateWorkflowOptions + { createWorkflowOptionsProvision = Just True, + createWorkflowOptionsValidation = Just ValidationAll, + createWorkflowOptionsWaitForCompletionTimeout = Just "5s" + } + `shouldBe` [("provision", Just "true"), ("validation", Just "all"), ("wait_for_completion_timeout", Just "5s")] + + describe "provisionOptionsParams" $ do + it "renders nothing for the default options" $ + provisionOptionsParams defaultProvisionOptions `shouldBe` [] + it "renders wait_for_completion_timeout when set" $ + provisionOptionsParams + defaultProvisionOptions {provisionOptionsTimeout = Just "2s"} + `shouldBe` [("wait_for_completion_timeout", Just "2s")] + it "renders substitution keys as additional query params" $ + provisionOptionsParams + defaultProvisionOptions {provisionOptionsSubstitutions = Just (Map.fromList [("openai_key", "12345")])} + `shouldBe` [("openai_key", Just "12345")] + it "renders both timeout and substitutions together" $ + provisionOptionsParams + defaultProvisionOptions + { provisionOptionsTimeout = Just "2s", + provisionOptionsSubstitutions = Just (Map.fromList [("k", "v")]) + } + `shouldBe` [("wait_for_completion_timeout", Just "2s"), ("k", Just "v")] + + describe "deleteWorkflowOptionsParams" $ do + it "renders nothing for the default options" $ + deleteWorkflowOptionsParams defaultDeleteWorkflowOptions `shouldBe` [] + it "renders clear_status=true when set" $ + deleteWorkflowOptionsParams + defaultDeleteWorkflowOptions {deleteWorkflowOptionsClearStatus = Just True} + `shouldBe` [("clear_status", Just "true")] + + -- ======================================================================= + -- DeprovisionWorkflowResponse (deprovision success body) + -- ======================================================================= + describe "DeprovisionWorkflowResponse JSON" $ do + it "decodes the bare {workflow_id} success body" $ + decode "{\"workflow_id\":\"8xL8bowB8y25Tqfenm50\"}" + `shouldBe` Just (DeprovisionWorkflowResponse (WorkflowId "8xL8bowB8y25Tqfenm50")) + it "round-trips" $ + let resp = DeprovisionWorkflowResponse (WorkflowId "abc") + in (decode . encode) resp `shouldBe` Just resp + it "requires workflow_id" $ + decode "{\"foo\":\"bar\"}" + `shouldBe` (Nothing :: Maybe DeprovisionWorkflowResponse) + it "silently ignores unexpected extra keys (forward-compat)" $ do + let resp = DeprovisionWorkflowResponse (WorkflowId "w") + decode "{\"workflow_id\":\"w\",\"unexpected\":\"x\",\"state\":\"COMPLETED\"}" + `shouldBe` Just resp + + -- ======================================================================= + -- WorkflowStateResponse (GET _status body) + -- ======================================================================= + describe "WorkflowStateResponse JSON" $ do + it "decodes the minimal NOT_STARTED body" $ do + let lbs = "{\"workflow_id\":\"8xL8bowB8y25Tqfenm50\",\"state\":\"NOT_STARTED\"}" :: LBS.ByteString + decoded = decode lbs :: Maybe WorkflowStateResponse + workflowStateResponseWorkflowId <$> decoded `shouldBe` Just (WorkflowId "8xL8bowB8y25Tqfenm50") + workflowStateResponseState <$> decoded `shouldBe` Just WorkflowStateNotStarted + (decoded >>= workflowStateResponseResourcesCreated) `shouldBe` Nothing + it "decodes a provisioning body with resources_created" $ do + let lbs = + "{\"workflow_id\":\"w\",\"state\":\"PROVISIONING\",\ + \ \"resources_created\":[{\"workflow_step_name\":\"create_connector\",\ + \ \"workflow_step_id\":\"create_connector_1\",\"resource_type\":\"connector_id\",\ + \ \"resource_id\":\"r1\"}]}" :: + LBS.ByteString + decoded = decode lbs :: Maybe WorkflowStateResponse + workflowStateResponseState <$> decoded `shouldBe` Just WorkflowStateProvisioning + (length <$> (workflowStateResponseResourcesCreated =<< decoded)) `shouldBe` Just 1 + it "decodes a FAILED body carrying an error field" $ do + let lbs = "{\"workflow_id\":\"w\",\"state\":\"FAILED\",\"error\":\"boom\"}" :: LBS.ByteString + workflowStateResponseError + <$> (decode lbs :: Maybe WorkflowStateResponse) + `shouldBe` Just (Just "boom") + it "decodes an unknown state via the forward-compat escape hatch" $ + workflowStateResponseState + <$> (decode "{\"workflow_id\":\"w\",\"state\":\"QUEUED\"}" :: Maybe WorkflowStateResponse) + `shouldBe` Just (WorkflowStateOther "QUEUED") + it "captures the all=true extras verbatim in other (forward-compat)" $ do + let lbs = + "{\"workflow_id\":\"w\",\"state\":\"COMPLETED\",\ + \ \"provisioning_progress\":{\"done\":3,\"total\":3},\ + \ \"provision_start_time\":123,\"provision_end_time\":456,\ + \ \"user_outputs\":{\"k\":\"v\"}}" :: + LBS.ByteString + other = workflowStateResponseOther <$> (decode lbs :: Maybe WorkflowStateResponse) + -- The catch-all is the whole original object, so the all=true + -- fields are preserved verbatim and reachable by re-decoding it. + other `shouldBe` (decode lbs :: Maybe Value) + + -- ======================================================================= + -- Options rendering (deprovisionWorkflowOptionsParams / workflowStateOptionsParams) + -- ======================================================================= + describe "deprovisionWorkflowOptionsParams" $ do + it "renders nothing for the default options" $ + deprovisionWorkflowOptionsParams defaultDeprovisionWorkflowOptions `shouldBe` [] + it "renders allow_delete verbatim when set" $ + deprovisionWorkflowOptionsParams + defaultDeprovisionWorkflowOptions {deprovisionWorkflowOptionsAllowDelete = Just "my-index,my-pipeline"} + `shouldBe` [("allow_delete", Just "my-index,my-pipeline")] + + describe "workflowStateOptionsParams" $ do + it "renders nothing for the default options" $ + workflowStateOptionsParams defaultWorkflowStateOptions `shouldBe` [] + it "renders all=true when set" $ + workflowStateOptionsParams + defaultWorkflowStateOptions {workflowStateOptionsAll = Just True} + `shouldBe` [("all", Just "true")] + it "renders all=false when explicitly set" $ + workflowStateOptionsParams + defaultWorkflowStateOptions {workflowStateOptionsAll = Just False} + `shouldBe` [("all", Just "false")] + + -- ======================================================================= + -- WorkflowStep (GET _steps descriptor entry) + -- ======================================================================= + describe "WorkflowStep JSON" $ do + it "decodes the register_remote_model sample from the docs" $ do + let lbs = + "{\"inputs\":[\"name\",\"connector_id\"],\ + \ \"outputs\":[\"model_id\",\"register_model_status\"],\ + \ \"required_plugins\":[\"opensearch-ml\"]}" :: + LBS.ByteString + decoded = decode lbs :: Maybe WorkflowStep + workflowStepInputs <$> decoded `shouldBe` Just ["name", "connector_id"] + workflowStepOutputs <$> decoded `shouldBe` Just ["model_id", "register_model_status"] + workflowStepRequiredPlugins <$> decoded `shouldBe` Just ["opensearch-ml"] + it "decodes a step carrying an undocumented field (forward-compat)" $ do + let lbs = + "{\"inputs\":[\"a\"],\"outputs\":[\"b\"],\ + \ \"required_plugins\":[\"opensearch-ml\"],\"default_timeout\":60}" :: + LBS.ByteString + decoded = decode lbs :: Maybe WorkflowStep + workflowStepInputs <$> decoded `shouldBe` Just ["a"] + -- The catch-all captures the whole original object verbatim, so the + -- undocumented @default_timeout@ key survives a round-trip. + (workflowStepOther <$> decoded) `shouldBe` (decode lbs :: Maybe Value) + it "decodes a step missing the optional arrays as empty lists" $ do + let decoded = decode "{}" :: Maybe WorkflowStep + workflowStepInputs <$> decoded `shouldBe` Just [] + workflowStepOutputs <$> decoded `shouldBe` Just [] + workflowStepRequiredPlugins <$> decoded `shouldBe` Just [] + + -- ======================================================================= + -- WorkflowStepsResponse (GET _steps top-level map) + -- ======================================================================= + describe "WorkflowStepsResponse JSON" $ do + it "decodes a multi-step map keyed by step name" $ do + let lbs = + "{\"register_remote_model\":\ + \ {\"inputs\":[\"name\"],\"outputs\":[\"model_id\"],\"required_plugins\":[\"opensearch-ml\"]},\ + \ \"deploy_model\":\ + \ {\"inputs\":[\"model_id\"],\"outputs\":[],\"required_plugins\":[\"opensearch-ml\"]}}" :: + LBS.ByteString + decoded = unWorkflowStepsResponse <$> (decode lbs :: Maybe WorkflowStepsResponse) + (Map.size <$> decoded) `shouldBe` Just 2 + let outputs = + workflowStepOutputs + <$> (decoded >>= Map.lookup "register_remote_model") + outputs `shouldBe` Just ["model_id"] + it "decodes an empty object as an empty map" $ + unWorkflowStepsResponse + <$> (decode "{}" :: Maybe WorkflowStepsResponse) + `shouldBe` Just Map.empty + + -- ======================================================================= + -- Options rendering (workflowStepsOptionsParams) + -- ======================================================================= + describe "workflowStepsOptionsParams" $ do + it "renders nothing for the default options" $ + workflowStepsOptionsParams defaultWorkflowStepsOptions `shouldBe` [] + it "renders workflow_step verbatim when set" $ + workflowStepsOptionsParams + defaultWorkflowStepsOptions {workflowStepsStep = Just "create_connector,deploy_model"} + `shouldBe` [("workflow_step", Just "create_connector,deploy_model")] + + -- ======================================================================= + -- searchWorkflowState hit shape (SearchResult WorkflowStateResponse) + -- ======================================================================= + describe "searchWorkflowState hit (SearchResult WorkflowStateResponse)" $ + it "decodes a standard search envelope wrapping workflow-state documents" $ do + let lbs = + "{\"took\":1,\"timed_out\":false,\"_shards\":{},\ + \ \"hits\":{\"total\":{\"value\":1,\"relation\":\"eq\"},\ + \ \"hits\":[{\"_index\":\"workflow-state\",\"_id\":\"w\",\ + \ \"_source\":{\"workflow_id\":\"w\",\"state\":\"NOT_STARTED\"}}]}}" :: + LBS.ByteString + decoded = decode lbs :: Maybe (SearchResult WorkflowStateResponse) + -- If decode failed this whole chain yields Nothing. + hitCount = fmap (length . hits . searchHits) decoded + firstSrcWorkflowId = + decoded >>= \r -> case hits (searchHits r) of + (h : _) -> workflowStateResponseWorkflowId <$> hitSource h + [] -> Nothing + hitCount `shouldBe` Just 1 + firstSrcWorkflowId `shouldBe` Just (WorkflowId "w") + +-- QuickCheck instance: drives the WorkflowState round-trip property above. +-- Includes the four documented states plus a generator for the Other +-- escape hatch (so the property exercises forward-compat decode). +instance Arbitrary WorkflowState where + arbitrary = + oneof + [ pure WorkflowStateNotStarted, + pure WorkflowStateProvisioning, + pure WorkflowStateCompleted, + pure WorkflowStateFailed, + WorkflowStateOther . T.pack <$> listOf1 (elements (['A' .. 'Z'] <> "_")) + ] + shrink (WorkflowStateOther _) = [WorkflowStateCompleted, WorkflowStateFailed] + shrink _ = [] diff --git a/tests/Test/FreezeIndexSpec.hs b/tests/Test/FreezeIndexSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/FreezeIndexSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-warnings-deprecations #-} + +module Test.FreezeIndexSpec (spec) where + +import Data.ByteString.Lazy qualified as LBS +import Database.Bloodhound.ElasticSearch7.Requests qualified as Requests +import TestsUtils.Common +import TestsUtils.Import + +-- | Freeze/unfreeze return the standard @_shards@ envelope. +sampleShardsBytes :: LBS.ByteString +sampleShardsBytes = + "{\"_shards\":{\"total\":2,\"successful\":2,\"skipped\":0,\"failed\":0}}" + +spec :: Spec +spec = do + -- ------------------------------------------------------------------ -- + -- Pure JSON decoder tests (no ES required). -- + -- ------------------------------------------------------------------ -- + describe "ShardsResult decoding (freeze/unfreeze envelope)" $ do + it "decodes the {_shards} envelope returned by _freeze/_unfreeze" $ do + let Just (ShardsResult sr) = decode sampleShardsBytes :: Maybe ShardsResult + shardTotal sr `shouldBe` 2 + shardsSuccessful sr `shouldBe` 2 + shardsFailed sr `shouldBe` 0 + + -- ------------------------------------------------------------------ -- + -- Endpoint shape (BHRequest, no ES required). -- + -- ------------------------------------------------------------------ -- + describe "freezeIndex endpoint shape" $ do + let idx = [qqIndexName|my-idx|] + + it "POSTs /{index}/_freeze with an empty body" $ do + let req = Requests.freezeIndex idx + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["my-idx", "_freeze"] + bhRequestBody req `shouldBe` Just "" + + describe "unfreezeIndex endpoint shape" $ do + let idx = [qqIndexName|my-idx|] + + it "POSTs /{index}/_unfreeze with an empty body" $ do + let req = Requests.unfreezeIndex idx + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["my-idx", "_unfreeze"] + bhRequestBody req `shouldBe` Just "" diff --git a/tests/Test/HealthReportSpec.hs b/tests/Test/HealthReportSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/HealthReportSpec.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.HealthReportSpec (spec) where + +import Data.Aeson +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Map.Strict qualified as M +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch9.Client qualified as ClientES9 +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import Database.Bloodhound.ElasticSearch9.Types qualified as ES9 +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +------------------------------------------------------------------------------ +-- Sample payloads (trimmed to the wire fields decoded by the types). +------------------------------------------------------------------------------ + +-- | A healthy cluster: green status, one green indicator whose subtype +-- adds an extra @details@ object that must survive in 'ES9.hiOther'. +sampleReportGreenBytes :: LBS.ByteString +sampleReportGreenBytes = + "{\ + \ \"cluster_name\": \"my-cluster\",\n\ + \ \"status\": \"green\",\ + \ \"indicators\": {\ + \ \"master_is_stable\": {\ + \ \"status\": \"green\",\ + \ \"symptom\": \"The cluster has a healthy master node.\",\ + \ \"details\": {\"is_stable\": true}\ + \ }\ + \ }\ + \}" + +-- | An unhealthy indicator carrying @impacts@ and @diagnosis@ (the fields +-- the server only populates when status is not green). +sampleIndicatorRedBytes :: LBS.ByteString +sampleIndicatorRedBytes = + "{\ + \ \"status\": \"red\",\ + \ \"symptom\": \"Disk usage is high.\",\ + \ \"impacts\": [\ + \ {\ + \ \"description\": \"Reduced indexing capacity.\",\ + \ \"id\": \"disk@ingest-disabled\",\ + \ \"impact_areas\": [\"ingest\"],\ + \ \"severity\": 1\ + \ }\ + \ ],\ + \ \"diagnosis\": [\ + \ {\ + \ \"id\": \"disk@high-disk-watermark\",\ + \ \"action\": \"Free up disk space.\",\ + \ \"cause\": \"Disk watermark exceeded.\",\ + \ \"help_url\": \"https://www.elastic.co/guide/\",\ + \ \"affected_resources\": {\ + \ \"nodes\": [{\"node_id\": \"n1\", \"name\": \"node-1\"}]\ + \ }\ + \ }\ + \ ]\ + \}" + +spec :: Spec +spec = do + -------------------------------------------------------------------------- + -- JSON (de)serialisation + -------------------------------------------------------------------------- + describe "HealthReport JSON" $ do + it "decodes a green report with its indicators map" $ do + let decoded = eitherDecode sampleReportGreenBytes :: Either String ES9.HealthReport + decoded `shouldSatisfy` isRight + let Right report = decoded + ES9.hrClusterName report `shouldBe` "my-cluster" + ES9.hrStatus report `shouldBe` Just ES9.HealthReportStatusGreen + M.size (ES9.hrIndicators report) `shouldBe` 1 + + it "captures subtype-specific fields in hiOther" $ do + let decoded = eitherDecode sampleReportGreenBytes :: Either String ES9.HealthReport + Right report = decoded + Just indicator = M.lookup "master_is_stable" (ES9.hrIndicators report) + ES9.hiStatus indicator `shouldBe` ES9.HealthReportStatusGreen + ES9.hiOther indicator `shouldSatisfy` isJust + + it "round-trips the known fields through encode/decode" $ do + let decoded = eitherDecode sampleReportGreenBytes :: Either String ES9.HealthReport + decoded `shouldSatisfy` isRight + let Right report = decoded + let reDecoded = eitherDecode (encode report) :: Either String ES9.HealthReport + reDecoded `shouldSatisfy` isRight + -- The known fields survive a round trip. + let Right reReport = reDecoded + ES9.hrClusterName reReport `shouldBe` ES9.hrClusterName report + ES9.hrStatus reReport `shouldBe` ES9.hrStatus report + + it "preserves the hiOther catch-all across encode/decode" $ do + -- The catch-all is the module's headline invariant: subtype-specific + -- fields must survive a round trip. A wrong X.union bias would lose + -- them, so this guards it explicitly. + let decoded = eitherDecode sampleReportGreenBytes :: Either String ES9.HealthReport + Right report = decoded + Just indicator = M.lookup "master_is_stable" (ES9.hrIndicators report) + let reDecoded = eitherDecode (encode report) :: Either String ES9.HealthReport + Right reReport = reDecoded + Just reIndicator = M.lookup "master_is_stable" (ES9.hrIndicators reReport) + ES9.hiOther reIndicator `shouldSatisfy` isJust + ES9.hiOther reIndicator `shouldBe` ES9.hiOther indicator + + describe "HealthIndicator JSON" $ do + it "decodes impacts and diagnosis on a red indicator" $ do + let decoded = eitherDecode sampleIndicatorRedBytes :: Either String ES9.HealthIndicator + decoded `shouldSatisfy` isRight + let Right indicator = decoded + ES9.hiStatus indicator `shouldBe` ES9.HealthReportStatusRed + length <$> ES9.hiImpacts indicator `shouldBe` Just 1 + length <$> ES9.hiDiagnosis indicator `shouldBe` Just 1 + + it "decodes the HealthReportStatus enum both ways" $ do + ES9.healthReportStatusToText ES9.HealthReportStatusRed `shouldBe` "red" + ES9.healthReportStatusFromText "unavailable" + `shouldBe` Just ES9.HealthReportStatusUnavailable + + -------------------------------------------------------------------------- + -- Endpoint shape + -------------------------------------------------------------------------- + describe "getHealthReport endpoint shape" $ do + it "GETs /_health_report when given Nothing" $ do + let req = RequestsES9.getHealthReport Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_health_report"] + + it "GETs /_health_report/{feature} when given features" $ do + let req = RequestsES9.getHealthReport (Just ["disk"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_health_report", "disk"] + + it "joins multiple features with a comma" $ do + let req = RequestsES9.getHealthReport (Just ["disk", "ilm"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_health_report", "disk,ilm"] + + it "uses the GET method" $ do + let req = RequestsES9.getHealthReport Nothing + bhRequestMethod req `shouldBe` "GET" + + it "carries no request body" $ do + let req = RequestsES9.getHealthReport Nothing + bhRequestBody req `shouldBe` Nothing + + it "carries no query string by default" $ do + let req = RequestsES9.getHealthReport Nothing + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "renders verbose via getHealthReportWith" $ do + let opts = ES9.defaultHealthReportOptions {ES9.hroVerbose = Just False} + req = RequestsES9.getHealthReportWith opts Nothing + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("verbose", Just "false")] + + -------------------------------------------------------------------------- + -- Live integration (ES9 only). + -------------------------------------------------------------------------- + backendSpecific + [ElasticSearch9] + $ describe "Health report API (live integration)" + $ do + it "getHealthReport Nothing returns a parseable response" $ + withTestEnv $ do + result <- tryEsError $ ClientES9.getHealthReport Nothing + liftIO $ + case result of + Left e + | endpointMissing e -> + pendingWith "health report requires Elasticsearch 9+" + _ -> pure () + case result of + Left e -> liftIO $ expectationFailure $ "getHealthReport failed: " <> show e + Right report -> + liftIO $ + ES9.hrClusterName report `shouldSatisfy` (not . T.null) + +-- | Detect the @no handler found for uri@shape returned by Elasticsearch +-- when an endpoint isn't registered on this version. Used to mark the +-- live tests as 'pendingWith' rather than failing. +endpointMissing :: EsError -> Bool +endpointMissing e = + "no handler found" `T.isInfixOf` T.toLower (errorMessage e) diff --git a/tests/Test/HighlightsSpec.hs b/tests/Test/HighlightsSpec.hs --- a/tests/Test/HighlightsSpec.hs +++ b/tests/Test/HighlightsSpec.hs @@ -2,7 +2,7 @@ module Test.HighlightsSpec where -import qualified Data.Map as M +import Data.Map qualified as M import TestsUtils.Common import TestsUtils.Import diff --git a/tests/Test/HybridQuerySpec.hs b/tests/Test/HybridQuerySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/HybridQuerySpec.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Pure-JSON tests for the OpenSearch @hybrid@ compound query clause. +-- +-- These tests do not require a running OpenSearch instance (and do not +-- exercise the search-pipeline normalization/combination machinery, which +-- is configured out-of-band via @PUT /_search/pipeline/@). They verify +-- that 'HybridQuery' (and the 'QueryHybridQuery' arm of 'Query') +-- serializes to the JSON shape documented at +-- +-- and round-trips through 'ToJSON' \/ 'FromJSON'. +module Test.HybridQuerySpec (spec) where + +import Data.Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as LBS +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromJust) +import Data.Vector qualified as V +import Database.Bloodhound.Types + ( FieldName (..), + HybridQuery (..), + Query (..), + QueryString (..), + Term (..), + mkBoolQuery, + mkHybridQuery, + mkMatchQuery, + ) +import Test.Hspec (Spec, describe, it, shouldBe, shouldNotSatisfy, shouldSatisfy) + +-- | A simple @match@ sub-query clause, used as filler inside hybrid +-- @queries@ arrays. +matchClause :: Query +matchClause = + QueryMatchQuery + (mkMatchQuery (FieldName "title") (QueryString "search engine")) + +-- | A simple @term@ sub-query clause. +termClause :: Query +termClause = + TermQuery (Term "category" "books") Nothing + +-- | A @match_all@ clause for filler / filter use. +matchAll :: Query +matchAll = MatchAllQuery Nothing + +-- | Walk into a nested dict path, returning the inner Value if reachable. +walk :: [Key] -> Value -> Maybe Value +walk [] v = Just v +walk (k : ks) (Object obj) = case KM.lookup k obj of + Just v -> walk ks v + Nothing -> Nothing +walk _ _ = Nothing + +-- | True iff the encoded value is an Object containing the given key. +hasKey :: LBS.ByteString -> Key -> Bool +hasKey bs k = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +-- | Unwrap the @hybrid@ body of an encoded HybridQuery \/ QueryHybridQuery. +hybridBody :: Value -> Maybe Value +hybridBody = walk ["hybrid"] + +spec :: Spec +spec = describe "Hybrid query clause (OpenSearch)" $ do + describe "HybridQuery body shape" $ do + it "serializes as {\"hybrid\": {...}} at the top level" $ do + let clause = mkHybridQuery (matchClause :| []) + encode (QueryHybridQuery clause) `shouldSatisfy` \bs -> hasKey bs "hybrid" + + it "emits queries as an array under the hybrid key" $ do + let clause = mkHybridQuery (matchClause :| [termClause]) + let Just (Object body) = hybridBody (fromJust (decode (encode (QueryHybridQuery clause)))) + case KM.lookup "queries" body of + Just (Array arr) -> length arr `shouldBe` 2 + other -> fail $ "expected queries array, got " ++ show other + + it "serializes each sub-query through the parent Query ToJSON" $ do + let clause = mkHybridQuery (matchClause :| [termClause]) + let Just (Object body) = hybridBody (fromJust (decode (encode (QueryHybridQuery clause)))) + case KM.lookup "queries" body of + Just (Array arr) -> do + case V.toList arr of + (firstSub : _) -> decode (encode firstSub) `shouldBe` Just matchClause + [] -> fail "queries array was unexpectedly empty" + other -> fail $ "expected queries array, got " ++ show other + + it "omits the filter field when filter is Nothing" $ do + let clause = mkHybridQuery (matchClause :| []) + let Just (Object body) = hybridBody (fromJust (decode (encode (QueryHybridQuery clause)))) + body `shouldNotSatisfy` KM.member "filter" + + it "includes the filter field when filter is Just" $ do + let clause = + (mkHybridQuery (matchClause :| [])) + { hybridFilter = Just matchAll + } + let Just (Object body) = hybridBody (fromJust (decode (encode (QueryHybridQuery clause)))) + body `shouldSatisfy` KM.member "filter" + + it "emits a single-element queries array for a one-clause hybrid" $ do + let clause = mkHybridQuery (matchClause :| []) + let Just (Object body) = hybridBody (fromJust (decode (encode (QueryHybridQuery clause)))) + case KM.lookup "queries" body of + Just (Array arr) -> length arr `shouldBe` 1 + other -> fail $ "expected queries array, got " ++ show other + + describe "HybridQuery round-trip" $ do + it "round-trips a single-clause hybrid through ToJSON/FromJSON" $ do + let clause = mkHybridQuery (matchClause :| []) + decode (encode clause) `shouldBe` Just clause + + it "round-trips a two-clause hybrid through ToJSON/FromJSON" $ do + let clause = mkHybridQuery (matchClause :| [termClause]) + decode (encode clause) `shouldBe` Just clause + + it "round-trips a hybrid with a filter set" $ do + let clause = + (mkHybridQuery (matchClause :| [termClause])) + { hybridFilter = Just matchAll + } + decode (encode clause) `shouldBe` Just clause + + it "round-trips a hybrid whose sub-query is itself a compound (bool)" $ do + let innerBool = QueryBoolQuery (mkBoolQuery [matchClause] [] [] []) + let clause = mkHybridQuery (innerBool :| []) + decode (encode clause) `shouldBe` Just clause + + describe "Query sum type integration" $ do + it "QueryHybridQuery wraps the clause under the \"hybrid\" key" $ do + let inner = mkHybridQuery (matchClause :| []) + let wrapped = QueryHybridQuery inner + encode wrapped `shouldSatisfy` \bs -> hasKey bs "hybrid" + + it "QueryHybridQuery round-trips through the parent Query sum type" $ do + let inner = mkHybridQuery (matchClause :| [termClause]) + let wrapped = QueryHybridQuery inner + decode (encode wrapped) `shouldBe` Just wrapped + + it "QueryHybridQuery round-trips with filter set" $ do + let inner = + (mkHybridQuery (matchClause :| [])) + { hybridFilter = Just matchAll + } + let wrapped = QueryHybridQuery inner + decode (encode wrapped) `shouldBe` Just wrapped + + it "distinguishes hybrid from neural_sparse and neural in the parser" $ do + let inner = mkHybridQuery (matchClause :| []) + let wrapped = QueryHybridQuery inner + let Just (Object obj) = decode (encode wrapped) + obj `shouldNotSatisfy` KM.member "neural" + obj `shouldNotSatisfy` KM.member "neural_sparse" + obj `shouldSatisfy` KM.member "hybrid" + + it "parses hybrid clauses encountered as a bool sub-query" $ do + let hybrid = QueryHybridQuery (mkHybridQuery (matchClause :| [])) + let boolQuery = QueryBoolQuery (mkBoolQuery [hybrid] [] [] []) + decode (encode boolQuery) `shouldBe` Just boolQuery + + describe "HybridQuery parser rejects malformed clauses" $ do + it "rejects hybrid clause with no queries field (via Query sum type)" $ do + let bad = object ["hybrid" .= object ["filter" .= matchAll]] + (decode (encode bad) :: Maybe Query) `shouldBe` Nothing + + it "rejects hybrid clause with an empty queries array (via Query sum type)" $ do + let bad = object ["hybrid" .= object ["queries" .= ([] :: [Value])]] + (decode (encode bad) :: Maybe Query) `shouldBe` Nothing + + it "rejects hybrid clause with queries that is not an array (via Query sum type)" $ do + let bad = object ["hybrid" .= object ["queries" .= String "not an array"]] + (decode (encode bad) :: Maybe Query) `shouldBe` Nothing + + it "rejects a direct HybridQuery body with an empty queries array" $ do + -- Pins down the explicit fail at Query.hs FromJSON HybridQuery: + -- "queries must be a non-empty array". Exercises the inner parser + -- directly without going through the Query sum-type dispatch. + let bad = object ["queries" .= ([] :: [Value])] + (decode (encode bad) :: Maybe HybridQuery) `shouldBe` Nothing + + it "rejects a direct HybridQuery body with no queries field" $ do + let bad = object ["filter" .= matchAll] + (decode (encode bad) :: Maybe HybridQuery) `shouldBe` Nothing diff --git a/tests/Test/ILMSpec.hs b/tests/Test/ILMSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ILMSpec.hs @@ -0,0 +1,814 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.ILMSpec (spec) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.Aeson.Types (parseMaybe) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List (sort) +import Data.Text qualified as Text +import Data.Time.Clock.POSIX (getPOSIXTime) +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.Common.Client qualified as CommonClient +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- | Fixture mimicking the @GET /_ilm/policy@ response (two policies, keyed +-- by id). Adapted from the shape documented at +-- https://www.elastic.co/guide/en/elasticsearch/reference/current/ilm-get-lifecycle.html. +sampleListResponse :: LBS.ByteString +sampleListResponse = + "{\ + \ \"my_policy\": {\ + \ \"version\": 1,\ + \ \"modified_date\": 1580000000000,\ + \ \"modified_date_string\": \"2020-01-26T06:53:20.000Z\",\ + \ \"policy\": {\ + \ \"phases\": {\ + \ \"warm\": {\ + \ \"min_age\": \"10d\",\ + \ \"actions\": { \"forcemerge\": { \"max_num_segments\": 1 } }\ + \ }\ + \ }\ + \ },\ + \ \"in_use_by\": {\ + \ \"indices\": [\"logs-2020-01-26-000001\"],\ + \ \"data_streams\": []\ + \ }\ + \ },\ + \ \"other_policy\": {\ + \ \"version\": 3,\ + \ \"modified_date\": 1590000000000,\ + \ \"modified_date_string\": \"2020-05-21T00:00:00.000Z\",\ + \ \"policy\": { \"phases\": {} }\ + \ }\ + \}" + +-- | Fixture mimicking the @GET /_ilm/policy/{id}@ response. ES still wraps the +-- single policy in a one-entry object keyed by id. +sampleSingleResponse :: LBS.ByteString +sampleSingleResponse = + "{\ + \ \"my_policy\": {\ + \ \"version\": 1,\ + \ \"modified_date\": -1,\ + \ \"modified_date_string\": \"2020-01-26T06:53:20.000Z\",\ + \ \"policy\": {\ + \ \"phases\": {\ + \ \"hot\": {\ + \ \"min_age\": \"0ms\",\ + \ \"actions\": { \"rollover\": { \"max_size\": \"50gb\" } }\ + \ }\ + \ }\ + \ }\ + \ }\ + \}" + +policyIdKey :: ILMPolicyInfo -> Text +policyIdKey = unILMPolicyId . ilmPolicyInfoId + +spec :: Spec +spec = describe "Index Lifecycle Management (ILM) API" $ do + describe "ILMInUseBy JSON" $ do + it "decodes both indices and data_streams" $ do + let decoded = + decode "{ \"indices\": [\"a\", \"b\"], \"data_streams\": [\"ds1\"] }" :: + Maybe ILMInUseBy + (map unIndexName . ilmInUseByIndices <$> decoded) `shouldBe` Just ["a", "b"] + (ilmInUseByDataStreams <$> decoded) `shouldBe` Just ["ds1"] + + it "defaults missing arrays to []" $ do + let decoded = decode "{}" :: Maybe ILMInUseBy + (ilmInUseByIndices <$> decoded) `shouldBe` Just [] + (ilmInUseByDataStreams <$> decoded) `shouldBe` Just [] + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = + decode "{ \"indices\": [\"x\"], \"data_streams\": [\"y\"] }" :: + Maybe ILMInUseBy + (decode . encode) decoded `shouldBe` Just decoded + + describe "ILMPolicyInfo JSON (inner body)" $ do + -- The standalone decoder fills ilmPolicyInfoId with a placeholder "" + -- because the id is the JSON object key in the outer response, not a + -- field in the inner value. The outer ILMPolicies decoder overrides it. + it "decodes a single policy body (id stays as the placeholder)" $ do + let Just (Object o) = decode sampleSingleResponse + Just body = KM.lookup "my_policy" o + decoded = parseMaybe parseJSON body :: Maybe ILMPolicyInfo + ilmPolicyInfoId <$> decoded `shouldBe` Just (ILMPolicyId "") + ilmPolicyInfoVersion <$> decoded `shouldBe` Just (Just 1) + ilmPolicyInfoModifiedDate <$> decoded `shouldBe` Just (Just (-1)) + ilmPolicyInfoModifiedDateString <$> decoded `shouldBe` Just (Just "2020-01-26T06:53:20.000Z") + -- policy body is opaque Value; just check it has the expected phases key + ilmPolicyInfoPolicy <$> decoded `shouldSatisfy` maybe False hasPhasesKey + ilmPolicyInfoInUseBy <$> decoded `shouldBe` Just Nothing + + it "rejects a policy body missing the required 'policy' field" $ do + let decoded = decode "{ \"version\": 1 }" :: Maybe ILMPolicyInfo + decoded `shouldBe` Nothing + + it "tolerates modern ES wire shape (modified_date as ISO-8601 string)" $ do + let decoded = decode sampleModernPolicyBodyBytes :: Maybe ILMPolicyInfo + ilmPolicyInfoVersion <$> decoded `shouldBe` Just (Just 2) + ilmPolicyInfoModifiedDate <$> decoded `shouldBe` Just Nothing + ilmPolicyInfoModifiedDateString + <$> decoded + `shouldBe` Just (Just "2026-06-20T07:49:06.354Z") + ilmPolicyInfoPolicy <$> decoded `shouldSatisfy` maybe False hasPhasesKey + + it "prefers an explicit modified_date_string over the string-shaped modified_date" $ do + let decoded = + decode + "{ \"version\": 1\ + \, \"modified_date\": \"2026-06-20T07:49:06.354Z\"\ + \, \"modified_date_string\": \"2020-01-26T06:53:20.000Z\"\ + \, \"policy\": { \"phases\": {} } }" :: + Maybe ILMPolicyInfo + ilmPolicyInfoModifiedDate <$> decoded `shouldBe` Just Nothing + ilmPolicyInfoModifiedDateString + <$> decoded + `shouldBe` Just (Just "2020-01-26T06:53:20.000Z") + + describe "ILMPolicies JSON (keyed response)" $ do + it "decodes the list-all response, stamping each id from the JSON key" $ do + let Just policies = decode sampleListResponse :: Maybe ILMPolicies + ps = unILMPolicies policies + length ps `shouldBe` 2 + sort (map policyIdKey ps) `shouldBe` ["my_policy", "other_policy"] + + it "preserves the in_use_by field on the policy that has one" $ do + let Just policies = decode sampleListResponse :: Maybe ILMPolicies + myPolicy = head [p | p <- unILMPolicies policies, policyIdKey p == "my_policy"] + (map unIndexName . ilmInUseByIndices <$> ilmPolicyInfoInUseBy myPolicy) + `shouldBe` Just ["logs-2020-01-26-000001"] + + it "decodes the single-policy response as a one-entry list" $ do + let Just policies = decode sampleSingleResponse :: Maybe ILMPolicies + ps = unILMPolicies policies + length ps `shouldBe` 1 + policyIdKey (head ps) `shouldBe` "my_policy" + + it "decodes an empty response {} as the empty list" $ do + let decoded = decode "{}" :: Maybe ILMPolicies + unILMPolicies <$> decoded `shouldBe` Just [] + + it "round-trips the full keyed response through ToJSON/FromJSON, preserving ids" $ do + let Just (policies :: ILMPolicies) = decode sampleListResponse + reEncoded = encode policies + case (decode reEncoded :: Maybe ILMPolicies) of + Just reDecoded -> + sort (map policyIdKey (unILMPolicies reDecoded)) + `shouldBe` sort (map policyIdKey (unILMPolicies policies)) + Nothing -> expectationFailure "round-trip decode returned Nothing" + + it "rejects a top-level array (the response must be a keyed object)" $ do + let decoded = decode "[]" :: Maybe ILMPolicies + decoded `shouldBe` Nothing + + it "rejects malformed JSON" $ do + let decoded = decode "{ this is not json" :: Maybe ILMPolicies + decoded `shouldBe` Nothing + + describe "getILMPolicy endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "GETs /_ilm/policy when given Nothing" $ do + let req = Common.getILMPolicy Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "policy"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_ilm/policy/{id} when given Just pid" $ do + let req = Common.getILMPolicy (Just (ILMPolicyId "my_policy")) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "policy", "my_policy"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "does not attach a body (GET semantics)" $ do + let req = Common.getILMPolicy Nothing + bhRequestBody req `shouldBe` Nothing + + describe "ILMPolicy JSON (PUT body)" $ do + -- The request body wraps the user-supplied policy under "policy". + it "encodes the policy body under the 'policy' key" $ do + let body = object ["phases" .= object []] + encoded = encode (ILMPolicy body) + encoded `shouldBe` "{\"policy\":{\"phases\":{}}}" + + it "round-trips through ToJSON/FromJSON" $ do + let body = object ["phases" .= object ["hot" .= object ["min_age" .= String "0ms"]]] + Just decoded = decode (encode (ILMPolicy body)) :: Maybe ILMPolicy + unILMPolicy decoded `shouldBe` body + + it "decodes a wrapped body, extracting the policy field" $ do + let Just decoded = + decode "{ \"policy\": { \"phases\": {} } }" :: + Maybe ILMPolicy + unILMPolicy decoded `shouldBe` object ["phases" .= object []] + + it "rejects a body missing the 'policy' field" $ do + let decoded = decode "{ \"version\": 1 }" :: Maybe ILMPolicy + decoded `shouldBe` Nothing + + it "rejects a non-object body" $ do + let decoded = decode "[1,2,3]" :: Maybe ILMPolicy + decoded `shouldBe` Nothing + + describe "putILMPolicy endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "PUTs /_ilm/policy/{id}" $ do + let req = Common.putILMPolicy (ILMPolicyId "my_policy") (ILMPolicy (object [])) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "policy", "my_policy"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches the encoded policy as the request body" $ do + let policy = ILMPolicy (object ["phases" .= object []]) + req = Common.putILMPolicy (ILMPolicyId "my_policy") policy + bhRequestBody req `shouldBe` Just (encode policy) + + it "uses a distinct id in the path when given a different PolicyId" $ do + let req = Common.putILMPolicy (ILMPolicyId "other") (ILMPolicy (object [])) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "policy", "other"] + + describe "deleteILMPolicy endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "DELETEs /_ilm/policy/{id}" $ do + let req = Common.deleteILMPolicy (ILMPolicyId "my_policy") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "policy", "my_policy"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the DELETE method" $ do + let req = Common.deleteILMPolicy (ILMPolicyId "my_policy") + bhRequestMethod req `shouldBe` "DELETE" + + it "does not attach a body (DELETE semantics)" $ do + let req = Common.deleteILMPolicy (ILMPolicyId "my_policy") + bhRequestBody req `shouldBe` Nothing + + it "uses a distinct id in the path when given a different PolicyId" $ do + let req = Common.deleteILMPolicy (ILMPolicyId "other") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "policy", "other"] + + -- -------------------------------------------------------------------------- + -- GET /_ilm/explain/{index} + -- --------------------------------------------------------------------------- + describe "ILMExplanation JSON (per-index body)" $ do + -- Adapted from the example at + -- https://www.elastic.co/guide/en/elasticsearch/reference/current/ilm-explain-lifecycle.html + it "decodes the canonical managed-index example from the ES docs" $ do + let Just decoded = decode sampleExplainEntryBytes :: Maybe ILMExplanation + unIndexName (ilmExplanationIndex decoded) `shouldBe` "my-index-000001" + ilmExplanationManaged decoded `shouldBe` True + ilmExplanationPolicy decoded `shouldBe` Just "my_policy" + ilmExplanationPhase decoded `shouldBe` Just "new" + ilmExplanationAction decoded `shouldBe` Just "complete" + ilmExplanationStep decoded `shouldBe` Just "complete" + ilmExplanationPhaseTimeMillis decoded `shouldBe` Just 1538475653317 + ilmExplanationActionTimeMillis decoded `shouldBe` Just 1538475653317 + ilmExplanationStepTimeMillis decoded `shouldBe` Just 1538475653317 + ilmExplanationLifecycleDateMillis decoded `shouldBe` Just 1538475653281 + ilmExplanationIndexCreationDateMillis decoded `shouldBe` Just 1538475653281 + ilmExplanationAge decoded `shouldBe` Just "15s" + ilmExplanationTimeSinceIndexCreation decoded `shouldBe` Just "15s" + ilmExplanationStepInfo decoded `shouldBe` Nothing + + it "decodes an unmanaged index, leaving every optional field as Nothing" $ do + let Just decoded = decode "{ \"index\": \"foo\", \"managed\": false }" :: Maybe ILMExplanation + unIndexName (ilmExplanationIndex decoded) `shouldBe` "foo" + ilmExplanationManaged decoded `shouldBe` False + ilmExplanationPolicy decoded `shouldBe` Nothing + ilmExplanationPhase decoded `shouldBe` Nothing + ilmExplanationStepInfo decoded `shouldBe` Nothing + + it "decodes an error-state entry, carrying step_info as an opaque Value" $ do + let Just decoded = + decode + "{ \"index\": \"broken-idx\"\ + \, \"managed\": true\ + \, \"policy\": \"p\"\ + \, \"phase\": \"hot\"\ + \, \"action\": \"rollover\"\ + \, \"step\": \"ERROR\"\ + \, \"step_info\": { \"type\": \"illegal_argument_exception\"\ + \ , \"reason\": \"setting [index.lifecycle.indexing_complete]\" } }" :: + Maybe ILMExplanation + ilmExplanationStep decoded `shouldBe` Just "ERROR" + case ilmExplanationStepInfo decoded of + Just (Object o) -> "reason" `KM.member` o `shouldBe` True + _ -> expectationFailure "expected step_info to decode as a JSON object" + + it "treats an explicit \"step_info\": null the same as a missing field" $ do + -- Aeson's .:? returns Nothing for both, pinning the behaviour so a + -- future stricter parser cannot silently regress it. + let Just decoded = decode "{ \"index\": \"ix\", \"managed\": true, \"step_info\": null }" :: Maybe ILMExplanation + ilmExplanationStepInfo decoded `shouldBe` Nothing + + it "tolerates unknown extra fields in the body" $ do + -- The wire shape will grow new fields over time; decode must not + -- reject bodies just because ES added a key we don't model yet. + let Just decoded = + decode + "{ \"index\": \"ix\", \"managed\": true\ + \, \"future_field\": \"whatever\", \"another\": 42 }" :: + Maybe ILMExplanation + ilmExplanationManaged decoded `shouldBe` True + + it "round-trips through ToJSON/FromJSON" $ do + let Just (decoded :: ILMExplanation) = decode sampleExplainEntryBytes + (decode . encode) decoded `shouldBe` Just decoded + + it "rejects a body missing the required 'managed' field" $ do + let decoded = decode "{ \"index\": \"foo\" }" :: Maybe ILMExplanation + decoded `shouldBe` Nothing + + it "rejects a body missing the required 'index' field" $ do + let decoded = decode "{ \"managed\": true }" :: Maybe ILMExplanation + decoded `shouldBe` Nothing + + describe "ILMExplanations JSON (keyed response)" $ do + it "decodes the full response, returning one entry per matched index" $ do + let Just decoded = decode sampleExplainResponseBytes :: Maybe ILMExplanations + entries = unILMExplanations decoded + length entries `shouldBe` 2 + sort (map (unIndexName . ilmExplanationIndex) entries) + `shouldBe` ["logs-2024-01-01-000001", "my-index-000001"] + + it "preserves the managed flag and policy from each entry" $ do + let Just decoded = decode sampleExplainResponseBytes :: Maybe ILMExplanations + managed = head [e | e <- unILMExplanations decoded, unIndexName (ilmExplanationIndex e) == "my-index-000001"] + ilmExplanationManaged managed `shouldBe` True + ilmExplanationPolicy managed `shouldBe` Just "my_policy" + + it "decodes an empty indices object as the empty list" $ do + let Just decoded = decode "{ \"indices\": {} }" :: Maybe ILMExplanations + unILMExplanations decoded `shouldBe` [] + + it "round-trips the full keyed response through ToJSON/FromJSON" $ do + -- Assert the *full* bodies (not just index names) survive encode/decode. + let Just (decoded :: ILMExplanations) = decode sampleExplainResponseBytes + case (decode . encode) decoded :: Maybe ILMExplanations of + Just reDecoded -> reDecoded `shouldBe` decoded + Nothing -> expectationFailure "round-trip decode returned Nothing" + + it "rejects a top-level array" $ do + decode "[]" `shouldBe` (Nothing :: Maybe ILMExplanations) + + it "rejects a response missing the 'indices' wrapper" $ do + decode "{ \"my-index-000001\": { \"index\": \"x\", \"managed\": true } }" + `shouldBe` (Nothing :: Maybe ILMExplanations) + + describe "explainILM endpoint shape" $ do + it "GETs /_ilm/explain/{index} with no body and no queries" $ do + let req = Common.explainILM [qqIndexName|my-index|] + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "explain", "my-index"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + -- Note: IndexName validation rejects wildcard characters (e.g. "logs-*") + -- so the wildcard form of the index path segment is out of reach until + -- Bloodhound relaxes IndexName. Out of scope for this bead. + + describe "explainILMWith options rendering" $ do + it "emits no queries for defaultILMExplainOptions (≡ explainILM)" $ do + let simple = Common.explainILM [qqIndexName|ix|] + withDefaults = Common.explainILMWith defaultILMExplainOptions [qqIndexName|ix|] + bhRequestEndpoint simple `shouldBe` bhRequestEndpoint withDefaults + + it "renders only_errors, only_managed and master_timeout when set" $ do + let opts = + defaultILMExplainOptions + { ilmeoOnlyErrors = Just True, + ilmeoOnlyManaged = Just False, + ilmeoMasterTimeout = Just (TimeUnitSeconds, 30) + } + req = Common.explainILMWith opts [qqIndexName|ix|] + queries = getRawEndpointQueries (bhRequestEndpoint req) + lookup "only_errors" queries `shouldBe` Just (Just "true") + lookup "only_managed" queries `shouldBe` Just (Just "false") + lookup "master_timeout" queries `shouldBe` Just (Just "30s") + + it "renders master_timeout across the full TimeUnits grammar" $ do + -- Table-driven to pin each constructor's wire suffix; future + -- additions to TimeUnits will need a matching case here. + let render u n = + lookup "master_timeout" $ + getRawEndpointQueries $ + bhRequestEndpoint $ + Common.explainILMWith + defaultILMExplainOptions {ilmeoMasterTimeout = Just (u, n)} + [qqIndexName|ix|] + render TimeUnitDays 7 `shouldBe` Just (Just "7d") + render TimeUnitHours 2 `shouldBe` Just (Just "2h") + render TimeUnitMinutes 5 `shouldBe` Just (Just "5m") + render TimeUnitMilliseconds 500 `shouldBe` Just (Just "500ms") + render TimeUnitMicroseconds 1000 `shouldBe` Just (Just "1000micros") + render TimeUnitNanoseconds 1 `shouldBe` Just (Just "1nanos") + + it "ilmExplainOptionsParams yields [] for the default record" $ do + Common.ilmExplainOptionsParams defaultILMExplainOptions `shouldBe` [] + + -- ---------------------------------------------------------------------- + -- ILM control: start / stop / status / move / retry / remove + -- ---------------------------------------------------------------------- + + describe "ILMStepKey JSON" $ do + -- The wire-shape gotcha: the step identifier lives under the "name" + -- key (NOT "step"), unlike ilmExplanationStep in the explain response. + -- The next two tests pin that. + it "encodes the step identifier under the \"name\" key, not \"step\"" $ do + let key = + ILMStepKey + { ilmStepKeyPhase = "hot", + ilmStepKeyAction = Just "rollover", + ilmStepKeyName = Just "check-rollover-ready" + } + Object o = toJSON key + KM.member "name" o `shouldBe` True + KM.member "step" o `shouldBe` False + KM.lookup "phase" o `shouldBe` Just (String "hot") + KM.lookup "name" o `shouldBe` Just (String "check-rollover-ready") + + it "round-trips a fully-populated key through ToJSON/FromJSON" $ do + let key = + ILMStepKey + { ilmStepKeyPhase = "warm", + ilmStepKeyAction = Just "forcemerge", + ilmStepKeyName = Just "forcemerge" + } + (decode . encode) key `shouldBe` Just key + + it "omits the optional action and name when they are Nothing" $ do + let key = ILMStepKey {ilmStepKeyPhase = "hot", ilmStepKeyAction = Nothing, ilmStepKeyName = Nothing} + Object o = toJSON key + KM.toList o `shouldBe` [("phase", String "hot")] + + it "decodes a phase-only key, leaving action and name as Nothing" $ do + let Just decoded = decode "{ \"phase\": \"delete\" }" :: Maybe ILMStepKey + ilmStepKeyPhase decoded `shouldBe` "delete" + ilmStepKeyAction decoded `shouldBe` Nothing + ilmStepKeyName decoded `shouldBe` Nothing + + it "rejects a body missing the required phase field" $ do + let decoded = decode "{ \"action\": \"rollover\", \"name\": \"x\" }" :: Maybe ILMStepKey + decoded `shouldBe` Nothing + + describe "MoveStepRequest JSON" $ do + let cur = ILMStepKey "new" (Just "complete") (Just "complete") + nxt = ILMStepKey "warm" (Just "forcemerge") (Just "forcemerge") + req = MoveStepRequest cur nxt + + it "emits current_step and next_step wrappers" $ do + let Object o = toJSON req + KM.member "current_step" o `shouldBe` True + KM.member "next_step" o `shouldBe` True + + it "round-trips through ToJSON/FromJSON" $ do + (decode . encode) req `shouldBe` Just req + + it "rejects a body missing next_step" $ do + let decoded = + decode + "{ \"current_step\": { \"phase\": \"new\" } }" :: + Maybe MoveStepRequest + decoded `shouldBe` Nothing + + it "rejects a body missing current_step" $ do + let decoded = + decode + "{ \"next_step\": { \"phase\": \"new\" } }" :: + Maybe MoveStepRequest + decoded `shouldBe` Nothing + + describe "ILMOperationMode JSON" $ do + -- Table-driven round-trip across the full Bounded/Enum surface. + let roundTrips mode wire = + (encode mode, decode wire :: Maybe ILMOperationMode) + `shouldBe` (wire, Just mode) + it "round-trips RUNNING with the all-caps wire spelling" $ + roundTrips ILMOperationModeRunning "\"RUNNING\"" + it "round-trips STOPPING with the all-caps wire spelling" $ + roundTrips ILMOperationModeStopping "\"STOPPING\"" + it "round-trips STOPPED with the all-caps wire spelling" $ + roundTrips ILMOperationModeStopped "\"STOPPED\"" + + it "rejects an unknown mode string" $ do + let decoded = decode "\"PAUSED\"" :: Maybe ILMOperationMode + decoded `shouldBe` Nothing + + it "rejects a lower-case spelling (the wire form is upper case)" $ do + let decoded = decode "\"running\"" :: Maybe ILMOperationMode + decoded `shouldBe` Nothing + + describe "ILMStatus JSON" $ do + it "decodes the canonical RUNNING response" $ do + let Just decoded = decode "{ \"operation_mode\": \"RUNNING\" }" :: Maybe ILMStatus + ilmStatusOperationMode decoded `shouldBe` ILMOperationModeRunning + + it "round-trips through ToJSON/FromJSON" $ do + let status = ILMStatus ILMOperationModeStopped + (decode . encode) status `shouldBe` Just status + + it "rejects a body missing operation_mode" $ do + let decoded = decode "{ \"other\": true }" :: Maybe ILMStatus + decoded `shouldBe` Nothing + + describe "startILM/stopILM endpoint shape" $ do + it "POSTs /_ilm/start with an empty body and no queries" $ do + let req = Common.startILM + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "start"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Just "" + + it "POSTs /_ilm/stop with an empty body and no queries" $ do + let req = Common.stopILM + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "stop"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Just "" + + describe "getILMStatus endpoint shape" $ do + it "GETs /_ilm/status with no body and no queries" $ do + let req = Common.getILMStatus + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "status"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + describe "moveILMStep endpoint shape" $ do + let body = + MoveStepRequest + (ILMStepKey "new" (Just "complete") (Just "complete")) + (ILMStepKey "warm" (Just "forcemerge") (Just "forcemerge")) + + it "POSTs /_ilm/move/{index} carrying the encoded MoveStepRequest body" $ do + let req = Common.moveILMStep [qqIndexName|my-index|] body + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "move", "my-index"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Just (encode body) + + it "forwards a different index name into the path" $ do + let req = Common.moveILMStep [qqIndexName|logs-000001|] body + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "move", "logs-000001"] + + describe "retryILMStep/removeILM endpoint shape" $ do + it "POSTs /_ilm/retry/{index} with an empty body and no queries" $ do + let req = Common.retryILMStep [qqIndexName|my-index|] + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "retry", "my-index"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Just "" + + it "POSTs /_ilm/remove/{index} with an empty body and no queries" $ do + let req = Common.removeILM [qqIndexName|my-index|] + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "remove", "my-index"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Just "" + + describe "MigrateDataTiersRequest JSON" $ do + it "encodes both fields when present" $ do + let req = + MigrateDataTiersRequest + { migrateDataTiersRequestLegacyTemplateToDelete = Just "old-template", + migrateDataTiersRequestNodeAttribute = Just "data_hot" + } + encode req `shouldBe` "{\"legacy_template_to_delete\":\"old-template\",\"node_attribute\":\"data_hot\"}" + + it "omits absent fields (defaultMigrateDataTiersRequest renders as empty object)" $ do + encode defaultMigrateDataTiersRequest `shouldBe` "{}" + + it "decodes both fields" $ do + let Just decoded = decode "{\"legacy_template_to_delete\":\"t\",\"node_attribute\":\"a\"}" :: Maybe MigrateDataTiersRequest + migrateDataTiersRequestLegacyTemplateToDelete decoded `shouldBe` Just "t" + migrateDataTiersRequestNodeAttribute decoded `shouldBe` Just "a" + + it "decodes an empty body as the empty request" $ do + let Just decoded = decode "{}" :: Maybe MigrateDataTiersRequest + decoded `shouldBe` defaultMigrateDataTiersRequest + + describe "MigrateDataTiersResponse JSON" $ do + let fullBytes = + "{\ + \ \"dry_run\": true,\ + \ \"removed_legacy_template\": \"legacy-logs-template\",\ + \ \"migrated_ilm_policies\": [\"logs\", \"metrics\"],\ + \ \"migrated_indices\": [\"logs-2024\", \"logs-2023\"],\ + \ \"migrated_legacy_templates\": [\"old-tpl\"],\ + \ \"migrated_composable_templates\": [\"logs-template\"],\ + \ \"migrated_component_templates\": [\"logs-component\"]\ + \}" + + it "decodes a full dry-run response" $ do + let Just decoded = decode fullBytes :: Maybe MigrateDataTiersResponse + migrateDataTiersResponseDryRun decoded `shouldBe` True + migrateDataTiersResponseRemovedLegacyTemplate decoded `shouldBe` Just "legacy-logs-template" + migrateDataTiersResponseMigratedIlmPolicies decoded `shouldBe` ["logs", "metrics"] + migrateDataTiersResponseMigratedIndices decoded `shouldBe` ["logs-2024", "logs-2023"] + migrateDataTiersResponseMigratedLegacyTemplates decoded `shouldBe` ["old-tpl"] + migrateDataTiersResponseMigratedComposableTemplates decoded `shouldBe` ["logs-template"] + migrateDataTiersResponseMigratedComponentTemplates decoded `shouldBe` ["logs-component"] + + it "decodes migrated_indices when it is a bare string (union wire shape)" $ do + let bytes = + "{\ + \ \"dry_run\": false,\ + \ \"migrated_ilm_policies\": [],\ + \ \"migrated_indices\": \"only-index\",\ + \ \"migrated_legacy_templates\": [],\ + \ \"migrated_composable_templates\": [],\ + \ \"migrated_component_templates\": []\ + \}" + Just decoded = decode bytes :: Maybe MigrateDataTiersResponse + migrateDataTiersResponseMigratedIndices decoded `shouldBe` ["only-index"] + migrateDataTiersResponseDryRun decoded `shouldBe` False + + it "tolerates a missing removed_legacy_template (documented as required but often absent)" $ do + let bytes = + "{\ + \ \"dry_run\": false,\ + \ \"migrated_ilm_policies\": [],\ + \ \"migrated_indices\": [],\ + \ \"migrated_legacy_templates\": [],\ + \ \"migrated_composable_templates\": [],\ + \ \"migrated_component_templates\": []\ + \}" + Just decoded = decode bytes :: Maybe MigrateDataTiersResponse + migrateDataTiersResponseRemovedLegacyTemplate decoded `shouldBe` Nothing + + it "round-trips through ToJSON/FromJSON (re-emitting migrated_indices as an array)" $ do + let Just decoded = decode fullBytes :: Maybe MigrateDataTiersResponse + Just reDecoded = decode (encode decoded) :: Maybe MigrateDataTiersResponse + reDecoded `shouldBe` decoded + + describe "migrateDataTiers endpoint shape" $ do + let req = Common.migrateDataTiers + + it "POSTs /_ilm/migrate_to_data_tiers" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "migrate_to_data_tiers"] + + it "uses the POST method" $ do + bhRequestMethod req `shouldBe` "POST" + + it "sends an empty body (defaultMigrateDataTiersRequest encodes to {})" $ do + bhRequestBody req `shouldBe` Just "{}" + + it "carries no query string by default" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "migrateDataTiersWith endpoint shape" $ do + it "emits dry_run=true when the option is set" $ do + let opts = defaultMigrateDataTiersOptions {migrateDataTiersOptionsDryRun = Just True} + req = Common.migrateDataTiersWith opts defaultMigrateDataTiersRequest + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ilm", "migrate_to_data_tiers"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("dry_run", Just "true")] + + it "emits dry_run=false when the option is unset explicitly" $ do + let opts = defaultMigrateDataTiersOptions {migrateDataTiersOptionsDryRun = Just False} + req = Common.migrateDataTiersWith opts defaultMigrateDataTiersRequest + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("dry_run", Just "false")] + + it "omits dry_run entirely when the option is Nothing" $ do + let req = Common.migrateDataTiersWith defaultMigrateDataTiersOptions defaultMigrateDataTiersRequest + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "encodes the request body fields" $ do + let body = + defaultMigrateDataTiersRequest + { migrateDataTiersRequestNodeAttribute = Just "data_hot" + } + req = Common.migrateDataTiersWith defaultMigrateDataTiersOptions body + bhRequestBody req `shouldBe` Just "{\"node_attribute\":\"data_hot\"}" + + backendSpecific + [ElasticSearch7, ElasticSearch8, ElasticSearch9] + $ describe "getILMPolicy (live integration)" + $ do + it "round-trips a single policy via Just pid" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let pid = + ILMPolicyId $ + Text.pack $ + "bloodhound_test_ilm_live_pid_" <> suffix + _ <- CommonClient.putILMPolicy pid sampleLivePolicy + policies <- CommonClient.getILMPolicy (Just pid) + liftIO $ + case policies of + [p] -> do + ilmPolicyInfoId p `shouldBe` pid + ilmPolicyInfoPolicy p `shouldSatisfy` hasPhasesKey + _ -> + expectationFailure $ + "expected exactly one policy, got " <> show (length policies) + + it "lists the created policy via Nothing" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let pid = + ILMPolicyId $ + Text.pack $ + "bloodhound_test_ilm_live_list_" <> suffix + _ <- CommonClient.putILMPolicy pid sampleLivePolicy + policies <- CommonClient.getILMPolicy Nothing + liftIO $ + map (unILMPolicyId . ilmPolicyInfoId) policies + `shouldSatisfy` elem (unILMPolicyId pid) + + backendSpecific + [ElasticSearch7, ElasticSearch8, ElasticSearch9] + $ describe "deleteILMPolicy (live integration)" + $ do + it "removes a policy that was just created" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let pid = + ILMPolicyId $ + Text.pack $ + "bloodhound_test_ilm_live_del_" <> suffix + _ <- CommonClient.putILMPolicy pid sampleLivePolicy + _ <- CommonClient.deleteILMPolicy pid + policies <- CommonClient.getILMPolicy Nothing + liftIO $ + map (unILMPolicyId . ilmPolicyInfoId) policies + `shouldSatisfy` notElem (unILMPolicyId pid) + +-- | Single per-index entry, copied from the canonical example at +-- . +sampleExplainEntryBytes :: LBS.ByteString +sampleExplainEntryBytes = + "{\ + \ \"index\": \"my-index-000001\",\n\ + \ \"index_creation_date_millis\": 1538475653281,\n\ + \ \"index_creation_date\": \"2018-10-15T13:45:21.981Z\",\n\ + \ \"time_since_index_creation\": \"15s\",\n\ + \ \"managed\": true,\n\ + \ \"policy\": \"my_policy\",\n\ + \ \"lifecycle_date_millis\": 1538475653281,\n\ + \ \"lifecycle_date\": \"2018-10-15T13:45:21.981Z\",\n\ + \ \"age\": \"15s\",\n\ + \ \"phase\": \"new\",\n\ + \ \"phase_time_millis\": 1538475653317,\n\ + \ \"phase_time\": \"2018-10-15T13:45:22.577Z\",\n\ + \ \"action\": \"complete\",\n\ + \ \"action_time_millis\": 1538475653317,\n\ + \ \"action_time\": \"2018-10-15T13:45:22.577Z\",\n\ + \ \"step\": \"complete\",\n\ + \ \"step_time_millis\": 1538475653317,\n\ + \ \"step_time\": \"2018-10-15T13:45:22.577Z\"\n\ + \}" + +-- | Two-index response used to assert the keyed-response walking and +-- multi-entry decode. The second index is unmanaged, exercising the +-- 'Maybe' field decoding. +sampleExplainResponseBytes :: LBS.ByteString +sampleExplainResponseBytes = + "{\ + \ \"indices\": {\n\ + \ \"my-index-000001\": " + <> sampleExplainEntryBytes + <> ",\n\ + \ \"logs-2024-01-01-000001\": {\n\ + \ \"index\": \"logs-2024-01-01-000001\",\n\ + \ \"managed\": false\n\ + \ }\n\ + \ }\n\ + \}" + +-- | Modern ES (7.17+\/8\/9) wire shape for a single policy body: +-- @modified_date@ is an ISO-8601 string and there is no +-- @modified_date_string@ sibling. Pins the tolerant parser independently of +-- the live cluster (the classic-shape fixtures above use epoch-millis). +sampleModernPolicyBodyBytes :: LBS.ByteString +sampleModernPolicyBodyBytes = + "{\ + \ \"version\": 2,\n\ + \ \"modified_date\": \"2026-06-20T07:49:06.354Z\",\n\ + \ \"policy\": { \"phases\": {} }\n\ + \}" + +-- | Minimal ILM policy body used by the live integration tests: a single +-- @warm@ phase with a @forcemerge@ action. Small enough to be accepted by +-- every supported ES version (7.17+) and recognisable enough that the +-- round-trip assertion can confirm the body survived the PUT\/GET cycle. +sampleLivePolicy :: ILMPolicy +sampleLivePolicy = + ILMPolicy $ + object + [ "phases" + .= object + [ "warm" + .= object + [ "min_age" .= ("10d" :: Text), + "actions" + .= object + [ "forcemerge" + .= object ["max_num_segments" .= (1 :: Int)] + ] + ] + ] + ] + +-- | True iff the given Value is an object containing a @phases@ key. Used to +-- assert the opaque policy body without modelling the full ILM schema. +hasPhasesKey :: Value -> Bool +hasPhasesKey (Object o) = "phases" `KM.member` o +hasPhasesKey _ = False diff --git a/tests/Test/ISMSpec.hs b/tests/Test/ISMSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ISMSpec.hs @@ -0,0 +1,2969 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.ISMSpec (spec) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value (..), decode, eitherDecode, encode, object, (.=)) +import Data.Aeson.KeyMap qualified as KM +import Data.Aeson.Types (parseEither, parseJSON) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Either (isLeft) +import Data.List (sort) +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Data.Time.Clock.POSIX (getPOSIXTime) +import Database.Bloodhound.Client.Cluster (BH) +import Database.Bloodhound.OpenSearch1.Client qualified as OS1.Client +import Database.Bloodhound.OpenSearch1.Types qualified as OS1.Types +import Database.Bloodhound.OpenSearch2.Client qualified as OS2.Client +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2.Types +import Database.Bloodhound.OpenSearch3.Client qualified as OS3.Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types qualified as OS3.Types +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- The shared typed policy body used by both the request sample and the +-- expected response sample below. Matches the JSON shape documented at +-- https://docs.opensearch.org/latest/im-plugin/ism/policies/. +samplePolicyBody :: OS1.Types.ISMPolicyBody +samplePolicyBody = + OS1.Types.ISMPolicyBody + { OS1.Types.ismPolicyBodyDescription = Just "test policy", + OS1.Types.ismPolicyBodyDefaultState = "ingest", + OS1.Types.ismPolicyBodyStates = + [ OS1.Types.ISMState + { OS1.Types.ismStateName = "ingest", + OS1.Types.ismStateActions = [], + OS1.Types.ismStateTransitions = [] + } + ], + OS1.Types.ismPolicyBodyIsmTemplate = [], + OS1.Types.ismPolicyBodyErrorNotification = Nothing, + OS1.Types.ismPolicyBodyUserVariables = Nothing + } + +-- A more elaborate policy body used by the typed-schema JSON tests below: +-- one state with a rollover action, a transition into the delete state, and +-- a transition condition. Exercises every typed sub-shape at least once. +sampleFullPolicyBody :: OS1.Types.ISMPolicyBody +sampleFullPolicyBody = + OS1.Types.ISMPolicyBody + { OS1.Types.ismPolicyBodyDescription = Just "rollover then delete", + OS1.Types.ismPolicyBodyDefaultState = "hot", + OS1.Types.ismPolicyBodyStates = + [ OS1.Types.ISMState + { OS1.Types.ismStateName = "hot", + OS1.Types.ismStateActions = + [ OS1.Types.mkISMActionEntry + ( OS1.Types.ISMActionRollover + ( Just + ( OS1.Types.ISMRolloverConfig + { OS1.Types.ismRolloverConfigMinSize = Just "1gb", + OS1.Types.ismRolloverConfigMinDocCount = Nothing, + OS1.Types.ismRolloverConfigMinIndexAge = Just "1d", + OS1.Types.ismRolloverConfigMinPrimaryShardSize = Nothing, + OS1.Types.ismRolloverConfigCopyAlias = Nothing + } + ) + ) + ), + OS1.Types.mkISMActionEntry + ( OS1.Types.ISMActionForceMerge + ( Just + ( OS1.Types.ISMForceMergeConfig + { OS1.Types.ismForceMergeConfigMaxNumSegments = Just 1, + OS1.Types.ismForceMergeConfigWaitForCompletion = Nothing, + OS1.Types.ismForceMergeConfigTaskExecutionTimeout = Nothing + } + ) + ) + ) + ], + OS1.Types.ismStateTransitions = + [ OS1.Types.ISMTransition + { OS1.Types.ismTransitionStateName = "delete", + OS1.Types.ismTransitionConditions = + Just + ( OS1.Types.ISMCondition + { OS1.Types.ismConditionMinSize = Just "50gb", + OS1.Types.ismConditionMinDocCount = Nothing, + OS1.Types.ismConditionMinIndexAge = Nothing, + OS1.Types.ismConditionMinRolloverAge = Nothing, + OS1.Types.ismConditionCron = + Just + ( OS1.Types.ISMCron + ( OS1.Types.ISMCronCondition + { OS1.Types.ismCronConditionExpression = "* 17 * * SAT", + OS1.Types.ismCronConditionTimezone = Just "America/Los_Angeles" + } + ) + ), + OS1.Types.ismConditionDsl = Nothing + } + ) + } + ] + }, + OS1.Types.ISMState + { OS1.Types.ismStateName = "delete", + OS1.Types.ismStateActions = [OS1.Types.mkISMActionEntry OS1.Types.ISMActionDelete], + OS1.Types.ismStateTransitions = [] + } + ], + OS1.Types.ismPolicyBodyIsmTemplate = + [ OS1.Types.ISMTemplate + { OS1.Types.ismTemplateIndexPatterns = ["log-*"], + OS1.Types.ismTemplatePriority = Just 50 + } + ], + OS1.Types.ismPolicyBodyErrorNotification = Nothing, + OS1.Types.ismPolicyBodyUserVariables = + Just (OS1.Types.ISMUserVariables (Map.fromList [("role", "data")])) + } + +os1SamplePolicy :: OS1.Types.ISMPolicyRequest +os1SamplePolicy = OS1.Types.ISMPolicyRequest samplePolicyBody + +os1ExpectedResponsePolicy :: OS1.Types.ISMPolicyResponse +os1ExpectedResponsePolicy = + OS1.Types.ISMPolicyResponse + { OS1.Types.ismPolicyResponsePolicyId = Nothing, + -- The test fixture's samplePutResponseBody carries schema_version and + -- last_updated_time on the outer @policy@ wrapper, not inside the + -- inner body. PutISMPolicyResponse merges the outer fields into the + -- inner ISMPolicyResponse so callers see them regardless of where OS + -- placed them. + OS1.Types.ismPolicyResponseSchemaVersion = Just 1, + OS1.Types.ismPolicyResponseLastUpdatedTime = Just 1548311893804, + OS1.Types.ismPolicyResponseBody = samplePolicyBody + } + +os2SamplePolicy :: OS2.Types.ISMPolicyRequest +os2SamplePolicy = + OS2.Types.ISMPolicyRequest + ( OS2.Types.ISMPolicyBody + { OS2.Types.ismPolicyBodyDescription = Just "test policy", + OS2.Types.ismPolicyBodyDefaultState = "ingest", + OS2.Types.ismPolicyBodyStates = + [ OS2.Types.ISMState + { OS2.Types.ismStateName = "ingest", + OS2.Types.ismStateActions = [], + OS2.Types.ismStateTransitions = [] + } + ], + OS2.Types.ismPolicyBodyIsmTemplate = [], + OS2.Types.ismPolicyBodyErrorNotification = Nothing, + OS2.Types.ismPolicyBodyUserVariables = Nothing + } + ) + +os2ExpectedResponsePolicy :: OS2.Types.ISMPolicyResponse +os2ExpectedResponsePolicy = + OS2.Types.ISMPolicyResponse + { OS2.Types.ismPolicyResponsePolicyId = Nothing, + OS2.Types.ismPolicyResponseSchemaVersion = Just 1, + OS2.Types.ismPolicyResponseLastUpdatedTime = Just 1548311893804, + OS2.Types.ismPolicyResponseBody = + OS2.Types.ISMPolicyBody + { OS2.Types.ismPolicyBodyDescription = Just "test policy", + OS2.Types.ismPolicyBodyDefaultState = "ingest", + OS2.Types.ismPolicyBodyStates = + [ OS2.Types.ISMState + { OS2.Types.ismStateName = "ingest", + OS2.Types.ismStateActions = [], + OS2.Types.ismStateTransitions = [] + } + ], + OS2.Types.ismPolicyBodyIsmTemplate = [], + OS2.Types.ismPolicyBodyErrorNotification = Nothing, + OS2.Types.ismPolicyBodyUserVariables = Nothing + } + } + +os3SamplePolicy :: OS3.Types.ISMPolicyRequest +os3SamplePolicy = + OS3.Types.ISMPolicyRequest + ( OS3.Types.ISMPolicyBody + { OS3.Types.ismPolicyBodyDescription = Just "test policy", + OS3.Types.ismPolicyBodyDefaultState = "ingest", + OS3.Types.ismPolicyBodyStates = + [ OS3.Types.ISMState + { OS3.Types.ismStateName = "ingest", + OS3.Types.ismStateActions = [], + OS3.Types.ismStateTransitions = [] + } + ], + OS3.Types.ismPolicyBodyIsmTemplate = [], + OS3.Types.ismPolicyBodyErrorNotification = Nothing, + OS3.Types.ismPolicyBodyUserVariables = Nothing + } + ) + +os3ExpectedResponsePolicy :: OS3.Types.ISMPolicyResponse +os3ExpectedResponsePolicy = + OS3.Types.ISMPolicyResponse + { OS3.Types.ismPolicyResponsePolicyId = Nothing, + OS3.Types.ismPolicyResponseSchemaVersion = Just 1, + OS3.Types.ismPolicyResponseLastUpdatedTime = Just 1548311893804, + OS3.Types.ismPolicyResponseBody = + OS3.Types.ISMPolicyBody + { OS3.Types.ismPolicyBodyDescription = Just "test policy", + OS3.Types.ismPolicyBodyDefaultState = "ingest", + OS3.Types.ismPolicyBodyStates = + [ OS3.Types.ISMState + { OS3.Types.ismStateName = "ingest", + OS3.Types.ismStateActions = [], + OS3.Types.ismStateTransitions = [] + } + ], + OS3.Types.ismPolicyBodyIsmTemplate = [], + OS3.Types.ismPolicyBodyErrorNotification = Nothing, + OS3.Types.ismPolicyBodyUserVariables = Nothing + } + } + +-- Realistic OpenSearch PUT policy response body. The outer "policy" wraps +-- metadata (schema_version, last_updated_time, ...) plus the inner "policy" +-- which is the actual user-supplied policy body. +samplePutResponseBody :: LBS.ByteString +samplePutResponseBody = + LBS.pack $ + unlines + [ "{", + " \"_id\": \"test_policy\",", + " \"_version\": 2,", + " \"_primary_term\": 1,", + " \"_seq_no\": 5,", + " \"policy\": {", + " \"last_updated_time\": 1548311893804,", + " \"schema_version\": 1,", + " \"policy\": {", + " \"description\": \"test policy\",", + " \"default_state\": \"ingest\",", + " \"states\": [", + " {\"name\": \"ingest\", \"actions\": [], \"transitions\": []}", + " ]", + " }", + " }", + "}" + ] + +spec :: Spec +spec = do + describe "ISM PolicyId JSON" $ do + it "encodes PolicyId as a bare JSON string" $ do + encode (OS1.Types.PolicyId "my_policy") `shouldBe` "\"my_policy\"" + + it "decodes a bare JSON string into PolicyId" $ do + let decoded = decode "\"my_policy\"" :: Maybe OS1.Types.PolicyId + decoded `shouldBe` Just (OS1.Types.PolicyId "my_policy") + + it "round-trips PolicyId through encode -> decode" $ do + let original = OS1.Types.PolicyId "round_trip_id" + let reencoded = encode original + let decoded = decode reencoded :: Maybe OS1.Types.PolicyId + decoded `shouldBe` Just original + + describe "ISM PutISMPolicyResponse JSON decoding" $ do + it "decodes OpenSearch1 response envelope with nested policy" $ do + let decoded = decode samplePutResponseBody :: Maybe OS1.Types.PutISMPolicyResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1.Types.putISMPolicyResponseId r `shouldBe` "test_policy" + OS1.Types.putISMPolicyResponsePrimaryTerm r `shouldBe` 1 + OS1.Types.putISMPolicyResponseSeqNo r `shouldBe` 5 + OS1.Types.putISMPolicyResponsePolicy r `shouldBe` os1ExpectedResponsePolicy + + it "decodes OpenSearch2 response envelope with nested policy" $ do + let decoded = decode samplePutResponseBody :: Maybe OS2.Types.PutISMPolicyResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS2.Types.putISMPolicyResponseId r `shouldBe` "test_policy" + OS2.Types.putISMPolicyResponsePolicy r `shouldBe` os2ExpectedResponsePolicy + + it "decodes OpenSearch3 response envelope with nested policy" $ do + let decoded = decode samplePutResponseBody :: Maybe OS3.Types.PutISMPolicyResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS3.Types.putISMPolicyResponseId r `shouldBe` "test_policy" + OS3.Types.putISMPolicyResponsePolicy r `shouldBe` os3ExpectedResponsePolicy + + it "rejects a response where the outer policy is not an object" $ do + let malformed = + LBS.pack $ + unlines + [ "{", + " \"_id\": \"test_policy\",", + " \"_version\": 1,", + " \"_primary_term\": 1,", + " \"_seq_no\": 0,", + " \"policy\": \"not-an-object\"", + "}" + ] + let result = parseEither parseJSON =<< eitherDecode malformed :: Either String OS1.Types.PutISMPolicyResponse + result `shouldSatisfy` isLeft + + it "rejects a response missing the inner policy key" $ do + let missingInner = + LBS.pack $ + unlines + [ "{", + " \"_id\": \"test_policy\",", + " \"_version\": 1,", + " \"_primary_term\": 1,", + " \"_seq_no\": 0,", + " \"policy\": {\"schema_version\": 1, \"last_updated_time\": 1548311893804}", + "}" + ] + let result = parseEither parseJSON =<< eitherDecode missingInner :: Either String OS1.Types.PutISMPolicyResponse + result `shouldSatisfy` isLeft + + it "round-trips OpenSearch1 decode -> encode -> decode" $ do + let Just (r1 :: OS1.Types.PutISMPolicyResponse) = decode samplePutResponseBody + let reencoded = encode r1 + let decodedAgain = decode reencoded :: Maybe OS1.Types.PutISMPolicyResponse + decodedAgain `shouldBe` Just r1 + + -- Asserts the typed inner policy is populated from the response body: + -- description and default_state come through, and the server-only fields + -- (policy_id, schema_version, last_updated_time) are merged from the + -- outer envelope (where the test fixture carries them) into the inner + -- ISMPolicyResponse by PutISMPolicyResponse's decoder. + it "decodes typed inner policy fields from the PUT response" $ do + let Just (r :: OS1.Types.PutISMPolicyResponse) = decode samplePutResponseBody + let inner = OS1.Types.putISMPolicyResponsePolicy r + OS1.Types.ismPolicyResponsePolicyId inner `shouldBe` Nothing + OS1.Types.ismPolicyResponseSchemaVersion inner `shouldBe` Just 1 + OS1.Types.ismPolicyResponseLastUpdatedTime inner `shouldBe` Just 1548311893804 + let body = OS1.Types.ismPolicyResponseBody inner + OS1.Types.ismPolicyBodyDescription body `shouldBe` Just "test policy" + OS1.Types.ismPolicyBodyDefaultState body `shouldBe` "ingest" + OS1.Types.ismPolicyBodyStates body `shouldSatisfy` (not . null) + let firstState = head (OS1.Types.ismPolicyBodyStates body) + OS1.Types.ismStateName firstState `shouldBe` "ingest" + + -- ======================================================================== + -- Typed schema: ISMPolicyBody, ISMState, ISMAction, ISMTransition, + -- ISMCondition. Pure JSON round-trip and rejection tests for the typed + -- shapes added in bloodhound-04f.6.1.1. Almost all cases exercise OS1 only + -- because the OS2/OS3 ISM modules are byte-identical mirrors (the build + -- verifies them); the allocation decode is spot-checked on OS3 as well. + -- ======================================================================== + + describe "ISM typed schema: ISMPolicyBody" $ do + it "round-trips the minimal body through encode -> decode" $ do + let encoded = encode samplePolicyBody + decode encoded `shouldBe` Just samplePolicyBody + + it "encodes the minimal body without the server-only fields" $ do + -- omitNulls drops empty arrays (actions/transitions) and Nothing + -- fields (ism_template, error_notification, user_vars); the body + -- therefore carries just description, default_state and states. + let encoded = encode samplePolicyBody + let Just (parsed :: Value) = decode encoded + case parsed of + Object o -> do + KM.lookup "default_state" o `shouldBe` Just (String "ingest") + KM.lookup "description" o `shouldBe` Just (String "test policy") + -- Empty actions/transitions arrays must be omitted by omitNulls: + KM.lookup "actions" o `shouldBe` Nothing + KM.lookup "transitions" o `shouldBe` Nothing + KM.lookup "ism_template" o `shouldBe` Nothing + other -> expectationFailure ("Expected Object, got " <> show other) + + it "round-trips the full body (states, actions, transitions, template, user_vars)" $ do + let encoded = encode sampleFullPolicyBody + decode encoded `shouldBe` Just sampleFullPolicyBody + + it "rejects a body missing default_state" $ do + let body = LBS.pack "{\"description\":\"no default\",\"states\":[]}" + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS1.Types.ISMPolicyBody + result `shouldSatisfy` isLeft + + it "rejects a body missing states (states is required by OpenSearch)" $ do + let body = LBS.pack "{\"description\":\"no states\",\"default_state\":\"hot\"}" + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS1.Types.ISMPolicyBody + result `shouldSatisfy` isLeft + + it "decodes a body with no description but with states" $ do + let body = + LBS.pack + "{\"default_state\":\"hot\",\"states\":[{\"name\":\"hot\"}]}" + let Just (parsed :: OS1.Types.ISMPolicyBody) = decode body + OS1.Types.ismPolicyBodyDescription parsed `shouldBe` Nothing + OS1.Types.ismPolicyBodyDefaultState parsed `shouldBe` "hot" + OS1.Types.ismPolicyBodyStates parsed `shouldSatisfy` (not . null) + + -- ======================================================================== + -- ism_template list form + fractional priority. The OpenSearch spec allows + -- ism_template as a single object, null, or an array of IsmTemplate, and + -- types priority as a generic number. These pin the normalisation + -- (single/array/null/missing -> list) and the Scientific priority decoder + -- that previously rejected fractional values. OS1, OS2 and OS3 share the + -- codec, so each is exercised. + -- ======================================================================== + describe "ISM typed schema: ism_template list form" $ do + let os1Tpl = + OS1.Types.ISMTemplate + { OS1.Types.ismTemplateIndexPatterns = ["log-*"], + OS1.Types.ismTemplatePriority = Just 50 + } + os2Tpl = + OS2.Types.ISMTemplate + { OS2.Types.ismTemplateIndexPatterns = ["log-*"], + OS2.Types.ismTemplatePriority = Just 50 + } + os3Tpl = + OS3.Types.ISMTemplate + { OS3.Types.ismTemplateIndexPatterns = ["log-*"], + OS3.Types.ismTemplatePriority = Just 50 + } + + it "OS1 decodes a single-object ism_template into a one-element list" $ do + let body = + LBS.pack + "{\"default_state\":\"hot\",\"states\":[],\"ism_template\":{\"index_patterns\":[\"log-*\"],\"priority\":50}}" + let Just (p :: OS1.Types.ISMPolicyBody) = decode body + OS1.Types.ismPolicyBodyIsmTemplate p `shouldBe` [os1Tpl] + + it "OS1 decodes an array ism_template into a multi-element list" $ do + let body = + LBS.pack + "{\"default_state\":\"hot\",\"states\":[],\"ism_template\":[{\"index_patterns\":[\"log-*\"],\"priority\":50},{\"index_patterns\":[\"audit-*\"],\"priority\":10}]}" + let Just (p :: OS1.Types.ISMPolicyBody) = decode body + OS1.Types.ismPolicyBodyIsmTemplate p `shouldSatisfy` (\l -> length l == 2) + OS1.Types.ismTemplateIndexPatterns (head (OS1.Types.ismPolicyBodyIsmTemplate p)) + `shouldBe` ["log-*"] + + it "OS1 decodes a null ism_template into the empty list" $ do + let body = + LBS.pack + "{\"default_state\":\"hot\",\"states\":[],\"ism_template\":null}" + let Just (p :: OS1.Types.ISMPolicyBody) = decode body + OS1.Types.ismPolicyBodyIsmTemplate p `shouldBe` [] + + it "OS1 decodes a missing ism_template into the empty list" $ do + let body = LBS.pack "{\"default_state\":\"hot\",\"states\":[]}" + let Just (p :: OS1.Types.ISMPolicyBody) = decode body + OS1.Types.ismPolicyBodyIsmTemplate p `shouldBe` [] + + it "OS1 encodes a non-empty ism_template as a JSON array" $ do + let b = samplePolicyBody {OS1.Types.ismPolicyBodyIsmTemplate = [os1Tpl]} + let Just (parsed :: Value) = decode (encode b) + case parsed of + Object o -> case KM.lookup "ism_template" o of + Just (Array _) -> pure () + other -> expectationFailure ("Expected Array, got " <> show other) + other -> expectationFailure ("Expected Object, got " <> show other) + + it "OS1 omits ism_template when the list is empty" $ do + let Just (parsed :: Value) = decode (encode samplePolicyBody) + case parsed of + Object o -> KM.lookup "ism_template" o `shouldBe` Nothing + other -> expectationFailure ("Expected Object, got " <> show other) + + it "OS2 decodes a single-object ism_template into a one-element list" $ do + let body = + LBS.pack + "{\"default_state\":\"hot\",\"states\":[],\"ism_template\":{\"index_patterns\":[\"log-*\"],\"priority\":50}}" + let Just (p :: OS2.Types.ISMPolicyBody) = decode body + OS2.Types.ismPolicyBodyIsmTemplate p `shouldBe` [os2Tpl] + + it "OS3 decodes a single-object ism_template into a one-element list" $ do + let body = + LBS.pack + "{\"default_state\":\"hot\",\"states\":[],\"ism_template\":{\"index_patterns\":[\"log-*\"],\"priority\":50}}" + let Just (p :: OS3.Types.ISMPolicyBody) = decode body + OS3.Types.ismPolicyBodyIsmTemplate p `shouldBe` [os3Tpl] + + describe "ISM typed schema: ISMTemplate priority (Scientific)" $ do + it "OS1 decodes a fractional priority" $ do + let body = LBS.pack "{\"index_patterns\":[\"log-*\"],\"priority\":1.5}" + let Just (t :: OS1.Types.ISMTemplate) = decode body + OS1.Types.ismTemplatePriority t `shouldBe` Just 1.5 + + it "OS1 round-trips a fractional priority" $ do + let t = + OS1.Types.ISMTemplate + { OS1.Types.ismTemplateIndexPatterns = ["log-*"], + OS1.Types.ismTemplatePriority = Just 1.5 + } + decode (encode t) `shouldBe` Just t + + it "OS2 decodes a fractional priority" $ do + let body = LBS.pack "{\"index_patterns\":[\"log-*\"],\"priority\":2.5}" + let Just (t :: OS2.Types.ISMTemplate) = decode body + OS2.Types.ismTemplatePriority t `shouldBe` Just 2.5 + + it "OS3 decodes a fractional priority" $ do + let body = LBS.pack "{\"index_patterns\":[\"log-*\"],\"priority\":3.5}" + let Just (t :: OS3.Types.ISMTemplate) = decode body + OS3.Types.ismTemplatePriority t `shouldBe` Just 3.5 + + describe "ISM typed schema: ISMState" $ do + it "round-trips a state with actions and transitions" $ do + let s = + OS1.Types.ISMState + { OS1.Types.ismStateName = "hot", + OS1.Types.ismStateActions = [OS1.Types.mkISMActionEntry OS1.Types.ISMActionDelete], + OS1.Types.ismStateTransitions = [] + } + decode (encode s) `shouldBe` Just s + + it "rejects a state missing name" $ do + let body = LBS.pack "{\"actions\":[],\"transitions\":[]}" + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS1.Types.ISMState + result `shouldSatisfy` isLeft + + it "decodes a state with no actions or transitions keys (defaults to empty)" $ do + let body = LBS.pack "{\"name\":\"hot\"}" + let Just (s :: OS1.Types.ISMState) = decode body + OS1.Types.ismStateActions s `shouldBe` [] + OS1.Types.ismStateTransitions s `shouldBe` [] + + describe "ISM typed schema: ISMAction encoding" $ do + it "encodes ISMActionRollover as a single-key object {\"rollover\":{...}}" $ do + let a = + OS1.Types.ISMActionRollover + ( Just + ( OS1.Types.ISMRolloverConfig + { OS1.Types.ismRolloverConfigMinSize = Just "1gb", + OS1.Types.ismRolloverConfigMinDocCount = Nothing, + OS1.Types.ismRolloverConfigMinIndexAge = Nothing, + OS1.Types.ismRolloverConfigMinPrimaryShardSize = Nothing, + OS1.Types.ismRolloverConfigCopyAlias = Nothing + } + ) + ) + encode a `shouldBe` encode (object ["rollover" .= object ["min_size" .= String "1gb"]]) + + it "round-trips rollover action with typed config" $ do + let a = + OS1.Types.ISMActionRollover + ( Just + ( OS1.Types.ISMRolloverConfig + { OS1.Types.ismRolloverConfigMinSize = Just "1gb", + OS1.Types.ismRolloverConfigMinDocCount = Just 1000, + OS1.Types.ismRolloverConfigMinIndexAge = Just "1d", + OS1.Types.ismRolloverConfigMinPrimaryShardSize = Nothing, + OS1.Types.ismRolloverConfigCopyAlias = Nothing + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "OS2 round-trips rollover action with copy_alias" $ do + let a = + OS2.Types.ISMActionRollover + ( Just + ( OS2.Types.ISMRolloverConfig + { OS2.Types.ismRolloverConfigMinSize = Just "1gb", + OS2.Types.ismRolloverConfigMinDocCount = Nothing, + OS2.Types.ismRolloverConfigMinIndexAge = Nothing, + OS2.Types.ismRolloverConfigMinPrimaryShardSize = Nothing, + OS2.Types.ismRolloverConfigCopyAlias = Just True + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "OS2 decodes rollover action with copy_alias from OpenSearch" $ do + let body = LBS.pack "{\"rollover\":{\"min_size\":\"1gb\",\"copy_alias\":true}}" + let Just (a :: OS2.Types.ISMAction) = decode body + case a of + OS2.Types.ISMActionRollover (Just cfg) -> do + OS2.Types.ismRolloverConfigMinSize cfg `shouldBe` Just "1gb" + OS2.Types.ismRolloverConfigCopyAlias cfg `shouldBe` Just True + other -> expectationFailure ("Expected ISMActionRollover, got " <> show other) + + it "OS2 encodes copy_alias as a top-level rollover key" $ do + let a = + OS2.Types.ISMActionRollover + ( Just + ( OS2.Types.ISMRolloverConfig + { OS2.Types.ismRolloverConfigMinSize = Nothing, + OS2.Types.ismRolloverConfigMinDocCount = Nothing, + OS2.Types.ismRolloverConfigMinIndexAge = Nothing, + OS2.Types.ismRolloverConfigMinPrimaryShardSize = Nothing, + OS2.Types.ismRolloverConfigCopyAlias = Just True + } + ) + ) + encode a `shouldBe` encode (object ["rollover" .= object ["copy_alias" .= Bool True]]) + + it "OS3 round-trips rollover action with copy_alias" $ do + let a = + OS3.Types.ISMActionRollover + ( Just + ( OS3.Types.ISMRolloverConfig + { OS3.Types.ismRolloverConfigMinSize = Just "1gb", + OS3.Types.ismRolloverConfigMinDocCount = Nothing, + OS3.Types.ismRolloverConfigMinIndexAge = Nothing, + OS3.Types.ismRolloverConfigMinPrimaryShardSize = Nothing, + OS3.Types.ismRolloverConfigCopyAlias = Just True + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "OS3 decodes rollover action with copy_alias from OpenSearch" $ do + let body = LBS.pack "{\"rollover\":{\"min_size\":\"1gb\",\"copy_alias\":true}}" + let Just (a :: OS3.Types.ISMAction) = decode body + case a of + OS3.Types.ISMActionRollover (Just cfg) -> do + OS3.Types.ismRolloverConfigMinSize cfg `shouldBe` Just "1gb" + OS3.Types.ismRolloverConfigCopyAlias cfg `shouldBe` Just True + other -> expectationFailure ("Expected ISMActionRollover, got " <> show other) + + it "OS2 round-trips rollover with copy_alias = Just False (not omitted)" $ do + let a = + OS2.Types.ISMActionRollover + ( Just + ( OS2.Types.ISMRolloverConfig + { OS2.Types.ismRolloverConfigMinSize = Just "1gb", + OS2.Types.ismRolloverConfigMinDocCount = Nothing, + OS2.Types.ismRolloverConfigMinIndexAge = Nothing, + OS2.Types.ismRolloverConfigMinPrimaryShardSize = Nothing, + OS2.Types.ismRolloverConfigCopyAlias = Just False + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "round-trips force_merge action with typed config" $ do + let a = + OS1.Types.ISMActionForceMerge + ( Just + ( OS1.Types.ISMForceMergeConfig + { OS1.Types.ismForceMergeConfigMaxNumSegments = Just 5, + OS1.Types.ismForceMergeConfigWaitForCompletion = Nothing, + OS1.Types.ismForceMergeConfigTaskExecutionTimeout = Nothing + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "OS1 round-trips rollover action with copy_alias" $ do + let a = + OS1.Types.ISMActionRollover + ( Just + ( OS1.Types.ISMRolloverConfig + { OS1.Types.ismRolloverConfigMinSize = Just "1gb", + OS1.Types.ismRolloverConfigMinDocCount = Nothing, + OS1.Types.ismRolloverConfigMinIndexAge = Nothing, + OS1.Types.ismRolloverConfigMinPrimaryShardSize = Nothing, + OS1.Types.ismRolloverConfigCopyAlias = Just True + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "OS1 decodes rollover action with copy_alias from OpenSearch" $ do + let body = LBS.pack "{\"rollover\":{\"min_size\":\"1gb\",\"copy_alias\":true}}" + let Just (a :: OS1.Types.ISMAction) = decode body + case a of + OS1.Types.ISMActionRollover (Just cfg) -> do + OS1.Types.ismRolloverConfigMinSize cfg `shouldBe` Just "1gb" + OS1.Types.ismRolloverConfigCopyAlias cfg `shouldBe` Just True + other -> expectationFailure ("Expected ISMActionRollover, got " <> show other) + + it "OS1 encodes copy_alias as a top-level rollover key" $ do + let a = + OS1.Types.ISMActionRollover + ( Just + ( OS1.Types.ISMRolloverConfig + { OS1.Types.ismRolloverConfigMinSize = Nothing, + OS1.Types.ismRolloverConfigMinDocCount = Nothing, + OS1.Types.ismRolloverConfigMinIndexAge = Nothing, + OS1.Types.ismRolloverConfigMinPrimaryShardSize = Nothing, + OS1.Types.ismRolloverConfigCopyAlias = Just True + } + ) + ) + encode a `shouldBe` encode (object ["rollover" .= object ["copy_alias" .= Bool True]]) + + it "OS1 round-trips force_merge with wait_for_completion and task_execution_timeout" $ do + let a = + OS1.Types.ISMActionForceMerge + ( Just + ( OS1.Types.ISMForceMergeConfig + { OS1.Types.ismForceMergeConfigMaxNumSegments = Just 1, + OS1.Types.ismForceMergeConfigWaitForCompletion = Just False, + OS1.Types.ismForceMergeConfigTaskExecutionTimeout = Just "1h" + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "OS1 decodes force_merge payload straight from OpenSearch" $ do + let body = + LBS.pack + "{\"force_merge\":{\"max_num_segments\":1,\"wait_for_completion\":false,\"task_execution_timeout\":\"1h\"}}" + let Just (a :: OS1.Types.ISMAction) = decode body + case a of + OS1.Types.ISMActionForceMerge (Just cfg) -> do + OS1.Types.ismForceMergeConfigMaxNumSegments cfg `shouldBe` Just 1 + OS1.Types.ismForceMergeConfigWaitForCompletion cfg `shouldBe` Just False + OS1.Types.ismForceMergeConfigTaskExecutionTimeout cfg `shouldBe` Just "1h" + other -> expectationFailure ("Expected ISMActionForceMerge, got " <> show other) + + it "OS1 omits wait_for_completion/task_execution_timeout when Nothing" $ do + let a = + OS1.Types.ISMActionForceMerge + ( Just + ( OS1.Types.ISMForceMergeConfig + { OS1.Types.ismForceMergeConfigMaxNumSegments = Just 5, + OS1.Types.ismForceMergeConfigWaitForCompletion = Nothing, + OS1.Types.ismForceMergeConfigTaskExecutionTimeout = Nothing + } + ) + ) + case decode (encode a) :: Maybe (KM.KeyMap Value) of + Just outer + | Just (Object inner) <- KM.lookup "force_merge" outer -> do + KM.member "wait_for_completion" inner `shouldBe` False + KM.member "task_execution_timeout" inner `shouldBe` False + _ -> expectationFailure "expected force_merge object" + + it "OS2 round-trips force_merge with wait_for_completion and task_execution_timeout" $ do + let a = + OS2.Types.ISMActionForceMerge + ( Just + ( OS2.Types.ISMForceMergeConfig + { OS2.Types.ismForceMergeConfigMaxNumSegments = Just 1, + OS2.Types.ismForceMergeConfigWaitForCompletion = Just False, + OS2.Types.ismForceMergeConfigTaskExecutionTimeout = Just "1h" + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "OS3 round-trips force_merge with wait_for_completion and task_execution_timeout" $ do + let a = + OS3.Types.ISMActionForceMerge + ( Just + ( OS3.Types.ISMForceMergeConfig + { OS3.Types.ismForceMergeConfigMaxNumSegments = Just 1, + OS3.Types.ismForceMergeConfigWaitForCompletion = Just False, + OS3.Types.ismForceMergeConfigTaskExecutionTimeout = Just "1h" + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "OS2 decodes force_merge payload straight from OpenSearch 2.18" $ do + let body = + LBS.pack + "{\"force_merge\":{\"max_num_segments\":1,\"wait_for_completion\":false,\"task_execution_timeout\":\"1h\"}}" + let Just (a :: OS2.Types.ISMAction) = decode body + case a of + OS2.Types.ISMActionForceMerge (Just cfg) -> do + OS2.Types.ismForceMergeConfigMaxNumSegments cfg `shouldBe` Just 1 + OS2.Types.ismForceMergeConfigWaitForCompletion cfg `shouldBe` Just False + OS2.Types.ismForceMergeConfigTaskExecutionTimeout cfg `shouldBe` Just "1h" + other -> expectationFailure ("Expected ISMActionForceMerge, got " <> show other) + + it "OS2 omits wait_for_completion/task_execution_timeout when Nothing" $ do + let a = + OS2.Types.ISMActionForceMerge + ( Just + ( OS2.Types.ISMForceMergeConfig + { OS2.Types.ismForceMergeConfigMaxNumSegments = Just 5, + OS2.Types.ismForceMergeConfigWaitForCompletion = Nothing, + OS2.Types.ismForceMergeConfigTaskExecutionTimeout = Nothing + } + ) + ) + case decode (encode a) :: Maybe (KM.KeyMap Value) of + Just outer + | Just (Object inner) <- KM.lookup "force_merge" outer -> do + KM.member "wait_for_completion" inner `shouldBe` False + KM.member "task_execution_timeout" inner `shouldBe` False + _ -> expectationFailure "expected force_merge object" + + it "round-trips allocation action with typed config" $ do + let a = + OS1.Types.ISMActionAllocation + ( Just + ( OS1.Types.ISMAllocationConfig + { OS1.Types.ismAllocationConfigRequire = Just (Map.fromList [("box_type", "hot")]), + OS1.Types.ismAllocationConfigInclude = Nothing, + OS1.Types.ismAllocationConfigExclude = Nothing, + OS1.Types.ismAllocationConfigWaitFor = Nothing + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "round-trips allocation action with wait_for" $ do + let a = + OS1.Types.ISMActionAllocation + ( Just + ( OS1.Types.ISMAllocationConfig + { OS1.Types.ismAllocationConfigRequire = Just (Map.fromList [("box_type", "hot")]), + OS1.Types.ismAllocationConfigInclude = Nothing, + OS1.Types.ismAllocationConfigExclude = Just (Map.fromList [("box_type", "warm")]), + OS1.Types.ismAllocationConfigWaitFor = Just True + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "round-trips allocation action with wait_for = Just False" $ do + let a = + OS1.Types.ISMActionAllocation + ( Just + ( OS1.Types.ISMAllocationConfig + { OS1.Types.ismAllocationConfigRequire = Just (Map.fromList [("box_type", "hot")]), + OS1.Types.ismAllocationConfigInclude = Nothing, + OS1.Types.ismAllocationConfigExclude = Nothing, + OS1.Types.ismAllocationConfigWaitFor = Just False + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "decodes an allocation action payload straight from OpenSearch" $ do + let body = LBS.pack "{\"allocation\":{\"require\":{\"box_type\":\"hot\"},\"wait_for\":false}}" + let Just (a :: OS1.Types.ISMAction) = decode body + case a of + OS1.Types.ISMActionAllocation (Just cfg) -> do + OS1.Types.ismAllocationConfigWaitFor cfg `shouldBe` Just False + OS1.Types.ismAllocationConfigRequire cfg + `shouldBe` Just (Map.fromList [("box_type", "hot")]) + other -> expectationFailure ("Expected ISMActionAllocation, got " <> show other) + + it "OS3 decodes an allocation action payload straight from OpenSearch" $ do + let body = LBS.pack "{\"allocation\":{\"require\":{\"box_type\":\"hot\"},\"wait_for\":false}}" + let Just (a :: OS3.Types.ISMAction) = decode body + case a of + OS3.Types.ISMActionAllocation (Just cfg) -> do + OS3.Types.ismAllocationConfigWaitFor cfg `shouldBe` Just False + OS3.Types.ismAllocationConfigRequire cfg + `shouldBe` Just (Map.fromList [("box_type", "hot")]) + other -> expectationFailure ("Expected ISMActionAllocation, got " <> show other) + + it "round-trips replica_count action with typed config" $ do + let a = + OS1.Types.ISMActionReplicaCount + ( Just + ( OS1.Types.ISMReplicaCountConfig + { OS1.Types.ismReplicaCountConfigNumberOfReplicas = 2 + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "encodes ISMActionReplicaCount as {\"replica_count\":{\"number_of_replicas\":N}}" $ do + let a = + OS1.Types.ISMActionReplicaCount + ( Just + ( OS1.Types.ISMReplicaCountConfig + { OS1.Types.ismReplicaCountConfigNumberOfReplicas = 3 + } + ) + ) + encode a `shouldBe` encode (object ["replica_count" .= object ["number_of_replicas" .= (3 :: Int)]]) + + it "encodes ISMActionReplicaCount Nothing as {\"replica_count\":{}}" $ + encode (OS1.Types.ISMActionReplicaCount Nothing) + `shouldBe` encode (object ["replica_count" .= object []]) + + it "decodes a replica_count action payload into the typed constructor (not ISMActionCustom)" $ do + let body = LBS.pack "{\"replica_count\":{\"number_of_replicas\":2}}" + let Just (a :: OS1.Types.ISMAction) = decode body + case a of + OS1.Types.ISMActionReplicaCount (Just cfg) -> + OS1.Types.ismReplicaCountConfigNumberOfReplicas cfg `shouldBe` 2 + other -> + expectationFailure ("Expected ISMActionReplicaCount, got " <> show other) + + it "round-trips alias action with add and remove sub-actions" $ do + let a = + OS1.Types.ISMActionAlias + ( Just + ( OS1.Types.ISMAliasConfig + { OS1.Types.ismAliasConfigActions = + [ OS1.Types.ISMAliasActionAdd + { OS1.Types.ismAliasActionAddAlias = "log", + OS1.Types.ismAliasActionAddIndex = Just "log-2024-01-01", + OS1.Types.ismAliasActionAddIsWriteIndex = Just True + }, + OS1.Types.ISMAliasActionRemove + { OS1.Types.ismAliasActionRemoveAlias = "old-log" + } + ] + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "round-trips alias action with a minimal add (alias only)" $ do + let a = + OS1.Types.ISMActionAlias + ( Just + ( OS1.Types.ISMAliasConfig + { OS1.Types.ismAliasConfigActions = + [ OS1.Types.ISMAliasActionAdd + { OS1.Types.ismAliasActionAddAlias = "log", + OS1.Types.ismAliasActionAddIndex = Nothing, + OS1.Types.ismAliasActionAddIsWriteIndex = Nothing + } + ] + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "decodes the doc example alias payload (single remove) into the typed constructor" $ do + let body = LBS.pack "{\"alias\":{\"actions\":[{\"remove\":{\"alias\":\"log\"}}]}}" + let Just (a :: OS1.Types.ISMAction) = decode body + case a of + OS1.Types.ISMActionAlias (Just cfg) -> + OS1.Types.ismAliasConfigActions cfg + `shouldBe` [ OS1.Types.ISMAliasActionRemove + { OS1.Types.ismAliasActionRemoveAlias = "log" + } + ] + other -> + expectationFailure ("Expected ISMActionAlias, got " <> show other) + + it "encodes ISMActionAlias Nothing as {\"alias\":{}}" $ + encode (OS1.Types.ISMActionAlias Nothing) + `shouldBe` encode (object ["alias" .= object []]) + + it "OS2 round-trips replica_count action with typed config" $ do + let a = + OS2.Types.ISMActionReplicaCount + ( Just + ( OS2.Types.ISMReplicaCountConfig + { OS2.Types.ismReplicaCountConfigNumberOfReplicas = 2 + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "OS3 round-trips replica_count action with typed config" $ do + let a = + OS3.Types.ISMActionReplicaCount + ( Just + ( OS3.Types.ISMReplicaCountConfig + { OS3.Types.ismReplicaCountConfigNumberOfReplicas = 2 + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "OS2 round-trips alias action with add and remove sub-actions" $ do + let a = + OS2.Types.ISMActionAlias + ( Just + ( OS2.Types.ISMAliasConfig + { OS2.Types.ismAliasConfigActions = + [ OS2.Types.ISMAliasActionAdd + { OS2.Types.ismAliasActionAddAlias = "log", + OS2.Types.ismAliasActionAddIndex = Just "log-2024-01-01", + OS2.Types.ismAliasActionAddIsWriteIndex = Just True + }, + OS2.Types.ISMAliasActionRemove + { OS2.Types.ismAliasActionRemoveAlias = "old-log" + } + ] + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "OS3 round-trips alias action with add and remove sub-actions" $ do + let a = + OS3.Types.ISMActionAlias + ( Just + ( OS3.Types.ISMAliasConfig + { OS3.Types.ismAliasConfigActions = + [ OS3.Types.ISMAliasActionAdd + { OS3.Types.ismAliasActionAddAlias = "log", + OS3.Types.ismAliasActionAddIndex = Just "log-2024-01-01", + OS3.Types.ismAliasActionAddIsWriteIndex = Just True + }, + OS3.Types.ISMAliasActionRemove + { OS3.Types.ismAliasActionRemoveAlias = "old-log" + } + ] + } + ) + ) + decode (encode a) `shouldBe` Just a + + it "OS2 actionTagName yields the wire name for replica_count and alias" $ do + OS2.Types.actionTagName (OS2.Types.ISMActionReplicaCount Nothing) + `shouldBe` "replica_count" + OS2.Types.actionTagName (OS2.Types.ISMActionAlias Nothing) + `shouldBe` "alias" + + it "OS3 actionTagName yields the wire name for replica_count and alias" $ do + OS3.Types.actionTagName (OS3.Types.ISMActionReplicaCount Nothing) + `shouldBe` "replica_count" + OS3.Types.actionTagName (OS3.Types.ISMActionAlias Nothing) + `shouldBe` "alias" + + it "encodes ISMActionDelete as {\"delete\":{}}" $ + encode OS1.Types.ISMActionDelete `shouldBe` encode (object ["delete" .= object []]) + + it "encodes ISMActionReadOnly as {\"read_only\":{}}" $ + encode OS1.Types.ISMActionReadOnly `shouldBe` encode (object ["read_only" .= object []]) + + it "decodes an unknown action name into ISMActionCustom (lossless)" $ do + let body = LBS.pack "{\"new_action\":{\"foo\":\"bar\"}}" + let Just (a :: OS1.Types.ISMAction) = decode body + case a of + OS1.Types.ISMActionCustom tag _ -> + tag `shouldBe` "new_action" + other -> expectationFailure ("Expected ISMActionCustom, got " <> show other) + + it "round-trips an unknown action through ISMActionCustom" $ do + let body = LBS.pack "{\"new_action\":{\"foo\":\"bar\"}}" + let Just (a :: OS1.Types.ISMAction) = decode body + -- Re-encoding should preserve the tag name and the inner config. + let Just (a' :: OS1.Types.ISMAction) = decode (encode a) + a' `shouldBe` a + + it "rejects an empty action object" $ do + let body = LBS.pack "{}" + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS1.Types.ISMAction + result `shouldSatisfy` isLeft + + describe "ISM typed schema: ISMActionEntry meta (timeout/retry)" $ do + it "mkISMActionEntry encodes byte-for-byte like the bare action" $ do + let bareA = OS1.Types.ISMActionDelete + encode (OS1.Types.mkISMActionEntry bareA) `shouldBe` encode bareA + + it "mkISMActionEntry preserves the bare action for a typed-config action" $ do + let rollover = + OS1.Types.ISMActionRollover + ( Just + ( OS1.Types.ISMRolloverConfig + { OS1.Types.ismRolloverConfigMinSize = Just "1gb", + OS1.Types.ismRolloverConfigMinDocCount = Nothing, + OS1.Types.ismRolloverConfigMinIndexAge = Nothing, + OS1.Types.ismRolloverConfigMinPrimaryShardSize = Nothing, + OS1.Types.ismRolloverConfigCopyAlias = Nothing + } + ) + ) + encode (OS1.Types.mkISMActionEntry rollover) `shouldBe` encode rollover + + it "encodes timeout as a sibling of the action key (flat merge)" $ do + let entry = + OS1.Types.ISMActionEntry + { OS1.Types.ismActionEntryAction = OS1.Types.ISMActionDelete, + OS1.Types.ismActionEntryTimeout = Just "1d", + OS1.Types.ismActionEntryRetry = Nothing + } + encode entry + `shouldBe` encode + ( object + [ "delete" .= object [], + "timeout" .= String "1d" + ] + ) + + it "encodes retry as a sibling of the action key (flat merge)" $ do + let entry = + OS1.Types.ISMActionEntry + { OS1.Types.ismActionEntryAction = OS1.Types.ISMActionDelete, + OS1.Types.ismActionEntryTimeout = Nothing, + OS1.Types.ismActionEntryRetry = + Just + ( OS1.Types.ISMRetryConfig + { OS1.Types.ismRetryConfigCount = Just 3, + OS1.Types.ismRetryConfigBackoff = Just OS1.Types.ISMRetryBackoffExponential, + OS1.Types.ismRetryConfigDelay = Just "1m" + } + ) + } + encode entry + `shouldBe` encode + ( object + [ "delete" .= object [], + "retry" + .= object + [ "count" .= (3 :: Int), + "backoff" .= String "exponential", + "delay" .= String "1m" + ] + ] + ) + + it "encodes a fully-populated entry with action+timeout+retry" $ do + let entry = + OS1.Types.ISMActionEntry + { OS1.Types.ismActionEntryAction = + OS1.Types.ISMActionRollover + ( Just + ( OS1.Types.ISMRolloverConfig + { OS1.Types.ismRolloverConfigMinSize = Just "50gb", + OS1.Types.ismRolloverConfigMinDocCount = Nothing, + OS1.Types.ismRolloverConfigMinIndexAge = Nothing, + OS1.Types.ismRolloverConfigMinPrimaryShardSize = Nothing, + OS1.Types.ismRolloverConfigCopyAlias = Nothing + } + ) + ), + OS1.Types.ismActionEntryTimeout = Just "1d", + OS1.Types.ismActionEntryRetry = + Just + ( OS1.Types.ISMRetryConfig + { OS1.Types.ismRetryConfigCount = Just 3, + OS1.Types.ismRetryConfigBackoff = Just OS1.Types.ISMRetryBackoffExponential, + OS1.Types.ismRetryConfigDelay = Just "1m" + } + ) + } + encode entry + `shouldBe` encode + ( object + [ "rollover" .= object ["min_size" .= String "50gb"], + "timeout" .= String "1d", + "retry" + .= object + [ "count" .= (3 :: Int), + "backoff" .= String "exponential", + "delay" .= String "1m" + ] + ] + ) + + it "decodes an action entry without meta (backwards compat)" $ do + let body = LBS.pack "{\"delete\":{}}" + let Just (e :: OS1.Types.ISMActionEntry) = decode body + OS1.Types.ismActionEntryAction e `shouldBe` OS1.Types.ISMActionDelete + OS1.Types.ismActionEntryTimeout e `shouldBe` Nothing + OS1.Types.ismActionEntryRetry e `shouldBe` Nothing + + it "decodes timeout sibling" $ do + let body = LBS.pack "{\"delete\":{}, \"timeout\":\"1d\"}" + let Just (e :: OS1.Types.ISMActionEntry) = decode body + OS1.Types.ismActionEntryAction e `shouldBe` OS1.Types.ISMActionDelete + OS1.Types.ismActionEntryTimeout e `shouldBe` Just "1d" + OS1.Types.ismActionEntryRetry e `shouldBe` Nothing + + it "decodes retry sibling" $ do + let body = + LBS.pack + "{\"delete\":{}, \"retry\":{\"count\":3,\"backoff\":\"exponential\",\"delay\":\"1m\"}}" + let Just (e :: OS1.Types.ISMActionEntry) = decode body + OS1.Types.ismActionEntryAction e `shouldBe` OS1.Types.ISMActionDelete + OS1.Types.ismActionEntryTimeout e `shouldBe` Nothing + OS1.Types.ismActionEntryRetry e + `shouldBe` Just + ( OS1.Types.ISMRetryConfig + { OS1.Types.ismRetryConfigCount = Just 3, + OS1.Types.ismRetryConfigBackoff = Just OS1.Types.ISMRetryBackoffExponential, + OS1.Types.ismRetryConfigDelay = Just "1m" + } + ) + + it "decodes both timeout and retry siblings" $ do + let body = + LBS.pack + "{\"rollover\":{\"min_size\":\"50gb\"}, \"timeout\":\"1d\", \"retry\":{\"count\":3,\"backoff\":\"exponential\",\"delay\":\"1m\"}}" + let Just (e :: OS1.Types.ISMActionEntry) = decode body + OS1.Types.ismActionEntryTimeout e `shouldBe` Just "1d" + OS1.Types.ismActionEntryRetry e + `shouldBe` Just + ( OS1.Types.ISMRetryConfig + { OS1.Types.ismRetryConfigCount = Just 3, + OS1.Types.ismRetryConfigBackoff = Just OS1.Types.ISMRetryBackoffExponential, + OS1.Types.ismRetryConfigDelay = Just "1m" + } + ) + case OS1.Types.ismActionEntryAction e of + OS1.Types.ISMActionRollover (Just cfg) -> + OS1.Types.ismRolloverConfigMinSize cfg `shouldBe` Just "50gb" + other -> + expectationFailure ("Expected ISMActionRollover, got " <> show other) + + it "round-trips a fully-populated entry through encode -> decode" $ do + let entry = + OS1.Types.ISMActionEntry + { OS1.Types.ismActionEntryAction = OS1.Types.ISMActionDelete, + OS1.Types.ismActionEntryTimeout = Just "1d", + OS1.Types.ismActionEntryRetry = + Just + ( OS1.Types.ISMRetryConfig + { OS1.Types.ismRetryConfigCount = Just 3, + OS1.Types.ismRetryConfigBackoff = Just OS1.Types.ISMRetryBackoffExponential, + OS1.Types.ismRetryConfigDelay = Just "1m" + } + ) + } + decode (encode entry) `shouldBe` Just entry + + it "round-trips an entry built with mkISMActionEntry (no meta)" $ do + let entry = OS1.Types.mkISMActionEntry OS1.Types.ISMActionDelete + decode (encode entry) `shouldBe` Just entry + + it "ISMRetryBackoff renders all three strategies" $ do + OS1.Types.ismRetryBackoffText OS1.Types.ISMRetryBackoffExponential `shouldBe` "exponential" + OS1.Types.ismRetryBackoffText OS1.Types.ISMRetryBackoffConstant `shouldBe` "constant" + OS1.Types.ismRetryBackoffText OS1.Types.ISMRetryBackoffLinear `shouldBe` "linear" + + it "ISMRetryBackoff decodes all three strategies" $ do + decode "\"exponential\"" `shouldBe` Just OS1.Types.ISMRetryBackoffExponential + decode "\"constant\"" `shouldBe` Just OS1.Types.ISMRetryBackoffConstant + decode "\"linear\"" `shouldBe` Just OS1.Types.ISMRetryBackoffLinear + + it "ISMRetryBackoff rejects an unknown strategy" $ do + let result = + parseEither parseJSON =<< eitherDecode (LBS.pack "\"backoff\"") :: + Either String OS1.Types.ISMRetryBackoff + result `shouldSatisfy` isLeft + + it "ISMRetryConfig omits null fields (partial config)" $ do + let cfg = + OS1.Types.ISMRetryConfig + { OS1.Types.ismRetryConfigCount = Just 3, + OS1.Types.ismRetryConfigBackoff = Nothing, + OS1.Types.ismRetryConfigDelay = Nothing + } + encode cfg `shouldBe` encode (object ["count" .= (3 :: Int)]) + + it "round-trips a state whose action carries timeout/retry meta" $ do + let entry = + OS1.Types.ISMActionEntry + { OS1.Types.ismActionEntryAction = OS1.Types.ISMActionDelete, + OS1.Types.ismActionEntryTimeout = Just "1d", + OS1.Types.ismActionEntryRetry = + Just + ( OS1.Types.ISMRetryConfig + { OS1.Types.ismRetryConfigCount = Just 3, + OS1.Types.ismRetryConfigBackoff = Just OS1.Types.ISMRetryBackoffConstant, + OS1.Types.ismRetryConfigDelay = Just "30m" + } + ) + } + let s = + OS1.Types.ISMState + { OS1.Types.ismStateName = "hot", + OS1.Types.ismStateActions = [entry], + OS1.Types.ismStateTransitions = [] + } + decode (encode s) `shouldBe` Just s + + it "OS1 round-trips an entry whose retry uses Linear backoff (wire-level)" $ do + let entry = + OS1.Types.ISMActionEntry + { OS1.Types.ismActionEntryAction = OS1.Types.ISMActionDelete, + OS1.Types.ismActionEntryTimeout = Nothing, + OS1.Types.ismActionEntryRetry = + Just + ( OS1.Types.ISMRetryConfig + { OS1.Types.ismRetryConfigCount = Just 5, + OS1.Types.ismRetryConfigBackoff = Just OS1.Types.ISMRetryBackoffLinear, + OS1.Types.ismRetryConfigDelay = Just "10m" + } + ) + } + decode (encode entry) `shouldBe` Just entry + + it "OS2 round-trips an entry whose retry uses Linear backoff (wire-level)" $ do + let entry = + OS2.Types.ISMActionEntry + { OS2.Types.ismActionEntryAction = OS2.Types.ISMActionDelete, + OS2.Types.ismActionEntryTimeout = Nothing, + OS2.Types.ismActionEntryRetry = + Just + ( OS2.Types.ISMRetryConfig + { OS2.Types.ismRetryConfigCount = Just 5, + OS2.Types.ismRetryConfigBackoff = Just OS2.Types.ISMRetryBackoffLinear, + OS2.Types.ismRetryConfigDelay = Just "10m" + } + ) + } + decode (encode entry) `shouldBe` Just entry + + it "OS3 round-trips an entry whose retry uses Linear backoff (wire-level)" $ do + let entry = + OS3.Types.ISMActionEntry + { OS3.Types.ismActionEntryAction = OS3.Types.ISMActionDelete, + OS3.Types.ismActionEntryTimeout = Nothing, + OS3.Types.ismActionEntryRetry = + Just + ( OS3.Types.ISMRetryConfig + { OS3.Types.ismRetryConfigCount = Just 5, + OS3.Types.ismRetryConfigBackoff = Just OS3.Types.ISMRetryBackoffLinear, + OS3.Types.ismRetryConfigDelay = Just "10m" + } + ) + } + decode (encode entry) `shouldBe` Just entry + + it "OS1 round-trips an ISMActionCustom entry carrying timeout+retry meta" $ do + let entry = + OS1.Types.ISMActionEntry + { OS1.Types.ismActionEntryAction = + OS1.Types.ISMActionCustom + "custom_op" + (Just (object ["steps" .= (5 :: Int)])), + OS1.Types.ismActionEntryTimeout = Just "1d", + OS1.Types.ismActionEntryRetry = + Just + ( OS1.Types.ISMRetryConfig + { OS1.Types.ismRetryConfigCount = Just 3, + OS1.Types.ismRetryConfigBackoff = Just OS1.Types.ISMRetryBackoffExponential, + OS1.Types.ismRetryConfigDelay = Just "1m" + } + ) + } + decode (encode entry) `shouldBe` Just entry + + it "OS2 round-trips an ISMActionCustom entry carrying timeout+retry meta" $ do + let entry = + OS2.Types.ISMActionEntry + { OS2.Types.ismActionEntryAction = + OS2.Types.ISMActionCustom + "custom_op" + (Just (object ["steps" .= (5 :: Int)])), + OS2.Types.ismActionEntryTimeout = Just "1d", + OS2.Types.ismActionEntryRetry = + Just + ( OS2.Types.ISMRetryConfig + { OS2.Types.ismRetryConfigCount = Just 3, + OS2.Types.ismRetryConfigBackoff = Just OS2.Types.ISMRetryBackoffExponential, + OS2.Types.ismRetryConfigDelay = Just "1m" + } + ) + } + decode (encode entry) `shouldBe` Just entry + + it "OS3 round-trips an ISMActionCustom entry carrying timeout+retry meta" $ do + let entry = + OS3.Types.ISMActionEntry + { OS3.Types.ismActionEntryAction = + OS3.Types.ISMActionCustom + "custom_op" + (Just (object ["steps" .= (5 :: Int)])), + OS3.Types.ismActionEntryTimeout = Just "1d", + OS3.Types.ismActionEntryRetry = + Just + ( OS3.Types.ISMRetryConfig + { OS3.Types.ismRetryConfigCount = Just 3, + OS3.Types.ismRetryConfigBackoff = Just OS3.Types.ISMRetryBackoffExponential, + OS3.Types.ismRetryConfigDelay = Just "1m" + } + ) + } + decode (encode entry) `shouldBe` Just entry + + -- 'rollover' iterates after 'retry' in aeson's KeyMap, so without the + -- decode-side 'deleteSeveral ["timeout","retry"]' guard the meta 'retry' + -- key would be mis-read as an 'ISMActionCustom "retry"'. This pins the + -- guard for OS2 (the OS1 twin is "decodes both timeout and retry + -- siblings" above). + it "OS2 decodes a rollover entry with meta even when 'retry' iterates first" $ do + let body = + LBS.pack + "{\"rollover\":{\"min_size\":\"50gb\"},\"timeout\":\"1d\",\"retry\":{\"count\":3,\"backoff\":\"exponential\",\"delay\":\"1m\"}}" + let Just (e :: OS2.Types.ISMActionEntry) = decode body + OS2.Types.ismActionEntryTimeout e `shouldBe` Just "1d" + case OS2.Types.ismActionEntryAction e of + OS2.Types.ISMActionRollover (Just cfg) -> + OS2.Types.ismRolloverConfigMinSize cfg `shouldBe` Just "50gb" + other -> + expectationFailure ("Expected ISMActionRollover, got " <> show other) + + it "OS3 decodes a rollover entry with meta even when 'retry' iterates first" $ do + let body = + LBS.pack + "{\"rollover\":{\"min_size\":\"50gb\"},\"timeout\":\"1d\",\"retry\":{\"count\":3,\"backoff\":\"exponential\",\"delay\":\"1m\"}}" + let Just (e :: OS3.Types.ISMActionEntry) = decode body + OS3.Types.ismActionEntryTimeout e `shouldBe` Just "1d" + case OS3.Types.ismActionEntryAction e of + OS3.Types.ISMActionRollover (Just cfg) -> + OS3.Types.ismRolloverConfigMinSize cfg `shouldBe` Just "50gb" + other -> + expectationFailure ("Expected ISMActionRollover, got " <> show other) + + describe "ISM typed schema: ISMPolicyRequest" $ do + it "round-trips the request through encode -> decode" $ do + let encoded = encode os1SamplePolicy + decode encoded `shouldBe` Just os1SamplePolicy + + it "wraps the body in a top-level policy key on encode" $ do + -- OpenSearch's PUT /_plugins/_ism/policies/{id} endpoint requires the + -- user-supplied body to sit inside a top-level "policy" wrapper. + -- ISMPolicyRequest's ToJSON instance emits that wrapper. + let encoded = encode os1SamplePolicy + let Just (parsed :: Value) = decode encoded + case parsed of + Object o -> do + KM.lookup "policy" o `shouldSatisfy` isJust + -- The body fields (default_state) live INSIDE the wrapper, not at + -- the top level. + KM.lookup "default_state" o `shouldBe` Nothing + case KM.lookup "policy" o of + Just (Object inner) -> + KM.lookup "default_state" inner `shouldBe` Just (String "ingest") + other -> expectationFailure ("Expected inner Object, got " <> show other) + other -> expectationFailure ("Expected Object, got " <> show other) + + it "decodes both wrapped ({\"policy\":{...}}) and bare body shapes" $ do + -- The decoder accepts both the wrapped form (what ToJSON emits and what + -- OS expects on the wire) and the bare form (used by hand-built + -- fixtures and unit tests). + let wrapped = encode os1SamplePolicy + bare = encode samplePolicyBody + decode wrapped `shouldBe` Just os1SamplePolicy + decode bare `shouldBe` Just os1SamplePolicy + + describe "ISM typed schema: ISMPolicyResponse" $ do + it "round-trips a response with server-injected fields" $ do + let r = + OS1.Types.ISMPolicyResponse + { OS1.Types.ismPolicyResponsePolicyId = Just "log_policy", + OS1.Types.ismPolicyResponseSchemaVersion = Just 1, + OS1.Types.ismPolicyResponseLastUpdatedTime = Just 1700000000000, + OS1.Types.ismPolicyResponseBody = samplePolicyBody + } + decode (encode r) `shouldBe` Just r + + -- ======================================================================== + -- Direct tests for the cron transition condition. The OpenSearch docs + -- (https://docs.opensearch.org/latest/im-plugin/ism/policies/#transitions) + -- shape conditions.cron as a nested object: + -- {"cron":{"cron":{"expression":"...","timezone":"..."}}} + -- The ISMCondition parser must decode that shape (not a bare string) and + -- re-encode it losslessly. Only OS1 is exercised because OS2/OS3 ISM are + -- byte-identical mirrors (the build verifies them). + -- ======================================================================== + + describe "ISM typed schema: ISMCondition cron" $ do + let documentedCronBody = + LBS.pack + ( unlines + [ "{", + " \"cron\": {", + " \"cron\": {", + " \"expression\": \"* 17 * * SAT\",", + " \"timezone\": \"America/Los_Angeles\"", + " }", + " }", + "}" + ] + ) + documentedCronCondition = + OS1.Types.ISMCondition + { OS1.Types.ismConditionMinSize = Nothing, + OS1.Types.ismConditionMinDocCount = Nothing, + OS1.Types.ismConditionMinIndexAge = Nothing, + OS1.Types.ismConditionMinRolloverAge = Nothing, + OS1.Types.ismConditionCron = + Just + ( OS1.Types.ISMCron + ( OS1.Types.ISMCronCondition + { OS1.Types.ismCronConditionExpression = "* 17 * * SAT", + OS1.Types.ismCronConditionTimezone = Just "America/Los_Angeles" + } + ) + ), + OS1.Types.ismConditionDsl = Nothing + } + + it "decodes the documented nested-object cron shape" $ do + let Just (c :: OS1.Types.ISMCondition) = decode documentedCronBody + c `shouldBe` documentedCronCondition + + it "round-trips the documented cron condition through encode -> decode" $ do + let encoded = encode documentedCronCondition + decode encoded `shouldBe` Just documentedCronCondition + + it "omits the timezone key when timezone is Nothing" $ do + let withoutTz = + OS1.Types.ISMCondition + { OS1.Types.ismConditionMinSize = Nothing, + OS1.Types.ismConditionMinDocCount = Nothing, + OS1.Types.ismConditionMinIndexAge = Nothing, + OS1.Types.ismConditionMinRolloverAge = Nothing, + OS1.Types.ismConditionCron = + Just + ( OS1.Types.ISMCron + ( OS1.Types.ISMCronCondition + { OS1.Types.ismCronConditionExpression = "* 0 * * SUN", + OS1.Types.ismCronConditionTimezone = Nothing + } + ) + ), + OS1.Types.ismConditionDsl = Nothing + } + let Just (parsed :: Value) = decode (encode withoutTz) + case parsed of + Object o -> do + -- The outer wrapper ("cron") and the inner "expression" must be + -- present, but "timezone" must be omitted by omitNulls. + case KM.lookup "cron" o of + Just (Object cronOuter) -> + case KM.lookup "cron" cronOuter of + Just (Object cronInner) -> do + KM.lookup "expression" cronInner `shouldBe` Just (String "* 0 * * SUN") + KM.lookup "timezone" cronInner `shouldBe` Nothing + other -> expectationFailure ("Expected inner cron Object, got " <> show other) + other -> expectationFailure ("Expected outer cron Object, got " <> show other) + other -> expectationFailure ("Expected top-level Object, got " <> show other) + + it "decodes a cron condition without a timezone field" $ do + let body = + LBS.pack + ( unlines + [ "{", + " \"cron\": {", + " \"cron\": {", + " \"expression\": \"* 0 * * SUN\"", + " }", + " }", + "}" + ] + ) + let Just (c :: OS1.Types.ISMCondition) = decode body + case OS1.Types.ismConditionCron c of + Just (OS1.Types.ISMCron (OS1.Types.ISMCronCondition {OS1.Types.ismCronConditionTimezone = tz})) -> + tz `shouldBe` Nothing + other -> + expectationFailure ("Expected Just ISMCron, got " <> show other) + + it "rejects the legacy bare-string cron shape (the pre-fix wire contract)" $ do + -- Before the fix, ismConditionCron was `Maybe Text` and parsed a bare + -- cron expression string. The documented shape is the nested object + -- exercised above; a bare string must now fail to decode so silently + -- accepting the wrong wire shape can never regress. + let legacyBody = LBS.pack "{\"cron\": \"* 17 * * SAT\"}" + let result = parseEither parseJSON =<< eitherDecode legacyBody :: Either String OS1.Types.ISMCondition + result `shouldSatisfy` isLeft + + it "rejects a cron object missing the inner expression field" $ do + let body = + LBS.pack + ( unlines + [ "{", + " \"cron\": {", + " \"cron\": {", + " \"timezone\": \"America/Los_Angeles\"", + " }", + " }", + "}" + ] + ) + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS1.Types.ISMCondition + result `shouldSatisfy` isLeft + + -- ======================================================================== + -- Direct tests for the notification/error_notification sub-shapes that the + -- round-trip-only coverage above leaves implicit. These pin the wire shape + -- for the destination sum type and its escape hatch. + -- ======================================================================== + + describe "ISM typed schema: ISMErrorNotificationDestination" $ do + it "encodes Slack destination as {\"slack\":{...}}" $ do + let d = + OS1.Types.ISMErrorNotificationDestinationSlack + (Just (object ["message" .= String "fire!"])) + encode d `shouldBe` encode (object ["slack" .= object ["message" .= String "fire!"]]) + + it "encodes Chime destination as {\"chime\":{...}}" $ do + let d = OS1.Types.ISMErrorNotificationDestinationChime Nothing + encode d `shouldBe` encode (object ["chime" .= object []]) + + it "encodes CustomWebhook destination as {\"custom_webhook\":{...}}" $ do + let d = OS1.Types.ISMErrorNotificationDestinationCustomWebhook Nothing + encode d `shouldBe` encode (object ["custom_webhook" .= object []]) + + it "decodes {\"slack\":{...}} into Slack destination" $ do + let body = LBS.pack "{\"slack\":{\"message\":\"fire!\"}}" + let Just (d :: OS1.Types.ISMErrorNotificationDestination) = decode body + case d of + OS1.Types.ISMErrorNotificationDestinationSlack _ -> pure () + other -> expectationFailure ("Expected Slack, got " <> show other) + + it "decodes an unknown destination kind into Custom (lossless)" $ do + let body = LBS.pack "{\"future_destination\":{\"url\":\"http://x\"}}" + let Just (d :: OS1.Types.ISMErrorNotificationDestination) = decode body + case d of + OS1.Types.ISMErrorNotificationDestinationCustom tag _ -> + tag `shouldBe` "future_destination" + other -> expectationFailure ("Expected Custom, got " <> show other) + + it "round-trips an unknown destination through Custom" $ do + let body = LBS.pack "{\"future_destination\":{\"url\":\"http://x\"}}" + let Just (d :: OS1.Types.ISMErrorNotificationDestination) = decode body + decode (encode d) `shouldBe` Just d + + it "rejects an empty destination object" $ do + let body = LBS.pack "{}" + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS1.Types.ISMErrorNotificationDestination + result `shouldSatisfy` isLeft + + describe "ISM typed schema (OS2): ISMErrorNotificationDestination" $ do + it "OS2 encodes Slack destination as {\"slack\":{...}}" $ do + let d = + OS2.Types.ISMErrorNotificationDestinationSlack + (Just (object ["message" .= String "fire!"])) + encode d `shouldBe` encode (object ["slack" .= object ["message" .= String "fire!"]]) + + it "OS2 encodes Chime destination as {\"chime\":{...}}" $ do + let d = OS2.Types.ISMErrorNotificationDestinationChime Nothing + encode d `shouldBe` encode (object ["chime" .= object []]) + + it "OS2 encodes CustomWebhook destination as {\"custom_webhook\":{...}}" $ do + let d = OS2.Types.ISMErrorNotificationDestinationCustomWebhook Nothing + encode d `shouldBe` encode (object ["custom_webhook" .= object []]) + + it "OS2 decodes {\"slack\":{...}} into Slack destination" $ do + let body = LBS.pack "{\"slack\":{\"message\":\"fire!\"}}" + let Just (d :: OS2.Types.ISMErrorNotificationDestination) = decode body + case d of + OS2.Types.ISMErrorNotificationDestinationSlack _ -> pure () + other -> expectationFailure ("Expected Slack, got " <> show other) + + it "OS2 decodes an unknown destination kind into Custom (lossless)" $ do + let body = LBS.pack "{\"future_destination\":{\"url\":\"http://x\"}}" + let Just (d :: OS2.Types.ISMErrorNotificationDestination) = decode body + case d of + OS2.Types.ISMErrorNotificationDestinationCustom tag _ -> + tag `shouldBe` "future_destination" + other -> expectationFailure ("Expected Custom, got " <> show other) + + it "OS2 round-trips an unknown destination through Custom" $ do + let body = LBS.pack "{\"future_destination\":{\"url\":\"http://x\"}}" + let Just (d :: OS2.Types.ISMErrorNotificationDestination) = decode body + decode (encode d) `shouldBe` Just d + + it "OS2 rejects an empty destination object" $ do + let body = LBS.pack "{}" + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS2.Types.ISMErrorNotificationDestination + result `shouldSatisfy` isLeft + + it "OS2 destinationTag yields the wire name for every destination kind" $ do + OS2.Types.destinationTag (OS2.Types.ISMErrorNotificationDestinationChime Nothing) + `shouldBe` "chime" + OS2.Types.destinationTag (OS2.Types.ISMErrorNotificationDestinationCustomWebhook Nothing) + `shouldBe` "custom_webhook" + OS2.Types.destinationTag (OS2.Types.ISMErrorNotificationDestinationSlack Nothing) + `shouldBe` "slack" + OS2.Types.destinationTag (OS2.Types.ISMErrorNotificationDestinationCustom "future_destination" Nothing) + `shouldBe` "future_destination" + + it "OS2 destinationConfig extracts the carried config payload" $ do + let cfg = Just (object ["message" .= String "fire!"]) + OS2.Types.destinationConfig (OS2.Types.ISMErrorNotificationDestinationSlack cfg) + `shouldBe` cfg + OS2.Types.destinationConfig (OS2.Types.ISMErrorNotificationDestinationChime Nothing) + `shouldBe` Nothing + + describe "ISM typed schema (OS3): ISMErrorNotificationDestination" $ do + it "OS3 encodes Slack destination as {\"slack\":{...}}" $ do + let d = + OS3.Types.ISMErrorNotificationDestinationSlack + (Just (object ["message" .= String "fire!"])) + encode d `shouldBe` encode (object ["slack" .= object ["message" .= String "fire!"]]) + + it "OS3 encodes Chime destination as {\"chime\":{...}}" $ do + let d = OS3.Types.ISMErrorNotificationDestinationChime Nothing + encode d `shouldBe` encode (object ["chime" .= object []]) + + it "OS3 encodes CustomWebhook destination as {\"custom_webhook\":{...}}" $ do + let d = OS3.Types.ISMErrorNotificationDestinationCustomWebhook Nothing + encode d `shouldBe` encode (object ["custom_webhook" .= object []]) + + it "OS3 decodes {\"slack\":{...}} into Slack destination" $ do + let body = LBS.pack "{\"slack\":{\"message\":\"fire!\"}}" + let Just (d :: OS3.Types.ISMErrorNotificationDestination) = decode body + case d of + OS3.Types.ISMErrorNotificationDestinationSlack _ -> pure () + other -> expectationFailure ("Expected Slack, got " <> show other) + + it "OS3 decodes an unknown destination kind into Custom (lossless)" $ do + let body = LBS.pack "{\"future_destination\":{\"url\":\"http://x\"}}" + let Just (d :: OS3.Types.ISMErrorNotificationDestination) = decode body + case d of + OS3.Types.ISMErrorNotificationDestinationCustom tag _ -> + tag `shouldBe` "future_destination" + other -> expectationFailure ("Expected Custom, got " <> show other) + + it "OS3 round-trips an unknown destination through Custom" $ do + let body = LBS.pack "{\"future_destination\":{\"url\":\"http://x\"}}" + let Just (d :: OS3.Types.ISMErrorNotificationDestination) = decode body + decode (encode d) `shouldBe` Just d + + it "OS3 rejects an empty destination object" $ do + let body = LBS.pack "{}" + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS3.Types.ISMErrorNotificationDestination + result `shouldSatisfy` isLeft + + it "OS3 destinationTag yields the wire name for every destination kind" $ do + OS3.Types.destinationTag (OS3.Types.ISMErrorNotificationDestinationChime Nothing) + `shouldBe` "chime" + OS3.Types.destinationTag (OS3.Types.ISMErrorNotificationDestinationCustomWebhook Nothing) + `shouldBe` "custom_webhook" + OS3.Types.destinationTag (OS3.Types.ISMErrorNotificationDestinationSlack Nothing) + `shouldBe` "slack" + OS3.Types.destinationTag (OS3.Types.ISMErrorNotificationDestinationCustom "future_destination" Nothing) + `shouldBe` "future_destination" + + it "OS3 destinationConfig extracts the carried config payload" $ do + let cfg = Just (object ["message" .= String "fire!"]) + OS3.Types.destinationConfig (OS3.Types.ISMErrorNotificationDestinationSlack cfg) + `shouldBe` cfg + OS3.Types.destinationConfig (OS3.Types.ISMErrorNotificationDestinationChime Nothing) + `shouldBe` Nothing + + describe "ISM typed schema: ISMMessageTemplate" $ do + it "round-trips a {source: ...} template (lang defaults to Nothing)" $ do + let t = + OS1.Types.ISMMessageTemplate + { OS1.Types.ismMessageTemplateSource = "policy failed: ", + OS1.Types.ismMessageTemplateLang = Nothing + } + decode (encode t) `shouldBe` Just t + + it "encodes as {\"source\":\"...\"} with no lang key when lang is Nothing" $ do + let t = + OS1.Types.ISMMessageTemplate + { OS1.Types.ismMessageTemplateSource = "boom", + OS1.Types.ismMessageTemplateLang = Nothing + } + encode t `shouldBe` encode (object ["source" .= String "boom"]) + + it "round-trips a template carrying a server-injected lang" $ do + let t = + OS1.Types.ISMMessageTemplate + { OS1.Types.ismMessageTemplateSource = "boom", + OS1.Types.ismMessageTemplateLang = Just "mustache" + } + decode (encode t) `shouldBe` Just t + + it "encodes lang when present" $ do + let t = + OS1.Types.ISMMessageTemplate + { OS1.Types.ismMessageTemplateSource = "boom", + OS1.Types.ismMessageTemplateLang = Just "mustache" + } + encode t + `shouldBe` encode (object ["source" .= String "boom", "lang" .= String "mustache"]) + + it "decodes a server object that omits lang" $ do + let body = LBS.pack "{\"source\":\"hi\"}" + decode body + `shouldBe` Just + ( OS1.Types.ISMMessageTemplate + { OS1.Types.ismMessageTemplateSource = "hi", + OS1.Types.ismMessageTemplateLang = Nothing + } + ) + + it "decodes a server object that includes lang" $ do + let body = LBS.pack "{\"source\":\"hi\",\"lang\":\"mustache\"}" + decode body + `shouldBe` Just + ( OS1.Types.ISMMessageTemplate + { OS1.Types.ismMessageTemplateSource = "hi", + OS1.Types.ismMessageTemplateLang = Just "mustache" + } + ) + + describe "ISM typed schema: ISMErrorNotification" $ do + it "round-trips a destination-based error_notification block" $ do + let n = + OS1.Types.ISMErrorNotification + { OS1.Types.ismErrorNotificationDestination = + Just (OS1.Types.ISMErrorNotificationDestinationSlack (Just (object ["message" .= String "fire!"]))), + OS1.Types.ismErrorNotificationChannelId = Nothing, + OS1.Types.ismErrorNotificationMessageTemplate = + OS1.Types.ISMMessageTemplate {OS1.Types.ismMessageTemplateSource = "policy failed: ", OS1.Types.ismMessageTemplateLang = Nothing} + } + decode (encode n) `shouldBe` Just n + + it "encodes a destination-based block with no channel key" $ do + let n = + OS1.Types.ISMErrorNotification + { OS1.Types.ismErrorNotificationDestination = + Just (OS1.Types.ISMErrorNotificationDestinationSlack (Just (object ["message" .= String "fire!"]))), + OS1.Types.ismErrorNotificationChannelId = Nothing, + OS1.Types.ismErrorNotificationMessageTemplate = + OS1.Types.ISMMessageTemplate {OS1.Types.ismMessageTemplateSource = "policy failed: ", OS1.Types.ismMessageTemplateLang = Nothing} + } + encode n + `shouldBe` encode + ( object + [ "destination" .= object ["slack" .= object ["message" .= String "fire!"]], + "message_template" .= object ["source" .= String "policy failed: "] + ] + ) + + it "parses the documented Example 4 (channel-based) notification" $ do + let body = + LBS.pack + "{\"channel\":{\"id\":\"some-channel-config-id\"},\"message_template\":{\"source\":\"The index {{ctx.index}} failed.\"}}" + let Just (n :: OS1.Types.ISMErrorNotification) = decode body + OS1.Types.ismErrorNotificationChannelId n `shouldBe` Just "some-channel-config-id" + OS1.Types.ismErrorNotificationDestination n `shouldBe` Nothing + + it "round-trips a channel-based error_notification block" $ do + let n = + OS1.Types.ISMErrorNotification + { OS1.Types.ismErrorNotificationDestination = Nothing, + OS1.Types.ismErrorNotificationChannelId = Just "some-channel-config-id", + OS1.Types.ismErrorNotificationMessageTemplate = + OS1.Types.ISMMessageTemplate {OS1.Types.ismMessageTemplateSource = "The index {{ctx.index}} failed.", OS1.Types.ismMessageTemplateLang = Nothing} + } + decode (encode n) `shouldBe` Just n + + it "encodes a channel-based block with no destination key" $ do + let n = + OS1.Types.ISMErrorNotification + { OS1.Types.ismErrorNotificationDestination = Nothing, + OS1.Types.ismErrorNotificationChannelId = Just "some-channel-config-id", + OS1.Types.ismErrorNotificationMessageTemplate = + OS1.Types.ISMMessageTemplate {OS1.Types.ismMessageTemplateSource = "boom", OS1.Types.ismMessageTemplateLang = Nothing} + } + encode n + `shouldBe` encode + ( object + [ "channel" .= object ["id" .= String "some-channel-config-id"], + "message_template" .= object ["source" .= String "boom"] + ] + ) + + it "rejects an error_notification missing both destination and channel" $ do + let body = LBS.pack "{\"message_template\":{\"source\":\"s\"}}" + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS1.Types.ISMErrorNotification + result `shouldSatisfy` isLeft + + it "rejects an error_notification specifying both destination and channel" $ do + let body = + LBS.pack + "{\"destination\":{\"slack\":{\"url\":\"http://x\"}},\"channel\":{\"id\":\"c\"},\"message_template\":{\"source\":\"s\"}}" + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS1.Types.ISMErrorNotification + result `shouldSatisfy` isLeft + + it "rejects both keys present even when channel is malformed (empty)" $ do + let body = + LBS.pack + "{\"destination\":{\"slack\":{\"url\":\"http://x\"}},\"channel\":{},\"message_template\":{\"source\":\"s\"}}" + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS1.Types.ISMErrorNotification + result `shouldSatisfy` isLeft + + it "rejects a channel object missing its id" $ do + let body = LBS.pack "{\"channel\":{},\"message_template\":{\"source\":\"s\"}}" + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS1.Types.ISMErrorNotification + result `shouldSatisfy` isLeft + + describe "ISM typed schema: ISMUserVariables" $ do + it "round-trips a populated user_vars map" $ do + let v = OS1.Types.ISMUserVariables (Map.fromList [("role", "hot"), ("ttl", "7d")]) + decode (encode v) `shouldBe` Just v + + it "encodes as a JSON object of key→string" $ do + let v = OS1.Types.ISMUserVariables (Map.fromList [("role", "hot")]) + encode v `shouldBe` encode (object ["role" .= String "hot"]) + + -- ======================================================================== + -- Pure unit tests for ISMExplainOptions rendering. The explain endpoint + -- (GET /_plugins/_ism/explain/{index}) documents four query parameters; + -- these tests pin the wire shape produced by ismExplainOptionsParams so a + -- regression that drops or renames one cannot pass silently. Only OS1 is + -- exercised because the OS2/OS3 ISM modules are byte-identical mirrors + -- (the build verifies them). + -- ======================================================================== + + describe "ISM ISMExplainOptions rendering" $ do + it "defaultISMExplainOptions produces no query string" $ do + OS1.Types.ismExplainOptionsParams OS1.Types.defaultISMExplainOptions + `shouldBe` [] + + it "renders show_policy=True alone" $ do + let opts = + OS1.Types.defaultISMExplainOptions + { OS1.Types.ismExplainOptionsShowPolicy = True + } + OS1.Types.ismExplainOptionsParams opts + `shouldBe` [("show_policy", Just "true")] + + it "renders validate_action=True alone" $ do + let opts = + OS1.Types.defaultISMExplainOptions + { OS1.Types.ismExplainOptionsValidateAction = True + } + OS1.Types.ismExplainOptionsParams opts + `shouldBe` [("validate_action", Just "true")] + + it "omits show_policy and validate_action when False" $ do + let opts = + OS1.Types.defaultISMExplainOptions + { OS1.Types.ismExplainOptionsShowPolicy = False, + OS1.Types.ismExplainOptionsValidateAction = False + } + OS1.Types.ismExplainOptionsParams opts `shouldBe` [] + + it "renders local=Just True as \"true\"" $ do + let opts = + OS1.Types.defaultISMExplainOptions + { OS1.Types.ismExplainOptionsLocal = Just True + } + OS1.Types.ismExplainOptionsParams opts + `shouldBe` [("local", Just "true")] + + it "renders local=Just False as \"false\"" $ do + let opts = + OS1.Types.defaultISMExplainOptions + { OS1.Types.ismExplainOptionsLocal = Just False + } + OS1.Types.ismExplainOptionsParams opts + `shouldBe` [("local", Just "false")] + + it "renders expand_wildcards as a comma-separated list" $ do + let opts = + OS1.Types.defaultISMExplainOptions + { OS1.Types.ismExplainOptionsExpandWildcards = + Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + OS1.Types.ismExplainOptionsParams opts + `shouldBe` [("expand_wildcards", Just "open,closed")] + + it "renders a single-element expand_wildcards without trailing comma" $ do + let opts = + OS1.Types.defaultISMExplainOptions + { OS1.Types.ismExplainOptionsExpandWildcards = + Just (ExpandWildcardsAll :| []) + } + OS1.Types.ismExplainOptionsParams opts + `shouldBe` [("expand_wildcards", Just "all")] + + it "renders all four parameters set at once (order-insensitive)" $ do + let opts = + OS1.Types.defaultISMExplainOptions + { OS1.Types.ismExplainOptionsShowPolicy = True, + OS1.Types.ismExplainOptionsValidateAction = True, + OS1.Types.ismExplainOptionsLocal = Just False, + OS1.Types.ismExplainOptionsExpandWildcards = + Just (ExpandWildcardsOpen :| [ExpandWildcardsHidden]) + } + sort (OS1.Types.ismExplainOptionsParams opts) + `shouldBe` sort + [ ("show_policy", Just "true"), + ("validate_action", Just "true"), + ("local", Just "false"), + ("expand_wildcards", Just "open,hidden") + ] + + describe "ISM PutISMPolicy API" $ do + -- OpenSearch's PUT /_plugins/_ism/policies/{id} returns 409 if the policy + -- already exists unless ?if_seq_no=&if_primary_term= are provided, so each + -- invocation uses a unique policy id to keep the test idempotent. + os1It <- runIO os1OnlyIT + os1It "creates and updates an ISM policy (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS1.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os1_" <> suffix + resp <- OS1.Client.putISMPolicy policyId os1SamplePolicy + _ <- OS1.Client.deleteISMPolicy policyId + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> OS1.Types.putISMPolicyResponseId r `shouldBe` OS1.Types.unPolicyId policyId + + os2It <- runIO os2OnlyIT + os2It "creates and updates an ISM policy (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS2.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os2_" <> suffix + resp <- OS2.Client.putISMPolicy policyId os2SamplePolicy + _ <- OS2.Client.deleteISMPolicy policyId + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> OS2.Types.putISMPolicyResponseId r `shouldBe` OS2.Types.unPolicyId policyId + + os3It <- runIO os3OnlyIT + os3It "creates and updates an ISM policy (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS3.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os3_" <> suffix + resp <- OS3.Client.putISMPolicy policyId os3SamplePolicy + _ <- OS3.Client.deleteISMPolicy policyId + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> OS3.Types.putISMPolicyResponseId r `shouldBe` OS3.Types.unPolicyId policyId + + describe "ISM PutISMPolicyWith (optimistic concurrency)" $ do + -- Each test PUTs a fresh policy via 'putISMPolicy', reads the returned + -- (_seq_no, _primary_term), then re-PUTs via 'putISMPolicyWith' to verify + -- the if_seq_no / if_primary_term query params reach OpenSearch and are + -- enforced: a stale pair yields HTTP 409 (Left EsError), the current + -- pair succeeds (Right). Unique policy ids keep each test idempotent. + os1It <- runIO os1OnlyIT + os1It "rejects a stale (seqNo, primaryTerm) with 409 (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS1.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os1_occ_stale_" <> suffix + firstResp <- OS1.Client.putISMPolicy policyId os1SamplePolicy + mOcc <- liftIO $ case firstResp of + Left e -> do + expectationFailure ("Setup PUT failed: " <> show e) + pure Nothing + Right r -> + pure $ + Just + ( fromIntegral (OS1.Types.putISMPolicyResponseSeqNo r) + 1, + fromIntegral (OS1.Types.putISMPolicyResponsePrimaryTerm r) + ) + case mOcc of + Nothing -> pure () + Just stale -> do + staleResp <- OS1.Client.putISMPolicyWith policyId os1SamplePolicy (Just stale) + liftIO $ staleResp `shouldSatisfy` isLeft + + os1It "accepts the current (seqNo, primaryTerm) (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS1.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os1_occ_fresh_" <> suffix + firstResp <- OS1.Client.putISMPolicy policyId os1SamplePolicy + mOcc <- liftIO $ case firstResp of + Left e -> do + expectationFailure ("Setup PUT failed: " <> show e) + pure Nothing + Right r -> + pure $ + Just + ( fromIntegral (OS1.Types.putISMPolicyResponseSeqNo r), + fromIntegral (OS1.Types.putISMPolicyResponsePrimaryTerm r) + ) + case mOcc of + Nothing -> pure () + Just fresh -> do + freshResp <- OS1.Client.putISMPolicyWith policyId os1SamplePolicy (Just fresh) + liftIO $ + case freshResp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r' -> OS1.Types.putISMPolicyResponseId r' `shouldBe` OS1.Types.unPolicyId policyId + + os2It <- runIO os2OnlyIT + os2It "rejects a stale (seqNo, primaryTerm) with 409 (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS2.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os2_occ_stale_" <> suffix + firstResp <- OS2.Client.putISMPolicy policyId os2SamplePolicy + mOcc <- liftIO $ case firstResp of + Left e -> do + expectationFailure ("Setup PUT failed: " <> show e) + pure Nothing + Right r -> + pure $ + Just + ( fromIntegral (OS2.Types.putISMPolicyResponseSeqNo r) + 1, + fromIntegral (OS2.Types.putISMPolicyResponsePrimaryTerm r) + ) + case mOcc of + Nothing -> pure () + Just stale -> do + staleResp <- OS2.Client.putISMPolicyWith policyId os2SamplePolicy (Just stale) + liftIO $ staleResp `shouldSatisfy` isLeft + + os2It "accepts the current (seqNo, primaryTerm) (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS2.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os2_occ_fresh_" <> suffix + firstResp <- OS2.Client.putISMPolicy policyId os2SamplePolicy + mOcc <- liftIO $ case firstResp of + Left e -> do + expectationFailure ("Setup PUT failed: " <> show e) + pure Nothing + Right r -> + pure $ + Just + ( fromIntegral (OS2.Types.putISMPolicyResponseSeqNo r), + fromIntegral (OS2.Types.putISMPolicyResponsePrimaryTerm r) + ) + case mOcc of + Nothing -> pure () + Just fresh -> do + freshResp <- OS2.Client.putISMPolicyWith policyId os2SamplePolicy (Just fresh) + liftIO $ + case freshResp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r' -> OS2.Types.putISMPolicyResponseId r' `shouldBe` OS2.Types.unPolicyId policyId + + os3It <- runIO os3OnlyIT + os3It "rejects a stale (seqNo, primaryTerm) with 409 (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS3.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os3_occ_stale_" <> suffix + firstResp <- OS3.Client.putISMPolicy policyId os3SamplePolicy + mOcc <- liftIO $ case firstResp of + Left e -> do + expectationFailure ("Setup PUT failed: " <> show e) + pure Nothing + Right r -> + pure $ + Just + ( fromIntegral (OS3.Types.putISMPolicyResponseSeqNo r) + 1, + fromIntegral (OS3.Types.putISMPolicyResponsePrimaryTerm r) + ) + case mOcc of + Nothing -> pure () + Just stale -> do + staleResp <- OS3.Client.putISMPolicyWith policyId os3SamplePolicy (Just stale) + liftIO $ staleResp `shouldSatisfy` isLeft + + os3It "accepts the current (seqNo, primaryTerm) (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS3.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os3_occ_fresh_" <> suffix + firstResp <- OS3.Client.putISMPolicy policyId os3SamplePolicy + mOcc <- liftIO $ case firstResp of + Left e -> do + expectationFailure ("Setup PUT failed: " <> show e) + pure Nothing + Right r -> + pure $ + Just + ( fromIntegral (OS3.Types.putISMPolicyResponseSeqNo r), + fromIntegral (OS3.Types.putISMPolicyResponsePrimaryTerm r) + ) + case mOcc of + Nothing -> pure () + Just fresh -> do + freshResp <- OS3.Client.putISMPolicyWith policyId os3SamplePolicy (Just fresh) + liftIO $ + case freshResp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r' -> OS3.Types.putISMPolicyResponseId r' `shouldBe` OS3.Types.unPolicyId policyId + + describe "ISM DeleteISMPolicy API" $ do + -- PUT a fresh policy, then DELETE it. OpenSearch stores policies as + -- documents in @.opendistro-ism-config@, so DELETE returns the standard + -- document-delete envelope (IndexedDocument) with @result = "deleted"@, + -- not an Acknowledged ack. Each invocation uses a unique policy id to + -- keep the test idempotent (PUT 409s on duplicate ids without + -- ?if_seq_no=&if_primary_term=, and DELETE 404s on unknown ids). + os1It <- runIO os1OnlyIT + os1It "creates then deletes an ISM policy (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS1.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os1_del_" <> suffix + putResp <- OS1.Client.putISMPolicy policyId os1SamplePolicy + liftIO $ + case putResp of + Left e -> expectationFailure ("PUT failed: " <> show e) + Right _ -> pure () + delResp <- OS1.Client.deleteISMPolicy policyId + liftIO $ + case delResp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> do + idxDocResult r `shouldBe` "deleted" + idxDocId r `shouldBe` OS1.Types.unPolicyId policyId + + os2It <- runIO os2OnlyIT + os2It "creates then deletes an ISM policy (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS2.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os2_del_" <> suffix + putResp <- OS2.Client.putISMPolicy policyId os2SamplePolicy + liftIO $ + case putResp of + Left e -> expectationFailure ("PUT failed: " <> show e) + Right _ -> pure () + delResp <- OS2.Client.deleteISMPolicy policyId + liftIO $ + case delResp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> do + idxDocResult r `shouldBe` "deleted" + idxDocId r `shouldBe` OS2.Types.unPolicyId policyId + + os3It <- runIO os3OnlyIT + os3It "creates then deletes an ISM policy (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS3.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os3_del_" <> suffix + putResp <- OS3.Client.putISMPolicy policyId os3SamplePolicy + liftIO $ + case putResp of + Left e -> expectationFailure ("PUT failed: " <> show e) + Right _ -> pure () + delResp <- OS3.Client.deleteISMPolicy policyId + liftIO $ + case delResp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> do + idxDocResult r `shouldBe` "deleted" + idxDocId r `shouldBe` OS3.Types.unPolicyId policyId + + -- Deleting a non-existent policy yields 404 -> Left EsError whose message + -- mentions the missing policy. We pin the message rather than just `isLeft` + -- so a future regression that surfaces an unrelated Left (network blip, + -- JSON parse bug) does not silently pass. + os1It <- runIO os1OnlyIT + os1It "returns Left when deleting a non-existent ISM policy (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS1.Types.PolicyId $ Text.pack $ "bloodhound_test_policy_os1_missing_" <> suffix + resp <- OS1.Client.deleteISMPolicy policyId + liftIO $ + case resp of + Left e -> + errorMessage e `shouldSatisfy` Text.isInfixOf "not found" + Right _ -> expectationFailure "Expected Left, got Right" + + describe "ISM ISMUpdatedIndicesResponse JSON decoding" $ do + -- Realistic success body for POST /_plugins/_ism/add/{index}: + -- {"updated_indices": N, "failures": false, "failed_indices": []} + -- See https://docs.opensearch.org/latest/im-plugin/ism/api/#add-policy + let successBody = + LBS.pack + "{ \"updated_indices\": 1, \"failures\": false, \"failed_indices\": [] }" + + it "decodes OpenSearch1 success body" $ do + let decoded = decode successBody :: Maybe OS1.Types.ISMUpdatedIndicesResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1.Types.ismUpdatedIndicesResponseUpdatedIndices r `shouldBe` 1 + OS1.Types.ismUpdatedIndicesResponseFailures r `shouldBe` False + OS1.Types.ismUpdatedIndicesResponseFailedIndices r `shouldBe` [] + + it "decodes OpenSearch2 success body" $ do + let decoded = decode successBody :: Maybe OS2.Types.ISMUpdatedIndicesResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS2.Types.ismUpdatedIndicesResponseUpdatedIndices r `shouldBe` 1 + OS2.Types.ismUpdatedIndicesResponseFailures r `shouldBe` False + + it "decodes OpenSearch3 success body" $ do + let decoded = decode successBody :: Maybe OS3.Types.ISMUpdatedIndicesResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS3.Types.ismUpdatedIndicesResponseUpdatedIndices r `shouldBe` 1 + OS3.Types.ismUpdatedIndicesResponseFailures r `shouldBe` False + + it "decodes a body without failed_indices as empty list" $ do + let body = + LBS.pack + "{ \"updated_indices\": 0, \"failures\": false }" + let decoded = decode body :: Maybe OS1.Types.ISMUpdatedIndicesResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1.Types.ismUpdatedIndicesResponseFailedIndices r `shouldBe` [] + + it "decodes a failure body with one failed index" $ do + let body = + LBS.pack $ + unlines + [ "{", + " \"updated_indices\": 0,", + " \"failures\": true,", + " \"failed_indices\": [", + " {", + " \"index_name\": \"missing-index\",", + " \"index_uuid\": null,", + " \"reason\": \"index missing\"", + " }", + " ]", + "}" + ] + let decoded = decode body :: Maybe OS1.Types.ISMUpdatedIndicesResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1.Types.ismUpdatedIndicesResponseFailures r `shouldBe` True + OS1.Types.ismUpdatedIndicesResponseFailedIndices r `shouldSatisfy` (not . null) + let firstFailure = head (OS1.Types.ismUpdatedIndicesResponseFailedIndices r) + OS1.Types.ismFailedIndexName firstFailure `shouldBe` "missing-index" + OS1.Types.ismFailedIndexUuid firstFailure `shouldBe` Nothing + OS1.Types.ismFailedIndexReason firstFailure `shouldBe` "index missing" + + it "rejects a body with non-boolean failures" $ do + let malformed = + LBS.pack + "{ \"updated_indices\": 0, \"failures\": \"yes\", \"failed_indices\": [] }" + let result = parseEither parseJSON =<< eitherDecode malformed :: Either String OS1.Types.ISMUpdatedIndicesResponse + result `shouldSatisfy` isLeft + + it "round-trips OpenSearch1 decode -> encode -> decode" $ do + let Just (r1 :: OS1.Types.ISMUpdatedIndicesResponse) = + decode + ( LBS.pack + "{ \"updated_indices\": 2, \"failures\": false, \"failed_indices\": [] }" + ) + let reencoded = encode r1 + let decodedAgain = decode reencoded :: Maybe OS1.Types.ISMUpdatedIndicesResponse + decodedAgain `shouldBe` Just r1 + + it "round-trips a populated failed_indices list through encode -> decode" $ do + -- Exercises the ToJSON/FromJSON of ISMFailedIndex (including the + -- Nothing index_uuid path) that the empty-list round-trip above + -- does not touch. + let body = + LBS.pack $ + unlines + [ "{", + " \"updated_indices\": 0,", + " \"failures\": true,", + " \"failed_indices\": [", + " {", + " \"index_name\": \"foo\",", + " \"index_uuid\": null,", + " \"reason\": \"already managed\"", + " }", + " ]", + "}" + ] + let Just (r1 :: OS1.Types.ISMUpdatedIndicesResponse) = decode body + let reencoded = encode r1 + let Just r2 = decode reencoded :: Maybe OS1.Types.ISMUpdatedIndicesResponse + r2 `shouldBe` r1 + OS1.Types.ismFailedIndexUuid (head (OS1.Types.ismUpdatedIndicesResponseFailedIndices r2)) `shouldBe` Nothing + + describe "ISM AddISMPolicy API" $ do + -- POST /_plugins/_ism/add/{index} attaches an existing policy to a fresh + -- index. We PUT a unique policy, create a unique index, then call + -- addISMPolicy and assert updated_indices >= 1 with no failures. Cleanup + -- deletes the index; the policy is left in place (PUT 409s on duplicate ids + -- and DELETE 404s on missing ids, so unique names keep the test + -- idempotent, matching the existing Put/Delete ISM policy tests above). + os1It <- runIO os1OnlyIT + os1It "adds an ISM policy to an index (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS1.Types.PolicyId $ Text.pack $ "bloodhound_test_add_policy_os1_" <> suffix + let Right indexName = mkIndexName $ Text.pack $ "bloodhound_test_add_index_os1_" <> suffix + _ <- OS1.Client.putISMPolicy policyId os1SamplePolicy + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) indexName + resp <- OS1.Client.addISMPolicy policyId indexName + _ <- performBHRequest $ deleteIndex indexName + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> do + OS1.Types.ismUpdatedIndicesResponseUpdatedIndices r `shouldSatisfy` (>= 1) + OS1.Types.ismUpdatedIndicesResponseFailures r `shouldBe` False + OS1.Types.ismUpdatedIndicesResponseFailedIndices r `shouldBe` [] + + os2It <- runIO os2OnlyIT + os2It "adds an ISM policy to an index (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS2.Types.PolicyId $ Text.pack $ "bloodhound_test_add_policy_os2_" <> suffix + let Right indexName = mkIndexName $ Text.pack $ "bloodhound_test_add_index_os2_" <> suffix + _ <- OS2.Client.putISMPolicy policyId os2SamplePolicy + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) indexName + resp <- OS2.Client.addISMPolicy policyId indexName + _ <- performBHRequest $ deleteIndex indexName + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> do + OS2.Types.ismUpdatedIndicesResponseUpdatedIndices r `shouldSatisfy` (>= 1) + OS2.Types.ismUpdatedIndicesResponseFailures r `shouldBe` False + OS2.Types.ismUpdatedIndicesResponseFailedIndices r `shouldBe` [] + + os3It <- runIO os3OnlyIT + os3It "adds an ISM policy to an index (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS3.Types.PolicyId $ Text.pack $ "bloodhound_test_add_policy_os3_" <> suffix + let Right indexName = mkIndexName $ Text.pack $ "bloodhound_test_add_index_os3_" <> suffix + _ <- OS3.Client.putISMPolicy policyId os3SamplePolicy + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) indexName + resp <- OS3.Client.addISMPolicy policyId indexName + _ <- performBHRequest $ deleteIndex indexName + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> do + OS3.Types.ismUpdatedIndicesResponseUpdatedIndices r `shouldSatisfy` (>= 1) + OS3.Types.ismUpdatedIndicesResponseFailures r `shouldBe` False + OS3.Types.ismUpdatedIndicesResponseFailedIndices r `shouldBe` [] + + -- Adding a non-existent policy to an index yields 404 with an EsError + -- message mentioning the missing policy, rather than a 200 with + -- failures=true. We pin the message rather than just `isLeft` so a future + -- regression that surfaces an unrelated Left (network blip, JSON parse + -- bug) does not silently pass. + os1It <- runIO os1OnlyIT + os1It "returns Left when adding a non-existent ISM policy (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS1.Types.PolicyId $ Text.pack $ "bloodhound_test_add_missing_os1_" <> suffix + let Right indexName = mkIndexName $ Text.pack $ "bloodhound_test_add_missing_idx_os1_" <> suffix + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) indexName + resp <- OS1.Client.addISMPolicy policyId indexName + _ <- performBHRequest $ deleteIndex indexName + liftIO $ + case resp of + Left e -> + errorMessage e `shouldSatisfy` Text.isInfixOf "policy" + Right _ -> expectationFailure "Expected Left, got Right" + + -- ==================================================================== + -- New endpoint types: ChangePolicyRequest, ISMExplanation, ISMPolicyInfo, + -- GetISMPoliciesResponse, ISMPoliciesQuery. Pure JSON tests first, then + -- live integration per backend. The pure tests exercise OS1.Types only + -- because the OS2/OS3 ISM modules are byte-identical mirrors (verified by + -- the build); the live tests cover all three backends. + -- ==================================================================== + + describe "ISM ChangePolicyRequest JSON" $ do + let body = + LBS.pack + "{\"policy_id\":\"p1\",\"state\":\"delete\",\"include\":[{\"state\":\"search\"}]}" + parsed = decode body :: Maybe OS1.Types.ChangePolicyRequest + expectedReq = + OS1.Types.ChangePolicyRequest + { OS1.Types.changePolicyRequestId = OS1.Types.PolicyId "p1", + OS1.Types.changePolicyRequestState = Just "delete", + OS1.Types.changePolicyRequestInclude = + [OS1.Types.ISMChangePolicyInclude "search"] + } + it "decodes policy_id, state and include" $ + parsed `shouldBe` Just expectedReq + it "round-trips decode -> encode -> decode" $ do + let Just r = parsed + decode (encode r) `shouldBe` Just r + it "omits Nothing state and empty include on encode" $ do + let r = + OS1.Types.ChangePolicyRequest + { OS1.Types.changePolicyRequestId = OS1.Types.PolicyId "p1", + OS1.Types.changePolicyRequestState = Nothing, + OS1.Types.changePolicyRequestInclude = [] + } + encode r `shouldBe` encode (object ["policy_id" .= String "p1"]) + + describe "ISM ISMExplanation JSON" $ do + -- Minimal unmanaged body: just the dotted policy_id setting, no + -- managed-index fields, no total_managed_indices. + let unmanaged = + LBS.pack + "{\"index_1\":{\"index.plugins.index_state_management.policy_id\":\"policy_1\"}}" + it "decodes the minimal unmanaged body, keeping the policy_id setting" $ do + let Just (e :: OS1.Types.ISMExplanation) = decode unmanaged + OS1.Types.ismExplanationTotalManagedIndices e `shouldBe` Nothing + let entry = lookup "index_1" (Map.toList (OS1.Types.ismExplanationEntries e)) + entry `shouldSatisfy` isJust + let Just ent = entry + OS1.Types.ismExplanationEntryPolicyIdSetting ent `shouldBe` Just "policy_1" + OS1.Types.ismExplanationEntryIndex ent `shouldBe` Nothing + + -- Full managed body (representative slice of the documented response). + let managed = + LBS.pack $ + unlines + [ "{", + " \"index_1\": {", + " \"index\": \"index_1\",", + " \"index_uuid\": \"abc\",", + " \"policy_id\": \"policy_1\",", + " \"enabled\": true,", + " \"state\": {\"name\":\"hot\",\"start_time\":123},", + " \"action\": {\"name\":\"rollover\",\"start_time\":123,\"index\":0,\"failed\":false,\"consumed_retries\":0,\"last_retry_time\":0},", + " \"step\": {\"name\":\"attempt_rollover\",\"start_time\":123,\"step_status\":\"starting\"},", + " \"retry_info\": {\"failed\":false,\"consumed_retries\":0},", + " \"info\": {\"message\":\"Currently checking rollover conditions\"}", + " },", + " \"total_managed_indices\": 1", + "}" + ] + it "decodes the managed body including nested sub-objects" $ do + let Just (e :: OS1.Types.ISMExplanation) = decode managed + OS1.Types.ismExplanationTotalManagedIndices e `shouldBe` Just 1 + let Just ent = lookup "index_1" (Map.toList (OS1.Types.ismExplanationEntries e)) + OS1.Types.ismExplanationEntryIndex ent `shouldBe` Just "index_1" + OS1.Types.ismExplanationEntryEnabled ent `shouldBe` Just True + OS1.Types.ismExplanationEntryState ent `shouldSatisfy` isJust + OS1.Types.ismExplanationEntryAction ent `shouldSatisfy` isJust + OS1.Types.ismExplanationEntryRetryInfo ent `shouldSatisfy` isJust + + it "decodes the validate_action body (validate sub-object present)" $ do + let body = + LBS.pack $ + unlines + [ "{", + " \"test-000001\": {", + " \"index\": \"test-000001\",", + " \"enabled\": false,", + " \"validate\": {", + " \"validation_message\": \"Missing rollover_alias\",", + " \"validation_status\": \"re_validating\"", + " }", + " },", + " \"total_managed_indices\": 1", + "}" + ] + let Just (e :: OS1.Types.ISMExplanation) = decode body + let Just ent = lookup "test-000001" (Map.toList (OS1.Types.ismExplanationEntries e)) + OS1.Types.ismExplanationEntryValidate ent `shouldSatisfy` isJust + let Just v = OS1.Types.ismExplanationEntryValidate ent + OS1.Types.ismExplanationValidateValidationStatus v `shouldBe` "re_validating" + + it "round-trips decode -> encode -> decode (managed)" $ do + let Just (e :: OS1.Types.ISMExplanation) = decode managed + decode (encode e) `shouldBe` Just e + + it "rejects a body whose entry value is not an object" $ do + let body = LBS.pack "{\"index_1\": 42}" + let result = parseEither parseJSON =<< eitherDecode body :: Either String OS1.Types.ISMExplanation + result `shouldSatisfy` isLeft + + describe "ISM ISMPolicyInfo / GetISMPoliciesResponse JSON" $ do + let singleBody = + LBS.pack + "{\"_id\":\"policy_1\",\"_version\":2,\"_seq_no\":10,\"_primary_term\":1,\"policy\":{\"policy_id\":\"policy_1\"}}" + it "decodes a single-policy body" $ do + let Just (p :: OS1.Types.ISMPolicyInfo) = decode singleBody + OS1.Types.ismPolicyInfoId p `shouldBe` "policy_1" + OS1.Types.ismPolicyInfoSeqNo p `shouldBe` 10 + it "round-trips a single policy" $ do + let Just (p :: OS1.Types.ISMPolicyInfo) = decode singleBody + decode (encode p) `shouldBe` Just p + let listBody = + LBS.pack + "{\"policies\":[{\"_id\":\"policy_1\",\"_version\":2,\"_seq_no\":10,\"_primary_term\":1,\"policy\":{\"policy_id\":\"policy_1\"}}]}" + it "decodes the policies list" $ do + let Just (r :: OS1.Types.GetISMPoliciesResponse) = decode listBody + OS1.Types.getISMPoliciesResponsePolicies r `shouldSatisfy` (not . null) + OS1.Types.ismPolicyInfoId (head (OS1.Types.getISMPoliciesResponsePolicies r)) `shouldBe` "policy_1" + it "round-trips the policies list" $ do + let Just (r :: OS1.Types.GetISMPoliciesResponse) = decode listBody + decode (encode r) `shouldBe` Just r + + describe "ISM ISMPoliciesQuery to pairs" $ do + it "omits all Nothing fields" $ + OS1.Types.ismPoliciesQueryToPairs + (OS1.Types.ISMPoliciesQuery Nothing Nothing Nothing Nothing Nothing) + `shouldBe` [] + it "renders size as text and includes only set fields" $ + OS1.Types.ismPoliciesQueryToPairs + (OS1.Types.ISMPoliciesQuery (Just 5) Nothing (Just "policy_id") Nothing Nothing) + `shouldBe` [("size", Just "5"), ("sortField", Just "policy_id")] + + -- -------------------- Live integration: removeISMPolicy -------------------- + + describe "ISM removeISMPolicy API" $ do + os1It <- runIO os1OnlyIT + os1It "removes an ISM policy from an index (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS1.Types.PolicyId $ Text.pack $ "bloodhound_test_rem_policy_os1_" <> suffix + let Right indexName = mkIndexName $ Text.pack $ "bloodhound_test_rem_index_os1_" <> suffix + _ <- OS1.Client.putISMPolicy policyId os1SamplePolicy + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) indexName + _ <- OS1.Client.addISMPolicy policyId indexName + resp <- OS1.Client.removeISMPolicy indexName + _ <- performBHRequest $ deleteIndex indexName + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> do + OS1.Types.ismUpdatedIndicesResponseUpdatedIndices r `shouldSatisfy` (>= 1) + OS1.Types.ismUpdatedIndicesResponseFailures r `shouldBe` False + + os2It <- runIO os2OnlyIT + os2It "removes an ISM policy from an index (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS2.Types.PolicyId $ Text.pack $ "bloodhound_test_rem_policy_os2_" <> suffix + let Right indexName = mkIndexName $ Text.pack $ "bloodhound_test_rem_index_os2_" <> suffix + _ <- OS2.Client.putISMPolicy policyId os2SamplePolicy + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) indexName + _ <- OS2.Client.addISMPolicy policyId indexName + resp <- OS2.Client.removeISMPolicy indexName + _ <- performBHRequest $ deleteIndex indexName + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> do + OS2.Types.ismUpdatedIndicesResponseUpdatedIndices r `shouldSatisfy` (>= 1) + OS2.Types.ismUpdatedIndicesResponseFailures r `shouldBe` False + + os3It <- runIO os3OnlyIT + os3It "removes an ISM policy from an index (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS3.Types.PolicyId $ Text.pack $ "bloodhound_test_rem_policy_os3_" <> suffix + let Right indexName = mkIndexName $ Text.pack $ "bloodhound_test_rem_index_os3_" <> suffix + _ <- OS3.Client.putISMPolicy policyId os3SamplePolicy + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) indexName + _ <- OS3.Client.addISMPolicy policyId indexName + resp <- OS3.Client.removeISMPolicy indexName + _ <- performBHRequest $ deleteIndex indexName + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> do + OS3.Types.ismUpdatedIndicesResponseUpdatedIndices r `shouldSatisfy` (>= 1) + OS3.Types.ismUpdatedIndicesResponseFailures r `shouldBe` False + + -- -------------------- Pure wire shape: explainISMIndexFiltered -------------------- + + describe "ISM explainISMIndexFiltered API (POST filter body shape)" $ do + let os3Idx = [qqIndexName|my-index-os3|] + os2Idx = [qqIndexName|my-index-os2|] + + it "OS3: POSTs to /_plugins/_ism/explain/{index} with no query string" $ do + let req = OS3Requests.explainISMIndexFiltered os3Idx OS3.Types.defaultISMExplainFilter + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ism", "explain", "my-index-os3"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "OS3: sends a {\"filter\":{...}} body, omitting Nothing fields" $ do + let filt = + OS3.Types.ISMExplainFilter + (Just "hot-warm-delete-policy") + (Just "warm") + Nothing + Nothing + req = OS3Requests.explainISMIndexFiltered os3Idx filt + Just body = bhRequestBody req + decode body + `shouldBe` ( Just $ + object + [ "filter" + .= object + [ "policy_id" .= ("hot-warm-delete-policy" :: Text), + "state" .= ("warm" :: Text) + ] + ] + ) + + it "OS3: defaultISMExplainFilter produces {\"filter\":{}}" $ do + let req = OS3Requests.explainISMIndexFiltered os3Idx OS3.Types.defaultISMExplainFilter + Just body = bhRequestBody req + decode body `shouldBe` (Just $ object ["filter" .= object []]) + + it "OS2: POSTs to /_plugins/_ism/explain/{index} with no query string" $ do + let req = OS2Requests.explainISMIndexFiltered os2Idx OS2.Types.defaultISMExplainFilter + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ism", "explain", "my-index-os2"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "OS2: sends a {\"filter\":{...}} body, omitting Nothing fields" $ do + let filt = + OS2.Types.ISMExplainFilter + (Just "data-lifecycle-policy") + Nothing + (Just "rollover") + (Just True) + req = OS2Requests.explainISMIndexFiltered os2Idx filt + Just body = bhRequestBody req + decode body + `shouldBe` ( Just $ + object + [ "filter" + .= object + [ "policy_id" .= ("data-lifecycle-policy" :: Text), + "action_type" .= ("rollover" :: Text), + "failed" .= True + ] + ] + ) + + it "OS2: defaultISMExplainFilter produces {\"filter\":{}}" $ do + let req = OS2Requests.explainISMIndexFiltered os2Idx OS2.Types.defaultISMExplainFilter + Just body = bhRequestBody req + decode body `shouldBe` (Just $ object ["filter" .= object []]) + + -- -------------------- Live integration: explainISMIndex -------------------- + + describe "ISM explainISMIndex API" $ do + -- explain on a fresh (unmanaged) index is deterministic: the response + -- contains an entry for the index (with the dotted policy_id setting, + -- possibly null). The managed path (show_policy=true) is exercised by + -- the pure JSON tests above since ISM management is asynchronous. + os1It <- runIO os1OnlyIT + os1It "explains an index (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let Right indexName = mkIndexName $ Text.pack $ "bloodhound_test_explain_idx_os1_" <> suffix + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) indexName + resp <- OS1.Client.explainISMIndex indexName + _ <- performBHRequest $ deleteIndex indexName + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right e -> + OS1.Types.ismExplanationEntries e `shouldSatisfy` (not . null) + + os2It <- runIO os2OnlyIT + os2It "explains an index (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let Right indexName = mkIndexName $ Text.pack $ "bloodhound_test_explain_idx_os2_" <> suffix + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) indexName + resp <- OS2.Client.explainISMIndex indexName + _ <- performBHRequest $ deleteIndex indexName + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right e -> + OS2.Types.ismExplanationEntries e `shouldSatisfy` (not . null) + + os3It <- runIO os3OnlyIT + os3It "explains an index (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let Right indexName = mkIndexName $ Text.pack $ "bloodhound_test_explain_idx_os3_" <> suffix + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) indexName + resp <- OS3.Client.explainISMIndex indexName + _ <- performBHRequest $ deleteIndex indexName + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right e -> + OS3.Types.ismExplanationEntries e `shouldSatisfy` (not . null) + + -- -------------------- Live integration: getISMPolicy / getISMPolicies -------- + + describe "ISM getISMPolicy API" $ do + os1It <- runIO os1OnlyIT + os1It "fetches a single policy by id (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS1.Types.PolicyId $ Text.pack $ "bloodhound_test_get_policy_os1_" <> suffix + _ <- OS1.Client.putISMPolicy policyId os1SamplePolicy + resp <- OS1.Client.getISMPolicy policyId + _ <- OS1.Client.deleteISMPolicy policyId + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> + OS1.Types.ismPolicyInfoId r `shouldBe` OS1.Types.unPolicyId policyId + + os2It <- runIO os2OnlyIT + os2It "fetches a single policy by id (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS2.Types.PolicyId $ Text.pack $ "bloodhound_test_get_policy_os2_" <> suffix + _ <- OS2.Client.putISMPolicy policyId os2SamplePolicy + resp <- OS2.Client.getISMPolicy policyId + _ <- OS2.Client.deleteISMPolicy policyId + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> + OS2.Types.ismPolicyInfoId r `shouldBe` OS2.Types.unPolicyId policyId + + os3It <- runIO os3OnlyIT + os3It "fetches a single policy by id (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS3.Types.PolicyId $ Text.pack $ "bloodhound_test_get_policy_os3_" <> suffix + _ <- OS3.Client.putISMPolicy policyId os3SamplePolicy + resp <- OS3.Client.getISMPolicy policyId + _ <- OS3.Client.deleteISMPolicy policyId + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> + OS3.Types.ismPolicyInfoId r `shouldBe` OS3.Types.unPolicyId policyId + + describe "ISM getISMPolicies API" $ do + -- Each test creates a fresh policy, then lists with a 'queryString' + -- filter scoped to that policy id. Filtering keeps the assertion + -- deterministic regardless of how many policies accumulated from prior + -- runs (the unfiltered list's default page would otherwise push the + -- new policy out of the first page on a dirty container). Each test + -- also best-effort deletes its policy to keep the cluster from + -- accumulating test policies across runs. + os1It <- runIO os1OnlyIT + os1It "lists policies and contains the created one (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS1.Types.PolicyId $ Text.pack $ "bloodhound_test_list_policy_os1_" <> suffix + listQuery = + OS1.Types.ISMPoliciesQuery + { OS1.Types.ismPoliciesQuerySize = Nothing, + OS1.Types.ismPoliciesQueryFrom = Nothing, + OS1.Types.ismPoliciesQuerySortField = Nothing, + OS1.Types.ismPoliciesQuerySortOrder = Nothing, + OS1.Types.ismPoliciesQueryQueryString = Just (OS1.Types.unPolicyId policyId) + } + _ <- OS1.Client.putISMPolicy policyId os1SamplePolicy + resp <- OS1.Client.getISMPolicies (Just listQuery) + _ <- OS1.Client.deleteISMPolicy policyId + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> + OS1.Types.getISMPoliciesResponsePolicies r + `shouldSatisfy` any ((== OS1.Types.unPolicyId policyId) . OS1.Types.ismPolicyInfoId) + + os2It <- runIO os2OnlyIT + os2It "lists policies and contains the created one (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS2.Types.PolicyId $ Text.pack $ "bloodhound_test_list_policy_os2_" <> suffix + listQuery = + OS2.Types.ISMPoliciesQuery + { OS2.Types.ismPoliciesQuerySize = Nothing, + OS2.Types.ismPoliciesQueryFrom = Nothing, + OS2.Types.ismPoliciesQuerySortField = Nothing, + OS2.Types.ismPoliciesQuerySortOrder = Nothing, + OS2.Types.ismPoliciesQueryQueryString = Just (OS2.Types.unPolicyId policyId) + } + _ <- OS2.Client.putISMPolicy policyId os2SamplePolicy + resp <- OS2.Client.getISMPolicies (Just listQuery) + _ <- OS2.Client.deleteISMPolicy policyId + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> + OS2.Types.getISMPoliciesResponsePolicies r + `shouldSatisfy` any ((== OS2.Types.unPolicyId policyId) . OS2.Types.ismPolicyInfoId) + + os3It <- runIO os3OnlyIT + os3It "lists policies and contains the created one (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS3.Types.PolicyId $ Text.pack $ "bloodhound_test_list_policy_os3_" <> suffix + listQuery = + OS3.Types.ISMPoliciesQuery + { OS3.Types.ismPoliciesQuerySize = Nothing, + OS3.Types.ismPoliciesQueryFrom = Nothing, + OS3.Types.ismPoliciesQuerySortField = Nothing, + OS3.Types.ismPoliciesQuerySortOrder = Nothing, + OS3.Types.ismPoliciesQueryQueryString = Just (OS3.Types.unPolicyId policyId) + } + _ <- OS3.Client.putISMPolicy policyId os3SamplePolicy + resp <- OS3.Client.getISMPolicies (Just listQuery) + _ <- OS3.Client.deleteISMPolicy policyId + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> + OS3.Types.getISMPoliciesResponsePolicies r + `shouldSatisfy` any ((== OS3.Types.unPolicyId policyId) . OS3.Types.ismPolicyInfoId) + + -- -------- Live integration: changeISMPolicy / retryISMIndex (smoke) ---------- + -- + -- These mutate managed-index state, which ISM applies asynchronously, so we + -- assert only that the endpoint responds with the shared update shape and no + -- failures (the deterministic managed-path coverage lives in the JSON tests). + + describe "ISM changeISMPolicy API" $ do + os1It <- runIO os1OnlyIT + os1It "changes the policy on a managed index without failures (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS1.Types.PolicyId $ Text.pack $ "bloodhound_test_chg_policy_os1_" <> suffix + let Right indexName = mkIndexName $ Text.pack $ "bloodhound_test_chg_index_os1_" <> suffix + _ <- OS1.Client.putISMPolicy policyId os1SamplePolicy + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) indexName + _ <- OS1.Client.addISMPolicy policyId indexName + let req = OS1.Types.ChangePolicyRequest policyId Nothing [] + resp <- OS1.Client.changeISMPolicy indexName req + _ <- performBHRequest $ deleteIndex indexName + liftIO $ + case resp of + Left e -> expectationFailure ("Expected Right, got: " <> show e) + Right r -> OS1.Types.ismUpdatedIndicesResponseFailures r `shouldBe` False + + describe "ISM retryISMIndex API" $ do + -- retry is only exercised against OS1 because OS2/OS3 share the exact same + -- Requests/Client code path (the ISM type modules are byte-identical + -- mirrors); the pure JSON tests cover the response shape. + os1It <- runIO os1OnlyIT + os1It "hits POST /_plugins/_ism/retry/{index} and decodes the response (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let policyId = OS1.Types.PolicyId $ Text.pack $ "bloodhound_test_rty_policy_os1_" <> suffix + let Right indexName = mkIndexName $ Text.pack $ "bloodhound_test_rty_index_os1_" <> suffix + _ <- OS1.Client.putISMPolicy policyId os1SamplePolicy + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) indexName + _ <- OS1.Client.addISMPolicy policyId indexName + resp <- OS1.Client.retryISMIndex indexName Nothing + _ <- performBHRequest $ deleteIndex indexName + liftIO $ + case resp of + -- A wrong endpoint path / method would surface as a 404/400 Left, + -- so requiring Right (a decoded ISMUpdatedIndicesResponse) proves + -- the retry path and body shape. On a managed-but-not-failed + -- index OS legitimately returns failures=true here; we only assert + -- that the shared update shape decoded, not the failure flag. + Left e -> expectationFailure ("Expected decoded Right, got Left: " <> show e) + Right _ -> pure () + + describe "simulateISMPolicy endpoint shape (OS 3.7+)" $ do + it "POSTs /_plugins/_ism/simulate with the encoded body" $ do + let req = + OS3.Types.SimulateISMPolicyRequest + { OS3.Types.simulateISMPolicyRequestPolicyId = Just "my-policy", + OS3.Types.simulateISMPolicyRequestPolicy = Nothing, + OS3.Types.simulateISMPolicyRequestIndices = ["logs-*"] + } + r = OS3Requests.simulateISMPolicy req + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) `shouldBe` ["_plugins", "_ism", "simulate"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + let body = case bhRequestBody r of Just b -> b + LBS.unpack body `shouldContain` "\"policy_id\"" + LBS.unpack body `shouldContain` "\"logs-*\"" + + it "forwards an inline policy when policy_id is Nothing" $ do + let req = + OS3.Types.SimulateISMPolicyRequest + { OS3.Types.simulateISMPolicyRequestPolicyId = Nothing, + OS3.Types.simulateISMPolicyRequestPolicy = Just os3SimulateSamplePolicyBody, + OS3.Types.simulateISMPolicyRequestIndices = ["my-index"] + } + r = OS3Requests.simulateISMPolicy req + let body = case bhRequestBody r of Just b -> b + LBS.unpack body `shouldContain` "\"policy\"" + LBS.unpack body `shouldNotContain` "\"policy_id\"" + + describe "SimulateISMPolicyResponse decoding (simulate fixture)" $ do + let fixture = + LBS.pack + "{\"simulate_results\":[{\"index_name\":\"logs-2024-01-15\",\ + \\"index_uuid\":\"gCFlS_zcTdih8xyxf3jQ-A\",\"policy_id\":\"my-policy\",\ + \\"is_managed\":false,\"current_state\":\"hot\",\"current_action\":\"transition\",\ + \\"transition_evaluation\":[{\"state_name\":\"warm\",\"condition_met\":true,\ + \\"condition_type\":\"min_index_age\",\"current_value\":\"10d\",\"required_value\":\"7d\"}],\ + \\"next_state\":\"warm\"},{\"index_name\":\"nonexistent\",\"index_uuid\":null,\ + \\"policy_id\":\"my-policy\",\"is_managed\":false,\"error\":\"Index not found\"}]}" + + it "decodes the documented success + error fixture" $ do + let Just decoded = decode fixture :: Maybe OS3.Types.SimulateISMPolicyResponse + let [r1, r2] = OS3.Types.simulateISMPolicyResponseSimulateResults decoded + OS3.Types.simulateISMPolicyResultIndexName r1 `shouldBe` Just "logs-2024-01-15" + OS3.Types.simulateISMPolicyResultCurrentState r1 `shouldBe` Just "hot" + OS3.Types.simulateISMPolicyResultNextState r1 `shouldBe` Just "warm" + let [te] = case OS3.Types.simulateISMPolicyResultTransitionEvaluation r1 of Just xs -> xs + OS3.Types.simulateISMTransitionEvaluationConditionMet te `shouldBe` Just True + OS3.Types.simulateISMTransitionEvaluationConditionType te `shouldBe` Just "min_index_age" + OS3.Types.simulateISMTransitionEvaluationCurrentValue te `shouldBe` Just "10d" + -- the error case: index not found returns inline error, not HTTP 404 + OS3.Types.simulateISMPolicyResultIndexName r2 `shouldBe` Just "nonexistent" + OS3.Types.simulateISMPolicyResultIndexUuid r2 `shouldBe` Nothing + OS3.Types.simulateISMPolicyResultError r2 `shouldBe` Just "Index not found" + OS3.Types.simulateISMPolicyResultCurrentState r2 `shouldBe` Nothing + +os3SimulateSamplePolicyBody :: OS3.Types.ISMPolicyBody +os3SimulateSamplePolicyBody = + OS3.Types.ISMPolicyBody + { OS3.Types.ismPolicyBodyDescription = Just "test policy", + OS3.Types.ismPolicyBodyDefaultState = "ingest", + OS3.Types.ismPolicyBodyStates = + [ OS3.Types.ISMState + { OS3.Types.ismStateName = "ingest", + OS3.Types.ismStateActions = [], + OS3.Types.ismStateTransitions = [] + } + ], + OS3.Types.ismPolicyBodyIsmTemplate = [], + OS3.Types.ismPolicyBodyErrorNotification = Nothing, + OS3.Types.ismPolicyBodyUserVariables = Nothing + } diff --git a/tests/Test/IndexDocumentParamsSpec.hs b/tests/Test/IndexDocumentParamsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/IndexDocumentParamsSpec.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.IndexDocumentParamsSpec (spec) where + +import Data.Aeson (decode, encode) +import Data.List (sort) +import Data.Text (Text) +import Database.Bloodhound.Common.Requests (indexQueryString) +import Database.Bloodhound.Common.Types +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +-- | Stable ordering for equality. 'indexQueryString' preserves the +-- order in which params are emitted (legacy version-control first, +-- then routing, then the newer ones), but tests should not couple to +-- that internal ordering. +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + +spec :: Spec +spec = + describe "IndexDocumentSettings URI param rendering" $ do + it "defaultIndexDocumentSettings emits no params" $ do + indexQueryString defaultIndexDocumentSettings (DocId "1") + `shouldBe` [] + + it "JoinRelation ParentDocument emits routing = docId" $ do + let cfg = + defaultIndexDocumentSettings + { idsJoinRelation = + Just (ParentDocument (FieldName "join") (RelationName "message")) + } + indexQueryString cfg (DocId "42") + `shouldBe` [("routing", Just "42")] + + it "JoinRelation ChildDocument emits routing = parent docId" $ do + let cfg = + defaultIndexDocumentSettings + { idsJoinRelation = + Just + ( ChildDocument + (FieldName "join") + (RelationName "reply") + (DocId "parent-1") + ) + } + indexQueryString cfg (DocId "child-2") + `shouldBe` [("routing", Just "parent-1")] + + it "ExternalGTE version control emits version + version_type" $ do + let cfg = + defaultIndexDocumentSettings + { idsVersionControl = ExternalGTE (ExternalDocVersion minBound) + } + normalize (indexQueryString cfg (DocId "1")) + `shouldBe` [ ("version", Just "1"), + ("version_type", Just "external_gte") + ] + + describe "op_type" $ do + it "OpCreate renders as op_type=create" $ do + let cfg = defaultIndexDocumentSettings {idsOpType = Just OpCreate} + indexQueryString cfg (DocId "1") + `shouldBe` [("op_type", Just "create")] + it "OpIndex renders as op_type=index" $ do + let cfg = defaultIndexDocumentSettings {idsOpType = Just OpIndex} + indexQueryString cfg (DocId "1") + `shouldBe` [("op_type", Just "index")] + + -- \| Regression coverage for the underlying 'OpType' type and the + -- @idsOpType@ lens (the URI-rendering tests above exercise the + -- downstream output only; these pin the type-level building blocks + -- so a refactor of 'OpType' or its instances cannot silently break + -- @op_type@ support). Bead bloodhound-04f.7.14. + describe "OpType type and lens (regression)" $ do + it "renderOpType yields the bare URI value" $ do + renderOpType OpCreate `shouldBe` "create" + renderOpType OpIndex `shouldBe` "index" + it "ToJSON renders as the quoted string ES expects in bodies" $ do + encode OpCreate `shouldBe` "\"create\"" + encode OpIndex `shouldBe` "\"index\"" + it "FromJSON round-trips both constructors" $ do + decode "\"create\"" `shouldBe` Just OpCreate + decode "\"index\"" `shouldBe` Just OpIndex + it "FromJSON rejects unknown values" $ do + (decode "\"upsert\"" :: Maybe OpType) `shouldBe` Nothing + it "idsOpType field round-trips set/get" $ do + let s = defaultIndexDocumentSettings {idsOpType = Just OpCreate} + idsOpType s `shouldBe` Just OpCreate + it "defaultIndexDocumentSettings has no op_type (Nothing)" $ + idsOpType defaultIndexDocumentSettings `shouldBe` Nothing + + it "pipeline renders the supplied pipeline id verbatim" $ do + let cfg = defaultIndexDocumentSettings {idsPipeline = Just "my-pipeline"} + indexQueryString cfg (DocId "1") + `shouldBe` [("pipeline", Just "my-pipeline")] + + describe "refresh" $ do + it "RefreshTrue renders as refresh=true" $ do + let cfg = defaultIndexDocumentSettings {idsRefresh = Just RefreshTrue} + indexQueryString cfg (DocId "1") + `shouldBe` [("refresh", Just "true")] + it "RefreshFalse renders as refresh=false" $ do + let cfg = defaultIndexDocumentSettings {idsRefresh = Just RefreshFalse} + indexQueryString cfg (DocId "1") + `shouldBe` [("refresh", Just "false")] + it "RefreshWaitFor renders as refresh=wait_for" $ do + let cfg = defaultIndexDocumentSettings {idsRefresh = Just RefreshWaitFor} + indexQueryString cfg (DocId "1") + `shouldBe` [("refresh", Just "wait_for")] + + describe "wait_for_active_shards" $ do + it "AllActiveShards renders as wait_for_active_shards=all" $ do + let cfg = + defaultIndexDocumentSettings + { idsWaitForActiveShards = Just AllActiveShards + } + indexQueryString cfg (DocId "1") + `shouldBe` [("wait_for_active_shards", Just "all")] + it "ActiveShards n renders as wait_for_active_shards=" $ do + let cfg = + defaultIndexDocumentSettings + { idsWaitForActiveShards = Just (ActiveShards 3) + } + indexQueryString cfg (DocId "1") + `shouldBe` [("wait_for_active_shards", Just "3")] + + describe "if_seq_no / if_primary_term" $ do + it "emits both when both are set" $ do + let cfg = + defaultIndexDocumentSettings + { idsIfSeqNo = Just 7, + idsIfPrimaryTerm = Just 2 + } + normalize (indexQueryString cfg (DocId "1")) + `shouldBe` [ ("if_primary_term", Just "2"), + ("if_seq_no", Just "7") + ] + it "emits if_seq_no alone when only if_seq_no is set (pass-through to ES 400)" $ do + let cfg = defaultIndexDocumentSettings {idsIfSeqNo = Just 7} + indexQueryString cfg (DocId "1") + `shouldBe` [("if_seq_no", Just "7")] + it "emits if_primary_term alone when only if_primary_term is set (pass-through to ES 400)" $ do + let cfg = defaultIndexDocumentSettings {idsIfPrimaryTerm = Just 2} + indexQueryString cfg (DocId "1") + `shouldBe` [("if_primary_term", Just "2")] + + describe "require_alias" $ do + it "Just True renders as require_alias=true" $ do + let cfg = defaultIndexDocumentSettings {idsRequireAlias = Just True} + indexQueryString cfg (DocId "1") + `shouldBe` [("require_alias", Just "true")] + it "Just False renders as require_alias=false" $ do + let cfg = defaultIndexDocumentSettings {idsRequireAlias = Just False} + indexQueryString cfg (DocId "1") + `shouldBe` [("require_alias", Just "false")] + + describe "timeout" $ do + it "(TimeUnitSeconds, 30) renders as timeout=30s" $ do + let cfg = defaultIndexDocumentSettings {idsTimeout = Just (TimeUnitSeconds, 30)} + indexQueryString cfg (DocId "1") + `shouldBe` [("timeout", Just "30s")] + it "(TimeUnitMilliseconds, 200) renders as timeout=200ms" $ do + let cfg = defaultIndexDocumentSettings {idsTimeout = Just (TimeUnitMilliseconds, 200)} + indexQueryString cfg (DocId "1") + `shouldBe` [("timeout", Just "200ms")] + it "(TimeUnitMinutes, 1) renders as timeout=1m (matches server default shape)" $ do + let cfg = defaultIndexDocumentSettings {idsTimeout = Just (TimeUnitMinutes, 1)} + indexQueryString cfg (DocId "1") + `shouldBe` [("timeout", Just "1m")] + it "defaultIndexDocumentSettings has no timeout (Nothing)" $ + idsTimeout defaultIndexDocumentSettings `shouldBe` Nothing + it "idsTimeout field round-trips set/get" $ do + let s = defaultIndexDocumentSettings {idsTimeout = Just (TimeUnitSeconds, 5)} + idsTimeout s `shouldBe` Just (TimeUnitSeconds, 5) + + it "renders every field together when all are populated" $ do + let cfg = + defaultIndexDocumentSettings + { idsOpType = Just OpCreate, + idsPipeline = Just "p", + idsRefresh = Just RefreshWaitFor, + idsWaitForActiveShards = Just AllActiveShards, + idsIfSeqNo = Just 10, + idsIfPrimaryTerm = Just 1, + idsRequireAlias = Just True, + idsTimeout = Just (TimeUnitSeconds, 5) + } + let rendered = indexQueryString cfg (DocId "1") + length rendered `shouldBe` 8 + -- every value is non-Nothing + rendered `shouldSatisfy` all (isJust . snd) + normalize rendered + `shouldBe` sort + [ ("if_primary_term", Just "1"), + ("if_seq_no", Just "10"), + ("op_type", Just "create"), + ("pipeline", Just "p"), + ("refresh", Just "wait_for"), + ("require_alias", Just "true"), + ("timeout", Just "5s"), + ("wait_for_active_shards", Just "all") + ] + + it "preserves backwards compatibility: legacy version + join emit only the old params" $ do + let cfg = + defaultIndexDocumentSettings + { idsVersionControl = ExternalGTE (ExternalDocVersion minBound), + idsJoinRelation = + Just (ParentDocument (FieldName "j") (RelationName "message")) + } + normalize (indexQueryString cfg (DocId "abc")) + `shouldBe` [ ("routing", Just "abc"), + ("version", Just "1"), + ("version_type", Just "external_gte") + ] + where + isJust (Just _) = True + isJust Nothing = False diff --git a/tests/Test/IndexSettingsOptionsSpec.hs b/tests/Test/IndexSettingsOptionsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/IndexSettingsOptionsSpec.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.IndexSettingsOptionsSpec (spec) where + +import Data.List (sort) +import Data.Text (Text) +import Database.Bloodhound.Common.Types +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +-- | Stable ordering for equality: 'withQueries' preserves the order in +-- which params are emitted, but the tests compare the @Set@ of params to +-- avoid coupling to internal field ordering of the Options records. +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + +spec :: Spec +spec = do + describe "UpdateIndexSettingsOptions URI param rendering" $ do + it "defaultUpdateIndexSettingsOptions emits no params" $ + updateIndexSettingsOptionsParams defaultUpdateIndexSettingsOptions + `shouldBe` [] + + it "renders every Bool field as true/false strings" $ do + let opts = + defaultUpdateIndexSettingsOptions + { uisoPreserveExisting = Just True, + uisoFlatSettings = Just False + } + normalize (updateIndexSettingsOptionsParams opts) + `shouldBe` [ ("flat_settings", Just "false"), + ("preserve_existing", Just "true") + ] + + it "renders master_timeout and timeout as " $ do + let opts = + defaultUpdateIndexSettingsOptions + { uisoMasterTimeout = Just (TimeUnitSeconds, 30), + uisoTimeout = Just (TimeUnitMinutes, 1) + } + normalize (updateIndexSettingsOptionsParams opts) + `shouldBe` [ ("master_timeout", Just "30s"), + ("timeout", Just "1m") + ] + + it "supports every TimeUnits suffix for master_timeout" $ do + let mk u = updateIndexSettingsOptionsParams defaultUpdateIndexSettingsOptions {uisoMasterTimeout = Just (u, 1)} + mk TimeUnitDays `shouldBe` [("master_timeout", Just "1d")] + mk TimeUnitHours `shouldBe` [("master_timeout", Just "1h")] + mk TimeUnitMinutes `shouldBe` [("master_timeout", Just "1m")] + mk TimeUnitSeconds `shouldBe` [("master_timeout", Just "1s")] + mk TimeUnitMilliseconds `shouldBe` [("master_timeout", Just "1ms")] + mk TimeUnitMicroseconds `shouldBe` [("master_timeout", Just "1micros")] + mk TimeUnitNanoseconds `shouldBe` [("master_timeout", Just "1nanos")] + + it "emits the full param set when every field is populated" $ do + let opts = + defaultUpdateIndexSettingsOptions + { uisoMasterTimeout = Just (TimeUnitSeconds, 5), + uisoTimeout = Just (TimeUnitSeconds, 10), + uisoPreserveExisting = Just True, + uisoFlatSettings = Just True + } + let rendered = updateIndexSettingsOptionsParams opts + length rendered `shouldBe` 4 + rendered `shouldSatisfy` all (\(_, v) -> v == Just "5s" || v == Just "10s" || v == Just "true") + sort (map fst rendered) + `shouldBe` [ "flat_settings", + "master_timeout", + "preserve_existing", + "timeout" + ] + + describe "GetIndexSettingsOptions URI param rendering" $ do + it "defaultGetIndexSettingsOptions emits no params" $ + getIndexSettingsOptionsParams defaultGetIndexSettingsOptions + `shouldBe` [] + + it "renders every Bool field as true/false strings" $ do + let opts = + defaultGetIndexSettingsOptions + { gisoFlatSettings = Just True, + gisoIncludeDefaults = Just False, + gisoLocal = Just True + } + normalize (getIndexSettingsOptionsParams opts) + `shouldBe` [ ("flat_settings", Just "true"), + ("include_defaults", Just "false"), + ("local", Just "true") + ] + + it "renders master_timeout as " $ do + let opts = + defaultGetIndexSettingsOptions + { gisoMasterTimeout = Just (TimeUnitSeconds, 30) + } + getIndexSettingsOptionsParams opts + `shouldBe` [("master_timeout", Just "30s")] + + it "supports every TimeUnits suffix for master_timeout" $ do + let mk u = getIndexSettingsOptionsParams defaultGetIndexSettingsOptions {gisoMasterTimeout = Just (u, 1)} + mk TimeUnitDays `shouldBe` [("master_timeout", Just "1d")] + mk TimeUnitHours `shouldBe` [("master_timeout", Just "1h")] + mk TimeUnitMinutes `shouldBe` [("master_timeout", Just "1m")] + mk TimeUnitSeconds `shouldBe` [("master_timeout", Just "1s")] + mk TimeUnitMilliseconds `shouldBe` [("master_timeout", Just "1ms")] + mk TimeUnitMicroseconds `shouldBe` [("master_timeout", Just "1micros")] + mk TimeUnitNanoseconds `shouldBe` [("master_timeout", Just "1nanos")] + + it "emits the full param set when every field is populated" $ do + let opts = + defaultGetIndexSettingsOptions + { gisoMasterTimeout = Just (TimeUnitSeconds, 5), + gisoFlatSettings = Just True, + gisoIncludeDefaults = Just True, + gisoLocal = Just False + } + let rendered = getIndexSettingsOptionsParams opts + length rendered `shouldBe` 4 + sort (map fst rendered) + `shouldBe` [ "flat_settings", + "include_defaults", + "local", + "master_timeout" + ] diff --git a/tests/Test/IndexTransformsSpec.hs b/tests/Test/IndexTransformsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/IndexTransformsSpec.hs @@ -0,0 +1,883 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.IndexTransformsSpec (spec) where + +import Control.Monad (void) +import Control.Monad.Catch (bracket_) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value (..), decode, encode, object, (.=)) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List qualified as L +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust) +import Data.Text qualified as T +import Data.Time.Clock.POSIX (getPOSIXTime) +import Database.Bloodhound.OpenSearch1.Client qualified as OS1Client +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch1.Types qualified as OS1Types +import Database.Bloodhound.OpenSearch2.Client qualified as OS2Client +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2Types +import Database.Bloodhound.OpenSearch3.Client qualified as OS3Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types qualified as OS3Types +import TestsUtils.Common + ( os1OnlyIT, + os2OnlyIT, + os3OnlyIT, + withTestEnv, + ) +import TestsUtils.Import +import Prelude + +-- --------------------------------------------------------------------------- +-- Sample fixtures, drawn verbatim from the OS Index Transforms plugin docs +-- (). +-- --------------------------------------------------------------------------- + +-- | A bare-bones transform request body — exactly the shape the docs show +-- for @PUT /_plugins/_transform/{transform_id}@ (an interval schedule, a +-- single @terms@ group, a @match_all@ data selection, and a page size). +sampleTransformJson :: LBS.ByteString +sampleTransformJson = + "{\ + \ \"description\": \"A simple transform\",\ + \ \"schedule\": {\ + \ \"interval\": {\ + \ \"period\": 1,\ + \ \"unit\": \"Minutes\",\ + \ \"start_time\": 1602100553\ + \ }\ + \ },\ + \ \"metadata_id\": null,\ + \ \"source_index\": \"bloodhound-test-source-os1\",\ + \ \"target_index\": \"bloodhound-test-target-os1\",\ + \ \"data_selection_query\": {\ + \ \"match_all\": {}\ + \ },\ + \ \"page_size\": 1,\ + \ \"groups\": [\ + \ {\ + \ \"terms\": {\ + \ \"source_field\": \"category\",\ + \ \"target_field\": \"category_term\"\ + \ }\ + \ }\ + \ ]\ + \}" + +-- | The full server response envelope for Create \/ Get. Carries every +-- server-injected bookkeeping field the decoder must round-trip +-- (@schema_version@, @updated_at@, @enabled_at@, @roles@, +-- @transform_id@). +sampleDocumentResponseJson :: LBS.ByteString +sampleDocumentResponseJson = + "{\ + \ \"_id\": \"my-transform-id\",\ + \ \"_version\": 1,\ + \ \"_seq_no\": 0,\ + \ \"_primary_term\": 1,\ + \ \"transform\": {\ + \ \"transform_id\": \"my-transform-id\",\ + \ \"schema_version\": 2,\ + \ \"continuous\": false,\ + \ \"schedule\": {\ + \ \"interval\": {\ + \ \"period\": 1,\ + \ \"unit\": \"Minutes\",\ + \ \"start_time\": 1602100553\ + \ }\ + \ },\ + \ \"metadata_id\": null,\ + \ \"updated_at\": 1602100553,\ + \ \"enabled\": false,\ + \ \"enabled_at\": null,\ + \ \"description\": \"A simple transform\",\ + \ \"source_index\": \"bloodhound-test-source-os1\",\ + \ \"data_selection_query\": {\ + \ \"match_all\": {\ + \ \"boost\": 1.0\ + \ }\ + \ },\ + \ \"target_index\": \"bloodhound-test-target-os1\",\ + \ \"roles\": [],\ + \ \"page_size\": 1,\ + \ \"groups\": [\ + \ {\ + \ \"terms\": {\ + \ \"source_field\": \"category\",\ + \ \"target_field\": \"category_term\"\ + \ }\ + \ }\ + \ ]\ + \ }\ + \}" + +-- | The list endpoint envelope. Note the distinct @total_transforms@ and +-- @transforms@ keys (NOT the standard search @hits@ envelope). +sampleListResponseJson :: LBS.ByteString +sampleListResponseJson = + "{\ + \ \"total_transforms\": 1,\ + \ \"transforms\": [\ + \ {\ + \ \"_id\": \"my-transform-id\",\ + \ \"_seq_no\": 0,\ + \ \"_primary_term\": 1,\ + \ \"transform\": {\ + \ \"transform_id\": \"my-transform-id\",\ + \ \"schedule\": {\ + \ \"interval\": { \"period\": 1, \"unit\": \"Minutes\" }\ + \ },\ + \ \"source_index\": \"bloodhound-test-source-os1\",\ + \ \"data_selection_query\": { \"match_all\": {} },\ + \ \"target_index\": \"bloodhound-test-target-os1\",\ + \ \"page_size\": 1,\ + \ \"groups\": [\ + \ { \"terms\": { \"source_field\": \"category\" } }\ + \ ]\ + \ }\ + \ }\ + \ ]\ + \}" + +-- | The @_explain@ response — keyed by transform_id at the top level. +sampleExplainResponseJson :: LBS.ByteString +sampleExplainResponseJson = + "{\ + \ \"my-transform-id\": {\ + \ \"metadata_id\": \"PaLcRj0gaQq-y_WO81N0Q\",\ + \ \"transform_metadata\": {\ + \ \"continuous_stats\": {\ + \ \"last_timestamp\": 1633392680364,\ + \ \"documents_behind\": { \"bloodhound-test-source-os1\": 0 }\ + \ },\ + \ \"transform_id\": \"my-transform-id\",\ + \ \"last_updated_at\": 1633392680364,\ + \ \"status\": \"finished\",\ + \ \"failure_reason\": null,\ + \ \"stats\": {\ + \ \"pages_processed\": 1,\ + \ \"documents_processed\": 10,\ + \ \"documents_indexed\": 1,\ + \ \"index_time_in_millis\": 5,\ + \ \"search_time_in_millis\": 3\ + \ }\ + \ }\ + \ }\ + \}" + +-- | The @_preview@ response — a list of opaque row documents. +samplePreviewResponseJson :: LBS.ByteString +samplePreviewResponseJson = + "{\ + \ \"documents\": [\ + \ {\ + \ \"category_term\": \"alpha\",\ + \ \"count\": 5\ + \ },\ + \ {\ + \ \"category_term\": \"beta\",\ + \ \"count\": 3\ + \ }\ + \ ]\ + \}" + +-- | The @terms@ group body for 'sampleTransformJson'. +sampleTermsGroup :: OS1Types.TermsGroup +sampleTermsGroup = + OS1Types.TermsGroup + { OS1Types.termsGroupSourceField = "category", + OS1Types.termsGroupTargetField = Just "category_term", + OS1Types.termsGroupOther = Nothing + } + +-- | Haskell-side 'OS1Types.Transform' mirror of 'sampleTransformJson'. +os1SampleTransform :: OS1Types.Transform +os1SampleTransform = + OS1Types.Transform + { OS1Types.transformEnabled = Nothing, + OS1Types.transformContinuous = Nothing, + OS1Types.transformSchedule = + OS1Types.TransformScheduleInterval + OS1Types.TransformInterval + { OS1Types.transformIntervalPeriod = 1, + OS1Types.transformIntervalUnit = OS1Types.TransformPeriodUnitMinutes, + OS1Types.transformIntervalStartTime = Just 1602100553 + }, + OS1Types.transformDescription = Just "A simple transform", + OS1Types.transformMetadataId = Nothing, + OS1Types.transformSourceIndex = "bloodhound-test-source-os1", + OS1Types.transformTargetIndex = "bloodhound-test-target-os1", + OS1Types.transformDataSelectionQuery = + object ["match_all" .= object []], + OS1Types.transformPageSize = 1, + OS1Types.transformGroups = Just [OS1Types.TransformGroupTerms sampleTermsGroup], + OS1Types.transformAggregations = Nothing + } + +spec :: Spec +spec = do + -- ======================================================================= + -- TransformId newtype + -- ======================================================================= + describe "IndexTransforms TransformId JSON" $ do + it "encodes TransformId as a bare JSON string" $ do + encode (OS1Types.TransformId "abc-123") + `shouldBe` "\"abc-123\"" + + it "decodes a bare JSON string into TransformId" $ do + decode "\"abc-123\"" `shouldBe` Just (OS1Types.TransformId "abc-123") + + it "round-trips TransformId through encode -> decode" $ do + let original = OS1Types.TransformId "round-trip-id" + (decode . encode) original `shouldBe` Just original + + -- ======================================================================= + -- TransformPeriodUnit enum + -- ======================================================================= + describe "IndexTransforms TransformPeriodUnit JSON" $ do + let cases = + [ (OS1Types.TransformPeriodUnitMinutes, "Minutes"), + (OS1Types.TransformPeriodUnitHours, "Hours"), + (OS1Types.TransformPeriodUnitDays, "Days"), + (OS1Types.TransformPeriodUnitSeconds, "Seconds"), + (OS1Types.TransformPeriodUnitWeeks, "Weeks"), + (OS1Types.TransformPeriodUnitMonths, "Months") + ] + forM_ cases $ \(u, wire) -> do + it ("encodes " <> show wire <> " to the documented wire string") $ do + encode u `shouldBe` "\"" <> LBS.fromStrict wire <> "\"" + it ("decodes the documented wire string " <> show wire) $ do + (decode ("\"" <> LBS.fromStrict wire <> "\"") :: Maybe OS1Types.TransformPeriodUnit) + `shouldBe` Just u + + it "decodes an unknown unit into TransformPeriodUnitCustom" $ do + (decode "\"Decades\"" :: Maybe OS1Types.TransformPeriodUnit) + `shouldBe` Just (OS1Types.TransformPeriodUnitCustom "Decades") + + it "round-trips TransformPeriodUnit through ToJSON/FromJSON (known)" $ do + let u = OS1Types.TransformPeriodUnitMinutes + (decode . encode) u `shouldBe` Just u + + -- ======================================================================= + -- TransformSortDirection enum + -- ======================================================================= + describe "IndexTransforms TransformSortDirection JSON" $ do + let cases = + [ (OS1Types.TransformSortDirectionAsc, "ASC"), + (OS1Types.TransformSortDirectionDesc, "DESC") + ] + forM_ cases $ \(d, wire) -> do + it ("encodes " <> show wire <> " to the documented wire string") $ do + encode d `shouldBe` "\"" <> LBS.fromStrict wire <> "\"" + it ("decodes the documented wire string " <> show wire) $ do + (decode ("\"" <> LBS.fromStrict wire <> "\"") :: Maybe OS1Types.TransformSortDirection) + `shouldBe` Just d + + -- ======================================================================= + -- TransformsListOptions -> query params + -- ======================================================================= + describe "IndexTransforms TransformsListOptions params" $ do + it "defaultTransformsListOptions produces no query pairs" $ do + OS1Types.transformsListOptionsParams OS1Types.defaultTransformsListOptions + `shouldBe` [] + + it "renders all fields when fully populated" $ do + let opts = + OS1Types.defaultTransformsListOptions + { OS1Types.transformsListOptionsFrom = Just 5, + OS1Types.transformsListOptionsSize = Just 20, + OS1Types.transformsListOptionsSearch = Just "foo", + OS1Types.transformsListOptionsSortField = Just "id", + OS1Types.transformsListOptionsSortDirection = Just OS1Types.TransformSortDirectionDesc + } + L.sortOn fst (OS1Types.transformsListOptionsParams opts) + `shouldBe` [ ("from", Just "5"), + ("search", Just "foo"), + ("size", Just "20"), + ("sortDirection", Just "DESC"), + ("sortField", Just "id") + ] + + it "omits Nothing fields" $ do + let opts = + OS1Types.defaultTransformsListOptions + { OS1Types.transformsListOptionsSize = Just 10 + } + OS1Types.transformsListOptionsParams opts + `shouldBe` [("size", Just "10")] + + -- ======================================================================= + -- Transform (request body) JSON + -- ======================================================================= + describe "IndexTransforms Transform JSON" $ do + it "decodes the documented request body fixture" $ do + let decoded = decode sampleTransformJson :: Maybe OS1Types.Transform + decoded `shouldBe` Just os1SampleTransform + + it "round-trips the sample Transform through encode -> decode" $ do + (decode . encode) os1SampleTransform `shouldBe` Just os1SampleTransform + + it "encodes a Transform omitting nulls (no enabled/continuous/aggregations)" $ do + let encoded = encode os1SampleTransform + encodedStr = LBS.unpack encoded + encodedStr `shouldSatisfy` not . L.isInfixOf "\"enabled\"" + encodedStr `shouldSatisfy` not . L.isInfixOf "\"continuous\"" + encodedStr `shouldSatisfy` not . L.isInfixOf "\"aggregations\"" + -- @schedule@, @source_index@, @target_index@, @data_selection_query@, + -- @page_size@, @groups@ are required and always appear. + encodedStr `shouldSatisfy` L.isInfixOf "\"schedule\"" + encodedStr `shouldSatisfy` L.isInfixOf "\"source_index\"" + encodedStr `shouldSatisfy` L.isInfixOf "\"page_size\"" + + -- ======================================================================= + -- TransformGroup sum type + -- ======================================================================= + describe "IndexTransforms TransformGroup JSON" $ do + it "decodes {\"terms\": {...}} into TransformGroupTerms" $ do + let raw = "{\"terms\": {\"source_field\": \"category\"}}" + expected = + OS1Types.TransformGroupTerms + OS1Types.TermsGroup + { OS1Types.termsGroupSourceField = "category", + OS1Types.termsGroupTargetField = Nothing, + OS1Types.termsGroupOther = Nothing + } + (decode raw :: Maybe OS1Types.TransformGroup) `shouldBe` Just expected + + it "decodes {\"histogram\": {...}} into TransformGroupHistogram" $ do + let raw = "{\"histogram\": {\"source_field\": \"price\", \"interval\": 10}}" + expected = + OS1Types.TransformGroupHistogram + OS1Types.HistogramGroup + { OS1Types.histogramGroupSourceField = "price", + OS1Types.histogramGroupTargetField = Nothing, + OS1Types.histogramGroupInterval = Just 10, + OS1Types.histogramGroupOther = Nothing + } + (decode raw :: Maybe OS1Types.TransformGroup) `shouldBe` Just expected + + it "decodes {\"date_histogram\": {...}} into TransformGroupDateHistogram" $ do + let raw = "{\"date_histogram\": {\"source_field\": \"timestamp\", \"interval\": \"1d\", \"format\": \"yyyy-MM-dd\"}}" + let decoded = decode raw :: Maybe OS1Types.TransformGroup + decoded `shouldSatisfy` isJust + case decoded of + Just (OS1Types.TransformGroupDateHistogram g) -> do + OS1Types.dateHistogramGroupSourceField g `shouldBe` "timestamp" + OS1Types.dateHistogramGroupInterval g `shouldBe` Just "1d" + OS1Types.dateHistogramGroupFormat g `shouldBe` Just "yyyy-MM-dd" + other -> expectationFailure ("unexpected decode: " <> show other) + + it "round-trips each variant through encode -> decode" $ do + let g1 = OS1Types.TransformGroupTerms sampleTermsGroup + g2 = + OS1Types.TransformGroupHistogram + OS1Types.HistogramGroup + { OS1Types.histogramGroupSourceField = "f", + OS1Types.histogramGroupTargetField = Nothing, + OS1Types.histogramGroupInterval = Nothing, + OS1Types.histogramGroupOther = Nothing + } + g3 = + OS1Types.TransformGroupDateHistogram + OS1Types.DateHistogramGroup + { OS1Types.dateHistogramGroupSourceField = "t", + OS1Types.dateHistogramGroupTargetField = Nothing, + OS1Types.dateHistogramGroupInterval = Nothing, + OS1Types.dateHistogramGroupFormat = Nothing, + OS1Types.dateHistogramGroupTimeZone = Nothing, + OS1Types.dateHistogramGroupOther = Nothing + } + (decode . encode) g1 `shouldBe` Just g1 + (decode . encode) g2 `shouldBe` Just g2 + (decode . encode) g3 `shouldBe` Just g3 + + it "preserves unknown group fields through the Other escape hatch" $ do + let raw = "{\"percentiles\": {\"source_field\": \"x\"}}" + let decoded = decode raw :: Maybe OS1Types.TransformGroup + case decoded of + Just (OS1Types.TransformGroupOther _) -> pure () + other -> expectationFailure ("expected TransformGroupOther, got " <> show other) + -- round-trip preserves the unknown wrapper key + (decode . encode =<< decoded) `shouldBe` decoded + + -- ======================================================================= + -- TransformDocumentResponse JSON (envelope + inner TransformResponse) + -- ======================================================================= + describe "IndexTransforms TransformDocumentResponse JSON" $ do + it "decodes the documented response envelope (OS1)" $ do + let decoded = decode sampleDocumentResponseJson :: Maybe OS1Types.TransformDocumentResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.transformDocumentResponseId r `shouldBe` "my-transform-id" + OS1Types.transformDocumentResponseVersion r `shouldBe` 1 + OS1Types.transformDocumentResponseSeqNo r `shouldBe` 0 + OS1Types.transformDocumentResponsePrimaryTerm r `shouldBe` 1 + + it "decodes the same response envelope identically across OS1/OS2/OS3" $ do + let one = decode sampleDocumentResponseJson :: Maybe OS1Types.TransformDocumentResponse + two = decode sampleDocumentResponseJson :: Maybe OS2Types.TransformDocumentResponse + three = decode sampleDocumentResponseJson :: Maybe OS3Types.TransformDocumentResponse + one `shouldSatisfy` isJust + two `shouldSatisfy` isJust + three `shouldSatisfy` isJust + + it "round-trips the response envelope through encode -> decode" $ do + let decoded = decode sampleDocumentResponseJson :: Maybe OS1Types.TransformDocumentResponse + (decode . encode) decoded `shouldBe` decoded + + it "rejects a response missing the transform key" $ do + let bad = "{ \"_id\": \"x\", \"_version\": 1, \"_seq_no\": 0, \"_primary_term\": 1 }" + (decode bad :: Maybe OS1Types.TransformDocumentResponse) `shouldBe` Nothing + + -- ======================================================================= + -- Delete response is the bulk envelope (live-verified on OS 3.7.0) + -- ======================================================================= + describe "IndexTransforms deleteTransform response shape" $ do + -- Captured live against OS 3.7.0 (port 9205): DELETE returns the + -- bulk envelope because the transform is stored as a doc in + -- .opendistro-ism-config and the plugin deletes via the bulk + -- handler. BulkResponse (Common.Types.Bulk) matches the shape + -- byte-for-byte. + let deleteResponseJson = + "{\ + \ \"took\": 11,\ + \ \"errors\": false,\ + \ \"items\": [\ + \ {\ + \ \"delete\": {\ + \ \"_index\": \".opendistro-ism-config\",\ + \ \"_id\": \"my-transform-id\",\ + \ \"_version\": 2,\ + \ \"result\": \"deleted\",\ + \ \"forced_refresh\": true,\ + \ \"_shards\": { \"total\": 2, \"successful\": 1, \"failed\": 0 },\ + \ \"_seq_no\": 6404,\ + \ \"_primary_term\": 2,\ + \ \"status\": 200\ + \ }\ + \ }\ + \ ]\ + \}" + + it "decodes the live bulk-delete envelope into BulkResponse" $ do + let decoded = decode deleteResponseJson :: Maybe BulkResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + bulkTook r `shouldBe` 11 + bulkErrors r `shouldBe` False + length (bulkActionItems r) `shouldBe` 1 + + -- ======================================================================= + -- GetTransformsResponse (list envelope) + -- ======================================================================= + describe "IndexTransforms GetTransformsResponse JSON" $ do + it "decodes the documented list envelope" $ do + let decoded = decode sampleListResponseJson :: Maybe OS1Types.GetTransformsResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.getTransformsResponseTotalTransforms r `shouldBe` 1 + length (OS1Types.getTransformsResponseTransforms r) `shouldBe` 1 + + it "decodes an empty transforms array" $ do + let empty = "{ \"total_transforms\": 0, \"transforms\": [] }" + let decoded = decode empty :: Maybe OS1Types.GetTransformsResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + OS1Types.getTransformsResponseTotalTransforms r `shouldBe` 0 + + -- ======================================================================= + -- TransformExplain (the _explain response) + -- ======================================================================= + describe "IndexTransforms TransformExplain JSON" $ do + it "decodes the documented explain body" $ do + let decoded = + decode sampleExplainResponseJson :: + Maybe (Map.Map T.Text OS1Types.TransformExplain) + decoded `shouldSatisfy` isJust + let Just m = decoded + Map.size m `shouldBe` 1 + let Just entry = Map.lookup "my-transform-id" m + OS1Types.transformExplainMetadataId entry `shouldBe` Just "PaLcRj0gaQq-y_WO81N0Q" + OS1Types.transformExplainTransformMetadata entry `shouldSatisfy` isJust + + it "decodes a continuous_stats sub-object" $ do + let decoded = + decode sampleExplainResponseJson :: + Maybe (Map.Map T.Text OS1Types.TransformExplain) + let Just m = decoded + Just entry = Map.lookup "my-transform-id" m + Just md = OS1Types.transformExplainTransformMetadata entry + Just cs = OS1Types.transformMetadataContinuousStats md + OS1Types.transformContinuousStatsLastTimestamp cs `shouldBe` Just 1633392680364 + + -- ======================================================================= + -- PreviewTransformResponse + -- ======================================================================= + describe "IndexTransforms PreviewTransformResponse JSON" $ do + it "decodes the documented preview body" $ do + let decoded = decode samplePreviewResponseJson :: Maybe OS1Types.PreviewTransformResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + length (OS1Types.previewTransformResponseDocuments r) `shouldBe` 2 + + it "decodes an empty documents array" $ do + let empty' = "{ \"documents\": [] }" + let decoded = decode empty' :: Maybe OS1Types.PreviewTransformResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + length (OS1Types.previewTransformResponseDocuments r) `shouldBe` 0 + + -- ======================================================================= + -- Lifecycle endpoint shapes + -- ======================================================================= + describe "IndexTransforms lifecycle endpoint shape" $ do + let tid1 = OS1Types.TransformId "t1" + tid2 = OS2Types.TransformId "t2" + tid3 = OS3Types.TransformId "t3" + + it "createTransform PUTs /_plugins/_transform/{id} with the wrapped body" $ do + let req = OS1Requests.createTransform tid1 os1SampleTransform + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_transform", "t1"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + -- Body wraps under "transform" key + let Just body = bhRequestBody req + case decode body :: Maybe Value of + Just (Object o) -> "transform" `KM.member` o `shouldBe` True + _ -> expectationFailure "body should be a JSON object" + + it "updateTransformWith emits if_seq_no / if_primary_term query params" $ do + let req = OS1Requests.updateTransformWith tid1 os1SampleTransform (Just (7, 4)) + bhRequestMethod req `shouldBe` "PUT" + L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [("if_primary_term", Just "4"), ("if_seq_no", Just "7")] + + it "getTransform GETs /_plugins/_transform/{id} with no body" $ do + let req = OS1Requests.getTransform tid1 + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_transform", "t1"] + bhRequestBody req `shouldBe` Nothing + + it "getTransforms GETs /_plugins/_transform; forwards list opts as queries" $ do + let reqNoOpts = OS1Requests.getTransforms Nothing + bhRequestMethod reqNoOpts `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint reqNoOpts) + `shouldBe` ["_plugins", "_transform"] + getRawEndpointQueries (bhRequestEndpoint reqNoOpts) `shouldBe` [] + let opts = + OS1Types.defaultTransformsListOptions + { OS1Types.transformsListOptionsSize = Just 5, + OS1Types.transformsListOptionsSearch = Just "abc" + } + reqWithOpts = OS1Requests.getTransforms (Just opts) + L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint reqWithOpts)) + `shouldBe` [("search", Just "abc"), ("size", Just "5")] + + it "startTransform POSTs /_plugins/_transform/{id}/_start" $ do + let req = OS1Requests.startTransform tid1 + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_transform", "t1", "_start"] + + it "stopTransform POSTs /_plugins/_transform/{id}/_stop" $ do + let req = OS1Requests.stopTransform tid1 + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_transform", "t1", "_stop"] + + it "explainTransform GETs /_plugins/_transform/{id}/_explain" $ do + let req = OS1Requests.explainTransform tid1 + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_transform", "t1", "_explain"] + + it "previewTransform POSTs /_plugins/_transform/_preview with the wrapped body" $ do + let req = OS1Requests.previewTransform os1SampleTransform + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_transform", "_preview"] + -- Body wraps under "transform" key + let Just body = bhRequestBody req + LBS.unpack body `shouldSatisfy` L.isInfixOf "\"transform\"" + + it "deleteTransform DELETEs /_plugins/_transform/{id}" $ do + let req = OS1Requests.deleteTransform tid1 + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_transform", "t1"] + bhRequestBody req `shouldBe` Nothing + + it "OS1, OS2, OS3 produce identical paths and methods for every endpoint" $ do + let same = "same-id" + one = OS1Types.TransformId same + two = OS2Types.TransformId same + three = OS3Types.TransformId same + getRawEndpoint (bhRequestEndpoint (OS1Requests.deleteTransform one)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteTransform two)) + getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteTransform two)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteTransform three)) + bhRequestMethod (OS1Requests.startTransform one) + `shouldBe` bhRequestMethod (OS3Requests.startTransform three) + bhRequestMethod (OS1Requests.stopTransform one) + `shouldBe` bhRequestMethod (OS3Requests.stopTransform three) + + -- ======================================================================= + -- Live integration round-trip. Runs only against the matching + -- OS major version. The Transforms plugin ships with OS 1.0+. + -- ======================================================================= + describe "IndexTransforms plugin live round-trip" $ do + os1It <- runIO os1OnlyIT + os1It "create -> get -> preview -> start -> explain -> stop -> delete (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let sourceIdx = T.pack ("bloodhound_test_itf_src_os1_" <> suffix) + targetIdx = T.pack ("bloodhound_test_itf_tgt_os1_" <> suffix) + transformIdText = T.pack ("bloodhound_test_itf_t1_" <> suffix) + transformId = OS1Types.TransformId transformIdText + let Right sourceName = mkIndexName sourceIdx + Right targetName = mkIndexName targetIdx + bracket_ + (transformSetupIndex sourceName targetName) + ( do + void $ performBHRequest $ deleteIndex sourceName + void $ performBHRequest $ deleteIndex targetName + ) + $ do + let transform = + os1SampleTransform + { OS1Types.transformSourceIndex = sourceIdx, + OS1Types.transformTargetIndex = targetIdx, + OS1Types.transformDescription = Just "bloodhound live test" + } + createResp <- OS1Client.createTransform transformId transform + case createResp of + Left e -> + liftIO $ + expectationFailure + ("createTransform failed: " <> T.unpack (errorMessage e)) + Right _ -> do + getResp <- OS1Client.getTransform transformId + liftIO $ expectationFailureOnLeft getResp "getTransform failed:" + previewResp <- OS1Client.previewTransform transform + liftIO $ expectationFailureOnLeft previewResp "previewTransform failed:" + startResp <- OS1Client.startTransform transformId + liftIO $ expectationFailureOnLeft startResp "startTransform failed:" + explainResp <- OS1Client.explainTransform transformId + liftIO $ expectationFailureOnLeft explainResp "explainTransform failed:" + stopResp <- OS1Client.stopTransform transformId + liftIO $ expectationFailureOnLeft stopResp "stopTransform failed:" + delResp <- OS1Client.deleteTransform transformId + liftIO $ expectationFailureOnLeft delResp "deleteTransform failed:" + + os2It <- runIO os2OnlyIT + os2It "create -> get -> preview -> start -> explain -> stop -> delete (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let sourceIdx = T.pack ("bloodhound_test_itf_src_os2_" <> suffix) + targetIdx = T.pack ("bloodhound_test_itf_tgt_os2_" <> suffix) + transformIdText = T.pack ("bloodhound_test_itf_t2_" <> suffix) + transformId = OS2Types.TransformId transformIdText + let Right sourceName = mkIndexName sourceIdx + Right targetName = mkIndexName targetIdx + bracket_ + (transformSetupIndex sourceName targetName) + ( do + void $ performBHRequest $ deleteIndex sourceName + void $ performBHRequest $ deleteIndex targetName + ) + $ do + let transform = + OS2Types.Transform + { OS2Types.transformEnabled = Nothing, + OS2Types.transformContinuous = Nothing, + OS2Types.transformSchedule = + OS2Types.TransformScheduleInterval + OS2Types.TransformInterval + { OS2Types.transformIntervalPeriod = 1, + OS2Types.transformIntervalUnit = OS2Types.TransformPeriodUnitMinutes, + OS2Types.transformIntervalStartTime = Nothing + }, + OS2Types.transformDescription = Just "bloodhound live test", + OS2Types.transformMetadataId = Nothing, + OS2Types.transformSourceIndex = sourceIdx, + OS2Types.transformTargetIndex = targetIdx, + OS2Types.transformDataSelectionQuery = + object ["match_all" .= object []], + OS2Types.transformPageSize = 1, + OS2Types.transformGroups = + Just + [ OS2Types.TransformGroupTerms + OS2Types.TermsGroup + { OS2Types.termsGroupSourceField = "category", + OS2Types.termsGroupTargetField = Just "category_term", + OS2Types.termsGroupOther = Nothing + } + ], + OS2Types.transformAggregations = Nothing + } + createResp <- OS2Client.createTransform transformId transform + case createResp of + Left e -> + liftIO $ + expectationFailure + ("createTransform failed: " <> T.unpack (errorMessage e)) + Right _ -> do + getResp <- OS2Client.getTransform transformId + liftIO $ expectationFailureOnLeft getResp "getTransform failed:" + previewResp <- OS2Client.previewTransform transform + liftIO $ expectationFailureOnLeft previewResp "previewTransform failed:" + startResp <- OS2Client.startTransform transformId + liftIO $ expectationFailureOnLeft startResp "startTransform failed:" + explainResp <- OS2Client.explainTransform transformId + liftIO $ expectationFailureOnLeft explainResp "explainTransform failed:" + stopResp <- OS2Client.stopTransform transformId + liftIO $ expectationFailureOnLeft stopResp "stopTransform failed:" + delResp <- OS2Client.deleteTransform transformId + liftIO $ expectationFailureOnLeft delResp "deleteTransform failed:" + + os3It <- runIO os3OnlyIT + os3It "create -> get -> preview -> start -> explain -> stop -> delete (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let sourceIdx = T.pack ("bloodhound_test_itf_src_os3_" <> suffix) + targetIdx = T.pack ("bloodhound_test_itf_tgt_os3_" <> suffix) + transformIdText = T.pack ("bloodhound_test_itf_t3_" <> suffix) + transformId = OS3Types.TransformId transformIdText + let Right sourceName = mkIndexName sourceIdx + Right targetName = mkIndexName targetIdx + bracket_ + (transformSetupIndex sourceName targetName) + ( do + void $ performBHRequest $ deleteIndex sourceName + void $ performBHRequest $ deleteIndex targetName + ) + $ do + let transform = + OS3Types.Transform + { OS3Types.transformEnabled = Nothing, + OS3Types.transformContinuous = Nothing, + OS3Types.transformSchedule = + OS3Types.TransformScheduleInterval + OS3Types.TransformInterval + { OS3Types.transformIntervalPeriod = 1, + OS3Types.transformIntervalUnit = OS3Types.TransformPeriodUnitMinutes, + OS3Types.transformIntervalStartTime = Nothing + }, + OS3Types.transformDescription = Just "bloodhound live test", + OS3Types.transformMetadataId = Nothing, + OS3Types.transformSourceIndex = sourceIdx, + OS3Types.transformTargetIndex = targetIdx, + OS3Types.transformDataSelectionQuery = + object ["match_all" .= object []], + OS3Types.transformPageSize = 1, + OS3Types.transformGroups = + Just + [ OS3Types.TransformGroupTerms + OS3Types.TermsGroup + { OS3Types.termsGroupSourceField = "category", + OS3Types.termsGroupTargetField = Just "category_term", + OS3Types.termsGroupOther = Nothing + } + ], + OS3Types.transformAggregations = Nothing + } + createResp <- OS3Client.createTransform transformId transform + case createResp of + Left e -> + liftIO $ + expectationFailure + ("createTransform failed: " <> T.unpack (errorMessage e)) + Right _ -> do + getResp <- OS3Client.getTransform transformId + liftIO $ expectationFailureOnLeft getResp "getTransform failed:" + previewResp <- OS3Client.previewTransform transform + liftIO $ expectationFailureOnLeft previewResp "previewTransform failed:" + startResp <- OS3Client.startTransform transformId + liftIO $ expectationFailureOnLeft startResp "startTransform failed:" + explainResp <- OS3Client.explainTransform transformId + liftIO $ expectationFailureOnLeft explainResp "explainTransform failed:" + stopResp <- OS3Client.stopTransform transformId + liftIO $ expectationFailureOnLeft stopResp "stopTransform failed:" + delResp <- OS3Client.deleteTransform transformId + liftIO $ expectationFailureOnLeft delResp "deleteTransform failed:" + +-- | Create the source and target indexes, seed the source with a few +-- documents carrying a @category@ field, and refresh. The Transforms +-- plugin requires the source index to exist and to have at least one +-- document matching the @data_selection_query@ before it can preview +-- or run; we add three documents spanning two @category@ values so +-- the @terms@ group produces two buckets. +-- +-- The @category@ field is mapped explicitly as @keyword@ — the +-- Transforms plugin refuses to create a @terms@ group on a field that +-- has no aggregation-friendly mapping (auto-mapped @text@ does not +-- qualify). The target index is created with the same setting; the +-- plugin writes buckets keyed by the group's @target_field@. +transformSetupIndex :: IndexName -> IndexName -> BH IO () +transformSetupIndex sourceName targetName = do + void $ + performBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + sourceName + -- Map @category@ as keyword so the @terms@ group can aggregate on + -- it. The Transforms plugin rejects the create with + -- @Cannot find field [category] that can be grouped as [terms]@ + -- otherwise. + void $ + performBHRequest $ + putMapping @Value sourceName $ + object + [ "properties" + .= object + [ "category" .= object ["type" .= String "keyword"], + "value" .= object ["type" .= String "long"] + ] + ] + -- Target index may already need to exist for some plugin versions; + -- create it up front with the same settings so the start can write + -- to it. + void $ + performBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + targetName + let seedDoc cat value = + object ["category" .= String cat, "value" .= Number value] + void $ + performBHRequest $ + indexDocument + sourceName + defaultIndexDocumentSettings + (seedDoc "alpha" 1) + (DocId "1") + void $ + performBHRequest $ + indexDocument + sourceName + defaultIndexDocumentSettings + (seedDoc "alpha" 2) + (DocId "2") + void $ + performBHRequest $ + indexDocument + sourceName + defaultIndexDocumentSettings + (seedDoc "beta" 3) + (DocId "3") + void $ performBHRequest $ refreshIndex sourceName + pure () + +-- | Fail the test (with a prefix and the cluster error message) when a +-- 'ParsedEsResponse' is 'Left'. Used by the live lifecycle assertions. +expectationFailureOnLeft :: Either EsError a -> String -> IO () +expectationFailureOnLeft r prefix = + case r of + Left e -> expectationFailure (prefix <> " " <> T.unpack (errorMessage e)) + Right _ -> pure () diff --git a/tests/Test/IndicesSpec.hs b/tests/Test/IndicesSpec.hs --- a/tests/Test/IndicesSpec.hs +++ b/tests/Test/IndicesSpec.hs @@ -4,181 +4,2223 @@ module Test.IndicesSpec where -import qualified Data.List as L -import qualified Data.Map as M -import TestsUtils.Common -import TestsUtils.Import - -checkHasSettings :: [UpdatableIndexSetting] -> BH IO () -checkHasSettings settings = do - IndexSettingsSummary _ _ currentSettings <- performBHRequest $ getIndexSettings testIndex - liftIO $ L.intersect currentSettings settings `shouldBe` settings - -spec :: Spec -spec = do - describe "Index create/delete API" $ do - it "creates and then deletes the requested index" $ - withTestEnv $ do - -- priming state. - _ <- deleteExampleIndex - (resp, _) <- createExampleIndex - (deleteResp, _) <- deleteExampleIndex - liftIO $ do - validateStatus resp 200 - validateStatus deleteResp 200 - - describe "Index aliases" $ do - let aName = IndexAliasName ([qqIndexName|bloodhound-tests-twitter-1-alias|]) - let alias = IndexAlias testIndex aName - let create = IndexAliasCreate Nothing Nothing - let action = AddAlias alias create - it "handles the simple case of aliasing an existing index" $ do - withTestEnv $ do - resetIndex - (resp, _) <- performBHRequest $ keepBHResponse $ updateIndexAliases (action :| []) - liftIO $ validateStatus resp 200 - let cleanup = withTestEnv (performBHRequest $ updateIndexAliases (RemoveAlias alias :| [])) - ( do - IndexAliasesSummary summs <- withTestEnv (performBHRequest getIndexAliases) - let expected = IndexAliasSummary alias create - L.find ((== alias) . indexAliasSummaryAlias) summs `shouldBe` Just expected - ) - `finally` cleanup - it "allows alias deletion" $ do - IndexAliasesSummary summs <- withTestEnv $ do - resetIndex - (resp, _) <- performBHRequest $ keepBHResponse $ updateIndexAliases (action :| []) - liftIO $ validateStatus resp 200 - _ <- performBHRequest $ deleteIndexAlias aName - performBHRequest getIndexAliases - -- let expected = IndexAliasSummary alias create - L.find - ( (== aName) - . indexAlias - . indexAliasSummaryAlias - ) - summs - `shouldBe` Nothing - - describe "Index Listing" $ do - it "returns a list of index names" $ - withTestEnv $ do - _ <- createExampleIndex - ixns <- performBHRequest listIndices - liftIO (ixns `shouldContain` [testIndex]) - - describe "Index Settings" $ do - it "persists settings" $ - withTestEnv $ do - _ <- deleteExampleIndex - _ <- createExampleIndex - let updates = BlocksWrite False :| [] - (updateResp, _) <- performBHRequest $ keepBHResponse $ updateIndexSettings updates testIndex - liftIO $ validateStatus updateResp 200 - checkHasSettings [BlocksWrite False] - - it "allows total fields to be set" $ - withTestEnv $ do - _ <- deleteExampleIndex - _ <- createExampleIndex - let updates = MappingTotalFieldsLimit 2500 :| [] - (updateResp, _) <- performBHRequest $ keepBHResponse $ updateIndexSettings updates testIndex - liftIO $ validateStatus updateResp 200 - checkHasSettings [MappingTotalFieldsLimit 2500] - - it "allows unassigned.node_left.delayed_timeout to be set" $ - withTestEnv $ do - _ <- deleteExampleIndex - _ <- createExampleIndex - let updates = UnassignedNodeLeftDelayedTimeout 10 :| [] - (updateResp, _) <- performBHRequest $ keepBHResponse $ updateIndexSettings updates testIndex - liftIO $ validateStatus updateResp 200 - checkHasSettings [UnassignedNodeLeftDelayedTimeout 10] - - it "accepts customer analyzers" $ - withTestEnv $ do - _ <- deleteExampleIndex - let analysis = - Analysis - ( M.singleton - "ex_analyzer" - ( AnalyzerDefinition - (Just (Tokenizer "ex_tokenizer")) - ( map - TokenFilter - [ "ex_filter_lowercase", - "ex_filter_uppercase", - "ex_filter_apostrophe", - "ex_filter_reverse", - "ex_filter_snowball", - "ex_filter_shingle" - ] - ) - ( map - CharFilter - ["html_strip", "ex_mapping", "ex_pattern_replace"] - ) - ) - ) - ( M.singleton - "ex_tokenizer" - ( TokenizerDefinitionNgram - (Ngram 3 4 [TokenLetter, TokenDigit]) - ) - ) - ( M.fromList - [ ("ex_filter_lowercase", TokenFilterDefinitionLowercase (Just Greek)), - ("ex_filter_uppercase", TokenFilterDefinitionUppercase Nothing), - ("ex_filter_apostrophe", TokenFilterDefinitionApostrophe), - ("ex_filter_reverse", TokenFilterDefinitionReverse), - ("ex_filter_snowball", TokenFilterDefinitionSnowball English), - ("ex_filter_shingle", TokenFilterDefinitionShingle (Shingle 3 3 True False " " "_")), - ("ex_filter_stemmer", TokenFilterDefinitionStemmer German), - ("ex_filter_stop1", TokenFilterDefinitionStop (Left French)), - ( "ex_filter_stop2", - TokenFilterDefinitionStop - ( Right $ - map StopWord ["a", "is", "the"] - ) - ) - ] - ) - ( M.fromList - [ ("ex_mapping", CharFilterDefinitionMapping (M.singleton "١" "1")), - ("ex_pattern_replace", CharFilterDefinitionPatternReplace "(\\d+)-(?=\\d)" "$1_" Nothing) - ] - ) - updates = [AnalysisSetting analysis] - (createResp, _) <- performBHRequest $ keepBHResponse $ createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex - liftIO $ validateStatus createResp 200 - checkHasSettings updates - - it "accepts default compression codec" $ - withTestEnv $ do - _ <- deleteExampleIndex - let updates = [CompressionSetting CompressionDefault] - (createResp, _) <- performBHRequest $ keepBHResponse $ createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex - liftIO $ validateStatus createResp 200 - checkHasSettings updates - - it "accepts best compression codec" $ - withTestEnv $ do - _ <- deleteExampleIndex - let updates = [CompressionSetting CompressionBest] - (createResp, _) <- performBHRequest $ keepBHResponse $ createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex - liftIO $ validateStatus createResp 200 - checkHasSettings updates - - describe "Index Optimization" $ do - it "returns a successful response upon completion" $ - withTestEnv $ do - _ <- createExampleIndex - (resp, _) <- performBHRequest $ keepBHResponse $ forceMergeIndex (IndexList (testIndex :| [])) defaultForceMergeIndexSettings - liftIO $ validateStatus resp 200 - - describe "Index flushing" $ do - it "returns a successful response upon flushing" $ - withTestEnv $ do - _ <- createExampleIndex - (resp, _) <- performBHRequest $ keepBHResponse $ flushIndex testIndex - liftIO $ validateStatus resp 200 +import Control.Exception (finally) +import Control.Monad.Catch (bracket_) +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as BL8 +import Data.List qualified as L +import Data.Map qualified as M +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import TestsUtils.Common +import TestsUtils.Import + +checkHasSettings :: [UpdatableIndexSetting] -> BH IO () +checkHasSettings settings = do + IndexSettingsSummary _ _ currentSettings <- performBHRequest $ getIndexSettings testIndex + liftIO $ L.intersect currentSettings settings `shouldBe` settings + +-- | 'True' when the list contains a 'NumberOfReplicas' entry. Used to +-- verify the @GET /{index}@ parser filters it out of the updateable +-- settings list (it's already carried by 'indexReplicas'). +hasNumberOfReplicas :: [UpdatableIndexSetting] -> Bool +hasNumberOfReplicas = any isNumberOfReplicas + where + isNumberOfReplicas (NumberOfReplicas _) = True + isNumberOfReplicas _ = False + +-- | Navigate the @GET /{index}/_mapping@ response envelope +-- @{\: {mappings: {properties: {message: {type: ...}}}}}@ +-- and return the @type@ of the @message@ field. Used to verify +-- 'getMapping' round-trips a mapping installed with 'putMapping'. +extractMessageType :: Value -> Either String T.Text +extractMessageType = parseEither parser + where + parser = + withObject "mapping response" $ \top -> + case KM.elems top of + (idxBody : _) -> withObject "index body" indexBody idxBody + [] -> fail "empty mapping response" + indexBody body = do + mappings <- body .: "mappings" + props <- withObject "mappings" (.: "properties") mappings + fieldDef <- withObject "properties" (.: "message") props + withObject "message field" (.: "type") fieldDef + +-- | Navigate the @GET /{index}/_mapping/field/@ response envelope +-- @{\: {mappings: {\: {mapping: {\: {type: ...}}}}}}@ +-- and return the @type@ of the requested field. Used to verify +-- 'getFieldMapping' returns the per-field mapping it was asked for. +extractFieldMappingType :: T.Text -> Value -> Either String T.Text +extractFieldMappingType fieldName = parseEither parser + where + parser = + withObject "field mapping response" $ \top -> + case KM.elems top of + (idxBody : _) -> withObject "index body" indexBody idxBody + [] -> fail "empty field mapping response" + indexBody body = do + mappings <- body .: "mappings" + fieldDef <- withObject "mappings" (.: fromText fieldName) mappings + inner <- withObject "field envelope" (.: "mapping") fieldDef + leaf <- withObject "mapping blob" (.: fromText fieldName) inner + withObject "field type" (.: "type") leaf + +-- | First shard copy across all shard numbers in a segments response. +-- Used by the @GET /{index}/_segments@ spec to navigate the +-- @indices -> {: {shards: {: [, ...]}}}@ envelope. +firstShardCopy :: M.Map Text [IndexSegmentsShard] -> Maybe IndexSegmentsShard +firstShardCopy shardsMap = + case concat (M.elems shardsMap) of + (copy : _) -> Just copy + [] -> Nothing + +-- | First segment (by segment id) in a shard copy. +firstSegment :: IndexSegmentsShard -> Maybe SegmentInfo +firstSegment shardCopy = + case M.elems (indexSegmentsShardSegments shardCopy) of + (seg : _) -> Just seg + [] -> Nothing + +-- | First store copy across all shard numbers in a shard stores +-- response. Used by the @GET /{index}/_shard_stores@ spec to navigate +-- the @indices -> {: {shards: {: {stores: [, ...]}}}}@ +-- envelope. +firstShardStore :: M.Map Text ShardStoresShard -> Maybe ShardStore +firstShardStore shardsMap = + case concatMap shardStoresShardStores (M.elems shardsMap) of + (copy : _) -> Just copy + [] -> Nothing + +spec :: Spec +spec = do + describe "Index create/delete API" $ do + it "creates and then deletes the requested index" $ + withTestEnv $ do + -- priming state. + _ <- deleteExampleIndex + (resp, _) <- createExampleIndex + (deleteResp, _) <- deleteExampleIndex + liftIO $ do + validateStatus resp 200 + validateStatus deleteResp 200 + + describe "Index aliases" $ do + let aName = IndexAliasName ([qqIndexName|bloodhound-tests-twitter-1-alias|]) + let alias = IndexAlias testIndex aName + let create = defaultIndexAliasCreate + let action = AddAlias alias create + it "handles the simple case of aliasing an existing index" $ do + withTestEnv $ do + resetIndex + (resp, _) <- performBHRequest $ keepBHResponse $ updateIndexAliases (action :| []) + liftIO $ validateStatus resp 200 + let cleanup = withTestEnv (performBHRequest $ updateIndexAliases (RemoveAlias alias :| [])) + ( do + IndexAliasesSummary summs <- withTestEnv (performBHRequest getIndexAliases) + let expected = IndexAliasSummary alias create + L.find ((== alias) . indexAliasSummaryAlias) summs `shouldBe` Just expected + ) + `finally` cleanup + it "allows alias deletion" $ do + IndexAliasesSummary summs <- withTestEnv $ do + resetIndex + (resp, _) <- performBHRequest $ keepBHResponse $ updateIndexAliases (action :| []) + liftIO $ validateStatus resp 200 + _ <- performBHRequest $ deleteIndexAlias aName + performBHRequest getIndexAliases + -- let expected = IndexAliasSummary alias create + L.find + ( (== aName) + . indexAlias + . indexAliasSummaryAlias + ) + summs + `shouldBe` Nothing + + it "reports whether an alias exists (aliasExists)" $ do + withTestEnv $ do + resetIndex + (resp, _) <- performBHRequest $ keepBHResponse $ updateIndexAliases (action :| []) + liftIO $ validateStatus resp 200 + present <- performBHRequest $ aliasExists aName + absent <- performBHRequest $ aliasExists (IndexAliasName [qqIndexName|bloodhound-tests-no-such-alias|]) + liftIO $ do + present `shouldBe` True + absent `shouldBe` False + + it "creates a single alias via PUT /{index}/_alias/{name} (createIndexAlias)" $ do + withTestEnv $ do + resetIndex + let writeCreate = defaultIndexAliasCreate {aliasCreateIsWriteIndex = Just True} + resp <- performBHRequest $ createIndexAlias testIndex aName writeCreate + liftIO $ isAcknowledged resp `shouldBe` True + present <- performBHRequest $ aliasExists aName + liftIO $ present `shouldBe` True + IndexAliasesSummary summs <- performBHRequest getIndexAliases + let found = L.find ((== alias) . indexAliasSummaryAlias) summs + writeFlag = (aliasCreateIsWriteIndex . indexAliasSummaryCreate) <$> found + liftIO $ writeFlag `shouldBe` Just (Just True) + + it "round-trips is_write_index through updateIndexAliases and getIndexAliases" $ do + let writeCreate = defaultIndexAliasCreate {aliasCreateIsWriteIndex = Just True} + writeAction = AddAlias alias writeCreate + IndexAliasesSummary summs <- + ( do + withTestEnv $ do + resetIndex + (resp, _) <- performBHRequest $ keepBHResponse $ updateIndexAliases (writeAction :| []) + liftIO $ validateStatus resp 200 + performBHRequest getIndexAliases + ) + `finally` withTestEnv (performBHRequest $ updateIndexAliases (RemoveAlias alias :| [])) + let found = L.find ((== alias) . indexAliasSummaryAlias) summs + writeFlag = aliasCreateIsWriteIndex . indexAliasSummaryCreate <$> found + writeFlag `shouldBe` Just (Just True) + + it "accepts master_timeout on updateIndexAliasesWith" $ do + let opts = defaultUpdateAliasesOptions {uaoMasterTimeout = Just (TimeUnitSeconds, 1)} + withTestEnv $ do + resetIndex + (resp, _) <- + performBHRequest $ + keepBHResponse $ + updateIndexAliasesWith opts (action :| []) + liftIO $ validateStatus resp 200 + _ <- performBHRequest $ updateIndexAliases (RemoveAlias alias :| []) + pure () + + it "deleteIndexAliasFrom only detaches the alias from the named source index" $ + let otherSrc = [qqIndexName|bloodhound-tests-delete-alias-from-other|] + otherAlias = IndexAlias otherSrc aName + addOther = AddAlias otherAlias create + in ( do + IndexAliasesSummary summs <- + withTestEnv $ do + resetIndex + _ <- tryEsError $ performBHRequest $ deleteIndex otherSrc + _ <- performBHRequest $ createIndex defaultIndexSettings otherSrc + _ <- performBHRequest $ updateIndexAliases (action :| []) + _ <- performBHRequest $ updateIndexAliases (addOther :| []) + _ <- performBHRequest $ deleteIndexAliasFrom testIndex aName + performBHRequest getIndexAliases + -- The alias should no longer be attached to @testIndex@... + let onTest = L.find (\s -> indexAliasSummaryAlias s == alias) summs + onTest `shouldBe` Nothing + -- ...but it should still be attached to @otherSrc@. + let onOther = L.find (\s -> indexAliasSummaryAlias s == otherAlias) summs + onOther `shouldSatisfy` isJust + ) + `finally` withTestEnv (tryEsError $ performBHRequest $ deleteIndex otherSrc) + + it "GET /{index}/_alias/{name} (getIndexAlias) returns the named alias" $ + let otherAName = IndexAliasName [qqIndexName|bloodhound-tests-get-index-alias-just-other|] + in ( do + IndexAliasesInfo summs <- + withTestEnv $ do + resetIndex + resp <- performBHRequest $ createIndexAlias testIndex aName create + liftIO $ isAcknowledged resp `shouldBe` True + -- Attach a second alias to the same index so the + -- @(Just name)@ branch is observed to filter, not + -- just to mirror the @Nothing@ payload. + _ <- performBHRequest $ createIndexAlias testIndex otherAName create + performBHRequest $ + getIndexAlias testIndex (Just (indexAliasNameToAliasName aName)) + let found = indexAlias . indexAliasSummaryAlias <$> summs + liftIO $ do + aName `shouldSatisfy` (`elem` found) + -- The other alias must NOT appear: proves the filter + -- narrowed to the requested name. + otherAName `shouldNotSatisfy` (`elem` found) + ) + `finally` withTestEnv + ( do + _ <- tryEsError $ performBHRequest $ deleteIndexAlias aName + _ <- tryEsError $ performBHRequest $ deleteIndexAlias otherAName + pure () + ) + + it "GET /{index}/_alias (getIndexAlias Nothing) lists every alias on the index" $ + let otherAName = IndexAliasName [qqIndexName|bloodhound-tests-get-index-alias-list-other|] + otherAlias = IndexAlias testIndex otherAName + in ( do + IndexAliasesInfo summs <- + withTestEnv $ do + resetIndex + _ <- performBHRequest $ createIndexAlias testIndex aName create + _ <- performBHRequest $ createIndexAlias testIndex otherAName create + performBHRequest $ getIndexAlias testIndex Nothing + let names = indexAlias . indexAliasSummaryAlias <$> summs + liftIO $ do + aName `shouldSatisfy` (`elem` names) + otherAName `shouldSatisfy` (`elem` names) + ) + `finally` withTestEnv + ( do + _ <- tryEsError $ performBHRequest $ deleteIndexAlias aName + _ <- tryEsError $ performBHRequest $ deleteIndexAlias otherAName + pure () + ) + + it "getIndexAlias surfaces 404 as EsError when the named alias is absent" $ do + result <- + withTestEnv $ + tryEsError + ( performBHRequest $ + getIndexAlias + testIndex + (Just (AliasName [qqIndexName|bloodhound-tests-no-such-alias|])) + ) + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected EsError for missing alias, got success" + + it "getIndexAlias surfaces 404 as EsError when the index is absent" $ do + result <- + withTestEnv $ + tryEsError + ( performBHRequest $ + getIndexAlias + [qqIndexName|bloodhound-no-such-index-04f-2-18-3|] + (Just (AliasName [qqIndexName|bloodhound-tests-no-such-alias|])) + ) + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected EsError for missing index, got success" + + describe "Index Listing" $ do + it "returns a list of index names" $ + withTestEnv $ do + _ <- createExampleIndex + ixns <- performBHRequest listIndices + liftIO (ixns `shouldContain` [testIndex]) + + describe "Index Settings" $ do + it "persists settings" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let updates = BlocksWrite False :| [] + (updateResp, _) <- performBHRequest $ keepBHResponse $ updateIndexSettings updates testIndex + liftIO $ validateStatus updateResp 200 + checkHasSettings [BlocksWrite False] + + it "allows total fields to be set" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let updates = MappingTotalFieldsLimit 2500 :| [] + (updateResp, _) <- performBHRequest $ keepBHResponse $ updateIndexSettings updates testIndex + liftIO $ validateStatus updateResp 200 + checkHasSettings [MappingTotalFieldsLimit 2500] + + it "allows unassigned.node_left.delayed_timeout to be set" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let updates = UnassignedNodeLeftDelayedTimeout 10 :| [] + (updateResp, _) <- performBHRequest $ keepBHResponse $ updateIndexSettings updates testIndex + liftIO $ validateStatus updateResp 200 + checkHasSettings [UnassignedNodeLeftDelayedTimeout 10] + + it "accepts customer analyzers" $ + withTestEnv $ do + _ <- deleteExampleIndex + let analysis = + Analysis + ( M.singleton + "ex_analyzer" + ( AnalyzerDefinition + (Just (Tokenizer "ex_tokenizer")) + ( map + TokenFilter + [ "ex_filter_lowercase", + "ex_filter_uppercase", + "ex_filter_apostrophe", + "ex_filter_reverse", + "ex_filter_snowball", + "ex_filter_shingle" + ] + ) + ( map + CharFilter + ["html_strip", "ex_mapping", "ex_pattern_replace"] + ) + ) + ) + ( M.singleton + "ex_tokenizer" + ( TokenizerDefinitionNgram + (Ngram 3 4 [TokenLetter, TokenDigit]) + ) + ) + ( M.fromList + [ ("ex_filter_lowercase", TokenFilterDefinitionLowercase (Just Greek)), + ("ex_filter_uppercase", TokenFilterDefinitionUppercase Nothing), + ("ex_filter_apostrophe", TokenFilterDefinitionApostrophe), + ("ex_filter_reverse", TokenFilterDefinitionReverse), + ("ex_filter_snowball", TokenFilterDefinitionSnowball English), + ("ex_filter_shingle", TokenFilterDefinitionShingle (Shingle 3 3 True False " " "_")), + ("ex_filter_stemmer", TokenFilterDefinitionStemmer German), + ("ex_filter_stop1", TokenFilterDefinitionStop (Left French)), + ( "ex_filter_stop2", + TokenFilterDefinitionStop + ( Right $ + map StopWord ["a", "is", "the"] + ) + ) + ] + ) + ( M.fromList + [ ("ex_mapping", CharFilterDefinitionMapping (M.singleton "١" "1")), + ("ex_pattern_replace", CharFilterDefinitionPatternReplace "(\\d+)-(?=\\d)" "$1_" Nothing) + ] + ) + updates = [AnalysisSetting analysis] + (createResp, _) <- performBHRequest $ keepBHResponse $ createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex + liftIO $ validateStatus createResp 200 + checkHasSettings updates + + it "accepts default compression codec" $ + withTestEnv $ do + _ <- deleteExampleIndex + let updates = [CompressionSetting CompressionDefault] + (createResp, _) <- performBHRequest $ keepBHResponse $ createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex + liftIO $ validateStatus createResp 200 + checkHasSettings updates + + it "accepts best compression codec" $ + withTestEnv $ do + _ <- deleteExampleIndex + let updates = [CompressionSetting CompressionBest] + (createResp, _) <- performBHRequest $ keepBHResponse $ createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex + liftIO $ validateStatus createResp 200 + checkHasSettings updates + + it "updateIndexSettingsWith accepts master_timeout and preserve_existing" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let opts = + defaultUpdateIndexSettingsOptions + { uisoMasterTimeout = Just (TimeUnitSeconds, 30), + uisoPreserveExisting = Just True + } + updates = BlocksWrite False :| [] + (updateResp, _) <- + performBHRequest $ + keepBHResponse $ + updateIndexSettingsWith updates testIndex opts + liftIO $ validateStatus updateResp 200 + checkHasSettings [BlocksWrite False] + + it "updateIndexSettingsWith with defaultUpdateIndexSettingsOptions matches updateIndexSettings" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let updates = BlocksWrite False :| [] + (updateResp, _) <- + performBHRequest $ + keepBHResponse $ + updateIndexSettingsWith updates testIndex defaultUpdateIndexSettingsOptions + liftIO $ validateStatus updateResp 200 + checkHasSettings [BlocksWrite False] + + it "getIndexSettingsWith accepts include_defaults and parses the response" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let opts = + defaultGetIndexSettingsOptions + { gisoIncludeDefaults = Just True + } + -- Discard all fields: this test only asserts that the response + -- (with include_defaults=true) decodes successfully. + IndexSettingsSummary _ _ _ <- performBHRequest $ getIndexSettingsWith testIndex opts + pure () + + it "getIndexSettingsWith with defaultGetIndexSettingsOptions matches getIndexSettings" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + IndexSettingsSummary _ _ a <- performBHRequest $ getIndexSettings testIndex + IndexSettingsSummary _ _ b <- performBHRequest $ getIndexSettingsWith testIndex defaultGetIndexSettingsOptions + liftIO $ a `shouldBe` b + + -- Verifies a dynamic per-index setting from the modern set added in + -- bloodhound-04f.7.14 round-trips through the Index API. index.priority + -- is chosen because it is documented as dynamic and accepted by all ES + -- versions Bloodhound supports. + it "accepts index.priority" $ + withTestEnv $ do + _ <- deleteExampleIndex + let updates = [IndexPriority 5] + (createResp, _) <- performBHRequest $ keepBHResponse $ createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex + liftIO $ validateStatus createResp 200 + checkHasSettings updates + + -- Verifies a search-slowlog threshold from the modern set added in + -- bloodhound-04f.7.14 round-trips through the Index API. Uses the + -- query-phase path (ES splits the search slowlog into query/fetch + -- phases). Slowlog thresholds are dynamic since ES 7.x. + it "accepts index.search.slowlog.threshold.query.warn" $ + withTestEnv $ do + _ <- deleteExampleIndex + let updates = [SearchSlowlogThresholdQueryWarn (EsDuration 10 TimeUnitSeconds)] + (createResp, _) <- performBHRequest $ keepBHResponse $ createIndexWith (updates ++ [NumberOfReplicas (ReplicaCount 0)]) 1 testIndex + liftIO $ validateStatus createResp 200 + checkHasSettings updates + + -- ------------------------------------------------------------------ -- + -- Modern dynamic settings (bloodhound-04f.7.14) -- + -- Each is set via PUT /{index}/_settings and read back with -- + -- GET /{index}/_settings. ES returns leaf values as strings; the -- + -- 'unStringlyTypeJSON' fallback in the 'FromJSON' parser handles -- + -- the Bool/Int round-trip transparently. -- + -- ------------------------------------------------------------------ -- + describe "Index Settings (modern dynamic settings)" $ do + it "persists index.search.idle.after" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let updates = IndexSearchIdleAfter (EsDuration 60 TimeUnitSeconds) :| [] + (updateResp, _) <- performBHRequest $ keepBHResponse $ updateIndexSettings updates testIndex + liftIO $ validateStatus updateResp 200 + checkHasSettings [IndexSearchIdleAfter (EsDuration 60 TimeUnitSeconds)] + + it "persists index.requests.cache.enable" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let updates = RequestsCacheEnable True :| [] + (updateResp, _) <- performBHRequest $ keepBHResponse $ updateIndexSettings updates testIndex + liftIO $ validateStatus updateResp 200 + checkHasSettings [RequestsCacheEnable True] + + it "persists index.priority" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let updates = IndexPriority 42 :| [] + (updateResp, _) <- performBHRequest $ keepBHResponse $ updateIndexSettings updates testIndex + liftIO $ validateStatus updateResp 200 + checkHasSettings [IndexPriority 42] + + it "persists index.hidden" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let updates = IndexHidden True :| [] + (updateResp, _) <- performBHRequest $ keepBHResponse $ updateIndexSettings updates testIndex + liftIO $ validateStatus updateResp 200 + checkHasSettings [IndexHidden True] + + it "persists a search slowlog threshold (query.warn = 200ms)" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let setting = SearchSlowlogThresholdQueryWarn (EsDuration 200 TimeUnitMilliseconds) + updates = setting :| [] + (updateResp, _) <- performBHRequest $ keepBHResponse $ updateIndexSettings updates testIndex + liftIO $ validateStatus updateResp 200 + checkHasSettings [setting] + + it "persists an indexing slowlog threshold (index.info = 1s)" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let setting = IndexingSlowlogThresholdIndexInfo (EsDuration 1 TimeUnitSeconds) + updates = setting :| [] + (updateResp, _) <- performBHRequest $ keepBHResponse $ updateIndexSettings updates testIndex + liftIO $ validateStatus updateResp 200 + checkHasSettings [setting] + + describe "Index Settings (modern constructors, pure JSON round-trip)" $ do + -- Pure encode/decode pinning the exact wire shape — exercised for + -- every constructor via propApproxJSON in Test/JSONSpec.hs; these + -- 'it' cases lock representative wire paths so a path rename is + -- caught as a readable failure, not a QuickCheck shrink-sequence. + let encEq :: (ToJSON a) => a -> BL8.ByteString -> Expectation + encEq x expected = encode x `shouldBe` expected + decRoundTrip :: (Eq a, Show a, FromJSON a, ToJSON a) => a -> Expectation + decRoundTrip x = decode (encode x) `shouldBe` Just x + + it "encodes IndexPriority at index.priority" $ + encEq (IndexPriority 42) "{\"index\":{\"priority\":42}}" + it "round-trips IndexPriority" $ decRoundTrip (IndexPriority 42) + + it "encodes IndexHidden at index.hidden" $ + encEq (IndexHidden True) "{\"index\":{\"hidden\":true}}" + it "round-trips IndexHidden" $ decRoundTrip (IndexHidden True) + + it "encodes RequestsCacheEnable at index.requests.cache.enable" $ + encEq (RequestsCacheEnable True) "{\"index\":{\"requests\":{\"cache\":{\"enable\":true}}}}" + it "round-trips RequestsCacheEnable" $ decRoundTrip (RequestsCacheEnable True) + + it "encodes BlocksReadOnlyAllowDelete at index.blocks.read_only_allow_delete" $ + encEq (BlocksReadOnlyAllowDelete True) "{\"index\":{\"blocks\":{\"read_only_allow_delete\":true}}}" + it "round-trips BlocksReadOnlyAllowDelete" $ decRoundTrip (BlocksReadOnlyAllowDelete True) + + -- Pins the bloodhound-442 fix: the four sibling Blocks* renderers + -- emit the same index.blocks.X form. Without these goldens a path + -- rename would surface only as a QuickCheck shrink-sequence, not + -- a readable failure (cf. the comment opening this describe block). + it "encodes BlocksReadOnly at index.blocks.read_only" $ + encEq (BlocksReadOnly True) "{\"index\":{\"blocks\":{\"read_only\":true}}}" + it "round-trips BlocksReadOnly" $ decRoundTrip (BlocksReadOnly True) + + it "encodes BlocksRead at index.blocks.read" $ + encEq (BlocksRead True) "{\"index\":{\"blocks\":{\"read\":true}}}" + it "round-trips BlocksRead" $ decRoundTrip (BlocksRead True) + + it "encodes BlocksWrite at index.blocks.write" $ + encEq (BlocksWrite True) "{\"index\":{\"blocks\":{\"write\":true}}}" + it "round-trips BlocksWrite" $ decRoundTrip (BlocksWrite True) + + it "encodes BlocksMetaData at index.blocks.metadata" $ + encEq (BlocksMetaData True) "{\"index\":{\"blocks\":{\"metadata\":true}}}" + it "round-trips BlocksMetaData" $ decRoundTrip (BlocksMetaData True) + + it "encodes IndexSearchIdleAfter with a string duration at index.search.idle.after" $ + encEq + (IndexSearchIdleAfter (EsDuration 30 TimeUnitSeconds)) + "{\"index\":{\"search\":{\"idle\":{\"after\":\"30s\"}}}}" + it "round-trips IndexSearchIdleAfter" $ + decRoundTrip (IndexSearchIdleAfter (EsDuration 30 TimeUnitSeconds)) + + it "encodes a percent disk watermark at the low water mark" $ + encEq + (RoutingAllocationDiskWatermarkLow (DiskWatermarkPercent 85)) + "{\"index\":{\"routing\":{\"allocation\":{\"disk\":{\"watermark\":{\"low\":\"85.0%\"}}}}}}" + it "encodes a byte disk watermark at the high water mark" $ + encEq + (RoutingAllocationDiskWatermarkHigh (DiskWatermarkBytes (Bytes 5000))) + "{\"index\":{\"routing\":{\"allocation\":{\"disk\":{\"watermark\":{\"high\":\"5000b\"}}}}}}" + it "round-trips both disk watermark forms" $ do + decRoundTrip (RoutingAllocationDiskWatermarkFloodStage (DiskWatermarkPercent 95)) + decRoundTrip (RoutingAllocationDiskWatermarkFloodStage (DiskWatermarkBytes (Bytes 1024))) + + it "encodes a search slowlog threshold at the deep query.warn path" $ + encEq + (SearchSlowlogThresholdQueryWarn (EsDuration 200 TimeUnitMilliseconds)) + "{\"index\":{\"search\":{\"slowlog\":{\"threshold\":{\"query\":{\"warn\":\"200ms\"}}}}}}" + it "encodes an indexing slowlog threshold at the deep index.info path" $ + encEq + (IndexingSlowlogThresholdIndexInfo (EsDuration 5 TimeUnitSeconds)) + "{\"index\":{\"indexing\":{\"slowlog\":{\"threshold\":{\"index\":{\"info\":\"5s\"}}}}}}" + + it "decodes the search slowlog threshold from the wire path" $ + decode + "{\"index\":{\"search\":{\"slowlog\":{\"threshold\":{\"fetch\":{\"trace\":\"500ms\"}}}}}}" + `shouldBe` Just (SearchSlowlogThresholdFetchTrace (EsDuration 500 TimeUnitMilliseconds)) + + it "round-trips every slowlog threshold constructor" $ do + decRoundTrip (SearchSlowlogThresholdQueryWarn (EsDuration 1 TimeUnitMilliseconds)) + decRoundTrip (SearchSlowlogThresholdFetchInfo (EsDuration 2 TimeUnitSeconds)) + decRoundTrip (IndexingSlowlogThresholdIndexDebug (EsDuration 3 TimeUnitMilliseconds)) + + -- Disk watermarks are NOT exercised by a live integration test: + -- @index.routing.allocation.disk.watermark.*@ can be refused by the + -- per-index @/_settings@ API on some backends (they are + -- cluster-level allocation settings). The constructors are + -- round-tripped purely above and covered by propApproxJSON. + + describe "Compression codec (pure)" $ do + -- CompressionDefault / CompressionBest are exercised by the live + -- "Index Settings" block above; CompressionZstd is unit-only because + -- the ES test backend does not accept it (zstd is OpenSearch-native). + it "encodes default/best/zstd" $ do + encode CompressionDefault `shouldBe` "\"default\"" + encode CompressionBest `shouldBe` "\"best_compression\"" + encode CompressionZstd `shouldBe` "\"zstd\"" + it "decodes all three codec names" $ do + decode "\"default\"" `shouldBe` Just CompressionDefault + decode "\"best_compression\"" `shouldBe` Just CompressionBest + decode "\"zstd\"" `shouldBe` Just CompressionZstd + it "rejects an unknown codec" $ + (decode "\"lz4\"" :: Maybe Compression) `shouldBe` Nothing + + describe "EsDuration / DiskWatermark (pure)" $ do + it "renders every TimeUnits suffix" $ do + renderEsDuration (EsDuration 5 TimeUnitMilliseconds) `shouldBe` "5ms" + renderEsDuration (EsDuration 5 TimeUnitMicroseconds) `shouldBe` "5micros" + renderEsDuration (EsDuration 5 TimeUnitNanoseconds) `shouldBe` "5nanos" + renderEsDuration (EsDuration 5 TimeUnitSeconds) `shouldBe` "5s" + it "parses ms before s (200ms is milliseconds, not 200m+s)" $ + decode "\"200ms\"" `shouldBe` Just (EsDuration 200 TimeUnitMilliseconds) + it "parses bare seconds" $ + decode "\"5s\"" `shouldBe` Just (EsDuration 5 TimeUnitSeconds) + it "parses a percent watermark" $ + decode "\"85%\"" `shouldBe` Just (DiskWatermarkPercent 85) + it "parses a byte-size watermark (gb)" $ + decode "\"500gb\"" `shouldBe` Just (DiskWatermarkBytes (Bytes 500000000000)) + it "parses a bare-bytes watermark (b suffix)" $ + decode "\"1024b\"" `shouldBe` Just (DiskWatermarkBytes (Bytes 1024)) + it "rejects an unparseable duration" $ + (decode "\"abc\"" :: Maybe EsDuration) `shouldBe` Nothing + + describe "GET /{index} (getIndex)" $ do + it "returns the requested index name, settings and mappings" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- performBHRequest $ putMapping @Value testIndex TweetMapping + info <- performBHRequest $ getIndex testIndex + liftIO $ do + iiIndexName info `shouldBe` testIndex + -- putMapping in resetIndex uses ShardCount 1 / ReplicaCount 0 + -- (see TestsUtils.Common.createExampleIndex). + indexShards (iiFixedSettings info) `shouldBe` ShardCount 1 + indexReplicas (iiFixedSettings info) `shouldBe` ReplicaCount 0 + -- mappings block should be present and an object, not Null + case iiMappings info of + Object _ -> pure () + other -> expectationFailure $ "expected mappings object, got " <> show other + -- NumberOfReplicas is filtered out of the updateable list + -- because it is already carried by iiFixedSettings.indexReplicas. + hasNumberOfReplicas (iiUpdateableSettings info) `shouldBe` False + + it "returns an empty aliases list for a fresh index" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + info <- performBHRequest $ getIndex testIndex + liftIO $ iiAliases info `shouldBe` [] + + it "includes aliases added via updateIndexAliases" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let aName = IndexAliasName [qqIndexName|bloodhound-tests-getindex-alias|] + let alias = IndexAlias testIndex aName + let create = defaultIndexAliasCreate + _ <- performBHRequest $ keepBHResponse $ updateIndexAliases (AddAlias alias create :| []) + info <- performBHRequest $ getIndex testIndex + liftIO $ do + length (iiAliases info) `shouldBe` 1 + let summary = case iiAliases info of + (s : _) -> Just s + [] -> Nothing + (indexAliasSummaryAlias <$> summary) `shouldBe` Just alias + + it "surfaces server-side errors (404) for a non-existent index" $ do + result <- + withTestEnv $ + tryEsError (performBHRequest $ getIndex [qqIndexName|bloodhound-no-such-index-04f-2-1|]) + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected EsError for missing index, got success" + + describe "GET /{index}/_mapping (getMapping)" $ do + it "round-trips a mapping installed with putMapping" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- performBHRequest $ putMapping @Value testIndex TweetMapping + mapping <- performBHRequest $ getMapping @Value testIndex + case extractMessageType mapping of + Right t -> liftIO $ t `shouldBe` "text" + Left e -> liftIO $ expectationFailure $ "getMapping response did not decode: " <> e + + it "surfaces server-side errors (404) for a non-existent index" $ do + result <- + withTestEnv $ + tryEsError (performBHRequest $ getMapping @Value [qqIndexName|bloodhound-no-such-index-04f-2-2|]) + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected EsError for missing index, got success" + + describe "GET /{index}/_mapping/field/{fields} (getFieldMapping)" $ do + it "returns the type of a single requested field" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- performBHRequest $ putMapping @Value testIndex TweetMapping + mapping <- performBHRequest $ getFieldMapping @Value testIndex [FieldName "message"] + case extractFieldMappingType "message" mapping of + Right t -> liftIO $ t `shouldBe` "text" + Left e -> liftIO $ expectationFailure $ "getFieldMapping response did not decode: " <> e + + it "decodes multiple requested fields" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- performBHRequest $ putMapping @Value testIndex TweetMapping + mapping <- + performBHRequest $ + getFieldMapping + @Value + testIndex + [FieldName "user", FieldName "age"] + case (extractFieldMappingType "user" mapping, extractFieldMappingType "age" mapping) of + (Right tu, Right ta) -> liftIO $ do + tu `shouldBe` "text" + ta `shouldBe` "integer" + (Left e, _) -> liftIO $ expectationFailure $ "user field not decoded: " <> e + (_, Left e) -> liftIO $ expectationFailure $ "age field not decoded: " <> e + + it "decodes into the typed FieldMappingResponse" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- performBHRequest $ putMapping @Value testIndex TweetMapping + resp <- performBHRequest $ getFieldMapping @FieldMappingResponse testIndex [FieldName "message"] + case M.lookup testIndex (fieldMappingResponseIndices resp) of + Nothing -> liftIO $ expectationFailure "expected an entry for the test index" + Just entry -> case M.lookup "message" (fieldMappingIndexEntryFields entry) of + Nothing -> liftIO $ expectationFailure "expected a 'message' field entry" + Just detail -> + liftIO $ fieldMappingDetailFullName detail `shouldBe` "message" + + it "expands wildcards and returns every matching field" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- performBHRequest $ putMapping @Value testIndex TweetMapping + resp <- performBHRequest $ getFieldMapping @FieldMappingResponse testIndex [FieldName "*"] + case M.lookup testIndex (fieldMappingResponseIndices resp) of + Nothing -> liftIO $ expectationFailure "expected an entry for the test index" + Just entry -> + liftIO $ + M.member "message" (fieldMappingIndexEntryFields entry) + `shouldBe` True + + it "surfaces server-side errors (404) for a non-existent index" $ do + result <- + withTestEnv $ + tryEsError + ( performBHRequest $ + getFieldMapping + @Value + [qqIndexName|bloodhound-no-such-index-04f-2-3|] + [FieldName "message"] + ) + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected EsError for missing index, got success" + + describe "Index Optimization" $ do + it "returns a successful response upon completion" $ + withTestEnv $ do + _ <- createExampleIndex + (resp, _) <- performBHRequest $ keepBHResponse $ forceMergeIndex (IndexList (testIndex :| [])) defaultForceMergeIndexSettings + liftIO $ validateStatus resp 200 + + describe "Index flushing" $ do + it "returns a successful response upon flushing" $ + withTestEnv $ do + _ <- createExampleIndex + (resp, _) <- performBHRequest $ keepBHResponse $ flushIndex testIndex + liftIO $ validateStatus resp 200 + + -- Regression guard for bloodhound-04f.2.19: flushIndex used to be + -- typed as 'BHRequest StatusDependant ShardResult', but the real + -- ES/OS response is the @_shards@ envelope. The old 'ShardResult' + -- parser silently decoded every field to 0, hiding real shard + -- counts. Asserting @shardTotal >= 1@ here is the minimum check + -- that catches the silent-zero regression on a live cluster. + it "parses the {_shards: ...} envelope from _flush" $ + withTestEnv $ do + _ <- createExampleIndex + ShardsResult shardResult <- performBHRequest $ flushIndex testIndex + liftIO $ do + shardTotal shardResult `shouldSatisfy` (>= 1) + shardsFailed shardResult `shouldBe` 0 + + -- Mirror of the _flush guard above for 'refreshIndex'. Same parser + -- (@FromJSON ShardsResult@), same envelope shape, separate endpoint + -- so a regression on either path surfaces independently. + it "parses the {_shards: ...} envelope from _refresh" $ + withTestEnv $ do + _ <- createExampleIndex + ShardsResult shardResult <- performBHRequest $ refreshIndex testIndex + liftIO $ do + shardTotal shardResult `shouldSatisfy` (>= 1) + shardsFailed shardResult `shouldBe` 0 + + -- Pure unit test (no ES round-trip): locks the 'FromJSON ShardsResult' + -- decoder against the actual wire shape returned by + -- @POST //_flush@ and @POST //_refresh@, so the + -- silent-zero regression cannot sneak back in without a test failure + -- even when no cluster is reachable. + it "FromJSON ShardsResult decodes the {_shards: ...} envelope from _flush/_refresh" $ do + let payload = BL8.pack "{\"_shards\":{\"total\":2,\"successful\":2,\"skipped\":0,\"failed\":0}}" + decoded = decode payload :: Maybe ShardsResult + decoded `shouldBe` Just (ShardsResult (ShardResult 2 2 0 0)) + + describe "Index cache clearing" $ do + it "returns a successful response upon clearing the cache" $ + withTestEnv $ do + _ <- createExampleIndex + (resp, _) <- performBHRequest $ keepBHResponse $ clearIndexCache testIndex + liftIO $ validateStatus resp 200 + it "parses the {_shards: ...} envelope into ShardsResult" $ + withTestEnv $ do + _ <- createExampleIndex + ShardsResult shardResult <- performBHRequest $ clearIndexCache testIndex + liftIO $ shardsSuccessful shardResult `shouldSatisfy` (>= 0) + + -- ------------------------------------------------------------------ -- + -- createIndexOptions: body fields + URI params (bloodhound-04f.7.11) -- + -- ------------------------------------------------------------------ -- + describe "createIndexOptions URI param rendering" $ do + -- Pure unit tests (no ES required) — modelled after + -- Test/SearchOptionsSpec.hs. + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultCreateIndexOptions emits no params" $ + createIndexOptionsParams defaultCreateIndexOptions + `shouldBe` [] + + it "renders AllActiveShards as \"all\"" $ do + let opts = defaultCreateIndexOptions {cioWaitForActiveShards = Just AllActiveShards} + createIndexOptionsParams opts + `shouldBe` [("wait_for_active_shards", Just "all")] + + it "renders ActiveShards as the bare decimal" $ do + let opts = defaultCreateIndexOptions {cioWaitForActiveShards = Just (ActiveShards 3)} + createIndexOptionsParams opts + `shouldBe` [("wait_for_active_shards", Just "3")] + + it "renders master_timeout and timeout as " $ do + let opts = + defaultCreateIndexOptions + { cioMasterTimeout = Just (TimeUnitSeconds, 30), + cioTimeout = Just (TimeUnitMilliseconds, 500) + } + normalize (createIndexOptionsParams opts) + `shouldBe` [ ("master_timeout", Just "30s"), + ("timeout", Just "500ms") + ] + + it "emits every param together when all are set" $ do + let opts = + defaultCreateIndexOptions + { cioWaitForActiveShards = Just AllActiveShards, + cioMasterTimeout = Just (TimeUnitMinutes, 1), + cioTimeout = Just (TimeUnitSeconds, 10) + } + normalize (createIndexOptionsParams opts) + `shouldBe` [ ("master_timeout", Just "1m"), + ("timeout", Just "10s"), + ("wait_for_active_shards", Just "all") + ] + + describe "createIndexOptions body rendering" $ do + -- Pure unit tests for the body builder. We compare decoded JSON + -- (not raw bytes) because 'deepMerge' does not guarantee key order. + let decodedKeys :: Maybe Value -> Maybe [T.Text] + decodedKeys (Just (Object o)) = Just (L.sort (toText <$> KM.keys o)) + decodedKeys _ = Nothing + + it "defaultCreateIndexOptions produces no body" $ + createIndexOptionsBody defaultCreateIndexOptions + `shouldBe` Nothing + + it "cioSettings alone matches the legacy createIndex body" $ do + let settings = IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits + let opts = defaultCreateIndexOptions {cioSettings = Just settings} + createIndexOptionsBody opts + `shouldBe` Just (encode settings) + + it "cioMappings alone produces a body with only the mappings key" $ do + let mapping = object ["properties" .= object ["user" .= object ["type" .= ("keyword" :: T.Text)]]] + let opts = defaultCreateIndexOptions {cioMappings = Just mapping} + decodedKeys (decode =<< createIndexOptionsBody opts) + `shouldBe` Just ["mappings"] + + it "cioAliases alone produces a body with only the aliases key" $ do + let aliases = KM.singleton "bloodhound-tests-twitter-1-alias" (object []) + let opts = defaultCreateIndexOptions {cioAliases = Just aliases} + decodedKeys (decode =<< createIndexOptionsBody opts) + `shouldBe` Just ["aliases"] + + it "merges settings + mappings + aliases into one object" $ do + let settings = IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits + let mapping = object ["properties" .= object []] + let aliases = KM.singleton "alias1" (object []) + let opts = + defaultCreateIndexOptions + { cioSettings = Just settings, + cioMappings = Just mapping, + cioAliases = Just aliases + } + decodedKeys (decode =<< createIndexOptionsBody opts) + `shouldBe` Just ["aliases", "mappings", "settings"] + + describe "createIndexOptions integration" $ do + -- Live integration coverage: verify the new endpoint variants are + -- accepted by a real backend. Each case tears the index down first + -- so that createIndexOptions is the call that actually creates it. + let resetIndexOpts opts = withTestEnv $ do + _ <- tryEsError deleteExampleIndex + (resp, _) <- performBHRequest $ keepBHResponse $ createIndexOptions opts testIndex + pure (resp :: BHResponse StatusDependant Acknowledged, ()) + + it "succeeds with only cioSettings (default-equivalent to createIndex)" $ do + let opts = defaultCreateIndexOptions {cioSettings = Just defaultIndexSettings} + (resp, _) <- resetIndexOpts opts + liftIO $ validateStatus resp 200 + + it "accepts cioMappings (properties block)" $ do + let mapping = object ["properties" .= object ["user" .= object ["type" .= ("keyword" :: T.Text)]]] + let opts = + defaultCreateIndexOptions + { cioSettings = Just defaultIndexSettings, + cioMappings = Just mapping + } + (resp, _) <- resetIndexOpts opts + liftIO $ validateStatus resp 200 + + it "accepts cioAliases (alias defined at create time)" $ do + let aliases = KM.singleton "bloodhound-tests-create-options-alias" (object []) + let opts = + defaultCreateIndexOptions + { cioSettings = Just defaultIndexSettings, + cioAliases = Just aliases + } + (resp, _) <- resetIndexOpts opts + liftIO $ validateStatus resp 200 + + it "accepts cioWaitForActiveShards = AllActiveShards" $ do + -- defaultIndexSettings sets 2 replicas, but a single-node test + -- cluster cannot allocate them, so @wait_for_active_shards=all@ + -- would block until the request times out. Use ReplicaCount 0 + -- so every shard copy is on the single available node. + let settings = IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits + let opts = + defaultCreateIndexOptions + { cioSettings = Just settings, + cioWaitForActiveShards = Just AllActiveShards + } + (resp, _) <- resetIndexOpts opts + liftIO $ validateStatus resp 200 + + it "accepts cioTimeout" $ do + let opts = + defaultCreateIndexOptions + { cioSettings = Just defaultIndexSettings, + cioTimeout = Just (TimeUnitSeconds, 5) + } + (resp, _) <- resetIndexOpts opts + liftIO $ validateStatus resp 200 + + describe "GET /{index}/_stats (getIndexStats)" $ do + it "returns stats for the requested index with typed docs and store" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- performBHRequest $ putMapping @Value testIndex TweetMapping + _ <- performBHRequest $ indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1") + _ <- performBHRequest $ refreshIndex testIndex + stats <- performBHRequest $ getIndexStats testIndex + liftIO $ shardsSuccessful (indexStatsShards stats) `shouldSatisfy` (>= 1) + case M.lookup testIndex (indexStatsIndices stats) of + Nothing -> liftIO $ expectationFailure "expected an entry for the test index" + Just entry -> do + let primaries = indexStatEntryPrimaries entry + case indexStatMetricsDocs primaries of + Nothing -> liftIO $ expectationFailure "expected primaries.docs to be present" + Just d -> liftIO $ indexStatDocsCount d `shouldSatisfy` (>= 1) + case indexStatMetricsStore (indexStatEntryTotal entry) of + Nothing -> liftIO $ expectationFailure "expected total.store to be present" + Just s -> liftIO $ indexStatStoreSizeInBytes s `shouldSatisfy` (>= 1) + -- The "other" blob must preserve the raw metrics object so + -- callers can navigate indexing/search/merge/etc. sections + -- that are not yet typed. + case indexStatMetricsOther primaries of + Object _ -> pure () + other -> liftIO $ expectationFailure $ "expected metrics object, got " <> show other + + it "exposes _shards and the index entry even on a fresh index" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + stats <- performBHRequest $ getIndexStats testIndex + liftIO $ M.member testIndex (indexStatsIndices stats) `shouldBe` True + + it "surfaces server-side errors (404) for a non-existent index" $ do + result <- + withTestEnv $ + tryEsError (performBHRequest $ getIndexStats [qqIndexName|bloodhound-no-such-index-04f-2-8|]) + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected EsError for missing index, got success" + + describe "GET /{index}/_recovery (getIndexRecovery)" $ do + it "returns recovery info for the requested index with typed shard entries" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- performBHRequest $ putMapping @Value testIndex TweetMapping + _ <- performBHRequest $ indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1") + _ <- performBHRequest $ refreshIndex testIndex + recovery <- performBHRequest $ getIndexRecovery testIndex + -- The endpoint is scoped to a single index; only that key + -- should appear in the response. + liftIO $ M.keys (indexRecoveryIndices recovery) `shouldBe` [testIndex] + case M.lookup testIndex (indexRecoveryIndices recovery) of + Nothing -> liftIO $ expectationFailure "expected an entry for the test index" + Just (s : _) -> do + liftIO $ shardRecoveryId s `shouldSatisfy` (>= 0) + liftIO $ shardRecoveryPrimary s `shouldBe` True + -- Once refreshIndex returns, every recovery has settled to + -- DONE for an already-green primary shard. + liftIO $ shardRecoveryStage s `shouldBe` Just "DONE" + case shardRecoveryIndex s of + Nothing -> liftIO $ expectationFailure "expected an index block on the shard" + Just idxBlock -> do + -- The verbatim "Other" blob must preserve the raw + -- @index@ object so callers can navigate not-yet-typed + -- sections (size, translog, verify_index, ...). + case shardRecoveryIndexOther idxBlock of + Object _ -> pure () + other -> + liftIO $ + expectationFailure $ + "expected index block to be an object, got " <> show other + case shardRecoveryIndexFiles idxBlock of + Nothing -> liftIO $ expectationFailure "expected a files block on the index" + Just files -> liftIO $ do + -- Whatever was recovered equals the total file count + -- (trivially 0 == 0 for an EMPTY_STORE primary on a + -- fresh local index, or N == N once DONE on a real + -- recovery). + shardRecoveryFilesTotal files `shouldBe` shardRecoveryFilesRecovered files + -- Percent is always present and well-formed. + case shardRecoveryFilesPercent files of + Just p -> T.isSuffixOf "%" p `shouldBe` True + Nothing -> expectationFailure "expected a percent value" + Just [] -> liftIO $ expectationFailure "expected at least one shard entry" + + it "preserves the raw shard object verbatim in shardRecoveryOther" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + recovery <- performBHRequest $ getIndexRecovery testIndex + case M.lookup testIndex (indexRecoveryIndices recovery) of + Just (s : _) -> case shardRecoveryOther s of + Object _ -> pure () + other -> + liftIO $ + expectationFailure $ + "expected shard other to be an object, got " <> show other + _ -> liftIO $ expectationFailure "expected at least one shard entry" + + it "exposes the index entry even on a fresh empty index" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + recovery <- performBHRequest $ getIndexRecovery testIndex + liftIO $ M.member testIndex (indexRecoveryIndices recovery) `shouldBe` True + + it "surfaces server-side errors (404) for a non-existent index" $ do + result <- + withTestEnv $ + tryEsError (performBHRequest $ getIndexRecovery [qqIndexName|bloodhound-no-such-index-04f-2-10|]) + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected EsError for missing index, got success" + + describe "GET /{index}/_segments (getIndexSegments)" $ do + it "returns segment info for the requested index with typed core fields" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- performBHRequest $ putMapping @Value testIndex TweetMapping + _ <- performBHRequest $ indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1") + _ <- performBHRequest $ refreshIndex testIndex + segments <- performBHRequest $ getIndexSegments testIndex + liftIO $ shardsSuccessful (indexSegmentsShards segments) `shouldSatisfy` (>= 1) + case M.lookup testIndex (indexSegmentsIndices segments) of + Nothing -> liftIO $ expectationFailure "expected an entry for the test index" + Just shardsMap -> case firstShardCopy shardsMap of + Nothing -> liftIO $ expectationFailure "expected at least one shard copy" + Just shardCopy -> do + liftIO $ segmentRoutingPrimary (indexSegmentsShardRouting shardCopy) `shouldBe` True + case firstSegment shardCopy of + Nothing -> liftIO $ expectationFailure "expected at least one segment after indexing a document" + Just seg -> liftIO $ do + segmentNumDocs seg `shouldSatisfy` (>= 1) + segmentSizeInBytes seg `shouldSatisfy` (>= 1) + segmentGeneration seg `shouldSatisfy` (>= 0) + segmentDeletedDocs seg `shouldSatisfy` (>= 0) + -- version is always populated once a segment exists + case segmentVersion seg of + Nothing -> expectationFailure "expected a segment version" + Just _ -> pure () + + it "exposes _shards and the index entry even on a fresh empty index" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + segments <- performBHRequest $ getIndexSegments testIndex + liftIO $ do + shardTotal (indexSegmentsShards segments) `shouldSatisfy` (>= 1) + M.member testIndex (indexSegmentsIndices segments) `shouldBe` True + + it "surfaces server-side errors (404) for a non-existent index" $ do + result <- + withTestEnv $ + tryEsError (performBHRequest $ getIndexSegments [qqIndexName|bloodhound-no-such-index-04f-2-9|]) + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected EsError for missing index, got success" + + it "SegmentInfo preserves non-promoted keys in segmentOther" $ do + -- ES 8+/9+ add fields like lucene_version, segment_sort, + -- vector_dimension that the typed SegmentInfo does not (yet) + -- promote. This pure unit test pins the knownKeys filter so a + -- future field addition cannot silently drop them. + let blob = + object + [ "generation" .= Number 0, + "num_docs" .= Number 1, + "deleted_docs" .= Number 0, + "size_in_bytes" .= Number 4278, + "memory_in_bytes" .= Number 1428, + "committed" .= Bool False, + "search" .= Bool True, + "version" .= String "8.11.3", + "compound" .= Bool True, + "attributes" .= object ["Lucene87StoredFieldsFormat.mode" .= String "BEST_SPEED"], + -- exotic / future fields: + "lucene_version" .= String "9.0.0", + "segment_sort" .= String "doc", + "vector_dimension" .= Number 768 + ] + case eitherDecode (encode blob) of + Right seg -> case segmentOther seg of + Just (Object km) -> do + length km `shouldBe` 3 + KM.member "lucene_version" km `shouldBe` True + KM.member "segment_sort" km `shouldBe` True + KM.member "vector_dimension" km `shouldBe` True + other -> + expectationFailure $ "expected non-empty object, got " <> show other + Left err -> expectationFailure $ "decode failed: " <> err + + describe "GET /{index}/_shard_stores (getShardStores)" $ do + -- Pure FromJSON unit tests exercise the dynamic node-id key shape + -- and the forward-compat paths that the integration tests below + -- can't reliably reach (the live server always emits the ES-rich + -- node metadata set and never returns `unavailable` on a green + -- single-node cluster). + describe "ShardStores FromJSON" $ do + let decodeStores = (decode :: BL8.ByteString -> Maybe ShardStores) + + it "parses the canonical ES example with one primary store copy" $ do + let body = + BL8.pack + "{\"indices\":{\"my-index-000001\":{\"shards\":{\"0\":{\"stores\":[\ + \{\"sPa3OgxLSYGvQ4oPs-Tajw\":{\"name\":\"node_t0\",\"ephemeral_id\":\"9NlXRFGCT1m8tkvYCMK-8A\",\"transport_address\":\"local[1]\",\"external_id\":\"node_t0\",\"attributes\":{},\"roles\":[],\"version\":\"8.10.0\",\"min_index_version\":7000099,\"max_index_version\":8100099},\"allocation_id\":\"2iNySv_OQVePRX-yaRH_lQ\",\"allocation\":\"primary\"}]}}}}}" + let Just (stores :: ShardStores) = decodeStores body + case M.lookup [qqIndexName|my-index-000001|] (shardStoresIndices stores) of + Nothing -> expectationFailure "expected an entry for the index" + Just shardsMap -> case M.lookup "0" shardsMap of + Nothing -> expectationFailure "expected shard 0" + Just shard -> case shardStoresShardStores shard of + [copy] -> do + shardStoreAllocationId copy `shouldBe` Just "2iNySv_OQVePRX-yaRH_lQ" + shardStoreAllocation copy `shouldBe` Just ShardStoreAllocationPrimary + case shardStoreNode copy of + Just (nodeId, node) -> do + nodeId `shouldBe` "sPa3OgxLSYGvQ4oPs-Tajw" + shardStoreNodeName node `shouldBe` Just "node_t0" + shardStoreNodeTransportAddress node `shouldBe` Just "local[1]" + shardStoreNodeExternalId node `shouldBe` Just "node_t0" + shardStoreNodeRoles node `shouldBe` Just [] + shardStoreNodeVersion node `shouldBe` Just "8.10.0" + shardStoreNodeMinIndexVersion node `shouldBe` Just 7000099 + shardStoreNodeMaxIndexVersion node `shouldBe` Just 8100099 + other -> + expectationFailure $ "expected node entry, got " <> show other + other -> + expectationFailure $ "expected exactly one store copy, got " <> show other + + it "parses the OpenSearch (minimal) node metadata shape" $ do + let body = + BL8.pack + "{\"indices\":{\"logs-shardstore\":{\"shards\":{\"0\":{\"stores\":[\ + \{\"UFyVYVMCSDOUbA1wPxSW5w\":{\"name\":\"opensearch-node1\",\"ephemeral_id\":\"vkSB_-M7QVyFXvgda6oRZg\",\"transport_address\":\"172.19.0.2:9300\",\"attributes\":{\"shard_indexing_pressure_enabled\":\"true\"}},\"allocation_id\":\"PEM5YjEWSz-jJEj-Not6Aw\",\"allocation\":\"replica\"}]}}}}}" + let Just (stores :: ShardStores) = decodeStores body + case M.lookup [qqIndexName|logs-shardstore|] (shardStoresIndices stores) of + Just shardsMap -> case M.lookup "0" shardsMap of + Just shard -> case shardStoresShardStores shard of + [copy] -> case shardStoreNode copy of + Just (_, node) -> do + shardStoreNodeName node `shouldBe` Just "opensearch-node1" + shardStoreNodeExternalId node `shouldBe` Nothing + shardStoreNodeRoles node `shouldBe` Nothing + shardStoreNodeVersion node `shouldBe` Nothing + shardStoreNodeMinIndexVersion node `shouldBe` Nothing + shardStoreNodeAttributes node + `shouldBe` Just (M.fromList [("shard_indexing_pressure_enabled", "true")]) + other -> + expectationFailure $ "expected node entry, got " <> show other + other -> + expectationFailure $ "expected one store copy, got " <> show other + Nothing -> expectationFailure "expected shard 0" + Nothing -> expectationFailure "expected an entry for the index" + + it "parses an empty stores array (shard with no assigned copy)" $ do + let body = BL8.pack "{\"indices\":{\"ix\":{\"shards\":{\"1\":{\"stores\":[]}}}}}" + let Just (stores :: ShardStores) = decodeStores body + case M.lookup [qqIndexName|ix|] (shardStoresIndices stores) of + Just shardsMap -> case M.lookup "1" shardsMap of + Just shard -> shardStoresShardStores shard `shouldBe` [] + Nothing -> expectationFailure "expected shard 1" + Nothing -> expectationFailure "expected an entry for the index" + + it "parses the unavailable allocation with a store_exception" $ do + let body = + BL8.pack + "{\"indices\":{\"ix\":{\"shards\":{\"0\":{\"stores\":[\ + \{\"abc\":{\"name\":\"n\"},\"allocation_id\":\"id1\",\"allocation\":\"unavailable\",\"store_exception\":{\"type\":\"file_corrupt\",\"reason\":\"boom\"}}]}}}}}" + let Just (stores :: ShardStores) = decodeStores body + case M.lookup [qqIndexName|ix|] (shardStoresIndices stores) of + Just shardsMap -> case M.lookup "0" shardsMap of + Just shard -> case shardStoresShardStores shard of + [copy] -> do + shardStoreAllocation copy `shouldBe` Just ShardStoreAllocationUnavailable + case shardStoreStoreException copy of + Just exc -> do + shardStoreExceptionType exc `shouldBe` Just "file_corrupt" + shardStoreExceptionReason exc `shouldBe` Just "boom" + Nothing -> expectationFailure "expected store_exception" + Nothing -> expectationFailure "expected shard 0" + Nothing -> expectationFailure "expected an entry for the index" + + it "rejects payloads with multiple Object-valued node entries" $ do + let body = + BL8.pack + "{\"indices\":{\"ix\":{\"shards\":{\"0\":{\"stores\":[\ + \{\"abc\":{\"name\":\"n\"},\"def\":{\"name\":\"m\"},\"allocation\":\"primary\"}]}}}}}" + case decodeStores body of + Just (_ :: ShardStores) -> + expectationFailure "expected decode to fail with multiple node entries" + Nothing -> pure () + + it "preserves unknown scalar sibling keys in shardStoreOther" $ do + -- Future scalar sibling fields (e.g. a hypothetical + -- `recovery_state`) survive round-trip in shardStoreOther + -- without breaking the node-id detection. + let body = + BL8.pack + "{\"indices\":{\"ix\":{\"shards\":{\"0\":{\"stores\":[\ + \{\"abc\":{\"name\":\"n\"},\"allocation\":\"primary\",\ + \\"recovery_state\":\"active\",\"priority\":42}]}}}}}" + let Just (stores :: ShardStores) = decodeStores body + case M.lookup [qqIndexName|ix|] (shardStoresIndices stores) of + Just shardsMap -> case M.lookup "0" shardsMap of + Just shard -> case shardStoresShardStores shard of + [copy] -> do + -- node entry still detected alongside the new scalars + case shardStoreNode copy of + Just (nodeId, node) -> do + nodeId `shouldBe` "abc" + shardStoreNodeName node `shouldBe` Just "n" + Nothing -> expectationFailure "expected node entry" + -- unknown scalars captured verbatim + case shardStoreOther copy of + Just (Object km) -> do + length km `shouldBe` 2 + KM.member "recovery_state" km `shouldBe` True + KM.member "priority" km `shouldBe` True + other -> + expectationFailure $ "expected non-empty object, got " <> show other + Nothing -> expectationFailure "expected shard 0" + Nothing -> expectationFailure "expected an entry for the index" + + it "preserves non-promoted keys in shardStoreExceptionOther" $ do + let blob = + object + [ "type" .= String "file_corrupt", + "reason" .= String "boom", + -- exotic / future fields: + "stack_hash" .= String "0xdeadbeef", + "retryable" .= Bool False + ] + case eitherDecode (encode blob) of + Right exc -> case shardStoreExceptionOther exc of + Just (Object km) -> do + length km `shouldBe` 2 + KM.member "stack_hash" km `shouldBe` True + KM.member "retryable" km `shouldBe` True + other -> + expectationFailure $ "expected non-empty object, got " <> show other + Left err -> expectationFailure $ "decode failed: " <> err + + it "preserves non-promoted keys in shardStoreNodeOther" $ do + -- Future / engine-specific node fields survive round-trip in + -- shardStoreNodeOther (mirrors segmentOther behaviour). + let blob = + object + [ "name" .= String "n", + "ephemeral_id" .= String "eid", + "transport_address" .= String "ta", + "external_id" .= String "eid2", + "attributes" .= object [], + "roles" .= ([] :: [Text]), + "version" .= String "9.0.0", + "min_index_version" .= Number 7, + "max_index_version" .= Number 9, + -- exotic / future fields: + "node_role" .= String "data_hot", + "build_type" .= String "docker" + ] + case eitherDecode (encode blob) of + Right node -> case shardStoreNodeOther node of + Just (Object km) -> do + length km `shouldBe` 2 + KM.member "node_role" km `shouldBe` True + KM.member "build_type" km `shouldBe` True + other -> + expectationFailure $ "expected non-empty object, got " <> show other + Left err -> expectationFailure $ "decode failed: " <> err + + it "tolerates a missing _shards envelope (defensive parse)" $ do + let body = BL8.pack "{\"indices\":{\"ix\":{\"shards\":{\"0\":{\"stores\":[]}}}}}" + let Just (stores :: ShardStores) = decodeStores body + shardTotal (shardStoresShards stores) `shouldBe` 0 + + it "round-trips ShardStoresStatus through ToJSON/FromJSON" $ do + let roundTrip s = decode (encode s) :: Maybe ShardStoresStatus + roundTrip ShardStoresStatusGreen `shouldBe` Just ShardStoresStatusGreen + roundTrip ShardStoresStatusYellow `shouldBe` Just ShardStoresStatusYellow + roundTrip ShardStoresStatusRed `shouldBe` Just ShardStoresStatusRed + roundTrip ShardStoresStatusAll `shouldBe` Just ShardStoresStatusAll + + it "round-trips ShardStoreAllocation through ToJSON/FromJSON" $ do + let roundTrip a = decode (encode a) :: Maybe ShardStoreAllocation + roundTrip ShardStoreAllocationPrimary `shouldBe` Just ShardStoreAllocationPrimary + roundTrip ShardStoreAllocationReplica `shouldBe` Just ShardStoreAllocationReplica + roundTrip ShardStoreAllocationUnavailable `shouldBe` Just ShardStoreAllocationUnavailable + roundTrip (ShardStoreAllocationOther "postprimary") + `shouldBe` Just (ShardStoreAllocationOther "postprimary") + + it "shardStoresOptionsParams renders status as a comma-joined list" $ do + let opts = + defaultShardStoresOptions + { ssoStatus = Just (ShardStoresStatusYellow :| [ShardStoresStatusRed]) + } + shardStoresOptionsParams opts + `shouldContain` [("status", Just "yellow,red")] + + it "defaultShardStoresOptions emits no query string" $ do + shardStoresOptionsParams defaultShardStoresOptions `shouldBe` [] + + it "returns store info for the requested index with typed allocation" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- performBHRequest $ putMapping @Value testIndex TweetMapping + _ <- performBHRequest $ indexDocument testIndex defaultIndexDocumentSettings exampleTweet (DocId "1") + _ <- performBHRequest $ refreshIndex testIndex + -- The server's default status filter is @yellow,red@ which + -- excludes healthy primaries on a green single-node cluster; + -- widen the filter to surface the test index's stores. + let allStatus = defaultShardStoresOptions {ssoStatus = Just (ShardStoresStatusAll :| [])} + stores <- performBHRequest $ getShardStoresWith testIndex allStatus + case M.lookup testIndex (shardStoresIndices stores) of + Nothing -> + liftIO $ expectationFailure "expected an entry for the test index" + Just shardsMap -> case firstShardStore shardsMap of + Nothing -> + liftIO $ expectationFailure "expected at least one store copy" + Just copy -> do + liftIO $ case shardStoreAllocation copy of + Just ShardStoreAllocationPrimary -> pure () + other -> + expectationFailure $ + "expected primary allocation on single-node cluster, got " + <> show other + case shardStoreNode copy of + Just (_, node) -> + liftIO $ case shardStoreNodeName node of + Nothing -> expectationFailure "expected a node name" + Just _ -> pure () + Nothing -> + liftIO $ expectationFailure "expected a node entry" + + it "exposes the index entry even on a fresh empty index" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + let allStatus = defaultShardStoresOptions {ssoStatus = Just (ShardStoresStatusAll :| [])} + stores <- performBHRequest $ getShardStoresWith testIndex allStatus + liftIO $ M.member testIndex (shardStoresIndices stores) `shouldBe` True + + it "surfaces server-side errors (404) for a non-existent index" $ do + result <- + withTestEnv $ + tryEsError (performBHRequest $ getShardStores [qqIndexName|bloodhound-no-such-index-04f-2-11|]) + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected EsError for missing index, got success" + + describe "GET /_resolve/index (resolveIndex)" $ do + -- Pure FromJSON unit tests exercise the @string | array[string]@ + -- union and missing-field paths that the integration tests below + -- can't reach (the live server always emits the array form and + -- always populates every documented field). + describe "ResolvedIndices FromJSON" $ do + let decodeResolved = (decode :: BL8.ByteString -> Maybe ResolvedIndices) + + it "parses aliases[].indices as an array of strings" $ do + let body = + BL8.pack + "{\"indices\":[],\"aliases\":[{\"name\":\"a1\",\"indices\":[\"ix1\",\"ix2\"]}],\"data_streams\":[]}" + let Just (resolved :: ResolvedIndices) = decodeResolved body + case resolvedIndicesAliases resolved of + [alias] -> resolvedAliasIndices alias `shouldBe` [[qqIndexName|ix1|], [qqIndexName|ix2|]] + other -> expectationFailure $ "expected one alias entry, got " <> show other + + it "parses aliases[].indices as a bare string (ES-9.x OpenAPI union)" $ do + let body = + BL8.pack + "{\"indices\":[],\"aliases\":[{\"name\":\"a1\",\"indices\":\"ix1\"}],\"data_streams\":[]}" + let Just (resolved :: ResolvedIndices) = decodeResolved body + case resolvedIndicesAliases resolved of + [alias] -> resolvedAliasIndices alias `shouldBe` [[qqIndexName|ix1|]] + other -> expectationFailure $ "expected one alias entry, got " <> show other + + it "parses a data_streams entry with bare-string backing_indices" $ do + let body = + BL8.pack + "{\"indices\":[],\"aliases\":[],\"data_streams\":[{\"name\":\"ds1\",\"backing_indices\":\"ds-ds1-2024-01-01-000001\",\"timestamp_field\":\"@timestamp\"}]}" + let Just (resolved :: ResolvedIndices) = decodeResolved body + case resolvedIndicesDataStreams resolved of + [ds] -> do + resolvedDataStreamName ds `shouldBe` "ds1" + resolvedDataStreamBackingIndices ds `shouldBe` [[qqIndexName|ds-ds1-2024-01-01-000001|]] + resolvedDataStreamTimestampField ds `shouldBe` "@timestamp" + other -> expectationFailure $ "expected one data stream entry, got " <> show other + + it "treats a missing aliases field on an index entry as empty" $ do + let body = + BL8.pack + "{\"indices\":[{\"name\":\"ix1\",\"attributes\":[\"open\"]}],\"aliases\":[],\"data_streams\":[]}" + let Just (resolved :: ResolvedIndices) = decodeResolved body + case resolvedIndicesIndices resolved of + [entry] -> resolvedIndexAliases entry `shouldBe` [] + other -> expectationFailure $ "expected one index entry, got " <> show other + + it "treats a missing/null indices field on an alias entry as empty" $ do + let body = + BL8.pack + "{\"indices\":[],\"aliases\":[{\"name\":\"a1\"}],\"data_streams\":[]}" + let Just (resolved :: ResolvedIndices) = decodeResolved body + case resolvedIndicesAliases resolved of + [alias] -> resolvedAliasIndices alias `shouldBe` [] + other -> expectationFailure $ "expected one alias entry, got " <> show other + + let findResolvedIndex name = L.find (\e -> resolvedIndexName e == name) . resolvedIndicesIndices + findResolvedAlias name = L.find (\e -> resolvedAliasName e == name) . resolvedIndicesAliases + + it "returns the requested index with its attributes" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + resolved <- performBHRequest $ resolveIndex [IndexPattern (unIndexName testIndex)] + case findResolvedIndex testIndex resolved of + Nothing -> + liftIO $ + expectationFailure $ + "expected an entry for " <> show testIndex <> ", got " <> show resolved + Just entry -> liftIO $ do + resolvedIndexName entry `shouldBe` testIndex + -- A freshly-created, open index reports "open" in its + -- attributes (the only universally-documented value across + -- ES and OpenSearch). + resolvedIndexAttributes entry `shouldContain` ["open"] + + it "treats an empty pattern list as the wildcard *" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + resolved <- performBHRequest $ resolveIndex [] + liftIO $ + (testIndex `elem` map resolvedIndexName (resolvedIndicesIndices resolved)) + `shouldBe` True + + it "surfaces aliases both per-index and in the top-level aliases array" $ + withTestEnv $ do + let aliasName = IndexAliasName [qqIndexName|bloodhound-tests-resolve-alias|] + alias = IndexAlias testIndex aliasName + aliasPattern = IndexPattern (unIndexName [qqIndexName|bloodhound-tests-resolve-alias|]) + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- performBHRequest $ keepBHResponse $ updateIndexAliases (AddAlias alias defaultIndexAliasCreate :| []) + -- Resolving by *index* name lists the alias in the per-index + -- @aliases@ field. + byIndex <- + performBHRequest $ + resolveIndex [IndexPattern (unIndexName testIndex)] + -- Resolving by *alias* name surfaces the alias in the + -- top-level @aliases@ array with its backing indices. + byAlias <- performBHRequest $ resolveIndex [aliasPattern] + -- Clean up the alias so the next test starts clean. (Best-effort; + -- a parse failure during the resolves above would leak it, but + -- the test itself would already be failing by then.) + _ <- performBHRequest $ deleteIndexAlias aliasName + case findResolvedIndex testIndex byIndex of + Nothing -> + liftIO $ + expectationFailure $ + "expected an entry for " <> show testIndex <> ", got " <> show byIndex + Just entry -> + liftIO $ (aliasName `elem` resolvedIndexAliases entry) `shouldBe` True + case findResolvedAlias aliasName byAlias of + Nothing -> + liftIO $ + expectationFailure $ + "expected a top-level alias entry for " <> show aliasName <> ", got " <> show byAlias + Just aliasEntry -> + liftIO $ (testIndex `elem` resolvedAliasIndices aliasEntry) `shouldBe` True + + it "expands to closed indices when expand_wildcards includes closed" $ + withTestEnv $ do + _ <- deleteExampleIndex + _ <- createExampleIndex + _ <- performBHRequest $ closeIndex testIndex + let opts = + defaultResolveIndexOptions + { rioExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + resolved <- + performBHRequest $ + resolveIndexWith opts [IndexPattern (unIndexName testIndex)] + -- Reopen so downstream tests can use the index. + _ <- performBHRequest $ openIndex testIndex + case findResolvedIndex testIndex resolved of + Nothing -> + liftIO $ + expectationFailure $ + "expected a closed entry for " <> show testIndex <> ", got " <> show resolved + Just entry -> + liftIO $ (resolvedIndexAttributes entry `shouldContain` ["closed"]) + + it "returns an empty result for a missing concrete index" $ + -- Note: how a missing concrete index is reported is version + -- dependent. ES 7 returns 200 with empty @indices@/@aliases@/ + -- @data_streams@ arrays. ES 8/9 return a 404 unless + -- @ignore_unavailable=true@ is set, which restores the 200-empty + -- shape across every backend. We pass it here so the + -- 'StatusDependant' builder yields the empty 'ResolvedIndices' + -- uniformly; genuine server-side failures (auth, malformed + -- pattern, 5xx) still surface as 'EsError'. + withTestEnv $ do + resolved <- + performBHRequest $ + resolveIndexWith + defaultResolveIndexOptions {rioIgnoreUnavailable = Just True} + [IndexPattern "bloodhound-no-such-index-04f-2-14"] + liftIO $ + resolvedIndicesIndices resolved `shouldBe` [] + + -- ------------------------------------------------------------------ -- + -- Index ops URI params (bloodhound-04f.7.17) -- + -- open/close/flush/refresh -- + -- (forcemerge intentionally omitted: no backend accepts -- + -- master_timeout/timeout on _forcemerge — every tested server -- + -- returns HTTP 400 "unrecognized parameters".) -- + -- ------------------------------------------------------------------ -- + describe "openCloseIndexOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultOpenCloseIndexOptions emits no params" $ + openCloseIndexOptionsParams defaultOpenCloseIndexOptions + `shouldBe` [] + + it "renders wait_for_active_shards via ActiveShardCount" $ do + let opts = defaultOpenCloseIndexOptions {ocioWaitForActiveShards = Just AllActiveShards} + openCloseIndexOptionsParams opts + `shouldBe` [("wait_for_active_shards", Just "all")] + + it "renders booleans as lowercase true/false" $ do + let opts = + defaultOpenCloseIndexOptions + { ocioIgnoreUnavailable = Just True, + ocioAllowNoIndices = Just False + } + normalize (openCloseIndexOptionsParams opts) + `shouldBe` [ ("allow_no_indices", Just "false"), + ("ignore_unavailable", Just "true") + ] + + it "renders expand_wildcards as a comma-separated list" $ do + let opts = + defaultOpenCloseIndexOptions + { ocioExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + openCloseIndexOptionsParams opts + `shouldBe` [("expand_wildcards", Just "open,closed")] + + it "renders master_timeout and timeout as " $ do + let opts = + defaultOpenCloseIndexOptions + { ocioMasterTimeout = Just (TimeUnitSeconds, 30), + ocioTimeout = Just (TimeUnitMilliseconds, 500) + } + normalize (openCloseIndexOptionsParams opts) + `shouldBe` [ ("master_timeout", Just "30s"), + ("timeout", Just "500ms") + ] + + it "emits every param together when all are set" $ do + let opts = + defaultOpenCloseIndexOptions + { ocioWaitForActiveShards = Just (ActiveShards 2), + ocioIgnoreUnavailable = Just True, + ocioAllowNoIndices = Just True, + ocioExpandWildcards = Just (ExpandWildcardsOpen :| []), + ocioMasterTimeout = Just (TimeUnitMinutes, 1), + ocioTimeout = Just (TimeUnitSeconds, 10) + } + normalize (openCloseIndexOptionsParams opts) + `shouldBe` [ ("allow_no_indices", Just "true"), + ("expand_wildcards", Just "open"), + ("ignore_unavailable", Just "true"), + ("master_timeout", Just "1m"), + ("timeout", Just "10s"), + ("wait_for_active_shards", Just "2") + ] + + describe "putMappingOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultPutMappingOptions emits no params" $ + putMappingOptionsParams defaultPutMappingOptions + `shouldBe` [] + + it "renders booleans as lowercase true/false" $ do + let opts = + defaultPutMappingOptions + { pmoIgnoreUnavailable = Just True, + pmoAllowNoIndices = Just False, + pmoWriteIndexOnly = Just True + } + normalize (putMappingOptionsParams opts) + `shouldBe` [ ("allow_no_indices", Just "false"), + ("ignore_unavailable", Just "true"), + ("write_index_only", Just "true") + ] + + it "renders expand_wildcards as a comma-separated list" $ do + let opts = + defaultPutMappingOptions + { pmoExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + putMappingOptionsParams opts + `shouldBe` [("expand_wildcards", Just "open,closed")] + + it "renders master_timeout and timeout as " $ do + let opts = + defaultPutMappingOptions + { pmoMasterTimeout = Just (TimeUnitSeconds, 30), + pmoTimeout = Just (TimeUnitMilliseconds, 500) + } + normalize (putMappingOptionsParams opts) + `shouldBe` [ ("master_timeout", Just "30s"), + ("timeout", Just "500ms") + ] + + describe "putMapping endpoint shape" $ do + let idx = [qqIndexName|mapping-shape|] + + it "PUTs /{index}/_mapping with no query string by default" $ do + let req = putMapping @Value idx (object []) + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["mapping-shape", "_mapping"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "putMappingWith forwards options onto the query string" $ do + let opts = defaultPutMappingOptions {pmoAllowNoIndices = Just True} + req = putMappingWith @Value idx (object []) opts + bhRequestMethod req `shouldBe` "PUT" + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("allow_no_indices", Just "true")] + + describe "flushIndexOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultFlushIndexOptions emits no params" $ + flushIndexOptionsParams defaultFlushIndexOptions + `shouldBe` [] + + it "renders booleans as lowercase true/false" $ do + let opts = + defaultFlushIndexOptions + { fioWaitIfOngoing = Just True, + fioForce = Just False, + fioIgnoreUnavailable = Just True, + fioAllowNoIndices = Just False + } + normalize (flushIndexOptionsParams opts) + `shouldBe` [ ("allow_no_indices", Just "false"), + ("force", Just "false"), + ("ignore_unavailable", Just "true"), + ("wait_if_ongoing", Just "true") + ] + + it "emits every param together when all are set" $ do + let opts = + defaultFlushIndexOptions + { fioWaitIfOngoing = Just True, + fioForce = Just True, + fioIgnoreUnavailable = Just False, + fioAllowNoIndices = Just True, + fioExpandWildcards = Just (ExpandWildcardsAll :| []) + } + normalize (flushIndexOptionsParams opts) + `shouldBe` [ ("allow_no_indices", Just "true"), + ("expand_wildcards", Just "all"), + ("force", Just "true"), + ("ignore_unavailable", Just "false"), + ("wait_if_ongoing", Just "true") + ] + + describe "refreshIndexOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultRefreshIndexOptions emits no params" $ + refreshIndexOptionsParams defaultRefreshIndexOptions + `shouldBe` [] + + it "renders booleans as lowercase true/false" $ do + let opts = + defaultRefreshIndexOptions + { rfioIgnoreUnavailable = Just True, + rfioAllowNoIndices = Just False, + rfioForce = Just True + } + normalize (refreshIndexOptionsParams opts) + `shouldBe` [ ("allow_no_indices", Just "false"), + ("force", Just "true"), + ("ignore_unavailable", Just "true") + ] + + it "emits every param together when all are set" $ do + let opts = + defaultRefreshIndexOptions + { rfioIgnoreUnavailable = Just False, + rfioAllowNoIndices = Just True, + rfioExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsHidden]), + rfioForce = Just True + } + normalize (refreshIndexOptionsParams opts) + `shouldBe` [ ("allow_no_indices", Just "true"), + ("expand_wildcards", Just "open,hidden"), + ("force", Just "true"), + ("ignore_unavailable", Just "false") + ] + + describe "index ops *With integration" $ do + -- Live integration tests against the sandboxed test index. Each + -- exercises a parameterised *With variant end-to-end and checks for + -- a 2xx — proves the params are accepted (not rejected as unknown) + -- by the backend. The default-Options case is the regression for + -- the byte-identical legacy behaviour of the parameterless entry + -- points. + let withTestIndex action = withTestEnv $ do + _ <- createExampleIndex + r <- action + _ <- tryPerformBHRequest (deleteIndex testIndex) + pure r + + it "openIndexWith/closeIndexWith round-trip with default options" $ + withTestIndex $ do + closeResp <- performBHRequest $ closeIndexWith defaultOpenCloseIndexOptions testIndex + _ <- performBHRequest $ openIndexWith defaultOpenCloseIndexOptions testIndex + liftIO $ isAcknowledged closeResp `shouldBe` True + + it "closeIndexWith accepts master_timeout and timeout" $ + withTestIndex $ do + let opts = + defaultOpenCloseIndexOptions + { ocioMasterTimeout = Just (TimeUnitSeconds, 30), + ocioTimeout = Just (TimeUnitSeconds, 10) + } + resp <- performBHRequest $ closeIndexWith opts testIndex + liftIO $ isAcknowledged resp `shouldBe` True + -- Reopen so cleanup can delete the index. + _ <- performBHRequest $ openIndex testIndex + pure () + + it "openIndexWith accepts wait_for_active_shards" $ + withTestIndex $ do + _ <- performBHRequest $ closeIndex testIndex + let opts = defaultOpenCloseIndexOptions {ocioWaitForActiveShards = Just AllActiveShards} + resp <- performBHRequest $ openIndexWith opts testIndex + liftIO $ isAcknowledged resp `shouldBe` True + + it "flushIndexWith accepts force and wait_if_ongoing" $ + withTestIndex $ do + let opts = + defaultFlushIndexOptions + { fioForce = Just True, + fioWaitIfOngoing = Just True + } + ShardsResult shardResult <- performBHRequest $ flushIndexWith opts testIndex + liftIO $ shardsSuccessful shardResult `shouldSatisfy` (>= 0) + + it "refreshIndexWith accepts expand_wildcards" $ + withTestIndex $ do + let opts = + defaultRefreshIndexOptions + { rfioExpandWildcards = Just (ExpandWildcardsOpen :| []) + } + ShardsResult shardResult <- performBHRequest $ refreshIndexWith opts testIndex + liftIO $ shardsSuccessful shardResult `shouldSatisfy` (>= 0) + + -- ---------------------------------------------------------------- + -- Dangling indices API (bloodhound-04f.2.16) + -- GET /_dangling, POST /_dangling/{uuid}, DELETE /_dangling/{uuid} + -- Available since Elasticsearch 7.16 and OpenSearch 1.0. The + -- integration tests below run against every supported backend. + -- ---------------------------------------------------------------- + describe "Dangling indices API (bloodhound-04f.2.16)" $ do + describe "DanglingIndicesResponse FromJSON" $ do + let decodeResp = (decode :: BL8.ByteString -> Maybe DanglingIndicesResponse) + + it "parses a response with two entries" $ do + let body = + BL8.pack + "{\"dangling_indices\":[\ + \{\"index_uuid\":\"abc-1\",\"index_name\":\"old-idx-1\",\"node_ids\":[\"node-a\"],\"creation_date_millis\":1436443200000},\ + \{\"index_uuid\":\"abc-2\",\"index_name\":\"old-idx-2\",\"node_ids\":[\"node-b\"],\"creation_date_millis\":1436443200001}\ + \]}" + let Just (resp :: DanglingIndicesResponse) = decodeResp body + length (danglingIndicesResponseList resp) `shouldBe` 2 + let first = head (danglingIndicesResponseList resp) + second = danglingIndicesResponseList resp !! 1 + danglingIndexUuid first `shouldBe` DanglingIndexUuid "abc-1" + danglingIndexIndexName first `shouldBe` "old-idx-1" + danglingIndexNodeIds first `shouldBe` ["node-a"] + danglingIndexCreationDateMillis first `shouldBe` 1436443200000 + danglingIndexUuid second `shouldBe` DanglingIndexUuid "abc-2" + danglingIndexNodeIds second `shouldBe` ["node-b"] + danglingIndexCreationDateMillis second `shouldBe` 1436443200001 + + it "parses a node_ids array with multiple entries" $ do + let body = + BL8.pack + "{\"dangling_indices\":[{\"index_uuid\":\"abc\",\"index_name\":\"old\",\"node_ids\":[\"n1\",\"n2\",\"n3\"],\"creation_date_millis\":1436443200000}]}" + let Just (resp :: DanglingIndicesResponse) = decodeResp body + case danglingIndicesResponseList resp of + [entry] -> danglingIndexNodeIds entry `shouldBe` ["n1", "n2", "n3"] + other -> expectationFailure $ "expected one entry, got " <> show other + + it "parses an empty dangling_indices array" $ do + let body = BL8.pack "{\"dangling_indices\":[]}" + let Just (resp :: DanglingIndicesResponse) = decodeResp body + danglingIndicesResponseList resp `shouldBe` [] + + it "rejects a response missing the required node_ids field" $ do + let body = + BL8.pack + "{\"dangling_indices\":[{\"index_uuid\":\"abc\",\"index_name\":\"old\",\"creation_date_millis\":1436443200000}]}" + decodeResp body `shouldBe` Nothing + + it "rejects a response missing the required creation_date_millis field" $ do + let body = + BL8.pack + "{\"dangling_indices\":[{\"index_uuid\":\"abc\",\"index_name\":\"old\",\"node_ids\":[\"n\"]}]}" + decodeResp body `shouldBe` Nothing + + it "treats a missing dangling_indices field as empty" $ do + let body = BL8.pack "{}" + let Just (resp :: DanglingIndicesResponse) = decodeResp body + danglingIndicesResponseList resp `shouldBe` [] + + describe "importDanglingIndexOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "default emits only accept_data_loss=true" $ + normalize (importDanglingIndexOptionsParams defaultImportDanglingIndexOptions) + `shouldBe` [("accept_data_loss", Just "true")] + + it "renders master_timeout and timeout as " $ do + let opts = + defaultImportDanglingIndexOptions + { idioMasterTimeout = Just (TimeUnitSeconds, 30), + idioTimeout = Just (TimeUnitMilliseconds, 500) + } + normalize (importDanglingIndexOptionsParams opts) + `shouldBe` [ ("accept_data_loss", Just "true"), + ("master_timeout", Just "30s"), + ("timeout", Just "500ms") + ] + + it "honours an explicit accept_data_loss = False" $ do + let opts = defaultImportDanglingIndexOptions {idioAcceptDataLoss = False} + normalize (importDanglingIndexOptionsParams opts) + `shouldBe` [("accept_data_loss", Just "false")] + + describe "deleteDanglingIndexOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "default emits no params" $ + deleteDanglingIndexOptionsParams defaultDeleteDanglingIndexOptions + `shouldBe` [] + + it "renders master_timeout and timeout as " $ do + let opts = + defaultDeleteDanglingIndexOptions + { ddioMasterTimeout = Just (TimeUnitSeconds, 30), + ddioTimeout = Just (TimeUnitSeconds, 10) + } + normalize (deleteDanglingIndexOptionsParams opts) + `shouldBe` [ ("master_timeout", Just "30s"), + ("timeout", Just "10s") + ] + + -- Integration tests. The dangling-index endpoints exist on + -- ElasticSearch 7.16+ and OpenSearch 1.0+, so the live tests run + -- against every supported backend. + backendSpecific [ElasticSearch7, ElasticSearch8, ElasticSearch9, OpenSearch1, OpenSearch2, OpenSearch3] $ do + it "listDanglingIndices returns a list (typically empty on a clean cluster)" $ + withTestEnv $ do + entries <- performBHRequest listDanglingIndices + -- A clean test cluster should not have dangling indices. + -- We only assert the call succeeded and returned a finite + -- list; we do NOT assert emptiness because a developer's + -- long-running cluster might genuinely have some. + liftIO $ length entries `shouldSatisfy` (>= 0) + + it "deleteDanglingIndex on a non-existent UUID surfaces a 400 EsError" $ + withTestEnv $ do + let missing = DanglingIndexUuid "nonexistent-uuid-bloodhound-04f-2-16" + outcome <- tryEsError (performBHRequest $ deleteDanglingIndex missing) + case outcome of + Left e -> + -- ES rejects unknown UUIDs with 400 (illegal_argument_exception: + -- "No dangling index found for UUID [...]") rather than 404. + liftIO $ errorStatus e `shouldBe` Just 400 + Right _ -> + liftIO $ + expectationFailure + "deleteDanglingIndex unexpectedly succeeded for a non-existent UUID" + + -- Import-success path: skipped. Inducing a real dangling index + -- requires stopping the cluster, planting stale index files on + -- disk for a node, and restarting — a multi-step orchestration + -- that is out of scope for a single API bead. The 'importDanglingIndex' + -- builder is exercised end-to-end by the URI-rendering unit tests + -- above; the path and accept_data_loss query parameter are + -- verified there. + -- ------------------------------------------------------------------ -- + -- indexBlockText: pure wire-string rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "indexBlockText rendering" $ + it "covers every documented block wire string" $ + map + indexBlockText + [IndexBlockWrite, IndexBlockRead, IndexBlockReadOnly, IndexBlockMetadata] + `shouldBe` ["write", "read", "read_only", "metadata"] + + -- Pins the 'IndexBlock' -> 'UpdatableIndexSetting' correspondence used + -- by 'removeIndexBlock' to build the @PUT /_settings@ body. A swap of + -- two constructors here would silently clear the wrong block at + -- teardown, so lock in the mapping at the unit level (cf. the + -- bloodhound-5gs review: the integration test only exercises + -- 'IndexBlockWrite' end-to-end). + describe "indexBlockToSetting mapping" $ + it "maps every IndexBlock to its matching BlocksX" $ do + indexBlockToSetting False IndexBlockWrite `shouldBe` BlocksWrite False + indexBlockToSetting False IndexBlockRead `shouldBe` BlocksRead False + indexBlockToSetting False IndexBlockReadOnly `shouldBe` BlocksReadOnly False + indexBlockToSetting False IndexBlockMetadata `shouldBe` BlocksMetaData False + indexBlockToSetting True IndexBlockWrite `shouldBe` BlocksWrite True + + -- Pins the 'IndexBlock' -> 'UpdatableIndexSetting' mapping that + -- 'removeIndexBlock' (PUT /_settings) uses to clear a block. A wrong + -- mapping would otherwise fail silently in the 'withBlockedIndex' + -- teardown (which wraps 'removeIndexBlock' in 'tryPerformBHRequest') + -- and leak a blocked index rather than surface as a test failure — + -- cf. bloodhound-5gs. + describe "indexBlockToUpdatable mapping" $ + it "maps every IndexBlock to its matching BlocksX False" $ + map + indexBlockToUpdatable + [IndexBlockWrite, IndexBlockRead, IndexBlockReadOnly, IndexBlockMetadata] + `shouldBe` [ BlocksWrite False, + BlocksRead False, + BlocksReadOnly False, + BlocksMetaData False + ] + + -- ------------------------------------------------------------------ -- + -- addIndexBlock integration (mirrors openIndexWith/closeIndexWith) -- + -- ------------------------------------------------------------------ -- + describe "addIndexBlock integration" $ do + -- 'addIndexBlock' is the dedicated-function shortcut for the + -- @'updateIndexSettings' ('BlocksWrite' 'True' :| [])@ workaround, so + -- each case verifies both the 'Acknowledged' response and that the + -- matching 'UpdatableIndexSetting' surfaces via 'getIndexSettings'. + -- + -- Each test uses a unique index name (passed to 'withBlockedIndex') so + -- a stuck block on one index cannot cascade into the next test. + -- Without this, a left-on @read_only@ or @metadata@ block would make + -- the next test's 'createIndex' fail with HTTP 403 (not the expected + -- @resource_already_exists_exception@) — 'createExampleIndex' would + -- re-throw that, 'bracket_' wouldn't run teardown, and the stuck + -- index would leak into the cluster, breaking unrelated tests + -- (cluster-wide operations like @_cat\/indices@ fail while any + -- blocked index exists). Unique names break the chain. + -- + -- Teardown uses 'removeIndexBlock', which routes through + -- @PUT //_settings@ with the matching @BlocksX False@ + -- 'UpdatableIndexSetting' (the dedicated @/_block/@ + -- endpoint is add-only on every supported backend — see + -- bloodhound-5gs). The @PUT /_settings@ path is honoured by + -- ES\/OS even while a @metadata@ block rejects + -- @GET //_settings@. + let setupBlockedIndex idx = + -- 'tryPerformBHRequest': tolerate "resource_already_exists_exception" + -- from a leaked previous run; teardown will clean it up. + void $ + tryPerformBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + idx + teardownBlockedIndex idx block = do + void $ tryPerformBHRequest $ removeIndexBlock idx block + void $ tryPerformBHRequest (deleteIndex idx) + withBlockedIndex idx block action = + withTestEnv $ bracket_ (setupBlockedIndex idx) (teardownBlockedIndex idx block) action + -- Pairs of ('IndexBlock', matching 'UpdatableIndexSetting') for + -- the cases where 'getIndexSettings' can read the block back. + -- @metadata@ is excluded from the "surfaces" check: the metadata + -- block rejects @GET //_settings@ itself (verified + -- manually against a live ES9 cluster), so the only check is the + -- 'Acknowledged' response. + surfaceCases = + [ (IndexBlockWrite, BlocksWrite True), + (IndexBlockRead, BlocksRead True), + (IndexBlockReadOnly, BlocksReadOnly True) + ] + + forM_ + surfaceCases + ( \(block, expectedSetting) -> do + let label = "addIndexBlock " <> T.unpack (indexBlockText block) + idx = either (error . T.unpack) id $ mkIndexName ("bloodhound-tests-block-" <> indexBlockText block) + it (label <> " returns Acknowledged and surfaces in getIndexSettings") $ + withBlockedIndex idx block $ do + resp <- performBHRequest $ addIndexBlock idx block + liftIO $ isAcknowledged resp `shouldBe` True + IndexSettingsSummary _ _ settings <- + performBHRequest $ getIndexSettings idx + liftIO $ settings `shouldContain` [expectedSetting] + ) + + -- @metadata@ blocks @GET //_settings@ itself, so only the + -- 'Acknowledged' response is checked. + it "addIndexBlock metadata returns Acknowledged" $ do + let idx = either (error . T.unpack) id $ mkIndexName "bloodhound-tests-block-metadata" + withBlockedIndex idx IndexBlockMetadata $ do + resp <- performBHRequest $ addIndexBlock idx IndexBlockMetadata + liftIO $ isAcknowledged resp `shouldBe` True + + -- 'removeIndexBlock' is the load-bearing cleanup helper for every + -- test above. Test it directly so a regression that left it + -- unable to clear the block (cf. the original bloodhound-04f.2.15 + -- implementation that used @DELETE //_block/@, + -- which ES rejects with HTTP 405 — tracked in bloodhound-5gs — + -- or a hypothetical swap of its underlying verb; cf. the + -- clearKnnCache/warmupKnnIndex distinctness guard in + -- bloodhound-04f.6.2.6) would surface here rather than silently + -- letting teardown leak blocked indices. + it "removeIndexBlock clears an IndexBlockWrite applied by addIndexBlock" $ do + let idx = either (error . T.unpack) id $ mkIndexName "bloodhound-tests-block-remove" + withBlockedIndex idx IndexBlockWrite $ do + _ <- performBHRequest $ addIndexBlock idx IndexBlockWrite + IndexSettingsSummary _ _ before <- + performBHRequest $ getIndexSettings idx + liftIO $ before `shouldContain` [BlocksWrite True] + resp <- performBHRequest $ removeIndexBlock idx IndexBlockWrite + liftIO $ isAcknowledged resp `shouldBe` True + IndexSettingsSummary _ _ after <- + performBHRequest $ getIndexSettings idx + liftIO $ after `shouldNotContain` [BlocksWrite True] + + -- Pins the 'StatusDependant' choice: a 404 for a missing index + -- surfaces as a structured 'EsError' (per 'parseEsResponse'), + -- matching the deleteIndexTemplate precedent in Test.TemplatesSpec. + it "addIndexBlock surfaces a missing index as EsError 404" $ do + let idx = either (error . T.unpack) id $ mkIndexName "bloodhound-no-such-index-block-04f-2-15" + result <- + withTestEnv $ + tryPerformBHRequest (addIndexBlock idx IndexBlockWrite) + case result of + Left e -> errorStatus e `shouldBe` Just 404 + Right _ -> expectationFailure "expected 404 EsError, got Acknowledged" + + -- Mirrors the 'addIndexBlock' 404 test above. 'removeIndexBlock' + -- uses @PUT //_settings@ (not the add-only @/_block@ endpoint), + -- which also returns 404 for a missing index; the 'StatusDependant' + -- parser surfaces it as a structured 'EsError' rather than the + -- generic "Unable to parse body" that 'StatusIndependant' would + -- produce (cf. bloodhound-5gs review). + it "removeIndexBlock surfaces a missing index as EsError 404" $ do + let idx = either (error . T.unpack) id $ mkIndexName "bloodhound-no-such-index-block-5gs" + result <- + withTestEnv $ + tryPerformBHRequest (removeIndexBlock idx IndexBlockWrite) + case result of + Left e -> errorStatus e `shouldBe` Just 404 + Right _ -> expectationFailure "expected 404 EsError, got Acknowledged" + + -- ---------------------------------------------------------------- + -- Regression test for bloodhound-442: + -- BlocksX ToJSON must emit the index. prefix so that + -- updateIndexSettings can clear a read_only block while it is in + -- effect. Before the fix, the encoder produced {"blocks":{"read_only":false}} + -- (no index wrapper), which ES rejects with HTTP 400 once the + -- read_only block is applied — so the only way to clear the block was + -- the dedicated removeIndexBlock endpoint. + -- ---------------------------------------------------------------- + describe "updateIndexSettings clears a read_only block (bloodhound-442 regression)" $ do + it "BlocksReadOnly False via updateIndexSettings lifts an existing read_only block" $ do + let idx = either (error . T.unpack) id $ mkIndexName "bloodhound-tests-blocks-442-regression" + withTestEnv + $ bracket_ + ( void $ + tryPerformBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + idx + ) + ( do + -- Clear the block first (in case the test body failed mid-flight) + void $ tryPerformBHRequest $ removeIndexBlock idx IndexBlockReadOnly + void $ tryPerformBHRequest $ deleteIndex idx + ) + $ do + -- Apply the read_only block via the dedicated endpoint (works + -- regardless of encoder state). + _ <- performBHRequest $ addIndexBlock idx IndexBlockReadOnly + -- Now clear it via updateIndexSettings. Before the fix this + -- returned 400 ("blocked by: [FORBIDDEN/10/index read-only + -- (api)];" plus the unprefixed body would have been rejected + -- anyway). After the fix the body is {"index":{"blocks":{"read_only":false}}} + -- which ES accepts. + (resp, _) <- + performBHRequest $ + keepBHResponse $ + updateIndexSettings (BlocksReadOnly False :| []) idx + liftIO $ validateStatus resp 200 + IndexSettingsSummary _ _ settings <- + performBHRequest $ getIndexSettings idx + liftIO $ settings `shouldNotContain` [BlocksReadOnly True] diff --git a/tests/Test/InferenceSpec.hs b/tests/Test/InferenceSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/InferenceSpec.hs @@ -0,0 +1,1033 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.InferenceSpec (spec) where + +import Data.Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust, isNothing) +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch8.Requests qualified as RequestsES8 +import Database.Bloodhound.ElasticSearch8.Types qualified as Types +import Database.Bloodhound.ElasticSearch9.Client qualified as ClientES9 +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import TestsUtils.Common +import TestsUtils.Import + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +-- | Decode a @GET /_inference@ response body into a list of +-- 'Types.InferenceInfo'. The wire format is a JSON object keyed by +-- @\/@; 'Types.InferenceEndpointsResponse' +-- flattens it on decode. +decodeInferenceList :: LBS.ByteString -> Maybe [Types.InferenceInfo] +decodeInferenceList = + fmap Types.unInferenceEndpointsResponse . decode + +spec :: Spec +spec = describe "Inference API (GET/PUT/POST/DELETE /_inference/{task_type}/{inference_id})" $ do + describe "TaskType JSON" $ do + it "serializes known task types to snake_case" $ do + Types.taskTypeToText Types.TextEmbeddingTaskType `shouldBe` "text_embedding" + Types.taskTypeToText Types.SparseEmbeddingTaskType `shouldBe` "sparse_embedding" + Types.taskTypeToText Types.ChatCompletionTaskType `shouldBe` "chat_completion" + Types.taskTypeToText Types.RerankTaskType `shouldBe` "rerank" + + it "round-trips every known task type" $ do + mapM_ + (\tt -> decode (encode tt) `shouldBe` Just tt) + [ minBound + .. maxBound :: Types.TaskType + ] + + describe "Similarity JSON" $ do + it "round-trips every valid similarity value" $ do + mapM_ + (\s -> decode (encode s) `shouldBe` Just s) + [ Types.SimilarityCosine, + Types.SimilarityDotProduct, + Types.SimilarityL2Norm + ] + + it "rejects max_inner_product (not valid for any inference provider)" $ do + (decode "\"max_inner_product\"" :: Maybe Types.Similarity) + `shouldBe` Nothing + + describe "ChatMessage JSON" $ do + it "round-trips a minimal message (role + content)" $ do + let msg = Types.ChatMessage "user" (Just (toJSON ("hello" :: Text))) Nothing Nothing Nothing Nothing + decode (encode msg) `shouldBe` Just msg + + it "round-trips a message with tool_call_id and tool_calls" $ do + let msg = + Types.ChatMessage + { Types.cmRole = "tool", + Types.cmContent = Nothing, + Types.cmToolCallId = Just "call_abc", + Types.cmToolCalls = Just (toJSON [object ["id" .= ("call_1" :: Text)]]), + Types.cmReasoning = Nothing, + Types.cmReasoningDetails = Nothing + } + decode (encode msg) `shouldBe` Just msg + + it "round-trips a message with reasoning fields" $ do + let msg = + Types.ChatMessage + { Types.cmRole = "assistant", + Types.cmContent = Just (toJSON ("thinking..." :: Text)), + Types.cmToolCallId = Nothing, + Types.cmToolCalls = Nothing, + Types.cmReasoning = Just (toJSON True), + Types.cmReasoningDetails = Just (toJSON [object ["type" .= ("summary" :: Text)]]) + } + decode (encode msg) `shouldBe` Just msg + + it "omits Nothing optional fields from JSON" $ do + let msg = Types.ChatMessage "system" (Just (toJSON ("hi" :: Text))) Nothing Nothing Nothing Nothing + let json = encode msg + json `shouldNotSatisfy` hasKey "tool_call_id" + json `shouldNotSatisfy` hasKey "tool_calls" + json `shouldNotSatisfy` hasKey "reasoning" + json `shouldNotSatisfy` hasKey "reasoning_details" + + it "decodes a message without content" $ do + let raw = LBS.pack "{\"role\":\"assistant\",\"tool_calls\":[]}" + case decode raw :: Maybe Types.ChatMessage of + Just msg -> do + Types.cmRole msg `shouldBe` "assistant" + Types.cmContent msg `shouldBe` Nothing + Types.cmToolCalls msg `shouldSatisfy` isJust + Nothing -> expectationFailure "failed to decode ChatMessage" + + describe "ChatCompletionRequest JSON" $ do + it "round-trips a minimal request (messages only)" $ do + let req = + Types.ChatCompletionRequest + { Types.ccrMessages = + [Types.ChatMessage "user" (Just (toJSON ("hi" :: Text))) Nothing Nothing Nothing Nothing], + Types.ccrModel = Nothing, + Types.ccrMaxCompletionTokens = Nothing, + Types.ccrReasoning = Nothing, + Types.ccrStop = Nothing, + Types.ccrTemperature = Nothing, + Types.ccrToolChoice = Nothing, + Types.ccrTools = Nothing, + Types.ccrTopP = Nothing + } + decode (encode req) `shouldBe` Just req + + it "round-trips a fully-populated request with top-level fields" $ do + let req = + Types.ChatCompletionRequest + { Types.ccrMessages = + [Types.ChatMessage "user" (Just (toJSON ("hi" :: Text))) Nothing Nothing Nothing Nothing], + Types.ccrModel = Just "gpt-4o", + Types.ccrMaxCompletionTokens = Just 1024, + Types.ccrReasoning = Just (toJSON True), + Types.ccrStop = Just (toJSON ("STOP" :: Text)), + Types.ccrTemperature = Just 0.7, + Types.ccrToolChoice = Just (toJSON ("auto" :: Text)), + Types.ccrTools = Just (toJSON [object ["type" .= ("function" :: Text)]]), + Types.ccrTopP = Just 0.9 + } + decode (encode req) `shouldBe` Just req + + it "does not emit a task_settings wrapper" $ do + let req = + Types.ChatCompletionRequest + { Types.ccrMessages = + [Types.ChatMessage "user" (Just (toJSON ("hi" :: Text))) Nothing Nothing Nothing Nothing], + Types.ccrModel = Just "gpt-4o", + Types.ccrMaxCompletionTokens = Just 128, + Types.ccrReasoning = Nothing, + Types.ccrStop = Nothing, + Types.ccrTemperature = Just 0.5, + Types.ccrToolChoice = Nothing, + Types.ccrTools = Nothing, + Types.ccrTopP = Nothing + } + let json = encode req + json `shouldNotSatisfy` hasKey "task_settings" + json `shouldSatisfy` hasKey "messages" + json `shouldSatisfy` hasKey "model" + json `shouldSatisfy` hasKey "max_completion_tokens" + json `shouldSatisfy` hasKey "temperature" + + describe "optional api_key round-trip" $ do + it "round-trips an OpenAI config with api_key = Nothing" $ do + let cfg = + Types.InferenceConfig + { Types.inferenceProvider = + Types.OpenAIProvider + (Types.OpenAIServiceSettings Nothing "text-embedding-3-small" Nothing Nothing Nothing Nothing Nothing) + Nothing, + Types.inferenceChunkingSettings = Nothing + } + let json = encode cfg + json `shouldNotSatisfy` hasKey "api_key" + (decode json :: Maybe Types.InferenceConfig) `shouldBe` Just cfg + + it "round-trips a Cohere config with api_key = Nothing" $ do + let cfg = + Types.InferenceConfig + { Types.inferenceProvider = + Types.CohereProvider + (Types.CohereServiceSettings Nothing "embed-v3" Nothing Nothing Nothing) + Nothing, + Types.inferenceChunkingSettings = Nothing + } + (decode (encode cfg) :: Maybe Types.InferenceConfig) `shouldBe` Just cfg + + describe "InferenceConfig JSON" $ do + let minimalOpenAI = + Types.InferenceConfig + { Types.inferenceProvider = + Types.OpenAIProvider + (Types.OpenAIServiceSettings (Just "sk-xxx") "text-embedding-3-small" Nothing Nothing Nothing Nothing Nothing) + Nothing, + Types.inferenceChunkingSettings = Nothing + } + + it "emits service and service_settings for a minimal OpenAI config" $ do + let json = encode minimalOpenAI + json `shouldSatisfy` hasKey "service" + json `shouldSatisfy` hasKey "service_settings" + + it "omits Nothing optional top-level fields" $ do + let json = encode minimalOpenAI + json `shouldNotSatisfy` hasKey "task_settings" + json `shouldNotSatisfy` hasKey "chunking_settings" + + it "writes the OpenAI service name" $ do + let Just (Object o) = decode (encode minimalOpenAI) + KM.lookup "service" o `shouldBe` Just (String "openai") + + it "round-trips a minimal OpenAI config" $ do + decode (encode minimalOpenAI) `shouldBe` Just minimalOpenAI + + it "round-trips a fully-populated Cohere config" $ do + let cfg = + Types.InferenceConfig + { Types.inferenceProvider = + Types.CohereProvider + ( Types.CohereServiceSettings + { Types.cssApiKey = Just "cohere-key", + Types.cssModelId = "embed-english-light-v3.0", + Types.cssEmbeddingType = Just Types.CohereEmbeddingByte, + Types.cssSimilarity = Just Types.SimilarityCosine, + Types.cssRateLimit = Just (Types.RateLimit 100) + } + ) + ( Just + Types.CohereTaskSettings + { Types.ctsInputType = Just Types.CohereInputIngest, + Types.ctsReturnDocuments = Just True, + Types.ctsTopN = Just 10, + Types.ctsTruncate = Just Types.CohereTruncateEnd + } + ), + Types.inferenceChunkingSettings = Nothing + } + decode (encode cfg) `shouldBe` Just cfg + + it "round-trips an ELSER config" $ do + let cfg = + Types.InferenceConfig + { Types.inferenceProvider = + Types.ElserProvider + Types.ElserServiceSettings + { Types.esserNumAllocations = 1, + Types.esserNumThreads = 1, + Types.esserAdaptiveAllocations = Nothing + }, + Types.inferenceChunkingSettings = Nothing + } + let Just (Object o) = decode (encode cfg) + KM.lookup "service" o `shouldBe` Just (String "elser") + decode (encode cfg) `shouldBe` Just cfg + + it "round-trips the generic escape hatch" $ do + -- Use a service name not in the typed set so dispatch falls through + -- to GenericProvider on decode (typed names like "mistral" decode to + -- their typed constructor and would not round-trip via the generic). + let rawSettings = object ["model_id" .= ("foo" :: Text), "api_key" .= ("bar" :: Text)] + cfg = + Types.InferenceConfig + { Types.inferenceProvider = + Types.GenericProvider "some-future-provider" rawSettings Nothing, + Types.inferenceChunkingSettings = Nothing + } + decode (encode cfg) `shouldBe` Just cfg + + it "round-trips every typed provider and writes its service wire string" $ do + -- One minimal InferenceConfig per provider. Round-trips through + -- encode/decode and the emitted `service` field matches the wire name. + let rateLimit = Just (Types.RateLimit 100) + providers = + [ ( "openai", + Types.OpenAIProvider + (Types.OpenAIServiceSettings (Just "sk") "m" Nothing Nothing Nothing Nothing rateLimit) + Nothing + ), + ( "cohere", + Types.CohereProvider + (Types.CohereServiceSettings (Just "sk") "m" Nothing Nothing rateLimit) + Nothing + ), + ( "elser", + Types.ElserProvider $ + Types.ElserServiceSettings 1 1 Nothing + ), + ( "ai21", + Types.Ai21Provider $ + Types.Ai21ServiceSettings "m" (Just "sk") rateLimit + ), + ( "mistral", + Types.MistralProvider $ + Types.MistralServiceSettings (Just "sk") "m" (Just 1024) rateLimit + ), + ( "anthropic", + Types.AnthropicProvider + (Types.AnthropicServiceSettings (Just "sk") "m" rateLimit) + (Just (Types.AnthropicTaskSettings 128 (Just 0.5) (Just 4) Nothing)) + ), + ( "deepseek", + Types.DeepSeekProvider $ + Types.DeepSeekServiceSettings (Just "sk") "m" (Just "https://api.deepseek.com") + ), + ( "nvidia", + Types.NvidiaProvider + (Types.NvidiaServiceSettings (Just "sk") "m" (Just 2048) rateLimit (Just Types.SimilarityCosine) Nothing) + (Just (Types.NvidiaTaskSettings (Just Types.NvidiaInputSearch) (Just Types.CohereTruncateEnd))) + ), + ( "contextualai", + Types.ContextualAiProvider + (Types.ContextualAiServiceSettings (Just "sk") "m" rateLimit) + (Just (Types.ContextualAiTaskSettings (Just "ctx") (Just 5))) + ), + ( "fireworksai", + Types.FireworksAiProvider + (Types.FireworksAiServiceSettings (Just "sk") "m" (Just 768) rateLimit (Just Types.SimilarityDotProduct) (Just "https://api.fireworks.ai")) + (Just (Types.FireworksAiTaskSettings (Just "u") Nothing)) + ), + ( "googleaistudio", + Types.GoogleAiStudioProvider $ + Types.GoogleAiStudioServiceSettings (Just "sk") "m" rateLimit + ), + ( "googlevertexai", + Types.GoogleVertexAiProvider + (Types.GoogleVertexAiServiceSettings "acct-json" (Just Types.GoogleModelGardenGoogle) Nothing Nothing (Just "us") (Just "m") (Just "proj") rateLimit (Just 768) (Just 10)) + (Just (Types.GoogleVertexAiTaskSettings (Just True) (Just 1024) (Just (Types.ThinkingConfig (Just 64))) (Just 3))) + ), + ( "groq", + Types.GroqProvider $ + Types.GroqServiceSettings "m" (Just "sk") rateLimit + ), + ( "hugging_face", + Types.HuggingFaceProvider + (Types.HuggingFaceServiceSettings (Just "sk") "https://api.hf.co" (Just "m") rateLimit) + (Just (Types.HuggingFaceTaskSettings (Just True) (Just 2))) + ), + ( "jinaai", + Types.JinaAiProvider + (Types.JinaAiServiceSettings (Just "sk") "m" (Just 512) (Just Types.JinaAiElementFloat) (Just False) rateLimit (Just Types.SimilarityL2Norm)) + (Just (Types.JinaAiTaskSettings (Just Types.JinaAiInputSearch) (Just True) (Just False) (Just 3))) + ), + ( "llama", + Types.LlamaProvider $ + Types.LlamaServiceSettings "https://llama" "m" (Just 512) rateLimit (Just Types.SimilarityCosine) + ), + ( "openshift_ai", + Types.OpenShiftAiProvider + (Types.OpenShiftAiServiceSettings (Just "sk") "https://osh" (Just 512) (Just "m") rateLimit (Just Types.SimilarityCosine)) + (Just (Types.OpenShiftAiTaskSettings (Just True) (Just 2))) + ), + ( "voyageai", + Types.VoyageAiProvider + (Types.VoyageAiServiceSettings "m" (Just 512) (Just Types.JinaAiElementBit) rateLimit) + (Just (Types.VoyageAiTaskSettings (Just "search") (Just True) (Just 3) (Just False))) + ), + ( "elasticsearch", + Types.ElasticsearchProvider + (Types.ElasticsearchServiceSettings "m" 1 Nothing Nothing (Just 1) Nothing Nothing) + (Just (Types.ElasticsearchTaskSettings (Just True))) + ), + ( "alibabacloud-ai-search", + Types.AlibabaCloudProvider + (Types.AlibabaCloudServiceSettings (Just "sk") "host" "sid" "ws" rateLimit) + (Just (Types.AlibabaCloudTaskSettings (Just "search") (Just True))) + ), + ( "amazonbedrock", + Types.AmazonBedrockProvider + (Types.AmazonBedrockServiceSettings "ak" "m" "us-east-1" "sk" (Just "anthropic") rateLimit) + (Just (Types.AmazonBedrockTaskSettings (Just 128) (Just 0.5) (Just 4) Nothing)) + ), + ( "amazon_sagemaker", + Types.AmazonSageMakerProvider + (Types.AmazonSageMakerServiceSettings "ak" "ep" Types.AmazonSageMakerApiElastic "us-east-1" "sk" (Just Types.SimilarityCosine) (Just Types.AmazonSageMakerElementFloat) Nothing Nothing Nothing (Just 8) (Just 256)) + (Just (Types.AmazonSageMakerTaskSettings (Just "attr") Nothing Nothing Nothing Nothing)) + ), + ( "azureaistudio", + Types.AzureAiStudioProvider + (Types.AzureAiStudioServiceSettings (Just "sk") "openai" "t" "microsoft" rateLimit) + (Just (Types.AzureAiStudioTaskSettings (Just 0.5) (Just 128) (Just True) (Just 0.7) (Just 3) Nothing (Just "u"))) + ), + ( "azureopenai", + Types.AzureOpenAiProvider + (Types.AzureOpenAiServiceSettings "2024-02-15" "dep" "res" (Just "sk") Nothing Nothing Nothing rateLimit (Just ["s"]) Nothing) + (Just (Types.AzureOpenAiTaskSettings (Just "u") Nothing)) + ), + ( "custom", + Types.CustomProvider + (Types.CustomServiceSettings (object ["a" .= (1 :: Int)]) (object ["b" .= (2 :: Int)]) (Types.SecretValue (object [])) (Just 4) Nothing Nothing Nothing (Just "https://custom")) + (Just (Types.CustomTaskSettings (Just (object ["x" .= (1 :: Int)])))) + ), + ( "watsonxai", + Types.WatsonxProvider $ + Types.WatsonxServiceSettings (Just "sk") "2023-05-29" "m" "proj" "https://us-south.ml.cloud.ibm.com" rateLimit + ) + ] + mapM_ + ( \(svc, provider) -> do + let cfg = + Types.InferenceConfig + { Types.inferenceProvider = provider, + Types.inferenceChunkingSettings = Nothing + } + json = encode cfg + json `shouldSatisfy` hasKey "service" + case decode json :: Maybe Value of + Just (Object o) -> KM.lookup "service" o `shouldBe` Just (String svc) + _ -> expectationFailure "expected a JSON object" + (decode json :: Maybe Types.InferenceConfig) `shouldBe` Just cfg + ) + providers + + describe "InferencePutResponse JSON" $ do + it "decodes a complete response" $ do + let raw = + LBS.pack + "{\"inference_id\":\"my-openai\",\"task_type\":\"text_embedding\",\"service\":\"openai\",\"service_settings\":{\"api_key\":\"sk-x\",\"model_id\":\"text-embedding-3-small\"}}" + let Just resp = decode raw + Types.iprInferenceId resp `shouldBe` "my-openai" + Types.iprTaskType resp `shouldBe` Types.TextEmbeddingTaskType + Types.iprService resp `shouldBe` "openai" + Types.iprServiceSettings resp `shouldSatisfy` isJust + + it "round-trips" $ do + let resp = + Types.InferencePutResponse + { Types.iprInferenceId = "x", + Types.iprTaskType = Types.SparseEmbeddingTaskType, + Types.iprService = "elser", + Types.iprServiceSettings = Nothing, + Types.iprTaskSettings = Nothing, + Types.iprChunkingSettings = Nothing + } + decode (encode resp) `shouldBe` Just resp + + describe "InferenceInput JSON" $ do + it "always emits input as an array, omits optional fields" $ do + let input = Types.InferenceInput ["hello"] Nothing Nothing Nothing + let json = encode input + json `shouldSatisfy` hasKey "input" + json `shouldNotSatisfy` hasKey "query" + json `shouldNotSatisfy` hasKey "input_type" + json `shouldNotSatisfy` hasKey "task_settings" + case decode json :: Maybe Types.InferenceInput of + Just decoded -> Types.iiInput decoded `shouldBe` ["hello"] + Nothing -> expectationFailure "failed to decode InferenceInput" + + it "includes query and task_settings when set" $ do + let input = + Types.InferenceInput + { Types.iiInput = ["a", "b"], + Types.iiQuery = Just "star wars", + Types.iiInputType = Nothing, + Types.iiTaskSettings = Just (object ["max_tokens" .= (128 :: Int)]) + } + let json = encode input + json `shouldSatisfy` hasKey "query" + json `shouldSatisfy` hasKey "task_settings" + + describe "InferenceResult JSON" $ do + it "decodes a text_embedding response" $ do + let raw = LBS.pack "{\"text_embedding\":[{\"embedding\":[0.1,-0.2,0.3]}]}" + let Just (Types.DenseEmbeddingResult fmt xs) = decode raw + fmt `shouldBe` Types.FloatEmbedding + length xs `shouldBe` 1 + case xs of + (item : _) -> Types.deiEmbedding item `shouldBe` [0.1, -0.2, 0.3] + [] -> expectationFailure "expected one embedding" + + it "decodes an embeddings (plural) response as Float format" $ do + let raw = LBS.pack "{\"embeddings\":[{\"embedding\":[0.5]}]}" + let Just (Types.DenseEmbeddingResult fmt _) = decode raw + fmt `shouldBe` Types.FloatEmbedding + + it "decodes an embeddings_bytes response as Bytes format" $ do + let raw = LBS.pack "{\"embeddings_bytes\":[{\"embedding\":[1,2,3]}]}" + let Just (Types.DenseEmbeddingResult fmt _) = decode raw + fmt `shouldBe` Types.BytesEmbedding + + it "decodes a text_embedding_bytes response as Bytes format" $ do + let raw = LBS.pack "{\"text_embedding_bytes\":[{\"embedding\":[1,2]}]}" + let Just (Types.DenseEmbeddingResult fmt _) = decode raw + fmt `shouldBe` Types.BytesEmbedding + + it "decodes an embeddings_bits response as Bits format" $ do + let raw = LBS.pack "{\"embeddings_bits\":[{\"embedding\":[0,1]}]}" + let Just (Types.DenseEmbeddingResult fmt _) = decode raw + fmt `shouldBe` Types.BitsEmbedding + + it "decodes a text_embedding_bits response as Bits format" $ do + let raw = LBS.pack "{\"text_embedding_bits\":[{\"embedding\":[0]}]}" + let Just (Types.DenseEmbeddingResult fmt _) = decode raw + fmt `shouldBe` Types.BitsEmbedding + + it "decodes a sparse_embedding response" $ do + let raw = LBS.pack "{\"sparse_embedding\":[{\"is_truncated\":false,\"embedding\":{\"tok1\":0.34,\"tok2\":1.2}}]}" + let Just (Types.SparseEmbeddingResult [item]) = decode raw + Types.seiIsTruncated item `shouldBe` False + Types.seiEmbedding item `shouldBe` Map.fromList [("tok1" :: Text, 0.34), ("tok2", 1.2)] + + it "decodes a completion response" $ do + let raw = LBS.pack "{\"completion\":[{\"result\":\"hello world\"}]}" + let Just (Types.CompletionResult [item]) = decode raw + Types.ciResult item `shouldBe` "hello world" + + it "decodes a rerank response" $ do + let raw = + LBS.pack + "{\"rerank\":[{\"index\":5,\"relevance_score\":0.97,\"text\":\"star\"},{\"index\":0,\"relevance_score\":0.81}]}" + let Just (Types.RerankResult items) = decode raw + length items `shouldBe` 2 + case items of + (first : _) -> do + Types.riIndex first `shouldBe` 5 + Types.riRelevanceScore first `shouldBe` 0.97 + Types.riText first `shouldBe` Just "star" + [] -> expectationFailure "expected rerank items" + + it "rejects a multi-key object" $ do + let raw = LBS.pack "{\"completion\":[],\"rerank\":[]}" + (decode raw :: Maybe Types.InferenceResult) `shouldBe` Nothing + + it "rejects an empty object" $ do + let raw = LBS.pack "{}" + (decode raw :: Maybe Types.InferenceResult) `shouldBe` Nothing + + it "rejects an unknown result key" $ do + let raw = LBS.pack "{\"whatever\":[]}" + (decode raw :: Maybe Types.InferenceResult) `shouldBe` Nothing + + it "round-trips a text_embedding result" $ do + let res = + Types.DenseEmbeddingResult + Types.FloatEmbedding + [Types.DenseEmbeddingItem [0.1, 0.2]] + decode (encode res) `shouldBe` Just res + + describe "endpoint shape" $ do + it "PUTs to /_inference// with a body" $ do + let cfg = + Types.InferenceConfig + { Types.inferenceProvider = + Types.ElserProvider + Types.ElserServiceSettings + { Types.esserNumAllocations = 1, + Types.esserNumThreads = 1, + Types.esserAdaptiveAllocations = Nothing + }, + Types.inferenceChunkingSettings = Nothing + } + let req = RequestsES8.putInferenceEndpoint Types.SparseEmbeddingTaskType "my-elser" cfg + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "sparse_embedding", "my-elser"] + bhRequestBody req `shouldSatisfy` isJust + + it "POSTs to /_inference// with a body" $ do + let input = Types.InferenceInput ["hello"] Nothing Nothing Nothing + let req = RequestsES8.runInference Types.TextEmbeddingTaskType "my-openai" input + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "text_embedding", "my-openai"] + bhRequestBody req `shouldSatisfy` isJust + + it "DELETEs /_inference// with no body (ES8)" $ do + let req = RequestsES8.deleteInferenceEndpoint Types.TextEmbeddingTaskType "my-openai" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "text_embedding", "my-openai"] + bhRequestBody req `shouldSatisfy` isNothing + + it "DELETEs encode the snake_case task_type segment (ES8)" $ do + let req = RequestsES8.deleteInferenceEndpoint Types.SparseEmbeddingTaskType "my-elser" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "sparse_embedding", "my-elser"] + bhRequestBody req `shouldSatisfy` isNothing + + it "PUTs to /_inference///_update with a body (ES8)" $ do + let cfg = + Types.InferenceConfig + { Types.inferenceProvider = + Types.ElserProvider + Types.ElserServiceSettings + { Types.esserNumAllocations = 1, + Types.esserNumThreads = 1, + Types.esserAdaptiveAllocations = Nothing + }, + Types.inferenceChunkingSettings = Nothing + } + let req = RequestsES8.updateInferenceEndpoint Types.SparseEmbeddingTaskType "my-elser" cfg + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_inference", "sparse_embedding", "my-elser", "_update"] + bhRequestBody req `shouldSatisfy` isJust + + it "ES9 update builder hits the same path as ES8" $ do + let cfg = + Types.InferenceConfig + { Types.inferenceProvider = + Types.OpenAIProvider + (Types.OpenAIServiceSettings (Just "sk-xxx") "text-embedding-3-small" Nothing Nothing Nothing Nothing Nothing) + Nothing, + Types.inferenceChunkingSettings = Nothing + } + let req = RequestsES9.updateInferenceEndpoint Types.TextEmbeddingTaskType "my-openai" cfg + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_inference", "text_embedding", "my-openai", "_update"] + bhRequestBody req `shouldSatisfy` isJust + + it "ES9 request builders hit the same paths as ES8" $ do + let cfg = + Types.InferenceConfig + { Types.inferenceProvider = + Types.ElserProvider + Types.ElserServiceSettings + { Types.esserNumAllocations = 1, + Types.esserNumThreads = 1, + Types.esserAdaptiveAllocations = Nothing + }, + Types.inferenceChunkingSettings = Nothing + } + let input = Types.InferenceInput ["q"] (Just "query") Nothing Nothing + let putReq = RequestsES9.putInferenceEndpoint Types.RerankTaskType "r" cfg + let postReq = RequestsES9.runInference Types.RerankTaskType "r" input + getRawEndpoint (bhRequestEndpoint putReq) `shouldBe` ["_inference", "rerank", "r"] + getRawEndpoint (bhRequestEndpoint postReq) `shouldBe` ["_inference", "rerank", "r"] + + it "ES9 DELETE reuses the ES8 path (no body)" $ do + let req = RequestsES9.deleteInferenceEndpoint Types.RerankTaskType "r" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "rerank", "r"] + bhRequestBody req `shouldSatisfy` isNothing + + it "POSTs to /_inference/completion//_stream with a body (ES8)" $ do + let input = Types.InferenceInput ["What is Elastic?"] Nothing Nothing Nothing + let req = RequestsES8.streamCompletionInference "my-openai" input + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_inference", "completion", "my-openai", "_stream"] + bhRequestBody req `shouldSatisfy` isJust + + it "POSTs to /_inference/chat_completion//_stream with a body (ES8)" $ do + let chatReq = + Types.ChatCompletionRequest + { Types.ccrMessages = + [Types.ChatMessage "user" (Just (toJSON ("What is Elastic?" :: Text))) Nothing Nothing Nothing Nothing], + Types.ccrModel = Just "gpt-4o", + Types.ccrMaxCompletionTokens = Nothing, + Types.ccrReasoning = Nothing, + Types.ccrStop = Nothing, + Types.ccrTemperature = Nothing, + Types.ccrToolChoice = Nothing, + Types.ccrTools = Nothing, + Types.ccrTopP = Nothing + } + let req = RequestsES8.streamChatCompletionInference "my-openai" chatReq + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_inference", "chat_completion", "my-openai", "_stream"] + bhRequestBody req `shouldSatisfy` isJust + + it "ES9 streaming builders hit the same paths as ES8" $ do + let input = Types.InferenceInput ["q"] Nothing Nothing Nothing + getRawEndpoint + (bhRequestEndpoint $ RequestsES9.streamCompletionInference "c" input) + `shouldBe` ["_inference", "completion", "c", "_stream"] + let chatReq = + Types.ChatCompletionRequest + { Types.ccrMessages = + [Types.ChatMessage "user" (Just (toJSON ("hi" :: Text))) Nothing Nothing Nothing Nothing], + Types.ccrModel = Nothing, + Types.ccrMaxCompletionTokens = Nothing, + Types.ccrReasoning = Nothing, + Types.ccrStop = Nothing, + Types.ccrTemperature = Nothing, + Types.ccrToolChoice = Nothing, + Types.ccrTools = Nothing, + Types.ccrTopP = Nothing + } + getRawEndpoint + (bhRequestEndpoint $ RequestsES9.streamChatCompletionInference "c" chatReq) + `shouldBe` ["_inference", "chat_completion", "c", "_stream"] + + describe "deleteInferenceOptionsParams URI rendering" $ do + it "default emits dry_run=false and force=false" $ + Types.deleteInferenceOptionsParams Types.defaultDeleteInferenceOptions + `shouldBe` [ ("dry_run", Just "false"), + ("force", Just "false") + ] + + it "renders dry_run=true when set" $ + Types.deleteInferenceOptionsParams + Types.defaultDeleteInferenceOptions {Types.dioDryRun = True} + `shouldBe` [ ("dry_run", Just "true"), + ("force", Just "false") + ] + + it "renders force=true when set" $ + Types.deleteInferenceOptionsParams + Types.defaultDeleteInferenceOptions {Types.dioForce = True} + `shouldBe` [ ("dry_run", Just "false"), + ("force", Just "true") + ] + + it "renders both flags true together" $ + Types.deleteInferenceOptionsParams + Types.defaultDeleteInferenceOptions {Types.dioDryRun = True, Types.dioForce = True} + `shouldBe` [ ("dry_run", Just "true"), + ("force", Just "true") + ] + + describe "deleteInferenceEndpointWith endpoint shape" $ do + it "attaches dry_run/force query params (ES8)" $ do + let opts = Types.defaultDeleteInferenceOptions {Types.dioForce = True} + let req = RequestsES8.deleteInferenceEndpointWith Types.TextEmbeddingTaskType "my-openai" opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_inference", "text_embedding", "my-openai"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [ ("dry_run", Just "false"), + ("force", Just "true") + ] + bhRequestBody req `shouldSatisfy` isNothing + + it "shares the path of deleteInferenceEndpoint, which stays query-less (ES8)" $ do + let plain = RequestsES8.deleteInferenceEndpoint Types.RerankTaskType "r" + let withOpts = RequestsES8.deleteInferenceEndpointWith Types.RerankTaskType "r" Types.defaultDeleteInferenceOptions + getRawEndpoint (bhRequestEndpoint plain) + `shouldBe` getRawEndpoint (bhRequestEndpoint withOpts) + getRawEndpointQueries (bhRequestEndpoint plain) `shouldBe` [] + + it "ES9 With reuses the ES8 builder" $ do + let opts = Types.defaultDeleteInferenceOptions {Types.dioDryRun = True} + let req = RequestsES9.deleteInferenceEndpointWith Types.RerankTaskType "r" opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "rerank", "r"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [ ("dry_run", Just "true"), + ("force", Just "false") + ] + bhRequestBody req `shouldSatisfy` isNothing + + describe "inference timeout options URI rendering" $ do + it "putInferenceOptionsParams default emits no params" $ + Types.putInferenceOptionsParams Types.defaultPutInferenceOptions + `shouldBe` [] + it "putInferenceOptionsParams renders timeout (Seconds)" $ + Types.putInferenceOptionsParams + Types.defaultPutInferenceOptions {Types.pioTimeout = Just (Types.TimeUnitSeconds, 30)} + `shouldBe` [("timeout", Just "30s")] + it "runInferenceOptionsParams renders timeout (Milliseconds)" $ + Types.runInferenceOptionsParams + Types.defaultRunInferenceOptions {Types.rnioTimeout = Just (Types.TimeUnitMilliseconds, 500)} + `shouldBe` [("timeout", Just "500ms")] + it "streamCompletionInferenceOptionsParams renders timeout" $ + Types.streamCompletionInferenceOptionsParams + Types.defaultStreamCompletionInferenceOptions {Types.scioTimeout = Just (Types.TimeUnitSeconds, 5)} + `shouldBe` [("timeout", Just "5s")] + it "streamChatCompletionInferenceOptionsParams renders timeout (Minutes)" $ + Types.streamChatCompletionInferenceOptionsParams + Types.defaultStreamChatCompletionInferenceOptions {Types.sccioTimeout = Just (Types.TimeUnitMinutes, 2)} + `shouldBe` [("timeout", Just "2m")] + + describe "putInferenceEndpointWith endpoint shape" $ do + let cfg = + Types.InferenceConfig + { Types.inferenceProvider = + Types.ElserProvider + Types.ElserServiceSettings + { Types.esserNumAllocations = 1, + Types.esserNumThreads = 1, + Types.esserAdaptiveAllocations = Nothing + }, + Types.inferenceChunkingSettings = Nothing + } + it "is byte-identical to putInferenceEndpoint with default opts (ES8)" $ do + let plain = RequestsES8.putInferenceEndpoint Types.SparseEmbeddingTaskType "my-elser" cfg + withOpts = RequestsES8.putInferenceEndpointWith Types.SparseEmbeddingTaskType "my-elser" cfg Types.defaultPutInferenceOptions + getRawEndpoint (bhRequestEndpoint plain) `shouldBe` getRawEndpoint (bhRequestEndpoint withOpts) + getRawEndpointQueries (bhRequestEndpoint plain) `shouldBe` [] + getRawEndpointQueries (bhRequestEndpoint withOpts) `shouldBe` [] + it "attaches ?timeout=30s with opts (ES8)" $ do + let opts = Types.defaultPutInferenceOptions {Types.pioTimeout = Just (Types.TimeUnitSeconds, 30)} + req = RequestsES8.putInferenceEndpointWith Types.TextEmbeddingTaskType "my-openai" cfg opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "text_embedding", "my-openai"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("timeout", Just "30s")] + it "ES9 With reuses the ES8 builder" $ do + let opts = Types.defaultPutInferenceOptions {Types.pioTimeout = Just (Types.TimeUnitSeconds, 30)} + req = RequestsES9.putInferenceEndpointWith Types.RerankTaskType "r" cfg opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "rerank", "r"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("timeout", Just "30s")] + + describe "runInferenceWith endpoint shape" $ do + let input = Types.InferenceInput ["q"] Nothing Nothing Nothing + it "is byte-identical to runInference with default opts (ES8)" $ do + let plain = RequestsES8.runInference Types.TextEmbeddingTaskType "my-openai" input + withOpts = RequestsES8.runInferenceWith Types.TextEmbeddingTaskType "my-openai" input Types.defaultRunInferenceOptions + getRawEndpoint (bhRequestEndpoint plain) `shouldBe` getRawEndpoint (bhRequestEndpoint withOpts) + getRawEndpointQueries (bhRequestEndpoint plain) `shouldBe` [] + it "attaches ?timeout=10s with opts (ES8)" $ do + let opts = Types.defaultRunInferenceOptions {Types.rnioTimeout = Just (Types.TimeUnitSeconds, 10)} + req = RequestsES8.runInferenceWith Types.TextEmbeddingTaskType "my-openai" input opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "text_embedding", "my-openai"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("timeout", Just "10s")] + it "ES9 With reuses the ES8 builder" $ do + let opts = Types.defaultRunInferenceOptions {Types.rnioTimeout = Just (Types.TimeUnitSeconds, 10)} + req = RequestsES9.runInferenceWith Types.RerankTaskType "r" input opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "rerank", "r"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("timeout", Just "10s")] + + describe "streamCompletionInferenceWith endpoint shape" $ do + let input = Types.InferenceInput ["q"] Nothing Nothing Nothing + it "is byte-identical to streamCompletionInference with default opts (ES8)" $ do + let plain = RequestsES8.streamCompletionInference "my-openai" input + withOpts = RequestsES8.streamCompletionInferenceWith "my-openai" input Types.defaultStreamCompletionInferenceOptions + getRawEndpoint (bhRequestEndpoint plain) `shouldBe` getRawEndpoint (bhRequestEndpoint withOpts) + getRawEndpointQueries (bhRequestEndpoint plain) `shouldBe` [] + it "attaches ?timeout=5s with opts (ES8)" $ do + let opts = Types.defaultStreamCompletionInferenceOptions {Types.scioTimeout = Just (Types.TimeUnitSeconds, 5)} + req = RequestsES8.streamCompletionInferenceWith "my-openai" input opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "completion", "my-openai", "_stream"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("timeout", Just "5s")] + it "ES9 With reuses the ES8 builder" $ do + let opts = Types.defaultStreamCompletionInferenceOptions {Types.scioTimeout = Just (Types.TimeUnitSeconds, 5)} + req = RequestsES9.streamCompletionInferenceWith "c" input opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "completion", "c", "_stream"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("timeout", Just "5s")] + + describe "streamChatCompletionInferenceWith endpoint shape" $ do + let chatReq = + Types.ChatCompletionRequest + { Types.ccrMessages = [Types.ChatMessage "user" (Just (toJSON ("hi" :: Text))) Nothing Nothing Nothing Nothing], + Types.ccrModel = Nothing, + Types.ccrMaxCompletionTokens = Nothing, + Types.ccrReasoning = Nothing, + Types.ccrStop = Nothing, + Types.ccrTemperature = Nothing, + Types.ccrToolChoice = Nothing, + Types.ccrTools = Nothing, + Types.ccrTopP = Nothing + } + it "is byte-identical to streamChatCompletionInference with default opts (ES8)" $ do + let plain = RequestsES8.streamChatCompletionInference "my-openai" chatReq + withOpts = RequestsES8.streamChatCompletionInferenceWith "my-openai" chatReq Types.defaultStreamChatCompletionInferenceOptions + getRawEndpoint (bhRequestEndpoint plain) `shouldBe` getRawEndpoint (bhRequestEndpoint withOpts) + getRawEndpointQueries (bhRequestEndpoint plain) `shouldBe` [] + it "attaches ?timeout=5s with opts (ES8)" $ do + let opts = Types.defaultStreamChatCompletionInferenceOptions {Types.sccioTimeout = Just (Types.TimeUnitSeconds, 5)} + req = RequestsES8.streamChatCompletionInferenceWith "my-openai" chatReq opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "chat_completion", "my-openai", "_stream"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("timeout", Just "5s")] + it "ES9 With reuses the ES8 builder" $ do + let opts = Types.defaultStreamChatCompletionInferenceOptions {Types.sccioTimeout = Just (Types.TimeUnitSeconds, 5)} + req = RequestsES9.streamChatCompletionInferenceWith "c" chatReq opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "chat_completion", "c", "_stream"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("timeout", Just "5s")] + + describe "GET /_inference endpoint shape" $ do + it "lists every endpoint when no filter is given (ES8)" $ do + let req = RequestsES8.getInferenceEndpoints Nothing Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference"] + bhRequestBody req `shouldSatisfy` isNothing + + it "narrows to a task type when only TaskType is given (ES8)" $ do + let req = RequestsES8.getInferenceEndpoints (Just Types.TextEmbeddingTaskType) Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference", "text_embedding", "_all"] + bhRequestBody req `shouldSatisfy` isNothing + + it "targets a specific endpoint when both are given (ES8)" $ do + let req = + RequestsES8.getInferenceEndpoints + (Just Types.SparseEmbeddingTaskType) + (Just "my-elser") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_inference", "sparse_embedding", "my-elser"] + bhRequestBody req `shouldSatisfy` isNothing + + it "encodes the snake_case task_type segment (ES8)" $ do + let req = RequestsES8.getInferenceEndpoints (Just Types.ChatCompletionTaskType) Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_inference", "chat_completion", "_all"] + + it "falls back to list-all when only InferenceId is given (ES8)" $ do + -- (Nothing, Just iid) is not a valid ES URL; the builder drops the + -- bare id and lists every endpoint instead of synthesising an + -- unsupported path. + let req = RequestsES8.getInferenceEndpoints Nothing (Just "orphan-id") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_inference"] + + it "ES9 request builder hits the same paths as ES8" $ do + getRawEndpoint + (bhRequestEndpoint $ RequestsES9.getInferenceEndpoints Nothing Nothing) + `shouldBe` ["_inference"] + getRawEndpoint + ( bhRequestEndpoint $ + RequestsES9.getInferenceEndpoints (Just Types.RerankTaskType) Nothing + ) + `shouldBe` ["_inference", "rerank", "_all"] + getRawEndpoint + ( bhRequestEndpoint $ + RequestsES9.getInferenceEndpoints + (Just Types.RerankTaskType) + (Just "r") + ) + `shouldBe` ["_inference", "rerank", "r"] + + describe "InferenceInfo JSON" $ do + it "decodes a single-endpoint response, splitting the key" $ do + let raw = + LBS.pack + "{\"text_embedding/my-openai\":{\"service\":\"openai\",\"service_settings\":{\"model_id\":\"text-embedding-3-small\",\"api_key\":null}}}" + case decodeInferenceList raw of + Just [info] -> do + Types.infTaskType info `shouldBe` Types.TextEmbeddingTaskType + Types.infInferenceId info `shouldBe` "my-openai" + Types.infService info `shouldBe` "openai" + Types.infServiceSettings info `shouldSatisfy` isJust + Types.infTaskSettings info `shouldSatisfy` isNothing + Types.infChunkingSettings info `shouldSatisfy` isNothing + other -> + expectationFailure $ "expected one InferenceInfo, got: " <> show other + + it "decodes a multi-endpoint response into a list" $ do + let raw = + LBS.pack + "{\"text_embedding/a\":{\"service\":\"openai\"},\"rerank/b\":{\"service\":\"cohere\",\"task_settings\":{\"top_n\":5}}}" + case decodeInferenceList raw of + Just infos -> length infos `shouldBe` 2 + Nothing -> expectationFailure "failed to decode multi-endpoint response" + + it "decodes when task_settings and chunking_settings are present" $ do + let raw = + LBS.pack + "{\"completion/c\":{\"service\":\"openai\",\"task_settings\":{\"user\":\"x\"},\"chunking_settings\":{\"strategy\":\"sentence\"}}}" + case decodeInferenceList raw of + Just [info] -> do + Types.infTaskType info `shouldBe` Types.CompletionTaskType + Types.infInferenceId info `shouldBe` "c" + Types.infTaskSettings info `shouldSatisfy` isJust + Types.infChunkingSettings info `shouldSatisfy` isJust + other -> + expectationFailure $ "expected one InferenceInfo, got: " <> show other + + it "tolerates a null api_key in service_settings" $ do + let raw = + LBS.pack + "{\"text_embedding/d\":{\"service\":\"openai\",\"service_settings\":{\"api_key\":null}}}" + case decodeInferenceList raw of + Just [info] -> + Types.infServiceSettings info + `shouldBe` Just (object ["api_key" .= Null]) + other -> + expectationFailure $ "expected exactly one InferenceInfo, got: " <> show other + + it "rejects a key without a '/' separator" $ do + let raw = LBS.pack "{\"no-separator\":{\"service\":\"openai\"}}" + decodeInferenceList raw `shouldBe` Nothing + + it "rejects an unknown task_type in the key" $ do + let raw = LBS.pack "{\"bogus_type/x\":{\"service\":\"openai\"}}" + decodeInferenceList raw `shouldBe` Nothing + + it "decodes an empty response as the empty list" $ do + let raw = LBS.pack "{}" + decodeInferenceList raw `shouldBe` Just [] + + it "round-trips a bare InferenceInfo (direct FromJSON/ToJSON)" $ do + let info = + Types.InferenceInfo + { Types.infTaskType = Types.TextEmbeddingTaskType, + Types.infInferenceId = "my-openai", + Types.infService = "openai", + Types.infServiceSettings = Just (object ["model_id" .= ("text-embedding-3-small" :: Text)]), + Types.infTaskSettings = Nothing, + Types.infChunkingSettings = Nothing + } + (decode (encode info) :: Maybe Types.InferenceInfo) `shouldBe` Just info + + it "decodes a bare InferenceInfo object (no key wrapper)" $ do + let raw = + LBS.pack + "{\"task_type\":\"rerank\",\"inference_id\":\"r1\",\"service\":\"cohere\",\"task_settings\":{\"top_n\":5}}" + case (decode raw :: Maybe Types.InferenceInfo) of + Just info -> do + Types.infTaskType info `shouldBe` Types.RerankTaskType + Types.infInferenceId info `shouldBe` "r1" + Types.infService info `shouldBe` "cohere" + Types.infTaskSettings info `shouldSatisfy` isJust + Nothing -> expectationFailure "expected InferenceInfo, got Nothing" + + it "InferenceEndpointsResponse decodes the per-id {\"endpoints\":[...]} envelope" $ do + -- GET /_inference/{task_type}/{inference_id} returns this shape, which + -- must decode to the same [InferenceInfo] as the list envelope. + let raw = + LBS.pack + "{\"endpoints\":[{\"task_type\":\"text_embedding\",\"inference_id\":\"x\",\"service\":\"openai\"}]}" + decodeInferenceList raw `shouldBe` Just [Types.InferenceInfo Types.TextEmbeddingTaskType "x" "openai" Nothing Nothing Nothing] + + describe "live integration (requires ES8+ backend)" $ + backendSpecific [ElasticSearch8, ElasticSearch9] $ do + it "rejects an unknown inference service with a 4xx error" $ + withTestEnv $ do + let bogusSettings = object ["model_id" .= ("nope" :: Text)] + cfg = + Types.InferenceConfig + { Types.inferenceProvider = + Types.GenericProvider "definitely_not_a_real_service" bogusSettings Nothing, + Types.inferenceChunkingSettings = Nothing + } + result <- do + backend <- liftIO detectBackendType + if backend == Just ElasticSearch9 + then ClientES9.putInferenceEndpoint Types.TextEmbeddingTaskType "bloodhound-test-bogus" cfg + else ClientES8.putInferenceEndpoint Types.TextEmbeddingTaskType "bloodhound-test-bogus" cfg + case result of + Left e -> do + case errorStatus e of + Just s -> liftIO $ (s >= 400 && s < 500) `shouldBe` True + Nothing -> + liftIO $ + expectationFailure $ + "expected a 4xx status, got none. Message: " <> show (errorMessage e) + Right _ -> + liftIO $ + expectationFailure + "expected the bogus inference config to be rejected, but it succeeded" + + it "rejects DELETE of a non-existent inference endpoint with a 4xx error" $ + withTestEnv $ do + -- ES9 reuses the ES8 request builder verbatim, so a single call + -- covers both backends; 'tryPerformBHRequest' surfaces the 4xx as + -- 'Left EsError'. + result <- + tryPerformBHRequest $ + RequestsES8.deleteInferenceEndpoint Types.TextEmbeddingTaskType "bloodhound-test-definitely-missing" + case result of + Left e -> + case errorStatus e of + Just s -> liftIO $ (s >= 400 && s < 500) `shouldBe` True + Nothing -> + liftIO $ + expectationFailure $ + "expected a 4xx status, got none. Message: " <> show (errorMessage e) + Right _ -> + liftIO $ + expectationFailure + "expected DELETE of a missing inference endpoint to fail, but it succeeded" diff --git a/tests/Test/IngestGeoIpSpec.hs b/tests/Test/IngestGeoIpSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/IngestGeoIpSpec.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.IngestGeoIpSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Scientific (Scientific) +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import Database.Bloodhound.ElasticSearch9.Types qualified as Types +import TestsUtils.Import + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +spec :: Spec +spec = + describe "Ingest GeoIP / IP-location database APIs (/_ingest/geoip/*, /_ingest/ip_location/*)" $ do + describe "GeoIpDatabaseId JSON" $ do + it "round-trips an id" $ do + let i = Types.GeoIpDatabaseId "my-geoip-db" + decode (encode i) `shouldBe` Just i + + it "unGeoIpDatabaseId extracts the underlying Text" $ + Types.unGeoIpDatabaseId (Types.GeoIpDatabaseId "x") + `shouldBe` ("x" :: Text) + + describe "GeoIpMaxmindConfig JSON" $ do + it "encodes as {account_id: ...}" $ + encode (Types.GeoIpMaxmindConfig "my-key") + `shouldBe` "{\"account_id\":\"my-key\"}" + + it "round-trips" $ do + let c = Types.GeoIpMaxmindConfig "k" + decode (encode c) `shouldBe` Just c + + describe "GeoIpDatabasePutBody JSON" $ do + it "always encodes name and maxmind (required for GeoIP)" $ do + let body = + Types.GeoIpDatabasePutBody + { Types.gipbName = "GeoLite2-City.mmdb", + Types.gipbMaxmind = Types.GeoIpMaxmindConfig "acct" + } + hasKey "maxmind" (encode body) `shouldBe` True + hasKey "ipinfo" (encode body) `shouldBe` False + decode (encode body) `shouldBe` Just body + + it "round-trips a fully-populated body" $ do + let body = + Types.GeoIpDatabasePutBody + { Types.gipbName = "db", + Types.gipbMaxmind = Types.GeoIpMaxmindConfig "k" + } + decode (encode body) `shouldBe` Just body + + it "decodes a documented body verbatim" $ do + let raw = + LBS.pack + "{\"name\":\"GeoLite2-City.mmdb\",\"maxmind\":{\"account_id\":\"acct\"}}" + case decode raw :: Maybe Types.GeoIpDatabasePutBody of + Just b -> do + Types.gipbName b `shouldBe` ("GeoLite2-City.mmdb" :: Text) + Types.gipbMaxmind b + `shouldBe` Types.GeoIpMaxmindConfig "acct" + Nothing -> expectationFailure "failed to decode GeoIpDatabasePutBody" + + it "rejects a body missing the required maxmind field" $ + decode (LBS.pack "{\"name\":\"GeoLite2-City.mmdb\"}") + `shouldBe` (Nothing :: Maybe Types.GeoIpDatabasePutBody) + + describe "IpLocationDatabasePutBody JSON" $ do + it "encodes a maxmind-only body, omitting ipinfo" $ do + let body = + Types.IpLocationDatabasePutBody + { Types.ilpbName = "GeoLite2-City.mmdb", + Types.ilpbMaxmind = Just (Types.GeoIpMaxmindConfig "acct"), + Types.ilpbIpInfo = Nothing + } + hasKey "ipinfo" (encode body) `shouldBe` False + hasKey "maxmind" (encode body) `shouldBe` True + decode (encode body) `shouldBe` Just body + + it "encodes an ipinfo-only body, omitting maxmind" $ do + let body = + Types.IpLocationDatabasePutBody + { Types.ilpbName = "ipinfo-db", + Types.ilpbMaxmind = Nothing, + Types.ilpbIpInfo = Just (object ["token" .= ("t" :: Text)]) + } + hasKey "maxmind" (encode body) `shouldBe` False + hasKey "ipinfo" (encode body) `shouldBe` True + decode (encode body) `shouldBe` Just body + + it "omits both providers when Nothing" $ do + let body = + Types.IpLocationDatabasePutBody + { Types.ilpbName = "db", + Types.ilpbMaxmind = Nothing, + Types.ilpbIpInfo = Nothing + } + hasKey "maxmind" (encode body) `shouldBe` False + hasKey "ipinfo" (encode body) `shouldBe` False + decode (encode body) `shouldBe` Just body + + it "encodes both providers when both are set (caller's responsibility)" $ do + let body = + Types.IpLocationDatabasePutBody + { Types.ilpbName = "db", + Types.ilpbMaxmind = Just (Types.GeoIpMaxmindConfig "acct"), + Types.ilpbIpInfo = Just (object ["token" .= ("t" :: Text)]) + } + hasKey "maxmind" (encode body) `shouldBe` True + hasKey "ipinfo" (encode body) `shouldBe` True + decode (encode body) `shouldBe` Just body + + it "decodes an ipinfo-only body" $ do + let raw = + LBS.pack + "{\"name\":\"ipinfo-db\",\"ipinfo\":{\"token\":\"t\"}}" + case decode raw :: Maybe Types.IpLocationDatabasePutBody of + Just b -> do + Types.ilpbName b `shouldBe` ("ipinfo-db" :: Text) + Types.ilpbMaxmind b `shouldBe` Nothing + Nothing -> expectationFailure "failed to decode ipinfo-only body" + + it "decodes a full body" $ do + let raw = + LBS.pack + "{\"name\":\"GeoLite2-City.mmdb\",\"maxmind\":{\"account_id\":\"acct\"}}" + case decode raw :: Maybe Types.IpLocationDatabasePutBody of + Just b -> do + Types.ilpbName b `shouldBe` ("GeoLite2-City.mmdb" :: Text) + Types.ilpbMaxmind b + `shouldBe` Just (Types.GeoIpMaxmindConfig "acct") + Nothing -> expectationFailure "failed to decode IpLocationDatabasePutBody" + + describe "GeoIpDatabaseInfo JSON" $ do + it "decodes a documented GET entry verbatim" $ do + let raw = + LBS.pack + "{\"id\":\"my-geoip-db\",\"version\":42,\"modified_date_millis\":1700000000000,\"database\":{\"name\":\"GeoLite2-City.mmdb\"}}" + case decode raw :: Maybe Types.GeoIpDatabaseInfo of + Just info -> do + Types.gidiId info `shouldBe` "my-geoip-db" + Types.gidiVersion info `shouldBe` (42 :: Scientific) + Types.gidiModifiedDateMillis info + `shouldBe` (1700000000000 :: Scientific) + Nothing -> expectationFailure "failed to decode GeoIpDatabaseInfo" + + it "round-trips a fully-populated entry" $ do + let info = + Types.GeoIpDatabaseInfo + { Types.gidiId = "my-geoip-db", + Types.gidiVersion = 42, + Types.gidiModifiedDateMillis = 1700000000000, + Types.gidiDatabase = object ["name" .= ("GeoLite2-City.mmdb" :: Text)] + } + decode (encode info) `shouldBe` Just info + + it "rejects an entry missing a required field" $ + decode (LBS.pack "{\"id\":\"only-id\"}") + `shouldBe` (Nothing :: Maybe Types.GeoIpDatabaseInfo) + + describe "GeoIpDatabasesResponse JSON" $ do + it "decodes a databases array of fully-populated entries" $ do + let raw = + LBS.pack + "{\"databases\":[{\"id\":\"a\",\"version\":1,\"modified_date_millis\":1700000000000,\"database\":{}},{\"id\":\"b\",\"version\":2,\"modified_date_millis\":1700000000001,\"database\":{}}]}" + case decode raw :: Maybe Types.GeoIpDatabasesResponse of + Just resp -> length (Types.gdrDatabases resp) `shouldBe` 2 + Nothing -> expectationFailure "failed to decode GeoIpDatabasesResponse" + + it "defaults a missing databases key to []" $ + case decode (LBS.pack "{}") :: Maybe Types.GeoIpDatabasesResponse of + Just resp -> length (Types.gdrDatabases resp) `shouldBe` 0 + Nothing -> expectationFailure "failed to decode empty GeoIpDatabasesResponse" + + describe "GeoIpStats JSON" $ do + it "decodes a stats object verbatim" $ do + let raw = + LBS.pack + "{\"successful_downloads\":3,\"failed_downloads\":1,\"total_download_time\":4591,\"databases_count\":2,\"skipped_updates\":0,\"expired_databases\":0}" + case decode raw :: Maybe Types.GeoIpStats of + Just s -> do + Types.gisSuccessfulDownloads s + `shouldBe` (3 :: Scientific) + Types.gisDatabasesCount s + `shouldBe` (2 :: Scientific) + Nothing -> expectationFailure "failed to decode GeoIpStats" + + it "round-trips a fully-populated stats object" $ do + let s = + Types.GeoIpStats + { Types.gisSuccessfulDownloads = 3, + Types.gisFailedDownloads = 1, + Types.gisTotalDownloadTime = 4591, + Types.gisDatabasesCount = 2, + Types.gisSkippedUpdates = 0, + Types.gisExpiredDatabases = 0 + } + decode (encode s) `shouldBe` Just s + + it "rejects an object missing a required field" $ + decode (LBS.pack "{}") + `shouldBe` (Nothing :: Maybe Types.GeoIpStats) + + describe "GeoIpNodeStats JSON" $ do + it "decodes per-node databases and files_in_temp" $ do + let raw = + LBS.pack + "{\"databases\":[{\"name\":\"GeoLite2-City.mmdb\"}],\"files_in_temp\":[\"tmp1\"]}" + case decode raw :: Maybe Types.GeoIpNodeStats of + Just ns -> do + length (Types.ginsDatabases ns) `shouldBe` 1 + Types.ginsFilesInTemp ns `shouldBe` ["tmp1"] + Nothing -> expectationFailure "failed to decode GeoIpNodeStats" + + describe "GeoIpStatsResponse JSON" $ do + it "decodes the documented stats+nodes shape" $ do + let raw = + LBS.pack + "{\"stats\":{\"successful_downloads\":1,\"failed_downloads\":0,\"total_download_time\":10,\"databases_count\":1,\"skipped_updates\":0,\"expired_databases\":0},\"nodes\":{\"node-1\":{\"databases\":[{\"name\":\"GeoLite2-City.mmdb\"}],\"files_in_temp\":[]}}}" + case decode raw :: Maybe Types.GeoIpStatsResponse of + Just resp -> do + Types.gisSuccessfulDownloads (Types.gisrStats resp) + `shouldBe` (1 :: Scientific) + length (Types.gisrNodes resp) `shouldBe` 1 + Nothing -> expectationFailure "failed to decode GeoIpStatsResponse" + + it "rejects a response missing stats" $ + decode (LBS.pack "{\"nodes\":{}}") + `shouldBe` (Nothing :: Maybe Types.GeoIpStatsResponse) + + it "rejects a response missing nodes" $ + decode + ( LBS.pack + "{\"stats\":{\"successful_downloads\":1,\"failed_downloads\":0,\"total_download_time\":10,\"databases_count\":1,\"skipped_updates\":0,\"expired_databases\":0}}" + ) + `shouldBe` (Nothing :: Maybe Types.GeoIpStatsResponse) + + describe "endpoint shape" $ do + it "GETs /_ingest/geoip/stats with no body" $ do + let req = RequestsES9.getGeoIpStats + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "geoip", "stats"] + bhRequestBody req `shouldSatisfy` isNothing + + it "GETs /_ingest/geoip/database (all) with no body" $ do + let req = RequestsES9.getGeoIpDatabases + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "geoip", "database"] + + it "GETs /_ingest/geoip/database/" $ do + let req = RequestsES9.getGeoIpDatabase "mydb" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "geoip", "database", "mydb"] + + it "PUTs /_ingest/geoip/database/ with a body" $ do + let body = + Types.GeoIpDatabasePutBody + { Types.gipbName = "GeoLite2-City.mmdb", + Types.gipbMaxmind = Types.GeoIpMaxmindConfig "acct" + } + req = RequestsES9.putGeoIpDatabase "mydb" body + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "geoip", "database", "mydb"] + bhRequestBody req `shouldSatisfy` isJust + + it "DELETEs /_ingest/geoip/database/" $ do + let req = RequestsES9.deleteGeoIpDatabase "*" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "geoip", "database", "*"] + bhRequestBody req `shouldSatisfy` isNothing + + it "GETs /_ingest/ip_location/database/" $ do + let req = RequestsES9.getIpLocationDatabase "ipdb" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "ip_location", "database", "ipdb"] + + it "GETs /_ingest/ip_location/database (all) with no body" $ do + let req = RequestsES9.getIpLocationDatabases + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "ip_location", "database"] + bhRequestBody req `shouldSatisfy` isNothing + + it "PUTs /_ingest/ip_location/database/ with a body" $ do + let body = + Types.IpLocationDatabasePutBody + { Types.ilpbName = "ipinfo-db", + Types.ilpbMaxmind = Nothing, + Types.ilpbIpInfo = Just (object ["token" .= ("t" :: Text)]) + } + req = RequestsES9.putIpLocationDatabase "ipdb" body + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "ip_location", "database", "ipdb"] + bhRequestBody req `shouldSatisfy` isJust + + it "DELETEs /_ingest/ip_location/database/" $ do + let req = RequestsES9.deleteIpLocationDatabase "ipdb" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "ip_location", "database", "ipdb"] diff --git a/tests/Test/IngestPipelineSpec.hs b/tests/Test/IngestPipelineSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/IngestPipelineSpec.hs @@ -0,0 +1,512 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.IngestPipelineSpec (spec) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value (..), decode, encode, object, (.=)) +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.Aeson.Types (parseMaybe) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust) +import Data.Text qualified as Text +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Vector qualified as V +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.Common.Client qualified as CommonClient +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- | Fixture mimicking the @GET /_ingest/pipeline@ response (two pipelines, +-- keyed by id). Adapted from the shape documented at +-- https://www.elastic.co/guide/en/elasticsearch/reference/current/get-pipeline-api.html. +sampleListResponse :: LBS.ByteString +sampleListResponse = + "{\ + \ \"my-pipeline\": {\ + \ \"description\": \"Pipeline for synthetic test fixture\",\ + \ \"version\": 1,\ + \ \"last_modified\": \"2023-06-01T12:34:56.789Z\",\ + \ \"processors\": [\ + \ { \"set\": { \"field\": \"foo\", \"value\": \"bar\" } }\ + \ ]\ + \ },\ + \ \"other-pipeline\": {\ + \ \"version\": 3,\ + \ \"processors\": [\ + \ { \"uppercase\": { \"field\": \"name\" } }\ + \ ]\ + \ }\ + \}" + +-- | Fixture mimicking the @GET /_ingest/pipeline/{id}@ response. ES still +-- wraps the single pipeline in a one-entry object keyed by id. +sampleSingleResponse :: LBS.ByteString +sampleSingleResponse = + "{\ + \ \"my-pipeline\": {\ + \ \"description\": \"single pipeline fixture\",\ + \ \"version\": 2,\ + \ \"last_modified\": \"2024-01-15T08:00:00.000Z\",\ + \ \"processors\": [\ + \ { \"uppercase\": { \"field\": \"name\" } }\ + \ ]\ + \ }\ + \}" + +-- | Minimal ingest pipeline body used by the live integration tests: a +-- single @uppercase@ processor that upper-cases the @name@ field. Small +-- enough to be accepted by every supported ES / OpenSearch version, and +-- observable enough that the simulate round-trip can assert the +-- transformation was applied. +sampleUppercasePipeline :: IngestPipeline +sampleUppercasePipeline = + IngestPipeline $ + object + [ "description" .= ("uppercase the name field" :: Text.Text), + "processors" + .= [ object + [ "uppercase" + .= object ["field" .= ("name" :: Text.Text)] + ] + ] + ] + +spec :: Spec +spec = describe "Ingest Pipelines API" $ do + describe "PipelineId JSON" $ do + it "round-trips as a bare JSON string" $ do + let Just decoded = decode "\"my-pipeline\"" :: Maybe PipelineId + unPipelineId decoded `shouldBe` "my-pipeline" + encode (PipelineId "my-pipeline") `shouldBe` "\"my-pipeline\"" + + it "rejects a non-string value" $ do + let decoded = decode "42" :: Maybe PipelineId + decoded `shouldBe` Nothing + + describe "IngestPipeline JSON (PUT body)" $ do + it "encodes the carried Value verbatim (no 'pipeline' wrapping)" $ do + let body = + object + [ "description" .= ("synthetic" :: Text.Text), + "processors" + .= object ["set" .= object ["field" .= ("foo" :: Text.Text), "value" .= ("bar" :: Text.Text)]] + ] + encoded = encode (IngestPipeline body) + encoded `shouldBe` encode body + + it "decodes an object body verbatim" $ do + let Just decoded = decode samplePutBodyBytes :: Maybe IngestPipeline + Just expected = decode samplePutBodyBytes :: Maybe Value + unIngestPipeline decoded `shouldBe` expected + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode samplePutBodyBytes :: Maybe IngestPipeline + (decode . encode) decoded `shouldBe` Just decoded + + it "rejects a non-object body (array)" $ do + let decoded = decode "[1,2,3]" :: Maybe IngestPipeline + decoded `shouldBe` Nothing + + it "rejects a non-object body (bare number)" $ do + let decoded = decode "5" :: Maybe IngestPipeline + decoded `shouldBe` Nothing + + it "rejects invalid JSON" $ do + let decoded = decode "{ this is not json" :: Maybe IngestPipeline + decoded `shouldBe` Nothing + + describe "IngestPipelineInfo JSON" $ do + it "decodes a single pipeline body (id stays as the placeholder)" $ do + let Just (Object o) = decode sampleSingleResponse + Just body = KM.lookup "my-pipeline" o + decoded = parseMaybe parseJSON body :: Maybe IngestPipelineInfo + ingestPipelineInfoId <$> decoded `shouldBe` Just (PipelineId "") + ingestPipelineInfoVersion <$> decoded `shouldBe` Just (Just 2) + ingestPipelineInfoDescription <$> decoded `shouldBe` Just (Just "single pipeline fixture") + ingestPipelineInfoLastModified <$> decoded `shouldBe` Just (Just "2024-01-15T08:00:00.000Z") + (ingestPipelineInfoProcessors <$> decoded) `shouldSatisfy` maybe False (maybe False hasProcessorsShape) + + it "tolerates a body missing every optional field except processors" $ do + let decoded = decode "{ \"processors\": [] }" :: Maybe IngestPipelineInfo + ingestPipelineInfoId <$> decoded `shouldBe` Just (PipelineId "") + ingestPipelineInfoVersion <$> decoded `shouldBe` Just Nothing + ingestPipelineInfoDescription <$> decoded `shouldBe` Just Nothing + ingestPipelineInfoLastModified <$> decoded `shouldBe` Just Nothing + + it "tolerates a body with no processors field at all" $ do + let decoded = decode "{ \"description\": \"empty\" }" :: Maybe IngestPipelineInfo + ingestPipelineInfoProcessors <$> decoded `shouldBe` Just Nothing + + describe "IngestPipelines JSON (keyed-by-id response walk)" $ do + it "decodes a multi-entry response, stamping each id from the JSON key" $ do + let Just decoded = decode sampleListResponse :: Maybe IngestPipelines + entries = unIngestPipelines decoded + length entries `shouldBe` 2 + map (unPipelineId . ingestPipelineInfoId) entries `shouldSatisfy` elem "my-pipeline" + map (unPipelineId . ingestPipelineInfoId) entries `shouldSatisfy` elem "other-pipeline" + + it "decodes the single-entry response as a singleton list" $ do + let Just decoded = decode sampleSingleResponse :: Maybe IngestPipelines + length (unIngestPipelines decoded) `shouldBe` 1 + + it "round-trips a multi-entry response through ToJSON/FromJSON" $ do + let Just decoded = decode sampleListResponse :: Maybe IngestPipelines + (decode . encode) decoded `shouldBe` Just decoded + + -- Pindocumentation: 'IngestPipelineInfo''s 'ToJSON' uses 'omitNulls', + -- which drops empty arrays. A standalone @decode . encode :: IngestPipelineInfo + -- -> Maybe IngestPipelineInfo@ therefore loses a 'Just (Array [])' + -- processors field (turning it into 'Nothing'). This matches the ILM + -- module's behavior and is intentional — round-trip via 'IngestPipelines' + -- (which preserves ids and bodies) for full fidelity. + it "omitNulls drops an empty processors array on ToJSON round-trip" $ do + let info = + IngestPipelineInfo + { ingestPipelineInfoId = PipelineId "x", + ingestPipelineInfoVersion = Nothing, + ingestPipelineInfoDescription = Nothing, + ingestPipelineInfoLastModified = Nothing, + ingestPipelineInfoProcessors = Just (Array mempty) + } + encoded = encode info + encoded `shouldBe` "{}" + + it "decodes an empty object as an empty list" $ do + let Just decoded = decode "{}" :: Maybe IngestPipelines + unIngestPipelines decoded `shouldBe` [] + + it "rejects a non-object response (array)" $ do + let decoded = decode "[1,2,3]" :: Maybe IngestPipelines + decoded `shouldBe` Nothing + + describe "SimulateIngestPipelineRequest JSON" $ do + it "emits both pipeline and docs when both are present" $ do + let req = + SimulateIngestPipelineRequest + { simulateIngestPipelineRequestPipeline = Just sampleUppercasePipeline, + simulateIngestPipelineRequestDocs = [object ["_source" .= object ["name" .= ("hello" :: Text.Text)]]] + } + Object o = toJSON req + KM.member "pipeline" o `shouldBe` True + KM.member "docs" o `shouldBe` True + + it "omits the pipeline field when it is Nothing" $ do + let req = + SimulateIngestPipelineRequest + { simulateIngestPipelineRequestPipeline = Nothing, + simulateIngestPipelineRequestDocs = [] + } + Object o = toJSON req + KM.member "pipeline" o `shouldBe` False + KM.member "docs" o `shouldBe` True + + it "round-trips through ToJSON/FromJSON" $ do + let req = + SimulateIngestPipelineRequest + { simulateIngestPipelineRequestPipeline = Just sampleUppercasePipeline, + simulateIngestPipelineRequestDocs = + [ object + [ "_index" .= ("ix" :: Text.Text), + "_source" .= object ["name" .= ("hello" :: Text.Text)] + ] + ] + } + (decode . encode) req `shouldBe` Just req + + describe "SimulateResult JSON" $ do + it "decodes a non-verbose response verbatim" $ do + let decoded = + decode + "{\ + \ \"docs\": [\ + \ { \"doc\": { \"_index\": \"ix\", \"_source\": { \"name\": \"HELLO\" } } }\ + \ ]\ + \}" :: + Maybe SimulateResult + decoded `shouldSatisfy` isJust + + it "rejects a non-object response" $ do + let decoded = decode "[1,2,3]" :: Maybe SimulateResult + decoded `shouldBe` Nothing + + describe "putIngestPipeline endpoint shape" $ do + let body = IngestPipeline (object ["description" .= ("synthetic" :: Text.Text)]) + req = Common.putIngestPipeline (PipelineId "my-pipeline") body + + it "PUTs /_ingest/pipeline/{id}" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ingest", "pipeline", "my-pipeline"] + + it "uses the PUT method" $ do + bhRequestMethod req `shouldBe` "PUT" + + it "attaches the encoded pipeline as the request body" $ do + bhRequestBody req `shouldBe` Just (encode body) + + it "carries no query string" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses a distinct id in the path when given a different PipelineId" $ do + let req' = Common.putIngestPipeline (PipelineId "other") body + getRawEndpoint (bhRequestEndpoint req') `shouldBe` ["_ingest", "pipeline", "other"] + + describe "getIngestPipeline endpoint shape" $ do + it "GETs /_ingest/pipeline when given Nothing" $ do + let req = Common.getIngestPipeline Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ingest", "pipeline"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_ingest/pipeline/{id} when given Just pid" $ do + let req = Common.getIngestPipeline (Just (PipelineId "my-pipeline")) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ingest", "pipeline", "my-pipeline"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the GET method" $ do + let req = Common.getIngestPipeline Nothing + bhRequestMethod req `shouldBe` "GET" + + it "carries no body" $ do + let req = Common.getIngestPipeline Nothing + bhRequestBody req `shouldBe` Nothing + + describe "deleteIngestPipeline endpoint shape" $ do + it "DELETEs /_ingest/pipeline/{id}" $ do + let req = Common.deleteIngestPipeline (PipelineId "my-pipeline") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ingest", "pipeline", "my-pipeline"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the DELETE method" $ do + let req = Common.deleteIngestPipeline (PipelineId "my-pipeline") + bhRequestMethod req `shouldBe` "DELETE" + + it "forwards a different id into the path" $ do + let req = Common.deleteIngestPipeline (PipelineId "other") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ingest", "pipeline", "other"] + + describe "simulateIngestPipeline endpoint shape" $ do + let docs = [object ["_source" .= object ["name" .= ("hello" :: Text.Text)]]] + + it "POSTs /_ingest/pipeline/_simulate when given Nothing" $ do + let req = Common.simulateIngestPipeline Nothing sampleUppercasePipeline docs + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ingest", "pipeline", "_simulate"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "POSTs /_ingest/pipeline/{id}/_simulate when given Just pid" $ do + let req = Common.simulateIngestPipeline (Just (PipelineId "my-pipeline")) sampleUppercasePipeline docs + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ingest", "pipeline", "my-pipeline", "_simulate"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the POST method" $ do + let req = Common.simulateIngestPipeline Nothing sampleUppercasePipeline docs + bhRequestMethod req `shouldBe` "POST" + + it "attaches the encoded SimulateIngestPipelineRequest as the body" $ do + let req = Common.simulateIngestPipeline Nothing sampleUppercasePipeline docs + expectedBody = encode (SimulateIngestPipelineRequest (Just sampleUppercasePipeline) docs) + bhRequestBody req `shouldBe` Just expectedBody + + describe "GrokPatterns JSON" $ do + it "decodes a patterns response (unwrapping the 'patterns' key)" $ do + let bytes = + "{\ + \ \"patterns\": {\ + \ \"PATH\": \"(?:%{UNIXPATH}|%{WINPATH})\",\ + \ \"BACULA_CAPACITY\": \"%{INT}{1,3}(,%{INT}{3})*\"\ + \ }\ + \}" + Just decoded = decode bytes :: Maybe GrokPatterns + m = unGrokPatterns decoded + Map.size m `shouldBe` 2 + Map.lookup "PATH" m `shouldBe` Just "(?:%{UNIXPATH}|%{WINPATH})" + + it "decodes an empty patterns map" $ do + let Just decoded = decode "{\"patterns\":{}}" :: Maybe GrokPatterns + unGrokPatterns decoded `shouldBe` Map.empty + + it "rejects a response missing the patterns key" $ do + let decoded = decode "{\"foo\":{}}" :: Maybe GrokPatterns + decoded `shouldBe` Nothing + + it "round-trips through ToJSON/FromJSON" $ do + let gp = GrokPatterns (Map.fromList [("IP", "%{IPV4}|%{IPV6}"), ("WORD", "\\b\\w+\\b")]) + (decode . encode) gp `shouldBe` Just gp + + it "encodes back under the 'patterns' key" $ do + let gp = GrokPatterns (Map.singleton "IP" "%{IPV4}|%{IPV6}") + encode gp `shouldBe` "{\"patterns\":{\"IP\":\"%{IPV4}|%{IPV6}\"}}" + + describe "getGrokPatterns endpoint shape" $ do + let req = Common.getGrokPatterns + + it "GETs /_ingest/processor/grok" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_ingest", "processor", "grok"] + + it "uses the GET method" $ do + bhRequestMethod req `shouldBe` "GET" + + it "carries no request body" $ do + bhRequestBody req `shouldBe` Nothing + + it "carries no query string" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + -- ------------------------------------------------------------------------ + -- Live integration: round-trip through a real ES / OpenSearch cluster. + -- Ingest pipelines are universal across every supported backend, so we + -- run on the full set. + -- ------------------------------------------------------------------------ + backendSpecific + [ElasticSearch7, ElasticSearch8, ElasticSearch9, OpenSearch1, OpenSearch2, OpenSearch3] + $ describe "Ingest pipeline (live integration)" + $ do + it "round-trips a pipeline via putIngestPipeline + getIngestPipeline (Just pid)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let pid = + PipelineId $ + Text.pack $ + "bloodhound_test_ingest_live_put_" <> suffix + _ <- CommonClient.putIngestPipeline pid sampleUppercasePipeline + infos <- CommonClient.getIngestPipeline (Just pid) + liftIO $ + case infos of + [info] -> do + ingestPipelineInfoId info `shouldBe` pid + ingestPipelineInfoProcessors info `shouldSatisfy` maybe False hasProcessorsShape + _ -> + expectationFailure $ + "expected exactly one pipeline, got " <> show (length infos) + -- cleanup so the next run starts clean + _ <- CommonClient.deleteIngestPipeline pid + pure () + + it "lists the created pipeline via getIngestPipeline Nothing" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let pid = + PipelineId $ + Text.pack $ + "bloodhound_test_ingest_live_list_" <> suffix + _ <- CommonClient.putIngestPipeline pid sampleUppercasePipeline + infos <- CommonClient.getIngestPipeline Nothing + liftIO $ + map (unPipelineId . ingestPipelineInfoId) infos + `shouldSatisfy` elem (unPipelineId pid) + _ <- CommonClient.deleteIngestPipeline pid + pure () + + it "deleteIngestPipeline removes the pipeline" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let pid = + PipelineId $ + Text.pack $ + "bloodhound_test_ingest_live_del_" <> suffix + _ <- CommonClient.putIngestPipeline pid sampleUppercasePipeline + _ <- CommonClient.deleteIngestPipeline pid + infos <- CommonClient.getIngestPipeline Nothing + liftIO $ + map (unPipelineId . ingestPipelineInfoId) infos + `shouldSatisfy` notElem (unPipelineId pid) + + it "simulateIngestPipeline upper-cases the name field" $ + withTestEnv $ do + let docs = + [ object + [ "_index" .= ("ix" :: Text.Text), + "_source" .= object ["name" .= ("hello world" :: Text.Text)] + ] + ] + result <- + CommonClient.simulateIngestPipeline Nothing sampleUppercasePipeline docs + let body = unSimulateResult result + -- Walk the response: docs[0].doc._source.name == "HELLO WORLD" + key :: Text.Text -> Value -> Maybe Value + key k (Object o) = KM.lookup (K.fromText k) o + key _ _ = Nothing + walkName :: Value -> Maybe Value + walkName top = do + docsArr <- key "docs" top + firstDoc <- firstArrayElement docsArr + doc <- key "doc" firstDoc + src <- key "_source" doc + key "name" src + firstArrayElement :: Value -> Maybe Value + firstArrayElement (Array a) = case V.toList a of (x : _) -> Just x; _ -> Nothing + firstArrayElement _ = Nothing + liftIO $ walkName body `shouldBe` Just (String "HELLO WORLD") + + it "simulateIngestPipeline (Just pid) runs the STORED pipeline; the inline body is ignored" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let pid = + PipelineId $ + Text.pack $ + "bloodhound_test_ingest_live_simid_" <> suffix + -- Store a pipeline that uppercases @name@ — we will assert this + -- transformation runs. + _ <- CommonClient.putIngestPipeline pid sampleUppercasePipeline + -- Simulate against the stored id but supply a DIFFERENT inline + -- body (a no-op @set@ of an unrelated field). ES must run the + -- stored pipeline, not the inline one — so @name@ should be + -- upper-cased. + let inlineBody = + IngestPipeline $ + object + [ "description" .= ("inline no-op, should be ignored" :: Text.Text), + "processors" + .= [ object + [ "set" + .= object + [ "field" .= ("inline_marker" :: Text.Text), + "value" .= ("inline" :: Text.Text) + ] + ] + ] + ] + docs = + [ object + [ "_index" .= ("ix" :: Text.Text), + "_source" .= object ["name" .= ("store me" :: Text.Text)] + ] + ] + result <- CommonClient.simulateIngestPipeline (Just pid) inlineBody docs + let body = unSimulateResult result + key :: Text.Text -> Value -> Maybe Value + key k (Object o) = KM.lookup (K.fromText k) o + key _ _ = Nothing + walkName :: Value -> Maybe Value + walkName top = do + docsArr <- key "docs" top + firstDoc <- firstArrayElement docsArr + doc <- key "doc" firstDoc + src <- key "_source" doc + key "name" src + firstArrayElement :: Value -> Maybe Value + firstArrayElement (Array a) = case V.toList a of (x : _) -> Just x; _ -> Nothing + firstArrayElement _ = Nothing + liftIO $ walkName body `shouldBe` Just (String "STORE ME") + _ <- CommonClient.deleteIngestPipeline pid + pure () + +-- | Sample PUT body shaped like a real ingest pipeline: a @description@ +-- and a single @set@ processor. Used by the JSON round-trip tests. +samplePutBodyBytes :: LBS.ByteString +samplePutBodyBytes = + "{\ + \ \"description\": \"example pipeline\",\ + \ \"processors\": [\ + \ { \"set\": { \"field\": \"foo\", \"value\": \"bar\" } }\ + \ ],\ + \ \"version\": 1\ + \}" + +-- | True iff the given 'Value' is an array-shaped processors field. Used +-- to assert the opaque processors body without modelling the ~30 +-- processor types. +hasProcessorsShape :: Value -> Bool +hasProcessorsShape (Array _) = True +hasProcessorsShape _ = False diff --git a/tests/Test/JSONSpec.hs b/tests/Test/JSONSpec.hs --- a/tests/Test/JSONSpec.hs +++ b/tests/Test/JSONSpec.hs @@ -4,10 +4,12 @@ module Test.JSONSpec (spec) where -import qualified Data.ByteString.Lazy.Char8 as BL8 -import qualified Data.List as L -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as BL8 +import Data.List qualified as L +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Optics (view) import TestsUtils.ApproxEq import TestsUtils.Generators import TestsUtils.Import @@ -81,6 +83,108 @@ flagStrs = T.splitOn "|" str in noDuplicates flagStrs + -- Golden tests for the wire-key fix in bloodhound-04f.24. ES docs + -- document these fields in pure snake_case + -- (https://www.elastic.co/guide/en/elasticsearch/reference/current/highlighting.html); + -- the previous camelCase keys were silently dropped on the wire. + -- Highlight types are request-only (no FromJSON), so we pin the + -- encode direction only. + describe "Highlight wire shape (04f.24)" $ do + it "FastVectorHighlight emits phrase_limit" $ + let fvh = + FastVectorHighlight + Nothing + Nothing + Nothing + Nothing + Nothing + [] + (Just (3 :: Int)) + in toJSON (FastVector fvh) + `shouldBe` object + [ "type" .= String "fvh", + "phrase_limit" .= (3 :: Int) + ] + + it "PlainHighlight wraps CommonHighlight.require_field_match" $ + let ch = + CommonHighlight + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + (Just True) + pl = PlainHighlight (Just ch) Nothing + in toJSON (Plain pl) + `shouldBe` object + [ "type" .= String "plain", + "require_field_match" .= True + ] + + -- bloodhound-ajt: the spec highlighter type enum is [plain, fvh, unified]; + -- 'postings' was removed pre-7.x and is server-rejected, so the + -- PostingsHighlight arm is replaced by the modern 'unified' highlighter. + it "UnifiedHighlight emits type unified" $ + let ch = + CommonHighlight + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + (Just True) + uh = UnifiedHighlight (Just ch) + in toJSON (Unified uh) + `shouldBe` object + [ "type" .= String "unified", + "require_field_match" .= True + ] + + -- bloodhound-ajt: HighlightTag.TagSchema previously emitted the wrong key + -- ('scheme') with the wrong value ('default'); the spec key is tags_schema + -- and its only enum value is 'styled'. TagSchema is now a nullary + -- constructor (the old Text arg was ignored). + it "CommonHighlight with TagSchema emits tags_schema styled" $ + let ch = + CommonHighlight + Nothing + Nothing + (Just TagSchema) + Nothing + Nothing + Nothing + Nothing + pl = PlainHighlight (Just ch) Nothing + in toJSON (Plain pl) + `shouldBe` object + [ "type" .= String "plain", + "tags_schema" .= String "styled" + ] + + -- bloodhound-ajt: force_source is marked deprecated:true in the spec + -- (no replacement); the field now carries a DEPRECATED pragma but is + -- still emitted so existing requests keep working. Positional + -- construction avoids triggering the pragma at this call site. + it "CommonHighlight force_source is still emitted (deprecated)" $ + let ch = + CommonHighlight + Nothing + (Just True) -- forceSource (positional: no field-name use) + Nothing + Nothing + Nothing + Nothing + Nothing + pl = PlainHighlight (Just ch) Nothing + in toJSON (Plain pl) + `shouldBe` object + [ "type" .= String "plain", + "force_source" .= True + ] + describe "FromJSON EsError" $ do it "should parse ElasticSearch 7 responses (status & error)" $ do let mbJson = decode "{\"status\": 209, \"error\": \"Error message\"}" @@ -95,6 +199,542 @@ let mbJson = decode "{\"took\":9,\"timed_out\":false,\"total\":3,\"updated\":1,\"deleted\":0,\"batches\":1,\"version_conflicts\":2,\"noops\":0,\"retries\":{\"bulk\":0,\"search\":0},\"throttled_millis\":0,\"requests_per_second\":-1.0,\"throttled_until_millis\":0,\"failures\":[{\"index\":\"directory_test\",\"type\":\"_doc\",\"id\":\"9fda4188-2afd-490d-8796-e023df61a4e9\",\"cause\":{\"type\":\"version_conflict_engine_exception\",\"reason\":\"[9fda4188-2afd-490d-8796-e023df61a4e9]: version conflict, required seqNo [11], primary term [1]. current document has seqNo [16] and primary term [1]\",\"index\":\"directory_test\",\"shard\":\"0\",\"index_uuid\":\"Y3RpVY_DQEW9ULn8oGulrg\"},\"status\":409},{\"index\":\"directory_test\",\"type\":\"_doc\",\"id\":\"d70b631d-966a-4951-a94c-35ddc210f28a\",\"cause\":{\"type\":\"version_conflict_engine_exception\",\"reason\":\"[d70b631d-966a-4951-a94c-35ddc210f28a]: version conflict, required seqNo [13], primary term [1]. current document has seqNo [15] and primary term [1]\",\"index\":\"directory_test\",\"shard\":\"0\",\"index_uuid\":\"Y3RpVY_DQEW9ULn8oGulrg\"},\"status\":409}]}" mbJson `shouldBe` Just (EsError (Just 409) "[9fda4188-2afd-490d-8796-e023df61a4e9]: version conflict, required seqNo [11], primary term [1]. current document has seqNo [16] and primary term [1]") + -- Golden tests for the new 'UpdatableIndexSetting' constructors added + -- in bloodhound-04f.7.14. Each case pins the exact wire shape AND + -- round-trips through FromJSON, so a typo between the twelve slowlog + -- paths (warn/info/debug/trace x query/fetch x search/indexing) would + -- fail. Paths verified against a running ES 7.17 instance: each + -- golden JSON, when PUT to /{idx}, is accepted without "unknown + -- setting" errors. + describe "UpdatableIndexSetting wire shape (04f.7.14)" $ do + let roundTrips :: UpdatableIndexSetting -> Value -> Expectation + roundTrips setting expected = do + toJSON setting `shouldBe` expected + parseEither parseJSON expected `shouldBe` Right setting + + it "index.priority" $ + roundTrips (IndexPriority 5) (object ["index" .= object ["priority" .= (5 :: Int)]]) + + it "index.hidden" $ + roundTrips (IndexHidden True) (object ["index" .= object ["hidden" .= True]]) + + it "index.blocks.read_only_allow_delete" $ + roundTrips (BlocksReadOnlyAllowDelete True) (object ["index" .= object ["blocks" .= object ["read_only_allow_delete" .= True]]]) + + it "blocks.read_only_allow_delete" $ + roundTrips (BlocksReadOnlyAllowDelete True) (object ["index" .= object ["blocks" .= object ["read_only_allow_delete" .= True]]]) + + it "index.blocks.read_only" $ + roundTrips (BlocksReadOnly True) (object ["index" .= object ["blocks" .= object ["read_only" .= True]]]) + + it "index.blocks.read" $ + roundTrips (BlocksRead True) (object ["index" .= object ["blocks" .= object ["read" .= True]]]) + + it "index.blocks.write" $ + roundTrips (BlocksWrite True) (object ["index" .= object ["blocks" .= object ["write" .= True]]]) + + it "index.blocks.metadata" $ + roundTrips (BlocksMetaData True) (object ["index" .= object ["blocks" .= object ["metadata" .= True]]]) + + it "index.requests.cache.enable" $ + roundTrips (RequestsCacheEnable False) (object ["index" .= object ["requests" .= object ["cache" .= object ["enable" .= False]]]]) + + it "index.search.idle.after" $ + roundTrips (IndexSearchIdleAfter (EsDuration 30 TimeUnitSeconds)) (object ["index" .= object ["search" .= object ["idle" .= object ["after" .= String "30s"]]]]) + + it "index.search.slowlog.threshold.query.warn" $ + roundTrips (SearchSlowlogThresholdQueryWarn (EsDuration 10 TimeUnitSeconds)) (object ["index" .= object ["search" .= object ["slowlog" .= object ["threshold" .= object ["query" .= object ["warn" .= String "10s"]]]]]]) + + it "index.search.slowlog.threshold.query.info" $ + roundTrips (SearchSlowlogThresholdQueryInfo (EsDuration 10 TimeUnitSeconds)) (object ["index" .= object ["search" .= object ["slowlog" .= object ["threshold" .= object ["query" .= object ["info" .= String "10s"]]]]]]) + + it "index.search.slowlog.threshold.query.debug" $ + roundTrips (SearchSlowlogThresholdQueryDebug (EsDuration 10 TimeUnitSeconds)) (object ["index" .= object ["search" .= object ["slowlog" .= object ["threshold" .= object ["query" .= object ["debug" .= String "10s"]]]]]]) + + it "index.search.slowlog.threshold.query.trace" $ + roundTrips (SearchSlowlogThresholdQueryTrace (EsDuration 10 TimeUnitSeconds)) (object ["index" .= object ["search" .= object ["slowlog" .= object ["threshold" .= object ["query" .= object ["trace" .= String "10s"]]]]]]) + + it "index.search.slowlog.threshold.fetch.warn" $ + roundTrips (SearchSlowlogThresholdFetchWarn (EsDuration 10 TimeUnitSeconds)) (object ["index" .= object ["search" .= object ["slowlog" .= object ["threshold" .= object ["fetch" .= object ["warn" .= String "10s"]]]]]]) + + it "index.search.slowlog.threshold.fetch.info" $ + roundTrips (SearchSlowlogThresholdFetchInfo (EsDuration 10 TimeUnitSeconds)) (object ["index" .= object ["search" .= object ["slowlog" .= object ["threshold" .= object ["fetch" .= object ["info" .= String "10s"]]]]]]) + + it "index.search.slowlog.threshold.fetch.debug" $ + roundTrips (SearchSlowlogThresholdFetchDebug (EsDuration 10 TimeUnitSeconds)) (object ["index" .= object ["search" .= object ["slowlog" .= object ["threshold" .= object ["fetch" .= object ["debug" .= String "10s"]]]]]]) + + it "index.search.slowlog.threshold.fetch.trace" $ + roundTrips (SearchSlowlogThresholdFetchTrace (EsDuration 10 TimeUnitSeconds)) (object ["index" .= object ["search" .= object ["slowlog" .= object ["threshold" .= object ["fetch" .= object ["trace" .= String "10s"]]]]]]) + + it "index.indexing.slowlog.threshold.index.warn" $ + roundTrips (IndexingSlowlogThresholdIndexWarn (EsDuration 10 TimeUnitSeconds)) (object ["index" .= object ["indexing" .= object ["slowlog" .= object ["threshold" .= object ["index" .= object ["warn" .= String "10s"]]]]]]) + + it "index.indexing.slowlog.threshold.index.info" $ + roundTrips (IndexingSlowlogThresholdIndexInfo (EsDuration 10 TimeUnitSeconds)) (object ["index" .= object ["indexing" .= object ["slowlog" .= object ["threshold" .= object ["index" .= object ["info" .= String "10s"]]]]]]) + + it "index.indexing.slowlog.threshold.index.debug" $ + roundTrips (IndexingSlowlogThresholdIndexDebug (EsDuration 10 TimeUnitSeconds)) (object ["index" .= object ["indexing" .= object ["slowlog" .= object ["threshold" .= object ["index" .= object ["debug" .= String "10s"]]]]]]) + + it "index.indexing.slowlog.threshold.index.trace" $ + roundTrips (IndexingSlowlogThresholdIndexTrace (EsDuration 10 TimeUnitSeconds)) (object ["index" .= object ["indexing" .= object ["slowlog" .= object ["threshold" .= object ["index" .= object ["trace" .= String "10s"]]]]]]) + + -- Golden + round-trip tests for the new 'ExpandWildcards' + -- constructors added in bloodhound-04f.21. Both the 'ToJSON' + -- instance and every URI-param renderer route through + -- 'expandWildcardsText', so pinning the wire string here guards the + -- single source of truth for every endpoint that takes the + -- @expand_wildcards@ parameter. + describe "ExpandWildcards wire shape (04f.21)" $ do + let roundTrip :: ExpandWildcards -> Value -> Expectation + roundTrip v expected = do + toJSON v `shouldBe` expected + parseEither parseJSON expected `shouldBe` Right v + + it "all" $ roundTrip ExpandWildcardsAll (String "all") + it "open" $ roundTrip ExpandWildcardsOpen (String "open") + it "closed" $ roundTrip ExpandWildcardsClosed (String "closed") + it "hidden" $ roundTrip ExpandWildcardsHidden (String "hidden") + it "none" $ roundTrip ExpandWildcardsNone (String "none") + + -- bloodhound-41e: enum boundaries. 'VersionType' dropped the + -- spec-absent @external_gt@; 'ExpandWildcards' dropped the + -- OS-spec-absent @aliases@/@foreign@. Pin both the surviving wire + -- strings and the rejection of the removed values so a regression is + -- caught. + describe "VersionType wire shape (41e)" $ do + let roundTrip v expected = do + toJSON v `shouldBe` expected + parseEither parseJSON expected `shouldBe` Right v + it "internal" $ roundTrip VersionTypeInternal (String "internal") + it "external" $ roundTrip VersionTypeExternal (String "external") + it "external_gte" $ roundTrip VersionTypeExternalGTE (String "external_gte") + it "rejects the removed external_gt" $ + (decode "\"external_gt\"" :: Maybe VersionType) `shouldBe` Nothing + + describe "ExpandWildcards rejects the removed aliases/foreign (41e)" $ do + it "rejects aliases" $ + (decode "\"aliases\"" :: Maybe ExpandWildcards) `shouldBe` Nothing + it "rejects foreign" $ + (decode "\"foreign\"" :: Maybe ExpandWildcards) `shouldBe` Nothing + + -- bloodhound-41e: response-shape requiredness relaxed to match the + -- spec — HitsMetadata required=[hits], Hit required=[_index], bulk + -- ResponseItem._id nullable, PointInTimeReference required=[id]. + -- Pin the decode side so a regression to strict .: is caught. + describe "Response-shape optional fields (41e)" $ do + it "SearchHits decodes without 'total' (track_total_hits:false) as hitsTotal=Nothing" $ + (hitsTotal <$> (decode "{\"hits\":[]}" :: Maybe (SearchHits Value))) + `shouldBe` (Just Nothing :: Maybe (Maybe HitsTotal)) + + it "SearchHits decodes without 'max_score' as maxScore=Nothing" $ + (maxScore <$> (decode "{\"hits\":[]}" :: Maybe (SearchHits Value))) + `shouldBe` (Just Nothing :: Maybe (Maybe Double)) + + it "Hit decodes with only _index (spec-required); _id/_score absent -> Nothing" $ do + let h = decode "{\"_index\":\"twitter\"}" :: Maybe (Hit Value) + (unIndexName . hitIndex <$> h, hitDocId <$> h, hitScore <$> h) + `shouldBe` (Just "twitter", Just Nothing, Just Nothing) + + it "BulkItem decodes _id=null as Nothing (nullable per spec)" $ + (biId <$> (decode "{\"_index\":\"i\",\"_id\":null}" :: Maybe BulkItem)) + `shouldBe` (Just Nothing :: Maybe (Maybe Text)) + + it "BulkItem decodes a missing _id as Nothing" $ + (biId <$> (decode "{\"_index\":\"i\"}" :: Maybe BulkItem)) + `shouldBe` (Just Nothing :: Maybe (Maybe Text)) + + it "TermVectors defaults a missing _id to empty DocId" $ + (termVectorsId <$> (decode "{\"_index\":\"i\"}" :: Maybe TermVectors)) + `shouldBe` Just (DocId "") + + -- GET /{index}/_doc/{id} always returns _seq_no, _primary_term in + -- ES7+\/OpenSearch, plus _routing when the document was indexed with + -- routing. bloodhound-65e added these to 'EsResultFound' so callers + -- can feed them back into if_seq_no\/if_primary_term writes + -- (optimistic concurrency) and reconstruct the routing for follow-up + -- requests. Pure decode tests here pin the parse; the live round-trip + -- lives in DocumentsSpec. + describe "EsResultFound wire shape (65e)" $ do + let fullBody :: BL8.ByteString + fullBody = + "{\"_index\":\"twitter\",\"_id\":\"1\",\ + \\"_version\":3,\"found\":true,\ + \\"_seq_no\":42,\"_primary_term\":7,\"_routing\":\"user-42\",\ + \\"_source\":{\"user\":\"bob\"}}" + + it "decodes _seq_no, _primary_term, _routing on a found document" $ do + let Just (found :: EsResult Value) = decode fullBody + Just rf = foundResult found + view esResultFoundSeqNoLens rf `shouldBe` Just 42 + view esResultFoundPrimaryTermLens rf `shouldBe` Just 7 + view esResultFoundRoutingLens rf `shouldBe` Just "user-42" + + it "decodes a body without the optional fields as Nothing" $ do + let Just (found :: EsResult Value) = + decode + "{\"_index\":\"twitter\",\"_id\":\"1\",\ + \\"_version\":1,\"found\":true,\ + \\"_source\":{\"user\":\"bob\"}}" + Just rf = foundResult found + view esResultFoundSeqNoLens rf `shouldBe` Nothing + view esResultFoundPrimaryTermLens rf `shouldBe` Nothing + view esResultFoundRoutingLens rf `shouldBe` Nothing + + it "still exposes _version and _source alongside the new fields" $ do + let Just (found :: EsResult Value) = decode fullBody + Just rf = foundResult found + _version rf `shouldBe` DocVersion 3 + getSource found `shouldBe` Just (object ["user" .= ("bob" :: Text)]) + + it "treats _seq_no, _primary_term, _routing as independently optional" $ do + -- Pin that the three new fields are not coupled: a body with + -- _routing present but _seq_no/_primary_term absent decodes with + -- the latter two as Nothing (some OpenSearch routed-GET shapes). + let Just (found :: EsResult Value) = + decode + "{\"_index\":\"twitter\",\"_id\":\"1\",\ + \\"_version\":1,\"found\":true,\ + \\"_routing\":\"user-42\",\ + \\"_source\":{\"user\":\"bob\"}}" + Just rf = foundResult found + view esResultFoundSeqNoLens rf `shouldBe` Nothing + view esResultFoundPrimaryTermLens rf `shouldBe` Nothing + view esResultFoundRoutingLens rf `shouldBe` Just "user-42" + + it "yields foundResult=Nothing when _source is absent (_source=false)" $ do + -- Documents the known footgun: when the caller sends _source=false + -- the server omits the _source key, the EsResultFound parser + -- fails, and the EsResult parser's 'optional' swallow fires — + -- so the new fields cannot be inspected in that case. The new + -- fields do not introduce a regression here (the swallow predates + -- them), but pinning the behavior protects callers from assuming + -- _seq_no is always reachable. + let Just (found :: EsResult Value) = + decode + "{\"_index\":\"twitter\",\"_id\":\"1\",\ + \\"_version\":1,\"found\":true,\ + \\"_seq_no\":5,\"_primary_term\":2}" + foundResult found `shouldBe` (Nothing :: Maybe (EsResultFound Value)) + + describe "ClusterHealthStatus accepts both casings (41e)" $ do + it "decodes uppercase GREEN/YELLOW/RED" $ do + decode "\"GREEN\"" `shouldBe` (Just ClusterHealthGreen :: Maybe ClusterHealthStatus) + decode "\"YELLOW\"" `shouldBe` (Just ClusterHealthYellow :: Maybe ClusterHealthStatus) + decode "\"RED\"" `shouldBe` (Just ClusterHealthRed :: Maybe ClusterHealthStatus) + it "still decodes lowercase green/yellow/red" $ do + decode "\"green\"" `shouldBe` (Just ClusterHealthGreen :: Maybe ClusterHealthStatus) + decode "\"yellow\"" `shouldBe` (Just ClusterHealthYellow :: Maybe ClusterHealthStatus) + decode "\"red\"" `shouldBe` (Just ClusterHealthRed :: Maybe ClusterHealthStatus) + it "rejects an unknown status" $ + (decode "\"purple\"" :: Maybe ClusterHealthStatus) `shouldBe` Nothing + + -- bloodhound-kc1: ClusterHealth gained several conditional Maybe + -- fields (task_max_waiting_in_queue[_millis], unassigned_primaries, + -- discovered_*, indices). They are absent on the default + -- cluster-level response and present with @level=indices@ or during + -- master election. Pin both paths. + describe "ClusterHealth Maybe fields (kc1)" $ do + let minimalBody = + BL8.pack + "{\"cluster_name\":\"c\",\"status\":\"green\",\"timed_out\":false,\ + \\"number_of_nodes\":1,\"number_of_data_nodes\":1,\ + \\"active_primary_shards\":1,\"active_shards\":1,\ + \\"relocating_shards\":0,\"initializing_shards\":0,\ + \\"unassigned_shards\":0,\"delayed_unassigned_shards\":0,\ + \\"number_of_pending_tasks\":0,\"number_of_in_flight_fetch\":0,\ + \\"active_shards_percent_as_number\":100.0}" + fullBody = + BL8.pack + "{\"cluster_name\":\"c\",\"status\":\"yellow\",\"timed_out\":false,\ + \\"number_of_nodes\":3,\"number_of_data_nodes\":3,\ + \\"active_primary_shards\":2,\"active_shards\":4,\ + \\"relocating_shards\":0,\"initializing_shards\":1,\ + \\"unassigned_shards\":1,\"delayed_unassigned_shards\":0,\ + \\"number_of_pending_tasks\":2,\"number_of_in_flight_fetch\":1,\ + \\"task_max_waiting_in_queue_millis\":1234,\ + \\"task_max_waiting_in_queue\":\"1.2s\",\ + \\"active_shards_percent_as_number\":80.0,\ + \\"unassigned_primaries\":1,\ + \\"discovered_master\":true,\ + \\"discovered_cluster_manager\":true,\ + \\"discovered_nodes\":3,\"discovered_data_nodes\":3}" + + it "leaves the new Maybe fields as Nothing on the minimal response" $ do + let Just (h :: ClusterHealth) = decode minimalBody + clusterHealthTaskMaxWaitingInQueueMillis h `shouldBe` Nothing + clusterHealthTaskMaxWaitingInQueue h `shouldBe` Nothing + clusterHealthUnassignedPrimaries h `shouldBe` Nothing + clusterHealthDiscoveredMaster h `shouldBe` Nothing + clusterHealthDiscoveredClusterManager h `shouldBe` Nothing + clusterHealthDiscoveredNodes h `shouldBe` Nothing + clusterHealthDiscoveredDataNodes h `shouldBe` Nothing + clusterHealthIndices h `shouldBe` Nothing + + it "parses the new fields when present" $ do + let Just (h :: ClusterHealth) = decode fullBody + clusterHealthTaskMaxWaitingInQueueMillis h `shouldBe` Just 1234 + clusterHealthTaskMaxWaitingInQueue h `shouldBe` Just "1.2s" + clusterHealthUnassignedPrimaries h `shouldBe` Just 1 + clusterHealthDiscoveredMaster h `shouldBe` Just True + clusterHealthDiscoveredClusterManager h `shouldBe` Just True + clusterHealthDiscoveredNodes h `shouldBe` Just 3 + clusterHealthDiscoveredDataNodes h `shouldBe` Just 3 + + it "parses the indices sub-object verbatim when level=indices is used" $ do + let body = + BL8.pack + "{\"cluster_name\":\"c\",\"status\":\"green\",\"timed_out\":false,\ + \\"number_of_nodes\":1,\"number_of_data_nodes\":1,\ + \\"active_primary_shards\":1,\"active_shards\":1,\ + \\"relocating_shards\":0,\"initializing_shards\":0,\ + \\"unassigned_shards\":0,\"delayed_unassigned_shards\":0,\ + \\"number_of_pending_tasks\":0,\"number_of_in_flight_fetch\":0,\ + \\"active_shards_percent_as_number\":100.0,\ + \\"indices\":{\"my-idx\":{\"status\":\"green\",\"active_shards\":1}}}" + let Just (h :: ClusterHealth) = decode body + case clusterHealthIndices h of + Just o -> KM.size o `shouldBe` 1 + Nothing -> expectationFailure "expected indices object, got Nothing" + + -- Golden encode tests for 'SortMode' (the @mode@ option on the + -- search sort DSL). The 'SortMode' type is encode-only (no + -- 'FromJSON'; the whole Sort module is deferred from round-tripping + -- per the note at 'CollapseInnerHits' in + -- 'Database.Bloodhound.Internal.Versions.Common.Types.Search'), so + -- this is a one-directional wire-shape guard, not a round-trip. + -- bloodhound-04f.9 added the missing @median@ value; pin all five + -- constructors here so the wire contract stays stable for every + -- endpoint that renders a 'DefaultSort'. + describe "SortMode wire shape (04f.9)" $ do + let encodes :: SortMode -> Value -> Expectation + encodes v expected = toJSON v `shouldBe` expected + + it "min" $ encodes SortMin (String "min") + it "max" $ encodes SortMax (String "max") + it "sum" $ encodes SortSum (String "sum") + it "avg" $ encodes SortAvg (String "avg") + it "median" $ encodes SortMedian (String "median") + + -- Encode-only wire-shape guards for 'SortSpec' (the @sort@ request body). + -- The whole Sort module is deferred from round-tripping per the note at + -- 'CollapseInnerHits' in 'Common.Types.Search', so these pin the + -- request-side JSON that 'DefaultSortSpec' and 'GeoDistanceSortSpec' + -- produce. bloodhound-536 fixed two wire bugs: 'GeoDistanceSortSpec' was + -- missing its @_geo_distance@ wrapper (and dropped @distance_type@/@mode@/ + -- @ignore_unmapped@/@nested@), and 'DefaultSort' rendered the ES-7.0-removed + -- flat @nested_filter@ key instead of the @nested@ object. + describe "SortSpec wire shape (536)" $ do + let geoPoint = GeoPoint (FieldName "location") (LatLon 48.8566 2.3522) + termFilter = Filter (TermQuery (Term "color" "red") Nothing) + + it "DefaultSort with no nested field omits the nested key" $ do + let sortSpec' = DefaultSortSpec $ mkSort (FieldName "age") Ascending + toJSON sortSpec' + `shouldBe` object + [ "age" .= object ["order" .= String "asc"] + ] + + it "DefaultSort carries nested as an object, not the flat nested_filter key" $ do + let ds = + (mkSort (FieldName "child.age") Ascending) + { nestedSort = + Just + ( NestedSortValue + { nestedSortPath = FieldName "child", + nestedSortFilter = Just termFilter, + nestedSortMaxChildren = Just 10, + nestedSortNested = Nothing + } + ) + } + toJSON (DefaultSortSpec ds) + `shouldBe` object + [ "child.age" + .= object + [ "order" .= String "asc", + "nested" + .= object + [ "path" .= String "child", + "filter" + .= object + [ "term" + .= object + [ "color" .= object ["value" .= String "red"] + ] + ], + "max_children" .= Number 10 + ] + ] + ] + + it "NestedSortValue omits optional sub-fields when Nothing" $ + toJSON + ( NestedSortValue + { nestedSortPath = FieldName "child", + nestedSortFilter = Nothing, + nestedSortMaxChildren = Nothing, + nestedSortNested = Nothing + } + ) + `shouldBe` object ["path" .= String "child"] + + it "NestedSortValue recurses on the nested key" $ + let inner = NestedSortValue (FieldName "grandchild") Nothing Nothing Nothing + in toJSON + ( NestedSortValue + { nestedSortPath = FieldName "child", + nestedSortFilter = Nothing, + nestedSortMaxChildren = Nothing, + nestedSortNested = Just inner + } + ) + `shouldBe` object + [ "path" .= String "child", + "nested" .= object ["path" .= String "grandchild"] + ] + + it "GeoDistanceSortSpec wraps body under the _geo_distance key" $ do + let sortSpec' = GeoDistanceSortSpec $ mkGeoDistanceSort Ascending geoPoint + toJSON sortSpec' + `shouldBe` object + [ "_geo_distance" + .= object + [ "location" + .= object ["lat" .= Number 48.8566, "lon" .= Number 2.3522], + "order" .= String "asc" + ] + ] + + it "GeoDistanceSortSpec carries all spec fields when set" $ do + let gds = + (mkGeoDistanceSort Descending geoPoint) + { gdsDistanceUnit = Just Kilometers, + gdsDistanceType = Just Arc, + gdsSortMode = Just SortMin, + gdsIgnoreUnmapped = Just True, + gdsNested = + Just + ( NestedSortValue + { nestedSortPath = FieldName "child", + nestedSortFilter = Nothing, + nestedSortMaxChildren = Nothing, + nestedSortNested = Nothing + } + ) + } + toJSON (GeoDistanceSortSpec gds) + `shouldBe` object + [ "_geo_distance" + .= object + [ "location" + .= object ["lat" .= Number 48.8566, "lon" .= Number 2.3522], + "order" .= String "desc", + "unit" .= String "km", + "distance_type" .= String "arc", + "mode" .= String "min", + "ignore_unmapped" .= Bool True, + "nested" .= object ["path" .= String "child"] + ] + ] + + it "GeoDistanceSortSpec never emits a flat top-level field-name key" $ + case toJSON (GeoDistanceSortSpec $ mkGeoDistanceSort Ascending geoPoint) of + Object o -> + KM.keys o `shouldBe` ["_geo_distance"] + other -> expectationFailure $ "expected Object, got " <> show other + + it "Sort (list of SortSpec) renders as a JSON array of specs" $ do + let sortList :: Sort + sortList = + [ DefaultSortSpec $ mkSort (FieldName "age") Ascending, + GeoDistanceSortSpec $ mkGeoDistanceSort Descending geoPoint + ] + case toJSON sortList of + Array xs -> length xs `shouldBe` 2 + other -> expectationFailure $ "expected Array, got " <> show other + + describe "RangeQuery wire shape (wzb)" $ do + let dmGte = DateMathString "now-1d" + dmLte = DateMathString "now/d" + dmLt = DateMathString "now-1h" + twoBound = + RangeDateMathValue + { rangeDateMathLt = Nothing, + rangeDateMathLte = Just dmLte, + rangeDateMathGt = Nothing, + rangeDateMathGte = Just dmGte + } + + it "RangeDateMath encodes gte/lte as date-math strings" $ + toJSON (mkRangeQuery (FieldName "ts") (RangeDateMath twoBound)) + `shouldBe` object + [ "ts" + .= object + [ "gte" .= String "now-1d", + "lte" .= String "now/d" + ] + ] + + it "RangeDateMath with only lt omits the other bound keys" $ + toJSON + ( mkRangeQuery (FieldName "ts") $ + RangeDateMath + RangeDateMathValue + { rangeDateMathLt = Just dmLt, + rangeDateMathLte = Nothing, + rangeDateMathGt = Nothing, + rangeDateMathGte = Nothing + } + ) + `shouldBe` object ["ts" .= object ["lt" .= String "now-1h"]] + + it "a date-math range body round-trips through FromJSON/ToJSON" $ do + let rq = mkRangeQuery (FieldName "ts") (RangeDateMath twoBound) + decode (encode rq) `shouldBe` Just rq + + it "decodes a date-math range body to RangeDateMath" $ + ( decode + "{\"gte\":\"now-1d\",\"lte\":\"now/d\"}" :: + Maybe RangeValue + ) + `shouldBe` Just (RangeDateMath twoBound) + + it "decodes a date-math range query via FromJSON Query to QueryRangeQuery" $ + ( decode + "{\"range\":{\"ts\":{\"lt\":\"now-1h\"}}}" :: + Maybe Query + ) + `shouldBe` Just + ( QueryRangeQuery $ + mkRangeQuery + (FieldName "ts") + ( RangeDateMath + RangeDateMathValue + { rangeDateMathLt = Just dmLt, + rangeDateMathLte = Nothing, + rangeDateMathGt = Nothing, + rangeDateMathGte = Nothing + } + ) + ) + + it "regression: an ISO-8601 body decodes to RangeDate* (not RangeDateMath)" $ + case ( decode + "{\"gte\":\"2099-01-01T00:00:00Z\",\"lte\":\"2099-01-02T00:00:00Z\"}" :: + Maybe RangeValue + ) of + Just (RangeDateGteLte _ _) -> pure () + other -> + expectationFailure $ + "expected RangeDateGteLte, got " <> show other + + it "regression: a numeric body decodes to RangeDouble* (not RangeDateMath)" $ + ( decode + "{\"gte\":1,\"lte\":2}" :: + Maybe RangeValue + ) + `shouldBe` Just (RangeDoubleGteLte (GreaterThanEq 1) (LessThanEq 2)) + describe "Exact isomorphism JSON instances" $ do propJSON (Proxy :: Proxy IndexName) propJSON (Proxy :: Proxy DocId) @@ -131,11 +771,8 @@ propJSON (Proxy :: Proxy StopWord) propJSON (Proxy :: Proxy QueryPath) propJSON (Proxy :: Proxy AllowLeadingWildcard) - propJSON (Proxy :: Proxy LowercaseExpanded) propJSON (Proxy :: Proxy EnablePositionIncrements) propJSON (Proxy :: Proxy AnalyzeWildcard) - propJSON (Proxy :: Proxy GeneratePhraseQueries) - propJSON (Proxy :: Proxy Locale) propJSON (Proxy :: Proxy MaxWordLength) propJSON (Proxy :: Proxy MinWordLength) propJSON (Proxy :: Proxy PhraseSlop) @@ -151,7 +788,6 @@ propJSON (Proxy :: Proxy RangeQuery) propJSON (Proxy :: Proxy PrefixQuery) propJSON (Proxy :: Proxy NestedQuery) - propJSON (Proxy :: Proxy MoreLikeThisFieldQuery) propJSON (Proxy :: Proxy MoreLikeThisQuery) propJSON (Proxy :: Proxy IndicesQuery) propJSON (Proxy :: Proxy IgnoreUnmapped) @@ -161,8 +797,6 @@ propJSON (Proxy :: Proxy HasParentQuery) propJSON (Proxy :: Proxy HasChildQuery) propJSON (Proxy :: Proxy FuzzyQuery) - propJSON (Proxy :: Proxy FuzzyLikeFieldQuery) - propJSON (Proxy :: Proxy FuzzyLikeThisQuery) propJSON (Proxy :: Proxy FunctionScoreQuery) propJSON (Proxy :: Proxy BoostMode) propJSON (Proxy :: Proxy ScoreMode) @@ -175,10 +809,12 @@ propJSON (Proxy :: Proxy BoostingQuery) propJSON (Proxy :: Proxy BoolQuery) propJSON (Proxy :: Proxy MatchQuery) + propJSON (Proxy :: Proxy MatchPhraseQuery) + propJSON (Proxy :: Proxy MatchPhrasePrefixQuery) propJSON (Proxy :: Proxy MultiMatchQueryType) propJSON (Proxy :: Proxy BooleanOperator) propJSON (Proxy :: Proxy ZeroTermsQuery) - propJSON (Proxy :: Proxy MatchQueryType) + propJSON (Proxy :: Proxy RangeRelation) propJSON (Proxy :: Proxy AliasRouting) propJSON (Proxy :: Proxy IndexAliasCreate) propJSON (Proxy :: Proxy SearchAliasRouting) @@ -205,6 +841,21 @@ propJSON (Proxy :: Proxy Suggest) propJSON (Proxy :: Proxy DirectGenerators) propJSON (Proxy :: Proxy DirectGeneratorSuggestModeTypes) + -- New suggester types (bloodhound-04f.10). 'SuggestType' itself is + -- not covered here because 'SuggestTypeContextSuggester' does not + -- round-trip at the 'SuggestType' level (it decodes as + -- 'SuggestTypeCompletionSuggester'); the 'Arbitrary SuggestType' + -- generator omits it so the @propJSON (Proxy :: Proxy Suggest)@ + -- above stays sound. Each new field type is covered directly. + propJSON (Proxy :: Proxy TermSuggester) + propJSON (Proxy :: Proxy TermSuggesterSort) + propJSON (Proxy :: Proxy TermSuggesterStringDistance) + propJSON (Proxy :: Proxy ContextQueryValue) + propJSON (Proxy :: Proxy CompletionSuggesterFuzzy) + propJSON (Proxy :: Proxy CompletionSuggester) + propJSON (Proxy :: Proxy ContextSuggester) + propJSON (Proxy :: Proxy RolloverConditions) + propJSON (Proxy :: Proxy RolloverResponse) describe "Approximate isomorphism JSON instances" $ do propApproxJSON (Proxy :: Proxy UpdatableIndexSetting') @@ -214,3 +865,6 @@ propApproxJSON (Proxy :: Proxy AllocationPolicy) propApproxJSON (Proxy :: Proxy InitialShardCount) propApproxJSON (Proxy :: Proxy FSType) + propApproxJSON (Proxy :: Proxy EsDuration) + propApproxJSON (Proxy :: Proxy DiskWatermark) + propApproxJSON (Proxy :: Proxy Compression) diff --git a/tests/Test/JobSchedulerSpec.hs b/tests/Test/JobSchedulerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/JobSchedulerSpec.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.JobSchedulerSpec (spec) where + +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Map.Strict qualified as Map +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types qualified as OS3Types +import TestsUtils.Import +import Prelude + +-- --------------------------------------------------------------------------- +-- Pure endpoint-shape and JSON-decoding tests for the OpenSearch Job +-- Scheduler plugin (@\/_plugins\/_job_scheduler\/api@). No live backend +-- is needed: every assertion runs against the in-memory 'BHRequest' +-- produced by the OS3 'Requests' module, or against JSON fixtures quoted +-- verbatim from a live OS 3.7.0 cluster. +-- +-- The @\/api\/jobs@ and @\/api\/locks@ REST handlers are only registered +-- on OpenSearch 3.x (a 1.x or 2.x cluster answers @404 no handler found@ +-- even when the @opensearch-job-scheduler@ plugin is installed), so this +-- surface lives solely in the OS3 module — see the type module Haddock +-- for the availability caveat. +-- +-- See +spec :: Spec +spec = describe "OpenSearch Job Scheduler API" $ do + -- =============================================================== + -- Endpoint-shape tests (no live backend) + -- =============================================================== + describe "getJobSchedulerJobs endpoint shape" $ + it "GETs /_plugins/_job_scheduler/api/jobs with no body or query" $ do + let req = OS3Requests.getJobSchedulerJobs + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_job_scheduler", "api", "jobs"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + describe "getJobSchedulerLocks endpoint shape" $ + it "GETs /_plugins/_job_scheduler/api/locks with no body or query" $ do + let req = OS3Requests.getJobSchedulerLocks + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_job_scheduler", "api", "locks"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + describe "getJobSchedulerLock endpoint shape" $ + it "GETs /_plugins/_job_scheduler/api/locks/{lock_id} with no body or query" $ do + let req = OS3Requests.getJobSchedulerLock (OS3Types.LockId ".opendistro-ism-config-myjob_123") + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_job_scheduler", "api", "locks", ".opendistro-ism-config-myjob_123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + -- =============================================================== + -- LockId JSON + -- =============================================================== + describe "LockId JSON" $ do + it "encodes LockId as a bare JSON string" $ + encode (OS3Types.LockId "index-jobid_42") + `shouldBe` "\"index-jobid_42\"" + it "decodes a bare JSON string into LockId" $ + decode "\"index-jobid_42\"" `shouldBe` Just (OS3Types.LockId "index-jobid_42") + it "round-trips LockId through encode -> decode" $ do + let original = OS3Types.LockId "round-trip-id" + (decode . encode) original `shouldBe` Just original + + -- =============================================================== + -- LocksResponse / LockEntry JSON (live-verified OS 3.7.0 shapes) + -- =============================================================== + describe "LocksResponse JSON" $ do + it "decodes the verbatim two-lock fixture" $ do + let Just resp = decode sampleLocksJson :: Maybe OS3Types.LocksResponse + OS3Types.locksResponseTotalLocks resp `shouldBe` 2 + Map.size (OS3Types.locksResponseLocks resp) `shouldBe` 2 + it "exposes each lock's typed fields" $ do + let Just resp = decode sampleLocksJson :: Maybe OS3Types.LocksResponse + Just entry = OS3Types.lookupLockEntry ".opendistro-ism-config-delprobe_tid_1859609" resp + OS3Types.lockEntryJobIndexName entry `shouldBe` Just ".opendistro-ism-config" + OS3Types.lockEntryJobId entry `shouldBe` Just "delprobe_tid_1859609" + OS3Types.lockEntryLockTime entry `shouldBe` Just 1782421825 + OS3Types.lockEntryLockDurationSeconds entry `shouldBe` Just 1800 + OS3Types.lockEntryReleased entry `shouldBe` Just True + OS3Types.lockEntryExtras entry `shouldBe` Nothing + it "lookupLockEntry returns Nothing for an absent id" $ do + let Just resp = decode sampleLocksJson :: Maybe OS3Types.LocksResponse + OS3Types.lookupLockEntry "nope" resp `shouldBe` Nothing + it "decodes an empty envelope (valid-format but unknown id)" $ do + let Just resp = decode "{ \"total_locks\": 0, \"locks\": {} }" :: Maybe OS3Types.LocksResponse + OS3Types.locksResponseTotalLocks resp `shouldBe` 0 + OS3Types.locksResponseLocks resp `shouldBe` Map.empty + it "defaults total_locks/locks when the keys are absent" $ do + let Just resp = decode "{}" :: Maybe OS3Types.LocksResponse + OS3Types.locksResponseTotalLocks resp `shouldBe` 0 + OS3Types.locksResponseLocks resp `shouldBe` Map.empty + + describe "LockEntry lenient decoding" $ do + it "captures unrecognised fields in lockEntryExtras" $ do + let Just (e :: OS3Types.LockEntry) = + decode + "{ \"job_id\": \"j1\", \ + \\"released\": false, \ + \\"custom_meta\": 7 }" + OS3Types.lockEntryJobId e `shouldBe` Just "j1" + OS3Types.lockEntryReleased e `shouldBe` Just False + OS3Types.lockEntryExtras e `shouldSatisfy` isJust + it "reads Nothing for every field of a minimal object" $ do + let Just (e :: OS3Types.LockEntry) = decode "{}" + OS3Types.lockEntryJobIndexName e `shouldBe` Nothing + OS3Types.lockEntryLockTime e `shouldBe` Nothing + + -- =============================================================== + -- JobsResponse / JobEntry JSON + -- =============================================================== + describe "JobsResponse JSON" $ do + it "decodes the empty envelope" $ do + let Just resp = decode sampleJobsEmptyJson :: Maybe OS3Types.JobsResponse + OS3Types.jobsResponseTotalJobs resp `shouldBe` 0 + OS3Types.jobsResponseJobs resp `shouldBe` [] + OS3Types.jobsResponseFailures resp `shouldBe` [] + it "decodes a populated job, routing plugin-specific fields to extras" $ do + let Just resp = decode sampleJobsPopulatedJson :: Maybe OS3Types.JobsResponse + OS3Types.jobsResponseTotalJobs resp `shouldBe` 1 + length (OS3Types.jobsResponseJobs resp) `shouldBe` 1 + let job = head (OS3Types.jobsResponseJobs resp) + OS3Types.jobEntryName job `shouldBe` Just "Snx1-J4BQHJI9IqNYJBj" + OS3Types.jobEntryEnabled job `shouldBe` Just False + OS3Types.jobEntryLockDurationSeconds job `shouldBe` Just 60 + OS3Types.jobEntryJobType job `shouldBe` Just "AD" + OS3Types.jobEntryJobId job `shouldBe` Nothing + -- window_delay / disabled_time are not known keys -> land in extras. + let Just extras = OS3Types.jobEntryExtras job + KeyMap.lookup "window_delay" extras `shouldSatisfy` isJust + KeyMap.lookup "disabled_time" extras `shouldSatisfy` isJust + it "defaults total_jobs/jobs/failures when the keys are absent" $ do + let Just resp = decode "{}" :: Maybe OS3Types.JobsResponse + OS3Types.jobsResponseTotalJobs resp `shouldBe` 0 + OS3Types.jobsResponseJobs resp `shouldBe` [] + + describe "JobEntry _source wrapper tolerance" $ + it "decodes a job wrapped in a {_source: ...} search hit" $ do + let wrapped = + "{ \"_source\": { \"name\": \"wrapped\", \"enabled\": true } }" + Just (e :: OS3Types.JobEntry) = decode wrapped + OS3Types.jobEntryName e `shouldBe` Just "wrapped" + OS3Types.jobEntryEnabled e `shouldBe` Just True + + -- =============================================================== + -- JobSchedulerSchedule JSON + -- =============================================================== + describe "JobSchedulerSchedule JSON" $ do + it "decodes the interval form" $ do + let Just (s :: OS3Types.JobSchedulerSchedule) = + decode "{ \"interval\": { \"period\": 1, \"unit\": \"Minutes\", \"start_time\": 42 } }" + Just (OS3Types.JobSchedulerScheduleInterval i) = Just s + OS3Types.jobSchedulerIntervalPeriod i `shouldBe` Just 1 + OS3Types.jobSchedulerIntervalUnit i `shouldBe` Just "Minutes" + OS3Types.jobSchedulerIntervalStartTime i `shouldBe` Just 42 + it "decodes the cron form" $ do + let Just (s :: OS3Types.JobSchedulerSchedule) = + decode "{ \"cron\": { \"expression\": \"0 * * * *\", \"timezone\": \"UTC\" } }" + Just (OS3Types.JobSchedulerScheduleCron c) = Just s + OS3Types.jobSchedulerCronExpression c `shouldBe` Just "0 * * * *" + OS3Types.jobSchedulerCronTimezone c `shouldBe` Just "UTC" + it "decodes an unknown schedule kind via the Custom escape hatch" $ do + let Just (s :: OS3Types.JobSchedulerSchedule) = + decode "{ \"daily\": { \"at\": \"12:00\" } }" + s `shouldSatisfy` (\case OS3Types.JobSchedulerScheduleCustom _ -> True; _ -> False) + + -- =============================================================== + -- Round-trip symmetry + -- =============================================================== + describe "Round-trip symmetry" $ do + it "JobsResponse round-trips through encode -> decode" $ do + let Just original = decode sampleJobsPopulatedJson :: Maybe OS3Types.JobsResponse + (decode . encode) original `shouldBe` Just original + it "LocksResponse round-trips through encode -> decode" $ do + let Just original = decode sampleLocksJson :: Maybe OS3Types.LocksResponse + (decode . encode) original `shouldBe` Just original + +-- --------------------------------------------------------------------------- +-- Fixtures, quoted verbatim from a live OS 3.7.0 cluster. +-- --------------------------------------------------------------------------- + +-- | @GET /_plugins/_job_scheduler/api/locks@ on a cluster running an ISM +-- probe job and an Anomaly Detection detector. +sampleLocksJson :: LBS.ByteString +sampleLocksJson = + "{\ + \ \"total_locks\": 2,\ + \ \"locks\": {\ + \ \".opendistro-ism-config-delprobe_tid_1859609\": {\ + \ \"job_index_name\": \".opendistro-ism-config\",\ + \ \"job_id\": \"delprobe_tid_1859609\",\ + \ \"lock_time\": 1782421825,\ + \ \"lock_duration_seconds\": 1800,\ + \ \"released\": true\ + \ },\ + \ \".opendistro-anomaly-detector-jobs-Snx1-J4BQHJI9IqNYJBj\": {\ + \ \"job_index_name\": \".opendistro-anomaly-detector-jobs\",\ + \ \"job_id\": \"Snx1-J4BQHJI9IqNYJBj\",\ + \ \"lock_time\": 1782285322,\ + \ \"lock_duration_seconds\": 60,\ + \ \"released\": true\ + \ }\ + \ }\ + \}" + +-- | @GET /_plugins/_job_scheduler/api/jobs@ on an idle scheduler (the +-- endpoint lists no jobs even though locks exist — see the type module +-- Haddock for the availability caveat). +sampleJobsEmptyJson :: LBS.ByteString +sampleJobsEmptyJson = + "{\ + \ \"total_jobs\": 0,\ + \ \"jobs\": [],\ + \ \"failures\": []\ + \}" + +-- | A populated jobs response. The @jobs@ element is reconstructed from +-- the @ScheduledJobParameter@ document stored in +-- @.opendistro-anomaly-detector-jobs@ (its @_source@, fetched via a +-- direct index search): the @window_delay@ / @disabled_time@ keys are +-- plugin-specific and exercise the @extras@ catch-all. +sampleJobsPopulatedJson :: LBS.ByteString +sampleJobsPopulatedJson = + "{\ + \ \"total_jobs\": 1,\ + \ \"jobs\": [\ + \ {\ + \ \"name\": \"Snx1-J4BQHJI9IqNYJBj\",\ + \ \"schedule\": {\ + \ \"interval\": { \"start_time\": 1782284902663, \"period\": 1, \"unit\": \"Minutes\" }\ + \ },\ + \ \"enabled\": false,\ + \ \"enabled_time\": 1782284902663,\ + \ \"last_update_time\": 1782285322682,\ + \ \"lock_duration_seconds\": 60,\ + \ \"type\": \"AD\",\ + \ \"window_delay\": { \"period\": { \"interval\": 0, \"unit\": \"Seconds\" } },\ + \ \"disabled_time\": 1782285322682\ + \ }\ + \ ],\ + \ \"failures\": []\ + \}" diff --git a/tests/Test/KnnClearCacheSpec.hs b/tests/Test/KnnClearCacheSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/KnnClearCacheSpec.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.KnnClearCacheSpec (spec) where + +import Database.Bloodhound.OpenSearch2.Client qualified as OS2.Client +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch3.Client qualified as OS3.Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- | Pure endpoint-shape tests for the k-NN plugin Clear Cache API +-- (@POST /_plugins/_knn/clear_cache\/{index}@) across OpenSearch 2 and 3. +-- The endpoint was added in OpenSearch 2.14, so unlike 'Test.KnnWarmupSpec' +-- there is no OpenSearch 1 variant. These mirror 'Test.NeuralClearCacheSpec's +-- shape tests but assert the @\/_plugins\/_knn\/clear_cache@ path, the POST +-- method, the empty-object body, and OS2\/OS3 cross-backend parity. JSON +-- decoding of the shared 'ShardsResult' response is re-verified here on +-- the clear-cache response shape +-- (@{\"_shards\":{\"total\":...,\"successful\":...,\"failed\":...}}@, +-- live-verified against OS 2.19.5 \/ 3.7.0) so a regression in the +-- pre-existing instance is caught in this spec too. +spec :: Spec +spec = describe "k-NN Clear Cache API" $ do + describe "clearKnnCache endpoint shape (OpenSearch 3)" $ do + it "POSTs to /_plugins/_knn/clear_cache/{index} when given an IndexName" $ do + let req = OS3Requests.clearKnnCache [[qqIndexName|my-index|]] + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "clear_cache", "my-index"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches an empty JSON object as the body" $ do + let req = OS3Requests.clearKnnCache [[qqIndexName|my-index|]] + bhRequestBody req `shouldBe` Just (encode (object [])) + + it "uses a distinct index in the path when given a different IndexName" $ do + let req = OS3Requests.clearKnnCache [[qqIndexName|other-index|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "clear_cache", "other-index"] + + it "keeps the index name as a single opaque path segment" $ do + let req = OS3Requests.clearKnnCache [[qqIndexName|my-index_42|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "clear_cache", "my-index_42"] + + describe "clearKnnCache endpoint shape (OpenSearch 2)" $ do + it "POSTs to /_plugins/_knn/clear_cache/{index} when given an IndexName" $ do + let req = OS2Requests.clearKnnCache [[qqIndexName|my-index|]] + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "clear_cache", "my-index"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches an empty JSON object as the body" $ do + let req = OS2Requests.clearKnnCache [[qqIndexName|my-index|]] + bhRequestBody req `shouldBe` Just (encode (object [])) + + it "uses a distinct index in the path when given a different IndexName" $ do + let req = OS2Requests.clearKnnCache [[qqIndexName|other-index|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "clear_cache", "other-index"] + + it "keeps the index name as a single opaque path segment" $ do + let req = OS2Requests.clearKnnCache [[qqIndexName|my-index_42|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "clear_cache", "my-index_42"] + + -- ---------------------------------------------------------------- -- + -- Multi-index (comma-separated) path rendering: bloodhound-6jy. -- + -- The k-NN Clear Cache API documents comma-separated lists and -- + -- index patterns in the {index} path segment; the [IndexName] -- + -- argument is rendered as a single comma-joined segment, matching -- + -- the OpenSearch multi-target syntax. -- + -- ---------------------------------------------------------------- -- + describe "clearKnnCache multi-index path rendering (OpenSearch 3)" $ do + it "renders [i1,i2,i3] as a single comma-joined path segment" $ do + let req = + OS3Requests.clearKnnCache + [[qqIndexName|index1|], [qqIndexName|index2|], [qqIndexName|index3|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "clear_cache", "index1,index2,index3"] + + it "preserves index name order in the comma-joined segment" $ do + let req = + OS3Requests.clearKnnCache + [[qqIndexName|zebra|], [qqIndexName|alpha|], [qqIndexName|mike|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "clear_cache", "zebra,alpha,mike"] + + it "renders an empty segment for an empty index list (server will error)" $ do + let req = OS3Requests.clearKnnCache [] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "clear_cache", ""] + + describe "clearKnnCache multi-index path rendering (OpenSearch 2)" $ do + it "renders [i1,i2] as a single comma-joined path segment" $ do + let req = + OS2Requests.clearKnnCache [[qqIndexName|index1|], [qqIndexName|index2|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "clear_cache", "index1,index2"] + + describe "clearKnnCache cross-backend parity" $ do + -- OS2 and OS3 must emit the same path, POST method, empty-object body, + -- and empty query string for the same 'IndexName'. (OS1 is excluded: + -- the Clear Cache API was added in OpenSearch 2.14.) + let idx = [qqIndexName|shared-index|] + + it "OS2, OS3 produce the same path segments" $ do + let path2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.clearKnnCache [idx])) + path3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.clearKnnCache [idx])) + path2 `shouldBe` path3 + + it "OS2, OS3 all use POST" $ do + let m2 = bhRequestMethod (OS2Requests.clearKnnCache [idx]) + m3 = bhRequestMethod (OS3Requests.clearKnnCache [idx]) + m2 `shouldBe` "POST" + m3 `shouldBe` "POST" + + it "OS2, OS3 all carry no query string" $ do + let q2 = getRawEndpointQueries (bhRequestEndpoint (OS2Requests.clearKnnCache [idx])) + q3 = getRawEndpointQueries (bhRequestEndpoint (OS3Requests.clearKnnCache [idx])) + q2 `shouldBe` [] + q3 `shouldBe` [] + + it "OS2, OS3 attach identical body bytes" $ do + let b2 = bhRequestBody (OS2Requests.clearKnnCache [idx]) + b3 = bhRequestBody (OS3Requests.clearKnnCache [idx]) + b2 `shouldBe` b3 + + describe "clearKnnCache is distinct from warmupKnnIndex" $ do + -- Guards against an accidental copy-paste regression where + -- clearKnnCache silently re-uses the warmup endpoint. The two APIs + -- share the @\/_plugins\/_knn@ prefix and a 'ShardsResult' return + -- type, but since bloodhound-04f.6.2.9 they differ in three ways: + -- method (@POST@ for clear_cache vs @GET@ for warmup), body + -- (empty-object for clear_cache vs absent for warmup), and the + -- @clear_cache@ vs @warmup@ path segment. The path is the most + -- stable distinguishing feature so it is the one pinned here; a + -- method-divergence assertion lives in 'Test.KnnWarmupSpec'. + let idx = [qqIndexName|shared-index|] + + it "OS2 clear_cache path differs from warmup path" $ do + let clearPath = getRawEndpoint (bhRequestEndpoint (OS2Requests.clearKnnCache [idx])) + warmupPath = getRawEndpoint (bhRequestEndpoint (OS2Requests.warmupKnnIndex [idx])) + clearPath `shouldNotBe` warmupPath + + it "OS3 clear_cache path differs from warmup path" $ do + let clearPath = getRawEndpoint (bhRequestEndpoint (OS3Requests.clearKnnCache [idx])) + warmupPath = getRawEndpoint (bhRequestEndpoint (OS3Requests.warmupKnnIndex [idx])) + clearPath `shouldNotBe` warmupPath + + describe "ShardsResult response decoding" $ do + -- Pure unit tests (no OS round-trip): lock the 'FromJSON ShardsResult' + -- decoder against the actual wire shape returned by + -- @POST /_plugins/_knn/clear_cache\/{index}@. Live OS 2.19.5 \/ 3.7.0 + -- confirmed the response is the @_shards@ envelope (matching + -- @warmupKnnIndex@, @flushIndex@, @refreshIndex@, @clearIndexCache@), + -- not the @{\"acknowledged\":true}@ envelope the previous + -- 'Acknowledged' return type assumed. + it "decodes {\"_shards\":{\"total\":2,\"successful\":1,\"skipped\":0,\"failed\":0}} into ShardsResult" $ do + let payload = "{\"_shards\":{\"total\":2,\"successful\":1,\"skipped\":0,\"failed\":0}}" + Just decoded = decode payload :: Maybe ShardsResult + decoded `shouldBe` ShardsResult (ShardResult 2 1 0 0) + + it "rejects a payload missing the _shards envelope" $ do + let payload = "{\"acknowledged\":true}" + decoded = decode payload :: Maybe ShardsResult + decoded `shouldBe` Nothing + + it "round-trips a captured live clear-cache response through the decoder" $ do + let original = "{\"_shards\":{\"total\":2,\"successful\":1,\"failed\":0}}" + Just decoded = decode original :: Maybe ShardsResult + shardTotal (srShards decoded) `shouldBe` 2 + + -- ---------------------------------------------------------------- -- + -- Live round-trip: gated per-OS with os{n}OnlyIT (the -- + -- 'Test.MLModelSpec' pattern). The k-NN Clear Cache API was added -- + -- in OpenSearch 2.14, so only OS 2 and OS 3 are exercised — OS 1 -- + -- is excluded. -- + -- -- + -- Wire shape live-verified against OS 2.19.5 (port 9204) and OS -- + -- 3.7.0 (port 9205) in bead bloodhound-vvj: the response is -- + -- @{"_shards":{"total":2,"successful":1,"failed":0}}@ — the -- + -- @_shards@ envelope, decoded into 'ShardsResult'. -- + -- ---------------------------------------------------------------- -- + describe "clearKnnCache live round-trip" $ do + os2It <- runIO os2OnlyIT + os3It <- runIO os3OnlyIT + + let assertShards :: ShardsResult -> IO () + assertShards (ShardsResult sr) = do + shardTotal sr `shouldSatisfy` (>= 1) + shardsFailed sr `shouldBe` 0 + + os2It "OS2: returns a ShardsResult with at least one shard and no failures" $ + withTestEnv $ do + _ <- tryEsError resetOsKnnIndex + result <- OS2.Client.clearKnnCache osKnnTestIndex + liftIO $ assertShards result + + os3It "OS3: returns a ShardsResult with at least one shard and no failures" $ + withTestEnv $ do + _ <- tryEsError resetOsKnnIndex + result <- OS3.Client.clearKnnCache osKnnTestIndex + liftIO $ assertShards result diff --git a/tests/Test/KnnEs8Spec.hs b/tests/Test/KnnEs8Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/KnnEs8Spec.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.KnnEs8Spec (spec) where + +import Data.Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Maybe (isJust) +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch8.Client +import TestsUtils.Common +import TestsUtils.Import + +vectorField :: FieldName +vectorField = FieldName "vector" + +queryVector :: [Double] +queryVector = [0.1, 0.2, 0.3, 0.4, 0.5] + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +-- | True iff the encoded object has a "knn" key whose value is itself an +-- object containing another "knn" key. Detects the pre-fix wrapper shape +-- @{"index": ..., "knn": {"field": ...}}@. +hasNestedKnnKey :: LBS.ByteString -> Bool +hasNestedKnnKey bs = case decode bs of + Just (Object obj) -> case KM.lookup "knn" obj of + Just (Object inner) -> "knn" `KM.member` inner + _ -> False + _ -> False + +spec :: Spec +spec = describe "k-NN Search API - Elasticsearch 8" $ do + describe "request body shape" $ do + it "serializes a KnnQuery as a bare ES clause (no index wrapper, no nested knn key)" $ do + let clause = + (mkKnnQuery vectorField queryVector (Just 3)) + { knnNumCandidates = Just 100 + } + let json = encode clause + json `shouldSatisfy` hasKey "field" + json `shouldSatisfy` hasKey "query_vector" + json `shouldSatisfy` hasKey "k" + json `shouldSatisfy` hasKey "num_candidates" + json `shouldNotSatisfy` hasKey "index" + json `shouldNotSatisfy` hasNestedKnnKey + + it "omits Nothing optional fields from the clause body" $ do + let clause = mkKnnQuery vectorField queryVector (Just 3) + let json = encode clause + json `shouldNotSatisfy` hasKey "filter" + json `shouldNotSatisfy` hasKey "similarity" + json `shouldNotSatisfy` hasKey "boost" + json `shouldNotSatisfy` hasKey "query_vector_builder" + json `shouldNotSatisfy` hasKey "inner_hits" + + it "includes filter, similarity, boost when set" $ do + let clause = + (mkKnnQuery vectorField queryVector (Just 5)) + { knnNumCandidates = Just 50, + knnSimilarity = Just 0.9, + knnBoost = Just 1.2, + knnFilter = Just (Filter (TermQuery (Term "label" "alpha") Nothing)) + } + let json = encode clause + json `shouldSatisfy` hasKey "filter" + json `shouldSatisfy` hasKey "similarity" + json `shouldSatisfy` hasKey "boost" + + it "serializes a query_vector_builder with text_embedding shape" $ do + let clause = + (mkKnnQuery vectorField [] (Just 5)) + { knnQueryVectorBuilder = + Just $ + KnnQueryVectorBuilderTextEmbedding + { knnTextEmbeddingModelId = "model-x", + knnTextEmbeddingModelText = "hello world" + } + } + let Just (Object obj) = decode (encode clause) + Just (Object builder) <- pure $ KM.lookup "query_vector_builder" obj + Just (Object te) <- pure $ KM.lookup "text_embedding" builder + KM.lookup "model_id" te `shouldBe` Just "model-x" + KM.lookup "model_text" te `shouldBe` Just "hello world" + + it "round-trips a KnnQuery through ToJSON/FromJSON" $ do + let clause = + (mkKnnQuery vectorField queryVector (Just 3)) + { knnNumCandidates = Just 100 + } + decode (encode clause) `shouldBe` Just clause + + it "serializes a Search with knnBody as a top-level knn array" $ do + let clause = mkKnnQuery vectorField queryVector (Just 3) + let search = (mkSearch Nothing Nothing) {knnBody = Just [clause]} + let json = encode search + json `shouldSatisfy` hasKey "knn" + json `shouldNotSatisfy` hasNestedKnnKey + let Just (Object obj) = decode json + let Just (Array knnArr) = KM.lookup "knn" obj + length knnArr `shouldBe` 1 + + describe "spec compliance (bloodhound-bqe)" $ do + it "never emits the non-spec window_bytes key" $ do + let clause = + (mkKnnQuery vectorField queryVector (Just 5)) + { knnNumCandidates = Just 100, + knnSimilarity = Just 0.9, + knnBoost = Just 1.2, + knnFilter = Just (Filter (TermQuery (Term "label" "alpha") Nothing)) + } + let json = encode clause + json `shouldNotSatisfy` hasKey "window_bytes" + + it "omits k when knnK = Nothing (k is optional per _types.KnnSearch)" $ do + let clause = (mkKnnQuery vectorField queryVector Nothing) {knnNumCandidates = Just 100} + let json = encode clause + json `shouldNotSatisfy` hasKey "k" + json `shouldSatisfy` hasKey "field" + + it "round-trips a KnnQuery with knnK = Nothing" $ do + let clause = (mkKnnQuery vectorField queryVector Nothing) {knnNumCandidates = Just 100} + decode (encode clause) `shouldBe` Just clause + + it "decodes a clause body that omits the optional k" $ do + let bare = "{\"field\":\"vector\",\"query_vector\":[0.1,0.2,0.3,0.4,0.5]}" + decode bare `shouldBe` Just (mkKnnQuery vectorField queryVector Nothing) + + describe "endpoint shape" $ do + it "POSTs to /{index}/_search (not /_knn_search)" $ do + let req = knnSearch @KnnDoc knnTestIndex (mkKnnQuery vectorField queryVector (Just 3)) (mkSearch Nothing Nothing) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName knnTestIndex, "_search"] + + it "carries no query string (the old bug shoved knn JSON into ?index=)" $ do + let req = knnSearch @KnnDoc knnTestIndex (mkKnnQuery vectorField queryVector (Just 3)) (mkSearch Nothing Nothing) + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "embeds the knn clause in the request body, not as a query param" $ do + let req = knnSearch @KnnDoc knnTestIndex (mkKnnQuery vectorField queryVector (Just 3)) (mkSearch Nothing Nothing) + let body = bhRequestBody req + body `shouldSatisfy` isJust + let Just bodyBytes = body + hasKey "knn" bodyBytes `shouldBe` True + + describe "live integration (requires ES8+ backend with dense_vector)" $ + backendSpecific [ElasticSearch8, ElasticSearch9] $ do + it "returns the nearest neighbour document" $ + withTestEnv $ do + insertKnnData + let search = mkSearch Nothing Nothing + clause = mkKnnQuery vectorField queryVector (Just 3) + result <- tryPerformBHRequest $ knnSearch @KnnDoc knnTestIndex clause search + case result of + Left e -> liftIO $ expectationFailure $ "knnSearch failed: " <> show e + Right searchResult -> do + let topHit = headMay $ hits $ searchHits searchResult + liftIO $ (hitDocId <$> topHit) `shouldBe` Just (Just (DocId "a")) + + it "supports optional filter and similarity fields" $ + withTestEnv $ do + insertKnnData + let search = mkSearch Nothing Nothing + clause = + (mkKnnQuery vectorField queryVector (Just 5)) + { knnNumCandidates = Just 50, + knnSimilarity = Just 0.0, + knnFilter = Just (Filter (TermQuery (Term "label" "alpha") Nothing)) + } + result <- tryPerformBHRequest $ knnSearch @KnnDoc knnTestIndex clause search + liftIO $ result `shouldSatisfy` isRight diff --git a/tests/Test/KnnEs9Spec.hs b/tests/Test/KnnEs9Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/KnnEs9Spec.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.KnnEs9Spec (spec) where + +import Data.Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Maybe (isJust) +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch9.Client +import TestsUtils.Common +import TestsUtils.Import + +vectorField :: FieldName +vectorField = FieldName "vector" + +queryVector :: [Double] +queryVector = [0.1, 0.2, 0.3, 0.4, 0.5] + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +hasNestedKnnKey :: LBS.ByteString -> Bool +hasNestedKnnKey bs = case decode bs of + Just (Object obj) -> case KM.lookup "knn" obj of + Just (Object inner) -> "knn" `KM.member` inner + _ -> False + _ -> False + +spec :: Spec +spec = describe "k-NN Search API - Elasticsearch 9" $ do + describe "request body shape" $ do + it "serializes a KnnQuery as a bare ES clause (no index wrapper, no nested knn key)" $ do + let clause = + (mkKnnQuery vectorField queryVector (Just 3)) + { knnNumCandidates = Just 100 + } + let json = encode clause + json `shouldSatisfy` hasKey "field" + json `shouldSatisfy` hasKey "query_vector" + json `shouldSatisfy` hasKey "k" + json `shouldSatisfy` hasKey "num_candidates" + json `shouldNotSatisfy` hasKey "index" + json `shouldNotSatisfy` hasNestedKnnKey + + it "round-trips a KnnQuery through ToJSON/FromJSON" $ do + let clause = + (mkKnnQuery vectorField queryVector (Just 3)) + { knnNumCandidates = Just 100 + } + decode (encode clause) `shouldBe` Just clause + + it "serializes a Search with knnBody as a top-level knn array" $ do + let clause = mkKnnQuery vectorField queryVector (Just 3) + let search = (mkSearch Nothing Nothing) {knnBody = Just [clause]} + let json = encode search + json `shouldSatisfy` hasKey "knn" + json `shouldNotSatisfy` hasNestedKnnKey + let Just (Object obj) = decode json + let Just (Array knnArr) = KM.lookup "knn" obj + length knnArr `shouldBe` 1 + + describe "spec compliance (bloodhound-bqe)" $ do + it "never emits the non-spec window_bytes key" $ do + let clause = (mkKnnQuery vectorField queryVector (Just 5)) {knnNumCandidates = Just 100} + let json = encode clause + json `shouldNotSatisfy` hasKey "window_bytes" + + it "omits k when knnK = Nothing (k is optional per _types.KnnSearch)" $ do + let clause = (mkKnnQuery vectorField queryVector Nothing) {knnNumCandidates = Just 100} + let json = encode clause + json `shouldNotSatisfy` hasKey "k" + json `shouldSatisfy` hasKey "field" + + it "round-trips a KnnQuery with knnK = Nothing" $ do + let clause = (mkKnnQuery vectorField queryVector Nothing) {knnNumCandidates = Just 100} + decode (encode clause) `shouldBe` Just clause + + it "decodes a clause body that omits the optional k" $ do + let bare = "{\"field\":\"vector\",\"query_vector\":[0.1,0.2,0.3,0.4,0.5]}" + decode bare `shouldBe` Just (mkKnnQuery vectorField queryVector Nothing) + + describe "endpoint shape" $ do + it "POSTs to /{index}/_search (not /_knn_search)" $ do + let req = knnSearch @KnnDoc knnTestIndex (mkKnnQuery vectorField queryVector (Just 3)) (mkSearch Nothing Nothing) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName knnTestIndex, "_search"] + + it "carries no query string (the old bug shoved knn JSON into ?index=)" $ do + let req = knnSearch @KnnDoc knnTestIndex (mkKnnQuery vectorField queryVector (Just 3)) (mkSearch Nothing Nothing) + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "embeds the knn clause in the request body, not as a query param" $ do + let req = knnSearch @KnnDoc knnTestIndex (mkKnnQuery vectorField queryVector (Just 3)) (mkSearch Nothing Nothing) + let body = bhRequestBody req + body `shouldSatisfy` isJust + let Just bodyBytes = body + hasKey "knn" bodyBytes `shouldBe` True + + describe "live integration (requires ES9 backend with dense_vector)" $ + backendSpecific [ElasticSearch9] $ do + it "returns the nearest neighbour document" $ + withTestEnv $ do + insertKnnData + let search = mkSearch Nothing Nothing + clause = mkKnnQuery vectorField queryVector (Just 3) + result <- tryPerformBHRequest $ knnSearch @KnnDoc knnTestIndex clause search + case result of + Left e -> liftIO $ expectationFailure $ "knnSearch failed: " <> show e + Right searchResult -> do + let topHit = headMay $ hits $ searchHits searchResult + liftIO $ (hitDocId <$> topHit) `shouldBe` Just (Just (DocId "a")) + + it "supports optional filter and similarity fields" $ + withTestEnv $ do + insertKnnData + let search = mkSearch Nothing Nothing + clause = + (mkKnnQuery vectorField queryVector (Just 5)) + { knnNumCandidates = Just 50, + knnSimilarity = Just 0.0, + knnFilter = Just (Filter (TermQuery (Term "label" "alpha") Nothing)) + } + result <- tryPerformBHRequest $ knnSearch @KnnDoc knnTestIndex clause search + liftIO $ result `shouldSatisfy` isRight diff --git a/tests/Test/KnnModelSpec.hs b/tests/Test/KnnModelSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/KnnModelSpec.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.KnnModelSpec (spec) where + +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- | A representative response body for @GET /_plugins/_knn/models/{model_id}@, +-- drawn from the OpenSearch vector-search API documentation. @model_blob@ is +-- truncated; the real value is a large base64 serialization of the trained +-- graph. +sampleFullResponse :: LBS.ByteString +sampleFullResponse = + "{\ + \ \"model_id\" : \"test-model\",\ + \ \"model_blob\" : \"SXdGbIAAAAAAAAAAAA...\",\ + \ \"state\" : \"created\",\ + \ \"timestamp\" : \"2021-11-15T18:45:07.505369036Z\",\ + \ \"description\" : \"Default\",\ + \ \"error\" : \"\",\ + \ \"space_type\" : \"l2\",\ + \ \"dimension\" : 128,\ + \ \"engine\" : \"faiss\"\ + \}" + +-- | A metadata-only response: a caller that passes @?filter_path=model_id,state@ +-- (or @_source_excludes=model_blob@) receives a subset. The parser must +-- tolerate any field being absent. +samplePartialResponse :: LBS.ByteString +samplePartialResponse = + "{\ + \ \"model_id\" : \"test-model\",\ + \ \"state\" : \"created\"\ + \}" + +-- | A model still undergoing training has no @model_blob@ yet and reports a +-- @training@ state. +sampleTrainingResponse :: LBS.ByteString +sampleTrainingResponse = + "{\ + \ \"model_id\" : \"train-model\",\ + \ \"state\" : \"training\"\ + \}" + +-- | A representative @POST /_plugins/_knn/models/_search@ response: the +-- standard OpenSearch search envelope wrapping hits from +-- @.opensearch-knn-models@. The first hit carries a full @_source@; the +-- second is metadata-only, mirroring the documented +-- @_source_excludes=model_blob@ read. Both must decode into 'KnnModel' +-- under 'SearchResult'. +sampleSearchModelsResponse :: LBS.ByteString +sampleSearchModelsResponse = + "{\ + \ \"took\" : 3,\ + \ \"timed_out\" : false,\ + \ \"_shards\" : {\"total\" : 1, \"successful\" : 1, \"skipped\" : 0, \"failed\" : 0},\ + \ \"hits\" : {\ + \ \"total\" : {\"value\" : 2, \"relation\" : \"eq\"},\ + \ \"max_score\" : 1.0,\ + \ \"hits\" : [\ + \ {\ + \ \"_index\" : \".opensearch-knn-models\",\ + \ \"_id\" : \"test-model\",\ + \ \"_score\" : 1.0,\ + \ \"_source\" : {\ + \ \"model_id\" : \"test-model\",\ + \ \"state\" : \"created\",\ + \ \"space_type\" : \"l2\",\ + \ \"dimension\" : 128,\ + \ \"engine\" : \"faiss\"\ + \ }\ + \ },\ + \ {\ + \ \"_index\" : \".opensearch-knn-models\",\ + \ \"_id\" : \"meta-only\",\ + \ \"_score\" : 1.0,\ + \ \"_source\" : {\ + \ \"model_id\" : \"meta-only\",\ + \ \"state\" : \"training\"\ + \ }\ + \ }\ + \ ]\ + \ }\ + \}" + +spec :: Spec +spec = describe "k-NN Get Model API" $ do + describe "KnnModelState JSON" $ do + it "encodes the three documented states as bare strings" $ do + encode KnnModelStateCreated `shouldBe` "\"created\"" + encode KnnModelStateFailed `shouldBe` "\"failed\"" + encode KnnModelStateTraining `shouldBe` "\"training\"" + + it "decodes the three documented states" $ do + decode "\"created\"" `shouldBe` Just KnnModelStateCreated + decode "\"failed\"" `shouldBe` Just KnnModelStateFailed + decode "\"training\"" `shouldBe` Just KnnModelStateTraining + + it "rejects an unknown state" $ do + let decoded = decode "\"loaded\"" :: Maybe KnnModelState + decoded `shouldBe` Nothing + + describe "KnnEngine JSON (OpenSearchKnnEngine reuse)" $ do + it "encodes the documented engines as bare strings" $ do + encode KnnEngineFaiss `shouldBe` "\"faiss\"" + encode KnnEngineNmslib `shouldBe` "\"nmslib\"" + encode KnnEngineLucene `shouldBe` "\"lucene\"" + + it "decodes the documented engines" $ do + decode "\"faiss\"" `shouldBe` Just KnnEngineFaiss + decode "\"nmslib\"" `shouldBe` Just KnnEngineNmslib + decode "\"lucene\"" `shouldBe` Just KnnEngineLucene + + it "rejects an unknown engine" $ do + let decoded = decode "\"annoy\"" :: Maybe OpenSearchKnnEngine + decoded `shouldBe` Nothing + + describe "KnnModel JSON" $ do + it "decodes a fully-populated response" $ do + let Just decoded = decode sampleFullResponse :: Maybe KnnModel + knnModelModelId decoded `shouldBe` "test-model" + knnModelState decoded `shouldBe` Just KnnModelStateCreated + knnModelDimension decoded `shouldBe` Just 128 + knnModelEngine decoded `shouldBe` Just KnnEngineFaiss + knnModelModelBlob decoded `shouldBe` Just "SXdGbIAAAAAAAAAAAA..." + + it "decodes a metadata-only (filter_path) response" $ do + let Just decoded = decode samplePartialResponse :: Maybe KnnModel + knnModelModelId decoded `shouldBe` "test-model" + knnModelState decoded `shouldBe` Just KnnModelStateCreated + knnModelModelBlob decoded `shouldBe` Nothing + knnModelDimension decoded `shouldBe` Nothing + knnModelEngine decoded `shouldBe` Nothing + + it "decodes a training-state model without a blob" $ do + let Just decoded = decode sampleTrainingResponse :: Maybe KnnModel + knnModelModelId decoded `shouldBe` "train-model" + knnModelState decoded `shouldBe` Just KnnModelStateTraining + knnModelModelBlob decoded `shouldBe` Nothing + + it "decodes a failed-state model carrying a non-empty error" $ do + let Just decoded = + decode + "{\ + \ \"model_id\":\"bad-model\",\ + \ \"state\":\"failed\",\ + \ \"error\":\"training failed: cluster timeout\"\ + \}" :: + Maybe KnnModel + knnModelModelId decoded `shouldBe` "bad-model" + knnModelState decoded `shouldBe` Just KnnModelStateFailed + knnModelError decoded `shouldBe` Just "training failed: cluster timeout" + + it "tolerates unknown fields (forward compatibility)" $ do + let Just decoded = decode "{\"model_id\":\"x\",\"future_field\":42}" :: Maybe KnnModel + knnModelModelId decoded `shouldBe` "x" + + it "requires the model_id field" $ do + let decoded = decode "{\"state\":\"created\"}" :: Maybe KnnModel + decoded `shouldBe` Nothing + + it "decodes an empty error string as Just \"\"" $ do + let Just decoded = decode sampleFullResponse :: Maybe KnnModel + knnModelError decoded `shouldBe` Just "" + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe KnnModel + decoded `shouldBe` Nothing + + it "rejects malformed JSON" $ do + let decoded = decode "{ not json" :: Maybe KnnModel + decoded `shouldBe` Nothing + + it "round-trips a full body through ToJSON/FromJSON" $ do + let Just decoded = decode sampleFullResponse :: Maybe KnnModel + (decode . encode) decoded `shouldBe` Just decoded + + it "round-trips a partial body through ToJSON/FromJSON" $ do + let Just decoded = decode samplePartialResponse :: Maybe KnnModel + (decode . encode) decoded `shouldBe` Just decoded + + it "ToJSON omits Nothing fields (no null leakage)" $ do + let Just decoded = decode samplePartialResponse :: Maybe KnnModel + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` not . BS.isInfixOf "\"model_blob\"" + encoded `shouldSatisfy` not . BS.isInfixOf "\"dimension\"" + + it "ToJSON emits a field when it is present" $ do + let Just decoded = decode sampleFullResponse :: Maybe KnnModel + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` BS.isInfixOf "\"engine\"" + encoded `shouldSatisfy` BS.isInfixOf "\"dimension\"" + + describe "getKnnModel endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "GETs /_plugins/_knn/models/{model_id} for the given ModelId" $ do + let req = OS3Requests.getKnnModel (ModelId "test-model") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "test-model"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the model id as a single opaque path segment" $ do + let req = OS3Requests.getKnnModel (ModelId "faiss-ivf-pq_42") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "faiss-ivf-pq_42"] + + it "uses a distinct id in the path when given a different ModelId" $ do + let req = OS3Requests.getKnnModel (ModelId "other-model") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "other-model"] + + it "uses the GET method" $ do + let req = OS3Requests.getKnnModel (ModelId "test-model") + bhRequestMethod req `shouldBe` "GET" + + it "does not attach a body (GET semantics)" $ do + let req = OS3Requests.getKnnModel (ModelId "test-model") + bhRequestBody req `shouldBe` Nothing + + describe "KnnDeleteModelResponse JSON" $ do + it "decodes the documented {model_id, result} response" $ do + let Just decoded = decode "{\"model_id\":\"m\",\"result\":\"deleted\"}" :: Maybe KnnDeleteModelResponse + knnDeleteModelResponseModelId decoded `shouldBe` "m" + knnDeleteModelResponseResult decoded `shouldBe` "deleted" + + it "echoes the model_id passed in the path" $ do + let Just decoded = decode "{\"model_id\":\"faiss-ivf_42\",\"result\":\"deleted\"}" :: Maybe KnnDeleteModelResponse + knnDeleteModelResponseModelId decoded `shouldBe` "faiss-ivf_42" + + it "round-trips through ToJSON/FromJSON" $ do + let original = KnnDeleteModelResponse "test-model" "deleted" + (decode . encode) original `shouldBe` Just original + + it "tolerates unknown fields (forward compatibility)" $ do + let Just decoded = decode "{\"model_id\":\"x\",\"result\":\"deleted\",\"future_field\":42}" :: Maybe KnnDeleteModelResponse + knnDeleteModelResponseModelId decoded `shouldBe` "x" + + it "requires the model_id field" $ do + let decoded = decode "{\"result\":\"deleted\"}" :: Maybe KnnDeleteModelResponse + decoded `shouldBe` Nothing + + it "requires the result field" $ do + let decoded = decode "{\"model_id\":\"x\"}" :: Maybe KnnDeleteModelResponse + decoded `shouldBe` Nothing + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe KnnDeleteModelResponse + decoded `shouldBe` Nothing + + it "rejects malformed JSON" $ do + let decoded = decode "{ not json" :: Maybe KnnDeleteModelResponse + decoded `shouldBe` Nothing + + describe "deleteKnnModel endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "DELETEs /_plugins/_knn/models/{model_id} for the given ModelId" $ do + let req = OS3Requests.deleteKnnModel (ModelId "test-model") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "test-model"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the model id as a single opaque path segment" $ do + let req = OS3Requests.deleteKnnModel (ModelId "faiss-ivf-pq_42") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "faiss-ivf-pq_42"] + + it "uses a distinct id in the path when given a different ModelId" $ do + let req = OS3Requests.deleteKnnModel (ModelId "other-model") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "other-model"] + + it "uses the DELETE method" $ do + let req = OS3Requests.deleteKnnModel (ModelId "test-model") + bhRequestMethod req `shouldBe` "DELETE" + + it "does not attach a body (DELETE semantics)" $ do + let req = OS3Requests.deleteKnnModel (ModelId "test-model") + bhRequestBody req `shouldBe` Nothing + + -- The DELETE and GET endpoints share an identical path and differ only in + -- HTTP method, so a copy-paste regression that pointed deleteKnnModel at + -- the GET builder would be invisible without this guard. Mirrors the + -- clearKnnCache/warmupKnnIndex distinctness precedent in Test.KnnClearCacheSpec. + it "is distinct from getKnnModel (same path, different method)" $ do + let modelId = ModelId "test-model" + delReq = OS3Requests.deleteKnnModel modelId + getReq = OS3Requests.getKnnModel modelId + getRawEndpoint (bhRequestEndpoint delReq) + `shouldBe` getRawEndpoint (bhRequestEndpoint getReq) + bhRequestMethod delReq `shouldBe` "DELETE" + bhRequestMethod getReq `shouldBe` "GET" + bhRequestMethod delReq `shouldNotBe` bhRequestMethod getReq + + describe "searchKnnModels endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + -- Mirrors the submitOSAsyncSearch body-forwarding tests and the + -- searchModels (ML Commons) path test. + it "POSTs to /_plugins/_knn/models/_search with no query string" $ do + let req = OS3Requests.searchKnnModels (mkSearch (Just (MatchAllQuery Nothing)) Nothing) + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches the encoded Search as the JSON body" $ do + let search = mkSearch (Just (MatchAllQuery Nothing)) Nothing + req = OS3Requests.searchKnnModels search + bhRequestBody req `shouldBe` Just (encode search) + + it "tracks the input Search: a different query yields a different body" $ do + let reqA = OS3Requests.searchKnnModels (mkSearch (Just (MatchAllQuery Nothing)) Nothing) + reqB = OS3Requests.searchKnnModels (mkSearch (Just (TermQuery (Term "user" "bob") Nothing)) Nothing) + bhRequestBody reqA `shouldNotBe` bhRequestBody reqB + + describe "searchKnnModels SearchResult KnnModel JSON" $ do + it "decodes the standard search envelope into SearchResult KnnModel" $ do + let Just decoded = decode sampleSearchModelsResponse :: Maybe (SearchResult KnnModel) + took decoded `shouldBe` 3 + timedOut decoded `shouldBe` False + let modelHits = hits (searchHits decoded) + length modelHits `shouldBe` 2 + + it "decodes a fully-populated _source as KnnModel" $ do + let Just decoded = decode sampleSearchModelsResponse :: Maybe (SearchResult KnnModel) + firstHit = head (hits (searchHits decoded)) + Just model = hitSource firstHit + knnModelModelId model `shouldBe` "test-model" + knnModelState model `shouldBe` Just KnnModelStateCreated + knnModelDimension model `shouldBe` Just 128 + knnModelEngine model `shouldBe` Just KnnEngineFaiss + + it "decodes a metadata-only _source (model_blob excluded) as KnnModel" $ do + let Just decoded = decode sampleSearchModelsResponse :: Maybe (SearchResult KnnModel) + secondHit = hits (searchHits decoded) !! 1 + Just model = hitSource secondHit + knnModelModelId model `shouldBe` "meta-only" + knnModelState model `shouldBe` Just KnnModelStateTraining + knnModelModelBlob model `shouldBe` Nothing + knnModelDimension model `shouldBe` Nothing + + it "rejects a response missing the hits envelope" $ do + let decoded = decode "{\"took\":1,\"timed_out\":false,\"_shards\":{}}" :: Maybe (SearchResult KnnModel) + decoded `shouldBe` Nothing diff --git a/tests/Test/KnnOs1Spec.hs b/tests/Test/KnnOs1Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/KnnOs1Spec.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.KnnOs1Spec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch1.Types +import Network.HTTP.Types.Method qualified as NHTM +import TestsUtils.Import +import Prelude + +-- | Sample identifiers for endpoint-shape assertions. The k-NN plugin uses +-- opaque 22-character node IDs; any 'Text' round-trips, so these are short +-- stand-ins purely for URL-segment checks. +testNodeId :: KnnNodeId +testNodeId = KnnNodeId "nodeIdOne" + +testStatName :: KnnStatName +testStatName = KnnStatName "hit_count" + +testModelId :: ModelId +testModelId = ModelId "test-model" + +-- | A minimal 'KnnTrainingRequest' (FAISS IVF) — only the shape matters for +-- endpoint tests, never the field values. +sampleTrainingRequest :: KnnTrainingRequest +sampleTrainingRequest = + KnnTrainingRequest + { knnTrainingRequestIndex = [qqIndexName|train-idx|], + knnTrainingRequestField = FieldName "vector", + knnTrainingRequestDimension = 4, + knnTrainingRequestMethod = + KnnTrainingMethod + { knnTrainingMethodName = "ivf", + knnTrainingMethodEngine = KnnEngineFaiss, + knnTrainingMethodSpaceType = Just "l2", + knnTrainingMethodParameters = Nothing + }, + knnTrainingRequestSpaceType = Nothing, + knnTrainingRequestMaxTrainingVectorCount = Nothing, + knnTrainingRequestSearchSize = Nothing, + knnTrainingRequestDescription = Nothing + } + +spec :: Spec +spec = describe "k-NN plugin endpoint shapes - OpenSearch 1" $ do + describe "getKnnStats" $ do + it "GETs /_plugins/_knn/stats with no node/stat filters" $ do + let req = OS1Requests.getKnnStats Nothing Nothing + bhRequestMethod req `shouldBe` NHTM.methodGet + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_knn", "stats"] + bhRequestBody req `shouldSatisfy` isNothing + + it "inserts the node id and stat name into the path when given" $ do + let req = OS1Requests.getKnnStats (Just testNodeId) (Just testStatName) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", unKnnNodeId testNodeId, "stats", unKnnStatName testStatName] + + it "emits node id only when no stat is requested" $ do + let req = OS1Requests.getKnnStats (Just testNodeId) Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", unKnnNodeId testNodeId, "stats"] + + describe "getKnnModel" $ do + it "GETs /_plugins/_knn/models/{model_id} with no body" $ do + let req = OS1Requests.getKnnModel testModelId + bhRequestMethod req `shouldBe` NHTM.methodGet + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", unModelId testModelId] + bhRequestBody req `shouldSatisfy` isNothing + + describe "trainKnnModel" $ do + it "POSTs the training body to /_plugins/_knn/models/{model_id}/_train" $ do + let req = OS1Requests.trainKnnModel testModelId sampleTrainingRequest + bhRequestMethod req `shouldBe` NHTM.methodPost + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", unModelId testModelId, "_train"] + bhRequestBody req `shouldSatisfy` isJust + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "trainKnnModelWith" $ do + it "adds ?preference={node_id} when a node is supplied" $ do + let req = OS1Requests.trainKnnModelWith (Just testNodeId) testModelId sampleTrainingRequest + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", unModelId testModelId, "_train"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("preference", Just (unKnnNodeId testNodeId))] + + it "omits ?preference when no node is supplied (regression)" $ do + let req = OS1Requests.trainKnnModelWith Nothing testModelId sampleTrainingRequest + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "deleteKnnModel" $ do + it "DELETEs /_plugins/_knn/models/{model_id} (distinct method from getKnnModel)" $ do + let req = OS1Requests.deleteKnnModel testModelId + bhRequestMethod req `shouldBe` NHTM.methodDelete + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", unModelId testModelId] + bhRequestBody req `shouldSatisfy` isNothing + + describe "searchKnnModels" $ do + it "POSTs the search body to /_plugins/_knn/models/_search" $ do + let req = OS1Requests.searchKnnModels (mkSearch Nothing Nothing) + bhRequestMethod req `shouldBe` NHTM.methodPost + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "_search"] + bhRequestBody req `shouldSatisfy` isJust + + it "serializes the Search DSL as the request body" $ do + let req = OS1Requests.searchKnnModels (mkSearch Nothing Nothing) + let body = bhRequestBody req + body `shouldSatisfy` isJust + -- An empty search encodes as an object, never an array or null. + case body of + Just bs -> LBS.head bs `shouldBe` '{' + Nothing -> expectationFailure "expected a request body" diff --git a/tests/Test/KnnOs2Spec.hs b/tests/Test/KnnOs2Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/KnnOs2Spec.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.KnnOs2Spec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types +import Network.HTTP.Types.Method qualified as NHTM +import TestsUtils.Import +import Prelude + +-- | Sample identifiers for endpoint-shape assertions. The k-NN plugin uses +-- opaque 22-character node IDs; any 'Text' round-trips, so these are short +-- stand-ins purely for URL-segment checks. +testNodeId :: KnnNodeId +testNodeId = KnnNodeId "nodeIdOne" + +testStatName :: KnnStatName +testStatName = KnnStatName "hit_count" + +testModelId :: ModelId +testModelId = ModelId "test-model" + +-- | A minimal 'KnnTrainingRequest' (FAISS IVF) — only the shape matters for +-- endpoint tests, never the field values. +sampleTrainingRequest :: KnnTrainingRequest +sampleTrainingRequest = + KnnTrainingRequest + { knnTrainingRequestIndex = [qqIndexName|train-idx|], + knnTrainingRequestField = FieldName "vector", + knnTrainingRequestDimension = 4, + knnTrainingRequestMethod = + KnnTrainingMethod + { knnTrainingMethodName = "ivf", + knnTrainingMethodEngine = KnnEngineFaiss, + knnTrainingMethodSpaceType = Just "l2", + knnTrainingMethodParameters = Nothing + }, + knnTrainingRequestSpaceType = Nothing, + knnTrainingRequestMaxTrainingVectorCount = Nothing, + knnTrainingRequestSearchSize = Nothing, + knnTrainingRequestDescription = Nothing + } + +spec :: Spec +spec = describe "k-NN plugin endpoint shapes - OpenSearch 2" $ do + describe "getKnnStats" $ do + it "GETs /_plugins/_knn/stats with no node/stat filters" $ do + let req = OS2Requests.getKnnStats Nothing Nothing + bhRequestMethod req `shouldBe` NHTM.methodGet + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_knn", "stats"] + bhRequestBody req `shouldSatisfy` isNothing + + it "inserts the node id and stat name into the path when given" $ do + let req = OS2Requests.getKnnStats (Just testNodeId) (Just testStatName) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", unKnnNodeId testNodeId, "stats", unKnnStatName testStatName] + + it "emits node id only when no stat is requested" $ do + let req = OS2Requests.getKnnStats (Just testNodeId) Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", unKnnNodeId testNodeId, "stats"] + + describe "getKnnModel" $ do + it "GETs /_plugins/_knn/models/{model_id} with no body" $ do + let req = OS2Requests.getKnnModel testModelId + bhRequestMethod req `shouldBe` NHTM.methodGet + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", unModelId testModelId] + bhRequestBody req `shouldSatisfy` isNothing + + describe "trainKnnModel" $ do + it "POSTs the training body to /_plugins/_knn/models/{model_id}/_train" $ do + let req = OS2Requests.trainKnnModel testModelId sampleTrainingRequest + bhRequestMethod req `shouldBe` NHTM.methodPost + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", unModelId testModelId, "_train"] + bhRequestBody req `shouldSatisfy` isJust + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "trainKnnModelWith" $ do + it "adds ?preference={node_id} when a node is supplied" $ do + let req = OS2Requests.trainKnnModelWith (Just testNodeId) testModelId sampleTrainingRequest + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", unModelId testModelId, "_train"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("preference", Just (unKnnNodeId testNodeId))] + + it "omits ?preference when no node is supplied (regression)" $ do + let req = OS2Requests.trainKnnModelWith Nothing testModelId sampleTrainingRequest + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "deleteKnnModel" $ do + it "DELETEs /_plugins/_knn/models/{model_id} (distinct method from getKnnModel)" $ do + let req = OS2Requests.deleteKnnModel testModelId + bhRequestMethod req `shouldBe` NHTM.methodDelete + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", unModelId testModelId] + bhRequestBody req `shouldSatisfy` isNothing + + describe "searchKnnModels" $ do + it "POSTs the search body to /_plugins/_knn/models/_search" $ do + let req = OS2Requests.searchKnnModels (mkSearch Nothing Nothing) + bhRequestMethod req `shouldBe` NHTM.methodPost + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "_search"] + bhRequestBody req `shouldSatisfy` isJust + + it "serializes the Search DSL as the request body" $ do + let req = OS2Requests.searchKnnModels (mkSearch Nothing Nothing) + let body = bhRequestBody req + body `shouldSatisfy` isJust + -- An empty search encodes as an object, never an array or null. + case body of + Just bs -> LBS.head bs `shouldBe` '{' + Nothing -> expectationFailure "expected a request body" diff --git a/tests/Test/KnnOs3Spec.hs b/tests/Test/KnnOs3Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/KnnOs3Spec.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.KnnOs3Spec (spec) where + +import Data.Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.Key qualified as AK +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Maybe (fromJust, isJust) +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.OpenSearch3.Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import TestsUtils.Common +import TestsUtils.Import + +vectorField :: FieldName +vectorField = FieldName "vector" + +queryVector :: [Double] +queryVector = [0.1, 0.2, 0.3, 0.4, 0.5] + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +-- | Walk into a nested dict path, returning the inner Value if reachable. +walk :: [Key] -> Value -> Maybe Value +walk [] v = Just v +walk (k : ks) (Object obj) = case KM.lookup k obj of + Just v -> walk ks v + Nothing -> Nothing +walk _ _ = Nothing + +-- | True iff the encoded OpenSearchKnnQuery produces the OS-correct shape +-- @{"knn": {: {...}}}@ with the field name as a dict key. +hasKnnNestedUnderField :: FieldName -> LBS.ByteString -> Bool +hasKnnNestedUnderField (FieldName f) bs = + case decode bs of + Just (Object obj) -> case KM.lookup "knn" obj of + Just (Object knnObj) -> KM.member (AK.fromText f) knnObj + _ -> False + _ -> False + +spec :: Spec +spec = describe "k-NN Search API - OpenSearch 3" $ do + describe "OpenSearchKnnQuery body shape" $ do + it "serializes as query.knn. with the field name as the dict key" $ do + let clause = mkOpenSearchKnnQuery vectorField queryVector 3 + let json = encode clause + json `shouldSatisfy` hasKey "knn" + json `shouldSatisfy` hasKnnNestedUnderField vectorField + -- No ES-style wrapper. + json `shouldNotSatisfy` hasKey "field" + json `shouldNotSatisfy` hasKey "query_vector" + + it "omits Nothing optional fields from the clause body" $ do + let clause = mkOpenSearchKnnQuery vectorField queryVector 3 + let Just (Object knnDict) = walk ["knn", AK.fromText "vector"] (fromJust (decode (encode clause))) + knnDict `shouldSatisfy` not . KM.member "filter" + knnDict `shouldSatisfy` not . KM.member "boost" + knnDict `shouldSatisfy` not . KM.member "method_parameters" + + it "includes filter, boost, method_parameters when set" $ do + let clause = + (mkOpenSearchKnnQuery vectorField queryVector 5) + { osknnFilter = Just (Filter (TermQuery (Term "label" "alpha") Nothing)), + osknnBoost = Just 1.2, + osknnMethodParameters = Just (KnnHnswParams 100) + } + let Just (Object knnDict) = walk ["knn", AK.fromText "vector"] (fromJust (decode (encode clause))) + knnDict `shouldSatisfy` KM.member "filter" + knnDict `shouldSatisfy` KM.member "boost" + knnDict `shouldSatisfy` KM.member "method_parameters" + + it "serializes HNSW method_parameters as {\"ef_search\":N} only" $ do + let clause = + (mkOpenSearchKnnQuery vectorField queryVector 5) + { osknnMethodParameters = Just (KnnHnswParams 100) + } + let Just (Object methodParams) = walk ["knn", AK.fromText "vector", "method_parameters"] (fromJust (decode (encode clause))) + KM.lookup "ef_search" methodParams `shouldBe` Just (Number 100) + methodParams `shouldSatisfy` not . KM.member "nprobes" + + it "serializes IVF method_parameters as {\"nprobes\":N} only" $ do + let clause = + (mkOpenSearchKnnQuery vectorField queryVector 5) + { osknnMethodParameters = Just (KnnIvfParams 10) + } + let Just (Object methodParams) = walk ["knn", AK.fromText "vector", "method_parameters"] (fromJust (decode (encode clause))) + KM.lookup "nprobes" methodParams `shouldBe` Just (Number 10) + methodParams `shouldSatisfy` not . KM.member "ef_search" + + it "round-trips KnnHnswParams and KnnIvfParams through ToJSON/FromJSON" $ do + decode (encode (KnnHnswParams 100)) `shouldBe` Just (KnnHnswParams 100 :: OpenSearchKnnMethodParameters) + decode (encode (KnnIvfParams 10)) `shouldBe` Just (KnnIvfParams 10 :: OpenSearchKnnMethodParameters) + + it "rejects a method_parameters object with neither expected key" $ do + let v = encode (object ["other" .= Number 1]) + decode v `shouldBe` (Nothing :: Maybe OpenSearchKnnMethodParameters) + + it "round-trips a minimal OpenSearchKnnQuery through ToJSON/FromJSON" $ do + let clause = mkOpenSearchKnnQuery vectorField queryVector 3 + decode (encode clause) `shouldBe` Just clause + + it "round-trips a fully-populated OpenSearchKnnQuery through ToJSON/FromJSON" $ do + let clause = + (mkOpenSearchKnnQuery vectorField queryVector 5) + { osknnFilter = Just (Filter (TermQuery (Term "label" "alpha") Nothing)), + osknnBoost = Just 1.2, + osknnMethodParameters = Just (KnnHnswParams 100) + } + decode (encode clause) `shouldBe` Just clause + + it "serializes OpenSearchKnnEngine as lowercase faiss/nmslib/lucene" $ do + encode KnnEngineFaiss `shouldBe` "\"faiss\"" + encode KnnEngineNmslib `shouldBe` "\"nmslib\"" + encode KnnEngineLucene `shouldBe` "\"lucene\"" + decode "\"faiss\"" `shouldBe` Just (KnnEngineFaiss :: OpenSearchKnnEngine) + + describe "OpenSearchKnnQuery radial-search variants" $ do + it "max_distance variant emits max_distance and no k in the clause body" $ do + let clause = mkOpenSearchKnnQueryByMaxDistance vectorField queryVector 1.5 + let json = encode clause + json `shouldSatisfy` hasKey "knn" + json `shouldSatisfy` hasKnnNestedUnderField vectorField + let Just (Object knnDict) = walk ["knn", AK.fromText "vector"] (fromJust (decode json)) + KM.lookup "max_distance" knnDict `shouldBe` Just (Number 1.5) + knnDict `shouldSatisfy` not . KM.member "k" + knnDict `shouldSatisfy` not . KM.member "min_score" + + it "min_score variant emits min_score and no k in the clause body" $ do + let clause = mkOpenSearchKnnQueryByMinScore vectorField queryVector 0.8 + let json = encode clause + json `shouldSatisfy` hasKey "knn" + json `shouldSatisfy` hasKnnNestedUnderField vectorField + let Just (Object knnDict) = walk ["knn", AK.fromText "vector"] (fromJust (decode json)) + KM.lookup "min_score" knnDict `shouldBe` Just (Number 0.8) + knnDict `shouldSatisfy` not . KM.member "k" + knnDict `shouldSatisfy` not . KM.member "max_distance" + + it "k variant still emits k (regression)" $ do + let clause = mkOpenSearchKnnQuery vectorField queryVector 3 + let Just (Object knnDict) = walk ["knn", AK.fromText "vector"] (fromJust (decode (encode clause))) + KM.lookup "k" knnDict `shouldBe` Just (Number 3) + knnDict `shouldSatisfy` not . KM.member "max_distance" + knnDict `shouldSatisfy` not . KM.member "min_score" + + it "preserves optional fields on the max_distance variant" $ do + let clause = + (mkOpenSearchKnnQueryByMaxDistance vectorField queryVector 1.5) + { osknnFilter = Just (Filter (TermQuery (Term "label" "alpha") Nothing)), + osknnBoost = Just 1.2, + osknnMethodParameters = Just (KnnHnswParams 100) + } + let Just (Object knnDict) = walk ["knn", AK.fromText "vector"] (fromJust (decode (encode clause))) + KM.lookup "max_distance" knnDict `shouldBe` Just (Number 1.5) + knnDict `shouldSatisfy` KM.member "filter" + knnDict `shouldSatisfy` KM.member "boost" + knnDict `shouldSatisfy` KM.member "method_parameters" + + it "round-trips a minimal max_distance query" $ do + let clause = mkOpenSearchKnnQueryByMaxDistance vectorField queryVector 1.5 + decode (encode clause) `shouldBe` Just clause + + it "round-trips a fully-populated min_score query" $ do + let clause = + (mkOpenSearchKnnQueryByMinScore vectorField queryVector 0.8) + { osknnFilter = Just (Filter (TermQuery (Term "label" "alpha") Nothing)), + osknnBoost = Just 1.2, + osknnMethodParameters = Just (KnnIvfParams 10) + } + decode (encode clause) `shouldBe` Just clause + + it "FromJSON picks KnnTerminationByK / ByMaxDistance / ByMinScore by present key" $ do + decode (encode (object ["k" .= Number 3])) + `shouldBe` Just (KnnTerminationByK 3 :: OpenSearchKnnQueryTermination) + decode (encode (object ["max_distance" .= Number 1.5])) + `shouldBe` Just (KnnTerminationByMaxDistance 1.5 :: OpenSearchKnnQueryTermination) + decode (encode (object ["min_score" .= Number 0.8])) + `shouldBe` Just (KnnTerminationByMinScore 0.8 :: OpenSearchKnnQueryTermination) + + it "ToJSON OpenSearchKnnQueryTermination emits the single expected key" $ do + encode (KnnTerminationByK 3) `shouldBe` "{\"k\":3}" + encode (KnnTerminationByMaxDistance 1.5) `shouldBe` "{\"max_distance\":1.5}" + encode (KnnTerminationByMinScore 0.8) `shouldBe` "{\"min_score\":0.8}" + + it "rejects a termination object with none of the expected keys" $ do + let v = encode (object ["other" .= Number 1]) + decode v `shouldBe` (Nothing :: Maybe OpenSearchKnnQueryTermination) + + describe "Search.osKnnBody integration" $ do + it "when osKnnBody is set, emits it under the top-level query slot" $ do + let clause = mkOpenSearchKnnQuery vectorField queryVector 3 + let search = (mkSearch Nothing Nothing) {osKnnBody = Just clause} + let json = encode search + json `shouldSatisfy` hasKey "query" + let Just (Object queryObj) = walk ["query"] (fromJust (decode json)) + queryObj `shouldSatisfy` KM.member "knn" + + it "when osKnnBody is Nothing, falls back to queryBody/filterBody logic" $ do + let search = mkSearch Nothing Nothing + let json = encode search + json `shouldNotSatisfy` hasKey "query" + + describe "endpoint shape" $ do + it "POSTs to /{index}/_search (not /_knn_search)" $ do + let bareReq = OS3Requests.knnSearch @KnnDoc osKnnTestIndex (mkOpenSearchKnnQuery vectorField queryVector 3) (mkSearch Nothing Nothing) + getRawEndpoint (bhRequestEndpoint bareReq) + `shouldBe` [unIndexName osKnnTestIndex, "_search"] + + it "carries no ?index= query string (the old bug)" $ do + let bareReq = OS3Requests.knnSearch @KnnDoc osKnnTestIndex (mkOpenSearchKnnQuery vectorField queryVector 3) (mkSearch Nothing Nothing) + getRawEndpointQueries (bhRequestEndpoint bareReq) `shouldBe` [] + + it "embeds the knn clause in the request body as query.knn." $ do + let bareReq = OS3Requests.knnSearch @KnnDoc osKnnTestIndex (mkOpenSearchKnnQuery vectorField queryVector 3) (mkSearch Nothing Nothing) + let body = bhRequestBody bareReq + body `shouldSatisfy` isJust + let Just bodyBytes = body + case decode bodyBytes of + Just (Object obj) -> case KM.lookup "query" obj of + Just (Object q) -> case KM.lookup "knn" q of + Just (Object knn) -> KM.member (AK.fromText "vector") knn `shouldBe` True + _ -> expectationFailure "missing knn key inside query" + _ -> expectationFailure "missing query key" + _ -> expectationFailure "body did not decode to Object" + + describe "live integration (requires OS3 backend with index.knn=true)" $ + backendSpecific [OpenSearch3] $ do + it "returns the nearest neighbour document" $ + withTestEnv $ do + insertOsKnnData + let search = mkSearch Nothing Nothing + clause = mkOpenSearchKnnQuery vectorField queryVector 3 + searchResult <- knnSearch osKnnTestIndex clause search :: BH IO (SearchResult KnnDoc) + let topHit = headMay $ hits $ searchHits searchResult + liftIO $ (hitDocId <$> topHit) `shouldBe` Just (Just (DocId "a")) + + it "supports optional filter and boost fields" $ + withTestEnv $ do + insertOsKnnData + let search = mkSearch Nothing Nothing + clause = + (mkOpenSearchKnnQuery vectorField queryVector 5) + { osknnBoost = Just 1.0, + osknnFilter = Just (Filter (TermQuery (Term "label" "alpha") Nothing)) + } + searchResult <- knnSearch osKnnTestIndex clause search :: BH IO (SearchResult KnnDoc) + let topHit = headMay $ hits $ searchHits searchResult + liftIO $ (hitDocId <$> topHit) `shouldBe` Just (Just (DocId "a")) + + it "radial search by max_distance returns the nearest neighbour" $ + withTestEnv $ do + insertOsKnnData + let search = mkSearch Nothing Nothing + clause = mkOpenSearchKnnQueryByMaxDistance vectorField queryVector 2.0 + searchResult <- knnSearch osKnnTestIndex clause search :: BH IO (SearchResult KnnDoc) + let topHit = headMay $ hits $ searchHits searchResult + liftIO $ (hitDocId <$> topHit) `shouldBe` Just (Just (DocId "a")) + + it "radial search by min_score returns the nearest neighbour" $ + withTestEnv $ do + insertOsKnnData + let search = mkSearch Nothing Nothing + clause = mkOpenSearchKnnQueryByMinScore vectorField queryVector 0.5 + searchResult <- knnSearch osKnnTestIndex clause search :: BH IO (SearchResult KnnDoc) + let topHit = headMay $ hits $ searchHits searchResult + liftIO $ (hitDocId <$> topHit) `shouldBe` Just (Just (DocId "a")) diff --git a/tests/Test/KnnStatsSpec.hs b/tests/Test/KnnStatsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/KnnStatsSpec.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.KnnStatsSpec (spec) where + +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Map.Strict qualified as Map +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- | The canonical k-NN stats response: cluster-level scalars at the top +-- level (one key per cluster stat) plus a @nodes@ object whose value is a +-- map keyed by opaque node ID. Drawn from the documented example shape in +-- the OS 3.x k-NN plugin source (RestKnnStatsAction + KnnStatsResponse). +-- Stat values are arbitrary nested JSON; we deliberately round-trip them +-- as 'Value' rather than modelling individual stats, since the stat-name +-- set is plugin-version dependent. +sampleFullResponse :: LBS.ByteString +sampleFullResponse = + "{\ + \ \"total_load_time\": 123456,\ + \ \"hit_count\": 42,\ + \ \"eviction_count\": 3,\ + \ \"circuit_breaker_triggered\": false,\ + \ \"nodes\": {\ + \ \"AaaBbbCccDddEeeFffGgHh\": {\ + \ \"hit_count\": 42,\ + \ \"miss_count\": 7,\ + \ \"knn_query_cache_size\": 1024,\ + \ \"knn_query_cache_eviction_count\": 0\ + \ }\ + \ }\ + \}" + +-- | A nodes-only response, as returned when a node-level @stat@ filter is +-- supplied (e.g. @GET /_plugins/_knn/stats/hit_count@). The cluster-level +-- stats are omitted because the filter restricts to node-level values; the +-- decoder must accept their absence. +sampleNodesOnlyResponse :: LBS.ByteString +sampleNodesOnlyResponse = + "{\ + \ \"nodes\": {\ + \ \"nodeOneIdTwentyTwoC00\": {\ + \ \"hit_count\": 3,\ + \ \"miss_count\": 1\ + \ },\ + \ \"nodeTwoIdTwentyTwoC00X\": {\ + \ \"hit_count\": 4,\ + \ \"miss_count\": 2\ + \ }\ + \ }\ + \}" + +spec :: Spec +spec = describe "k-NN Stats API" $ do + describe "KnnNodeId / KnnStatName JSON" $ do + it "KnnNodeId round-trips as a bare JSON string" $ do + encode (KnnNodeId "node-id-22-chars-000") `shouldBe` "\"node-id-22-chars-000\"" + decode "\"abc\"" `shouldBe` Just (KnnNodeId "abc") + + it "KnnStatName round-trips as a bare JSON string" $ do + encode (KnnStatName "hit_count") `shouldBe` "\"hit_count\"" + decode "\"miss_count\"" `shouldBe` Just (KnnStatName "miss_count") + + describe "KnnStats JSON" $ do + it "decodes a full response with cluster stats and a nodes map" $ do + let Just decoded = decode sampleFullResponse :: Maybe KnnStats + entries = knnStatsEntries decoded + -- 4 cluster-level keys + 1 "nodes" key. + Map.size entries `shouldBe` 5 + Map.member "nodes" entries `shouldBe` True + Map.member "total_load_time" entries `shouldBe` True + Map.member "hit_count" entries `shouldBe` True + Map.member "circuit_breaker_triggered" entries `shouldBe` True + + it "preserves cluster-level scalars as bare aeson Values" $ do + let Just decoded = decode sampleFullResponse :: Maybe KnnStats + entries = knnStatsEntries decoded + Map.lookup "total_load_time" entries `shouldBe` Just (toJSON (123456 :: Int)) + Map.lookup "hit_count" entries `shouldBe` Just (toJSON (42 :: Int)) + Map.lookup "circuit_breaker_triggered" entries + `shouldBe` Just (toJSON False) + Map.lookup "eviction_count" entries `shouldBe` Just (toJSON (3 :: Int)) + + it "preserves the per-node map under the \"nodes\" key as an aeson Value" $ do + let Just decoded = decode sampleFullResponse :: Maybe KnnStats + Just (Object nodesObj) = Map.lookup "nodes" (knnStatsEntries decoded) + nodeIds = [k | (k, _) <- KM.toList nodesObj] + length nodeIds `shouldBe` 1 + "AaaBbbCccDddEeeFffGgHh" `elem` nodeIds `shouldBe` True + + it "decodes the per-node body of a specific node" $ do + let Just decoded = decode sampleFullResponse :: Maybe KnnStats + Just (Object nodesObj) = Map.lookup "nodes" (knnStatsEntries decoded) + Just nodeBody = KM.lookup "AaaBbbCccDddEeeFffGgHh" nodesObj + nodeBody + `shouldBe` object + [ "hit_count" .= (42 :: Int), + "miss_count" .= (7 :: Int), + "knn_query_cache_size" .= (1024 :: Int), + "knn_query_cache_eviction_count" .= (0 :: Int) + ] + + it "decodes a multi-node nodes-only response without losing entries" $ do + let Just decoded = decode sampleNodesOnlyResponse :: Maybe KnnStats + entries = knnStatsEntries decoded + Just (Object nodesObj) = Map.lookup "nodes" entries + nodeIds = [k | (k, _) <- KM.toList nodesObj] + Map.size entries `shouldBe` 1 + length nodeIds `shouldBe` 2 + "nodeOneIdTwentyTwoC00" `elem` nodeIds `shouldBe` True + "nodeTwoIdTwentyTwoC00X" `elem` nodeIds `shouldBe` True + -- None of the cluster-level keys are present. + Map.member "total_load_time" entries `shouldBe` False + + it "decodes an empty object as an empty map" $ do + let Just decoded = decode "{}" :: Maybe KnnStats + knnStatsEntries decoded `shouldBe` Map.empty + + it "decodes an empty nodes map as an Object with no entries" $ do + let Just decoded = decode "{ \"nodes\": {} }" :: Maybe KnnStats + Just (Object nodesObj) = Map.lookup "nodes" (knnStatsEntries decoded) + KM.null nodesObj `shouldBe` True + + it "rejects a top-level null" $ do + let decoded = decode "null" :: Maybe KnnStats + decoded `shouldBe` Nothing + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe KnnStats + decoded `shouldBe` Nothing + + it "rejects a top-level scalar" $ do + let decoded = decode "42" :: Maybe KnnStats + decoded `shouldBe` Nothing + + it "rejects malformed JSON" $ do + let decoded = decode "{ not json" :: Maybe KnnStats + decoded `shouldBe` Nothing + + -- Lenient contract: the flat-Map decoder does NOT validate the shape of + -- the @nodes@ value (it is just another entry in the map). This test + -- pins the current behaviour so any future tightening of the decoder is + -- a deliberate, breaking change rather than a silent one. + it "accepts a non-object nodes value (lenient contract — pinned)" $ do + let Just decoded = decode "{ \"nodes\": \"unexpected\" }" :: Maybe KnnStats + Map.lookup "nodes" (knnStatsEntries decoded) + `shouldBe` Just (toJSON ("unexpected" :: Text)) + + it "round-trips a full response through ToJSON/FromJSON" $ do + let Just decoded = decode sampleFullResponse :: Maybe KnnStats + (decode . encode) decoded `shouldBe` Just decoded + + it "round-trips a nodes-only response through ToJSON/FromJSON" $ do + let Just decoded = decode sampleNodesOnlyResponse :: Maybe KnnStats + (decode . encode) decoded `shouldBe` Just decoded + + it "ToJSON emits both cluster and nodes keys" $ do + let Just decoded = decode sampleFullResponse :: Maybe KnnStats + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` BS.isInfixOf "\"nodes\"" + encoded `shouldSatisfy` BS.isInfixOf "\"total_load_time\"" + encoded `shouldSatisfy` BS.isInfixOf "\"AaaBbbCccDddEeeFffGgHh\"" + + describe "getKnnStats endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "GETs /_plugins/_knn/stats when given Nothing/Nothing" $ do + let req = OS3Requests.getKnnStats Nothing Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_plugins/_knn/stats/{stat} when only the stat name is set" $ do + let req = + OS3Requests.getKnnStats + Nothing + (Just (KnnStatName "hit_count")) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "stats", "hit_count"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_plugins/_knn/{nodeId}/stats when only the node id is set" $ do + let req = + OS3Requests.getKnnStats + (Just (KnnNodeId "node-id-22-chars-000")) + Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "node-id-22-chars-000", "stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_plugins/_knn/{nodeId}/stats/{stat} when both are set" $ do + let req = + OS3Requests.getKnnStats + (Just (KnnNodeId "node-id-22-chars-000")) + (Just (KnnStatName "miss_count")) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [ "_plugins", + "_knn", + "node-id-22-chars-000", + "stats", + "miss_count" + ] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the GET method" $ do + let req = OS3Requests.getKnnStats Nothing Nothing + bhRequestMethod req `shouldBe` "GET" + + it "does not attach a body (GET semantics)" $ do + let req = OS3Requests.getKnnStats Nothing Nothing + bhRequestBody req `shouldBe` Nothing diff --git a/tests/Test/KnnTrainSpec.hs b/tests/Test/KnnTrainSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/KnnTrainSpec.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.KnnTrainSpec (spec) where + +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- | A representative @KnnTrainingRequest@ used by the endpoint-shape tests +-- in both the 'trainKnnModel' and 'trainKnnModelWith' describe blocks. +sampleReq :: KnnTrainingRequest +sampleReq = + KnnTrainingRequest + { knnTrainingRequestIndex = [qqIndexName|train-index-name|], + knnTrainingRequestField = FieldName "train-field-name", + knnTrainingRequestDimension = 16, + knnTrainingRequestMethod = + KnnTrainingMethod + { knnTrainingMethodName = "ivf", + knnTrainingMethodEngine = KnnEngineFaiss, + knnTrainingMethodSpaceType = Just "l2", + knnTrainingMethodParameters = + Just (object ["nlist" .= (128 :: Int)]) + }, + knnTrainingRequestSpaceType = Nothing, + knnTrainingRequestMaxTrainingVectorCount = Nothing, + knnTrainingRequestSearchSize = Nothing, + knnTrainingRequestDescription = Just "My model" + } + +-- | A representative @method@ sub-object with full @parameters@, drawn from +-- the OpenSearch vector-search train-model example. Only IVF-style methods +-- (FAISS) require training; @parameters@ is deeply nested and +-- engine-specific. +sampleMethodJson :: LBS.ByteString +sampleMethodJson = + "{\ + \ \"name\": \"ivf\",\ + \ \"engine\": \"faiss\",\ + \ \"parameters\": {\ + \ \"nlist\": 128,\ + \ \"encoder\": {\ + \ \"name\": \"pq\",\ + \ \"parameters\": { \"code_size\": 8 }\ + \ }\ + \ }\ + \}" + +-- | A fully-populated train request body. Mirrors the example in the +-- OpenSearch vector-search docs. +sampleFullRequest :: LBS.ByteString +sampleFullRequest = + "{\ + \ \"training_index\": \"train-index-name\",\ + \ \"training_field\": \"train-field-name\",\ + \ \"dimension\": 16,\ + \ \"max_training_vector_count\": 1200,\ + \ \"search_size\": 100,\ + \ \"description\": \"My model\",\ + \ \"space_type\": \"l2\",\ + \ \"method\": {\ + \ \"name\": \"ivf\",\ + \ \"engine\": \"faiss\",\ + \ \"parameters\": {\ + \ \"nlist\": 128,\ + \ \"encoder\": {\ + \ \"name\": \"pq\",\ + \ \"parameters\": { \"code_size\": 8 }\ + \ }\ + \ }\ + \ }\ + \}" + +-- | A minimal request with only the four required fields. Used to verify +-- @omitNulls@ does not leak @null@ for the optional fields. +sampleMinimalRequest :: LBS.ByteString +sampleMinimalRequest = + "{\ + \ \"training_index\": \"train-index-name\",\ + \ \"training_field\": \"train-field-name\",\ + \ \"dimension\": 4,\ + \ \"method\": {\ + \ \"name\": \"ivf\",\ + \ \"engine\": \"faiss\"\ + \ }\ + \}" + +-- | The train endpoint's response is a bare object echoing the @model_id@. +sampleResponse :: LBS.ByteString +sampleResponse = "{ \"model_id\": \"dcdwscddscsad\" }" + +spec :: Spec +spec = describe "k-NN Train Model API" $ do + describe "KnnTrainingMethod JSON" $ do + it "decodes a method with full parameters" $ do + let Just decoded = decode sampleMethodJson :: Maybe KnnTrainingMethod + knnTrainingMethodName decoded `shouldBe` "ivf" + knnTrainingMethodEngine decoded `shouldBe` KnnEngineFaiss + knnTrainingMethodSpaceType decoded `shouldBe` Nothing + knnTrainingMethodParameters decoded `shouldSatisfy` isJust + + it "decodes a method with space_type at the method level" $ do + let Just decoded = + decode + "{ \"name\": \"ivf\", \"engine\": \"faiss\", \"space_type\": \"innerproduct\" }" :: + Maybe KnnTrainingMethod + knnTrainingMethodSpaceType decoded `shouldBe` Just "innerproduct" + + it "requires name and engine" $ do + let decoded = decode "{ \"name\": \"ivf\" }" :: Maybe KnnTrainingMethod + decoded `shouldBe` Nothing + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe KnnTrainingMethod + decoded `shouldBe` Nothing + + it "round-trips a full method through ToJSON/FromJSON" $ do + let Just decoded = decode sampleMethodJson :: Maybe KnnTrainingMethod + (decode . encode) decoded `shouldBe` Just decoded + + it "ToJSON omits Nothing method fields (no null leakage)" $ do + let method = + KnnTrainingMethod + { knnTrainingMethodName = "ivf", + knnTrainingMethodEngine = KnnEngineFaiss, + knnTrainingMethodSpaceType = Nothing, + knnTrainingMethodParameters = Nothing + } + encoded = LBS.toStrict (encode method) + encoded `shouldSatisfy` not . BS.isInfixOf "\"space_type\"" + encoded `shouldSatisfy` not . BS.isInfixOf "\"parameters\"" + encoded `shouldSatisfy` BS.isInfixOf "\"name\":\"ivf\"" + encoded `shouldSatisfy` BS.isInfixOf "\"engine\":\"faiss\"" + + it "ToJSON emits method parameters when present" $ do + let Just decoded = decode sampleMethodJson :: Maybe KnnTrainingMethod + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` BS.isInfixOf "\"parameters\"" + + describe "KnnTrainingRequest JSON" $ do + it "decodes a fully-populated request" $ do + let Just decoded = decode sampleFullRequest :: Maybe KnnTrainingRequest + unIndexName (knnTrainingRequestIndex decoded) `shouldBe` "train-index-name" + unFieldName (knnTrainingRequestField decoded) `shouldBe` "train-field-name" + knnTrainingRequestDimension decoded `shouldBe` 16 + knnTrainingRequestSpaceType decoded `shouldBe` Just "l2" + knnTrainingRequestMaxTrainingVectorCount decoded `shouldBe` Just 1200 + knnTrainingRequestSearchSize decoded `shouldBe` Just 100 + knnTrainingRequestDescription decoded `shouldBe` Just "My model" + (knnTrainingMethodName . knnTrainingRequestMethod) decoded `shouldBe` "ivf" + + it "decodes a minimal (required-only) request" $ do + let Just decoded = decode sampleMinimalRequest :: Maybe KnnTrainingRequest + knnTrainingRequestDimension decoded `shouldBe` 4 + knnTrainingRequestSpaceType decoded `shouldBe` Nothing + knnTrainingRequestMaxTrainingVectorCount decoded `shouldBe` Nothing + knnTrainingRequestSearchSize decoded `shouldBe` Nothing + knnTrainingRequestDescription decoded `shouldBe` Nothing + + it "requires the four required fields" $ do + decode "{ \"training_index\": \"x\", \"training_field\": \"y\", \"dimension\": 4 }" + `shouldBe` (Nothing :: Maybe KnnTrainingRequest) + + it "tolerates unknown fields (forward compatibility)" $ do + let Just decoded = + decode + "{\ + \ \"training_index\": \"ix\",\ + \ \"training_field\": \"fl\",\ + \ \"dimension\": 2,\ + \ \"method\": { \"name\": \"ivf\", \"engine\": \"faiss\" },\ + \ \"future_field\": 42\ + \}" :: + Maybe KnnTrainingRequest + unIndexName (knnTrainingRequestIndex decoded) `shouldBe` "ix" + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe KnnTrainingRequest + decoded `shouldBe` Nothing + + it "rejects malformed JSON" $ do + let decoded = decode "{ not json" :: Maybe KnnTrainingRequest + decoded `shouldBe` Nothing + + it "round-trips a full request through ToJSON/FromJSON" $ do + let Just decoded = decode sampleFullRequest :: Maybe KnnTrainingRequest + (decode . encode) decoded `shouldBe` Just decoded + + it "round-trips a minimal request through ToJSON/FromJSON" $ do + let Just decoded = decode sampleMinimalRequest :: Maybe KnnTrainingRequest + (decode . encode) decoded `shouldBe` Just decoded + + it "ToJSON omits Nothing request fields (no null leakage)" $ do + let Just decoded = decode sampleMinimalRequest :: Maybe KnnTrainingRequest + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` not . BS.isInfixOf "\"space_type\"" + encoded `shouldSatisfy` not . BS.isInfixOf "\"max_training_vector_count\"" + encoded `shouldSatisfy` not . BS.isInfixOf "\"search_size\"" + encoded `shouldSatisfy` not . BS.isInfixOf "\"description\"" + + it "ToJSON serializes training_index and training_field as bare strings (not wrapped objects)" $ do + let Just decoded = decode sampleMinimalRequest :: Maybe KnnTrainingRequest + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` BS.isInfixOf "\"training_index\":\"train-index-name\"" + encoded `shouldSatisfy` BS.isInfixOf "\"training_field\":\"train-field-name\"" + + it "ToJSON emits optional fields when present" $ do + let Just decoded = decode sampleFullRequest :: Maybe KnnTrainingRequest + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` BS.isInfixOf "\"space_type\":\"l2\"" + encoded `shouldSatisfy` BS.isInfixOf "\"max_training_vector_count\":1200" + encoded `shouldSatisfy` BS.isInfixOf "\"search_size\":100" + + describe "KnnTrainResponse JSON" $ do + it "decodes the documented response body" $ do + let Just decoded = decode sampleResponse :: Maybe KnnTrainResponse + knnTrainResponseModelId decoded `shouldBe` "dcdwscddscsad" + + it "requires the model_id field" $ do + let decoded = decode "{}" :: Maybe KnnTrainResponse + decoded `shouldBe` Nothing + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe KnnTrainResponse + decoded `shouldBe` Nothing + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode sampleResponse :: Maybe KnnTrainResponse + (decode . encode) decoded `shouldBe` Just decoded + + describe "trainKnnModel endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "POSTs to /_plugins/_knn/models/{model_id}/_train for the given ModelId" $ do + let req = OS3Requests.trainKnnModel (ModelId "test-model") sampleReq + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "test-model", "_train"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the model id as a single opaque path segment" $ do + let req = OS3Requests.trainKnnModel (ModelId "faiss-ivf-pq_42") sampleReq + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "faiss-ivf-pq_42", "_train"] + + it "uses a distinct id in the path when given a different ModelId" $ do + let req = OS3Requests.trainKnnModel (ModelId "other-model") sampleReq + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "other-model", "_train"] + + it "uses the POST method" $ do + let req = OS3Requests.trainKnnModel (ModelId "test-model") sampleReq + bhRequestMethod req `shouldBe` "POST" + + it "attaches a JSON body (POST semantics)" $ do + let req = OS3Requests.trainKnnModel (ModelId "test-model") sampleReq + bhRequestBody req `shouldSatisfy` isJust + + it "embeds training_index and method in the request body" $ do + let req = OS3Requests.trainKnnModel (ModelId "test-model") sampleReq + Just bodyBytes = bhRequestBody req + case decode bodyBytes of + Just (Object obj) -> do + KM.member "training_index" obj `shouldBe` True + KM.member "training_field" obj `shouldBe` True + KM.member "dimension" obj `shouldBe` True + KM.member "method" obj `shouldBe` True + _ -> expectationFailure "body did not decode to Object" + + it "does not leak null for the unset optional fields" $ do + let req = OS3Requests.trainKnnModel (ModelId "test-model") sampleReq + Just bodyBytes = bhRequestBody req + encoded = LBS.toStrict bodyBytes + encoded `shouldSatisfy` not . BS.isInfixOf "\"space_type\":null" + encoded `shouldSatisfy` not . BS.isInfixOf "\"max_training_vector_count\":null" + encoded `shouldSatisfy` not . BS.isInfixOf "\"search_size\":null" + + describe "trainKnnModelWith endpoint shape" $ do + it "trainKnnModel is equivalent to trainKnnModelWith Nothing" $ do + let base = OS3Requests.trainKnnModel (ModelId "test-model") sampleReq + withNothing = OS3Requests.trainKnnModelWith Nothing (ModelId "test-model") sampleReq + getRawEndpoint (bhRequestEndpoint base) + `shouldBe` getRawEndpoint (bhRequestEndpoint withNothing) + getRawEndpointQueries (bhRequestEndpoint base) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint withNothing) + bhRequestMethod base `shouldBe` bhRequestMethod withNothing + + it "trainKnnModelWith Nothing produces no query parameters" $ do + let req = OS3Requests.trainKnnModelWith Nothing (ModelId "test-model") sampleReq + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "test-model", "_train"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "trainKnnModelWith (Just node) attaches ?preference=" $ do + let req = OS3Requests.trainKnnModelWith (Just (KnnNodeId "node-abc")) (ModelId "test-model") sampleReq + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "test-model", "_train"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("preference", Just "node-abc")] + + it "trainKnnModelWith preserves the path for an opaque node id" $ do + let req = OS3Requests.trainKnnModelWith (Just (KnnNodeId "ZcRWj1BLTEq9OMxK3wEuwA")) (ModelId "faiss-ivf-pq_42") sampleReq + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "models", "faiss-ivf-pq_42", "_train"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("preference", Just "ZcRWj1BLTEq9OMxK3wEuwA")] + + it "trainKnnModelWith uses the POST method and attaches a JSON body" $ do + let req = OS3Requests.trainKnnModelWith (Just (KnnNodeId "node-1")) (ModelId "test-model") sampleReq + bhRequestMethod req `shouldBe` "POST" + bhRequestBody req `shouldSatisfy` isJust diff --git a/tests/Test/KnnWarmupSpec.hs b/tests/Test/KnnWarmupSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/KnnWarmupSpec.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.KnnWarmupSpec (spec) where + +import Database.Bloodhound.OpenSearch1.Client qualified as OS1.Client +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch2.Client qualified as OS2.Client +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch3.Client qualified as OS3.Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- | Pure endpoint-shape tests for the k-NN plugin Warmup API +-- (@GET /_plugins/_knn/warmup\/{index}@) across OpenSearch 1, 2, and 3. +-- These mirror 'Test.NeuralWarmupSpec's shape tests but assert the +-- @\/_plugins\/_knn\/warmup@ path, the GET method, the absent body, +-- and cross-backend parity. JSON decoding of the shared 'ShardsResult' +-- response is re-verified here on the warmup response shape +-- (@{\"_shards\":{\"total\":...,\"successful\":...,\"failed\":...}}@, +-- live-verified against OS 2.19.5 \/ 3.7.0) so a regression in the +-- pre-existing instance is caught in this spec too. +spec :: Spec +spec = describe "k-NN Warmup API" $ do + describe "warmupKnnIndex endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_knn/warmup/{index} when given an IndexName" $ do + let req = OS3Requests.warmupKnnIndex [[qqIndexName|my-index|]] + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "warmup", "my-index"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "carries no request body" $ do + let req = OS3Requests.warmupKnnIndex [[qqIndexName|my-index|]] + bhRequestBody req `shouldBe` Nothing + + it "uses a distinct index in the path when given a different IndexName" $ do + let req = OS3Requests.warmupKnnIndex [[qqIndexName|other-index|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "warmup", "other-index"] + + it "keeps the index name as a single opaque path segment" $ do + let req = OS3Requests.warmupKnnIndex [[qqIndexName|my-index_42|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "warmup", "my-index_42"] + + describe "warmupKnnIndex endpoint shape (OpenSearch 2)" $ do + it "GETs /_plugins/_knn/warmup/{index} when given an IndexName" $ do + let req = OS2Requests.warmupKnnIndex [[qqIndexName|my-index|]] + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "warmup", "my-index"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "carries no request body" $ do + let req = OS2Requests.warmupKnnIndex [[qqIndexName|my-index|]] + bhRequestBody req `shouldBe` Nothing + + it "uses a distinct index in the path when given a different IndexName" $ do + let req = OS2Requests.warmupKnnIndex [[qqIndexName|other-index|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "warmup", "other-index"] + + describe "warmupKnnIndex endpoint shape (OpenSearch 1)" $ do + it "GETs /_plugins/_knn/warmup/{index} when given an IndexName" $ do + let req = OS1Requests.warmupKnnIndex [[qqIndexName|my-index|]] + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "warmup", "my-index"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "carries no request body" $ do + let req = OS1Requests.warmupKnnIndex [[qqIndexName|my-index|]] + bhRequestBody req `shouldBe` Nothing + + it "uses a distinct index in the path when given a different IndexName" $ do + let req = OS1Requests.warmupKnnIndex [[qqIndexName|other-index|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "warmup", "other-index"] + + -- ---------------------------------------------------------------- -- + -- Multi-index (comma-separated) path rendering: bloodhound-6jy. -- + -- The k-NN Warmup API documents comma-separated lists and index -- + -- patterns in the {index} path segment; the [IndexName] argument -- + -- is rendered as a single comma-joined segment, matching the -- + -- OpenSearch multi-target syntax. -- + -- ---------------------------------------------------------------- -- + describe "warmupKnnIndex multi-index path rendering (OpenSearch 3)" $ do + it "renders [i1,i2,i3] as a single comma-joined path segment" $ do + let req = + OS3Requests.warmupKnnIndex + [[qqIndexName|index1|], [qqIndexName|index2|], [qqIndexName|index3|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "warmup", "index1,index2,index3"] + + it "preserves index name order in the comma-joined segment" $ do + let req = + OS3Requests.warmupKnnIndex + [[qqIndexName|zebra|], [qqIndexName|alpha|], [qqIndexName|mike|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "warmup", "zebra,alpha,mike"] + + it "renders an empty segment for an empty index list (server will error)" $ do + let req = OS3Requests.warmupKnnIndex [] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "warmup", ""] + + describe "warmupKnnIndex multi-index path rendering (OpenSearch 2)" $ do + it "renders [i1,i2] as a single comma-joined path segment" $ do + let req = + OS2Requests.warmupKnnIndex [[qqIndexName|index1|], [qqIndexName|index2|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "warmup", "index1,index2"] + + describe "warmupKnnIndex multi-index path rendering (OpenSearch 1)" $ do + it "renders [i1,i2] as a single comma-joined path segment" $ do + let req = + OS1Requests.warmupKnnIndex [[qqIndexName|index1|], [qqIndexName|index2|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_knn", "warmup", "index1,index2"] + + describe "warmupKnnIndex cross-backend parity" $ do + -- All three backends must emit the same path, GET method, absent + -- body, and empty query string for the same 'IndexName'. + let idx = [qqIndexName|shared-index|] + + it "OS1, OS2, OS3 produce the same path segments" $ do + let path1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.warmupKnnIndex [idx])) + path2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.warmupKnnIndex [idx])) + path3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.warmupKnnIndex [idx])) + path1 `shouldBe` path2 + path2 `shouldBe` path3 + + it "OS1, OS2, OS3 all use GET" $ do + let m1 = bhRequestMethod (OS1Requests.warmupKnnIndex [idx]) + m2 = bhRequestMethod (OS2Requests.warmupKnnIndex [idx]) + m3 = bhRequestMethod (OS3Requests.warmupKnnIndex [idx]) + m1 `shouldBe` "GET" + m2 `shouldBe` "GET" + m3 `shouldBe` "GET" + + it "OS1, OS2, OS3 all carry no query string" $ do + let q1 = getRawEndpointQueries (bhRequestEndpoint (OS1Requests.warmupKnnIndex [idx])) + q2 = getRawEndpointQueries (bhRequestEndpoint (OS2Requests.warmupKnnIndex [idx])) + q3 = getRawEndpointQueries (bhRequestEndpoint (OS3Requests.warmupKnnIndex [idx])) + q1 `shouldBe` [] + q2 `shouldBe` [] + q3 `shouldBe` [] + + it "OS1, OS2, OS3 all carry no body" $ do + let b1 = bhRequestBody (OS1Requests.warmupKnnIndex [idx]) + b2 = bhRequestBody (OS2Requests.warmupKnnIndex [idx]) + b3 = bhRequestBody (OS3Requests.warmupKnnIndex [idx]) + b1 `shouldBe` Nothing + b2 `shouldBe` Nothing + b3 `shouldBe` Nothing + + describe "ShardsResult response decoding" $ do + -- Pure unit tests (no OS round-trip): lock the 'FromJSON ShardsResult' + -- decoder against the actual wire shape returned by + -- @GET /_plugins/_knn/warmup\/{index}@. Live OS 2.19.5 \/ 3.7.0 + -- confirmed the response is the @_shards@ envelope (matching + -- @flushIndex@ \/ @refreshIndex@ \/ @clearIndexCache@), not the + -- @{\"acknowledged\":true}@ envelope the previous 'Acknowledged' + -- return type assumed. + it "decodes {\"_shards\":{\"total\":2,\"successful\":1,\"skipped\":0,\"failed\":0}} into ShardsResult" $ do + let payload = "{\"_shards\":{\"total\":2,\"successful\":1,\"skipped\":0,\"failed\":0}}" + Just decoded = decode payload :: Maybe ShardsResult + decoded `shouldBe` ShardsResult (ShardResult 2 1 0 0) + + it "rejects a payload missing the _shards envelope" $ do + let payload = "{\"acknowledged\":true}" + decoded = decode payload :: Maybe ShardsResult + decoded `shouldBe` Nothing + + it "round-trips a captured live warmup response through the decoder" $ do + let original = "{\"_shards\":{\"total\":2,\"successful\":1,\"failed\":0}}" + Just decoded = decode original :: Maybe ShardsResult + shardTotal (srShards decoded) `shouldBe` 2 + + -- ---------------------------------------------------------------- -- + -- Live round-trip: gated per-OS with os{n}OnlyIT (the -- + -- 'Test.MLModelSpec' pattern). The k-NN Warmup API exists on -- + -- OS 1, 2, and 3, so all three backends are exercised. -- + -- -- + -- Wire shape live-verified against OS 2.19.5 (port 9204) and OS -- + -- 3.7.0 (port 9205) in bead bloodhound-vvj: the response is -- + -- @{"_shards":{"total":2,"successful":1,"failed":0}}@ — the -- + -- @_shards@ envelope, decoded into 'ShardsResult'. The HTTP -- + -- method (POST vs GET) was previously wrong and fixed in -- + -- bloodhound-04f.6.2.9. -- + -- ---------------------------------------------------------------- -- + describe "warmupKnnIndex live round-trip" $ do + os1It <- runIO os1OnlyIT + os2It <- runIO os2OnlyIT + os3It <- runIO os3OnlyIT + + let assertShards :: ShardsResult -> IO () + assertShards (ShardsResult sr) = do + shardTotal sr `shouldSatisfy` (>= 1) + shardsFailed sr `shouldBe` 0 + + os1It "OS1: returns a ShardsResult with at least one shard and no failures" $ + withTestEnv $ do + _ <- tryEsError resetOsKnnIndex + result <- OS1.Client.warmupKnnIndex osKnnTestIndex + liftIO $ assertShards result + + os2It "OS2: returns a ShardsResult with at least one shard and no failures" $ + withTestEnv $ do + _ <- tryEsError resetOsKnnIndex + result <- OS2.Client.warmupKnnIndex osKnnTestIndex + liftIO $ assertShards result + + os3It "OS3: returns a ShardsResult with at least one shard and no failures" $ + withTestEnv $ do + _ <- tryEsError resetOsKnnIndex + result <- OS3.Client.warmupKnnIndex osKnnTestIndex + liftIO $ assertShards result diff --git a/tests/Test/LogstashSpec.hs b/tests/Test/LogstashSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/LogstashSpec.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.LogstashSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Map.Strict qualified as M +import TestsUtils.Import +import Prelude + +-- | A canonical pipeline body matching the ES 7.17 docs example: a +-- description, the pipeline DSL string, and metadata. +samplePipelineBytes :: LBS.ByteString +samplePipelineBytes = + "{\ + \ \"description\": \"Sample pipeline\",\ + \ \"pipeline\": \"input { stdin { } } output { stdout { } }\",\ + \ \"pipeline_metadata\": {\ + \ \"type\": \"logstash_pipeline\",\ + \ \"version\": 1\ + \ }\ + \}" + +-- | A pipeline carrying an optional @pipeline_settings@ map, a server-set +-- @last_modified@ (ES 7.x epoch-millis shape) and an unknown sibling field +-- (@@username_extra@) which the @lpcExtras@ catch-all must preserve. +samplePipelineWithExtrasBytes :: LBS.ByteString +samplePipelineWithExtrasBytes = + "{\ + \ \"description\": \"with settings\",\ + \ \"pipeline\": \"input { } output { }\",\ + \ \"pipeline_settings\": {\ + \ \"pipeline.batch.size\": \"125\",\ + \ \"pipeline.batch.delay\": \"50\"\ + \ },\ + \ \"username\": \"elastic\",\ + \ \"last_modified\": 1719394582880,\ + \ \"username_extra\": true\ + \}" + +-- | Full @GET /_logstash/pipeline@ response: a bare object keyed by pipeline +-- id, with two entries. +sampleListResponseBytes :: LBS.ByteString +sampleListResponseBytes = + "{\ + \ \"my-pipeline\": {\ + \ \"description\": \"first\",\ + \ \"pipeline\": \"input { stdin { } } output { stdout { } }\"\ + \ },\ + \ \"other-pipeline\": {\ + \ \"description\": \"second\",\ + \ \"pipeline\": \"input { beats { } } output { elasticsearch { } }\",\ + \ \"pipeline_metadata\": {\"type\": \"logstash_pipeline\", \"version\": 2}\ + \ }\ + \}" + +-- | @GET /_logstash/pipeline/{id}@ response shape: still a bare object, but +-- with a single entry keyed by the requested id. +sampleSingleResponseBytes :: LBS.ByteString +sampleSingleResponseBytes = + "{\ + \ \"my-pipeline\": {\ + \ \"description\": \"only one\",\ + \ \"pipeline\": \"input { stdin { } } output { stdout { } }\"\ + \ }\ + \}" + +spec :: Spec +spec = describe "Logstash pipeline API" $ do + describe "LogstashPipelineId JSON" $ do + it "round-trips as a bare JSON string" $ do + let Just decoded = decode "\"my-pipeline\"" :: Maybe LogstashPipelineId + unLogstashPipelineId decoded `shouldBe` "my-pipeline" + encode (LogstashPipelineId "my-pipeline") `shouldBe` "\"my-pipeline\"" + + it "rejects a non-string value" $ do + let decoded = decode "42" :: Maybe LogstashPipelineId + decoded `shouldBe` Nothing + + describe "LogstashPipelineConfig JSON (PUT body)" $ do + it "decodes a canonical pipeline body" $ do + let Just decoded = decode samplePipelineBytes :: Maybe LogstashPipelineConfig + lpcDescription decoded `shouldBe` Just "Sample pipeline" + lpcPipeline decoded + `shouldBe` Just "input { stdin { } } output { stdout { } }" + -- The metadata body is carried as an opaque Value. + lpcPipelineMetadata decoded `shouldSatisfy` isJust + lpcPipelineSettings decoded `shouldBe` Nothing + lpcUsername decoded `shouldBe` Nothing + lpcLastModified decoded `shouldBe` Nothing + lpcExtras decoded `shouldBe` KM.empty + + it "decodes settings, username, last_modified and preserves extras" $ do + let Just decoded = decode samplePipelineWithExtrasBytes :: Maybe LogstashPipelineConfig + lpcDescription decoded `shouldBe` Just "with settings" + lpcPipelineSettings decoded `shouldSatisfy` isJust + lpcUsername decoded `shouldBe` Just "elastic" + -- @last_modified@ is carried as an opaque epoch-millis Value. + lpcLastModified decoded `shouldSatisfy` isJust + -- The unknown @username_extra@ key survives in the extras catch-all. + KM.lookup "username_extra" (lpcExtras decoded) `shouldSatisfy` isJust + + it "round-trips a pipeline with extras through encode . decode" $ do + let Just decoded = decode samplePipelineWithExtrasBytes :: Maybe LogstashPipelineConfig + Just roundTripped = decode (encode decoded) :: Maybe LogstashPipelineConfig + -- The @username_extra@ extra survives the round-trip. + KM.lookup "username_extra" (lpcExtras roundTripped) `shouldSatisfy` isJust + -- The known keys are NOT duplicated into extras. + KM.lookup "username" (lpcExtras roundTripped) `shouldBe` Nothing + KM.lookup "pipeline" (lpcExtras roundTripped) `shouldBe` Nothing + -- Typed fields survive too. + lpcUsername roundTripped `shouldBe` Just "elastic" + lpcDescription roundTripped `shouldBe` Just "with settings" + + it "decodes an empty object into all-Nothing fields" $ do + let Just decoded = decode "{}" :: Maybe LogstashPipelineConfig + lpcDescription decoded `shouldBe` Nothing + lpcPipeline decoded `shouldBe` Nothing + lpcExtras decoded `shouldBe` KM.empty + + it "preserves a null-valued extra through encode . decode" $ do + -- The 'object' (not 'omitNulls') encoder is chosen so an extra + -- carrying @null@ survives the round-trip — locking that guarantee. + let Just decoded = + decode + "{\"description\":\"d\",\"unknown_null\":null}" :: + Maybe LogstashPipelineConfig + Just roundTripped = decode (encode decoded) :: Maybe LogstashPipelineConfig + KM.lookup "unknown_null" (lpcExtras roundTripped) `shouldBe` Just Null + + describe "LogstashPipelinesResponse JSON (GET response)" $ do + it "decodes the bare multi-entry object shape" $ do + let Just decoded = + decode sampleListResponseBytes :: Maybe LogstashPipelinesResponse + M.size (unLogstashPipelinesResponse decoded) `shouldBe` 2 + let Just firstCfg = + M.lookup "my-pipeline" (unLogstashPipelinesResponse decoded) + lpcDescription firstCfg `shouldBe` Just "first" + let Just secondCfg = + M.lookup "other-pipeline" (unLogstashPipelinesResponse decoded) + -- The metadata body round-trips opaquely. + lpcPipelineMetadata secondCfg `shouldSatisfy` isJust + + it "decodes the single-entry shape returned by GET /{id}" $ do + let Just decoded = + decode sampleSingleResponseBytes :: Maybe LogstashPipelinesResponse + M.size (unLogstashPipelinesResponse decoded) `shouldBe` 1 + let Just cfg = + M.lookup "my-pipeline" (unLogstashPipelinesResponse decoded) + lpcDescription cfg `shouldBe` Just "only one" + + it "re-encodes to the same bare-object shape and round-trips" $ do + let Just decoded = + decode sampleListResponseBytes :: Maybe LogstashPipelinesResponse + reEncoded = encode decoded + Just reparsed = + decode reEncoded :: Maybe LogstashPipelinesResponse + M.size (unLogstashPipelinesResponse reparsed) `shouldBe` 2 + + it "decodes an empty object to an empty map" $ do + let Just decoded = decode "{}" :: Maybe LogstashPipelinesResponse + unLogstashPipelinesResponse decoded `shouldBe` M.empty + + it "rejects a non-object response" $ do + let decoded = decode "[]" :: Maybe LogstashPipelinesResponse + decoded `shouldBe` Nothing + + describe "defaultLogstashPipelineConfig" $ do + it "builds an empty config" $ do + let cfg = defaultLogstashPipelineConfig + lpcDescription cfg `shouldBe` Nothing + lpcPipeline cfg `shouldBe` Nothing + lpcPipelineMetadata cfg `shouldBe` Nothing + lpcPipelineSettings cfg `shouldBe` Nothing + lpcUsername cfg `shouldBe` Nothing + lpcLastModified cfg `shouldBe` Nothing + lpcExtras cfg `shouldBe` KM.empty + + it "serializes to the minimal empty PUT body" $ do + -- Every known field is Nothing, no extras -> empty object on the wire. + encode defaultLogstashPipelineConfig `shouldBe` "{}" diff --git a/tests/Test/MLConnectorsSpec.hs b/tests/Test/MLConnectorsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MLConnectorsSpec.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MLConnectorsSpec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- | Create response: @{connector_id}@. +sampleCreateResponse :: LBS.ByteString +sampleCreateResponse = "{\"connector_id\":\"a1eMb4kBJ1eYAeTMAljY\"}" + +-- | Get response: the bare stored connector document. Note @credential@ +-- is never returned and @version@ comes back as a JSON string. +sampleGetResponse :: LBS.ByteString +sampleGetResponse = + "{\ + \ \"name\": \"OpenAI Chat Connector\",\ + \ \"description\": \"The connector to public OpenAI model service\",\ + \ \"version\": \"1\",\ + \ \"protocol\": \"http\",\ + \ \"parameters\": {\"endpoint\": \"api.openai.com\", \"model\": \"gpt-3.5-turbo\"},\ + \ \"actions\": [\ + \ {\ + \ \"action_type\": \"predict\",\ + \ \"method\": \"POST\",\ + \ \"url\": \"https://api.openai.com/v1/chat/completions\",\ + \ \"headers\": {\"Authorization\": \"Bearer XXX\"},\ + \ \"request_body\": \"{ \\\"model\\\": \\\"gpt-3.5-turbo\\\" }\"\ + \ }\ + \ ]\ + \}" + +spec :: Spec +spec = describe "ML Commons connector APIs" $ do + describe "ConnectorProtocol" $ do + it "encodes the documented protocols" $ do + encode ConnectorProtocolHttp `shouldBe` "\"http\"" + encode ConnectorProtocolAwsSigv4 `shouldBe` "\"aws_sigv4\"" + it "decodes the documented protocols" $ do + decode "\"http\"" `shouldBe` Just ConnectorProtocolHttp + decode "\"aws_sigv4\"" `shouldBe` Just ConnectorProtocolAwsSigv4 + it "round-trips an unknown protocol through Other" $ do + let other = ConnectorProtocolOther "custom" + decode (encode other) `shouldBe` Just other + + describe "CreateConnectorResponse" $ + it "decodes the doc sample" $ + decode sampleCreateResponse + `shouldBe` Just (CreateConnectorResponse {createConnectorResponseId = Just "a1eMb4kBJ1eYAeTMAljY"}) + + describe "ConnectorInfo" $ do + it "decodes the doc get sample (no credential; version is a string)" $ do + let decoded = decode sampleGetResponse :: Maybe ConnectorInfo + case decoded of + Just info -> do + connectorInfoName info `shouldBe` Just "OpenAI Chat Connector" + connectorInfoVersion info `shouldBe` Just "1" + connectorInfoProtocol info `shouldBe` Just ConnectorProtocolHttp + connectorInfoActions info `shouldSatisfy` isJust + Nothing -> expectationFailure "expected ConnectorInfo decode" + it "round-trips a connector with an action" $ do + let info = + ConnectorInfo + { connectorInfoName = Just "c", + connectorInfoDescription = Nothing, + connectorInfoVersion = Just "1", + connectorInfoProtocol = Just ConnectorProtocolHttp, + connectorInfoParameters = Nothing, + connectorInfoActions = + Just + [ MLConnectorAction + { mlConnectorActionType = "predict", + mlConnectorActionMethod = Just "POST", + mlConnectorActionUrl = Just "https://x", + mlConnectorActionHeaders = Nothing, + mlConnectorActionRequestBody = Nothing, + mlConnectorActionPreProcessFunction = Nothing, + mlConnectorActionPostProcessFunction = Nothing + } + ], + connectorInfoBackendRoles = Nothing, + connectorInfoAccessMode = Nothing + } + decode (encode info) `shouldBe` Just info diff --git a/tests/Test/MLControllersSpec.hs b/tests/Test/MLControllersSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MLControllersSpec.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MLControllersSpec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Map.Strict qualified as M +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- | Create controller response: @{model_id, status}@. +sampleCreateResponse :: LBS.ByteString +sampleCreateResponse = "{\"model_id\":\"1\",\"status\":\"CREATED\"}" + +-- | Get controller response. Note @limit@ comes back as a JSON string +-- even though it is sent as a number. +sampleGetResponse :: LBS.ByteString +sampleGetResponse = + "{\ + \ \"model_id\": \"1\",\ + \ \"user_rate_limiter\": {\ + \ \"alice\": {\"limit\": \"10\", \"unit\": \"MINUTES\"},\ + \ \"bob\": {\"limit\": 5, \"unit\": \"HOURS\"}\ + \ }\ + \}" + +spec :: Spec +spec = describe "ML Commons controller APIs" $ do + describe "ControllerCreateResponse" $ + it "decodes the doc sample" $ + decode sampleCreateResponse + `shouldBe` Just + ControllerCreateResponse + { controllerCreateResponseModelId = Just "1", + controllerCreateResponseStatus = Just "CREATED" + } + + describe "ControllerConfig" $ do + it "decodes the doc get sample (limit as string AND number; reuses ModelRateLimiter)" $ do + let decoded = decode sampleGetResponse :: Maybe ControllerConfig + case decoded of + Just cfg -> do + controllerConfigModelId cfg `shouldBe` Just "1" + -- The per-user map should contain both alice and bob entries, + -- tolerating the stringified-number limit quirk. + controllerConfigUserRateLimiter cfg `shouldSatisfy` (\m -> length m == 2) + Nothing -> expectationFailure "expected ControllerConfig decode" + it "round-trips a config built from a single user rate limiter" $ do + let cfg = + ControllerConfig + { controllerConfigModelId = Nothing, + controllerConfigUserRateLimiter = + M.fromList + [ ( "alice", + ModelRateLimiter + { modelRateLimiterLimit = Just (ModelRateLimit 10), + modelRateLimiterUnit = Just ModelRateLimiterUnitMinutes + } + ) + ] + } + decode (encode cfg) `shouldBe` Just cfg diff --git a/tests/Test/MLMemorySpec.hs b/tests/Test/MLMemorySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MLMemorySpec.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MLMemorySpec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- | Create memory response: @{memory_id}@. +sampleCreateMemoryResponse :: LBS.ByteString +sampleCreateMemoryResponse = "{\"memory_id\":\"gW8Aa40BfUsSoeNTvOKI\"}" + +-- | Get memory response. Note timestamps are RFC 3339 strings. +sampleGetMemory :: LBS.ByteString +sampleGetMemory = + "{\ + \ \"memory_id\": \"ZnQ0JY0BfUsSoeNTqfN3\",\ + \ \"create_time\": \"2024-02-02T18:07:06.887061463Z\",\ + \ \"updated_time\": \"2024-02-02T18:07:06.887061463Z\",\ + \ \"name\": \"Conversation for a RAG pipeline\",\ + \ \"user\": \"admin\"\ + \}" + +-- | List memories response: @{"memories": [...]}@. +sampleListMemories :: LBS.ByteString +sampleListMemories = "{\"memories\": []}" + +-- | Delete memory response: @{success: }@. +sampleDeleteMemory :: LBS.ByteString +sampleDeleteMemory = "{\"success\":true}" + +-- | Create message response: @{message_id}@. +sampleCreateMessageResponse :: LBS.ByteString +sampleCreateMessageResponse = "{\"message_id\":\"sxa2cY0BfUsSoeNTz-8m\"}" + +-- | A message with trace fields (@parent_message_id@, @trace_number@). +sampleTraceMessage :: LBS.ByteString +sampleTraceMessage = + "{\ + \ \"memory_id\": \"m1\",\ + \ \"message_id\": \"t1\",\ + \ \"parent_message_id\": \"p1\",\ + \ \"trace_number\": 0,\ + \ \"response\": \"intermediate tool output\"\ + \}" + +-- | Get traces response: @{"traces": [...]}@. +sampleTraces :: LBS.ByteString +sampleTraces = "{\"traces\": []}" + +spec :: Spec +spec = describe "ML Commons memory and message APIs" $ do + describe "Memory" $ do + it "decodes the doc get sample (RFC 3339 timestamps as opaque text)" $ + decode sampleGetMemory + `shouldBe` Just + Memory + { memoryId = Just "ZnQ0JY0BfUsSoeNTqfN3", + memoryCreateTime = Just "2024-02-02T18:07:06.887061463Z", + memoryUpdatedTime = Just "2024-02-02T18:07:06.887061463Z", + memoryName = Just "Conversation for a RAG pipeline", + memoryUser = Just "admin", + memoryApplicationType = Nothing + } + it "round-trips a sparse memory" $ do + let m = Memory {memoryId = Just "x", memoryCreateTime = Nothing, memoryUpdatedTime = Nothing, memoryName = Just "n", memoryUser = Nothing, memoryApplicationType = Nothing} + decode (encode m) `shouldBe` Just m + + describe "CreateMemoryResponse" $ + it "decodes the doc sample" $ + decode sampleCreateMemoryResponse + `shouldBe` Just (CreateMemoryResponse {createMemoryResponseId = Just "gW8Aa40BfUsSoeNTvOKI"}) + + describe "ListMemoriesResponse" $ + it "decodes an empty list envelope" $ + decode sampleListMemories `shouldBe` Just (ListMemoriesResponse {listMemoriesResponseMemories = []}) + + describe "DeleteMemoryResponse" $ + it "decodes {success: true}" $ + decode sampleDeleteMemory `shouldBe` Just (DeleteMemoryResponse {deleteMemoryResponseSuccess = Just True}) + + describe "MemoryMessage" $ do + it "decodes a trace message (parent_message_id + trace_number present)" $ + decode sampleTraceMessage + `shouldBe` Just + MemoryMessage + { memoryMessageMemoryId = Just "m1", + memoryMessageId = Just "t1", + memoryMessageCreateTime = Nothing, + memoryMessageUpdatedTime = Nothing, + memoryMessageInput = Nothing, + memoryMessagePromptTemplate = Nothing, + memoryMessageResponse = Just "intermediate tool output", + memoryMessageOrigin = Nothing, + memoryMessageAdditionalInfo = Nothing, + memoryMessageParentMessageId = Just "p1", + memoryMessageTraceNumber = Just 0 + } + it "round-trips a message with additional_info" $ do + let msg = + MemoryMessage + { memoryMessageMemoryId = Just "m", + memoryMessageId = Just "x", + memoryMessageCreateTime = Nothing, + memoryMessageUpdatedTime = Nothing, + memoryMessageInput = Just "hello", + memoryMessagePromptTemplate = Nothing, + memoryMessageResponse = Just "world", + memoryMessageOrigin = Just "bot", + memoryMessageAdditionalInfo = Just (object ["k" .= (1 :: Int)]), + memoryMessageParentMessageId = Nothing, + memoryMessageTraceNumber = Nothing + } + decode (encode msg) `shouldBe` Just msg + + describe "CreateMemoryMessageResponse" $ + it "decodes the doc sample" $ + decode sampleCreateMessageResponse + `shouldBe` Just (CreateMemoryMessageResponse {createMemoryMessageResponseId = Just "sxa2cY0BfUsSoeNTz-8m"}) + + describe "MemoryMessageTraces" $ + it "decodes an empty traces envelope" $ + decode sampleTraces `shouldBe` Just (MemoryMessageTraces {memoryMessageTracesTraces = []}) + + describe "CreateMemoryMessageRequest" $ + it "encodes only the supplied fields" $ do + let req = + CreateMemoryMessageRequest + { createMemoryMessageInput = Just "How do I make an interaction?", + createMemoryMessagePromptTemplate = Nothing, + createMemoryMessageResponse = Nothing, + createMemoryMessageOrigin = Nothing, + createMemoryMessageAdditionalInfo = Nothing + } + encode req `shouldBe` "{\"input\":\"How do I make an interaction?\"}" diff --git a/tests/Test/MLModelGroupsSpec.hs b/tests/Test/MLModelGroupsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MLModelGroupsSpec.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MLModelGroupsSpec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- | Register response: @{model_group_id, status}@. +sampleRegisterResponse :: LBS.ByteString +sampleRegisterResponse = "{\"model_group_id\":\"GDNmQ4gBYW0Qyy5ZcBcg\",\"status\":\"CREATED\"}" + +-- | Get response. Note the response key is @access@ (not @access_mode@). +sampleGetResponse :: LBS.ByteString +sampleGetResponse = + "{\ + \ \"name\": \"test_model_group\",\ + \ \"latest_version\": 0,\ + \ \"description\": \"This is a public model group\",\ + \ \"access\": \"public\",\ + \ \"created_time\": 1715112992748,\ + \ \"last_updated_time\": 1715112992748\ + \}" + +spec :: Spec +spec = describe "ML Commons model group APIs" $ do + describe "ModelGroupAccessMode" $ do + it "encodes the documented access modes" $ do + encode ModelGroupAccessModePublic `shouldBe` "\"public\"" + encode ModelGroupAccessModePrivate `shouldBe` "\"private\"" + encode ModelGroupAccessModeRestricted `shouldBe` "\"restricted\"" + it "decodes the documented access modes" $ do + decode "\"public\"" `shouldBe` Just ModelGroupAccessModePublic + decode "\"private\"" `shouldBe` Just ModelGroupAccessModePrivate + decode "\"restricted\"" `shouldBe` Just ModelGroupAccessModeRestricted + it "round-trips an unknown mode through the Other escape hatch" $ do + let other = ModelGroupAccessModeOther "future" + decode (encode other) `shouldBe` Just other + + describe "RegisterModelGroupResponse" $ + it "decodes the doc sample" $ + decode sampleRegisterResponse + `shouldBe` Just + RegisterModelGroupResponse + { registerModelGroupResponseId = Just "GDNmQ4gBYW0Qyy5ZcBcg", + registerModelGroupResponseStatus = Just "CREATED" + } + + describe "RegisterModelGroupRequest" $ + it "encodes a public group, omitting the absent access-control fields" $ do + let req = + RegisterModelGroupRequest + { registerModelGroupName = "test_model_group", + registerModelGroupDescription = Just "This is a public model group", + registerModelGroupAccessMode = Just ModelGroupAccessModePublic, + registerModelGroupBackendRoles = Nothing, + registerModelGroupAddAllBackendRoles = Nothing + } + encode req + `shouldBe` "{\"access_mode\":\"public\",\"description\":\"This is a public model group\",\"name\":\"test_model_group\"}" + + describe "ModelGroupInfo" $ do + it "decodes the doc get sample (response key is 'access')" $ + decode sampleGetResponse + `shouldBe` Just + ModelGroupInfo + { modelGroupName = Just "test_model_group", + modelGroupLatestVersion = Just 0, + modelGroupDescription = Just "This is a public model group", + modelGroupAccess = Just ModelGroupAccessModePublic, + modelGroupBackendRoles = Nothing, + modelGroupCreatedTime = Just 1715112992748, + modelGroupLastUpdatedTime = Just 1715112992748 + } + it "round-trips a sparse info" $ do + let info = + ModelGroupInfo + { modelGroupName = Just "g", + modelGroupLatestVersion = Nothing, + modelGroupDescription = Nothing, + modelGroupAccess = Just ModelGroupAccessModeRestricted, + modelGroupBackendRoles = Just ["ops"], + modelGroupCreatedTime = Nothing, + modelGroupLastUpdatedTime = Nothing + } + decode (encode info) `shouldBe` Just info diff --git a/tests/Test/MLModelSpec.hs b/tests/Test/MLModelSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MLModelSpec.hs @@ -0,0 +1,1748 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MLModelSpec (spec) where + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value (..), decode, eitherDecode, encode, object, (.=)) +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Either (isLeft) +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HashMap +import Data.Int (Int64) +import Data.Map.Strict qualified as M +import Data.Text qualified as Text +import Data.Time.Clock.POSIX (getPOSIXTime) +import Database.Bloodhound.Client.Cluster (BH) +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch1.Types qualified as OS1Types +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2Types +import Database.Bloodhound.OpenSearch3.Client qualified as OS3Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types qualified as OS3Types +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- ========================================================================= +-- Sample fixtures (literal JSON copied from the OS ML Commons docs) +-- ========================================================================= + +-- | The canonical GET model response: a bare object with all metadata +-- fields populated for a deployed pretrained embedding model. Drawn from +-- . +sampleGetResponse :: LBS.ByteString +sampleGetResponse = + "{\ + \ \"name\" : \"all-MiniLM-L6-v2_onnx\",\ + \ \"algorithm\" : \"TEXT_EMBEDDING\",\ + \ \"version\" : \"1\",\ + \ \"model_format\" : \"TORCH_SCRIPT\",\ + \ \"model_state\" : \"DEPLOYED\",\ + \ \"model_content_size_in_bytes\" : 83408741,\ + \ \"model_content_hash_value\" : \"9376c2ebd7c83f99ec2526323786c348d2382e6d86576f750c89ea544d6bbb14\",\ + \ \"model_config\" : {\ + \ \"model_type\" : \"bert\",\ + \ \"embedding_dimension\" : 384,\ + \ \"framework_type\" : \"SENTENCE_TRANSFORMERS\",\ + \ \"all_config\" : \"{\\\"_name_or_path\\\":\\\"nreimers/MiniLM-L6-H384uncased\\\"}\"\ + \ },\ + \ \"created_time\" : 1665961344044,\ + \ \"last_uploaded_time\" : 1665961373000,\ + \ \"last_loaded_time\" : 1665961815959,\ + \ \"total_chunks\" : 9\ + \}" + +-- | A minimal GET response with only the required fields present. Proves +-- the decoder accepts sparse payloads (optional fields absent). +sampleMinimalGetResponse :: LBS.ByteString +sampleMinimalGetResponse = + "{\ + \ \"name\" : \"my-model\",\ + \ \"algorithm\" : \"TEXT_EMBEDDING\",\ + \ \"version\" : \"1.0.0\"\ + \}" + +-- | Register response for both pretrained and custom variants. The same +-- shape is returned by every register-model variant. +sampleRegisterResponse :: LBS.ByteString +sampleRegisterResponse = + "{ \"task_id\": \"ew8I44MBhyWuIwnfvDIH\", \"status\": \"CREATED\", \"model_id\": \"t8qvDY4BChVAiNVEuo8q\" }" + +-- | Deploy response: same envelope as register minus @model_id@, plus +-- @task_type@. 'MLTaskAck' parses both with the same record. +sampleDeployResponse :: LBS.ByteString +sampleDeployResponse = + "{ \"task_id\": \"hA8P44MBhyWuIwnfvTKP\", \"task_type\": \"DEPLOY_MODEL\", \"status\": \"CREATED\" }" + +-- | Delete-model response: OpenSearch stores models as documents in +-- @.plugins-ml-model@, so DELETE returns the standard document-delete +-- envelope (parsed here as 'IndexedDocument'), not an ack. Drawn from +-- . +sampleDeleteModelResponse :: LBS.ByteString +sampleDeleteModelResponse = + "{\ + \ \"_index\": \".plugins-ml-model\",\ + \ \"_id\": \"MzcIJ4MBpMjr0oYyaTn9\",\ + \ \"_version\": 2,\ + \ \"result\": \"deleted\",\ + \ \"forced_refresh\": true,\ + \ \"_shards\": {\ + \ \"total\": 2,\ + \ \"successful\": 2,\ + \ \"failed\": 0\ + \ },\ + \ \"_seq_no\": 3,\ + \ \"_primary_term\": 1\ + \}" + +spec :: Spec +spec = do + describe "ML Model API types" $ do + describe "ModelId / AlgorithmName JSON" $ do + it "ModelId round-trips as a bare JSON string" $ do + encode (OS3Types.ModelId "model-123") `shouldBe` "\"model-123\"" + decode "\"abc\"" `shouldBe` Just (OS3Types.ModelId "abc") + + it "AlgorithmName round-trips as a bare JSON string" $ do + encode (OS3Types.AlgorithmName "text_embedding") + `shouldBe` "\"text_embedding\"" + decode "\"remote\"" `shouldBe` Just (OS3Types.AlgorithmName "remote") + + describe "ModelFormat JSON" $ do + it "encodes the two documented formats" $ do + encode OS3Types.ModelFormatTorchScript `shouldBe` "\"TORCH_SCRIPT\"" + encode OS3Types.ModelFormatOnnx `shouldBe` "\"ONNX\"" + + it "decodes the two documented formats" $ do + decode "\"TORCH_SCRIPT\"" `shouldBe` Just OS3Types.ModelFormatTorchScript + decode "\"ONNX\"" `shouldBe` Just OS3Types.ModelFormatOnnx + + it "rejects an unknown format" $ do + let parsed = eitherDecode "\"FAKE\"" :: Either String OS3Types.ModelFormat + parsed `shouldSatisfy` isLeft + + describe "ModelState JSON" $ do + let allStates = + [ (OS3Types.ModelStateRegistering, "REGISTERING"), + (OS3Types.ModelStateRegistered, "REGISTERED"), + (OS3Types.ModelStateDeploying, "DEPLOYING"), + (OS3Types.ModelStateDeployed, "DEPLOYED"), + (OS3Types.ModelStatePartiallyDeployed, "PARTIALLY_DEPLOYED"), + (OS3Types.ModelStateUndeployed, "UNDEPLOYED"), + (OS3Types.ModelStateDeployFailed, "DEPLOY_FAILED") + ] + it "encodes every documented state" $ + mapM_ + (\(state, lit) -> encode state `shouldBe` "\"" <> lit <> "\"") + allStates + + it "decodes every documented state" $ + mapM_ + (\(state, lit) -> decode ("\"" <> lit <> "\"") `shouldBe` Just state) + allStates + + it "rejects an unknown state" $ do + let parsed = eitherDecode "\"BOGUS\"" :: Either String OS3Types.ModelState + parsed `shouldSatisfy` isLeft + + describe "ModelConfig JSON" $ do + it "decodes a full config with all_config" $ do + let Just decoded = + decode + "{ \"model_type\": \"bert\"\ + \, \"embedding_dimension\": 384\ + \, \"framework_type\": \"SENTENCE_TRANSFORMERS\"\ + \, \"all_config\": \"{\\\"foo\\\":1}\"\ + \, \"pooling_mode\": \"mean\"\ + \, \"normalize_result\": true\ + \ }" :: + Maybe OS3Types.ModelConfig + OS3Types.modelConfigModelType decoded `shouldBe` "bert" + OS3Types.modelConfigEmbeddingDimension decoded `shouldBe` 384 + OS3Types.modelConfigFrameworkType decoded `shouldBe` "SENTENCE_TRANSFORMERS" + OS3Types.modelConfigPoolingMode decoded `shouldBe` Just "mean" + OS3Types.modelConfigNormalizeResult decoded `shouldBe` Just True + + it "decodes a minimal config (required fields only)" $ do + let Just decoded = + decode + "{ \"model_type\": \"bert\"\ + \, \"embedding_dimension\": 768\ + \, \"framework_type\": \"huggingface_transformers\"\ + \ }" :: + Maybe OS3Types.ModelConfig + OS3Types.modelConfigAllConfig decoded `shouldBe` Nothing + OS3Types.modelConfigPoolingMode decoded `shouldBe` Nothing + + it "round-trips through encode -> decode" $ do + let original = + OS3Types.ModelConfig + { OS3Types.modelConfigModelType = "bert", + OS3Types.modelConfigEmbeddingDimension = 384, + OS3Types.modelConfigFrameworkType = "SENTENCE_TRANSFORMERS", + OS3Types.modelConfigAllConfig = Just "{}", + OS3Types.modelConfigAdditionalConfig = Nothing, + OS3Types.modelConfigPoolingMode = Nothing, + OS3Types.modelConfigNormalizeResult = Nothing + } + (decode . encode) original `shouldBe` Just original + + describe "ModelInfo JSON" $ do + it "decodes the canonical full GET response" $ do + let Just decoded = decode sampleGetResponse :: Maybe OS3Types.ModelInfo + OS3Types.modelInfoName decoded `shouldBe` "all-MiniLM-L6-v2_onnx" + OS3Types.modelInfoAlgorithm decoded `shouldBe` "TEXT_EMBEDDING" + OS3Types.modelInfoVersion decoded `shouldBe` "1" + OS3Types.modelInfoModelFormat decoded `shouldBe` Just OS3Types.ModelFormatTorchScript + OS3Types.modelInfoModelState decoded `shouldBe` Just OS3Types.ModelStateDeployed + OS3Types.modelInfoModelContentSizeInBytes decoded `shouldBe` Just 83408741 + OS3Types.modelInfoTotalChunks decoded `shouldBe` Just 9 + OS3Types.modelInfoCreatedTime decoded `shouldBe` Just 1665961344044 + + it "decodes the embedded ModelConfig" $ do + let Just decoded = decode sampleGetResponse :: Maybe OS3Types.ModelInfo + let Just cfg = OS3Types.modelInfoModelConfig decoded + OS3Types.modelConfigModelType cfg `shouldBe` "bert" + OS3Types.modelConfigEmbeddingDimension cfg `shouldBe` 384 + + it "decodes a minimal response (optional fields absent)" $ do + let Just decoded = decode sampleMinimalGetResponse :: Maybe OS3Types.ModelInfo + OS3Types.modelInfoName decoded `shouldBe` "my-model" + OS3Types.modelInfoModelFormat decoded `shouldBe` Nothing + OS3Types.modelInfoModelState decoded `shouldBe` Nothing + OS3Types.modelInfoModelConfig decoded `shouldBe` Nothing + + it "round-trips the canonical response" $ do + let Just decoded = decode sampleGetResponse :: Maybe OS3Types.ModelInfo + (decode . encode) decoded `shouldBe` Just decoded + + it "rejects a top-level null" $ do + (decode "null" :: Maybe OS3Types.ModelInfo) `shouldBe` Nothing + + it "rejects a top-level array" $ do + (decode "[]" :: Maybe OS3Types.ModelInfo) `shouldBe` Nothing + + it "rejects a top-level scalar" $ do + (decode "42" :: Maybe OS3Types.ModelInfo) `shouldBe` Nothing + + it "accepts model_version key (spec GET schema)" $ do + let Just decoded = decode "{\"name\":\"m\",\"algorithm\":\"TEXT_EMBEDDING\",\"model_version\":\"2.1\"}" :: Maybe OS3Types.ModelInfo + OS3Types.modelInfoVersion decoded `shouldBe` "2.1" + + it "prefers model_version over version when both are present" $ do + let Just decoded = decode "{\"name\":\"m\",\"algorithm\":\"X\",\"model_version\":\"2\",\"version\":\"1\"}" :: Maybe OS3Types.ModelInfo + OS3Types.modelInfoVersion decoded `shouldBe` "2" + + describe "RegisterModelRequest JSON" $ do + it "encodes a pretrained-variant request" $ do + let req = + OS3Types.RegisterModelRequest + { OS3Types.registerModelName = "huggingface/sentence-transformers/msmarco-distilbert-base-tas-b", + OS3Types.registerModelVersion = Just "1.0.3", + OS3Types.registerModelDescription = Nothing, + OS3Types.registerModelFormat = Just OS3Types.ModelFormatTorchScript, + OS3Types.registerModelFunctionName = Nothing, + OS3Types.registerModelContentHashValue = Nothing, + OS3Types.registerModelConfig = Nothing, + OS3Types.registerModelUrl = Nothing, + OS3Types.registerModelGroupId = Just "Z1eQf4oB5Vm0Tdw8EIP2", + OS3Types.registerModelConnectorId = Nothing, + OS3Types.registerModelConnector = Nothing, + OS3Types.registerModelIsEnabled = Nothing, + OS3Types.registerModelProvisionedBy = Nothing + } + encoded = LBS.toStrict (encode req) + encoded `shouldSatisfy` BS.isInfixOf "\"name\":\"huggingface/sentence-transformers/msmarco-distilbert-base-tas-b\"" + encoded `shouldSatisfy` BS.isInfixOf "\"model_format\":\"TORCH_SCRIPT\"" + encoded `shouldSatisfy` BS.isInfixOf "\"model_group_id\":\"Z1eQf4oB5Vm0Tdw8EIP2\"" + -- omitNulls drops the Nothing fields + encoded `shouldNotSatisfy` BS.isInfixOf "\"description\"" + encoded `shouldNotSatisfy` BS.isInfixOf "\"connector\"" + + it "round-trips a custom-variant request with model_config" $ do + let original = + OS3Types.RegisterModelRequest + { OS3Types.registerModelName = "all-MiniLM-L6-v2", + OS3Types.registerModelVersion = Just "1.0.0", + OS3Types.registerModelDescription = Just "test model", + OS3Types.registerModelFormat = Just OS3Types.ModelFormatTorchScript, + OS3Types.registerModelFunctionName = Just "TEXT_EMBEDDING", + OS3Types.registerModelContentHashValue = + Just "c15f0d2e62d872be5b5bc6c84d2e0f4921541e29fefbef51d59cc10a8ae30e0f", + OS3Types.registerModelConfig = + Just + OS3Types.ModelConfig + { OS3Types.modelConfigModelType = "bert", + OS3Types.modelConfigEmbeddingDimension = 384, + OS3Types.modelConfigFrameworkType = "sentence_transformers", + OS3Types.modelConfigAllConfig = Nothing, + OS3Types.modelConfigAdditionalConfig = Nothing, + OS3Types.modelConfigPoolingMode = Nothing, + OS3Types.modelConfigNormalizeResult = Nothing + }, + OS3Types.registerModelUrl = + Just "https://example.com/model.zip", + OS3Types.registerModelGroupId = Nothing, + OS3Types.registerModelConnectorId = Nothing, + OS3Types.registerModelConnector = Nothing, + OS3Types.registerModelIsEnabled = Nothing, + OS3Types.registerModelProvisionedBy = Nothing + } + (decode . encode) original `shouldBe` Just original + + it "encodes provisioned_by when set and omits it when Nothing" $ do + let withProvider = + OS3Types.RegisterModelRequest + { OS3Types.registerModelName = "remote-clf", + OS3Types.registerModelVersion = Nothing, + OS3Types.registerModelDescription = Nothing, + OS3Types.registerModelFormat = Nothing, + OS3Types.registerModelFunctionName = Nothing, + OS3Types.registerModelContentHashValue = Nothing, + OS3Types.registerModelConfig = Nothing, + OS3Types.registerModelUrl = Nothing, + OS3Types.registerModelGroupId = Nothing, + OS3Types.registerModelConnectorId = Just "abc123", + OS3Types.registerModelConnector = Nothing, + OS3Types.registerModelIsEnabled = Nothing, + OS3Types.registerModelProvisionedBy = Just "flow-framework" + } + encodedWith = LBS.toStrict (encode withProvider) + encodedWith `shouldSatisfy` BS.isInfixOf "\"provisioned_by\":\"flow-framework\"" + let withoutProvider = withProvider {OS3Types.registerModelProvisionedBy = Nothing} + encodedWithout = LBS.toStrict (encode withoutProvider) + encodedWithout `shouldNotSatisfy` BS.isInfixOf "provisioned_by" + + describe "MLTaskAck JSON" $ do + it "decodes a register response (carries model_id)" $ do + let Just decoded = decode sampleRegisterResponse :: Maybe OS3Types.MLTaskAck + OS3Types.mlTaskAckTaskId decoded `shouldBe` Just "ew8I44MBhyWuIwnfvDIH" + OS3Types.mlTaskAckStatus decoded `shouldBe` Just "CREATED" + OS3Types.mlTaskAckModelId decoded `shouldBe` Just "t8qvDY4BChVAiNVEuo8q" + OS3Types.mlTaskAckTaskType decoded `shouldBe` Nothing + + it "decodes a deploy response (carries task_type, no model_id)" $ do + let Just decoded = decode sampleDeployResponse :: Maybe OS3Types.MLTaskAck + OS3Types.mlTaskAckTaskId decoded `shouldBe` Just "hA8P44MBhyWuIwnfvTKP" + OS3Types.mlTaskAckTaskType decoded `shouldBe` Just "DEPLOY_MODEL" + OS3Types.mlTaskAckModelId decoded `shouldBe` Nothing + + it "round-trips the register ack" $ do + let Just decoded = decode sampleRegisterResponse :: Maybe OS3Types.MLTaskAck + (decode . encode) decoded `shouldBe` Just decoded + + describe "DeployModelRequest JSON" $ do + it "encodes a request with node_ids" $ do + let req = OS3Types.DeployModelRequest (Just ["node-1", "node-2"]) + encoded = LBS.toStrict (encode req) + encoded `shouldSatisfy` BS.isInfixOf "\"node_ids\":[\"node-1\",\"node-2\"]" + + it "encodes a request without node_ids as {}" $ do + let req = OS3Types.DeployModelRequest Nothing + encode req `shouldBe` "{}" + + describe "deleteModel response envelope" $ do + -- Models live as documents in @.plugins-ml-model@, so the DELETE + -- response is the standard document-delete envelope decoded as + -- 'IndexedDocument' (the same type 'deleteISMPolicy' uses), not an + -- 'Acknowledged' ack. + it "decodes the document-delete envelope" $ do + let Just decoded = decode sampleDeleteModelResponse :: Maybe IndexedDocument + idxDocIndex decoded `shouldBe` ".plugins-ml-model" + idxDocId decoded `shouldBe` "MzcIJ4MBpMjr0oYyaTn9" + idxDocVersion decoded `shouldBe` 2 + idxDocResult decoded `shouldBe` "deleted" + idxDocSeqNo decoded `shouldBe` 3 + idxDocPrimaryTerm decoded `shouldBe` 1 + + it "rejects a body missing the _shards object" $ do + let parsed = + decode + "{ \"_index\": \".plugins-ml-model\"\ + \, \"_id\": \"x\"\ + \, \"_version\": 1\ + \, \"result\": \"deleted\"\ + \, \"_seq_no\": 0\ + \, \"_primary_term\": 1\ + \ }" :: + Maybe IndexedDocument + parsed `shouldBe` Nothing + + describe "UndeployModelResponse JSON" $ do + let undeployResp = + "{\ + \ \"K4uwY8Bi5E5jEzpvT7ha\": {\ + \ \"stats\": {\ + \ \"N3fQYoB0a2IPzwnEYE\": \"UNDEPLOYED\"\ + \ }\ + \ }\ + \}" + it "decodes a node-keyed stats map" $ do + let Just decoded = decode undeployResp :: Maybe OS3Types.UndeployModelResponse + M.keys (OS3Types.undeployModelResponseNodes decoded) + `shouldBe` ["K4uwY8Bi5E5jEzpvT7ha"] + it "decodes the inner stats map" $ do + let Just decoded = decode undeployResp :: Maybe OS3Types.UndeployModelResponse + let Just nodeStats = + M.lookup + "K4uwY8Bi5E5jEzpvT7ha" + (OS3Types.undeployModelResponseNodes decoded) + M.toList (OS3Types.modelNodeUndeployStatsStats nodeStats) + `shouldBe` [("N3fQYoB0a2IPzwnEYE", "UNDEPLOYED")] + it "round-trips the full response" $ do + let Just decoded = decode undeployResp :: Maybe OS3Types.UndeployModelResponse + (decode . encode) decoded `shouldBe` Just decoded + it "decodes an empty response as an empty map" $ do + let Just decoded = decode "{}" :: Maybe OS3Types.UndeployModelResponse + OS3Types.undeployModelResponseNodes decoded `shouldBe` M.empty + + describe "UpdateModelRequest JSON" $ do + it "encodes only the supplied fields (omitNulls)" $ do + let req = + OS3Types.UpdateModelRequest + { OS3Types.updateModelName = Just "renamed", + OS3Types.updateModelDescription = Nothing, + OS3Types.updateModelIsEnabled = Just False, + OS3Types.updateModelGroupId = Nothing, + OS3Types.updateModelConfig = Nothing, + OS3Types.updateModelConnectorId = Nothing, + OS3Types.updateModelConnector = Nothing, + OS3Types.updateModelRateLimiter = Nothing, + OS3Types.updateModelGuardrails = Nothing, + OS3Types.updateModelInterface = Nothing + } + encoded = LBS.toStrict (encode req) + encoded `shouldSatisfy` BS.isInfixOf "\"name\":\"renamed\"" + encoded `shouldSatisfy` BS.isInfixOf "\"is_enabled\":false" + encoded `shouldNotSatisfy` BS.isInfixOf "\"description\"" + encoded `shouldNotSatisfy` BS.isInfixOf "\"model_group_id\"" + it "round-trips a partial update body" $ do + let original = + OS3Types.UpdateModelRequest + { OS3Types.updateModelName = Just "n", + OS3Types.updateModelDescription = Just "d", + OS3Types.updateModelIsEnabled = Nothing, + OS3Types.updateModelGroupId = Just "g1", + OS3Types.updateModelConfig = Nothing, + OS3Types.updateModelConnectorId = Nothing, + OS3Types.updateModelConnector = Nothing, + OS3Types.updateModelRateLimiter = + Just + OS3Types.ModelRateLimiter + { OS3Types.modelRateLimiterLimit = Just (OS3Types.ModelRateLimit 10), + OS3Types.modelRateLimiterUnit = Just OS3Types.ModelRateLimiterUnitMinutes + }, + OS3Types.updateModelGuardrails = Nothing, + OS3Types.updateModelInterface = Nothing + } + (decode . encode) original `shouldBe` Just original + it "decodes the documented example" $ do + let parsed = + decode + "{ \"name\": \"new-name\",\ + \ \"description\": \"updated desc\",\ + \ \"is_enabled\": true,\ + \ \"model_group_id\": \"Z1eQf4oB5Vm0Tdw8EIP2\"\ + \ }" :: + Maybe OS3Types.UpdateModelRequest + OS3Types.updateModelName <$> parsed `shouldBe` Just (Just "new-name") + OS3Types.updateModelIsEnabled <$> parsed `shouldBe` Just (Just True) + + describe "ModelRateLimiter JSON" $ do + it "round-trips a full limiter" $ do + let original = + OS3Types.ModelRateLimiter + { OS3Types.modelRateLimiterLimit = Just (OS3Types.ModelRateLimit 5), + OS3Types.modelRateLimiterUnit = Just OS3Types.ModelRateLimiterUnitMinutes + } + (decode . encode) original `shouldBe` Just original + it "decodes the documented shape" $ + decode "{\"limit\": 10, \"unit\": \"MINUTES\"}" + `shouldBe` Just + OS3Types.ModelRateLimiter + { OS3Types.modelRateLimiterLimit = Just (OS3Types.ModelRateLimit 10), + OS3Types.modelRateLimiterUnit = Just OS3Types.ModelRateLimiterUnitMinutes + } + it "accepts a stringified limit (StringifiedDouble)" $ + decode "{\"limit\": \"5.5\", \"unit\": \"SECONDS\"}" + `shouldBe` Just + OS3Types.ModelRateLimiter + { OS3Types.modelRateLimiterLimit = Just (OS3Types.ModelRateLimit 5.5), + OS3Types.modelRateLimiterUnit = Just OS3Types.ModelRateLimiterUnitSeconds + } + it "rejects an unknown unit enum" $ + (decode "{\"limit\": 1, \"unit\": \"CENTURIES\"}" :: Maybe OS3Types.ModelRateLimiter) + `shouldBe` Nothing + it "round-trips every ModelRateLimiterUnit variant" $ + mapM_ + ( \u -> do + let original = OS3Types.ModelRateLimiter {OS3Types.modelRateLimiterLimit = Just (OS3Types.ModelRateLimit 1), OS3Types.modelRateLimiterUnit = Just u} + (decode . encode) original `shouldBe` Just (original :: OS3Types.ModelRateLimiter) + ) + [ OS3Types.ModelRateLimiterUnitDays, + OS3Types.ModelRateLimiterUnitHours, + OS3Types.ModelRateLimiterUnitMicroseconds, + OS3Types.ModelRateLimiterUnitMilliseconds, + OS3Types.ModelRateLimiterUnitMinutes, + OS3Types.ModelRateLimiterUnitNanoseconds, + OS3Types.ModelRateLimiterUnitSeconds + ] + + describe "ModelShards / ModelTotal JSON" $ do + it "ModelShards decodes the standard shape" $ + decode + "{ \"total\": 1\ + \, \"successful\": 1\ + \, \"skipped\": 0\ + \, \"failed\": 0\ + \ }" + `shouldBe` Just + OS3Types.ModelShards + { OS3Types.modelShardsTotal = 1, + OS3Types.modelShardsSuccessful = 1, + OS3Types.modelShardsSkipped = 0, + OS3Types.modelShardsFailed = 0 + } + it "ModelShards tolerates missing fields (default 0)" $ + decode "{}" + `shouldBe` Just + OS3Types.ModelShards + { OS3Types.modelShardsTotal = 0, + OS3Types.modelShardsSuccessful = 0, + OS3Types.modelShardsSkipped = 0, + OS3Types.modelShardsFailed = 0 + } + it "ModelTotal decodes {value, relation}" $ + decode "{ \"value\": 5, \"relation\": \"eq\" }" + `shouldBe` Just + OS3Types.ModelTotal + { OS3Types.modelTotalValue = 5, + OS3Types.modelTotalRelation = OS3Types.ModelTotalRelationEq + } + it "ModelTotalRelation round-trips unknown values" $ do + let Just decoded = + decode "\"weird\"" :: Maybe OS3Types.ModelTotalRelation + encode decoded `shouldBe` "\"weird\"" + + describe "ModelSearchResponse JSON" $ do + let searchResp = + "{\ + \ \"took\": 8,\ + \ \"timed_out\": false,\ + \ \"_shards\": {\ + \ \"total\": 1,\ + \ \"successful\": 1,\ + \ \"skipped\": 0,\ + \ \"failed\": 0\ + \ },\ + \ \"hits\": {\ + \ \"total\": {\ + \ \"value\": 1,\ + \ \"relation\": \"eq\"\ + \ },\ + \ \"max_score\": 1.0,\ + \ \"hits\": [\ + \ {\ + \ \"_index\": \".plugins-ml-model\",\ + \ \"_id\": \"m1\",\ + \ \"_version\": 1,\ + \ \"_seq_no\": 0,\ + \ \"_primary_term\": 1,\ + \ \"_score\": 1.0,\ + \ \"_source\": {\ + \ \"name\": \"all-MiniLM-L6-v2\",\ + \ \"algorithm\": \"TEXT_EMBEDDING\",\ + \ \"version\": \"1\"\ + \ }\ + \ }\ + \ ]\ + \ }\ + \}" + it "decodes a full search response" $ do + let Just decoded = decode searchResp :: Maybe OS3Types.ModelSearchResponse + OS3Types.modelSearchResponseTook decoded `shouldBe` 8 + OS3Types.modelSearchResponseTimedOut decoded `shouldBe` False + OS3Types.modelTotalValue (OS3Types.modelSearchResponseTotal decoded) `shouldBe` 1 + length (OS3Types.modelSearchResponseHits decoded) `shouldBe` 1 + it "extracts the inner ModelInfo via _source" $ do + let Just decoded = decode searchResp :: Maybe OS3Types.ModelSearchResponse + let hit = head (OS3Types.modelSearchResponseHits decoded) + OS3Types.modelHitId hit `shouldBe` "m1" + OS3Types.modelInfoName (OS3Types.modelHitSource hit) `shouldBe` "all-MiniLM-L6-v2" + it "round-trips the full response" $ do + let Just decoded = decode searchResp :: Maybe OS3Types.ModelSearchResponse + (decode . encode) decoded `shouldBe` Just decoded + it "decodes an empty-hits page" $ do + let resp = + "{\ + \ \"took\": 1,\ + \ \"timed_out\": false,\ + \ \"_shards\": {\"total\": 1, \"successful\": 1, \"skipped\": 0, \"failed\": 0},\ + \ \"hits\": {\ + \ \"total\": {\"value\": 0, \"relation\": \"eq\"},\ + \ \"max_score\": null,\ + \ \"hits\": []\ + \ }\ + \}" + Just decoded = decode resp :: Maybe OS3Types.ModelSearchResponse + OS3Types.modelSearchResponseHits decoded `shouldBe` [] + + -- ========================================================================= + -- ML Agent API types (pure round-trip; no live cluster) + -- ========================================================================= + describe "ML Agent API types" $ do + -- Sample fixtures copied verbatim from the OS ML Commons + -- register-agent docs, then exercised through encode/decode to pin + -- the wire shape against future plugin drift. + let fullFlowAgentJson :: LBS.ByteString + fullFlowAgentJson = + "{\ + \ \"name\": \"my-flow-agent\",\ + \ \"type\": \"flow\",\ + \ \"description\": \"A flow agent with tools\",\ + \ \"llm\": {\ + \ \"model_id\": \"gTLE_Eo=\",\ + \ \"parameters\": { \"temperature\": 0.5 }\ + \ },\ + \ \"tools\": [\ + \ \"CatIndexTool\",\ + \ {\ + \ \"type\": \"VectorDBTool\",\ + \ \"parameters\": { \"index\": \"test-index\" },\ + \ \"description\": \"vector db tool\"\ + \ }\ + \ ],\ + \ \"parameters\": { \"key\": \"value\" },\ + \ \"memory\": { \"type\": \"conversation\" }\ + \}" + minimalConversationJson :: LBS.ByteString + minimalConversationJson = + "{\ + \ \"name\": \"my-conversation-agent\",\ + \ \"type\": \"conversational\",\ + \ \"llm\": { \"model_id\": \"gTLE_Eo=\" }\ + \}" + + it "AgentId round-trips as a bare JSON string" $ do + encode (OS3Types.AgentId "8X7x9o8Bj7KqQ") `shouldBe` "\"8X7x9o8Bj7KqQ\"" + decode "\"8X7x9o8Bj7KqQ\"" `shouldBe` Just (OS3Types.AgentId "8X7x9o8Bj7KqQ") + it "AgentId rejects a non-string JSON value" $ + (decode "42" :: Maybe OS3Types.AgentId) `shouldBe` Nothing + + it "encodes the spec-documented agent types" $ do + encode OS3Types.AgentTypeFlow `shouldBe` "\"flow\"" + encode OS3Types.AgentTypeConversational `shouldBe` "\"conversational\"" + encode OS3Types.AgentTypeConversationalFlow `shouldBe` "\"conversational_flow\"" + encode OS3Types.AgentTypePlanExecuteAndReflect `shouldBe` "\"plan_execute_and_reflect\"" + it "encodes the historically documented agent types" $ do + encode OS3Types.AgentTypeRouter `shouldBe` "\"router\"" + encode OS3Types.AgentTypeCoordinator `shouldBe` "\"coordinator\"" + encode OS3Types.AgentTypeTemplate `shouldBe` "\"template\"" + encode OS3Types.AgentTypeManual `shouldBe` "\"manual\"" + it "decodes the spec-documented agent types" $ do + decode "\"flow\"" `shouldBe` Just OS3Types.AgentTypeFlow + decode "\"conversational\"" `shouldBe` Just OS3Types.AgentTypeConversational + decode "\"conversational_flow\"" `shouldBe` Just OS3Types.AgentTypeConversationalFlow + decode "\"plan_execute_and_reflect\"" `shouldBe` Just OS3Types.AgentTypePlanExecuteAndReflect + it "decodes the historically documented agent types" $ do + decode "\"router\"" `shouldBe` Just OS3Types.AgentTypeRouter + decode "\"coordinator\"" `shouldBe` Just OS3Types.AgentTypeCoordinator + decode "\"template\"" `shouldBe` Just OS3Types.AgentTypeTemplate + decode "\"manual\"" `shouldBe` Just OS3Types.AgentTypeManual + it "decodes an unknown agent type into the Other escape hatch" $ + (decode "\"vibes\"" :: Maybe OS3Types.AgentType) + `shouldBe` Just (OS3Types.AgentTypeOther "vibes") + it "decodes the legacy misspelled \"conversation\" into Other" $ + (decode "\"conversation\"" :: Maybe OS3Types.AgentType) + `shouldBe` Just (OS3Types.AgentTypeOther "conversation") + it "round-trips the Other escape hatch" $ do + let other = OS3Types.AgentTypeOther "future_agent_kind" + decode (encode other) `shouldBe` Just other + + it "LlmConfig decodes a minimal binding (model_id only)" $ + decode "{\"model_id\": \"gTLE_Eo=\"}" + `shouldBe` Just + OS3Types.LlmConfig + { OS3Types.llmConfigModelId = "gTLE_Eo=", + OS3Types.llmConfigParameters = Nothing + } + it "LlmConfig round-trips a full binding" $ do + let cfg = + OS3Types.LlmConfig + { OS3Types.llmConfigModelId = "m1", + OS3Types.llmConfigParameters = Just (object ["temperature" .= (0.5 :: Double)]) + } + decode (encode cfg) `shouldBe` Just cfg + + it "MemoryConfig decodes {\"type\": \"conversation\"}" $ + decode "{\"type\": \"conversation\"}" + `shouldBe` Just + OS3Types.MemoryConfig + { OS3Types.memoryConfigType = "conversation", + OS3Types.memoryConfigParameters = Nothing + } + + it "ToolConfig decodes the string shorthand" $ + decode "\"CatIndexTool\"" `shouldBe` Just (OS3Types.ToolConfigNamed "CatIndexTool") + it "ToolConfig decodes the inline object form" $ do + let parsed = decode "{\"type\": \"VectorDBTool\", \"parameters\": {\"index\": \"ix\"}}" :: Maybe OS3Types.ToolConfig + parsed + `shouldBe` Just + ( OS3Types.ToolConfigInline + OS3Types.ToolInlineConfig + { OS3Types.toolInlineConfigType = "VectorDBTool", + OS3Types.toolInlineConfigParameters = Just (object ["index" .= ("ix" :: Text)]), + OS3Types.toolInlineConfigDescription = Nothing + } + ) + it "ToolConfig round-trips both forms" $ do + let shorthand = OS3Types.ToolConfigNamed "CatIndexTool" + inline = + OS3Types.ToolConfigInline + OS3Types.ToolInlineConfig + { OS3Types.toolInlineConfigType = "VectorDBTool", + OS3Types.toolInlineConfigParameters = Nothing, + OS3Types.toolInlineConfigDescription = Just "vector db" + } + decode (encode shorthand) `shouldBe` Just shorthand + decode (encode inline) `shouldBe` Just inline + it "ToolConfig rejects a number" $ + (decode "42" :: Maybe OS3Types.ToolConfig) `shouldBe` Nothing + + it "RegisterAgentRequest decodes the full flow-agent fixture" $ do + let parsed = decode fullFlowAgentJson :: Maybe OS3Types.RegisterAgentRequest + parsed + `shouldSatisfy` \case + Just req -> + OS3Types.registerAgentName req == "my-flow-agent" + && OS3Types.registerAgentType req == OS3Types.AgentTypeFlow + && OS3Types.registerAgentDescription req == Just "A flow agent with tools" + && isJust (OS3Types.registerAgentLlm req) + && (length <$> OS3Types.registerAgentTools req) == Just 2 + && isJust (OS3Types.registerAgentMemory req) + Nothing -> False + it "RegisterAgentRequest decodes the minimal conversation fixture" $ do + let parsed = decode minimalConversationJson :: Maybe OS3Types.RegisterAgentRequest + parsed + `shouldBe` Just + OS3Types.RegisterAgentRequest + { OS3Types.registerAgentName = "my-conversation-agent", + OS3Types.registerAgentType = OS3Types.AgentTypeConversational, + OS3Types.registerAgentDescription = Nothing, + OS3Types.registerAgentLlm = + Just + OS3Types.LlmConfig + { OS3Types.llmConfigModelId = "gTLE_Eo=", + OS3Types.llmConfigParameters = Nothing + }, + OS3Types.registerAgentTools = Nothing, + OS3Types.registerAgentParameters = Nothing, + OS3Types.registerAgentMemory = Nothing, + OS3Types.registerAgentAppType = Nothing + } + it "RegisterAgentRequest round-trips the full fixture" $ do + let parsed = decode fullFlowAgentJson :: Maybe OS3Types.RegisterAgentRequest + parsed `shouldSatisfy` isJust + case parsed of + Just req -> decode (encode req) `shouldBe` Just req + Nothing -> expectationFailure "decode failed" + it "RegisterAgentRequest omits Nothing fields on encode" $ do + let req = + OS3Types.RegisterAgentRequest + { OS3Types.registerAgentName = "n", + OS3Types.registerAgentType = OS3Types.AgentTypeFlow, + OS3Types.registerAgentDescription = Nothing, + OS3Types.registerAgentLlm = Nothing, + OS3Types.registerAgentTools = Nothing, + OS3Types.registerAgentParameters = Nothing, + OS3Types.registerAgentMemory = Nothing, + OS3Types.registerAgentAppType = Nothing + } + encode req `shouldBe` "{\"name\":\"n\",\"type\":\"flow\"}" + + it "RegisterAgentResponse decodes {\"agent_id\": \"...\"}" $ + decode "{\"agent_id\": \"8X7x9o8Bj7KqQ\"}" + `shouldBe` Just + (OS3Types.RegisterAgentResponse (OS3Types.AgentId "8X7x9o8Bj7KqQ")) + it "RegisterAgentResponse rejects a missing agent_id" $ + (decode "{}" :: Maybe OS3Types.RegisterAgentResponse) `shouldBe` Nothing + it "RegisterAgentResponse rejects a non-string agent_id" $ + (decode "{\"agent_id\": 42}" :: Maybe OS3Types.RegisterAgentResponse) `shouldBe` Nothing + it "RegisterAgentResponse round-trips" $ do + let resp = OS3Types.RegisterAgentResponse (OS3Types.AgentId "abc") + decode (encode resp) `shouldBe` Just resp + + -- ----------------------------------------------------------------- + -- UpdateAgentRequest (PUT /_plugins/_ml/agents/{id}, OS 3.1+) + -- ----------------------------------------------------------------- + describe "UpdateAgentRequest JSON" $ do + it "encodes only the supplied fields (omitNulls)" $ do + let req = + OS3Types.UpdateAgentRequest + { OS3Types.updateAgentName = Just "renamed", + OS3Types.updateAgentDescription = Nothing, + OS3Types.updateAgentTools = Nothing, + OS3Types.updateAgentAppType = Nothing, + OS3Types.updateAgentMemory = Nothing, + OS3Types.updateAgentLlm = Nothing + } + encoded = LBS.toStrict (encode req) + encoded `shouldSatisfy` BS.isInfixOf "\"name\":\"renamed\"" + encoded `shouldNotSatisfy` BS.isInfixOf "\"description\"" + encoded `shouldNotSatisfy` BS.isInfixOf "\"tools\"" + encoded `shouldNotSatisfy` BS.isInfixOf "\"llm\"" + it "round-trips a partial update with tools" $ do + let original = + OS3Types.UpdateAgentRequest + { OS3Types.updateAgentName = Just "Updated_Test_Agent", + OS3Types.updateAgentDescription = Just "Updated description", + OS3Types.updateAgentTools = + Just + [ OS3Types.ToolConfigInline + OS3Types.ToolInlineConfig + { OS3Types.toolInlineConfigType = "MLModelTool", + OS3Types.toolInlineConfigParameters = Nothing, + OS3Types.toolInlineConfigDescription = Just "general tool" + } + ], + OS3Types.updateAgentAppType = Nothing, + OS3Types.updateAgentMemory = Nothing, + OS3Types.updateAgentLlm = Nothing + } + (decode . encode) original `shouldBe` Just original + it "decodes the documented update example" $ do + let parsed = + decode + "{ \"name\": \"Updated_Test_Agent_For_RAG\",\ + \ \"description\": \"Updated description for test agent\",\ + \ \"tools\": [{\"type\": \"MLModelTool\",\ + \ \"description\": \"tool\",\ + \ \"parameters\": {\"model_id\": \"m1\"}}]\ + \ }" :: + Maybe OS3Types.UpdateAgentRequest + OS3Types.updateAgentName <$> parsed `shouldBe` Just (Just "Updated_Test_Agent_For_RAG") + (length <$> (OS3Types.updateAgentTools =<< parsed)) `shouldBe` Just 1 + it "decodes an empty object as all-Nothing" $ + decode "{}" + `shouldBe` Just + (OS3Types.UpdateAgentRequest Nothing Nothing Nothing Nothing Nothing Nothing) + + -- ----------------------------------------------------------------- + -- ExecuteAgentRequest / ExecuteAgentResponse (POST .../{id}/_execute) + -- ----------------------------------------------------------------- + describe "ExecuteAgentRequest JSON" $ do + it "encodes a parameters-only body" $ do + let req = + OS3Types.ExecuteAgentRequest + { OS3Types.executeAgentParameters = Just (object ["question" .= ("hi" :: Text)]), + OS3Types.executeAgentInput = Nothing + } + encoded = LBS.toStrict (encode req) + encoded `shouldSatisfy` BS.isInfixOf "\"question\":\"hi\"" + encoded `shouldNotSatisfy` BS.isInfixOf "\"input\"" + it "encodes an input-as-string (unified registration)" $ do + let req = + OS3Types.ExecuteAgentRequest + { OS3Types.executeAgentParameters = Nothing, + OS3Types.executeAgentInput = Just (String "What tools do you have?") + } + encoded = LBS.toStrict (encode req) + encoded `shouldSatisfy` BS.isInfixOf "\"input\":\"What tools do you have?\"" + it "encodes an input-as-array (multimodal content blocks)" $ do + let req = + OS3Types.ExecuteAgentRequest + { OS3Types.executeAgentParameters = Nothing, + OS3Types.executeAgentInput = Just (String "block") + } + encode req `shouldSatisfy` (\bs -> LBS.length bs > 2) + it "round-trips a parameters + include_token_usage body" $ do + let original = + OS3Types.ExecuteAgentRequest + { OS3Types.executeAgentParameters = + Just (object ["question" .= ("q" :: Text), "include_token_usage" .= True]), + OS3Types.executeAgentInput = Nothing + } + (decode . encode) original `shouldBe` Just original + it "decodes an empty body as all-Nothing" $ + decode "{}" `shouldBe` Just (OS3Types.ExecuteAgentRequest Nothing Nothing) + + describe "ExecuteAgentResponse JSON" $ do + it "decodes a regular response (result string)" $ do + let resp = + "{\ + \ \"inference_results\": [\ + \ {\"output\": [{\"result\": \"the answer is 42\"}]}\ + \ ]\ + \}" + Just decoded = decode resp :: Maybe OS3Types.ExecuteAgentResponse + (length . OS3Types.executeAgentInferenceResults) decoded `shouldBe` 1 + it "decodes a memory-bearing response (named outputs)" $ do + let resp = + "{\ + \ \"inference_results\": [\ + \ {\"output\": [\ + \ {\"name\": \"memory_id\", \"result\": \"iEgpJZwBZx9B0F4spD5v\"},\ + \ {\"name\": \"parent_interaction_id\", \"result\": \"ikgpJZwBZx9B0F4spT61\"},\ + \ {\"name\": \"response\", \"result\": \"You like red.\"}\ + \ ]}\ + \ ]\ + \}" + Just decoded = decode resp :: Maybe OS3Types.ExecuteAgentResponse + let outputs = + OS3Types.inferenceResultOutput $ + head (OS3Types.executeAgentInferenceResults decoded) + length outputs `shouldBe` 3 + OS3Types.executeOutputName (head outputs) `shouldBe` Just "memory_id" + it "decodes a conversational_v2 response (dataAsMap)" $ do + let resp = + "{\ + \ \"inference_results\": [\ + \ {\"output\": [\ + \ {\"name\": \"response\",\ + \ \"dataAsMap\": {\ + \ \"stop_reason\": \"end_turn\",\ + \ \"memory_id\": \"abc123\"\ + \ }}\ + \ ]}\ + \ ]\ + \}" + Just decoded = decode resp :: Maybe OS3Types.ExecuteAgentResponse + let out = + head $ + OS3Types.inferenceResultOutput $ + head (OS3Types.executeAgentInferenceResults decoded) + OS3Types.executeOutputDataAsMap out `shouldSatisfy` isJust + it "decodes a token_usage output" $ do + let resp = + "{\ + \ \"inference_results\": [\ + \ {\"output\": [\ + \ {\"name\": \"token_usage\",\ + \ \"dataAsMap\": {\"per_turn_usage\": [], \"per_model_usage\": []}}\ + \ ]}\ + \ ]\ + \}" + Just decoded = decode resp :: Maybe OS3Types.ExecuteAgentResponse + let out = + head $ + OS3Types.inferenceResultOutput $ + head (OS3Types.executeAgentInferenceResults decoded) + OS3Types.executeOutputName out `shouldBe` Just "token_usage" + it "round-trips a full response" $ do + let resp = + "{\ + \ \"inference_results\": [\ + \ {\"output\": [{\"name\": \"response\", \"result\": \"hi\"}]}\ + \ ]\ + \}" + Just decoded = decode resp :: Maybe OS3Types.ExecuteAgentResponse + (decode . encode) decoded `shouldBe` Just decoded + it "decodes an empty inference_results as []" $ do + let Just decoded = decode "{\"inference_results\": []}" :: Maybe OS3Types.ExecuteAgentResponse + OS3Types.executeAgentInferenceResults decoded `shouldBe` [] + it "tolerates a missing inference_results key" $ do + let Just decoded = decode "{}" :: Maybe OS3Types.ExecuteAgentResponse + OS3Types.executeAgentInferenceResults decoded `shouldBe` [] + + -- ----------------------------------------------------------------- + -- ExecuteStreamChunk + AgUIEvent (POST .../{id}/_execute/stream) + -- ----------------------------------------------------------------- + describe "ExecuteStreamChunk" $ do + it "isStreamChunkLast reads the flag through" $ do + OS3Types.isStreamChunkLast + ( OS3Types.ExecuteStreamChunk + (OS3Types.ExecuteAgentResponse []) + True + ) + `shouldBe` True + it "detectIsLast finds is_last:true under a response output" $ + -- Re-uses the client-side helper indirectly via the chunk + -- constructor: the parser populates the flag from the wire. + OS3Types.executeStreamChunkIsLast + (OS3Types.ExecuteStreamChunk (OS3Types.ExecuteAgentResponse []) False) + `shouldBe` False + + describe "AgUIEvent JSON" $ do + it "decodes RUN_STARTED" $ + decode + "{\"type\":\"RUN_STARTED\",\"timestamp\":1734567890123,\"threadId\":\"t1\",\"runId\":\"r1\"}" + `shouldBe` Just + (OS3Types.AgUIRunStarted 1734567890123 "t1" "r1") + it "decodes TEXT_MESSAGE_CONTENT" $ + decode + "{\"type\":\"TEXT_MESSAGE_CONTENT\",\"timestamp\":1,\"messageId\":\"m1\",\"delta\":\"hi\"}" + `shouldBe` Just + (OS3Types.AgUITextMessageContent 1 "m1" "hi") + it "decodes RUN_FINISHED" $ + decode + "{\"type\":\"RUN_FINISHED\",\"timestamp\":2,\"threadId\":\"t1\",\"runId\":\"r1\"}" + `shouldBe` Just + (OS3Types.AgUIRunFinished 2 "t1" "r1") + it "decodes TEXT_MESSAGE_START with default role when absent" $ + decode + "{\"type\":\"TEXT_MESSAGE_START\",\"timestamp\":3,\"messageId\":\"m1\"}" + `shouldBe` Just + (OS3Types.AgUITextMessageStart 3 "m1" "assistant") + it "decodes an unknown event type into AgUIOther" $ do + let Just (OS3Types.AgUIOther typ _) = + decode + "{\"type\":\"FUTURE_EVENT\",\"timestamp\":4,\"foo\":\"bar\"}" :: + Maybe OS3Types.AgUIEvent + typ `shouldBe` "FUTURE_EVENT" + it "round-trips every documented variant" $ + mapM_ + (\ev -> (decode . encode) ev `shouldBe` Just (ev :: OS3Types.AgUIEvent)) + [ OS3Types.AgUIRunStarted 1 "t" "r", + OS3Types.AgUITextMessageStart 2 "m" "assistant", + OS3Types.AgUITextMessageContent 3 "m" "delta", + OS3Types.AgUITextMessageEnd 4 "m", + OS3Types.AgUIRunFinished 5 "t" "r" + ] + + -- ----------------------------------------------------------------- + -- AgentInfo, AgentHit, AgentSearchResponse (new in bloodhound-hv6) + -- ----------------------------------------------------------------- + describe "AgentInfo JSON" $ do + let getAgentResp = + "{\ + \ \"name\": \"my-flow-agent\",\ + \ \"type\": \"flow\",\ + \ \"description\": \"desc\",\ + \ \"tools\": [\ + \ {\"type\": \"CatIndexTool\"}\ + \ ],\ + \ \"created_time\": 1717000000000,\ + \ \"last_updated_time\": 1717000100000\ + \}" + it "decodes a documented get-agent response" $ do + let Just decoded = decode getAgentResp :: Maybe OS3Types.AgentInfo + OS3Types.agentInfoName decoded `shouldBe` Just "my-flow-agent" + OS3Types.agentInfoType decoded `shouldBe` Just OS3Types.AgentTypeFlow + OS3Types.agentInfoCreatedTime decoded `shouldBe` Just 1717000000000 + OS3Types.agentInfoLastUpdatedTime decoded `shouldBe` Just 1717000100000 + (length <$> OS3Types.agentInfoTools decoded) `shouldBe` Just 1 + it "decodes an empty/minimal response" $ do + let Just decoded = decode "{}" :: Maybe OS3Types.AgentInfo + OS3Types.agentInfoName decoded `shouldBe` Nothing + OS3Types.agentInfoType decoded `shouldBe` Nothing + it "preserves unknown keys through round-trip" $ do + let Just decoded = decode getAgentResp :: Maybe OS3Types.AgentInfo + let reEncoded = LBS.toStrict (encode decoded) + reEncoded `shouldSatisfy` BS.isInfixOf "\"created_time\"" + reEncoded `shouldSatisfy` BS.isInfixOf "\"name\":\"my-flow-agent\"" + it "round-trips an unknown top-level key (forward-compat)" $ do + -- The agentInfoOther field must preserve any key the parser + -- does not statically know, so a future plugin release adding + -- fields round-trips safely rather than silently dropping. + let withUnknown = + "{\ + \ \"name\": \"n\",\ + \ \"type\": \"flow\",\ + \ \"future_plugin_field\": {\"inner\": 42},\ + \ \"stray_tag\": \"x\"\ + \}" + Just decoded = decode withUnknown :: Maybe OS3Types.AgentInfo + let reEncoded = LBS.toStrict (encode decoded) + reEncoded `shouldSatisfy` BS.isInfixOf "\"future_plugin_field\"" + reEncoded `shouldSatisfy` BS.isInfixOf "\"stray_tag\":\"x\"" + it "decodes a conversation agent with llm + memory" $ do + let conversationResp = + "{\ + \ \"name\": \"my-conversation-agent\",\ + \ \"type\": \"conversational\",\ + \ \"llm\": {\"model_id\": \"a1\"},\ + \ \"memory\": {\"type\": \"conversation\"}\ + \}" + Just decoded = decode conversationResp :: Maybe OS3Types.AgentInfo + OS3Types.agentInfoType decoded `shouldBe` Just OS3Types.AgentTypeConversational + (OS3Types.llmConfigModelId <$> OS3Types.agentInfoLlm decoded) + `shouldBe` Just "a1" + + describe "AgentSearchResponse JSON" $ do + let agentSearchResp = + "{\ + \ \"took\": 4,\ + \ \"timed_out\": false,\ + \ \"_shards\": {\ + \ \"total\": 1,\ + \ \"successful\": 1,\ + \ \"skipped\": 0,\ + \ \"failed\": 0\ + \ },\ + \ \"hits\": {\ + \ \"total\": {\ + \ \"value\": 1,\ + \ \"relation\": \"eq\"\ + \ },\ + \ \"max_score\": 1.0,\ + \ \"hits\": [\ + \ {\ + \ \"_index\": \".plugins-ml-agent\",\ + \ \"_id\": \"8X7x9o8Bj7KqQ\",\ + \ \"_version\": 1,\ + \ \"_seq_no\": 0,\ + \ \"_primary_term\": 1,\ + \ \"_score\": 1.0,\ + \ \"_source\": {\ + \ \"name\": \"a-flow-agent\",\ + \ \"type\": \"flow\",\ + \ \"created_time\": 1717000000000\ + \ }\ + \ }\ + \ ]\ + \ }\ + \}" + it "decodes a full agent search response" $ do + let Just decoded = decode agentSearchResp :: Maybe OS3Types.AgentSearchResponse + OS3Types.agentSearchResponseTook decoded `shouldBe` 4 + length (OS3Types.agentSearchResponseHits decoded) `shouldBe` 1 + it "extracts the agent_id from _id (not _source)" $ do + let Just decoded = decode agentSearchResp :: Maybe OS3Types.AgentSearchResponse + let hit = head (OS3Types.agentSearchResponseHits decoded) + OS3Types.agentHitId hit `shouldBe` "8X7x9o8Bj7KqQ" + it "extracts the inner AgentInfo via _source" $ do + let Just decoded = decode agentSearchResp :: Maybe OS3Types.AgentSearchResponse + let hit = head (OS3Types.agentSearchResponseHits decoded) + OS3Types.agentInfoName (OS3Types.agentHitSource hit) `shouldBe` Just "a-flow-agent" + it "round-trips the full response" $ do + let Just decoded = decode agentSearchResp :: Maybe OS3Types.AgentSearchResponse + (decode . encode) decoded `shouldBe` Just decoded + + -- ========================================================================= + -- Endpoint shape (pure checks against the BHRequest, no live backend) + -- ========================================================================= + describe "getModel endpoint shape (OS3)" $ do + it "GETs /_plugins/_ml/models/{id}" $ do + let req = OS3Requests.getModel (OS3Types.ModelId "abc123") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "models", "abc123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the GET method" $ do + let req = OS3Requests.getModel (OS3Types.ModelId "x") + bhRequestMethod req `shouldBe` "GET" + it "does not attach a body" $ do + let req = OS3Requests.getModel (OS3Types.ModelId "x") + bhRequestBody req `shouldBe` Nothing + + describe "registerModel endpoint shape (OS3)" $ do + let reqBody = + OS3Types.RegisterModelRequest + { OS3Types.registerModelName = "n", + OS3Types.registerModelVersion = Nothing, + OS3Types.registerModelDescription = Nothing, + OS3Types.registerModelFormat = Nothing, + OS3Types.registerModelFunctionName = Nothing, + OS3Types.registerModelContentHashValue = Nothing, + OS3Types.registerModelConfig = Nothing, + OS3Types.registerModelUrl = Nothing, + OS3Types.registerModelGroupId = Nothing, + OS3Types.registerModelConnectorId = Nothing, + OS3Types.registerModelConnector = Nothing, + OS3Types.registerModelIsEnabled = Nothing, + OS3Types.registerModelProvisionedBy = Nothing + } + it "registerModel POSTs to /_plugins/_ml/models/_register with no deploy flag" $ do + let req = OS3Requests.registerModel reqBody + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "models", "_register"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestMethod req `shouldBe` "POST" + it "registerModelWith True attaches ?deploy=true" $ do + let req = OS3Requests.registerModelWith True reqBody + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "models", "_register"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("deploy", Just "true")] + it "registerModelWith False omits the query" $ do + let req = OS3Requests.registerModelWith False reqBody + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "attaches an encoded body" $ do + let req = OS3Requests.registerModel reqBody + bhRequestBody req `shouldSatisfy` isJust + + describe "deployModel endpoint shape (OS3)" $ do + it "POSTs to /_plugins/_ml/models/{id}/_deploy" $ do + let req = OS3Requests.deployModel (OS3Types.ModelId "m1") Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "models", "m1", "_deploy"] + bhRequestMethod req `shouldBe` "POST" + it "uses {} as the body when Nothing is supplied" $ do + let req = OS3Requests.deployModel (OS3Types.ModelId "m1") Nothing + bhRequestBody req `shouldBe` Just "{}" + it "encodes a supplied DeployModelRequest" $ do + let req = OS3Requests.deployModel (OS3Types.ModelId "m1") (Just (OS3Types.DeployModelRequest (Just ["n1"]))) + bhRequestBody req `shouldSatisfy` isJust + + describe "predict endpoint shape (OS3)" $ do + it "POSTs to /_plugins/_ml/_predict/{algo}/{id}" $ do + let req = OS3Requests.predict (OS3Types.AlgorithmName "remote") (OS3Types.ModelId "m1") (object []) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "_predict", "remote", "m1"] + bhRequestMethod req `shouldBe` "POST" + bhRequestBody req `shouldBe` Just "{}" + + describe "deleteModel endpoint shape (OS3)" $ do + it "DELETEs /_plugins/_ml/models/{id}" $ do + let req = OS3Requests.deleteModel (OS3Types.ModelId "abc123") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "models", "abc123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the DELETE method" $ do + let req = OS3Requests.deleteModel (OS3Types.ModelId "x") + bhRequestMethod req `shouldBe` "DELETE" + it "does not attach a body" $ do + let req = OS3Requests.deleteModel (OS3Types.ModelId "x") + bhRequestBody req `shouldBe` Nothing + + describe "registerAgent endpoint shape (OS3)" $ do + let agentReq = + OS3Types.RegisterAgentRequest + { OS3Types.registerAgentName = "my-conversation-agent", + OS3Types.registerAgentType = OS3Types.AgentTypeConversational, + OS3Types.registerAgentDescription = Nothing, + OS3Types.registerAgentLlm = + Just + OS3Types.LlmConfig + { OS3Types.llmConfigModelId = "gTLE_Eo=", + OS3Types.llmConfigParameters = Nothing + }, + OS3Types.registerAgentTools = Nothing, + OS3Types.registerAgentParameters = Nothing, + OS3Types.registerAgentMemory = Nothing, + OS3Types.registerAgentAppType = Nothing + } + it "POSTs to /_plugins/_ml/agents/_register" $ do + let req = OS3Requests.registerAgent agentReq + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "agents", "_register"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the POST method" $ do + let req = OS3Requests.registerAgent agentReq + bhRequestMethod req `shouldBe` "POST" + it "attaches an encoded body" $ do + let req = OS3Requests.registerAgent agentReq + bhRequestBody req `shouldSatisfy` isJust + + describe "undeployModel endpoint shape (OS3)" $ do + it "POSTs to /_plugins/_ml/models/{id}/_undeploy" $ do + let req = OS3Requests.undeployModel (OS3Types.ModelId "m1") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "models", "m1", "_undeploy"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the POST method" $ + bhRequestMethod (OS3Requests.undeployModel (OS3Types.ModelId "x")) + `shouldBe` "POST" + it "attaches an empty body" $ + bhRequestBody (OS3Requests.undeployModel (OS3Types.ModelId "x")) + `shouldBe` Just "{}" + + describe "updateModel endpoint shape (OS3)" $ do + let updReq = + OS3Types.UpdateModelRequest + { OS3Types.updateModelName = Just "n", + OS3Types.updateModelDescription = Nothing, + OS3Types.updateModelIsEnabled = Nothing, + OS3Types.updateModelGroupId = Nothing, + OS3Types.updateModelConfig = Nothing, + OS3Types.updateModelConnectorId = Nothing, + OS3Types.updateModelConnector = Nothing, + OS3Types.updateModelRateLimiter = Nothing, + OS3Types.updateModelGuardrails = Nothing, + OS3Types.updateModelInterface = Nothing + } + it "PUTs to /_plugins/_ml/models/{id}" $ do + let req = OS3Requests.updateModel (OS3Types.ModelId "m1") updReq + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "models", "m1"] + it "uses the PUT method" $ + bhRequestMethod (OS3Requests.updateModel (OS3Types.ModelId "x") updReq) + `shouldBe` "PUT" + it "attaches an encoded body" $ + bhRequestBody (OS3Requests.updateModel (OS3Types.ModelId "x") updReq) + `shouldSatisfy` isJust + + describe "searchModels endpoint shape (OS3)" $ do + it "POSTs to /_plugins/_ml/models/_search" $ do + let req = OS3Requests.searchModels Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "models", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the POST method" $ + bhRequestMethod (OS3Requests.searchModels Nothing) `shouldBe` "POST" + it "sends {} when the query is Nothing" $ + bhRequestBody (OS3Requests.searchModels Nothing) `shouldBe` Just "{}" + it "sends the encoded query when supplied" $ do + let req = OS3Requests.searchModels (Just (object ["size" .= (5 :: Int)])) + let body = LBS.toStrict <$> bhRequestBody req + body `shouldSatisfy` maybe False (BS.isInfixOf "\"size\":5") + + describe "listModels endpoint shape (OS3)" $ do + it "POSTs to /_plugins/_ml/models/_search (OS3 dropped _list)" $ do + let req = OS3Requests.listModels Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "models", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the POST method" $ + bhRequestMethod (OS3Requests.listModels Nothing) `shouldBe` "POST" + + describe "getAgent endpoint shape (OS3)" $ do + it "GETs /_plugins/_ml/agents/{id}" $ do + let req = OS3Requests.getAgent (OS3Types.AgentId "a1") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "agents", "a1"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the GET method" $ + bhRequestMethod (OS3Requests.getAgent (OS3Types.AgentId "x")) + `shouldBe` "GET" + it "does not attach a body" $ + bhRequestBody (OS3Requests.getAgent (OS3Types.AgentId "x")) + `shouldBe` Nothing + + describe "deleteAgent endpoint shape (OS3)" $ do + it "DELETEs /_plugins/_ml/agents/{id}" $ do + let req = OS3Requests.deleteAgent (OS3Types.AgentId "a1") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "agents", "a1"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the DELETE method" $ + bhRequestMethod (OS3Requests.deleteAgent (OS3Types.AgentId "x")) + `shouldBe` "DELETE" + it "does not attach a body" $ + bhRequestBody (OS3Requests.deleteAgent (OS3Types.AgentId "x")) + `shouldBe` Nothing + + describe "searchAgents endpoint shape (OS3)" $ do + it "POSTs to /_plugins/_ml/agents/_search" $ do + let req = OS3Requests.searchAgents Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "agents", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the POST method" $ + bhRequestMethod (OS3Requests.searchAgents Nothing) `shouldBe` "POST" + it "sends {} when the query is Nothing" $ + bhRequestBody (OS3Requests.searchAgents Nothing) `shouldBe` Just "{}" + + describe "updateAgent endpoint shape (OS3)" $ do + let updReq = + OS3Types.UpdateAgentRequest + { OS3Types.updateAgentName = Just "n", + OS3Types.updateAgentDescription = Nothing, + OS3Types.updateAgentTools = Nothing, + OS3Types.updateAgentAppType = Nothing, + OS3Types.updateAgentMemory = Nothing, + OS3Types.updateAgentLlm = Nothing + } + it "PUTs to /_plugins/_ml/agents/{id}" $ do + let req = OS3Requests.updateAgent (OS3Types.AgentId "a1") updReq + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "agents", "a1"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the PUT method" $ + bhRequestMethod (OS3Requests.updateAgent (OS3Types.AgentId "x") updReq) + `shouldBe` "PUT" + it "attaches an encoded body" $ + bhRequestBody (OS3Requests.updateAgent (OS3Types.AgentId "x") updReq) + `shouldSatisfy` isJust + + describe "executeAgent endpoint shape (OS3)" $ do + let execReq = + OS3Types.ExecuteAgentRequest + { OS3Types.executeAgentParameters = Just (object ["question" .= ("q" :: Text)]), + OS3Types.executeAgentInput = Nothing + } + it "POSTs to /_plugins/_ml/agents/{id}/_execute with no query" $ do + let req = OS3Requests.executeAgent (OS3Types.AgentId "a1") execReq + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "agents", "a1", "_execute"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the POST method" $ + bhRequestMethod (OS3Requests.executeAgent (OS3Types.AgentId "x") execReq) + `shouldBe` "POST" + it "attaches an encoded body" $ + bhRequestBody (OS3Requests.executeAgent (OS3Types.AgentId "x") execReq) + `shouldSatisfy` isJust + + describe "executeAgentAsync endpoint shape (OS3)" $ do + let execReq = + OS3Types.ExecuteAgentRequest + { OS3Types.executeAgentParameters = Just (object ["question" .= ("q" :: Text)]), + OS3Types.executeAgentInput = Nothing + } + it "POSTs to .../{id}/_execute with ?async=true" $ do + let req = OS3Requests.executeAgentAsync (OS3Types.AgentId "a1") execReq + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "agents", "a1", "_execute"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("async", Just "true")] + it "uses the POST method" $ + bhRequestMethod (OS3Requests.executeAgentAsync (OS3Types.AgentId "x") execReq) + `shouldBe` "POST" + + -- ========================================================================= + -- Cross-version parity (OS1 = OS2 = OS3 path shapes) + -- ========================================================================= + describe "endpoint cross-version parity (OS1/OS2/OS3)" $ do + it "OS1/OS2/OS3 build the same getModel path" $ do + let os1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.getModel (OS1Types.ModelId "z"))) + os2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.getModel (OS2Types.ModelId "z"))) + os3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.getModel (OS3Types.ModelId "z"))) + os1 `shouldBe` ["_plugins", "_ml", "models", "z"] + os2 `shouldBe` os1 + os3 `shouldBe` os1 + + it "OS2/OS3 build the same deployModel path (OS1 excluded: no register/deploy API in OS 1.3)" $ do + let os2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.deployModel (OS2Types.ModelId "z") Nothing)) + os3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.deployModel (OS3Types.ModelId "z") Nothing)) + os2 `shouldBe` ["_plugins", "_ml", "models", "z", "_deploy"] + os3 `shouldBe` os2 + + it "OS1/OS2/OS3 build the same predict path" $ do + let os1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.predict (OS1Types.AlgorithmName "remote") (OS1Types.ModelId "z") (object []))) + os2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.predict (OS2Types.AlgorithmName "remote") (OS2Types.ModelId "z") (object []))) + os3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.predict (OS3Types.AlgorithmName "remote") (OS3Types.ModelId "z") (object []))) + os1 `shouldBe` ["_plugins", "_ml", "_predict", "remote", "z"] + os2 `shouldBe` os1 + os3 `shouldBe` os1 + + it "OS1/OS2/OS3 build the same deleteModel path" $ do + let os1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.deleteModel (OS1Types.ModelId "z"))) + os2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteModel (OS2Types.ModelId "z"))) + os3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteModel (OS3Types.ModelId "z"))) + os1 `shouldBe` ["_plugins", "_ml", "models", "z"] + os2 `shouldBe` os1 + os3 `shouldBe` os1 + + it "OS2/OS3 build the same undeployModel path (OS1 excluded: no register/deploy API in OS 1.3)" $ do + let os2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.undeployModel (OS2Types.ModelId "z"))) + os3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.undeployModel (OS3Types.ModelId "z"))) + os2 `shouldBe` ["_plugins", "_ml", "models", "z", "_undeploy"] + os3 `shouldBe` os2 + + it "OS2/OS3 build the same updateModel path (OS1 excluded: no register/deploy API in OS 1.3)" $ do + let os2Req = + OS2Types.UpdateModelRequest + { OS2Types.updateModelName = Just "x", + OS2Types.updateModelDescription = Nothing, + OS2Types.updateModelIsEnabled = Nothing, + OS2Types.updateModelGroupId = Nothing, + OS2Types.updateModelConfig = Nothing, + OS2Types.updateModelConnectorId = Nothing, + OS2Types.updateModelConnector = Nothing, + OS2Types.updateModelRateLimiter = Nothing, + OS2Types.updateModelGuardrails = Nothing, + OS2Types.updateModelInterface = Nothing + } + os3Req = + OS3Types.UpdateModelRequest + { OS3Types.updateModelName = Just "x", + OS3Types.updateModelDescription = Nothing, + OS3Types.updateModelIsEnabled = Nothing, + OS3Types.updateModelGroupId = Nothing, + OS3Types.updateModelConfig = Nothing, + OS3Types.updateModelConnectorId = Nothing, + OS3Types.updateModelConnector = Nothing, + OS3Types.updateModelRateLimiter = Nothing, + OS3Types.updateModelGuardrails = Nothing, + OS3Types.updateModelInterface = Nothing + } + path2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.updateModel (OS2Types.ModelId "z") os2Req)) + path3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.updateModel (OS3Types.ModelId "z") os3Req)) + path2 `shouldBe` ["_plugins", "_ml", "models", "z"] + path3 `shouldBe` path2 + + it "OS1/OS2/OS3 build the same searchModels path" $ do + let os1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.searchModels Nothing)) + os2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.searchModels Nothing)) + os3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.searchModels Nothing)) + os1 `shouldBe` ["_plugins", "_ml", "models", "_search"] + os2 `shouldBe` os1 + os3 `shouldBe` os1 + + it "all backends hit _search for listModels (documented endpoint)" $ do + -- The @_list@ path was never documented for ML Commons; OS 2.x + -- removed POST from it (HTTP 405). The supported listing endpoint + -- across all versions is @_search@. + let os1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.listModels Nothing)) + os2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.listModels Nothing)) + os3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.listModels Nothing)) + os1 `shouldBe` ["_plugins", "_ml", "models", "_search"] + os2 `shouldBe` os1 + os3 `shouldBe` os1 + + it "OS2/OS3 build the same getAgent path (OS1 excluded: no ML agents)" $ do + let os2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.getAgent (OS2Types.AgentId "z"))) + os3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.getAgent (OS3Types.AgentId "z"))) + os2 `shouldBe` ["_plugins", "_ml", "agents", "z"] + os3 `shouldBe` os2 + + it "OS2/OS3 build the same deleteAgent path (OS1 excluded: no ML agents)" $ do + let os2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteAgent (OS2Types.AgentId "z"))) + os3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteAgent (OS3Types.AgentId "z"))) + os2 `shouldBe` ["_plugins", "_ml", "agents", "z"] + os3 `shouldBe` os2 + + it "OS2/OS3 build the same searchAgents path (OS1 excluded: no ML agents)" $ do + let os2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.searchAgents Nothing)) + os3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.searchAgents Nothing)) + os2 `shouldBe` ["_plugins", "_ml", "agents", "_search"] + os3 `shouldBe` os2 + + it "OS2/OS3 build the same executeAgent path (OS1 excluded: no ML agents)" $ do + let os2Req = + OS2Types.ExecuteAgentRequest + { OS2Types.executeAgentParameters = Nothing, + OS2Types.executeAgentInput = Nothing + } + os3Req = + OS3Types.ExecuteAgentRequest + { OS3Types.executeAgentParameters = Nothing, + OS3Types.executeAgentInput = Nothing + } + os2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.executeAgent (OS2Types.AgentId "z") os2Req)) + os3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.executeAgent (OS3Types.AgentId "z") os3Req)) + os2 `shouldBe` ["_plugins", "_ml", "agents", "z", "_execute"] + os3 `shouldBe` os2 + + it "OS2/OS3 build the same registerModel path and ?deploy=true query (OS1 excluded: no register/deploy API in OS 1.3)" $ do + let os2Req = + OS2Types.RegisterModelRequest + { OS2Types.registerModelName = "x", + OS2Types.registerModelVersion = Nothing, + OS2Types.registerModelDescription = Nothing, + OS2Types.registerModelFormat = Nothing, + OS2Types.registerModelFunctionName = Nothing, + OS2Types.registerModelContentHashValue = Nothing, + OS2Types.registerModelConfig = Nothing, + OS2Types.registerModelUrl = Nothing, + OS2Types.registerModelGroupId = Nothing, + OS2Types.registerModelConnectorId = Nothing, + OS2Types.registerModelConnector = Nothing, + OS2Types.registerModelIsEnabled = Nothing + } + os3Req = + OS3Types.RegisterModelRequest + { OS3Types.registerModelName = "x", + OS3Types.registerModelVersion = Nothing, + OS3Types.registerModelDescription = Nothing, + OS3Types.registerModelFormat = Nothing, + OS3Types.registerModelFunctionName = Nothing, + OS3Types.registerModelContentHashValue = Nothing, + OS3Types.registerModelConfig = Nothing, + OS3Types.registerModelUrl = Nothing, + OS3Types.registerModelGroupId = Nothing, + OS3Types.registerModelConnectorId = Nothing, + OS3Types.registerModelConnector = Nothing, + OS3Types.registerModelIsEnabled = Nothing + } + path2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.registerModel os2Req)) + path3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.registerModel os3Req)) + q2 = getRawEndpointQueries (bhRequestEndpoint (OS2Requests.registerModelWith True os2Req)) + q3 = getRawEndpointQueries (bhRequestEndpoint (OS3Requests.registerModelWith True os3Req)) + path2 `shouldBe` ["_plugins", "_ml", "models", "_register"] + path3 `shouldBe` path2 + q2 `shouldBe` [("deploy", Just "true")] + q3 `shouldBe` q2 + + it "OS2/OS3 build the same registerAgent path (OS1 excluded: agents shipped in OS 2.12)" $ do + let os2Req = + OS2Types.RegisterAgentRequest + { OS2Types.registerAgentName = "x", + OS2Types.registerAgentType = OS2Types.AgentTypeFlow, + OS2Types.registerAgentDescription = Nothing, + OS2Types.registerAgentLlm = Nothing, + OS2Types.registerAgentTools = Nothing, + OS2Types.registerAgentParameters = Nothing, + OS2Types.registerAgentMemory = Nothing, + OS2Types.registerAgentAppType = Nothing + } + os3Req = + OS3Types.RegisterAgentRequest + { OS3Types.registerAgentName = "x", + OS3Types.registerAgentType = OS3Types.AgentTypeFlow, + OS3Types.registerAgentDescription = Nothing, + OS3Types.registerAgentLlm = Nothing, + OS3Types.registerAgentTools = Nothing, + OS3Types.registerAgentParameters = Nothing, + OS3Types.registerAgentMemory = Nothing, + OS3Types.registerAgentAppType = Nothing + } + path2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.registerAgent os2Req)) + path3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.registerAgent os3Req)) + path2 `shouldBe` ["_plugins", "_ml", "agents", "_register"] + path3 `shouldBe` path2 + + -- ========================================================================= + -- Live integration tests (OS3 only; OS1/OS2 share identical code paths) + -- + -- Strategy: hit each endpoint with a non-existent model id and assert + -- @Left EsError@ (HTTP 4xx). This deterministically proves the endpoint + -- path, method, request body shape, and error decoder are correct + -- without depending on async task completion or a real model fixture. + -- registerModel is the exception: a syntactically valid body returns + -- @Right MLTaskAck@ synchronously (the async outcome is irrelevant). + -- + -- Note on state: registerModel registers a model metadata entry on the + -- cluster. The entry may be torn down via 'deleteModel' once undeployed; + -- tests that only need a 404 use a non-existent id to avoid touching + -- cluster state. Long-term accumulation from any untorn-down entries is + -- recoverable via @make compose-detach-down@ which clears the docker + -- volume. + -- ========================================================================= + describe "ML Model API live integration" $ do + os3It <- runIO os3OnlyIT + + os3It "getModel on a non-existent id returns Left (404)" $ + withTestEnv $ do + resp <- OS3Client.getModel (OS3Types.ModelId "bloodhound-nonexistent-model-id") + liftIO $ + case resp of + Left _ -> pure () + Right r -> + expectationFailure ("Expected Left for non-existent id, got Right: " <> show r) + + os3It "registerModel returns a task_id synchronously" $ + withTestEnv $ do + -- ML Commons refuses registration when only_run_on_ml_node is + -- true and no dedicated ML node is provisioned; relax it so the + -- endpoint is exercised regardless of cluster topology. + let mlSettings :: HashMap Text Value + mlSettings = HashMap.fromList [("plugins.ml_commons.only_run_on_ml_node", Bool False)] + _ <- + performBHRequest $ + updateClusterSettings + defaultClusterSettingsUpdate + { clusterSettingsUpdatePersistent = Just mlSettings + } + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let req = + OS3Types.RegisterModelRequest + { OS3Types.registerModelName = Text.pack ("bloodhound-test-reg-" <> suffix), + OS3Types.registerModelVersion = Just "1.0.0", + OS3Types.registerModelDescription = Nothing, + OS3Types.registerModelFormat = Just OS3Types.ModelFormatTorchScript, + OS3Types.registerModelFunctionName = Nothing, + OS3Types.registerModelContentHashValue = Nothing, + OS3Types.registerModelConfig = Nothing, + OS3Types.registerModelUrl = Nothing, + OS3Types.registerModelGroupId = Nothing, + OS3Types.registerModelConnectorId = Nothing, + OS3Types.registerModelConnector = Nothing, + OS3Types.registerModelIsEnabled = Nothing, + OS3Types.registerModelProvisionedBy = Nothing + } + resp <- OS3Client.registerModel req + liftIO $ + case resp of + Left e -> + expectationFailure ("Expected Right MLTaskAck, got Left: " <> show e) + Right ack -> + OS3Types.mlTaskAckTaskId ack `shouldSatisfy` isJust + + os3It "deployModel on a non-existent id returns Left" $ + withTestEnv $ do + resp <- OS3Client.deployModel (OS3Types.ModelId "bloodhound-nonexistent-model-id") Nothing + liftIO $ + case resp of + Left _ -> pure () + Right r -> + expectationFailure ("Expected Left for non-existent id, got Right: " <> show r) + + os3It "predict on a non-existent id returns Left" $ + withTestEnv $ do + resp <- + OS3Client.predict + (OS3Types.AlgorithmName "remote") + (OS3Types.ModelId "bloodhound-nonexistent-model-id") + (object ["parameters" .= object []]) + liftIO $ + case resp of + Left _ -> pure () + Right r -> + expectationFailure ("Expected Left for non-existent id, got Right: " <> show r) + + os3It "deleteModel on a non-existent id returns Left (404)" $ + withTestEnv $ do + resp <- OS3Client.deleteModel (OS3Types.ModelId "bloodhound-nonexistent-model-id") + liftIO $ + case resp of + Left _ -> pure () + Right r -> + expectationFailure ("Expected Left for non-existent id, got Right: " <> show r) + + os3It "undeployModel on a non-existent id returns Left" $ + withTestEnv $ do + resp <- OS3Client.undeployModel (OS3Types.ModelId "bloodhound-nonexistent-model-id") + liftIO $ + case resp of + Left _ -> pure () + Right r -> + expectationFailure ("Expected Left for non-existent id, got Right: " <> show r) + + os3It "updateModel on a non-existent id returns Left (404)" $ + withTestEnv $ do + let updReq = + OS3Types.UpdateModelRequest + { OS3Types.updateModelName = Just "bloodhound-test-updated", + OS3Types.updateModelDescription = Nothing, + OS3Types.updateModelIsEnabled = Nothing, + OS3Types.updateModelGroupId = Nothing, + OS3Types.updateModelConfig = Nothing, + OS3Types.updateModelConnectorId = Nothing, + OS3Types.updateModelConnector = Nothing, + OS3Types.updateModelRateLimiter = Nothing, + OS3Types.updateModelGuardrails = Nothing, + OS3Types.updateModelInterface = Nothing + } + resp <- OS3Client.updateModel (OS3Types.ModelId "bloodhound-nonexistent-model-id") updReq + liftIO $ + case resp of + Left _ -> pure () + Right r -> + expectationFailure ("Expected Left for non-existent id, got Right: " <> show r) + + os3It "searchModels returns a Right envelope on an empty cluster" $ + withTestEnv $ do + resp <- OS3Client.searchModels Nothing + liftIO $ + case resp of + Left e -> + expectationFailure ("Expected Right ModelSearchResponse, got Left: " <> show e) + Right _ -> pure () + + os3It "listModels returns a Right envelope on an empty cluster" $ + withTestEnv $ do + resp <- OS3Client.listModels Nothing + liftIO $ + case resp of + Left e -> + expectationFailure ("Expected Right ModelSearchResponse, got Left: " <> show e) + Right _ -> pure () + + os3It "getAgent on a non-existent id returns Left (404)" $ + withTestEnv $ do + resp <- OS3Client.getAgent (OS3Types.AgentId "bloodhound-nonexistent-agent-id") + liftIO $ + case resp of + Left _ -> pure () + Right r -> + expectationFailure ("Expected Left for non-existent id, got Right: " <> show r) + + os3It "deleteAgent on a non-existent id returns Left (404)" $ + withTestEnv $ do + resp <- OS3Client.deleteAgent (OS3Types.AgentId "bloodhound-nonexistent-agent-id") + liftIO $ + case resp of + Left _ -> pure () + Right r -> + expectationFailure ("Expected Left for non-existent id, got Right: " <> show r) + + os3It "searchAgents returns a Right envelope on an empty cluster" $ + withTestEnv $ do + resp <- OS3Client.searchAgents Nothing + liftIO $ + case resp of + Left e -> + expectationFailure ("Expected Right AgentSearchResponse, got Left: " <> show e) + Right _ -> pure () diff --git a/tests/Test/MLProfileSpec.hs b/tests/Test/MLProfileSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MLProfileSpec.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MLProfileSpec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Map.Strict qualified as M +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- | A profile response with two nodes, one carrying full per-model stats +-- and the other a bare worker_nodes routing entry. Drawn from the shape +-- documented at . +sampleProfileResponse :: LBS.ByteString +sampleProfileResponse = + "{\ + \ \"nodes\": {\ + \ \"qTduw0FJTrmGrqMrxH0dcA\": {\ + \ \"models\": {\ + \ \"WWQI44MBbzI2oUKAvNUt\": {\"worker_nodes\": [\"KzONM8c8T4Od-NoUANQNGg\"]}\ + \ }\ + \ },\ + \ \"KzONM8c8T4Od-NoUANQNGg\": {\ + \ \"models\": {\ + \ \"WWQI44MBbzI2oUKAvNUt\": {\ + \ \"model_state\": \"DEPLOYED\",\ + \ \"predictor\": \"org.opensearch.ml.engine.algorithms.text_embedding.TextEmbeddingModel@592814c9\",\ + \ \"worker_nodes\": [\"KzONM8c8T4Od-NoUANQNGg\"],\ + \ \"predict_request_stats\": {\ + \ \"count\": 2,\ + \ \"max\": 89.978681,\ + \ \"min\": 5.402,\ + \ \"average\": 47.6903405,\ + \ \"p50\": 47.6903405,\ + \ \"p90\": 81.5210129,\ + \ \"p99\": 89.13291418999998\ + \ }\ + \ }\ + \ }\ + \ }\ + \ }\ + \}" + +spec :: Spec +spec = describe "ML Commons profile API" $ do + describe "MLProfileResponse" $ do + it "decodes the doc sample (two nodes, one with full predict stats)" $ do + let decoded = decode sampleProfileResponse :: Maybe MLProfileResponse + case decoded of + Just resp -> do + -- Two nodes in the envelope. + length (mlProfileResponseNodes resp) `shouldBe` 2 + -- The fully-populated node's model should report DEPLOYED and a count of 2. + let nodes = M.elems (mlProfileResponseNodes resp) + deployedModels = + [ m + | n <- nodes, + m <- M.elems (mlProfileNodeModels n), + mlProfileModelModelState m == Just ModelStateDeployed + ] + case deployedModels of + (m : _) -> + (mlProfileModelPredictRequestStats m >>= mlProfileStatsCount) + `shouldBe` Just 2 + [] -> expectationFailure "expected a DEPLOYED model profile" + Nothing -> expectationFailure "expected MLProfileResponse decode" + + it "decodes an empty envelope" $ + decode "{\"nodes\":{}}" `shouldBe` Just (MLProfileResponse {mlProfileResponseNodes = M.empty}) + + describe "MLProfileModel" $ + it "round-trips a model with stats" $ do + let m = + MLProfileModel + { mlProfileModelModelState = Just ModelStateDeployed, + mlProfileModelPredictor = Just "cls@1", + mlProfileModelWorkerNodes = Just ["n1"], + mlProfileModelPredictRequestStats = + Just + MLProfilePredictRequestStats + { mlProfileStatsCount = Just 1, + mlProfileStatsMax = Just 1.0, + mlProfileStatsMin = Just 1.0, + mlProfileStatsAverage = Just 1.0, + mlProfileStatsP50 = Just 1.0, + mlProfileStatsP90 = Just 1.0, + mlProfileStatsP99 = Just 1.0 + } + } + decode (encode m) `shouldBe` Just m + + describe "MLProfileRequest" $ + it "encodes only the supplied filters" $ do + let req = + MLProfileRequest + { mlProfileRequestNodeIds = Just ["KzONM8c8T4Od-NoUANQNGg"], + mlProfileRequestModelIds = Nothing, + mlProfileRequestTaskIds = Nothing, + mlProfileRequestReturnAllTasks = Just True, + mlProfileRequestReturnAllModels = Just True + } + encode req + `shouldBe` "{\"node_ids\":[\"KzONM8c8T4Od-NoUANQNGg\"],\"return_all_models\":true,\"return_all_tasks\":true}" diff --git a/tests/Test/MLStatsSpec.hs b/tests/Test/MLStatsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MLStatsSpec.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MLStatsSpec (spec) where + +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Map.Strict qualified as Map +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch1.Types qualified as OS1Types +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2Types +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- | The canonical ML Commons stats response: cluster-level scalars at the +-- top level (one key per cluster stat) plus a @nodes@ object whose value is +-- a map keyed by opaque node ID. Drawn from the documented example shape in +-- the ML Commons plugin source (RestMLStatsAction + MLNodeLevelStat + +-- MLClusterLevelStat). Stat values are arbitrary nested JSON; we +-- deliberately round-trip them as 'Value' rather than modelling individual +-- stats, since the stat-name set is plugin-version dependent. +sampleFullResponse :: LBS.ByteString +sampleFullResponse = + "{\ + \ \"ml_task_index_status\": \"non-existent\",\ + \ \"ml_connector_count\": 2,\ + \ \"ml_config_index_status\": \"green\",\ + \ \"ml_controller_index_status\": \"non-existent\",\ + \ \"ml_model_index_status\": \"non-existent\",\ + \ \"ml_connector_index_status\": \"non-existent\",\ + \ \"ml_model_count\": 5,\ + \ \"nodes\": {\ + \ \"zbduvgCCSOeu6cfbQhTpnQ\": {\ + \ \"ml_executing_task_count\": 0,\ + \ \"ml_request_count\": 12,\ + \ \"ml_failure_count\": 1,\ + \ \"ml_jvm_heap_usage\": 0,\ + \ \"ml_deployed_model_count\": 2,\ + \ \"ml_circuit_breaker_trigger_count\": 0\ + \ },\ + \ \"54xOe0w8Qjyze00UuLDfdA\": {\ + \ \"ml_executing_task_count\": 1,\ + \ \"ml_request_count\": 30,\ + \ \"ml_failure_count\": 0,\ + \ \"ml_jvm_heap_usage\": 1048576,\ + \ \"ml_deployed_model_count\": 2,\ + \ \"ml_circuit_breaker_trigger_count\": 0\ + \ }\ + \ }\ + \}" + +-- | A nodes-only response, as returned when a node-level @stat@ filter is +-- supplied (e.g. @GET /_plugins/_ml/stats/ml_executing_task_count@). The +-- cluster-level stats are omitted because the filter restricts to node-level +-- values; the decoder must accept their absence. +sampleNodesOnlyResponse :: LBS.ByteString +sampleNodesOnlyResponse = + "{\ + \ \"nodes\": {\ + \ \"zbduvgCCSOeu6cfbQhTpnQ\": {\ + \ \"ml_executing_task_count\": 0\ + \ }\ + \ }\ + \}" + +spec :: Spec +spec = describe "ML Stats API" $ do + describe "MLNodeId / MLStatName JSON" $ do + it "MLNodeId round-trips as a bare JSON string" $ do + encode (MLNodeId "node-id-22-chars-000") `shouldBe` "\"node-id-22-chars-000\"" + decode "\"abc\"" `shouldBe` Just (MLNodeId "abc") + + it "MLStatName round-trips as a bare JSON string" $ do + encode (MLStatName "ml_executing_task_count") + `shouldBe` "\"ml_executing_task_count\"" + decode "\"ml_request_count\"" + `shouldBe` Just (MLStatName "ml_request_count") + + describe "MLStats JSON" $ do + it "decodes a full response with cluster stats and a nodes map" $ do + let Just decoded = decode sampleFullResponse :: Maybe MLStats + entries = mlStatsEntries decoded + -- 7 cluster-level keys + 1 "nodes" key. + Map.size entries `shouldBe` 8 + Map.member "nodes" entries `shouldBe` True + Map.member "ml_model_count" entries `shouldBe` True + Map.member "ml_connector_count" entries `shouldBe` True + Map.member "ml_model_index_status" entries `shouldBe` True + + it "preserves cluster-level scalars as bare aeson Values" $ do + let Just decoded = decode sampleFullResponse :: Maybe MLStats + entries = mlStatsEntries decoded + Map.lookup "ml_model_count" entries `shouldBe` Just (toJSON (5 :: Int)) + Map.lookup "ml_connector_count" entries `shouldBe` Just (toJSON (2 :: Int)) + Map.lookup "ml_model_index_status" entries + `shouldBe` Just (toJSON ("non-existent" :: Text)) + Map.lookup "ml_config_index_status" entries + `shouldBe` Just (toJSON ("green" :: Text)) + + it "preserves the per-node map under the \"nodes\" key as an aeson Value" $ do + let Just decoded = decode sampleFullResponse :: Maybe MLStats + Just (Object nodesObj) = Map.lookup "nodes" (mlStatsEntries decoded) + -- The Value's KeyMap should contain both node IDs. + nodeIds = [k | (k, _) <- KM.toList nodesObj] + length nodeIds `shouldBe` 2 + "zbduvgCCSOeu6cfbQhTpnQ" `elem` nodeIds `shouldBe` True + "54xOe0w8Qjyze00UuLDfdA" `elem` nodeIds `shouldBe` True + + it "decodes the per-node body of a specific node" $ do + let Just decoded = decode sampleFullResponse :: Maybe MLStats + Just (Object nodesObj) = Map.lookup "nodes" (mlStatsEntries decoded) + Just nodeBody = KM.lookup "zbduvgCCSOeu6cfbQhTpnQ" nodesObj + nodeBody + `shouldBe` object + [ "ml_executing_task_count" .= (0 :: Int), + "ml_request_count" .= (12 :: Int), + "ml_failure_count" .= (1 :: Int), + "ml_jvm_heap_usage" .= (0 :: Int), + "ml_deployed_model_count" .= (2 :: Int), + "ml_circuit_breaker_trigger_count" .= (0 :: Int) + ] + + it "decodes a nodes-only response (cluster stats absent)" $ do + let Just decoded = decode sampleNodesOnlyResponse :: Maybe MLStats + entries = mlStatsEntries decoded + Map.size entries `shouldBe` 1 + Map.member "nodes" entries `shouldBe` True + -- None of the cluster-level keys are present. + Map.member "ml_model_count" entries `shouldBe` False + + it "decodes an empty object as an empty map" $ do + let Just decoded = decode "{}" :: Maybe MLStats + mlStatsEntries decoded `shouldBe` Map.empty + + it "decodes an empty nodes map as an Object with no entries" $ do + let Just decoded = decode "{ \"nodes\": {} }" :: Maybe MLStats + Just (Object nodesObj) = Map.lookup "nodes" (mlStatsEntries decoded) + KM.null nodesObj `shouldBe` True + + it "rejects a top-level null" $ do + let decoded = decode "null" :: Maybe MLStats + decoded `shouldBe` Nothing + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe MLStats + decoded `shouldBe` Nothing + + it "rejects a top-level scalar" $ do + let decoded = decode "42" :: Maybe MLStats + decoded `shouldBe` Nothing + + it "rejects malformed JSON" $ do + let decoded = decode "{ not json" :: Maybe MLStats + decoded `shouldBe` Nothing + + -- Lenient contract: the flat-Map decoder does NOT validate the shape of + -- the @nodes@ value (it is just another entry in the map). This test + -- pins the current behaviour so any future tightening of the decoder is + -- a deliberate, breaking change rather than a silent one. + it "accepts a non-object nodes value (lenient contract — pinned)" $ do + let Just decoded = decode "{ \"nodes\": \"unexpected\" }" :: Maybe MLStats + Map.lookup "nodes" (mlStatsEntries decoded) + `shouldBe` Just (toJSON ("unexpected" :: Text)) + + it "round-trips a full response through ToJSON/FromJSON" $ do + let Just decoded = decode sampleFullResponse :: Maybe MLStats + (decode . encode) decoded `shouldBe` Just decoded + + it "round-trips a nodes-only response through ToJSON/FromJSON" $ do + let Just decoded = decode sampleNodesOnlyResponse :: Maybe MLStats + (decode . encode) decoded `shouldBe` Just decoded + + it "ToJSON emits both cluster and nodes keys" $ do + let Just decoded = decode sampleFullResponse :: Maybe MLStats + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` BS.isInfixOf "\"nodes\"" + encoded `shouldSatisfy` BS.isInfixOf "\"ml_model_count\"" + encoded `shouldSatisfy` BS.isInfixOf "\"zbduvgCCSOeu6cfbQhTpnQ\"" + + describe "getMLStats endpoint shape (OS3)" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "GETs /_plugins/_ml/stats when given Nothing/Nothing" $ do + let req = OS3Requests.getMLStats Nothing Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_plugins/_ml/stats/{stat} when only the stat name is set" $ do + let req = + OS3Requests.getMLStats + Nothing + (Just (MLStatName "ml_executing_task_count")) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "stats", "ml_executing_task_count"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_plugins/_ml/{nodeId}/stats when only the node id is set" $ do + let req = + OS3Requests.getMLStats + (Just (MLNodeId "node-id-22-chars-000")) + Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "node-id-22-chars-000", "stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_plugins/_ml/{nodeId}/stats/{stat} when both are set" $ do + let req = + OS3Requests.getMLStats + (Just (MLNodeId "node-id-22-chars-000")) + (Just (MLStatName "ml_request_count")) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [ "_plugins", + "_ml", + "node-id-22-chars-000", + "stats", + "ml_request_count" + ] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the GET method" $ do + let req = OS3Requests.getMLStats Nothing Nothing + bhRequestMethod req `shouldBe` "GET" + + it "does not attach a body (GET semantics)" $ do + let req = OS3Requests.getMLStats Nothing Nothing + bhRequestBody req `shouldBe` Nothing + + describe "getMLStats cross-version parity (OS1/OS2/OS3)" $ do + -- All three backend versions share the same path shape; this guards + -- against accidental module-name typos when back-porting. Each version + -- has its own @MLNodeId@ \/ @MLStatName@ newtype (they are deliberately + -- distinct at the type level even though they share a name and shape), + -- so the per-version values are constructed against the matching module. + let expectedBoth = + [ "_plugins", + "_ml", + "node-id-22-chars-000", + "stats", + "ml_executing_task_count" + ] + + it "OS1 builds the same /_plugins/_ml/stats path as OS3" $ do + getRawEndpoint + (bhRequestEndpoint (OS1Requests.getMLStats Nothing Nothing)) + `shouldBe` ["_plugins", "_ml", "stats"] + + it "OS2 builds the same /_plugins/_ml/stats path as OS3" $ do + getRawEndpoint + (bhRequestEndpoint (OS2Requests.getMLStats Nothing Nothing)) + `shouldBe` ["_plugins", "_ml", "stats"] + + it "OS1 builds the same {nodeId}/stats/{stat} path as OS3" $ do + getRawEndpoint + ( bhRequestEndpoint + ( OS1Requests.getMLStats + (Just (OS1Types.MLNodeId "node-id-22-chars-000")) + (Just (OS1Types.MLStatName "ml_executing_task_count")) + ) + ) + `shouldBe` expectedBoth + + it "OS2 builds the same {nodeId}/stats/{stat} path as OS3" $ do + getRawEndpoint + ( bhRequestEndpoint + ( OS2Requests.getMLStats + (Just (OS2Types.MLNodeId "node-id-22-chars-000")) + (Just (OS2Types.MLStatName "ml_executing_task_count")) + ) + ) + `shouldBe` expectedBoth diff --git a/tests/Test/MLTaskSpec.hs b/tests/Test/MLTaskSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MLTaskSpec.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MLTaskSpec (spec) where + +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch1.Types qualified as OS1Types +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2Types +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- | A representative response body for @GET /_plugins/_ml/tasks/{task_id}@ +-- after a successful model registration. Drawn from the shape documented at +-- . +sampleRegisterCompleted :: LBS.ByteString +sampleRegisterCompleted = + "{\ + \ \"task_id\": \"ew8I44MBhyWuIwnfvDIH\",\ + \ \"model_id\": \"d-MCYeIBUTn_O1uORDWuDw\",\ + \ \"task_type\": \"REGISTER_MODEL\",\ + \ \"function_name\": \"TEXT_EMBEDDING\",\ + \ \"state\": \"COMPLETED\",\ + \ \"worker_node\": [\"KzwtsZ7ySdeg1GqYuISPjg\"],\ + \ \"create_time\": 1704110400000,\ + \ \"last_update_time\": 1704110460000,\ + \ \"is_async\": true\ + \}" + +-- | A @CREATED@ task that has not started running yet: no @last_update_time@, +-- no @worker_node@. Exercises the all-'Maybe' record's tolerance for the +-- sparse fields the plugin emits early in the lifecycle. +sampleCreatedSparse :: LBS.ByteString +sampleCreatedSparse = + "{\ + \ \"task_id\": \"ew8I44MBhyWuIwnfvDIH\",\ + \ \"model_id\": \"d-MCYeIBUTn_O1uORDWuDw\",\ + \ \"task_type\": \"DEPLOY_MODEL\",\ + \ \"state\": \"CREATED\",\ + \ \"create_time\": 1704110400000,\ + \ \"is_async\": true\ + \}" + +-- | A @FAILED@ task carries an @error@ string instead of a @worker_node@ +-- list. Exercises the @error@ field plus an unrelated field (@model_id@) +-- being absent. +sampleFailed :: LBS.ByteString +sampleFailed = + "{\ + \ \"task_type\": \"DEPLOY_MODEL\",\ + \ \"state\": \"FAILED\",\ + \ \"error\": \"node memory constraints prevented deployment\"\ + \}" + +-- | OS 1.x emits @worker_node@ as a bare string rather than an array. The +-- 'FromJSON' instance must coerce this into a one-element list so the same +-- client works against every backend version. +sampleWorkerNodeString :: LBS.ByteString +sampleWorkerNodeString = + "{\ + \ \"task_type\": \"REGISTER_MODEL\",\ + \ \"state\": \"RUNNING\",\ + \ \"worker_node\": \"KzwtsZ7ySdeg1GqYuISPjg\"\ + \}" + +-- | A response with @state: NOT_FOUND@ — the plugin emits this when the +-- supplied task id has been cleaned up. No @task_type@, no @model_id@. +sampleNotFound :: LBS.ByteString +sampleNotFound = + "{\ + \ \"state\": \"NOT_FOUND\"\ + \}" + +spec :: Spec +spec = describe "ML Commons Get Task API" $ do + describe "MLTaskId JSON" $ do + it "MLTaskId round-trips as a bare JSON string" $ do + encode (MLTaskId "task-xyz-123") `shouldBe` "\"task-xyz-123\"" + decode "\"abc\"" `shouldBe` Just (MLTaskId "abc") + + describe "MLTaskType JSON" $ do + it "decodes known task_type values" $ do + decode "\"REGISTER_MODEL\"" `shouldBe` Just MLTaskTypeRegisterModel + decode "\"DEPLOY_MODEL\"" `shouldBe` Just MLTaskTypeDeployModel + decode "\"TRAINING\"" `shouldBe` Just MLTaskTypeTraining + decode "\"REGISTER_REMOTE_MODEL\"" `shouldBe` Just MLTaskTypeRegisterRemoteModel + decode "\"DEPLOY_REMOTE_MODEL\"" `shouldBe` Just MLTaskTypeDeployRemoteModel + + it "round-trips known values through ToJSON/FromJSON" $ do + encode MLTaskTypeRegisterModel `shouldBe` "\"REGISTER_MODEL\"" + encode MLTaskTypeDeployModel `shouldBe` "\"DEPLOY_MODEL\"" + + it "decodes unknown values to MLTaskTypeOther without failing" $ do + let Just decoded = decode "\"SOMETHING_NEW_IN_OS4\"" :: Maybe MLTaskType + decoded `shouldBe` MLTaskTypeOther "SOMETHING_NEW_IN_OS4" + (decode . encode) decoded `shouldBe` Just decoded + + it "rejects non-string task_type values" $ do + (decode "42" :: Maybe MLTaskType) `shouldBe` Nothing + (decode "{}" :: Maybe MLTaskType) `shouldBe` Nothing + + describe "MLTaskState JSON" $ do + it "decodes known state values" $ do + decode "\"CREATED\"" `shouldBe` Just MLTaskStateCreated + decode "\"RUNNING\"" `shouldBe` Just MLTaskStateRunning + decode "\"COMPLETED\"" `shouldBe` Just MLTaskStateCompleted + decode "\"FAILED\"" `shouldBe` Just MLTaskStateFailed + decode "\"NOT_FOUND\"" `shouldBe` Just MLTaskStateNotFound + + it "round-trips known values through ToJSON/FromJSON" $ do + encode MLTaskStateCreated `shouldBe` "\"CREATED\"" + encode MLTaskStateFailed `shouldBe` "\"FAILED\"" + + it "decodes unknown values to MLTaskStateOther without failing" $ do + let Just decoded = decode "\"CANCELLED\"" :: Maybe MLTaskState + decoded `shouldBe` MLTaskStateOther "CANCELLED" + (decode . encode) decoded `shouldBe` Just decoded + + it "rejects non-string state values" $ do + (decode "42" :: Maybe MLTaskState) `shouldBe` Nothing + (decode "[]" :: Maybe MLTaskState) `shouldBe` Nothing + + describe "MLTaskInfo decode" $ do + it "decodes a fully-populated REGISTER_MODEL/COMPLETED response" $ do + let Just decoded = decode sampleRegisterCompleted :: Maybe MLTaskInfo + mlTaskInfoTaskId decoded `shouldBe` Just "ew8I44MBhyWuIwnfvDIH" + mlTaskInfoModelId decoded `shouldBe` Just "d-MCYeIBUTn_O1uORDWuDw" + mlTaskInfoTaskType decoded `shouldBe` Just MLTaskTypeRegisterModel + mlTaskInfoFunctionName decoded `shouldBe` Just "TEXT_EMBEDDING" + mlTaskInfoState decoded `shouldBe` Just MLTaskStateCompleted + mlTaskInfoWorkerNode decoded `shouldBe` Just ["KzwtsZ7ySdeg1GqYuISPjg"] + mlTaskInfoCreateTime decoded `shouldBe` Just 1704110400000 + mlTaskInfoLastUpdateTime decoded `shouldBe` Just 1704110460000 + mlTaskInfoIsAsync decoded `shouldBe` Just True + mlTaskInfoError decoded `shouldBe` Nothing + + it "decodes a sparse CREATED response (absent fields become Nothing)" $ do + let Just decoded = decode sampleCreatedSparse :: Maybe MLTaskInfo + mlTaskInfoTaskId decoded `shouldBe` Just "ew8I44MBhyWuIwnfvDIH" + mlTaskInfoCreateTime decoded `shouldBe` Just 1704110400000 + mlTaskInfoLastUpdateTime decoded `shouldBe` Nothing + mlTaskInfoWorkerNode decoded `shouldBe` Nothing + mlTaskInfoError decoded `shouldBe` Nothing + mlTaskInfoState decoded `shouldBe` Just MLTaskStateCreated + + it "decodes a FAILED response carrying an error string" $ do + let Just decoded = decode sampleFailed :: Maybe MLTaskInfo + mlTaskInfoState decoded `shouldBe` Just MLTaskStateFailed + mlTaskInfoError decoded `shouldBe` Just "node memory constraints prevented deployment" + mlTaskInfoModelId decoded `shouldBe` Nothing + + it "coerces a single-string worker_node (OS 1.x shape) to a one-element list" $ do + let Just decoded = decode sampleWorkerNodeString :: Maybe MLTaskInfo + mlTaskInfoWorkerNode decoded `shouldBe` Just ["KzwtsZ7ySdeg1GqYuISPjg"] + + -- The tolerant worker_node parser silently shapes unexpected inputs into + -- the closest safe value rather than failing the record decode. These + -- three tests pin the chosen behaviour so a future tightening (or + -- loosening) of the parser is a deliberate decision rather than an + -- accidental side effect of a refactor. + it "decodes an empty worker_node array as Just [] (empty list, not Nothing)" $ do + let Just decoded = decode "{\"worker_node\":[]}" :: Maybe MLTaskInfo + mlTaskInfoWorkerNode decoded `shouldBe` Just ([] :: [Text]) + + it "silently drops non-String elements inside a worker_node array" $ do + -- OpenSearch never emits this, but the parser uses a list comprehension + -- @String t <- toList xs@ that filters rather than fails. Pin the + -- behaviour: the malformed element disappears and the rest survive. + let Just decoded = decode "{\"worker_node\":[\"ok\", 42, \"also-ok\"]}" :: Maybe MLTaskInfo + mlTaskInfoWorkerNode decoded `shouldBe` Just ["ok", "also-ok"] + + it "coerces an unexpected worker_node shape (object) to Nothing" $ do + -- The catch-all @Just _ -> Nothing@ arm. If OpenSearch ever ships a + -- third shape, the field is silently absent rather than failing the + -- whole decode. + let Just decoded = decode "{\"worker_node\":{\"id\":\"x\"}}" :: Maybe MLTaskInfo + mlTaskInfoWorkerNode decoded `shouldBe` Nothing + + it "decodes a NOT_FOUND response with only the state field" $ do + let Just decoded = decode sampleNotFound :: Maybe MLTaskInfo + mlTaskInfoState decoded `shouldBe` Just MLTaskStateNotFound + mlTaskInfoTaskType decoded `shouldBe` Nothing + + it "decodes an empty object as all-Nothing fields" $ do + let Just decoded = decode "{}" :: Maybe MLTaskInfo + mlTaskInfoModelId decoded `shouldBe` Nothing + mlTaskInfoState decoded `shouldBe` Nothing + + it "rejects a top-level array" $ do + (decode "[]" :: Maybe MLTaskInfo) `shouldBe` Nothing + + it "rejects a field with the wrong type (state as a number)" $ do + let decoded = decode "{\"state\": 42}" :: Maybe MLTaskInfo + decoded `shouldBe` Nothing + + it "rejects malformed JSON" $ do + (decode "{ not json" :: Maybe MLTaskInfo) `shouldBe` Nothing + + describe "MLTaskInfo ToJSON round-trip" $ do + it "round-trips a fully-populated body through ToJSON/FromJSON" $ do + let Just decoded = decode sampleRegisterCompleted :: Maybe MLTaskInfo + (decode . encode) decoded `shouldBe` Just decoded + + it "round-trips a sparse CREATED body through ToJSON/FromJSON" $ do + let Just decoded = decode sampleCreatedSparse :: Maybe MLTaskInfo + (decode . encode) decoded `shouldBe` Just decoded + + it "ToJSON omits Nothing fields (no null leakage)" $ do + let Just decoded = decode sampleCreatedSparse :: Maybe MLTaskInfo + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` not . BS.isInfixOf "\"error\"" + encoded `shouldSatisfy` not . BS.isInfixOf "\"worker_node\"" + encoded `shouldSatisfy` BS.isInfixOf "\"state\"" + + describe "getMLTask endpoint shape (OS1)" $ do + it "GETs /_plugins/_ml/tasks/{task_id}" $ do + let req = OS1Requests.getMLTask (OS1Types.MLTaskId "task-abc-123") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "tasks", "task-abc-123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the GET method" $ do + let req = OS1Requests.getMLTask (OS1Types.MLTaskId "task-abc-123") + bhRequestMethod req `shouldBe` "GET" + it "does not attach a body" $ do + let req = OS1Requests.getMLTask (OS1Types.MLTaskId "task-abc-123") + bhRequestBody req `shouldBe` Nothing + + describe "getMLTask endpoint shape (OS2)" $ do + it "GETs /_plugins/_ml/tasks/{task_id}" $ do + let req = OS2Requests.getMLTask (OS2Types.MLTaskId "task-abc-123") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "tasks", "task-abc-123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the GET method" $ do + let req = OS2Requests.getMLTask (OS2Types.MLTaskId "task-abc-123") + bhRequestMethod req `shouldBe` "GET" + it "does not attach a body" $ do + let req = OS2Requests.getMLTask (OS2Types.MLTaskId "task-abc-123") + bhRequestBody req `shouldBe` Nothing + + describe "getMLTask endpoint shape (OS3)" $ do + it "GETs /_plugins/_ml/tasks/{task_id}" $ do + let req = OS3Requests.getMLTask (MLTaskId "task-abc-123") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_ml", "tasks", "task-abc-123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the GET method" $ do + let req = OS3Requests.getMLTask (MLTaskId "task-abc-123") + bhRequestMethod req `shouldBe` "GET" + it "does not attach a body" $ do + let req = OS3Requests.getMLTask (MLTaskId "task-abc-123") + bhRequestBody req `shouldBe` Nothing diff --git a/tests/Test/MLTrainSpec.hs b/tests/Test/MLTrainSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MLTrainSpec.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MLTrainSpec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- | Sync train response (@POST /_plugins/_ml/_train/{algorithm}@): +-- @{model_id, status}@. The async shape (@{task_id, status}@) is the +-- same 'MLTaskAck' envelope; both decode with one parser. +sampleTrainSync :: LBS.ByteString +sampleTrainSync = "{\"model_id\":\"lblVmX8BO5w8y8RaYYvN\",\"status\":\"COMPLETED\"}" + +-- | Async train response: @{task_id, status}@. +sampleTrainAsync :: LBS.ByteString +sampleTrainAsync = "{\"task_id\":\"lrlamX8BO5w8y8Ra2otd\",\"status\":\"CREATED\"}" + +-- | Train-predict response: @{status, prediction_result}@. The +-- prediction payload is algorithm-specific, so it is kept opaque. +sampleTrainPredict :: LBS.ByteString +sampleTrainPredict = + "{\ + \ \"status\": \"COMPLETED\",\ + \ \"prediction_result\": {\ + \ \"column_metas\": [{\"name\": \"ClusterID\", \"column_type\": \"INTEGER\"}],\ + \ \"rows\": [{\"values\": [{\"column_type\": \"INTEGER\", \"value\": 1}]}]\ + \ }\ + \}" + +spec :: Spec +spec = describe "ML Commons train / train-predict APIs" $ do + describe "MLTaskAck (train responses)" $ do + it "decodes the sync train response (model_id + status)" $ + decode sampleTrainSync + `shouldBe` Just + MLTaskAck + { mlTaskAckTaskId = Nothing, + mlTaskAckStatus = Just "COMPLETED", + mlTaskAckModelId = Just "lblVmX8BO5w8y8RaYYvN", + mlTaskAckTaskType = Nothing + } + it "decodes the async train response (task_id + status)" $ + decode sampleTrainAsync + `shouldBe` Just + MLTaskAck + { mlTaskAckTaskId = Just "lrlamX8BO5w8y8Ra2otd", + mlTaskAckStatus = Just "CREATED", + mlTaskAckModelId = Nothing, + mlTaskAckTaskType = Nothing + } + + describe "TrainModelRequest" $ do + it "encodes parameters + input_query + input_index, omitting absent input_data" $ do + let req = + TrainModelRequest + { trainModelParameters = + object + [ "centroids" .= (3 :: Int), + "iterations" .= (10 :: Int) + ], + trainModelInputQuery = Just (object ["size" .= (10000 :: Int)]), + trainModelInputIndex = Just ["iris_data"], + trainModelInputData = Nothing + } + encode req `shouldBe` "{\"input_index\":[\"iris_data\"],\"input_query\":{\"size\":10000},\"parameters\":{\"centroids\":3,\"iterations\":10}}" + it "round-trips a request built from inline input_data" $ do + let req = + TrainModelRequest + { trainModelParameters = object ["k" .= (2 :: Int)], + trainModelInputQuery = Nothing, + trainModelInputIndex = Nothing, + trainModelInputData = Just (object ["rows" .= ([] :: [Value])]) + } + decode (encode req) `shouldBe` Just req + + describe "TrainAndPredictResponse" $ do + it "decodes the doc sample (status + opaque prediction_result)" $ do + let decoded = decode sampleTrainPredict :: Maybe TrainAndPredictResponse + case decoded of + Just r -> do + trainAndPredictResponseStatus r `shouldBe` Just "COMPLETED" + trainAndPredictResponsePredictionResult r `shouldSatisfy` isJust + Nothing -> expectationFailure "expected TrainAndPredictResponse decode" + it "round-trips a minimal response (status only)" $ do + let r = TrainAndPredictResponse {trainAndPredictResponseStatus = Just "COMPLETED", trainAndPredictResponsePredictionResult = Nothing} + decode (encode r) `shouldBe` Just r diff --git a/tests/Test/MigrationReindexSpec.hs b/tests/Test/MigrationReindexSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MigrationReindexSpec.hs @@ -0,0 +1,545 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.MigrationReindexSpec (spec) where + +import Data.Aeson +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch8.Requests qualified as RequestsES8 +import Database.Bloodhound.ElasticSearch8.Types qualified as Types +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import System.Environment (lookupEnv) +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +------------------------------------------------------------------------------ +-- Sample payloads (built from the ES9 OpenAPI spec shapes). +------------------------------------------------------------------------------ + +-- | Canonical @POST /_migration/reindex@ request body: reindex the +-- @my-data-stream@ data stream in @upgrade@ mode. +sampleMigrateReindexRequestBytes :: LBS.ByteString +sampleMigrateReindexRequestBytes = + "{\ + \ \"source\": {\"index\": \"my-data-stream\"},\ + \ \"mode\": \"upgrade\"\ + \}" + +-- | A @GET /_migration/reindex/{index}/_status@ response mid-flight: one +-- index in progress (half its docs reindexed), one errored, the rest +-- pending. @start_time@ is an ISO-8601 string (one of the two wire forms +-- of @_types.DateTime@). +sampleMigrateReindexStatusBytes :: LBS.ByteString +sampleMigrateReindexStatusBytes = + "{\ + \ \"start_time\": \"2024-01-15T10:30:00.000Z\",\ + \ \"start_time_millis\": 1705314600000,\ + \ \"complete\": false,\ + \ \"total_indices_in_data_stream\": 5,\ + \ \"total_indices_requiring_upgrade\": 4,\ + \ \"successes\": 2,\ + \ \"in_progress\": [\ + \ {\ + \ \"index\": \"logs-app-000003\",\ + \ \"total_doc_count\": 1000,\ + \ \"reindexed_doc_count\": 500\ + \ }\ + \ ],\ + \ \"pending\": 1,\ + \ \"errors\": [\ + \ {\ + \ \"index\": \"logs-app-000001\",\ + \ \"message\": \"cluster:blocked\"\ + \ }\ + \ ]\ + \}" + +-- | A completed status with @start_time@ as an epoch-millis number (the +-- other @_types.DateTime@ wire form) and an @exception@ set. +sampleMigrateReindexStatusCompleteBytes :: LBS.ByteString +sampleMigrateReindexStatusCompleteBytes = + "{\ + \ \"start_time_millis\": 1705314600000,\ + \ \"complete\": true,\ + \ \"total_indices_in_data_stream\": 3,\ + \ \"total_indices_requiring_upgrade\": 2,\ + \ \"successes\": 1,\ + \ \"in_progress\": [],\ + \ \"pending\": 0,\ + \ \"errors\": [],\ + \ \"exception\": \"partial failure\"\ + \}" + +------------------------------------------------------------------------------ +-- Spec +------------------------------------------------------------------------------ + +spec :: Spec +spec = describe "Migration reindex API" $ do + -------------------------------------------------------------------------- + -- MigrateReindexMode + -------------------------------------------------------------------------- + describe "MigrateReindexMode JSON" $ do + it "encodes the upgrade constructor" $ + encode Types.MigrateReindexModeUpgrade `shouldBe` "\"upgrade\"" + + it "decodes the upgrade wire string" $ + (decode "\"upgrade\"" :: Maybe Types.MigrateReindexMode) + `shouldBe` Just Types.MigrateReindexModeUpgrade + + it "rejects an unknown mode" $ + (decode "\"downgrade\"" :: Maybe Types.MigrateReindexMode) + `shouldBe` Nothing + + it "rejects a non-string value" $ + (decode "42" :: Maybe Types.MigrateReindexMode) + `shouldBe` Nothing + + -------------------------------------------------------------------------- + -- MigrateReindexSource / MigrateReindexRequest + -------------------------------------------------------------------------- + describe "MigrateReindexRequest JSON" $ do + it "decodes the canonical ES request body" $ + case (decode sampleMigrateReindexRequestBytes :: Maybe Types.MigrateReindexRequest) of + Nothing -> expectationFailure "expected MigrateReindexRequest decode" + Just decoded -> do + Types.migrateReindexRequestMode decoded + `shouldBe` Types.MigrateReindexModeUpgrade + Types.migrateReindexSourceIndex + (Types.migrateReindexRequestSource decoded) + `shouldBe` [qqIndexName|my-data-stream|] + + it "round-trips through ToJSON/FromJSON" $ do + let req = + Types.mkMigrateReindexRequest [qqIndexName|logs-stream|] + (decode . encode) req `shouldBe` Just req + + it "mkMigrateReindexRequest sets the upgrade mode" $ do + let req = Types.mkMigrateReindexRequest [qqIndexName|ds|] + Types.migrateReindexRequestMode req + `shouldBe` Types.MigrateReindexModeUpgrade + + it "rejects a body missing the mode field" $ + ( decode + "{\"source\":{\"index\":\"ds\"}}" :: + Maybe Types.MigrateReindexRequest + ) + `shouldBe` Nothing + + it "rejects a body missing the source field" $ + ( decode "{\"mode\":\"upgrade\"}" :: + Maybe Types.MigrateReindexRequest + ) + `shouldBe` Nothing + + it "rejects a non-object body" $ + (decode "[]" :: Maybe Types.MigrateReindexRequest) + `shouldBe` Nothing + + -------------------------------------------------------------------------- + -- MigrateReindexInProgress + -------------------------------------------------------------------------- + describe "MigrateReindexInProgress JSON" $ do + it "decodes a canonical entry" $ + case ( decode + "{\"index\":\"logs-app-000003\",\"total_doc_count\":1000,\"reindexed_doc_count\":500}" :: + Maybe Types.MigrateReindexInProgress + ) of + Nothing -> expectationFailure "expected MigrateReindexInProgress decode" + Just decoded -> do + Types.migrateReindexInProgressIndex decoded + `shouldBe` [qqIndexName|logs-app-000003|] + Types.migrateReindexInProgressTotalDocCount decoded + `shouldBe` 1000 + Types.migrateReindexInProgressReindexedDocCount decoded + `shouldBe` 500 + + it "round-trips through ToJSON/FromJSON" $ do + let entry = + Types.MigrateReindexInProgress + { Types.migrateReindexInProgressIndex = + [qqIndexName|idx|], + Types.migrateReindexInProgressTotalDocCount = 7, + Types.migrateReindexInProgressReindexedDocCount = 3 + } + (decode . encode) entry `shouldBe` Just entry + + it "rejects a body missing total_doc_count" $ + ( decode + "{\"index\":\"idx\",\"reindexed_doc_count\":3}" :: + Maybe Types.MigrateReindexInProgress + ) + `shouldBe` Nothing + + -------------------------------------------------------------------------- + -- MigrateReindexError + -------------------------------------------------------------------------- + describe "MigrateReindexError JSON" $ do + it "decodes a canonical entry" $ + case ( decode + "{\"index\":\"logs-app-000001\",\"message\":\"cluster:blocked\"}" :: + Maybe Types.MigrateReindexError + ) of + Nothing -> expectationFailure "expected MigrateReindexError decode" + Just decoded -> do + Types.migrateReindexErrorIndex decoded + `shouldBe` [qqIndexName|logs-app-000001|] + Types.migrateReindexErrorMessage decoded + `shouldBe` "cluster:blocked" + + it "round-trips through ToJSON/FromJSON" $ do + let err = + Types.MigrateReindexError + { Types.migrateReindexErrorIndex = [qqIndexName|idx|], + Types.migrateReindexErrorMessage = "boom" + } + (decode . encode) err `shouldBe` Just err + + -------------------------------------------------------------------------- + -- MigrateReindexStatus + -------------------------------------------------------------------------- + describe "MigrateReindexStatus JSON" $ do + it "decodes the canonical mid-flight response" $ + case (decode sampleMigrateReindexStatusBytes :: Maybe Types.MigrateReindexStatus) of + Nothing -> expectationFailure "expected MigrateReindexStatus decode" + Just decoded -> do + Types.migrateReindexStatusStartTimeMillis decoded + `shouldBe` 1705314600000 + Types.migrateReindexStatusComplete decoded `shouldBe` False + Types.migrateReindexStatusTotalIndicesInDataStream decoded + `shouldBe` 5 + Types.migrateReindexStatusSuccesses decoded `shouldBe` 2 + Types.migrateReindexStatusPending decoded `shouldBe` 1 + length (Types.migrateReindexStatusInProgress decoded) + `shouldBe` 1 + length (Types.migrateReindexStatusErrors decoded) + `shouldBe` 1 + -- start_time accepted as an ISO-8601 string + Types.migrateReindexStatusStartTime decoded + `shouldSatisfy` isJust + Types.migrateReindexStatusException decoded + `shouldBe` Nothing + + it "decodes a completed response with epoch-number start_time omitted and exception set" $ + case (decode sampleMigrateReindexStatusCompleteBytes :: Maybe Types.MigrateReindexStatus) of + Nothing -> expectationFailure "expected MigrateReindexStatus decode" + Just decoded -> do + Types.migrateReindexStatusComplete decoded `shouldBe` True + Types.migrateReindexStatusStartTime decoded + `shouldBe` Nothing + Types.migrateReindexStatusInProgress decoded `shouldBe` [] + Types.migrateReindexStatusErrors decoded `shouldBe` [] + Types.migrateReindexStatusException decoded + `shouldBe` Just "partial failure" + + it "tolerates missing in_progress and errors (default to empty)" $ + case ( decode + "{\"start_time_millis\":1,\"complete\":true,\ + \ \"total_indices_in_data_stream\":0,\ + \ \"total_indices_requiring_upgrade\":0,\ + \ \"successes\":0,\"pending\":0}" :: + Maybe Types.MigrateReindexStatus + ) of + Nothing -> expectationFailure "expected MigrateReindexStatus decode" + Just decoded -> do + Types.migrateReindexStatusInProgress decoded `shouldBe` [] + Types.migrateReindexStatusErrors decoded `shouldBe` [] + + it "round-trips through ToJSON/FromJSON (omitNulls drops empty arrays)" $ do + -- 'omitNulls' drops empty arrays and Nothing fields, so after a + -- round-trip an empty @in_progress@/@errors@ and absent @start_time@ + -- resurface as @[]@ / @Nothing@ (the decoder defaults them). + let s = + Types.MigrateReindexStatus + { Types.migrateReindexStatusStartTime = Nothing, + Types.migrateReindexStatusStartTimeMillis = 1, + Types.migrateReindexStatusComplete = True, + Types.migrateReindexStatusTotalIndicesInDataStream = 0, + Types.migrateReindexStatusTotalIndicesRequiringUpgrade = 0, + Types.migrateReindexStatusSuccesses = 0, + Types.migrateReindexStatusInProgress = [], + Types.migrateReindexStatusPending = 0, + Types.migrateReindexStatusErrors = [], + Types.migrateReindexStatusException = Nothing + } + (decode . encode) s `shouldBe` Just s + + it "round-trips a populated status unchanged" $ + case (decode sampleMigrateReindexStatusBytes :: Maybe Types.MigrateReindexStatus) of + Nothing -> expectationFailure "expected MigrateReindexStatus decode" + Just decoded -> (decode . encode) decoded `shouldBe` Just decoded + + it "rejects a body missing start_time_millis" $ + ( decode + "{\"complete\":true,\"total_indices_in_data_stream\":0,\ + \ \"total_indices_requiring_upgrade\":0,\"successes\":0,\ + \ \"pending\":0}" :: + Maybe Types.MigrateReindexStatus + ) + `shouldBe` Nothing + + it "rejects a non-object body" $ + (decode "42" :: Maybe Types.MigrateReindexStatus) + `shouldBe` Nothing + + -------------------------------------------------------------------------- + -- CreateIndexFromBody + -------------------------------------------------------------------------- + describe "CreateIndexFromBody JSON" $ do + it "decodes a fully-populated body" $ + case ( decode + "{\"mappings_override\":{\"enabled\":true},\ + \ \"settings_override\":{\"index\":{\"number_of_shards\":1}},\ + \ \"remove_index_blocks\":false}" :: + Maybe Types.CreateIndexFromBody + ) of + Nothing -> expectationFailure "expected CreateIndexFromBody decode" + Just decoded -> do + Types.createIndexFromBodyRemoveIndexBlocks decoded + `shouldBe` Just False + Types.createIndexFromBodyMappingsOverride decoded + `shouldSatisfy` isJust + + it "decodes an empty object as the default (all Nothing)" $ + (decode "{}" :: Maybe Types.CreateIndexFromBody) + `shouldBe` Just Types.defaultCreateIndexFromBody + + it "omits all Nothing fields from ToJSON output" $ + encode Types.defaultCreateIndexFromBody `shouldBe` "{}" + + it "round-trips a fully-populated body" $ do + let body = + Types.CreateIndexFromBody + { Types.createIndexFromBodyMappingsOverride = + Just (object ["enabled" .= True]), + Types.createIndexFromBodySettingsOverride = Nothing, + Types.createIndexFromBodyRemoveIndexBlocks = Just True + } + (decode . encode) body `shouldBe` Just body + + -------------------------------------------------------------------------- + -- CreateIndexFromResponse + -------------------------------------------------------------------------- + describe "CreateIndexFromResponse JSON" $ do + it "decodes a canonical response" $ do + let Just decoded = + decode + "{\"acknowledged\":true,\"index\":\"my-new-index\",\ + \ \"shards_acknowledged\":true}" :: + Maybe Types.CreateIndexFromResponse + Types.createIndexFromResponseAcknowledged decoded `shouldBe` True + Types.createIndexFromResponseIndex decoded + `shouldBe` [qqIndexName|my-new-index|] + Types.createIndexFromResponseShardsAcknowledged decoded + `shouldBe` True + + it "round-trips through ToJSON/FromJSON" $ do + let resp = + Types.CreateIndexFromResponse + { Types.createIndexFromResponseAcknowledged = True, + Types.createIndexFromResponseIndex = [qqIndexName|dest|], + Types.createIndexFromResponseShardsAcknowledged = False + } + (decode . encode) resp `shouldBe` Just resp + + it "rejects a body missing shards_acknowledged" $ + ( decode + "{\"acknowledged\":true,\"index\":\"dest\"}" :: + Maybe Types.CreateIndexFromResponse + ) + `shouldBe` Nothing + + -------------------------------------------------------------------------- + -- Endpoint shape tests (ES8 builders — the canonical implementation) + -------------------------------------------------------------------------- + describe "migrateReindex endpoint shape" $ do + let req = Types.mkMigrateReindexRequest [qqIndexName|my-data-stream|] + bhReq = RequestsES8.migrateReindex req + + it "POSTs /_migration/reindex" $ + getRawEndpoint (bhRequestEndpoint bhReq) + `shouldBe` ["_migration", "reindex"] + + it "uses the POST method" $ + bhRequestMethod bhReq `shouldBe` "POST" + + it "carries the encoded request body" $ do + bhRequestBody bhReq `shouldSatisfy` isJust + -- the body round-trips back into the same request + let Just body = bhRequestBody bhReq + (decode body :: Maybe Types.MigrateReindexRequest) `shouldBe` Just req + + it "carries no query string" $ + getRawEndpointQueries (bhRequestEndpoint bhReq) `shouldBe` [] + + describe "cancelMigrateReindex endpoint shape" $ do + let bhReq = + RequestsES8.cancelMigrateReindex + ([qqIndexName|my-data-stream|] :| []) + + it "POSTs /_migration/reindex/{index}/_cancel" $ + getRawEndpoint (bhRequestEndpoint bhReq) + `shouldBe` ["_migration", "reindex", "my-data-stream", "_cancel"] + + it "uses the POST method" $ + bhRequestMethod bhReq `shouldBe` "POST" + + it "sends an empty body" $ + bhRequestBody bhReq `shouldBe` Just "" + + it "comma-joins multiple indices into one path segment" $ do + let bhReq' = + RequestsES8.cancelMigrateReindex + ( [qqIndexName|ds-one|] + :| [[qqIndexName|ds-two|]] + ) + getRawEndpoint (bhRequestEndpoint bhReq') + `shouldBe` ["_migration", "reindex", "ds-one,ds-two", "_cancel"] + + describe "getMigrateReindexStatus endpoint shape" $ do + let bhReq = + RequestsES8.getMigrateReindexStatus + ([qqIndexName|my-data-stream|] :| []) + + it "GETs /_migration/reindex/{index}/_status" $ + getRawEndpoint (bhRequestEndpoint bhReq) + `shouldBe` ["_migration", "reindex", "my-data-stream", "_status"] + + it "uses the GET method" $ + bhRequestMethod bhReq `shouldBe` "GET" + + it "carries no request body" $ + bhRequestBody bhReq `shouldBe` Nothing + + describe "createIndexFrom endpoint shape" $ do + let bhReq = RequestsES8.createIndexFrom [qqIndexName|src|] [qqIndexName|dst|] + + it "POSTs /_create_from/{source}/{dest}" $ + getRawEndpoint (bhRequestEndpoint bhReq) + `shouldBe` ["_create_from", "src", "dst"] + + it "uses the POST method" $ + bhRequestMethod bhReq `shouldBe` "POST" + + it "sends an empty body when no overrides are supplied" $ + bhRequestBody bhReq `shouldBe` Just "" + + describe "createIndexFromWith endpoint shape" $ do + let body = + Types.CreateIndexFromBody + { Types.createIndexFromBodyMappingsOverride = + Just (object ["enabled" .= True]), + Types.createIndexFromBodySettingsOverride = Nothing, + Types.createIndexFromBodyRemoveIndexBlocks = Just False + } + bhReq = + RequestsES8.createIndexFromWith + [qqIndexName|src|] + [qqIndexName|dst|] + (Just body) + + it "POSTs /_create_from/{source}/{dest}" $ + getRawEndpoint (bhRequestEndpoint bhReq) + `shouldBe` ["_create_from", "src", "dst"] + + it "carries the encoded override body" $ do + bhRequestBody bhReq `shouldSatisfy` isJust + let Just b = bhRequestBody bhReq + (decode b :: Maybe Types.CreateIndexFromBody) `shouldBe` Just body + + describe "ES9 aliases match the ES8 builders" $ do + let indices = [qqIndexName|my-data-stream|] :| [] + + it "migrateReindex produces the same endpoint as ES8" $ do + let req = Types.mkMigrateReindexRequest [qqIndexName|ds|] + getRawEndpoint + (bhRequestEndpoint (RequestsES9.migrateReindex req)) + `shouldBe` getRawEndpoint + (bhRequestEndpoint (RequestsES8.migrateReindex req)) + + it "getMigrateReindexStatus produces the same endpoint as ES8" $ + getRawEndpoint + (bhRequestEndpoint (RequestsES9.getMigrateReindexStatus indices)) + `shouldBe` getRawEndpoint + (bhRequestEndpoint (RequestsES8.getMigrateReindexStatus indices)) + + it "cancelMigrateReindex produces the same endpoint as ES8" $ + getRawEndpoint + (bhRequestEndpoint (RequestsES9.cancelMigrateReindex indices)) + `shouldBe` getRawEndpoint + (bhRequestEndpoint (RequestsES8.cancelMigrateReindex indices)) + + it "createIndexFrom produces the same endpoint as ES8" $ + getRawEndpoint + ( bhRequestEndpoint + (RequestsES9.createIndexFrom [qqIndexName|s|] [qqIndexName|d|]) + ) + `shouldBe` getRawEndpoint + ( bhRequestEndpoint + (RequestsES8.createIndexFrom [qqIndexName|s|] [qqIndexName|d|]) + ) + + -------------------------------------------------------------------------- + -- Live integration (gated on ES8/ES9; mutating ops further gated + -- behind ES_TEST_RUN_MUTATING so cluster state is not perturbed by + -- default). + -------------------------------------------------------------------------- + backendSpecific + [ElasticSearch8, ElasticSearch9] + $ describe "Migration reindex API (live integration)" + $ do + it "getMigrateReindexStatus returns a parseable response when ES_TEST_RUN_MUTATING=true" $ + withTestEnv $ do + -- Querying a non-existent data stream surfaces as an EsError + -- (404) rather than a decodable status, so this is gated on + -- the mutating flag alongside the cluster-perturbing ops; a + -- meaningful live assertion requires a real data stream. + enabled <- liftIO $ lookupEnv "ES_TEST_RUN_MUTATING" + case enabled of + Just "true" -> do + result <- + ClientES8.getMigrateReindexStatus + ([qqIndexName|bloodhound-missing-stream|] :| []) + liftIO $ + Types.migrateReindexStatusComplete result + `shouldSatisfy` (const True :: Bool -> Bool) + _ -> + liftIO $ + pendingWith + "skipped: set ES_TEST_RUN_MUTATING=true to run this test" + + it "migrateReindex returns Acknowledged when ES_TEST_RUN_MUTATING=true" $ + withTestEnv $ do + enabled <- liftIO $ lookupEnv "ES_TEST_RUN_MUTATING" + case enabled of + Just "true" -> do + ack <- + ClientES8.migrateReindex + ( Types.mkMigrateReindexRequest + [qqIndexName|bloodhound-missing-stream|] + ) + liftIO $ isAcknowledged ack `shouldBe` True + _ -> + liftIO $ + pendingWith + "skipped: set ES_TEST_RUN_MUTATING=true to run this mutating test" + + it "createIndexFrom returns acknowledged when ES_TEST_RUN_MUTATING=true" $ + withTestEnv $ do + enabled <- liftIO $ lookupEnv "ES_TEST_RUN_MUTATING" + case enabled of + Just "true" -> do + resp <- + ClientES8.createIndexFrom + [qqIndexName|bloodhound-tests-twitter-1|] + [qqIndexName|bloodhound-createfrom-dest|] + liftIO $ + Types.createIndexFromResponseAcknowledged resp + `shouldBe` True + _ -> + liftIO $ + pendingWith + "skipped: set ES_TEST_RUN_MUTATING=true to run this mutating test" diff --git a/tests/Test/MigrationSpec.hs b/tests/Test/MigrationSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MigrationSpec.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.MigrationSpec (spec) where + +import Data.Aeson +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Map.Strict qualified as M +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.Common.Client qualified as CommonClient +import Database.Bloodhound.Common.Requests qualified as Common +import System.Environment (lookupEnv) +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +------------------------------------------------------------------------------ +-- Sample payloads (sourced from the ES reference docs and trimmed for +-- the wire fields actually decoded by the Migration types). +------------------------------------------------------------------------------ + +-- | Cluster-level deprecation with @details@ populated and +-- @resolve_during_rolling_upgrade@ / @_meta@ omitted (matches the +-- official ES example response). +sampleClusterDeprecationBytes :: LBS.ByteString +sampleClusterDeprecationBytes = + "{\ + \ \"level\": \"critical\",\ + \ \"message\": \"Cluster name cannot contain ':'\",\ + \ \"url\": \"https://www.elastic.co/guide/en/elasticsearch/reference/7.0/breaking-changes-7.0.html#_literal_literal_is_no_longer_allowed_in_cluster_name\",\ + \ \"details\": \"This cluster is named [mycompany:logging], which contains the illegal character ':'.\"\ + \}" + +-- | Full @GET /_migration/deprecations@ response matching the ES +-- reference example: cluster-level critical warning, empty @node@ list, +-- one index-level warning under @logs:apache@, empty @ml@ list. The +-- index name contains a colon, which 'IndexName' would reject — proving +-- why the map key type is 'Text'. +sampleDeprecationsResponseBytes :: LBS.ByteString +sampleDeprecationsResponseBytes = + "{\ + \ \"cluster_settings\": [\ + \ {\ + \ \"level\": \"critical\",\ + \ \"message\": \"Cluster name cannot contain ':'\",\ + \ \"url\": \"https://www.elastic.co/guide/en/elasticsearch/reference/7.0/breaking-changes-7.0.html#_literal_literal_is_no_longer_allowed_in_cluster_name\",\ + \ \"details\": \"This cluster is named [mycompany:logging], which contains the illegal character ':'.\"\ + \ }\ + \ ],\ + \ \"node_settings\": [],\ + \ \"index_settings\": {\ + \ \"logs:apache\": [\ + \ {\ + \ \"level\": \"warning\",\ + \ \"message\": \"Index name cannot contain ':'\",\ + \ \"url\": \"https://www.elastic.co/guide/en/elasticsearch/reference/7.0/breaking-changes-7.0.html#_literal_literal_is_no_longer_allowed_in_index_name\",\ + \ \"details\": \"This index is named [logs:apache], which contains the illegal character ':'.\",\ + \ \"resolve_during_rolling_upgrade\": true\ + \ }\ + \ ]\ + \ },\ + \ \"ml_settings\": []\ + \}" + +-- | Minimal @GET /_migration/system_features@ response: two features, +-- both @NO_MIGRATION_NEEDED@, empty @indices@ arrays (matches the +-- official ES example shape). +sampleSystemFeaturesResponseBytes :: LBS.ByteString +sampleSystemFeaturesResponseBytes = + "{\ + \ \"migration_status\": \"NO_MIGRATION_NEEDED\",\ + \ \"features\": [\ + \ {\ + \ \"feature_name\": \"async_search\",\ + \ \"minimum_index_version\": \"8100099\",\ + \ \"migration_status\": \"NO_MIGRATION_NEEDED\",\ + \ \"indices\": []\ + \ },\ + \ {\ + \ \"feature_name\": \"enrich\",\ + \ \"minimum_index_version\": \"8100099\",\ + \ \"migration_status\": \"NO_MIGRATION_NEEDED\",\ + \ \"indices\": []\ + \ }\ + \ ]\ + \}" + +------------------------------------------------------------------------------ +-- Spec +------------------------------------------------------------------------------ + +spec :: Spec +spec = describe "Migration API" $ do + -------------------------------------------------------------------------- + -- DeprecationLevel + -------------------------------------------------------------------------- + describe "DeprecationLevel JSON" $ do + it "round-trips each constructor through its wire string" $ do + encode DeprecationLevelNone `shouldBe` "\"none\"" + encode DeprecationLevelInfo `shouldBe` "\"info\"" + encode DeprecationLevelWarning `shouldBe` "\"warning\"" + encode DeprecationLevelCritical `shouldBe` "\"critical\"" + + it "decodes each wire string back to the constructor" $ do + decode "\"none\"" `shouldBe` Just DeprecationLevelNone + decode "\"info\"" `shouldBe` Just DeprecationLevelInfo + decode "\"warning\"" `shouldBe` Just DeprecationLevelWarning + decode "\"critical\"" `shouldBe` Just DeprecationLevelCritical + + it "rejects an unknown level" $ do + (decode "\"panic\"" :: Maybe DeprecationLevel) `shouldBe` Nothing + + it "rejects a non-string value" $ do + (decode "42" :: Maybe DeprecationLevel) `shouldBe` Nothing + + -------------------------------------------------------------------------- + -- Deprecation + -------------------------------------------------------------------------- + describe "Deprecation JSON" $ do + it "decodes the canonical ES example (no rolling_upgrade / _meta)" $ do + let Just decoded = decode sampleClusterDeprecationBytes :: Maybe Deprecation + deprecationLevel decoded `shouldBe` DeprecationLevelCritical + deprecationMessage decoded `shouldBe` "Cluster name cannot contain ':'" + deprecationDetails decoded `shouldBe` Just "This cluster is named [mycompany:logging], which contains the illegal character ':'." + deprecationResolveDuringRollingUpgrade decoded `shouldBe` Nothing + deprecationMeta decoded `shouldBe` Nothing + + it "decodes a deprecation that carries rolling_upgrade and _meta" $ do + let bytes = + "{\ + \ \"level\": \"warning\",\ + \ \"message\": \"m\",\ + \ \"url\": \"u\",\ + \ \"resolve_during_rolling_upgrade\": true,\ + \ \"_meta\": {\"k\": 1}\ + \}" + Just decoded = decode bytes :: Maybe Deprecation + deprecationResolveDuringRollingUpgrade decoded `shouldBe` Just True + deprecationMeta decoded `shouldBe` Just (object ["k" .= (1 :: Int)]) + + it "round-trips through ToJSON/FromJSON" $ do + let d = + Deprecation + { deprecationLevel = DeprecationLevelWarning, + deprecationMessage = "m", + deprecationUrl = "u", + deprecationDetails = Just "d", + deprecationResolveDuringRollingUpgrade = Just False, + deprecationMeta = Nothing + } + (decode . encode) d `shouldBe` Just d + + it "omits Nothing fields from ToJSON output" $ do + let d = + Deprecation + { deprecationLevel = DeprecationLevelInfo, + deprecationMessage = "m", + deprecationUrl = "u", + deprecationDetails = Nothing, + deprecationResolveDuringRollingUpgrade = Nothing, + deprecationMeta = Nothing + } + encode d `shouldBe` "{\"level\":\"info\",\"message\":\"m\",\"url\":\"u\"}" + + it "rejects a response missing the level field" $ do + (decode "{\"message\":\"m\",\"url\":\"u\"}" :: Maybe Deprecation) + `shouldBe` Nothing + + it "rejects a response with an unknown level value" $ do + (decode "{\"level\":\"panic\",\"message\":\"m\",\"url\":\"u\"}" :: Maybe Deprecation) + `shouldBe` Nothing + + it "rejects a non-object body" $ do + (decode "[1,2,3]" :: Maybe Deprecation) `shouldBe` Nothing + + -------------------------------------------------------------------------- + -- MigrationDeprecations + -------------------------------------------------------------------------- + describe "MigrationDeprecations JSON" $ do + it "decodes the canonical ES example response" $ do + let Just decoded = decode sampleDeprecationsResponseBytes :: Maybe MigrationDeprecations + migrationDeprecationsClusterSettings decoded + `shouldBe` Just + [ Deprecation + { deprecationLevel = DeprecationLevelCritical, + deprecationMessage = "Cluster name cannot contain ':'", + deprecationUrl = "https://www.elastic.co/guide/en/elasticsearch/reference/7.0/breaking-changes-7.0.html#_literal_literal_is_no_longer_allowed_in_cluster_name", + deprecationDetails = Just "This cluster is named [mycompany:logging], which contains the illegal character ':'.", + deprecationResolveDuringRollingUpgrade = Nothing, + deprecationMeta = Nothing + } + ] + migrationDeprecationsNodeSettings decoded `shouldBe` Just [] + migrationDeprecationsMlSettings decoded `shouldBe` Just [] + migrationDeprecationsIndexSettings decoded + `shouldBe` Just + ( M.fromList + [ ( "logs:apache", + [ Deprecation + { deprecationLevel = DeprecationLevelWarning, + deprecationMessage = "Index name cannot contain ':'", + deprecationUrl = "https://www.elastic.co/guide/en/elasticsearch/reference/7.0/breaking-changes-7.0.html#_literal_literal_is_no_longer_allowed_in_index_name", + deprecationDetails = Just "This index is named [logs:apache], which contains the illegal character ':'.", + deprecationResolveDuringRollingUpgrade = Just True, + deprecationMeta = Nothing + } + ] + ) + ] + ) + migrationDeprecationsDataStreams decoded `shouldBe` Nothing + migrationDeprecationsTemplates decoded `shouldBe` Nothing + migrationDeprecationsILMPolicies decoded `shouldBe` Nothing + + it "tolerates a response with only some sections present" $ do + let Just decoded = + decode "{\"cluster_settings\":[]}" :: Maybe MigrationDeprecations + migrationDeprecationsClusterSettings decoded `shouldBe` Just [] + migrationDeprecationsNodeSettings decoded `shouldBe` Nothing + + it "tolerates an empty object" $ do + let Just decoded = decode "{}" :: Maybe MigrationDeprecations + migrationDeprecationsClusterSettings decoded `shouldBe` Nothing + + it "decodes data_streams / templates / ilm_policies maps" $ do + let bytes = + "{\ + \ \"data_streams\": {\"logs-app\": [{\"level\":\"info\",\"message\":\"m\",\"url\":\"u\"}]},\ + \ \"templates\": {\"component-tpl\": [{\"level\":\"warning\",\"message\":\"m\",\"url\":\"u\"}]},\ + \ \"ilm_policies\": {\"my-policy\": [{\"level\":\"critical\",\"message\":\"m\",\"url\":\"u\"}]}\ + \}" + Just decoded = decode bytes :: Maybe MigrationDeprecations + expectedEntry lvl = + [ Deprecation + { deprecationLevel = lvl, + deprecationMessage = "m", + deprecationUrl = "u", + deprecationDetails = Nothing, + deprecationResolveDuringRollingUpgrade = Nothing, + deprecationMeta = Nothing + } + ] + migrationDeprecationsDataStreams decoded + `shouldBe` Just (M.fromList [("logs-app", expectedEntry DeprecationLevelInfo)]) + migrationDeprecationsTemplates decoded + `shouldBe` Just (M.fromList [("component-tpl", expectedEntry DeprecationLevelWarning)]) + migrationDeprecationsILMPolicies decoded + `shouldBe` Just (M.fromList [("my-policy", expectedEntry DeprecationLevelCritical)]) + + it "round-trips through ToJSON/FromJSON (omitNulls drops empty arrays)" $ do + -- 'omitNulls' drops empty arrays from the encoded JSON, so + -- @Just []@ surfaces as @Nothing@ after a round-trip. This matches + -- the SLM / ILM modules' treatment of empty list fields. + let d = + MigrationDeprecations + { migrationDeprecationsClusterSettings = Just [], + migrationDeprecationsNodeSettings = Nothing, + migrationDeprecationsMlSettings = Nothing, + migrationDeprecationsIndexSettings = Nothing, + migrationDeprecationsDataStreams = Nothing, + migrationDeprecationsTemplates = Nothing, + migrationDeprecationsILMPolicies = Nothing + } + (decode . encode) d + `shouldBe` Just + ( MigrationDeprecations + { migrationDeprecationsClusterSettings = Nothing, + migrationDeprecationsNodeSettings = Nothing, + migrationDeprecationsMlSettings = Nothing, + migrationDeprecationsIndexSettings = Nothing, + migrationDeprecationsDataStreams = Nothing, + migrationDeprecationsTemplates = Nothing, + migrationDeprecationsILMPolicies = Nothing + } + ) + + it "round-trips a non-empty cluster_settings list unchanged" $ do + let entry = + Deprecation + { deprecationLevel = DeprecationLevelInfo, + deprecationMessage = "m", + deprecationUrl = "u", + deprecationDetails = Nothing, + deprecationResolveDuringRollingUpgrade = Nothing, + deprecationMeta = Nothing + } + d = + MigrationDeprecations + { migrationDeprecationsClusterSettings = Just [entry], + migrationDeprecationsNodeSettings = Nothing, + migrationDeprecationsMlSettings = Nothing, + migrationDeprecationsIndexSettings = Nothing, + migrationDeprecationsDataStreams = Nothing, + migrationDeprecationsTemplates = Nothing, + migrationDeprecationsILMPolicies = Nothing + } + (decode . encode) d `shouldBe` Just d + + it "rejects a non-object response" $ do + (decode "[]" :: Maybe MigrationDeprecations) `shouldBe` Nothing + + -------------------------------------------------------------------------- + -- FeatureMigrationStatus + -------------------------------------------------------------------------- + describe "FeatureMigrationStatus JSON" $ do + it "round-trips each constructor through its wire string" $ do + encode FeatureMigrationStatusNoMigrationNeeded `shouldBe` "\"NO_MIGRATION_NEEDED\"" + encode FeatureMigrationStatusMigrationNeeded `shouldBe` "\"MIGRATION_NEEDED\"" + encode FeatureMigrationStatusInProgress `shouldBe` "\"IN_PROGRESS\"" + encode FeatureMigrationStatusError `shouldBe` "\"ERROR\"" + + it "decodes each wire string back to the constructor" $ do + decode "\"NO_MIGRATION_NEEDED\"" `shouldBe` Just FeatureMigrationStatusNoMigrationNeeded + decode "\"MIGRATION_NEEDED\"" `shouldBe` Just FeatureMigrationStatusMigrationNeeded + decode "\"IN_PROGRESS\"" `shouldBe` Just FeatureMigrationStatusInProgress + decode "\"ERROR\"" `shouldBe` Just FeatureMigrationStatusError + + it "rejects an unknown status" $ do + (decode "\"PENDING\"" :: Maybe FeatureMigrationStatus) `shouldBe` Nothing + + it "rejects a non-string value" $ do + (decode "42" :: Maybe FeatureMigrationStatus) `shouldBe` Nothing + + -------------------------------------------------------------------------- + -- FeatureUpgradeIndex + -------------------------------------------------------------------------- + describe "FeatureUpgradeIndex JSON" $ do + it "decodes a healthy entry (no failure_cause)" $ do + let Just decoded = + decode "{\"index\":\".async-search\",\"version\":\"v7.10.0\"}" :: + Maybe FeatureUpgradeIndex + featureUpgradeIndexIndex decoded `shouldBe` ".async-search" + featureUpgradeIndexVersion decoded `shouldBe` "v7.10.0" + featureUpgradeIndexFailureCause decoded `shouldBe` Nothing + + it "decodes an entry that carries a failure_cause blob" $ do + let bytes = + "{\ + \ \"index\": \"broken\",\ + \ \"version\": \"v1\",\ + \ \"failure_cause\": {\"type\":\"illegal_argument\",\"reason\":\"nope\"}\ + \}" + Just decoded = decode bytes :: Maybe FeatureUpgradeIndex + featureUpgradeIndexFailureCause decoded + `shouldBe` Just + (object ["type" .= String "illegal_argument", "reason" .= String "nope"]) + + it "round-trips through ToJSON/FromJSON" $ do + let i = + FeatureUpgradeIndex + { featureUpgradeIndexIndex = "ix", + featureUpgradeIndexVersion = "v1", + featureUpgradeIndexFailureCause = Nothing + } + (decode . encode) i `shouldBe` Just i + + it "rejects a response missing the index field" $ do + (decode "{\"version\":\"v1\"}" :: Maybe FeatureUpgradeIndex) + `shouldBe` Nothing + + -------------------------------------------------------------------------- + -- FeatureUpgradeInfo + -------------------------------------------------------------------------- + describe "FeatureUpgradeInfo JSON" $ do + it "decodes a no-migration-needed feature with empty indices" $ do + let Just decoded = + decode + "{\ + \ \"feature_name\": \"async_search\",\ + \ \"minimum_index_version\": \"8100099\",\ + \ \"migration_status\": \"NO_MIGRATION_NEEDED\",\ + \ \"indices\": []\ + \}" :: + Maybe FeatureUpgradeInfo + featureUpgradeInfoFeatureName decoded `shouldBe` "async_search" + featureUpgradeInfoMinimumIndexVersion decoded `shouldBe` "8100099" + featureUpgradeInfoMigrationStatus decoded `shouldBe` FeatureMigrationStatusNoMigrationNeeded + featureUpgradeInfoIndices decoded `shouldBe` [] + + it "tolerates a missing indices field (defaults to empty list)" $ do + let Just decoded = + decode + "{\ + \ \"feature_name\": \"enrich\",\ + \ \"minimum_index_version\": \"0\",\ + \ \"migration_status\": \"MIGRATION_NEEDED\"\ + \}" :: + Maybe FeatureUpgradeInfo + featureUpgradeInfoIndices decoded `shouldBe` [] + + it "decodes a feature that still has indices to migrate" $ do + let bytes = + "{\ + \ \"feature_name\": \"fleet\",\ + \ \"minimum_index_version\": \"8080099\",\ + \ \"migration_status\": \"IN_PROGRESS\",\ + \ \"indices\": [\ + \ {\"index\":\".fleet-actions-000001\",\"version\":\"v7.17.0\"},\ + \ {\"index\":\".fleet-actions-000002\",\"version\":\"v8.0.0\",\"failure_cause\":{\"type\":\"x\",\"reason\":\"y\"}}\ + \ ]\ + \}" + Just decoded = decode bytes :: Maybe FeatureUpgradeInfo + indices = featureUpgradeInfoIndices decoded + secondIdx = case indices of + (_ : y : _) -> y + _ -> error "expected two indices" + featureUpgradeInfoMigrationStatus decoded `shouldBe` FeatureMigrationStatusInProgress + length indices `shouldBe` 2 + featureUpgradeIndexFailureCause secondIdx `shouldBe` Just (object ["type" .= String "x", "reason" .= String "y"]) + + it "round-trips through ToJSON/FromJSON" $ do + let info = + FeatureUpgradeInfo + { featureUpgradeInfoFeatureName = "fleet", + featureUpgradeInfoMinimumIndexVersion = "0", + featureUpgradeInfoMigrationStatus = FeatureMigrationStatusError, + featureUpgradeInfoIndices = [] + } + (decode . encode) info `shouldBe` Just info + + it "rejects a response missing migration_status" $ do + (decode "{\"feature_name\":\"x\",\"minimum_index_version\":\"0\"}" :: Maybe FeatureUpgradeInfo) + `shouldBe` Nothing + + -------------------------------------------------------------------------- + -- FeatureUpgradeStatus + -------------------------------------------------------------------------- + describe "FeatureUpgradeStatus JSON" $ do + it "decodes the canonical ES example response" $ do + let Just decoded = decode sampleSystemFeaturesResponseBytes :: Maybe FeatureUpgradeStatus + featureUpgradeStatusMigrationStatus decoded `shouldBe` FeatureMigrationStatusNoMigrationNeeded + length (featureUpgradeStatusFeatures decoded) `shouldBe` 2 + featureUpgradeInfoFeatureName (head (featureUpgradeStatusFeatures decoded)) + `shouldBe` "async_search" + + it "tolerates a missing features field (defaults to empty list)" $ do + let Just decoded = decode "{\"migration_status\":\"NO_MIGRATION_NEEDED\"}" :: Maybe FeatureUpgradeStatus + featureUpgradeStatusFeatures decoded `shouldBe` [] + + it "round-trips through ToJSON/FromJSON" $ do + let s = + FeatureUpgradeStatus + { featureUpgradeStatusMigrationStatus = FeatureMigrationStatusNoMigrationNeeded, + featureUpgradeStatusFeatures = [] + } + (decode . encode) s `shouldBe` Just s + + it "rejects a response missing migration_status" $ do + (decode "{\"features\":[]}" :: Maybe FeatureUpgradeStatus) + `shouldBe` Nothing + + -------------------------------------------------------------------------- + -- Endpoint shape tests + -------------------------------------------------------------------------- + describe "getMigrationDeprecations endpoint shape" $ do + it "GETs /_migration/deprecations when given Nothing" $ do + let req = Common.getMigrationDeprecations Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_migration", "deprecations"] + + it "GETs /{index}/_migration/deprecations when given a Just index" $ do + let req = Common.getMigrationDeprecations (Just [qqIndexName|logs|]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["logs", "_migration", "deprecations"] + + it "uses the GET method" $ do + let req = Common.getMigrationDeprecations Nothing + bhRequestMethod req `shouldBe` "GET" + + it "carries no request body" $ do + let req = Common.getMigrationDeprecations Nothing + bhRequestBody req `shouldBe` Nothing + + it "carries no query string for either variant" $ do + let reqAll = Common.getMigrationDeprecations Nothing + reqOne = Common.getMigrationDeprecations (Just [qqIndexName|logs|]) + getRawEndpointQueries (bhRequestEndpoint reqAll) `shouldBe` [] + getRawEndpointQueries (bhRequestEndpoint reqOne) `shouldBe` [] + + describe "getSystemFeatures endpoint shape" $ do + let req = Common.getSystemFeatures + + it "GETs /_migration/system_features" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_migration", "system_features"] + + it "uses the GET method" $ do + bhRequestMethod req `shouldBe` "GET" + + it "carries no request body" $ do + bhRequestBody req `shouldBe` Nothing + + it "carries no query string" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "upgradeSystemFeatures endpoint shape" $ do + let req = Common.upgradeSystemFeatures + + it "POSTs /_migration/system_features" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_migration", "system_features"] + + it "uses the POST method" $ do + bhRequestMethod req `shouldBe` "POST" + + it "sends an empty body" $ do + bhRequestBody req `shouldBe` Just "" + + it "carries no query string" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + -------------------------------------------------------------------------- + -- Live integration (gated on ES backends; mutating POST further gated + -- behind ES_TEST_RUN_MUTATING so cluster state is not perturbed by + -- default). + -------------------------------------------------------------------------- + backendSpecific + [ElasticSearch7, ElasticSearch8, ElasticSearch9] + $ describe "Migration API (live integration)" + $ do + it "getMigrationDeprecations returns a parseable response" $ + withTestEnv $ do + result <- CommonClient.getMigrationDeprecations Nothing + liftIO $ + migrationDeprecationsClusterSettings result + `shouldSatisfy` (const True :: Maybe [Deprecation] -> Bool) + + it "getSystemFeatures returns a parseable response" $ + withTestEnv $ do + result <- CommonClient.getSystemFeatures + liftIO $ + featureUpgradeStatusMigrationStatus result + `shouldSatisfy` (const True :: FeatureMigrationStatus -> Bool) + + it "upgradeSystemFeatures returns Acknowledged when ES_TEST_RUN_MUTATING=true" $ + withTestEnv $ do + enabled <- liftIO $ lookupEnv "ES_TEST_RUN_MUTATING" + case enabled of + Just "true" -> do + ack <- CommonClient.upgradeSystemFeatures + liftIO $ isAcknowledged ack `shouldBe` True + _ -> + liftIO $ + pendingWith + "skipped: set ES_TEST_RUN_MUTATING=true to run this mutating test" diff --git a/tests/Test/MlAnomalySpec.hs b/tests/Test/MlAnomalySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MlAnomalySpec.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MlAnomalySpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Scientific (Scientific) +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import Database.Bloodhound.ElasticSearch9.Types qualified as Types +import TestsUtils.Import + +spec :: Spec +spec = + describe "ML anomaly APIs (/_ml/anomaly_detectors, /_ml/datafeeds, /_ml/filters, /_ml/calendars)" $ do + describe "identities and enums" $ do + it "round-trips MlJobId / MlModelSnapshotId / MlDatafeedId / MlFilterId / MlCalendarId" $ do + decode (encode (Types.MlJobId "j")) `shouldBe` Just (Types.MlJobId "j") + decode (encode (Types.MlModelSnapshotId "s")) + `shouldBe` Just (Types.MlModelSnapshotId "s") + decode (encode (Types.MlDatafeedId "f")) + `shouldBe` Just (Types.MlDatafeedId "f") + decode (encode (Types.MlFilterId "fi")) + `shouldBe` Just (Types.MlFilterId "fi") + decode (encode (Types.MlCalendarId "c")) + `shouldBe` Just (Types.MlCalendarId "c") + + it "round-trips documented job states and absorbs unknowns" $ do + mapM_ + (\s -> decode (encode s) `shouldBe` Just s) + [ Types.MlJobStateOpening, + Types.MlJobStateOpened, + Types.MlJobStateClosing, + Types.MlJobStateClosed, + Types.MlJobStateFailed + ] + decode "\"paused\"" `shouldBe` Just (Types.MlJobStateCustom "paused") + + it "maps result types to documented path segments" $ do + Types.mlAnomalyResultTypeSegment Types.MlAnomalyResultBuckets + `shouldBe` ("buckets" :: Text) + Types.mlAnomalyResultTypeSegment Types.MlAnomalyResultRecords + `shouldBe` ("records" :: Text) + Types.mlAnomalyResultTypeSegment Types.MlAnomalyResultOverallBuckets + `shouldBe` ("overall_buckets" :: Text) + + describe "MlAnomalyJob JSON" $ do + it "encodes the minimal body as analysis_config + data_description" $ do + let job = + Types.defaultMlAnomalyJob + { Types.mlajAnalysisConfig = object ["detectors" .= ([] :: [Int])], + Types.mlajDataDescription = object ["time_field" .= ("timestamp" :: Text)] + } + decode (encode job) `shouldBe` Just job + + it "omits optional fields" $ do + let job = + Types.defaultMlAnomalyJob + { Types.mlajAnalysisConfig = object [] + } + case decode (encode job) :: Maybe Value of + Just (Object o) -> KeyMap.member "description" o `shouldBe` False + _ -> expectationFailure "expected a JSON object" + + describe "MlAnomalyJobUpdate JSON" $ do + it "encodes to {} when empty" $ + encode Types.defaultMlAnomalyJobUpdate `shouldBe` "{}" + + describe "MlForecastOptions / MlFlushOptions JSON" $ do + it "forecast round-trips a populated body" $ do + let o = + Types.defaultMlForecastOptions + { Types.mlfoDuration = Just "1d" + } + decode (encode o) `shouldBe` Just o + + it "flush encodes to {} when empty" $ + encode Types.defaultMlFlushOptions `shouldBe` "{}" + + describe "MlAnomalyJobOptions params" $ do + it "renders nothing by default" $ + Types.mlAnomalyJobOptionsParams Types.defaultMlAnomalyJobOptions + `shouldBe` [] + + it "renders force/timeout/from in order" $ do + let opts = + Types.defaultMlAnomalyJobOptions + { Types.mlajoForce = Just True, + Types.mlajoTimeout = Just "30s", + Types.mlajoFrom = Just 10 + } + Types.mlAnomalyJobOptionsParams opts + `shouldBe` [ ("from", Just "10"), + ("force", Just "true"), + ("timeout", Just "30s") + ] + + describe "MlAnomalyJobDocument JSON" $ do + it "decodes a stored job, folding extras" $ do + let raw = + LBS.pack + "{\"job_id\":\"j\",\"state\":\"open\",\"job_type\":\"anomaly_detector\",\ + \\"create_time\":1700000000000,\"analysis_config\":{}}" + case decode raw :: Maybe Types.MlAnomalyJobDocument of + Just d -> do + Types.mlajdId d `shouldBe` Just ("j" :: Text) + Types.mlajdState d `shouldBe` Just Types.MlJobStateOpened + extras <- pure (Types.mlajdExtras d) + extras `shouldSatisfy` isJust + forM_ extras $ \km -> + KeyMap.lookup "analysis_config" km `shouldSatisfy` isJust + Nothing -> expectationFailure "failed to decode document" + + describe "MlAnomalyJobsResponse JSON" $ do + it "decodes a jobs envelope, defaulting count" $ do + let raw = LBS.pack "{\"jobs\":[{\"job_id\":\"a\"},{\"job_id\":\"b\"}]}" + case decode raw :: Maybe Types.MlAnomalyJobsResponse of + Just r -> do + length (Types.mlajsrJobs r) `shouldBe` 2 + Types.mlajsrCount r `shouldBe` Just 2 + Nothing -> expectationFailure "failed to decode jobs response" + + describe "MlAnomalyJobStatsResponse JSON" $ do + it "decodes a stats envelope" $ do + let raw = + LBS.pack + "{\"jobs\":[{\"job_id\":\"a\",\"state\":\"closed\",\"data_counts\":{}}]}" + case decode raw :: Maybe Types.MlAnomalyJobStatsResponse of + Just r -> do + length (Types.mlajsrrStats r) `shouldBe` 1 + case Types.mlajsrrStats r of + (s : _) -> Types.mlajssState s `shouldBe` Just Types.MlJobStateClosed + [] -> expectationFailure "expected one stats entry" + Nothing -> expectationFailure "failed to decode stats response" + + describe "forecast / flush responses" $ do + it "decodes a forecast response, defaulting acknowledged" $ do + let raw = LBS.pack "{\"forecast_id\":\"abc\"}" + case decode raw :: Maybe Types.MlForecastResponse of + Just r -> do + Types.mlfrAcknowledged r `shouldBe` Just True + Types.mlfrForecastId r `shouldBe` Just ("abc" :: Text) + Nothing -> expectationFailure "failed to decode forecast response" + + it "decodes a flush response" $ do + let raw = LBS.pack "{\"acknowledged\":true,\"last_finalized_bucket_end\":1234}" + case decode raw :: Maybe Types.MlFlushResponse of + Just r -> Types.mlflrLastFinalizedBucketEnd r `shouldBe` Just (1234 :: Scientific) + Nothing -> expectationFailure "failed to decode flush response" + + describe "model snapshots" $ do + it "decodes a snapshots envelope, defaulting count" $ do + let raw = + LBS.pack + "{\"model_snapshots\":[{\"id\":\"s1\",\"description\":\"d\"}]}" + case decode raw :: Maybe Types.MlModelSnapshotsResponse of + Just r -> do + length (Types.mlmsrSnapshots r) `shouldBe` 1 + Types.mlmsrCount r `shouldBe` Just 1 + Nothing -> expectationFailure "failed to decode snapshots response" + + it "decodes a revert response" $ do + let raw = + LBS.pack + "{\"model\":{\"foo\":1},\"model_snapshot_id\":\"s1\"}" + case decode raw :: Maybe Types.MlRevertSnapshotResponse of + Just r -> do + Types.mlrsrModelSnapshotId r `shouldBe` Just ("s1" :: Text) + Types.mlrsrModel r `shouldSatisfy` isJust + Nothing -> expectationFailure "failed to decode revert response" + + describe "MlDatafeed JSON" $ do + it "encodes the minimal body with job_id only" $ do + let df = Types.defaultMlDatafeed {Types.mldfJobId = "myjob"} + case decode (encode df) :: Maybe Types.MlDatafeed of + Just d -> Types.mldfJobId d `shouldBe` ("myjob" :: Text) + Nothing -> expectationFailure "datafeed should round-trip" + + it "decodes a datafeed document" $ do + let raw = LBS.pack "{\"datafeeds\":[{\"datafeed_id\":\"f\",\"job_id\":\"j\"}]}" + case decode raw :: Maybe Types.MlDatafeedsResponse of + Just r -> do + length (Types.mldfrDatafeeds r) `shouldBe` 1 + case Types.mldfrDatafeeds r of + (d : _) -> Types.mldfdJobId d `shouldBe` Just ("j" :: Text) + [] -> expectationFailure "expected one datafeed" + Nothing -> expectationFailure "failed to decode datafeeds response" + + describe "filters" $ do + it "decodes a filters response" $ do + let raw = + LBS.pack + "{\"filters\":[{\"id\":\"fi\",\"items\":[\"a\"]}]}" + case decode raw :: Maybe Types.MlFiltersResponse of + Just r -> length (Types.mlfsrFilters r) `shouldBe` 1 + Nothing -> expectationFailure "failed to decode filters response" + + it "round-trips a filter body" $ do + let f = + Types.defaultMlFilter + { Types.mlfItems = Just ["a", "b"] + } + decode (encode f) `shouldBe` Just f + + describe "calendars and scheduled events" $ do + it "decodes a calendars response" $ do + let raw = + LBS.pack + "{\"calendars\":[{\"calendar_id\":\"c\",\"description\":\"d\"}]}" + case decode raw :: Maybe Types.MlCalendarsResponse of + Just r -> length (Types.mlcsrCalendars r) `shouldBe` 1 + Nothing -> expectationFailure "failed to decode calendars response" + + it "encodes scheduled events as {events: [...]}" $ do + let e = + Types.MlScheduledEvents + { Types.mlseEvents = [object ["description" .= ("d" :: Text)]] + } + encode e `shouldBe` "{\"events\":[{\"description\":\"d\"}]}" + + describe "endpoint shape" $ do + it "PUTs /_ml/anomaly_detectors/" $ do + let req = RequestsES9.putMlAnomalyJob "j" Types.defaultMlAnomalyJob + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "anomaly_detectors", "j"] + bhRequestBody req `shouldSatisfy` isJust + + it "GETs /_ml/anomaly_detectors/" $ do + let req = RequestsES9.getMlAnomalyJobs (Just "j") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "anomaly_detectors", "j"] + + it "POSTs /_ml/anomaly_detectors//_open (empty body)" $ do + let req = RequestsES9.openMlAnomalyJob "j" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "anomaly_detectors", "j", "_open"] + bhRequestBody req `shouldSatisfy` isJust + + it "GETs /_ml/anomaly_detectors//_results/" $ do + let req = RequestsES9.getMlAnomalyJobResults "j" Types.MlAnomalyResultBuckets + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "anomaly_detectors", "j", "_results", "buckets"] + + it "GETs /_ml/anomaly_detectors//_model_snapshots/" $ do + let req = RequestsES9.getMlModelSnapshot "j" "snap" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "anomaly_detectors", "j", "_model_snapshots", "snap"] + + it "POSTs /_ml/anomaly_detectors//_model_snapshots//_revert" $ do + let req = RequestsES9.revertMlModelSnapshot "j" "snap" (object []) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "anomaly_detectors", "j", "_model_snapshots", "snap", "_revert"] + bhRequestBody req `shouldSatisfy` isJust + + it "POSTs /_ml/anomaly_detectors/_validate" $ do + let req = RequestsES9.validateMlAnomalyJob Types.defaultMlAnomalyJob + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "anomaly_detectors", "_validate"] + + it "PUTs /_ml/datafeeds/" $ do + let req = RequestsES9.putMlDatafeed "f" Types.defaultMlDatafeed + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "datafeeds", "f"] + + it "POSTs /_ml/datafeeds//_start with a body" $ do + let req = RequestsES9.startMlDatafeed "f" (object []) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "datafeeds", "f", "_start"] + bhRequestBody req `shouldSatisfy` isJust + + it "GETs /_ml/datafeeds//_preview" $ do + let req = RequestsES9.previewMlDatafeed "f" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "datafeeds", "f", "_preview"] + + it "PUTs /_ml/filters/" $ do + let req = RequestsES9.putMlFilter "fi" Types.defaultMlFilter + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "filters", "fi"] + + it "GETs /_ml/filters/" $ do + let req = RequestsES9.getMlFilters (Just "fi") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "filters", "fi"] + + it "PUTs /_ml/calendars/" $ do + let req = RequestsES9.putMlCalendar "c" Types.defaultMlCalendar + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "calendars", "c"] + + it "POSTs /_ml/calendars//events" $ do + let req = RequestsES9.setMlScheduledEvents "c" (Types.MlScheduledEvents []) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "calendars", "c", "events"] + bhRequestBody req `shouldSatisfy` isJust + + it "GETs /_ml/calendars//events" $ do + let req = RequestsES9.getMlScheduledEvents "c" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "calendars", "c", "events"] diff --git a/tests/Test/MlDataFrameAnalyticsSpec.hs b/tests/Test/MlDataFrameAnalyticsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MlDataFrameAnalyticsSpec.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MlDataFrameAnalyticsSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Scientific (Scientific) +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import Database.Bloodhound.ElasticSearch9.Types qualified as Types +import TestsUtils.Import + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KeyMap.member` obj + _ -> False + +spec :: Spec +spec = + describe "ML data frame analytics APIs (/_ml/data_frame/analytics/*)" $ do + describe "MlDataFrameAnalyticsId JSON" $ do + it "round-trips an id" $ do + let i = Types.MlDataFrameAnalyticsId "house_price_regression" + decode (encode i) `shouldBe` Just i + + it "unMlDataFrameAnalyticsId extracts the underlying Text" $ + Types.unMlDataFrameAnalyticsId (Types.MlDataFrameAnalyticsId "x") + `shouldBe` ("x" :: Text) + + describe "MlDataFrameAnalysisType JSON" $ do + it "encodes the documented values" $ do + encode Types.MlDataFrameAnalysisTypeClassification + `shouldBe` "\"classification\"" + encode Types.MlDataFrameAnalysisTypeRegression + `shouldBe` "\"regression\"" + encode Types.MlDataFrameAnalysisTypeOutlierDetection + `shouldBe` "\"outlier_detection\"" + + it "round-trips a custom value" $ do + let t = Types.MlDataFrameAnalysisTypeCustom "future_kind" + decode (encode t) `shouldBe` Just t + + it "decodes documented values back" $ + decode "\"regression\"" `shouldBe` Just Types.MlDataFrameAnalysisTypeRegression + + describe "MlDataFrameAnalyticsState JSON" $ do + it "round-trips documented states" $ do + mapM_ + (\s -> decode (encode s) `shouldBe` Just s) + [ Types.MlDataFrameAnalyticsStateStopped, + Types.MlDataFrameAnalyticsStateStarting, + Types.MlDataFrameAnalyticsStateStarted, + Types.MlDataFrameAnalyticsStateStopping, + Types.MlDataFrameAnalyticsStateReverting, + Types.MlDataFrameAnalyticsStateFailed + ] + + it "absorbs an unknown state" $ do + decode "\"awaiting_input\"" + `shouldBe` Just (Types.MlDataFrameAnalyticsStateCustom "awaiting_input") + + describe "MlDataFrameAnalyticsSource JSON" $ do + it "omits Nothing fields" $ do + let s = + Types.defaultMlDataFrameAnalyticsSource + { Types.mldasIndex = ["source-*"] + } + hasKey "query" (encode s) `shouldBe` False + hasKey "_source" (encode s) `shouldBe` False + decode (encode s) `shouldBe` Just s + + it "decodes a documented source" $ do + let raw = + LBS.pack + "{\"index\":[\"source-*\"],\"_source\":[\"price\",\"sqft\"]}" + case decode raw :: Maybe Types.MlDataFrameAnalyticsSource of + Just s -> do + Types.mldasIndex s `shouldBe` ["source-*"] + Types.mldasSource s `shouldBe` Just ["price" :: Text, "sqft"] + Nothing -> expectationFailure "failed to decode source" + + describe "MlDataFrameAnalyticsDest JSON" $ do + it "encodes only the index when results_field is Nothing" $ do + let d = Types.defaultMlDataFrameAnalyticsDest {Types.mldadIndex = Just "dest"} + hasKey "results_field" (encode d) `shouldBe` False + decode (encode d) `shouldBe` Just d + + describe "MlDataFrameAnalyticsPutBody JSON" $ do + it "omits every optional field for the minimal body" $ do + let body = + Types.defaultMlDataFrameAnalyticsPutBody + { Types.mldapbSource = + Types.defaultMlDataFrameAnalyticsSource + { Types.mldasIndex = ["source-*"] + }, + Types.mldapbDest = + Types.defaultMlDataFrameAnalyticsDest + { Types.mldadIndex = Just "dest" + } + } + hasKey "description" (encode body) `shouldBe` False + hasKey "analysis" (encode body) `shouldBe` False + decode (encode body) `shouldBe` Just body + + it "encodes an analysis sub-object verbatim" $ do + let cfg = object ["outlier_detection" .= object ["n_neighbors" .= (4 :: Int)]] + analysis = Types.MlDataFrameAnalyticsAnalysis cfg + body = + Types.defaultMlDataFrameAnalyticsPutBody + { Types.mldapbAnalysis = Just analysis + } + hasKey "analysis" (encode body) `shouldBe` True + Types.mldaanConfig + <$> Types.mldapbAnalysis body + `shouldBe` Just cfg + + describe "MlDataFrameAnalyticsUpdateBody JSON" $ do + it "encodes to {} when empty" $ + encode Types.defaultMlDataFrameAnalyticsUpdateBody + `shouldBe` "{}" + + it "round-trips with a description" $ do + let b = + Types.defaultMlDataFrameAnalyticsUpdateBody + { Types.mldaubDescription = Just "updated" + } + decode (encode b) `shouldBe` Just b + + describe "MlDataFrameAnalyticsOptions params" $ do + it "renders nothing by default" $ + Types.mlDataFrameAnalyticsOptionsParams Types.defaultMlDataFrameAnalyticsOptions + `shouldBe` [] + + it "renders from/size/force/verbose/timeout" $ do + let opts = + Types.defaultMlDataFrameAnalyticsOptions + { Types.mldaoFrom = Just 0, + Types.mldaoSize = Just 100, + Types.mldaoForce = Just True, + Types.mldaoVerbose = Just True, + Types.mldaoTimeout = Just "30s" + } + Types.mlDataFrameAnalyticsOptionsParams opts + `shouldBe` [ ("force", Just "true"), + ("from", Just "0"), + ("size", Just "100"), + ("verbose", Just "true"), + ("timeout", Just "30s") + ] + + describe "MlDataFrameAnalyticsDocument JSON" $ do + it "decodes a documented stored job verbatim" $ do + let raw = + LBS.pack + "{\"id\":\"house_price_regression\",\"state\":\"stopped\",\ + \\"analysis_type\":\"regression\",\"create_time\":1700000000000,\ + \\"version\":\"17.0.0\",\"source\":{\"index\":[\"source-*\"]},\ + \\"dest\":{\"index\":\"dest\"},\"description\":\"regress\"}" + case decode raw :: Maybe Types.MlDataFrameAnalyticsDocument of + Just d -> do + Types.mldadId d `shouldBe` Just ("house_price_regression" :: Text) + Types.mldadState d `shouldBe` Just Types.MlDataFrameAnalyticsStateStopped + Types.mldadAnalysisType d `shouldBe` Just Types.MlDataFrameAnalysisTypeRegression + Types.mldadCreateTime d `shouldBe` Just (1700000000000 :: Scientific) + -- description is not a typed Document field, so it lands in extras + let extras = Types.mldadExtras d + extras `shouldSatisfy` isJust + forM_ extras $ \km -> + KeyMap.lookup "description" km `shouldBe` Just (String "regress") + Nothing -> expectationFailure "failed to decode document" + + it "folds unknown sibling fields into extras" $ do + let raw = + LBS.pack + "{\"id\":\"x\",\"create_time\":1,\"model_memory_limit\":\"11mb\"}" + case decode raw :: Maybe Types.MlDataFrameAnalyticsDocument of + Just d -> do + Types.mldadId d `shouldBe` Just ("x" :: Text) + extras <- pure (Types.mldadExtras d) + extras `shouldSatisfy` isJust + let Just km = extras + KeyMap.lookup "model_memory_limit" km `shouldSatisfy` isJust + Nothing -> expectationFailure "failed to decode document with extras" + + it "round-trips including extras" $ do + let raw = + LBS.pack + "{\"id\":\"x\",\"state\":\"started\",\"future_field\":42}" + case decode raw :: Maybe Types.MlDataFrameAnalyticsDocument of + Just d -> encode d `shouldSatisfy` (\bs -> decode bs == Just d) + Nothing -> expectationFailure "failed to decode" + + describe "MlDataFrameAnalyticsGetResponse JSON" $ do + it "decodes a list envelope, defaulting count" $ do + let raw = + LBS.pack + "{\"data_frame_analytics\":[{\"id\":\"a\"},{\"id\":\"b\"}]}" + case decode raw :: Maybe Types.MlDataFrameAnalyticsGetResponse of + Just r -> do + length (Types.mldagrAnalytics r) `shouldBe` 2 + Types.mldagrCount r `shouldBe` Just 2 + Nothing -> expectationFailure "failed to decode get response" + + it "decodes an explicit count" $ do + let raw = LBS.pack "{\"count\":5,\"data_frame_analytics\":[]}" + case decode raw :: Maybe Types.MlDataFrameAnalyticsGetResponse of + Just r -> Types.mldagrCount r `shouldBe` Just 5 + Nothing -> expectationFailure "failed to decode get response" + + it "decodes an empty object to count 0, []" $ + case decode (LBS.pack "{}") :: Maybe Types.MlDataFrameAnalyticsGetResponse of + Just r -> do + Types.mldagrCount r `shouldBe` Just 0 + Types.mldagrAnalytics r `shouldBe` [] + Nothing -> expectationFailure "failed to decode empty get response" + + describe "MlDataFrameAnalyticsStatsResponse JSON" $ do + it "decodes a stats envelope, defaulting count" $ do + let raw = + LBS.pack + "{\"data_frame_analytics\":[{\"id\":\"a\",\"state\":\"started\",\ + \\"analysis_type\":\"outlier_detection\",\"progress\":[0.9]}]}" + case decode raw :: Maybe Types.MlDataFrameAnalyticsStatsResponse of + Just r -> do + length (Types.mldasrStats r) `shouldBe` 1 + Types.mldasrCount r `shouldBe` Just 1 + case Types.mldasrStats r of + (s : _) -> do + Types.mldasState s `shouldBe` Just Types.MlDataFrameAnalyticsStateStarted + Types.mldasAnalysisType s `shouldBe` Just Types.MlDataFrameAnalysisTypeOutlierDetection + let Just km = Types.mldasExtras s + KeyMap.size km `shouldBe` 1 + [] -> expectationFailure "expected one stats entry" + Nothing -> expectationFailure "failed to decode stats response" + + describe "MlDataFrameAnalyticsPreviewResponse JSON" $ do + it "decodes an array of row objects" $ do + let raw = + LBS.pack + "[{\"a\":1},{\"a\":2}]" + case decode raw :: Maybe Types.MlDataFrameAnalyticsPreviewResponse of + Just r -> length (Types.mldaprrRows r) `shouldBe` 2 + Nothing -> expectationFailure "failed to decode preview rows" + + it "decodes a non-array body to []" $ + case decode (LBS.pack "{}") :: Maybe Types.MlDataFrameAnalyticsPreviewResponse of + Just r -> Types.mldaprrRows r `shouldBe` [] + Nothing -> expectationFailure "failed to decode non-array preview" + + describe "endpoint shape" $ do + it "PUTs /_ml/data_frame/analytics/ with a body" $ do + let body = + Types.defaultMlDataFrameAnalyticsPutBody + { Types.mldapbSource = + Types.defaultMlDataFrameAnalyticsSource + { Types.mldasIndex = ["source-*"] + } + } + req = RequestsES9.putMlDataFrameAnalytics "myjob" body + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "data_frame", "analytics", "myjob"] + bhRequestBody req `shouldSatisfy` isJust + + it "PUT-With forwards options as query params" $ do + let opts = + Types.defaultMlDataFrameAnalyticsOptions + { Types.mldaoAllowLazyStart = Just True + } + req = + RequestsES9.putMlDataFrameAnalyticsWith + "myjob" + Types.defaultMlDataFrameAnalyticsPutBody + opts + getRawEndpointQueries (bhRequestEndpoint req) `shouldSatisfy` (not . null) + + it "GETs /_ml/data_frame/analytics (all)" $ do + let req = RequestsES9.getMlDataFrameAnalytics Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "data_frame", "analytics"] + + it "GETs /_ml/data_frame/analytics/" $ do + let req = RequestsES9.getMlDataFrameAnalytics (Just "myjob") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "data_frame", "analytics", "myjob"] + + it "GETs /_ml/data_frame/analytics//_stats" $ do + let req = RequestsES9.getMlDataFrameAnalyticsStats (Just "myjob") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "data_frame", "analytics", "myjob", "_stats"] + + it "GETs /_ml/data_frame/analytics/_stats (all)" $ do + let req = RequestsES9.getMlDataFrameAnalyticsStats Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "data_frame", "analytics", "_stats"] + + it "POSTs /_ml/data_frame/analytics//_update" $ do + let req = + RequestsES9.updateMlDataFrameAnalytics + "myjob" + Types.defaultMlDataFrameAnalyticsUpdateBody + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "data_frame", "analytics", "myjob", "_update"] + bhRequestBody req `shouldSatisfy` isJust + + it "DELETEs /_ml/data_frame/analytics/" $ do + let req = RequestsES9.deleteMlDataFrameAnalytics "myjob" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "data_frame", "analytics", "myjob"] + bhRequestBody req `shouldSatisfy` isNothing + + it "POSTs /_ml/data_frame/analytics//_start" $ do + let req = RequestsES9.startMlDataFrameAnalytics "myjob" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "data_frame", "analytics", "myjob", "_start"] + bhRequestBody req `shouldSatisfy` isJust + + it "POSTs /_ml/data_frame/analytics//_stop" $ do + let req = RequestsES9.stopMlDataFrameAnalytics "myjob" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "data_frame", "analytics", "myjob", "_stop"] + + it "POSTs /_ml/data_frame/analytics/_preview with a body" $ do + let req = + RequestsES9.previewMlDataFrameAnalytics $ + Types.MlDataFrameAnalyticsPreviewRequest (object ["id" .= ("x" :: Text)]) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "data_frame", "analytics", "_preview"] + bhRequestBody req `shouldSatisfy` isJust diff --git a/tests/Test/MlTrainedModelsSpec.hs b/tests/Test/MlTrainedModelsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MlTrainedModelsSpec.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MlTrainedModelsSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Scientific (Scientific) +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import Database.Bloodhound.ElasticSearch9.Types qualified as Types +import TestsUtils.Import + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KeyMap.member` obj + _ -> False + +spec :: Spec +spec = + describe "ML trained model APIs (/_ml/trained_models/*)" $ do + describe "MlTrainedModelId JSON" $ do + it "round-trips an id" $ do + let i = Types.MlTrainedModelId "lang_ident_model_1" + decode (encode i) `shouldBe` Just i + + it "unMlTrainedModelId extracts the underlying Text" $ + Types.unMlTrainedModelId (Types.MlTrainedModelId "x") + `shouldBe` ("x" :: Text) + + describe "MlTrainedModelPutBody JSON" $ do + it "encodes a compressed-definition body, omitting optional fields" $ do + let cfg = object ["regression" .= object []] + body = + Types.defaultMlTrainedModelPutBody + { Types.mltmpInferenceConfig = cfg, + Types.mltmpCompressedDefinition = Just "base64blob" + } + hasKey "description" (encode body) `shouldBe` False + hasKey "definition" (encode body) `shouldBe` False + hasKey "compressed_definition" (encode body) `shouldBe` True + decode (encode body) `shouldBe` Just body + + it "decodes a documented create body" $ do + let raw = + LBS.pack + "{\"compressed_definition\":\"Zm9v\",\"description\":\"d\",\ + \\"inference_config\":{\"regression\":{}}}" + case decode raw :: Maybe Types.MlTrainedModelPutBody of + Just b -> do + Types.mltmpCompressedDefinition b `shouldBe` Just ("Zm9v" :: Text) + Types.mltmpDescription b `shouldBe` Just ("d" :: Text) + Nothing -> expectationFailure "failed to decode put body" + + it "defaults a missing inference_config to {}" $ + case decode (LBS.pack "{\"compressed_definition\":\"x\"}") :: Maybe Types.MlTrainedModelPutBody of + Just b -> Types.mltmpInferenceConfig b `shouldBe` object [] + Nothing -> expectationFailure "failed to decode put body" + + describe "MlTrainedModelUpdateBody JSON" $ do + it "encodes to {} when empty" $ + encode Types.defaultMlTrainedModelUpdateBody + `shouldBe` "{}" + + it "round-trips a deprecation update" $ do + let b = + Types.defaultMlTrainedModelUpdateBody + { Types.mltmubDeprecated = Just True + } + decode (encode b) `shouldBe` Just b + + describe "MlTrainedModelOptions params" $ do + it "renders nothing by default" $ + Types.mlTrainedModelOptionsParams Types.defaultMlTrainedModelOptions + `shouldBe` [] + + it "renders deploy-related params in order" $ do + let opts = + Types.defaultMlTrainedModelOptions + { Types.mltooWaitForCompletion = Just True, + Types.mltooPriority = Just "normal", + Types.mltooThreads = Just 4 + } + Types.mlTrainedModelOptionsParams opts + `shouldBe` [ ("wait_for_completion", Just "true"), + ("priority", Just "normal"), + ("threads", Just "4") + ] + + describe "MlTrainedModelConfig JSON" $ do + it "decodes a documented config verbatim" $ do + let raw = + LBS.pack + "{\"model_id\":\"m\",\"created_by\":\"ml\",\"version\":\"17.0.0\",\ + \\"description\":\"d\",\"deprecated\":false,\ + \\"inference_config\":{\"regression\":{}},\ + \\"model_size_bytes\":1024}" + case decode raw :: Maybe Types.MlTrainedModelConfig of + Just c -> do + Types.mltmcModelId c `shouldBe` Just ("m" :: Text) + Types.mltmcDeprecated c `shouldBe` Just False + Types.mltmcInferenceConfig c `shouldSatisfy` isJust + extras <- pure (Types.mltmcExtras c) + extras `shouldSatisfy` isJust + forM_ extras $ \km -> + KeyMap.lookup "model_size_bytes" km `shouldSatisfy` isJust + Nothing -> expectationFailure "failed to decode config" + + describe "MlTrainedModelsResponse JSON" $ do + it "decodes a list envelope, defaulting count" $ do + let raw = + LBS.pack + "{\"trained_model_configs\":[{\"model_id\":\"a\"},{\"model_id\":\"b\"}]}" + case decode raw :: Maybe Types.MlTrainedModelsResponse of + Just r -> do + length (Types.mltrConfigs r) `shouldBe` 2 + Types.mltrCount r `shouldBe` Just 2 + Nothing -> expectationFailure "failed to decode response" + + it "decodes an explicit count" $ do + let raw = LBS.pack "{\"count\":5,\"trained_model_configs\":[]}" + case decode raw :: Maybe Types.MlTrainedModelsResponse of + Just r -> Types.mltrCount r `shouldBe` Just 5 + Nothing -> expectationFailure "failed to decode response" + + describe "MlTrainedModelStatsResponse JSON" $ do + it "decodes a stats envelope, defaulting count" $ do + let raw = + LBS.pack + "{\"trained_model_stats\":[{\"model_id\":\"a\",\"model_size_bytes\":2048}]}" + case decode raw :: Maybe Types.MlTrainedModelStatsResponse of + Just r -> do + length (Types.mltsrStats r) `shouldBe` 1 + Types.mltsrCount r `shouldBe` Just 1 + case Types.mltsrStats r of + (s : _) -> do + Types.mltmsModelId s `shouldBe` Just ("a" :: Text) + let extras = Types.mltmsExtras s + extras `shouldSatisfy` isJust + forM_ extras $ \km -> + KeyMap.size km `shouldBe` 1 + [] -> expectationFailure "expected one stats entry" + Nothing -> expectationFailure "failed to decode stats response" + + describe "MlTrainedModelDefinition JSON" $ do + it "decodes a definition envelope" $ do + let raw = + LBS.pack + "{\"model_id\":\"m\",\"total_definition_length\":2048,\ + \\"model_definition\":{\"trained_model\":{\"tree\":{}}}}" + case decode raw :: Maybe Types.MlTrainedModelDefinition of + Just d -> do + Types.mltmdModelId d `shouldBe` Just ("m" :: Text) + Types.mltmdTotalDefinitionLength d `shouldBe` Just (2048 :: Scientific) + Types.mltmdDefinition d `shouldSatisfy` isJust + Types.mltmdExtras d `shouldBe` Nothing + Nothing -> expectationFailure "failed to decode definition" + + describe "MlTrainedModelInferResponse JSON" $ do + it "round-trips an arbitrary prediction body" $ do + let body = object ["results" .= [object ["predicted_value" .= (1.5 :: Double)]]] + r = Types.MlTrainedModelInferResponse body + decode (encode r) `shouldBe` Just r + + describe "endpoint shape" $ do + it "PUTs /_ml/trained_models/ with a body" $ do + let req = + RequestsES9.putMlTrainedModel + "mymodel" + Types.defaultMlTrainedModelPutBody + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models", "mymodel"] + bhRequestBody req `shouldSatisfy` isJust + + it "GETs /_ml/trained_models (all)" $ do + let req = RequestsES9.getMlTrainedModels Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models"] + + it "GETs /_ml/trained_models/" $ do + let req = RequestsES9.getMlTrainedModels (Just "mymodel") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models", "mymodel"] + + it "GETs /_ml/trained_models//definition" $ do + let req = RequestsES9.getMlTrainedModelDefinition "mymodel" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models", "mymodel", "definition"] + + it "POSTs /_ml/trained_models//_update with a body" $ do + let req = + RequestsES9.updateMlTrainedModel + "mymodel" + Types.defaultMlTrainedModelUpdateBody + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models", "mymodel", "_update"] + bhRequestBody req `shouldSatisfy` isJust + + it "DELETEs /_ml/trained_models/" $ do + let req = RequestsES9.deleteMlTrainedModel "mymodel" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models", "mymodel"] + bhRequestBody req `shouldSatisfy` isNothing + + it "POSTs /_ml/trained_models//deployment/_deploy (empty body)" $ do + let req = RequestsES9.deployMlTrainedModel "mymodel" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models", "mymodel", "deployment", "_deploy"] + bhRequestBody req `shouldSatisfy` isJust + + it "POSTs /_ml/trained_models//deployment/_undeploy" $ do + let req = RequestsES9.undeployMlTrainedModel "mymodel" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models", "mymodel", "deployment", "_undeploy"] + + it "POSTs /_ml/trained_models//deployment/_start" $ do + let req = RequestsES9.startMlTrainedModelDeployment "mymodel" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models", "mymodel", "deployment", "_start"] + + it "POSTs /_ml/trained_models//deployment/_stop" $ do + let req = RequestsES9.stopMlTrainedModelDeployment "mymodel" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models", "mymodel", "deployment", "_stop"] + + it "GETs /_ml/trained_models//_stats" $ do + let req = RequestsES9.getMlTrainedModelStats (Just "mymodel") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models", "mymodel", "_stats"] + + it "GETs /_ml/trained_models/_stats (all)" $ do + let req = RequestsES9.getMlTrainedModelStats Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models", "_stats"] + + it "POSTs /_ml/trained_models//_infer with a body" $ do + let req = + RequestsES9.inferMlTrainedModel + "mymodel" + (Types.MlTrainedModelInferRequest (object ["docs" .= [object ["f" .= (1 :: Int)]]])) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ml", "trained_models", "mymodel", "_infer"] + bhRequestBody req `shouldSatisfy` isJust diff --git a/tests/Test/MultiGetOptionsSpec.hs b/tests/Test/MultiGetOptionsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MultiGetOptionsSpec.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MultiGetOptionsSpec (spec) where + +import Data.List (sort) +import Data.Text qualified as T +import Database.Bloodhound.Common.Types +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +-- | Stable ordering for equality. The renderer preserves field-declaration +-- order but tests should compare the set of params, not the order. +normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] +normalize = sort + +-- | Boolean helpers rendered as @true@/@false@ strings. +boolTrue :: Maybe T.Text +boolTrue = Just "true" + +boolFalse :: Maybe T.Text +boolFalse = Just "false" + +spec :: Spec +spec = + describe "MultiGetOptions URI param rendering" $ do + it "defaultMultiGetOptions emits no params" $ + multiGetOptionsParams defaultMultiGetOptions + `shouldBe` [] + + describe "_source" $ do + it "Just True renders as _source=true" $ do + let opts = defaultMultiGetOptions {mgoSource = Just True} + multiGetOptionsParams opts `shouldBe` [("_source", boolTrue)] + it "Just False renders as _source=false" $ do + let opts = defaultMultiGetOptions {mgoSource = Just False} + multiGetOptionsParams opts `shouldBe` [("_source", boolFalse)] + + it "_source_includes renders verbatim" $ do + let opts = defaultMultiGetOptions {mgoSourceIncludes = Just "metadata.*,name"} + multiGetOptionsParams opts + `shouldBe` [("_source_includes", Just "metadata.*,name")] + + it "_source_excludes renders verbatim" $ do + let opts = defaultMultiGetOptions {mgoSourceExcludes = Just "internal.*"} + multiGetOptionsParams opts + `shouldBe` [("_source_excludes", Just "internal.*")] + + it "stored_fields renders verbatim" $ do + let opts = defaultMultiGetOptions {mgoStoredFields = Just "user,location"} + multiGetOptionsParams opts + `shouldBe` [("stored_fields", Just "user,location")] + + it "preference renders verbatim" $ do + let opts = defaultMultiGetOptions {mgoPreference = Just "_local"} + multiGetOptionsParams opts + `shouldBe` [("preference", Just "_local")] + + describe "realtime" $ do + it "Just True renders as realtime=true" $ do + let opts = defaultMultiGetOptions {mgoRealtime = Just True} + multiGetOptionsParams opts `shouldBe` [("realtime", boolTrue)] + it "Just False renders as realtime=false" $ do + let opts = defaultMultiGetOptions {mgoRealtime = Just False} + multiGetOptionsParams opts `shouldBe` [("realtime", boolFalse)] + + describe "refresh" $ do + it "Just True renders as refresh=true" $ do + let opts = defaultMultiGetOptions {mgoRefresh = Just True} + multiGetOptionsParams opts `shouldBe` [("refresh", boolTrue)] + it "Just False renders as refresh=false" $ do + let opts = defaultMultiGetOptions {mgoRefresh = Just False} + multiGetOptionsParams opts `shouldBe` [("refresh", boolFalse)] + + it "routing renders verbatim" $ do + let opts = defaultMultiGetOptions {mgoRouting = Just "user-42"} + multiGetOptionsParams opts `shouldBe` [("routing", Just "user-42")] + + -- The whole point of the dedicated MultiGetOptions type (vs reusing + -- GetDocumentOptions) is that the multi-get endpoint does NOT accept + -- version/version_type as URI parameters. Pin the absence here so a + -- future refactor cannot silently regress the wire-level bug. + it "never emits version or version_type (not MGET URI params)" $ do + let rendered = multiGetOptionsParams defaultMultiGetOptions + let keys = map fst rendered + keys `shouldSatisfy` not . elem "version" + keys `shouldSatisfy` not . elem "version_type" + + it "renders every field together when all are populated" $ do + let opts = + defaultMultiGetOptions + { mgoSource = Just False, + mgoSourceIncludes = Just "a,b", + mgoSourceExcludes = Just "c", + mgoStoredFields = Just "s", + mgoPreference = Just "_local", + mgoRealtime = Just True, + mgoRefresh = Just False, + mgoRouting = Just "r" + } + let rendered = multiGetOptionsParams opts + -- Exactly the 8 documented MGET URI parameters — no version*, no + -- surprises. + length rendered `shouldBe` 8 + rendered `shouldSatisfy` all (isJust . snd) + normalize rendered + `shouldBe` sort + [ ("_source", Just "false"), + ("_source_excludes", Just "c"), + ("_source_includes", Just "a,b"), + ("preference", Just "_local"), + ("realtime", Just "true"), + ("refresh", Just "false"), + ("routing", Just "r"), + ("stored_fields", Just "s") + ] + where + isJust (Just _) = True + isJust Nothing = False diff --git a/tests/Test/MultiGetSpec.hs b/tests/Test/MultiGetSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MultiGetSpec.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.MultiGetSpec where + +import Data.List (isInfixOf) +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = + describe "multi-get API" $ do + it "fetches multiple documents by ID" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + result <- tryPerformBHRequest $ getDocuments @Tweet testIndex [DocId "1", DocId "2"] + case result of + Left _ -> liftIO $ expectationFailure "Multi-get failed" + Right resp -> do + let docs = multiGetResponseDocs resp + liftIO $ length docs `shouldBe` 2 + + it "returns found status for existing documents" $ + withTestEnv $ do + _ <- insertData + result <- tryPerformBHRequest $ getDocuments @Tweet testIndex [DocId "1"] + case result of + Left _ -> liftIO $ expectationFailure "Multi-get failed" + Right resp -> do + let docs = multiGetResponseDocs resp + liftIO $ length docs `shouldBe` 1 + let firstDoc = head docs + liftIO $ foundResult firstDoc `shouldSatisfy` isJust + + it "returns not found for missing documents" $ + withTestEnv $ do + _ <- insertData + result <- tryPerformBHRequest $ getDocuments @Tweet testIndex [DocId "nonexistent"] + case result of + Left _ -> liftIO $ expectationFailure "Multi-get failed" + Right resp -> do + let docs = multiGetResponseDocs resp + liftIO $ length docs `shouldBe` 1 + let firstDoc = head docs + liftIO $ foundResult firstDoc `shouldBe` Nothing + + it "handles mixed found and not found documents" $ + withTestEnv $ do + _ <- insertData + result <- tryPerformBHRequest $ getDocuments @Tweet testIndex [DocId "1", DocId "nonexistent"] + case result of + Left _ -> liftIO $ expectationFailure "Multi-get failed" + Right resp -> do + let docs = multiGetResponseDocs resp + liftIO $ length docs `shouldBe` 2 + let [firstDoc, secondDoc] = docs + liftIO $ foundResult firstDoc `shouldSatisfy` isJust + liftIO $ foundResult secondDoc `shouldBe` Nothing + + describe "per-document source filtering (MultiGetDoc body)" $ do + it "multiGetDocSource=NoSource omits the source for that document only" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + -- POST /_mget requires _index per-doc since no index is in the URL. + let doc1 = + (mkMultiGetDoc (DocId "1")) + { multiGetDocSource = Just NoSource, + multiGetDocIndex = Just testIndex + } + doc2 = (mkMultiGetDoc (DocId "2")) {multiGetDocIndex = Just testIndex} + body = MultiGet [doc1, doc2] + result <- tryPerformBHRequest $ getDocumentsMulti @Tweet body + case result of + Left _ -> liftIO $ expectationFailure "Multi-get failed" + Right resp -> do + let [firstDoc, secondDoc] = multiGetResponseDocs resp + -- First doc: _source=false per-doc → source absent → foundResult Nothing + -- Second doc: normal → source present + liftIO $ getSource firstDoc `shouldBe` Nothing + liftIO $ getSource secondDoc `shouldBe` Just otherTweet + + it "getDocumentsMultiWith applies MultiGetOptions at URI level" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + let opts = defaultMultiGetOptions {mgoSource = Just False} + doc i = (mkMultiGetDoc (DocId i)) {multiGetDocIndex = Just testIndex} + body = MultiGet (map doc ["1", "2"]) + result <- tryPerformBHRequest $ getDocumentsMultiWith @Tweet opts body + case result of + Left _ -> liftIO $ expectationFailure "Multi-get failed" + Right resp -> do + let docs = multiGetResponseDocs resp + liftIO $ length docs `shouldBe` 2 + -- With _source=false at the URI level, no document should + -- carry a source. + liftIO $ all (isNothing . getSource) docs `shouldBe` True + + it "getDocumentsWith applies MultiGetOptions at URI level" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + let opts = defaultMultiGetOptions {mgoSourceIncludes = Just "user"} + -- Parse as Value so we can inspect the partial source without + -- requiring every Tweet field to be present. + result <- tryPerformBHRequest $ getDocumentsWith @Value opts testIndex [DocId "1", DocId "2"] + case result of + Left _ -> liftIO $ expectationFailure "Multi-get failed" + Right resp -> do + let docs = multiGetResponseDocs resp + liftIO $ length docs `shouldBe` 2 + let firstAsValue = getSource (head docs) + liftIO $ firstAsValue `shouldSatisfy` isJust + -- With _source_includes=user, the re-encoded source should + -- contain exactly the "user" field and nothing else. + case firstAsValue of + Just v -> do + let s = show v + liftIO $ s `shouldSatisfy` isInfixOf "\"user\"" + liftIO $ s `shouldSatisfy` not . isInfixOf "\"age\"" + Nothing -> + liftIO $ expectationFailure "expected a source" diff --git a/tests/Test/MultiSearchSpec.hs b/tests/Test/MultiSearchSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MultiSearchSpec.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.MultiSearchSpec where + +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LC +import Data.Either (rights) +import Data.List (sort) +import Database.Bloodhound.Common.Types +import TestsUtils.Common +import TestsUtils.Import + +-- | Smart constructor that mirrors the pre-bloodhound-04f.7.3 2-field form +-- of 'MultiSearchItem'. Keeps the integration-test fixtures readable while +-- the record itself gains per-header fields. +mkItem :: Maybe IndexName -> Search -> MultiSearchItem +mkItem idx s = + MultiSearchItem + { multiSearchItemIndex = idx, + multiSearchItemRouting = Nothing, + multiSearchItemSearchType = Nothing, + multiSearchItemPreference = Nothing, + multiSearchItemAllowPartialSearchResults = Nothing, + multiSearchItemSearch = s + } + +-- | Decode a ToJSON-encoded value back to a sorted list of key names so the +-- tests can assert on the header line as a set rather than relying on +-- aeson's key ordering. +headerKeys :: LC.ByteString -> [Text] +headerKeys bs = case decode bs :: Maybe Object of + Just o -> sort (map K.toText (KM.keys o)) + Nothing -> error "headerKeys: decode failed" + +spec :: Spec +spec = do + describe "MultiSearchItem ToJSON header rendering" $ do + let bareSearch = mkSearch (Just (MatchAllQuery Nothing)) Nothing + logs = [qqIndexName|logs|] + + it "renders only index when no per-header fields are set" $ do + let item = mkItem (Just logs) bareSearch + encode item `shouldBe` "{\"index\":\"logs\"}" + + it "renders an empty object when no fields (including index) are set" $ do + let item = mkItem Nothing bareSearch + encode item `shouldBe` "{}" + + it "renders routing alongside index" $ do + let item = (mkItem (Just logs) bareSearch) {multiSearchItemRouting = Just "r1"} + headerKeys (encode item) `shouldBe` ["index", "routing"] + + it "renders search_type using the SearchType Text encoding" $ do + let item = (mkItem (Just logs) bareSearch) {multiSearchItemSearchType = Just SearchTypeDfsQueryThenFetch} + encode item `shouldBe` "{\"index\":\"logs\",\"search_type\":\"dfs_query_then_fetch\"}" + + it "renders preference and allow_partial_search_results" $ do + let item = + (mkItem (Just logs) bareSearch) + { multiSearchItemPreference = Just "_local", + multiSearchItemAllowPartialSearchResults = Just False + } + headerKeys (encode item) + `shouldBe` ["allow_partial_search_results", "index", "preference"] + + it "renders every per-header field simultaneously" $ do + let item = + (mkItem (Just logs) bareSearch) + { multiSearchItemRouting = Just "r1", + multiSearchItemSearchType = Just SearchTypeDfsQueryThenFetch, + multiSearchItemPreference = Just "_local", + multiSearchItemAllowPartialSearchResults = Just True + } + -- aeson 2.x renders object keys in alphabetical order; the + -- assertion pins the full wire shape so regressions in either + -- the key set or the value encoding surface here. + encode item + `shouldBe` "{\"allow_partial_search_results\":true,\"index\":\"logs\",\"preference\":\"_local\",\"routing\":\"r1\",\"search_type\":\"dfs_query_then_fetch\"}" + + describe "SearchOptions max_concurrent_searches (msearch URI param)" $ do + it "renders max_concurrent_searches as a decimal string" $ do + let opts = defaultSearchOptions {soMaxConcurrentSearches = Just 8} + searchOptionsParams opts SearchTypeQueryThenFetch + `shouldBe` [("max_concurrent_searches", Just "8")] + + describe "MultiSearchResponse per-item error decoding" $ do + -- No server round-trip: the decoder is exercised directly so the + -- assertions are stable across ES/OS versions and don't depend on + -- a live cluster. The wire shapes mirror what ES returns for a + -- per-item 404 (missing index) and a normal success sub-search. + it "decodes a per-item error as Left EsError" $ do + let perItemError = + LC.pack + "{\"responses\":[{\"error\":\"index_not_found_exception\",\ + \\"status\":404}]}" + let Just (resp :: MultiSearchResponse Tweet) = decode perItemError + multiSearchResponses resp + `shouldBe` [Left (EsError (Just 404) "index_not_found_exception")] + + it "decodes the modern ES error object form (error.reason) as Left EsError" $ do + -- ES 7+ returns per-item errors as objects carrying + -- {"type":..., "reason":...}. EsError's FromJSON p2 alternative + -- extracts .reason as the message. See BHRequest.hs EsError parser. + let perItemErrorObject = + LC.pack + "{\"responses\":[{\"error\":{\"type\":\"index_not_found_exception\",\ + \\"reason\":\"no such index [foo]\",\ + \\"index\":\"foo\"},\"status\":404}]}" + let Just (resp :: MultiSearchResponse Tweet) = decode perItemErrorObject + multiSearchResponses resp + `shouldBe` [Left (EsError (Just 404) "no such index [foo]")] + + it "preserves order when mixing successes and errors" $ do + let mixed = + LC.pack + "{\"responses\":[\ + \{\"took\":1,\"timed_out\":false,\"_shards\":{},\"hits\":{\"total\":{\"value\":0,\"relation\":\"eq\"},\"max_score\":null,\"hits\":[]}},\ + \{\"error\":\"index_not_found_exception\",\"status\":404}\ + \]}" + let Just (resp :: MultiSearchResponse Tweet) = decode mixed + length (multiSearchResponses resp) `shouldBe` 2 + -- Order preserved: first item is a successful SearchResult, the + -- second is a per-item EsError carrying the 404 status. + length (rights (multiSearchResponses resp)) `shouldBe` 1 + length [() | Left _ <- multiSearchResponses resp] `shouldBe` 1 + case multiSearchResponses resp of + [Right _, Left _] -> pure () + _ -> expectationFailure "expected [Right _, Left _] in order" + + it "still decodes an all-success payload as all Right" $ do + let allOk = + LC.pack + "{\"responses\":[\ + \{\"took\":1,\"timed_out\":false,\"_shards\":{},\"hits\":{\"total\":{\"value\":0,\"relation\":\"eq\"},\"max_score\":null,\"hits\":[]}},\ + \{\"took\":2,\"timed_out\":false,\"_shards\":{},\"hits\":{\"total\":{\"value\":0,\"relation\":\"eq\"},\"max_score\":null,\"hits\":[]}}\ + \]}" + let Just (resp :: MultiSearchResponse Tweet) = decode allOk + multiSearchResponses resp `shouldSatisfy` all (either (const False) (const True)) + length (multiSearchResponses resp) `shouldBe` 2 + + describe "multi-search API" $ do + it "executes multiple searches in a single request" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + let query1 = TermQuery (Term "user" "bitemyapp") Nothing + let search1 = mkSearch (Just query1) Nothing + let query2 = TermQuery (Term "user" "notmyapp") Nothing + let search2 = mkSearch (Just query2) Nothing + let items = mkItem Nothing search1 :| [mkItem Nothing search2] + result <- tryPerformBHRequest $ multiSearch @Tweet items + case result of + Left _ -> liftIO $ expectationFailure "Multi-search failed" + Right resp -> do + let responses = multiSearchResponses resp + liftIO $ responses `shouldSatisfy` all (either (const False) (const True)) + liftIO $ length responses `shouldBe` 2 + + it "executes multiple searches on a specific index" $ + withTestEnv $ do + _ <- insertData + let query1 = TermQuery (Term "user" "bitemyapp") Nothing + let search1 = mkSearch (Just query1) Nothing + let query2 = MatchAllQuery Nothing + let search2 = mkSearch (Just query2) Nothing + let searches = search1 :| [search2] + result <- tryPerformBHRequest $ multiSearchByIndex @Tweet testIndex searches + case result of + Left _ -> liftIO $ expectationFailure "Multi-search by index failed" + Right resp -> do + let responses = multiSearchResponses resp + liftIO $ responses `shouldSatisfy` all (either (const False) (const True)) + liftIO $ length responses `shouldBe` 2 + let firstResult = head (rights responses) + let hitsCount = maybe 0 value (hitsTotal (searchHits firstResult)) + liftIO $ hitsCount `shouldSatisfy` (> 0) + + it "handles searches on different indices" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + let query1 = TermQuery (Term "user" "bitemyapp") Nothing + let search1 = mkSearch (Just query1) Nothing + let query2 = TermQuery (Term "user" "notmyapp") Nothing + let search2 = mkSearch (Just query2) Nothing + let items = + mkItem (Just testIndex) search1 + :| [ mkItem (Just testIndex) search2 + ] + result <- tryPerformBHRequest $ multiSearch @Tweet items + case result of + Left _ -> liftIO $ expectationFailure "Multi-search failed" + Right resp -> do + let responses = multiSearchResponses resp + liftIO $ responses `shouldSatisfy` all (either (const False) (const True)) + liftIO $ length responses `shouldBe` 2 + + it "multiSearchWith forwards URI params (max_concurrent_searches, typed_keys)" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + let query1 = TermQuery (Term "user" "bitemyapp") Nothing + let search1 = mkSearch (Just query1) Nothing + let query2 = TermQuery (Term "user" "notmyapp") Nothing + let search2 = mkSearch (Just query2) Nothing + let items = mkItem Nothing search1 :| [mkItem Nothing search2] + opts = + defaultSearchOptions + { soMaxConcurrentSearches = Just 1, + soTypedKeys = Just True + } + result <- tryPerformBHRequest $ multiSearchWith @Tweet opts items + case result of + Left _ -> liftIO $ expectationFailure "Multi-search with options failed" + Right resp -> do + let responses = multiSearchResponses resp + liftIO $ responses `shouldSatisfy` all (either (const False) (const True)) + liftIO $ length responses `shouldBe` 2 + + it "per-header fields land on the header line and are accepted by ES" $ + withTestEnv $ do + _ <- insertData + let query = TermQuery (Term "user" "bitemyapp") Nothing + let search = mkSearch (Just query) Nothing + let item = + (mkItem (Just testIndex) search) + { multiSearchItemPreference = Just "_local", + multiSearchItemSearchType = Just SearchTypeQueryThenFetch, + multiSearchItemAllowPartialSearchResults = Just True + } + result <- tryPerformBHRequest $ multiSearch @Tweet (item :| []) + case result of + Left _ -> liftIO $ expectationFailure "Multi-search with header fields failed" + Right resp -> do + let responses = multiSearchResponses resp + liftIO $ responses `shouldSatisfy` all (either (const False) (const True)) + liftIO $ length responses `shouldBe` 1 diff --git a/tests/Test/MultiSearchTemplateSpec.hs b/tests/Test/MultiSearchTemplateSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/MultiSearchTemplateSpec.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.MultiSearchTemplateSpec where + +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LC +import Data.Either (rights) +import Data.List (sort) +import Database.Bloodhound.Common.Types +import TestsUtils.Common +import TestsUtils.Import + +-- | Smart constructor that mirrors the 2-field form of +-- 'MultiSearchTemplateItem'. Keeps the integration-test fixtures readable +-- while the record itself carries the full per-header field set. +mkItem :: Maybe IndexName -> SearchTemplate -> MultiSearchTemplateItem +mkItem idx t = + MultiSearchTemplateItem + { multiSearchTemplateItemIndex = idx, + multiSearchTemplateItemRouting = Nothing, + multiSearchTemplateItemSearchType = Nothing, + multiSearchTemplateItemPreference = Nothing, + multiSearchTemplateItemAllowPartialSearchResults = Nothing, + multiSearchTemplateItemSearchTemplate = t + } + +-- | Decode a ToJSON-encoded value back to a sorted list of key names so the +-- tests can assert on the header line as a set rather than relying on +-- aeson's key ordering. +headerKeys :: LC.ByteString -> [Text] +headerKeys bs = case Aeson.decode bs :: Maybe Aeson.Object of + Just o -> sort (map K.toText (KM.keys o)) + Nothing -> error "headerKeys: decode failed" + +-- | Split the NDJSON body into its non-empty lines so tests can assert on +-- line count and per-line shape without depending on trailing-newline +-- placement. +bodyLines :: LC.ByteString -> [LC.ByteString] +bodyLines = filter (not . LC.null) . LC.lines + +-- | A canned inline-source template that matches the seeded @Tweet@ in +-- @insertData@ (user = "bitemyapp") when its params are filled in. +matchingInlineTemplate :: SearchTemplate +matchingInlineTemplate = + mkSearchTemplate + (Right (SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } } }")) + templateParams + +-- | Params for 'matchingInlineTemplate', factored out so the same values +-- can be reused for a stored-id variant in an integration test. +templateParams :: TemplateQueryKeyValuePairs +templateParams = + TemplateQueryKeyValuePairs $ + KM.fromList + [ ("my_field", "user"), + ("my_value", "bitemyapp") + ] + +spec :: Spec +spec = do + describe "MultiSearchTemplateItem ToJSON header rendering" $ do + let bareTemplate = matchingInlineTemplate + logs = [qqIndexName|logs|] + + it "renders only index when no per-header fields are set" $ do + let item = mkItem (Just logs) bareTemplate + Aeson.encode item `shouldBe` "{\"index\":\"logs\"}" + + it "renders an empty object when no fields (including index) are set" $ do + let item = mkItem Nothing bareTemplate + Aeson.encode item `shouldBe` "{}" + + it "renders routing alongside index" $ do + let item = (mkItem (Just logs) bareTemplate) {multiSearchTemplateItemRouting = Just "r1"} + headerKeys (Aeson.encode item) `shouldBe` ["index", "routing"] + + it "renders search_type using the SearchType Text encoding" $ do + let item = (mkItem (Just logs) bareTemplate) {multiSearchTemplateItemSearchType = Just SearchTypeDfsQueryThenFetch} + Aeson.encode item + `shouldBe` "{\"index\":\"logs\",\"search_type\":\"dfs_query_then_fetch\"}" + + it "renders preference and allow_partial_search_results" $ do + let item = + (mkItem (Just logs) bareTemplate) + { multiSearchTemplateItemPreference = Just "_local", + multiSearchTemplateItemAllowPartialSearchResults = Just False + } + headerKeys (Aeson.encode item) + `shouldBe` ["allow_partial_search_results", "index", "preference"] + + it "renders every per-header field simultaneously" $ do + let item = + (mkItem (Just logs) bareTemplate) + { multiSearchTemplateItemRouting = Just "r1", + multiSearchTemplateItemSearchType = Just SearchTypeDfsQueryThenFetch, + multiSearchTemplateItemPreference = Just "_local", + multiSearchTemplateItemAllowPartialSearchResults = Just True + } + Aeson.encode item + `shouldBe` "{\"allow_partial_search_results\":true,\"index\":\"logs\",\"preference\":\"_local\",\"routing\":\"r1\",\"search_type\":\"dfs_query_then_fetch\"}" + + describe "encodeMultiSearchTemplateItems NDJSON shape" $ do + let logs = [qqIndexName|logs|] + t1 = matchingInlineTemplate + t2 = + mkSearchTemplate + (Right (SearchTemplateSource "{\"query\":{\"match_all\":{}}}")) + (TemplateQueryKeyValuePairs KM.empty) + + it "produces one header + one body line per item, plus a trailing newline" $ do + let items = mkItem (Just logs) t1 :| [mkItem Nothing t2] + encoded = encodeMultiSearchTemplateItems items + -- 2 items * 2 lines = 4 content newlines, plus the outer + -- wrapper's trailing newline (mirrors 'encodeMultiSearchItems'). + LC.count '\n' encoded `shouldBe` 5 + length (bodyLines encoded) `shouldBe` 4 + + it "every body line decodes to the JSON of one of the input templates" $ do + -- Order-agnostic: the encoder builds the NDJSON stream with a + -- 'foldr', which reverses iteration order, but each (header, body) + -- pair still corresponds to one input item. Asserting on the *set* + -- of body JSONs keeps this test honest without pinning an order + -- that the existing @_msearch@ encoder does not guarantee either. + let items = mkItem (Just logs) t1 :| [mkItem Nothing t2] + encoded = encodeMultiSearchTemplateItems items + lines' = bodyLines encoded + -- Lines 0 and 2 are headers (objects with @index@ at most); + -- lines 1 and 3 are bodies (objects with @source@ or @id@). + body1 = Aeson.decode (lines' !! 1) :: Maybe Aeson.Value + body2 = Aeson.decode (lines' !! 3) :: Maybe Aeson.Value + decodedSet = sort [show body1, show body2] + expectedSet = + sort + [ show (Aeson.decode (Aeson.encode t1) :: Maybe Aeson.Value), + show (Aeson.decode (Aeson.encode t2) :: Maybe Aeson.Value) + ] + decodedSet `shouldBe` expectedSet + + it "the header line matches encode " $ do + -- The header line is the ToJSON of the MultiSearchTemplateItem + -- (header-only, body dropped). Lock the wire shape so a regression + -- in the encoder (e.g. accidentally serialising the SearchTemplate + -- body in the header line) surfaces here. + let item = mkItem (Just logs) t1 + items = item :| [] + encoded = encodeMultiSearchTemplateItems items + lines' = bodyLines encoded + Aeson.decode (head lines') `shouldBe` (Aeson.decode (Aeson.encode item) :: Maybe Aeson.Value) + + describe "multi-search template API" $ do + it "executes a single inline-source template by index" $ + withTestEnv $ do + _ <- insertData + result <- + tryPerformBHRequest $ + multiSearchTemplateByIndex @Tweet testIndex (matchingInlineTemplate :| []) + case result of + Left _ -> liftIO $ expectationFailure "multi-search template by index failed" + Right resp -> do + let responses = multiSearchResponses resp + liftIO $ responses `shouldSatisfy` all (either (const False) (const True)) + liftIO $ length responses `shouldBe` 1 + let firstResult = head (rights responses) + let myTweet = grabFirst firstResult + liftIO $ myTweet `shouldBe` Right exampleTweet + + it "executes multiple templates in a single request" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + let otherTemplate = + mkSearchTemplate + (Right (SearchTemplateSource "{\"query\":{\"match_all\":{}}}")) + (TemplateQueryKeyValuePairs KM.empty) + items = mkItem (Just testIndex) matchingInlineTemplate :| [mkItem (Just testIndex) otherTemplate] + result <- tryPerformBHRequest $ multiSearchTemplate @Tweet items + case result of + Left _ -> liftIO $ expectationFailure "multi-search template failed" + Right resp -> do + let responses = multiSearchResponses resp + liftIO $ responses `shouldSatisfy` all (either (const False) (const True)) + liftIO $ length responses `shouldBe` 2 + let myTweet = grabFirst (head (rights responses)) + liftIO $ myTweet `shouldBe` Right exampleTweet + + it "resolves a stored template id alongside an inline source" $ + withTestEnv $ do + _ <- insertData + let tid = SearchTemplateId "bh-msearch-template-spec" + _ <- performBHRequest $ storeSearchTemplate tid (SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } } }") + let storedTemplate = mkSearchTemplate (Left tid) templateParams + items = mkItem (Just testIndex) matchingInlineTemplate :| [mkItem (Just testIndex) storedTemplate] + result <- tryPerformBHRequest $ multiSearchTemplate @Tweet items + -- cleanup before assertions so a later re-run doesn't see a stale script + _ <- performBHRequest $ deleteSearchTemplate tid + case result of + Left _ -> liftIO $ expectationFailure "multi-search template with stored id failed" + Right resp -> do + let responses = multiSearchResponses resp + liftIO $ responses `shouldSatisfy` all (either (const False) (const True)) + liftIO $ length responses `shouldBe` 2 + let myTweet = grabFirst (head (rights responses)) + liftIO $ myTweet `shouldBe` Right exampleTweet + + it "multiSearchTemplateWith forwards URI params (max_concurrent_searches, typed_keys)" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + let otherTemplate = + mkSearchTemplate + (Right (SearchTemplateSource "{\"query\":{\"match_all\":{}}}")) + (TemplateQueryKeyValuePairs KM.empty) + -- Index-pinned items: the cluster has system indices (e.g. + -- @.tasks@) whose documents do not decode as 'Tweet', so a + -- cluster-wide @match_all@ template would trip a parse + -- exception in the response decoder. Pinning to 'testIndex' + -- keeps the @match_all@ template scoped to twitter docs. + items = mkItem (Just testIndex) matchingInlineTemplate :| [mkItem (Just testIndex) otherTemplate] + opts = + defaultSearchOptions + { soMaxConcurrentSearches = Just 1, + soTypedKeys = Just True + } + result <- tryPerformBHRequest $ multiSearchTemplateWith @Tweet opts items + case result of + Left _ -> liftIO $ expectationFailure "multi-search template with options failed" + Right resp -> do + let responses = multiSearchResponses resp + liftIO $ responses `shouldSatisfy` all (either (const False) (const True)) + liftIO $ length responses `shouldBe` 2 + + it "per-header fields land on the header line and are accepted by ES" $ + withTestEnv $ do + _ <- insertData + let item = + (mkItem (Just testIndex) matchingInlineTemplate) + { multiSearchTemplateItemPreference = Just "_local", + multiSearchTemplateItemSearchType = Just SearchTypeQueryThenFetch, + multiSearchTemplateItemAllowPartialSearchResults = Just True + } + result <- tryPerformBHRequest $ multiSearchTemplate @Tweet (item :| []) + case result of + Left _ -> liftIO $ expectationFailure "multi-search template with header fields failed" + Right resp -> do + let responses = multiSearchResponses resp + liftIO $ responses `shouldSatisfy` all (either (const False) (const True)) + liftIO $ length responses `shouldBe` 1 diff --git a/tests/Test/NeuralClearCacheSpec.hs b/tests/Test/NeuralClearCacheSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/NeuralClearCacheSpec.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.NeuralClearCacheSpec (spec) where + +import Database.Bloodhound.OpenSearch3.Client qualified as OS3.Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- | Pure endpoint-shape tests for the Neural Search plugin Clear Cache API +-- (@POST /_plugins/_neural/clear_cache\/{index}@) for OpenSearch 3. These +-- mirror 'Test.NeuralWarmupSpec's shape tests but assert the +-- @\/_plugins\/_neural\/clear_cache@ path, the POST method, and the +-- empty-object body. JSON decoding of the shared 'ShardsResult' response +-- is re-verified here on the clear-cache response shape +-- (@{\"_shards\":{...}}@). The wire shape for the neural clear-cache API +-- is live-verified against OS 3.7.0 in bead bloodhound-at5. The +-- neural-sparse clear-cache route is OS 3.x only: OS 1.3.x does not ship +-- the neural-search plugin (bloodhound-ie4j) and OS 2.19.5 does not +-- register the route or the sparse_vector field type (bloodhound-sh7o), +-- so neither OS1 nor OS2 ships a builder and no cross-backend parity +-- block is meaningful. +spec :: Spec +spec = describe "Neural Clear Cache API" $ do + describe "clearNeuralCache endpoint shape (OpenSearch 3)" $ do + it "POSTs to /_plugins/_neural/clear_cache/{index} when given an IndexName" $ do + let req = OS3Requests.clearNeuralCache [[qqIndexName|my-index|]] + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "clear_cache", "my-index"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches an empty JSON object as the body" $ do + let req = OS3Requests.clearNeuralCache [[qqIndexName|my-index|]] + bhRequestBody req `shouldBe` Just (encode (object [])) + + it "uses a distinct index in the path when given a different IndexName" $ do + let req = OS3Requests.clearNeuralCache [[qqIndexName|other-index|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "clear_cache", "other-index"] + + it "keeps the index name as a single opaque path segment" $ do + let req = OS3Requests.clearNeuralCache [[qqIndexName|my-index_42|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "clear_cache", "my-index_42"] + + -- ---------------------------------------------------------------- -- + -- Multi-index (comma-separated) path rendering: bloodhound-6jy. -- + -- The Neural Clear Cache API documents comma-separated lists and -- + -- index patterns in the {index} path segment; the [IndexName] -- + -- argument is rendered as a single comma-joined segment, matching -- + -- the OpenSearch multi-target syntax. -- + -- ---------------------------------------------------------------- -- + describe "clearNeuralCache multi-index path rendering (OpenSearch 3)" $ do + it "renders [i1,i2,i3] as a single comma-joined path segment" $ do + let req = + OS3Requests.clearNeuralCache + [[qqIndexName|index1|], [qqIndexName|index2|], [qqIndexName|index3|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "clear_cache", "index1,index2,index3"] + + it "preserves index name order in the comma-joined segment" $ do + let req = + OS3Requests.clearNeuralCache + [[qqIndexName|zebra|], [qqIndexName|alpha|], [qqIndexName|mike|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "clear_cache", "zebra,alpha,mike"] + + it "renders an empty segment for an empty index list (server will error)" $ do + let req = OS3Requests.clearNeuralCache [] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "clear_cache", ""] + + describe "clearNeuralCache is distinct from warmupNeuralIndex" $ do + -- Guards against an accidental copy-paste regression where + -- clearNeuralCache silently re-uses the warmup endpoint. The two APIs + -- share an identical wire shape (POST + empty body + ShardsResult + -- response), differing only in the @warmup@ vs @clear_cache@ path + -- segment, so the path is the single distinguishing feature. + let idx = [qqIndexName|shared-index|] + + it "OS3 clear_cache path differs from warmup path" $ do + let clearPath = getRawEndpoint (bhRequestEndpoint (OS3Requests.clearNeuralCache [idx])) + warmupPath = getRawEndpoint (bhRequestEndpoint (OS3Requests.warmupNeuralIndex [idx])) + clearPath `shouldNotBe` warmupPath + + describe "ShardsResult response decoding" $ do + -- Pure unit tests (no OS round-trip): lock the 'FromJSON ShardsResult' + -- decoder against the wire shape returned by + -- @POST /_plugins/_neural/clear_cache\/{index}@. Live OS 3.7.0 + -- confirmed the response is the @_shards@ envelope + -- (@{"_shards":{"total":2,"successful":1,"failed":0}}@), matching + -- the warmup response shape (bead bloodhound-at5). + it "decodes {\"_shards\":{\"total\":2,\"successful\":1,\"skipped\":0,\"failed\":0}} into ShardsResult" $ do + let payload = "{\"_shards\":{\"total\":2,\"successful\":1,\"skipped\":0,\"failed\":0}}" + Just decoded = decode payload :: Maybe ShardsResult + decoded `shouldBe` ShardsResult (ShardResult 2 1 0 0) + + it "rejects a payload missing the _shards envelope" $ do + let payload = "{\"acknowledged\":true}" + decoded = decode payload :: Maybe ShardsResult + decoded `shouldBe` Nothing + + -- ---------------------------------------------------------------- -- + -- Live round-trip: gated per-OS with os{n}OnlyIT (the -- + -- 'Test.KnnClearCacheSpec' pattern). -- + -- -- + -- Wire shape live-verified against OS 3.7.0 (port 9205) in bead -- + -- bloodhound-at5: the response is -- + -- @{"_shards":{"total":2,"successful":1,"failed":0}}@ — the -- + -- @_shards@ envelope, decoded into 'ShardsResult'. The endpoint -- + -- requires an index with @index.sparse: true@ and a @sparse_vector@ -- + -- field mapping. -- + -- -- + -- The neural-sparse clear-cache route is OS 3.x only: OS 1.3.x does -- + -- not ship the neural-search plugin (bloodhound-ie4j), and OS 2.19.5 -- + -- does not register the clear-cache route or the @sparse_vector@ -- + -- field type (bloodhound-sh7o), so the live round-trip can only be -- + -- exercised on OS 3. -- + -- ---------------------------------------------------------------- -- + describe "clearNeuralCache live round-trip" $ do + os3It <- runIO os3OnlyIT + + let assertShards :: ShardsResult -> IO () + assertShards (ShardsResult sr) = do + shardTotal sr `shouldSatisfy` (>= 1) + shardsFailed sr `shouldBe` 0 + + os3It "OS3: returns a ShardsResult with at least one shard and no failures" $ + withTestEnv $ do + _ <- tryEsError resetOsNeuralSparseIndex + _ <- OS3.Client.warmupNeuralIndex osNeuralSparseTestIndex + result <- OS3.Client.clearNeuralCache osNeuralSparseTestIndex + liftIO $ assertShards result diff --git a/tests/Test/NeuralQuerySpec.hs b/tests/Test/NeuralQuerySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/NeuralQuerySpec.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Pure-JSON tests for the OpenSearch @neural@ query clause. +-- +-- These tests do not require a running OpenSearch instance; they verify +-- that 'NeuralQuery' (and the 'QueryNeuralQuery' arm of 'Query') serialize +-- to the JSON shape documented at +-- +-- and round-trip through 'ToJSON' \/ 'FromJSON'. +module Test.NeuralQuerySpec (spec) where + +import Data.Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.Key qualified as AK +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as LBS +import Data.Maybe (fromJust) +import Data.Text (Text) +import Database.Bloodhound.Types + ( FieldName (..), + NeuralQuery (..), + NeuralQueryInput (..), + NeuralQueryTermination (..), + Query (..), + mkNeuralQuery, + mkNeuralQueryByMaxDistance, + mkNeuralQueryByMinScore, + ) +import Test.Hspec (Spec, describe, it, shouldBe, shouldNotSatisfy, shouldSatisfy) + +textField :: FieldName +textField = FieldName "passage_embedding" + +imageField :: FieldName +imageField = FieldName "image_embedding" + +modelId :: Text +modelId = "aVeifm3sBaaSkm0rKKxQ" + +-- | Walk into a nested dict path, returning the inner Value if reachable. +walk :: [Key] -> Value -> Maybe Value +walk [] v = Just v +walk (k : ks) (Object obj) = case KM.lookup k obj of + Just v -> walk ks v + Nothing -> Nothing +walk _ _ = Nothing + +-- | True iff the encoded NeuralQuery produces the OS-correct shape +-- @{"neural": {: {...}}}@ with the field name as a dict key. +hasNeuralNestedUnderField :: FieldName -> Value -> Bool +hasNeuralNestedUnderField (FieldName f) (Object obj) = + case KM.lookup "neural" obj of + Just (Object neuralObj) -> KM.member (AK.fromText f) neuralObj + _ -> False +hasNeuralNestedUnderField _ _ = False + +-- | Bytestring variant for direct use with @\`shouldSatisfy\`@ on @encode@ output. +hasNeuralNestedUnderFieldBS :: FieldName -> LBS.ByteString -> Bool +hasNeuralNestedUnderFieldBS field bs = + case decode bs of + Just v -> hasNeuralNestedUnderField field v + Nothing -> False + +spec :: Spec +spec = describe "Neural query clause (OpenSearch)" $ do + describe "NeuralQuery body shape (text input)" $ do + it "serializes as neural. with the field name as the dict key" $ do + let clause = mkNeuralQuery textField (NeuralTextInput "hello world") modelId 5 + let json = encode clause + json `shouldSatisfy` hasKey "neural" + json `shouldSatisfy` hasNeuralNestedUnderFieldBS textField + + it "emits query_text (not query_image) for text input" $ do + let clause = mkNeuralQuery textField (NeuralTextInput "hello world") modelId 5 + let Just (Object body) = walk ["neural", AK.fromText "passage_embedding"] (fromJust (decode (encode clause))) + KM.lookup "query_text" body `shouldBe` Just (String "hello world") + body `shouldNotSatisfy` KM.member "query_image" + + it "omits boost when not set" $ do + let clause = mkNeuralQuery textField (NeuralTextInput "hello world") modelId 5 + let Just (Object body) = walk ["neural", AK.fromText "passage_embedding"] (fromJust (decode (encode clause))) + body `shouldNotSatisfy` KM.member "boost" + + it "includes boost when set" $ do + let clause = (mkNeuralQuery textField (NeuralTextInput "hello world") modelId 5) {neuralBoost = Just 1.5} + let Just (Object body) = walk ["neural", AK.fromText "passage_embedding"] (fromJust (decode (encode clause))) + KM.lookup "boost" body `shouldBe` Just (toJSON (1.5 :: Double)) + + describe "NeuralQuery body shape (image input)" $ do + it "emits query_image (not query_text) for image input" $ do + let clause = mkNeuralQuery imageField (NeuralImageInput "iVBORw0KGgo...") modelId 3 + let Just (Object body) = walk ["neural", AK.fromText "image_embedding"] (fromJust (decode (encode clause))) + KM.lookup "query_image" body `shouldBe` Just (String "iVBORw0KGgo...") + body `shouldNotSatisfy` KM.member "query_text" + + describe "NeuralQuery radial-search variants" $ do + it "max_distance variant emits max_distance and no k in the clause body" $ do + let clause = mkNeuralQueryByMaxDistance textField (NeuralTextInput "hello") modelId 1.5 + let Just (Object body) = walk ["neural", AK.fromText "passage_embedding"] (fromJust (decode (encode clause))) + KM.lookup "max_distance" body `shouldBe` Just (toJSON (1.5 :: Double)) + body `shouldNotSatisfy` KM.member "k" + body `shouldNotSatisfy` KM.member "min_score" + + it "min_score variant emits min_score and no k in the clause body" $ do + let clause = mkNeuralQueryByMinScore textField (NeuralTextInput "hello") modelId 0.8 + let Just (Object body) = walk ["neural", AK.fromText "passage_embedding"] (fromJust (decode (encode clause))) + KM.lookup "min_score" body `shouldBe` Just (toJSON (0.8 :: Double)) + body `shouldNotSatisfy` KM.member "k" + body `shouldNotSatisfy` KM.member "max_distance" + + it "k variant still emits k (regression)" $ do + let clause = mkNeuralQuery textField (NeuralTextInput "hello") modelId 5 + let Just (Object body) = walk ["neural", AK.fromText "passage_embedding"] (fromJust (decode (encode clause))) + KM.lookup "k" body `shouldBe` Just (toJSON (5 :: Int)) + body `shouldNotSatisfy` KM.member "max_distance" + body `shouldNotSatisfy` KM.member "min_score" + + describe "NeuralQuery round-trip" $ do + it "round-trips a minimal text+k query through ToJSON/FromJSON" $ do + let clause = mkNeuralQuery textField (NeuralTextInput "hello") modelId 5 + decode (encode clause) `shouldBe` Just clause + + it "round-trips an image+k query through ToJSON/FromJSON" $ do + let clause = mkNeuralQuery imageField (NeuralImageInput "iVBORw0KGgo...") modelId 3 + decode (encode clause) `shouldBe` Just clause + + it "round-trips a fully-populated text+k query (with boost)" $ do + let clause = + (mkNeuralQuery textField (NeuralTextInput "hello") modelId 5) + { neuralBoost = Just 1.5 + } + decode (encode clause) `shouldBe` Just clause + + it "round-trips a radial max_distance query" $ do + let clause = mkNeuralQueryByMaxDistance textField (NeuralTextInput "hello") modelId 1.5 + decode (encode clause) `shouldBe` Just clause + + it "round-trips a radial min_score query" $ do + let clause = mkNeuralQueryByMinScore textField (NeuralTextInput "hello") modelId 0.8 + decode (encode clause) `shouldBe` Just clause + + describe "NeuralQueryInput and NeuralQueryTermination" $ do + it "NeuralTextInput round-trips" $ do + let input = NeuralTextInput "hello" + decode (encode input) `shouldBe` Just input + + it "NeuralImageInput round-trips" $ do + let input = NeuralImageInput "iVBORw0KGgo..." + decode (encode input) `shouldBe` Just input + + it "NeuralTerminationByK round-trips" $ do + let term = NeuralTerminationByK 5 + decode (encode term) `shouldBe` Just term + + it "NeuralTerminationByMaxDistance round-trips" $ do + let term = NeuralTerminationByMaxDistance 1.5 + decode (encode term) `shouldBe` Just term + + it "NeuralTerminationByMinScore round-trips" $ do + let term = NeuralTerminationByMinScore 0.8 + decode (encode term) `shouldBe` Just term + + it "rejects NeuralQueryInput with neither query_text nor query_image" $ do + let bad = object ["something_else" .= String "x"] + (decode (encode bad) :: Maybe NeuralQueryInput) `shouldBe` Nothing + + it "rejects NeuralQueryTermination with no k/max_distance/min_score" $ do + let bad = object ["unrelated" .= Number 1] + (decode (encode bad) :: Maybe NeuralQueryTermination) `shouldBe` Nothing + + describe "Query sum type integration" $ do + it "QueryNeuralQuery wraps the clause under the \"neural\" key" $ do + let inner = mkNeuralQuery textField (NeuralTextInput "hello") modelId 5 + let wrapped = QueryNeuralQuery inner + let json = encode wrapped + json `shouldSatisfy` \bs -> case decode bs of + Just (Object obj) -> KM.member "neural" obj + _ -> False + + -- Regression guard for the double-wrap bug: the Query wrapper must NOT + -- re-wrap the leaf (which already self-wraps under "neural"). The + -- wire shape must be exactly {"neural": {: {...}}}, not + -- {"neural": {"neural": {: {...}}}}. + it "QueryNeuralQuery does NOT double-wrap the leaf neural key" $ do + let inner = mkNeuralQuery textField (NeuralTextInput "hello") modelId 5 + let json = encode (QueryNeuralQuery inner) + let Just (Object outer) = decode json + Just (Object neuralObj) = KM.lookup "neural" outer + -- The inner object must be field-keyed (NOT re-keyed under "neural"). + neuralObj `shouldNotSatisfy` KM.member "neural" + neuralObj `shouldSatisfy` KM.member (AK.fromText "passage_embedding") + + -- Walk-into-body assertion: the body shape under obj.neural. + -- must match the OS-correct clause body. This is the test that would + -- have caught the double-wrap bug. + it "QueryNeuralQuery produces OS-correct body shape under neural." $ do + let inner = mkNeuralQuery textField (NeuralTextInput "hello") modelId 5 + let Just (Object body) = walk ["neural", AK.fromText "passage_embedding"] (fromJust (decode (encode (QueryNeuralQuery inner)))) + KM.lookup "query_text" body `shouldBe` Just (String "hello") + KM.lookup "model_id" body `shouldBe` Just (String modelId) + KM.lookup "k" body `shouldBe` Just (toJSON (5 :: Int)) + + it "QueryNeuralQuery preserves boost in the body shape" $ do + let inner = (mkNeuralQuery textField (NeuralTextInput "hello") modelId 5) {neuralBoost = Just 2.0} + let Just (Object body) = walk ["neural", AK.fromText "passage_embedding"] (fromJust (decode (encode (QueryNeuralQuery inner)))) + KM.lookup "boost" body `shouldBe` Just (toJSON (2.0 :: Double)) + + it "QueryNeuralQuery round-trips through the parent Query sum type" $ do + let inner = mkNeuralQuery textField (NeuralTextInput "hello") modelId 5 + let wrapped = QueryNeuralQuery inner + decode (encode wrapped) `shouldBe` Just wrapped + + it "QueryNeuralQuery round-trips with boost set" $ do + let inner = + (mkNeuralQuery textField (NeuralTextInput "hello") modelId 5) + { neuralBoost = Just 2.0 + } + let wrapped = QueryNeuralQuery inner + decode (encode wrapped) `shouldBe` Just wrapped + + -- End-to-end: an OS-shaped wire JSON decodes to the expected Query. + -- Pre-fix, this returned Nothing because the decoder expected the + -- double-wrapped shape; post-fix, it succeeds. + it "decodes a real OS-shaped neural wire JSON" $ do + let wire = "{\"neural\":{\"passage_embedding\":{\"query_text\":\"hello\",\"model_id\":\"aVeifm3sBaaSkm0rKKxQ\",\"k\":5}}}" + let expected = QueryNeuralQuery (mkNeuralQuery textField (NeuralTextInput "hello") modelId 5) + (decode wire :: Maybe Query) `shouldBe` Just expected + + it "distinguishes neural from neural_sparse in the parser" $ do + let inner = mkNeuralQuery textField (NeuralTextInput "hello") modelId 5 + let wrapped = QueryNeuralQuery inner + let Just (Object obj) = decode (encode wrapped) + obj `shouldSatisfy` KM.member "neural" + obj `shouldNotSatisfy` KM.member "neural_sparse" + + it "rejects neural clause with multiple field keys" $ do + let bad = + object + [ "neural" + .= object + [ "field_a" .= object ["query_text" .= String "x", "model_id" .= String "m", "k" .= Number 1], + "field_b" .= object ["query_text" .= String "y", "model_id" .= String "m", "k" .= Number 1] + ] + ] + (decode (encode bad) :: Maybe NeuralQuery) `shouldBe` Nothing + + it "rejects neural clause with no field key" $ do + let bad = object ["neural" .= object []] + (decode (encode bad) :: Maybe NeuralQuery) `shouldBe` Nothing + + it "rejects neural clause with no termination field" $ do + let bad = + object + [ "neural" + .= object + [ "passage_embedding" + .= object + [ "query_text" .= String "x", + "model_id" .= String "m" + ] + ] + ] + (decode (encode bad) :: Maybe NeuralQuery) `shouldBe` Nothing + +-- | 'hasKey' helper mirroring 'KnnOs3Spec' style: takes a 'Key' and a raw +-- encoded 'LBS.ByteString', decoding internally. +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False diff --git a/tests/Test/NeuralSearchSpec.hs b/tests/Test/NeuralSearchSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/NeuralSearchSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.NeuralSearchSpec (spec) where + +import Data.Aeson (Value) +import Database.Bloodhound.Common.Requests qualified as Common +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- | Pure endpoint-shape tests for the Neural Search wrapper. Neural +-- search is /not/ a dedicated route: it targets the standard +-- @POST \/{indices}\/_search@ endpoint (or @POST /_search@ when no +-- indices are supplied), with a @neural@ clause carried in the 'Search' +-- body. The supplied index list is therefore rendered as a comma-joined +-- path segment, exactly as in 'searchByIndices', rather than as a query +-- parameter. These tests pin down the path composition for both the +-- empty and non-empty branches so that a regression is caught here. +spec :: Spec +spec = describe "Neural Search API (OS3 wrapper)" $ do + describe "neuralSearch endpoint shape" $ do + it "POSTs to /_search with no query when indices is empty" $ do + let req = OS3Requests.neuralSearch @Value [] (Common.mkSearch Nothing Nothing) + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches the serialized Search body" $ do + let search = Common.mkSearch Nothing Nothing + let req = OS3Requests.neuralSearch @Value [] search + bhRequestBody req `shouldBe` Just (encode search) + + it "puts the single index in the path (/index/_search) with no query" $ do + let req = OS3Requests.neuralSearch @Value [[qqIndexName|my-index|]] (Common.mkSearch Nothing Nothing) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["my-index", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "comma-joins multiple index names as a single path segment" $ do + let req = + OS3Requests.neuralSearch + @Value + [[qqIndexName|idx-a|], [qqIndexName|idx-b|], [qqIndexName|idx-c|]] + (Common.mkSearch Nothing Nothing) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["idx-a,idx-b,idx-c", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the POST method regardless of the index list" $ do + let req = OS3Requests.neuralSearch @Value [[qqIndexName|foo|]] (Common.mkSearch Nothing Nothing) + bhRequestMethod req `shouldBe` "POST" diff --git a/tests/Test/NeuralSparseQuerySpec.hs b/tests/Test/NeuralSparseQuerySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/NeuralSparseQuerySpec.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Pure-JSON tests for the OpenSearch @neural_sparse@ query clause. +-- +-- These tests do not require a running OpenSearch instance; they verify +-- that 'NeuralSparseQuery' (and the 'QueryNeuralSparseQuery' arm of +-- 'Query') serialize to the JSON shape documented at +-- +-- and round-trip through 'ToJSON' \/ 'FromJSON'. +module Test.NeuralSparseQuerySpec (spec) where + +import Data.Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.Key qualified as AK +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as M +import Data.Maybe (fromJust) +import Data.Text (Text) +import Database.Bloodhound.Types + ( FieldName (..), + NeuralSparseInput (..), + NeuralSparseMethodParameters (..), + NeuralSparseModelSource (..), + NeuralSparseQuery (..), + Query (..), + mkNeuralSparseQueryText, + mkNeuralSparseQueryTextAnalyzer, + mkNeuralSparseQueryTokens, + mkNeuralSparseQueryTokensAnalyzer, + ) +import Test.Hspec (Spec, describe, it, shouldBe, shouldNotSatisfy, shouldSatisfy) + +textField :: FieldName +textField = FieldName "passage_embedding" + +sparseVectorField :: FieldName +sparseVectorField = FieldName "sparse_embedding" + +modelId :: Text +modelId = "aP2Q8ooBpBj3wT4HVS8a" + +analyzer :: Text +analyzer = "bert-uncased" + +sampleTokens :: Map Text Double +sampleTokens = + M.fromList + [ ("hello", 3.3210192), + ("world", 2.6087382) + ] + +-- | Walk into a nested dict path, returning the inner Value if reachable. +walk :: [Key] -> Value -> Maybe Value +walk [] v = Just v +walk (k : ks) (Object obj) = case KM.lookup k obj of + Just v -> walk ks v + Nothing -> Nothing +walk _ _ = Nothing + +-- | True iff the encoded NeuralSparseQuery produces the OS-correct shape +-- @{"neural_sparse": {: {...}}}@ with the field name as a dict key. +hasNeuralSparseNestedUnderField :: FieldName -> Value -> Bool +hasNeuralSparseNestedUnderField (FieldName f) (Object obj) = + case KM.lookup "neural_sparse" obj of + Just (Object neuralObj) -> KM.member (AK.fromText f) neuralObj + _ -> False +hasNeuralSparseNestedUnderField _ _ = False + +-- | Bytestring variant for direct use with @\`shouldSatisfy\`@ on @encode@ output. +hasNeuralSparseNestedUnderFieldBS :: FieldName -> LBS.ByteString -> Bool +hasNeuralSparseNestedUnderFieldBS field bs = + case decode bs of + Just v -> hasNeuralSparseNestedUnderField field v + Nothing -> False + +-- | Lookup the inner clause body for a given field name. +clauseBody :: FieldName -> Value -> Maybe Value +clauseBody (FieldName f) v = + walk ["neural_sparse", AK.fromText f] v + +-- | True iff the encoded value is an Object containing the given key. +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +spec :: Spec +spec = describe "Neural Sparse query clause (OpenSearch)" $ do + describe "NeuralSparseQuery body shape (text input, model_id)" $ do + it "serializes as neural_sparse. with the field name as the dict key" $ do + let clause = mkNeuralSparseQueryText textField "Hi world" modelId + let json = encode clause + json `shouldSatisfy` hasKey "neural_sparse" + json `shouldSatisfy` hasNeuralSparseNestedUnderFieldBS textField + + it "emits query_text for text input" $ do + let clause = mkNeuralSparseQueryText textField "Hi world" modelId + let Just (Object body) = clauseBody textField (fromJust (decode (encode clause))) + KM.lookup "query_text" body `shouldBe` Just (String "Hi world") + body `shouldNotSatisfy` KM.member "query_tokens" + + it "emits model_id when set" $ do + let clause = mkNeuralSparseQueryText textField "Hi world" modelId + let Just (Object body) = clauseBody textField (fromJust (decode (encode clause))) + KM.lookup "model_id" body `shouldBe` Just (String modelId) + body `shouldNotSatisfy` KM.member "analyzer" + + it "omits method_parameters when not set" $ do + let clause = mkNeuralSparseQueryText textField "Hi world" modelId + let Just (Object body) = clauseBody textField (fromJust (decode (encode clause))) + body `shouldNotSatisfy` KM.member "method_parameters" + + it "never emits the deprecated max_token_score field" $ do + let clause = mkNeuralSparseQueryText textField "Hi world" modelId + let Just (Object body) = clauseBody textField (fromJust (decode (encode clause))) + body `shouldNotSatisfy` KM.member "max_token_score" + + describe "NeuralSparseQuery body shape (text input, analyzer)" $ do + it "emits analyzer when set" $ do + let clause = mkNeuralSparseQueryTextAnalyzer textField "Hi world" analyzer + let Just (Object body) = clauseBody textField (fromJust (decode (encode clause))) + KM.lookup "analyzer" body `shouldBe` Just (String analyzer) + body `shouldNotSatisfy` KM.member "model_id" + + describe "NeuralSparseQuery body shape (tokens input)" $ do + it "emits query_tokens (not query_text) for raw token input" $ do + let clause = mkNeuralSparseQueryTokens textField sampleTokens modelId + let Just (Object body) = clauseBody textField (fromJust (decode (encode clause))) + case KM.lookup "query_tokens" body of + Just (Object _) -> pure () + other -> fail $ "expected query_tokens object, got " ++ show other + body `shouldNotSatisfy` KM.member "query_text" + + it "serializes the token weights as a string-keyed map" $ do + let clause = mkNeuralSparseQueryTokens textField sampleTokens modelId + let Just (Object body) = clauseBody textField (fromJust (decode (encode clause))) + case KM.lookup "query_tokens" body of + Just (Object tokensObj) -> do + KM.lookup "hello" tokensObj `shouldBe` Just (toJSON (3.3210192 :: Double)) + KM.lookup "world" tokensObj `shouldBe` Just (toJSON (2.6087382 :: Double)) + other -> fail $ "expected query_tokens object, got " ++ show other + + it "supports analyzer source with token input" $ do + let clause = mkNeuralSparseQueryTokensAnalyzer textField sampleTokens analyzer + let Just (Object body) = clauseBody textField (fromJust (decode (encode clause))) + KM.lookup "analyzer" body `shouldBe` Just (String analyzer) + body `shouldNotSatisfy` KM.member "model_id" + + describe "NeuralSparseQuery body shape (default analyzer)" $ do + it "omits both model_id and analyzer when no source is set" $ do + let clause = + (mkNeuralSparseQueryText textField "Hi world" modelId) + { neuralSparseModelSource = Nothing + } + let Just (Object body) = clauseBody textField (fromJust (decode (encode clause))) + body `shouldNotSatisfy` KM.member "model_id" + body `shouldNotSatisfy` KM.member "analyzer" + + describe "NeuralSparseQuery method_parameters" $ do + it "emits method_parameters when set on sparse_vector fields" $ do + let clause = + (mkNeuralSparseQueryText sparseVectorField "Hi world" modelId) + { neuralSparseMethodParameters = + Just + NeuralSparseMethodParameters + { neuralSparseMethodParametersTopN = Just 10, + neuralSparseMethodParametersHeapFactor = Just 1.0, + neuralSparseMethodParametersK = Just 10 + } + } + let Just (Object body) = clauseBody sparseVectorField (fromJust (decode (encode clause))) + case KM.lookup "method_parameters" body of + Just (Object mp) -> do + KM.lookup "top_n" mp `shouldBe` Just (toJSON (10 :: Int)) + KM.lookup "heap_factor" mp `shouldBe` Just (toJSON (1.0 :: Double)) + KM.lookup "k" mp `shouldBe` Just (toJSON (10 :: Int)) + other -> fail $ "expected method_parameters object, got " ++ show other + + it "omits null sub-fields of method_parameters" $ do + let clause = + (mkNeuralSparseQueryText sparseVectorField "Hi world" modelId) + { neuralSparseMethodParameters = + Just + NeuralSparseMethodParameters + { neuralSparseMethodParametersTopN = Just 10, + neuralSparseMethodParametersHeapFactor = Nothing, + neuralSparseMethodParametersK = Nothing + } + } + let Just (Object body) = clauseBody sparseVectorField (fromJust (decode (encode clause))) + case KM.lookup "method_parameters" body of + Just (Object mp) -> do + KM.lookup "top_n" mp `shouldBe` Just (toJSON (10 :: Int)) + mp `shouldNotSatisfy` KM.member "heap_factor" + mp `shouldNotSatisfy` KM.member "k" + other -> fail $ "expected method_parameters object, got " ++ show other + + describe "NeuralSparseQuery round-trip" $ do + it "round-trips a text + model_id query through ToJSON/FromJSON" $ do + let clause = mkNeuralSparseQueryText textField "Hi world" modelId + decode (encode clause) `shouldBe` Just clause + + it "round-trips a text + analyzer query through ToJSON/FromJSON" $ do + let clause = mkNeuralSparseQueryTextAnalyzer textField "Hi world" analyzer + decode (encode clause) `shouldBe` Just clause + + it "round-trips a text query with no model source (default analyzer)" $ do + let clause = + (mkNeuralSparseQueryText textField "Hi world" modelId) + { neuralSparseModelSource = Nothing + } + decode (encode clause) `shouldBe` Just clause + + it "round-trips a tokens + model_id query through ToJSON/FromJSON" $ do + let clause = mkNeuralSparseQueryTokens textField sampleTokens modelId + decode (encode clause) `shouldBe` Just clause + + it "round-trips a query with method_parameters" $ do + let clause = + (mkNeuralSparseQueryText sparseVectorField "Hi world" modelId) + { neuralSparseMethodParameters = + Just + NeuralSparseMethodParameters + { neuralSparseMethodParametersTopN = Just 10, + neuralSparseMethodParametersHeapFactor = Just 1.0, + neuralSparseMethodParametersK = Just 10 + } + } + decode (encode clause) `shouldBe` Just clause + + it "round-trips a query with partially-populated method_parameters" $ do + let clause = + (mkNeuralSparseQueryText sparseVectorField "Hi world" modelId) + { neuralSparseMethodParameters = + Just + NeuralSparseMethodParameters + { neuralSparseMethodParametersTopN = Just 5, + neuralSparseMethodParametersHeapFactor = Nothing, + neuralSparseMethodParametersK = Just 7 + } + } + decode (encode clause) `shouldBe` Just clause + + describe "NeuralSparseInput and NeuralSparseModelSource" $ do + it "NeuralSparseTextInput round-trips" $ do + let input = NeuralSparseTextInput "hello" + decode (encode input) `shouldBe` Just input + + it "NeuralSparseTokensInput round-trips" $ do + let input = NeuralSparseTokensInput sampleTokens + decode (encode input) `shouldBe` Just input + + it "NeuralSparseByModelId round-trips" $ do + let src = NeuralSparseByModelId modelId + decode (encode src) `shouldBe` Just src + + it "NeuralSparseByAnalyzer round-trips" $ do + let src = NeuralSparseByAnalyzer analyzer + decode (encode src) `shouldBe` Just src + + it "NeuralSparseMethodParameters round-trips with all fields set" $ do + let params = + NeuralSparseMethodParameters + { neuralSparseMethodParametersTopN = Just 10, + neuralSparseMethodParametersHeapFactor = Just 1.0, + neuralSparseMethodParametersK = Just 5 + } + decode (encode params) `shouldBe` Just params + + it "rejects NeuralSparseInput with neither query_text nor query_tokens" $ do + let bad = object ["something_else" .= String "x"] + (decode (encode bad) :: Maybe NeuralSparseInput) `shouldBe` Nothing + + it "rejects NeuralSparseModelSource with neither model_id nor analyzer" $ do + let bad = object ["unrelated" .= Number 1] + (decode (encode bad) :: Maybe NeuralSparseModelSource) `shouldBe` Nothing + + describe "Query sum type integration" $ do + it "QueryNeuralSparseQuery wraps the clause under the \"neural_sparse\" key" $ do + let inner = mkNeuralSparseQueryText textField "Hi world" modelId + let wrapped = QueryNeuralSparseQuery inner + let json = encode wrapped + json `shouldSatisfy` \bs -> case decode bs of + Just (Object obj) -> KM.member "neural_sparse" obj + _ -> False + + -- Regression guard for the double-wrap bug: the Query wrapper must NOT + -- re-wrap the leaf (which already self-wraps under "neural_sparse"). + -- The wire shape must be exactly {"neural_sparse": {: {...}}}, + -- not {"neural_sparse": {"neural_sparse": {: {...}}}}. + it "QueryNeuralSparseQuery does NOT double-wrap the leaf neural_sparse key" $ do + let inner = mkNeuralSparseQueryText textField "Hi world" modelId + let json = encode (QueryNeuralSparseQuery inner) + let Just (Object outer) = decode json + Just (Object neuralSparseObj) = KM.lookup "neural_sparse" outer + neuralSparseObj `shouldNotSatisfy` KM.member "neural_sparse" + neuralSparseObj `shouldSatisfy` KM.member (AK.fromText "passage_embedding") + + -- Walk-into-body assertion: the body shape under obj.neural_sparse. + -- must match the OS-correct clause body. This is the test that would + -- have caught the double-wrap bug. + it "QueryNeuralSparseQuery produces OS-correct body shape under neural_sparse." $ do + let inner = mkNeuralSparseQueryText textField "Hi world" modelId + let Just (Object body) = walk ["neural_sparse", AK.fromText "passage_embedding"] (fromJust (decode (encode (QueryNeuralSparseQuery inner)))) + KM.lookup "query_text" body `shouldBe` Just (String "Hi world") + KM.lookup "model_id" body `shouldBe` Just (String modelId) + + it "QueryNeuralSparseQuery round-trips through the parent Query sum type" $ do + let inner = mkNeuralSparseQueryText textField "Hi world" modelId + let wrapped = QueryNeuralSparseQuery inner + decode (encode wrapped) `shouldBe` Just wrapped + + it "QueryNeuralSparseQuery round-trips with tokens input" $ do + let inner = mkNeuralSparseQueryTokens textField sampleTokens modelId + let wrapped = QueryNeuralSparseQuery inner + decode (encode wrapped) `shouldBe` Just wrapped + + it "QueryNeuralSparseQuery round-trips with method_parameters set" $ do + let inner = + (mkNeuralSparseQueryText sparseVectorField "Hi world" modelId) + { neuralSparseMethodParameters = + Just + NeuralSparseMethodParameters + { neuralSparseMethodParametersTopN = Just 10, + neuralSparseMethodParametersHeapFactor = Just 1.0, + neuralSparseMethodParametersK = Just 10 + } + } + let wrapped = QueryNeuralSparseQuery inner + decode (encode wrapped) `shouldBe` Just wrapped + + -- End-to-end: an OS-shaped wire JSON decodes to the expected Query. + -- Pre-fix, this returned Nothing because the decoder expected the + -- double-wrapped shape; post-fix, it succeeds. + it "decodes a real OS-shaped neural_sparse wire JSON" $ do + let wire = "{\"neural_sparse\":{\"passage_embedding\":{\"query_text\":\"Hi world\",\"model_id\":\"aP2Q8ooBpBj3wT4HVS8a\"}}}" + let expected = QueryNeuralSparseQuery (mkNeuralSparseQueryText textField "Hi world" modelId) + (decode wire :: Maybe Query) `shouldBe` Just expected + + it "distinguishes neural_sparse from neural in the parser" $ do + let inner = mkNeuralSparseQueryText textField "Hi world" modelId + let wrapped = QueryNeuralSparseQuery inner + let Just (Object obj) = decode (encode wrapped) + obj `shouldNotSatisfy` KM.member "neural" + obj `shouldSatisfy` KM.member "neural_sparse" + + describe "NeuralSparseQuery parser rejects malformed clauses" $ do + it "rejects neural_sparse clause with multiple field keys" $ do + let bad = + object + [ "neural_sparse" + .= object + [ "field_a" .= object ["query_text" .= String "x", "model_id" .= String "m"], + "field_b" .= object ["query_text" .= String "y", "model_id" .= String "m"] + ] + ] + (decode (encode bad) :: Maybe NeuralSparseQuery) `shouldBe` Nothing + + it "rejects neural_sparse clause with no field key" $ do + let bad = object ["neural_sparse" .= object []] + (decode (encode bad) :: Maybe NeuralSparseQuery) `shouldBe` Nothing + + it "rejects neural_sparse clause with no input field" $ do + let bad = + object + [ "neural_sparse" + .= object + [ "passage_embedding" + .= object + ["model_id" .= String "m"] + ] + ] + (decode (encode bad) :: Maybe NeuralSparseQuery) `shouldBe` Nothing + + it "accepts neural_sparse clause with model_id and analyzer absent (default)" $ do + let ok = + object + [ "neural_sparse" + .= object + [ "passage_embedding" + .= object + ["query_text" .= String "Hi world"] + ] + ] + let expected = + NeuralSparseQuery + { neuralSparseField = textField, + neuralSparseInput = NeuralSparseTextInput "Hi world", + neuralSparseModelSource = Nothing, + neuralSparseMethodParameters = Nothing + } + (decode (encode ok) :: Maybe NeuralSparseQuery) `shouldBe` Just expected diff --git a/tests/Test/NeuralStatsSpec.hs b/tests/Test/NeuralStatsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/NeuralStatsSpec.hs @@ -0,0 +1,420 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.NeuralStatsSpec (spec) where + +import Control.Exception (SomeException) +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List (isInfixOf, sortOn) +import Data.Map.Strict qualified as Map +import Data.Text qualified as Text +import Database.Bloodhound.OpenSearch3.Client qualified as OS3.Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- | A representative three-section response body for +-- @GET /_plugins/_neural/stats@. The stat-name set is plugin-version +-- dependent, so we exercise a small subset whose keys are confirmed against +-- a live OS 3.7.0 cluster (see 'liveCapturedResponse'). The section bodies +-- are arbitrary nested JSON; we deliberately round-trip them as 'Value' +-- rather than modelling individual stats. +-- +-- This fixture intentionally omits the @_nodes@ \/ @cluster_name@ envelope +-- the live endpoint emits, so it can also exercise the +-- @decode . encode@ round-trip (those envelope keys are dropped on re-encode +-- because 'NeuralStats' only models the three sections). The envelope is +-- covered separately by 'liveCapturedResponse'. +sampleFullResponse :: LBS.ByteString +sampleFullResponse = + "{\ + \ \"info\": {\ + \ \"cluster_version\": \"3.3.0\",\ + \ \"processors\": {\ + \ \"ingest\": { \"text_embedding_processors_in_pipelines\": 1 }\ + \ }\ + \ },\ + \ \"all_nodes\": {\ + \ \"processors\": {\ + \ \"ingest\": { \"text_embedding_executions\": { \"count\": 7 } }\ + \ }\ + \ },\ + \ \"nodes\": {\ + \ \"AaaBbbCccDddEeeFffGgHh\": {\ + \ \"processors\": {\ + \ \"ingest\": { \"text_embedding_executions\": { \"count\": 7 } }\ + \ }\ + \ }\ + \ }\ + \}" + +-- | A response carrying only the @info@ section. The other two sections are +-- independently toggled by the request's @include_all_nodes@ and +-- @include_individual_nodes@ flags; the decoder must accept their absence. +sampleInfoOnlyResponse :: LBS.ByteString +sampleInfoOnlyResponse = + "{\ + \ \"info\": {\ + \ \"cluster_version\": \"3.3.0\"\ + \ }\ + \}" + +-- | A response carrying only the @nodes@ section with two nodes. Verifies the +-- per-node map is decoded as 'Map.Map Text Value' without losing entries. +sampleNodesOnlyResponse :: LBS.ByteString +sampleNodesOnlyResponse = + "{\ + \ \"nodes\": {\ + \ \"nodeOneIdTwentyTwoC00\": {\ + \ \"processors\": { \"ingest\": { \"text_embedding_executions\": { \"count\": 3 } } }\ + \ },\ + \ \"nodeTwoIdTwentyTwoC00X\": {\ + \ \"processors\": { \"ingest\": { \"text_embedding_executions\": { \"count\": 4 } } }\ + \ }\ + \ }\ + \}" + +-- | A response body captured from a live OS 3.7.0 cluster against +-- @GET /_plugins/_neural/stats/hybrid_query_requests@ (single-stat filter). +-- Unlike the synthetic fixtures above, this carries the real @_nodes@ and +-- @cluster_name@ envelope keys the endpoint emits, confirming the decoder +-- ignores unknown top-level keys. The @nodes@ section is keyed by a real +-- 22-character node ID. The single-stat path segment filters the stat keys +-- /within/ each section (here down to just @hybrid_query_requests@); it does +-- not suppress the section envelopes, so all three sections remain present. +-- Captured with the cluster setting +-- @plugins.neural_search.stats_enabled=true@; with the setting off (the +-- default) the endpoint returns HTTP 403 instead of a body. +liveCapturedResponse :: LBS.ByteString +liveCapturedResponse = + "{\ + \ \"_nodes\": { \"total\": 1, \"successful\": 1, \"failed\": 0 },\ + \ \"cluster_name\": \"docker-cluster\",\ + \ \"info\": {},\ + \ \"all_nodes\": {\ + \ \"query\": { \"hybrid\": { \"hybrid_query_requests\": 0 } }\ + \ },\ + \ \"nodes\": {\ + \ \"5aGfOefgRluhqf92Qn9D7g\": {\ + \ \"query\": { \"hybrid\": { \"hybrid_query_requests\": 0 } }\ + \ }\ + \ }\ + \}" + +spec :: Spec +spec = describe "Neural Stats API" $ do + describe "NeuralNodeId / NeuralStatName JSON" $ do + it "NeuralNodeId round-trips as a bare JSON string" $ do + encode (NeuralNodeId "node-id-22-chars-000") `shouldBe` "\"node-id-22-chars-000\"" + decode "\"abc\"" `shouldBe` Just (NeuralNodeId "abc") + + it "NeuralStatName round-trips as a bare JSON string" $ do + encode (NeuralStatName "text_embedding_executions") + `shouldBe` "\"text_embedding_executions\"" + decode "\"hybrid_query_requests\"" + `shouldBe` Just (NeuralStatName "hybrid_query_requests") + + describe "NeuralStats JSON" $ do + it "decodes a fully-populated three-section response" $ do + let Just decoded = decode sampleFullResponse :: Maybe NeuralStats + neuralStatsInfo decoded `shouldSatisfy` isJust + neuralStatsAllNodes decoded `shouldSatisfy` isJust + neuralStatsNodes decoded `shouldSatisfy` isJust + + it "decodes the per-node map with the right number of entries" $ do + let Just decoded = decode sampleFullResponse :: Maybe NeuralStats + Just nodesMap = neuralStatsNodes decoded + Map.size nodesMap `shouldBe` 1 + Map.member "AaaBbbCccDddEeeFffGgHh" nodesMap `shouldBe` True + + it "decodes an info-only response (missing sections become Nothing)" $ do + let Just decoded = decode sampleInfoOnlyResponse :: Maybe NeuralStats + neuralStatsInfo decoded `shouldSatisfy` isJust + neuralStatsAllNodes decoded `shouldBe` Nothing + neuralStatsNodes decoded `shouldBe` Nothing + + it "decodes a nodes-only response with multiple node IDs" $ do + let Just decoded = decode sampleNodesOnlyResponse :: Maybe NeuralStats + Just nodesMap = neuralStatsNodes decoded + Map.size nodesMap `shouldBe` 2 + Map.member "nodeOneIdTwentyTwoC00" nodesMap `shouldBe` True + Map.member "nodeTwoIdTwentyTwoC00X" nodesMap `shouldBe` True + + it "decodes an empty object as all-Nothing sections" $ do + let Just decoded = decode "{}" :: Maybe NeuralStats + neuralStatsInfo decoded `shouldBe` Nothing + neuralStatsAllNodes decoded `shouldBe` Nothing + neuralStatsNodes decoded `shouldBe` Nothing + + it "rejects a top-level array" $ do + let decoded = decode "[]" :: Maybe NeuralStats + decoded `shouldBe` Nothing + + it "rejects malformed JSON" $ do + let decoded = decode "{ not json" :: Maybe NeuralStats + decoded `shouldBe` Nothing + + it "round-trips a full body through ToJSON/FromJSON" $ do + let Just decoded = decode sampleFullResponse :: Maybe NeuralStats + (decode . encode) decoded `shouldBe` Just decoded + + it "round-trips a nodes-only body through ToJSON/FromJSON" $ do + let Just decoded = decode sampleNodesOnlyResponse :: Maybe NeuralStats + (decode . encode) decoded `shouldBe` Just decoded + + it "ToJSON omits Nothing sections (no null keys)" $ do + let Just decoded = decode sampleInfoOnlyResponse :: Maybe NeuralStats + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` not . BS.isInfixOf "\"all_nodes\"" + encoded `shouldSatisfy` not . BS.isInfixOf "\"nodes\"" + encoded `shouldSatisfy` BS.isInfixOf "\"info\"" + + it "ToJSON omits info/all_nodes when only nodes is present" $ do + let Just decoded = decode sampleNodesOnlyResponse :: Maybe NeuralStats + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` not . BS.isInfixOf "\"info\"" + encoded `shouldSatisfy` not . BS.isInfixOf "\"all_nodes\"" + encoded `shouldSatisfy` BS.isInfixOf "\"nodes\"" + + it "decodes a live-captured body (envelope keys ignored, all sections present)" $ do + let Just decoded = decode liveCapturedResponse :: Maybe NeuralStats + neuralStatsInfo decoded `shouldSatisfy` isJust + neuralStatsAllNodes decoded `shouldSatisfy` isJust + neuralStatsNodes decoded `shouldSatisfy` isJust + + it "decodes the live 22-char node ID into the per-node map" $ do + let Just decoded = decode liveCapturedResponse :: Maybe NeuralStats + Just nodesMap = neuralStatsNodes decoded + Map.size nodesMap `shouldBe` 1 + Map.member "5aGfOefgRluhqf92Qn9D7g" nodesMap `shouldBe` True + + it "treats an empty info section ({}) as present (Just)" $ do + let Just decoded = decode liveCapturedResponse :: Maybe NeuralStats + neuralStatsInfo decoded `shouldBe` Just (object []) + + describe "getNeuralStats endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "GETs /_plugins/_neural/stats when given Nothing/Nothing" $ do + let req = OS3Requests.getNeuralStats Nothing Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_plugins/_neural/stats/{stat} when only the stat name is set" $ do + let req = + OS3Requests.getNeuralStats + Nothing + (Just (NeuralStatName "text_embedding_executions")) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "stats", "text_embedding_executions"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_plugins/_neural/{nodeId}/stats when only the node id is set" $ do + let req = + OS3Requests.getNeuralStats + (Just (NeuralNodeId "node-id-22-chars-000")) + Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "node-id-22-chars-000", "stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "GETs /_plugins/_neural/{nodeId}/stats/{stat} when both are set" $ do + let req = + OS3Requests.getNeuralStats + (Just (NeuralNodeId "node-id-22-chars-000")) + (Just (NeuralStatName "hybrid_query_requests")) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [ "_plugins", + "_neural", + "node-id-22-chars-000", + "stats", + "hybrid_query_requests" + ] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the GET method" $ do + let req = OS3Requests.getNeuralStats Nothing Nothing + bhRequestMethod req `shouldBe` "GET" + + it "does not attach a body (GET semantics)" $ do + let req = OS3Requests.getNeuralStats Nothing Nothing + bhRequestBody req `shouldBe` Nothing + + describe "getNeuralStatsWith endpoint shape" $ do + -- 'defaultNeuralStatsOptions' must reproduce the legacy wire shape + -- exactly: same path segments and no query string. + it "defaultNeuralStatsOptions is byte-identical to getNeuralStats" $ do + let legacy = OS3Requests.getNeuralStats Nothing Nothing + withDef = OS3Requests.getNeuralStatsWith Nothing Nothing defaultNeuralStatsOptions + getRawEndpoint (bhRequestEndpoint legacy) + `shouldBe` getRawEndpoint (bhRequestEndpoint withDef) + getRawEndpointQueries (bhRequestEndpoint legacy) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint withDef) + + it "defaultNeuralStatsOptions produces no query string" $ do + let req = OS3Requests.getNeuralStatsWith Nothing Nothing defaultNeuralStatsOptions + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "keeps the same path segments regardless of options" $ do + let req = + OS3Requests.getNeuralStatsWith + (Just (NeuralNodeId "node-id-22-chars-000")) + (Just (NeuralStatName "hybrid_query_requests")) + ( defaultNeuralStatsOptions + { nsoIncludeInfo = Just True, + nsoIncludeAllNodes = Just True, + nsoIncludeIndividualNodes = Just True + } + ) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [ "_plugins", + "_neural", + "node-id-22-chars-000", + "stats", + "hybrid_query_requests" + ] + + it "renders all three flags as =true when all set to Just True" $ do + let req = + OS3Requests.getNeuralStatsWith + Nothing + Nothing + ( defaultNeuralStatsOptions + { nsoIncludeInfo = Just True, + nsoIncludeAllNodes = Just True, + nsoIncludeIndividualNodes = Just True + } + ) + sortPairs (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sortPairs + [ ("include_info", Just "true"), + ("include_all_nodes", Just "true"), + ("include_individual_nodes", Just "true") + ] + + it "renders a single flag and omits the rest" $ do + let req = + OS3Requests.getNeuralStatsWith + Nothing + Nothing + defaultNeuralStatsOptions {nsoIncludeAllNodes = Just True} + sortPairs (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [("include_all_nodes", Just "true")] + + it "renders Just False as include_*=false (tri-state)" $ do + let req = + OS3Requests.getNeuralStatsWith + Nothing + Nothing + ( defaultNeuralStatsOptions + { nsoIncludeInfo = Just False, + nsoIncludeIndividualNodes = Just False + } + ) + sortPairs (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sortPairs + [ ("include_info", Just "false"), + ("include_individual_nodes", Just "false") + ] + + it "handles a mixed Just True / Just False / Nothing combination" $ do + let req = + OS3Requests.getNeuralStatsWith + Nothing + Nothing + ( defaultNeuralStatsOptions + { nsoIncludeInfo = Just True, + nsoIncludeAllNodes = Just False, + nsoIncludeIndividualNodes = Nothing + } + ) + sortPairs (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sortPairs + [ ("include_info", Just "true"), + ("include_all_nodes", Just "false") + ] + + it "Nothing and Just False produce distinct wire shapes" $ do + let omissions = + OS3Requests.getNeuralStatsWith + Nothing + Nothing + defaultNeuralStatsOptions {nsoIncludeInfo = Nothing} + explicitFalse = + OS3Requests.getNeuralStatsWith + Nothing + Nothing + defaultNeuralStatsOptions {nsoIncludeInfo = Just False} + getRawEndpointQueries (bhRequestEndpoint omissions) `shouldBe` [] + getRawEndpointQueries (bhRequestEndpoint explicitFalse) + `shouldBe` [("include_info", Just "false")] + + it "still uses the GET method and no body" $ do + let req = + OS3Requests.getNeuralStatsWith + Nothing + Nothing + defaultNeuralStatsOptions {nsoIncludeInfo = Just True} + bhRequestMethod req `shouldBe` "GET" + bhRequestBody req `shouldBe` Nothing + + -- ---------------------------------------------------------------- -- + -- Live round-trip: gated on OpenSearch 3 (the Neural Search plugin -- + -- is OS-specific). The endpoint is disabled by default and returns -- + -- HTTP 403 until the cluster setting -- + -- @plugins.neural_search.stats_enabled@ is set to @true@. The test -- + -- gracefully pends when the setting is off, so it does not fail on -- + -- a default cluster; to exercise it, enable the setting on the OS3 -- + -- docker container (port 9205) before running. -- + -- -- + -- Wire shape live-verified against OS 3.7.0 in bead bloodhound-6py: -- + -- the default response carries all three sections (@info@, -- + -- @all_nodes@, @nodes@) plus an @_nodes@ \/ @cluster_name@ envelope -- + -- that the decoder ignores. -- + -- ---------------------------------------------------------------- -- + describe "getNeuralStats live round-trip" $ do + os3It <- runIO os3OnlyIT + + os3It "OS3: decodes NeuralStats when stats_enabled, pends on 403 otherwise" $ + withTestEnv $ do + -- The endpoint is gated behind a cluster setting and, when it is + -- off, OS replies with HTTP 403 + a plain-text body + -- @"Stats endpoint is disabled"@. Because that body is not JSON, + -- the client cannot surface it as an 'EsError' and throws an + -- 'EsProtocolException' instead (the exception type lives in a + -- hidden library module, so we catch 'SomeException' and match on + -- the disabled-state marker in its 'show' representation — the + -- same approach 'Test.SearchApplicationsSpec' takes for 'EsError' + -- messages). Any other failure is a real test failure. + result <- try $ OS3.Client.getNeuralStats Nothing Nothing + liftIO $ case result of + Left (ex :: SomeException) + | "disabled" `isInfixOf` show ex -> + pendingWith $ + "plugins.neural_search.stats_enabled is false (the " + <> "default) on this cluster; the endpoint returns " + <> "HTTP 403 with a plain-text body. Set the " + <> "persistent cluster setting to true to exercise " + <> "the live neural stats endpoint." + | otherwise -> + expectationFailure $ + "getNeuralStats failed unexpectedly: " <> show ex + Right (Left e) -> + expectationFailure $ + "getNeuralStats returned an EsError: HTTP " + <> show (errorStatus e) + <> " — " + <> Text.unpack (errorMessage e) + Right (Right stats) -> do + neuralStatsInfo stats `shouldSatisfy` isJust + neuralStatsAllNodes stats `shouldSatisfy` isJust + neuralStatsNodes stats `shouldSatisfy` isJust + +-- | Order-insensitive comparison for @(key, value)@ query-param pairs. +-- 'withQueries' is order-insensitive, but the test-suite's @shouldBe@ +-- is not; this helper sorts both sides so a stable but unspecified +-- ordering does not cause spurious failures. +sortPairs :: [(Text.Text, Maybe Text.Text)] -> [(Text.Text, Maybe Text.Text)] +sortPairs = sortOn fst diff --git a/tests/Test/NeuralWarmupSpec.hs b/tests/Test/NeuralWarmupSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/NeuralWarmupSpec.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.NeuralWarmupSpec (spec) where + +import Database.Bloodhound.OpenSearch3.Client qualified as OS3.Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- | Pure endpoint-shape tests for the Neural Search plugin warmup API +-- (@POST /_plugins/_neural/warmup\/{index}@) for OpenSearch 3. These +-- mirror 'Test.OSAsyncSearchSpec's shape tests but assert the +-- @\/_plugins\/_neural\/warmup@ path, the POST method, and the +-- empty-object body. JSON decoding of the shared 'ShardsResult' response +-- is re-verified here on the warmup response shape +-- (@{\"_shards\":{...}}@). The wire shape for the neural warmup API is +-- live-verified against OS 3.7.0 in bead bloodhound-at5. The neural-sparse +-- warmup route is OS 3.x only: OS 1.3.x does not ship the neural-search +-- plugin (bloodhound-ie4j) and OS 2.19.5 does not register the route or +-- the sparse_vector field type (bloodhound-sh7o), so neither OS1 nor OS2 +-- ships a builder and no cross-backend parity block is meaningful. +spec :: Spec +spec = describe "Neural Warmup API" $ do + describe "warmupNeuralIndex endpoint shape (OpenSearch 3)" $ do + it "POSTs to /_plugins/_neural/warmup/{index} when given an IndexName" $ do + let req = OS3Requests.warmupNeuralIndex [[qqIndexName|my-index|]] + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "warmup", "my-index"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches an empty JSON object as the body" $ do + let req = OS3Requests.warmupNeuralIndex [[qqIndexName|my-index|]] + bhRequestBody req `shouldBe` Just (encode (object [])) + + it "uses a distinct index in the path when given a different IndexName" $ do + let req = OS3Requests.warmupNeuralIndex [[qqIndexName|other-index|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "warmup", "other-index"] + + it "keeps the index name as a single opaque path segment" $ do + let req = OS3Requests.warmupNeuralIndex [[qqIndexName|my-index_42|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "warmup", "my-index_42"] + + -- ---------------------------------------------------------------- -- + -- Multi-index (comma-separated) path rendering: bloodhound-6jy. -- + -- The Neural Warmup API documents comma-separated lists and index -- + -- patterns in the {index} path segment; the [IndexName] argument -- + -- is rendered as a single comma-joined segment, matching the -- + -- OpenSearch multi-target syntax. -- + -- ---------------------------------------------------------------- -- + describe "warmupNeuralIndex multi-index path rendering (OpenSearch 3)" $ do + it "renders [i1,i2,i3] as a single comma-joined path segment" $ do + let req = + OS3Requests.warmupNeuralIndex + [[qqIndexName|index1|], [qqIndexName|index2|], [qqIndexName|index3|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "warmup", "index1,index2,index3"] + + it "preserves index name order in the comma-joined segment" $ do + let req = + OS3Requests.warmupNeuralIndex + [[qqIndexName|zebra|], [qqIndexName|alpha|], [qqIndexName|mike|]] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "warmup", "zebra,alpha,mike"] + + it "renders an empty segment for an empty index list (server will error)" $ do + let req = OS3Requests.warmupNeuralIndex [] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_neural", "warmup", ""] + + describe "ShardsResult response decoding" $ do + -- Pure unit tests (no OS round-trip): lock the 'FromJSON ShardsResult' + -- decoder against the wire shape returned by + -- @POST /_plugins/_neural/warmup\/{index}@. Live OS 3.7.0 confirmed + -- the response is the @_shards@ envelope + -- (@{"_shards":{"total":2,"successful":1,"failed":0}}@), matching + -- @flushIndex@ \/ @refreshIndex@ \/ @clearIndexCache@ (bead + -- bloodhound-at5). + it "decodes {\"_shards\":{\"total\":2,\"successful\":1,\"skipped\":0,\"failed\":0}} into ShardsResult" $ do + let payload = "{\"_shards\":{\"total\":2,\"successful\":1,\"skipped\":0,\"failed\":0}}" + Just decoded = decode payload :: Maybe ShardsResult + decoded `shouldBe` ShardsResult (ShardResult 2 1 0 0) + + it "rejects a payload missing the _shards envelope" $ do + let payload = "{\"acknowledged\":true}" + decoded = decode payload :: Maybe ShardsResult + decoded `shouldBe` Nothing + + -- ---------------------------------------------------------------- -- + -- Live round-trip: gated per-OS with os{n}OnlyIT (the -- + -- 'Test.KnnWarmupSpec' pattern). -- + -- -- + -- Wire shape live-verified against OS 3.7.0 (port 9205) in bead -- + -- bloodhound-at5: the response is -- + -- @{"_shards":{"total":2,"successful":1,"failed":0}}@ — the -- + -- @_shards@ envelope, decoded into 'ShardsResult'. The endpoint -- + -- requires an index with @index.sparse: true@ and a @sparse_vector@ -- + -- field mapping. -- + -- -- + -- The neural-sparse warmup route is OS 3.x only: OS 1.3.x does not -- + -- ship the neural-search plugin (bloodhound-ie4j), and OS 2.19.5 -- + -- does not register the warmup route or the @sparse_vector@ field -- + -- type (bloodhound-sh7o), so the live round-trip can only be -- + -- exercised on OS 3. -- + -- ---------------------------------------------------------------- -- + describe "warmupNeuralIndex live round-trip" $ do + os3It <- runIO os3OnlyIT + + let assertShards :: ShardsResult -> IO () + assertShards (ShardsResult sr) = do + shardTotal sr `shouldSatisfy` (>= 1) + shardsFailed sr `shouldBe` 0 + + os3It "OS3: returns a ShardsResult with at least one shard and no failures" $ + withTestEnv $ do + _ <- tryEsError resetOsNeuralSparseIndex + result <- OS3.Client.warmupNeuralIndex osNeuralSparseTestIndex + liftIO $ assertShards result diff --git a/tests/Test/NodesSpec.hs b/tests/Test/NodesSpec.hs --- a/tests/Test/NodesSpec.hs +++ b/tests/Test/NodesSpec.hs @@ -1,7 +1,16 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Test.NodesSpec (spec) where +import Data.Aeson (Value (..), decode, encode) +import Data.Aeson.Key (toText) +import Data.Aeson.KeyMap qualified as KM +import Data.Aeson.Types (parseMaybe, withObject, (.:)) +import Data.ByteString.Lazy.Char8 qualified as BL +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text qualified as T +import Test.Hspec (Spec, describe, it, shouldBe) import TestsUtils.Common import TestsUtils.Import import Prelude @@ -21,7 +30,542 @@ it "fetches the responding node when LocalNode is used" $ withTestEnv $ do NodesStats {..} <- performBHRequest $ getNodesStats LocalNode - -- This is really just a smoke test for response - -- parsing. Node stats is so variable, there's not much I can - -- assert here. liftIO $ length nodesStats `shouldBe` 1 + + describe "getNodesUsage" $ + it "fetches the responding node when LocalNode is used" $ + withTestEnv $ do + NodesUsage {..} <- performBHRequest $ getNodesUsage LocalNode + liftIO $ length nodesUsage `shouldBe` 1 + + describe "getNodesHotThreads" $ do + -- The hot_threads endpoint returns plain text rather than JSON, so + -- this is a smoke test for the UTF-8 body decoder in + -- 'Internal.Utils.Requests.getText'. + it "returns a non-empty plain-text report with no selector" $ + withTestEnv $ do + report <- performBHRequest $ getNodesHotThreads Nothing Nothing + liftIO $ (not $ T.null report) `shouldBe` True + + it "honours the threads query parameter (ThreadCount 1)" $ + withTestEnv $ do + report <- performBHRequest $ getNodesHotThreads Nothing (Just (ThreadCount 1)) + liftIO $ (not $ T.null report) `shouldBe` True + + it "accepts a specific node selector" $ + withTestEnv $ do + NodesInfo {..} <- performBHRequest $ getNodesInfo LocalNode + let targetNodeName = nodeInfoName $ head nodesInfo + report <- performBHRequest $ getNodesHotThreads (Just (NodeByName targetNodeName)) Nothing + liftIO $ (not $ T.null report) `shouldBe` True + + -- Backend-agnostic live smoke test for the new URI parameters. + -- 'snapshots' and 'ignore_idle_threads' are accepted by both ES and + -- OpenSearch, so they are safe to exercise against whatever backend + -- is up. (The 'type' parameter is also universal, but is covered by + -- the pure endpoint-shape tests below.) + it "getNodesHotThreadsWith honours snapshots and ignore_idle_threads" $ + withTestEnv $ do + let opts = defaultHotThreadsOptions {htoSnapshots = Just 1, htoIgnoreIdleThreads = Just False} + report <- performBHRequest $ getNodesHotThreadsWith Nothing opts + liftIO $ (not $ T.null report) `shouldBe` True + + -- The hot-threads kind is named @type@ on every backend (the + -- historical @doc_type@ is rejected with HTTP 400). This live test + -- pins that the emitted @type=cpu@ request is accepted by the server. + it "getNodesHotThreadsWith honours type (the universally accepted kind param)" $ + withTestEnv $ do + let opts = defaultHotThreadsOptions {htoDocType = Just HotThreadsDocTypeCPU} + report <- performBHRequest $ getNodesHotThreadsWith Nothing opts + liftIO $ (not $ T.null report) `shouldBe` True + + -- Endpoint-shape tests for the fully-parameterised variant. Pure (no + -- live ES) — they pin the URL path and query string so the wire format + -- cannot drift silently. Mirrors the precedent set by + -- @getNodesInfoWith endpoint shape@ above. + describe "getNodesHotThreadsWith endpoint shape" $ do + let path req = getRawEndpoint (bhRequestEndpoint req) + queries req = getRawEndpointQueries (bhRequestEndpoint req) + + it "default options -> identical to legacy getNodesHotThreads Nothing Nothing" $ + path (getNodesHotThreadsWith Nothing defaultHotThreadsOptions) + `shouldBe` path (getNodesHotThreads Nothing Nothing) + + it "default options -> no query string" $ + queries (getNodesHotThreadsWith Nothing defaultHotThreadsOptions) `shouldBe` [] + + it "threads preserved via legacy delegation (Just 1)" $ + path (getNodesHotThreads Nothing (Just (ThreadCount 1))) + `shouldBe` path (getNodesHotThreadsWith Nothing defaultHotThreadsOptions {htoThreads = Just (ThreadCount 1)}) + + it "Just selector renders /_nodes/{seg}/hot_threads" $ + path (getNodesHotThreadsWith (Just (NodeByName (NodeName "n1"))) defaultHotThreadsOptions) + `shouldBe` ["_nodes", "n1", "hot_threads"] + + it "interval renders as {n}{unit}" $ + queries (getNodesHotThreadsWith Nothing defaultHotThreadsOptions {htoInterval = Just (TimeUnitMilliseconds, 500)}) + `shouldBe` [("interval", Just "500ms")] + + it "snapshots renders the bare integer" $ + queries (getNodesHotThreadsWith Nothing defaultHotThreadsOptions {htoSnapshots = Just 5}) + `shouldBe` [("snapshots", Just "5")] + + it "type emitted under the type key only (no doc_type)" $ + queries (getNodesHotThreadsWith Nothing defaultHotThreadsOptions {htoDocType = Just HotThreadsDocTypeCPU}) + `shouldBe` [("type", Just "cpu")] + + it "ignore_idle_threads renders as lowercase bool" $ + queries (getNodesHotThreadsWith Nothing defaultHotThreadsOptions {htoIgnoreIdleThreads = Just False}) + `shouldBe` [("ignore_idle_threads", Just "false")] + + it "master_timeout renders as {n}{unit}" $ + queries (getNodesHotThreadsWith Nothing defaultHotThreadsOptions {htoMasterTimeout = Just (TimeUnitSeconds, 5)}) + `shouldBe` [("master_timeout", Just "5s")] + + it "timeout renders as {n}{unit}" $ + queries (getNodesHotThreadsWith Nothing defaultHotThreadsOptions {htoTimeout = Just (TimeUnitSeconds, 10)}) + `shouldBe` [("timeout", Just "10s")] + + it "all params together render in field order" $ + let opts = + defaultHotThreadsOptions + { htoThreads = Just (ThreadCount 1), + htoInterval = Just (TimeUnitMilliseconds, 500), + htoSnapshots = Just 5, + htoDocType = Just HotThreadsDocTypeWait, + htoIgnoreIdleThreads = Just True, + htoMasterTimeout = Just (TimeUnitSeconds, 5), + htoTimeout = Just (TimeUnitSeconds, 10) + } + in queries (getNodesHotThreadsWith Nothing opts) + `shouldBe` [ ("threads", Just "1"), + ("interval", Just "500ms"), + ("snapshots", Just "5"), + ("type", Just "wait"), + ("ignore_idle_threads", Just "true"), + ("master_timeout", Just "5s"), + ("timeout", Just "10s") + ] + + describe "HotThreadsDocType JSON" $ do + it "renders HotThreadsDocTypeCPU as \"cpu\"" $ + encode HotThreadsDocTypeCPU `shouldBe` "\"cpu\"" + + it "renders HotThreadsDocTypeWait as \"wait\"" $ + encode HotThreadsDocTypeWait `shouldBe` "\"wait\"" + + it "renders HotThreadsDocTypeBlock as \"block\"" $ + encode HotThreadsDocTypeBlock `shouldBe` "\"block\"" + + it "parses \"cpu\" as HotThreadsDocTypeCPU" $ + decode "\"cpu\"" `shouldBe` Just HotThreadsDocTypeCPU + + it "parses \"wait\" as HotThreadsDocTypeWait" $ + decode "\"wait\"" `shouldBe` Just HotThreadsDocTypeWait + + it "parses \"block\" as HotThreadsDocTypeBlock" $ + decode "\"block\"" `shouldBe` Just HotThreadsDocTypeBlock + + it "round-trips every named constructor" $ do + decode (encode HotThreadsDocTypeCPU) `shouldBe` Just HotThreadsDocTypeCPU + decode (encode HotThreadsDocTypeWait) `shouldBe` Just HotThreadsDocTypeWait + decode (encode HotThreadsDocTypeBlock) `shouldBe` Just HotThreadsDocTypeBlock + + it "rejects unknown strings (reject-unknown convention, matches NodeInfoMetric)" $ + decode "\"future_kind\"" `shouldBe` (Nothing :: Maybe HotThreadsDocType) + + it "encodes the Other escape hatch verbatim (Haskell-only, not decodable)" $ + encode (OtherHotThreadsDocType "future_kind") `shouldBe` "\"future_kind\"" + + describe "ThreadPoolType FromJSON" $ do + it "parses \"resizable\" as ThreadPoolResizable" $ + decode "\"resizable\"" `shouldBe` Just ThreadPoolResizable + + it "parses \"scaling\" as ThreadPoolScaling" $ + decode "\"scaling\"" `shouldBe` Just ThreadPoolScaling + + it "parses \"fixed\" as ThreadPoolFixed" $ + decode "\"fixed\"" `shouldBe` Just ThreadPoolFixed + + it "parses \"cached\" as ThreadPoolCached" $ + decode "\"cached\"" `shouldBe` Just ThreadPoolCached + + it "parses \"fixed_auto_queue_size\" as ThreadPoolFixedAutoQueueSize" $ + decode "\"fixed_auto_queue_size\"" `shouldBe` Just ThreadPoolFixedAutoQueueSize + + it "rejects unknown thread pool types" $ + decode "\"bogus\"" `shouldBe` (Nothing :: Maybe ThreadPoolType) + + -- Endpoint-shape tests for the metric-filter variants. These are pure + -- (no live ES) — they pin the URL path that 'getNodesInfoWith' / + -- 'getNodesStatsWith' emit so the wire format cannot drift silently. + describe "getNodesInfoWith endpoint shape" $ do + let path req = getRawEndpoint (bhRequestEndpoint req) + queries req = getRawEndpointQueries (bhRequestEndpoint req) + + it "no metrics -> identical to getNodesInfo (LocalNode)" $ + path (getNodesInfoWith LocalNode defaultNodeInfoOptions) + `shouldBe` path (getNodesInfo LocalNode) + + it "no metrics -> identical to getNodesInfo (AllNodes)" $ + path (getNodesInfoWith AllNodes defaultNodeInfoOptions) + `shouldBe` path (getNodesInfo AllNodes) + + it "no metrics -> identical to getNodesInfo (NodeList)" $ + let sel = NodeList (NodeByName (NodeName "node-1") :| []) + in path (getNodesInfoWith sel defaultNodeInfoOptions) `shouldBe` path (getNodesInfo sel) + + it "LocalNode + [jvm, os] -> /_nodes/_local/info/jvm,os" $ + path (getNodesInfoWith LocalNode defaultNodeInfoOptions {nioMetrics = Just [NodeInfoMetricJVM, NodeInfoMetricOS]}) + `shouldBe` ["_nodes", "_local", "info", "jvm,os"] + + it "AllNodes + [jvm] -> /_nodes/_all/info/jvm" $ + path (getNodesInfoWith AllNodes defaultNodeInfoOptions {nioMetrics = Just [NodeInfoMetricJVM]}) + `shouldBe` ["_nodes", "_all", "info", "jvm"] + + it "NodeList + [jvm] -> /_nodes/{sel}/info/jvm" $ + let sel = NodeList (NodeByName (NodeName "node-1") :| [NodeByFullNodeId (FullNodeId "abc")]) + in path (getNodesInfoWith sel defaultNodeInfoOptions {nioMetrics = Just [NodeInfoMetricJVM]}) + `shouldBe` ["_nodes", "node-1,abc", "info", "jvm"] + + it "NodeByHost selector renders host as-is" $ + let sel = NodeList (NodeByHost (Server "10.0.0.1") :| []) + in path (getNodesInfoWith sel defaultNodeInfoOptions {nioMetrics = Just [NodeInfoMetricHTTP]}) + `shouldBe` ["_nodes", "10.0.0.1", "info", "http"] + + it "NodeByAttribute renders as key:value" $ + let sel = NodeList (NodeByAttribute (NodeAttrName "rack") "r1" :| []) + in path (getNodesInfoWith sel defaultNodeInfoOptions {nioMetrics = Just [NodeInfoMetricOS]}) + `shouldBe` ["_nodes", "rack:r1", "info", "os"] + + it "OtherNodeInfoMetric renders verbatim" $ + path (getNodesInfoWith LocalNode defaultNodeInfoOptions {nioMetrics = Just [OtherNodeInfoMetric "custom_metric"]}) + `shouldBe` ["_nodes", "_local", "info", "custom_metric"] + + it "multiple metrics comma-joined in declaration order" $ + path + ( getNodesInfoWith + LocalNode + defaultNodeInfoOptions {nioMetrics = Just [NodeInfoMetricPlugins, NodeInfoMetricIngest, NodeInfoMetricJVM]} + ) + `shouldBe` ["_nodes", "_local", "info", "plugins,ingest,jvm"] + + it "default options -> no query string" $ + queries (getNodesInfoWith LocalNode defaultNodeInfoOptions) `shouldBe` [] + + it "flat_settings renders as lowercase bool" $ + queries (getNodesInfoWith LocalNode defaultNodeInfoOptions {nioFlatSettings = Just True}) + `shouldBe` [("flat_settings", Just "true")] + + it "master_timeout renders as {n}{unit}" $ + queries (getNodesInfoWith LocalNode defaultNodeInfoOptions {nioMasterTimeout = Just (TimeUnitSeconds, 5)}) + `shouldBe` [("master_timeout", Just "5s")] + + it "timeout renders as {n}{unit}" $ + queries (getNodesInfoWith LocalNode defaultNodeInfoOptions {nioTimeout = Just (TimeUnitSeconds, 10)}) + `shouldBe` [("timeout", Just "10s")] + + it "all params together render in field order" $ + let opts = + defaultNodeInfoOptions + { nioFlatSettings = Just True, + nioMasterTimeout = Just (TimeUnitSeconds, 5), + nioTimeout = Just (TimeUnitSeconds, 10) + } + in queries (getNodesInfoWith LocalNode opts) + `shouldBe` [ ("flat_settings", Just "true"), + ("master_timeout", Just "5s"), + ("timeout", Just "10s") + ] + + describe "getNodesStatsWith endpoint shape" $ do + let path req = getRawEndpoint (bhRequestEndpoint req) + queries req = getRawEndpointQueries (bhRequestEndpoint req) + + it "no metrics -> identical to getNodesStats (LocalNode)" $ + path (getNodesStatsWith LocalNode defaultNodeStatsOptions) + `shouldBe` path (getNodesStats LocalNode) + + it "no metrics -> identical to getNodesStats (AllNodes)" $ + path (getNodesStatsWith AllNodes defaultNodeStatsOptions) + `shouldBe` path (getNodesStats AllNodes) + + it "LocalNode + [jvm, os] -> /_nodes/_local/stats/jvm,os" $ + path (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoMetrics = Just [NodeStatsMetricJVM, NodeStatsMetricOS]}) + `shouldBe` ["_nodes", "_local", "stats", "jvm,os"] + + it "AllNodes + [fs] -> /_nodes/_all/stats/fs" $ + path (getNodesStatsWith AllNodes defaultNodeStatsOptions {nsoMetrics = Just [NodeStatsMetricFS]}) + `shouldBe` ["_nodes", "_all", "stats", "fs"] + + it "NodeList + [jvm, breakers] preserves selector rendering" $ + let sel = NodeList (NodeByName (NodeName "n1") :| []) + in path (getNodesStatsWith sel defaultNodeStatsOptions {nsoMetrics = Just [NodeStatsMetricJVM, NodeStatsMetricBreakers]}) + `shouldBe` ["_nodes", "n1", "stats", "jvm,breakers"] + + it "OtherNodeStatsMetric renders verbatim" $ + path (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoMetrics = Just [OtherNodeStatsMetric "indexing_pressure"]}) + `shouldBe` ["_nodes", "_local", "stats", "indexing_pressure"] + + it "default options -> no query string" $ + queries (getNodesStatsWith LocalNode defaultNodeStatsOptions) `shouldBe` [] + + it "completion_fields renders verbatim" $ + queries (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoCompletionFields = Just "text,*_suggest"}) + `shouldBe` [("completion_fields", Just "text,*_suggest")] + + it "fielddata_fields renders verbatim" $ + queries (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoFielddataFields = Just "text"}) + `shouldBe` [("fielddata_fields", Just "text")] + + it "fields renders verbatim" $ + queries (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoFields = Just "*"}) + `shouldBe` [("fields", Just "*")] + + it "groups renders verbatim" $ + queries (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoGroups = Just "g1,g2"}) + `shouldBe` [("groups", Just "g1,g2")] + + it "level renders via renderNodeStatsLevel" $ + queries (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoLevel = Just NodeStatsLevelShards}) + `shouldBe` [("level", Just "shards")] + + it "level=cluster renders via renderNodeStatsLevel" $ + queries (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoLevel = Just NodeStatsLevelCluster}) + `shouldBe` [("level", Just "cluster")] + + it "types renders verbatim" $ + queries (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoTypes = Just "_doc"}) + `shouldBe` [("types", Just "_doc")] + + it "master_timeout renders as {n}{unit}" $ + queries (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoMasterTimeout = Just (TimeUnitSeconds, 5)}) + `shouldBe` [("master_timeout", Just "5s")] + + it "timeout renders as {n}{unit}" $ + queries (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoTimeout = Just (TimeUnitSeconds, 10)}) + `shouldBe` [("timeout", Just "10s")] + + it "include_segment_file_sizes renders as lowercase bool" $ + queries (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoIncludeSegmentFileSizes = Just True}) + `shouldBe` [("include_segment_file_sizes", Just "true")] + + it "include_unloaded_segments renders as lowercase bool" $ + queries (getNodesStatsWith LocalNode defaultNodeStatsOptions {nsoIncludeUnloadedSegments = Just True}) + `shouldBe` [("include_unloaded_segments", Just "true")] + + it "all params together render in field order" $ + let opts = + defaultNodeStatsOptions + { nsoCompletionFields = Just "cf", + nsoFielddataFields = Just "fdf", + nsoFields = Just "f", + nsoGroups = Just "g", + nsoLevel = Just NodeStatsLevelIndices, + nsoTypes = Just "t", + nsoMasterTimeout = Just (TimeUnitSeconds, 5), + nsoTimeout = Just (TimeUnitSeconds, 10), + nsoIncludeSegmentFileSizes = Just True, + nsoIncludeUnloadedSegments = Just False + } + in queries (getNodesStatsWith LocalNode opts) + `shouldBe` [ ("completion_fields", Just "cf"), + ("fielddata_fields", Just "fdf"), + ("fields", Just "f"), + ("groups", Just "g"), + ("level", Just "indices"), + ("types", Just "t"), + ("master_timeout", Just "5s"), + ("timeout", Just "10s"), + ("include_segment_file_sizes", Just "true"), + ("include_unloaded_segments", Just "false") + ] + + describe "getNodesUsageWith endpoint shape" $ do + let path req = getRawEndpoint (bhRequestEndpoint req) + queries req = getRawEndpointQueries (bhRequestEndpoint req) + + it "no metrics -> identical to getNodesUsage (LocalNode)" $ + path (getNodesUsageWith LocalNode defaultNodeUsageOptions) + `shouldBe` path (getNodesUsage LocalNode) + + it "no metrics -> identical to getNodesUsage (AllNodes)" $ + path (getNodesUsageWith AllNodes defaultNodeUsageOptions) + `shouldBe` path (getNodesUsage AllNodes) + + it "LocalNode + [RestActions] -> /_nodes/_local/usage/rest_actions" $ + path (getNodesUsageWith LocalNode defaultNodeUsageOptions {nuoMetrics = Just [NodeUsageMetricRestActions]}) + `shouldBe` ["_nodes", "_local", "usage", "rest_actions"] + + it "AllNodes no metrics -> /_nodes/_all/usage" $ + path (getNodesUsageWith AllNodes defaultNodeUsageOptions) + `shouldBe` ["_nodes", "_all", "usage"] + + it "NodeList + [RestActions] -> /_nodes/{sel}/usage/rest_actions" $ + let sel = NodeList (NodeByName (NodeName "n1") :| [NodeByFullNodeId (FullNodeId "abc")]) + in path (getNodesUsageWith sel defaultNodeUsageOptions {nuoMetrics = Just [NodeUsageMetricRestActions]}) + `shouldBe` ["_nodes", "n1,abc", "usage", "rest_actions"] + + it "OtherNodeUsageMetric renders verbatim" $ + path (getNodesUsageWith LocalNode defaultNodeUsageOptions {nuoMetrics = Just [OtherNodeUsageMetric "custom_metric"]}) + `shouldBe` ["_nodes", "_local", "usage", "custom_metric"] + + it "default options -> no query string" $ + queries (getNodesUsageWith LocalNode defaultNodeUsageOptions) `shouldBe` [] + + it "master_timeout renders as {n}{unit}" $ + queries (getNodesUsageWith LocalNode defaultNodeUsageOptions {nuoMasterTimeout = Just (TimeUnitSeconds, 5)}) + `shouldBe` [("master_timeout", Just "5s")] + + it "timeout renders as {n}{unit}" $ + queries (getNodesUsageWith LocalNode defaultNodeUsageOptions {nuoTimeout = Just (TimeUnitSeconds, 10)}) + `shouldBe` [("timeout", Just "10s")] + + it "all params together render in field order" $ + let opts = + defaultNodeUsageOptions + { nuoMasterTimeout = Just (TimeUnitSeconds, 5), + nuoTimeout = Just (TimeUnitSeconds, 10) + } + in queries (getNodesUsageWith LocalNode opts) + `shouldBe` [ ("master_timeout", Just "5s"), + ("timeout", Just "10s") + ] + + -- Endpoint-shape tests for 'reloadSecureSettings'. Pure (no live ES) + -- — they pin the HTTP method, URL path, query string and body so the + -- wire format cannot drift silently. Mirrors the precedent set by + -- @startILM@\/@stopILM@ in @Test/ILMSpec.hs@ and @cleanupSnapshotRepo@ + -- in @Test/SnapshotsSpec.hs@. + describe "reloadSecureSettings endpoint shape" $ do + let mkReq = reloadSecureSettings + assertShape req expectedPath = do + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` expectedPath + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Just "" + + it "Nothing -> POST /_nodes/reload_secure_settings, empty body, no queries" $ + assertShape (mkReq Nothing) ["_nodes", "reload_secure_settings"] + + it "Just LocalNode -> POST /_nodes/_local/reload_secure_settings" $ + assertShape (mkReq (Just LocalNode)) ["_nodes", "_local", "reload_secure_settings"] + + it "Just AllNodes -> POST /_nodes/_all/reload_secure_settings" $ + assertShape (mkReq (Just AllNodes)) ["_nodes", "_all", "reload_secure_settings"] + + it "Just (NodeList ...) renders selectors comma-joined" $ do + let sel = NodeList (NodeByName (NodeName "n1") :| [NodeByFullNodeId (FullNodeId "abc")]) + assertShape (mkReq (Just sel)) ["_nodes", "n1,abc", "reload_secure_settings"] + + it "Just (NodeList NodeByAttribute ...) renders key:value" $ do + let sel = NodeList (NodeByAttribute (NodeAttrName "rack") "r1" :| []) + assertShape (mkReq (Just sel)) ["_nodes", "rack:r1", "reload_secure_settings"] + + it "Just (NodeList NodeByHost ...) renders host verbatim" $ do + let sel = NodeList (NodeByHost (Server "10.0.0.1") :| []) + assertShape (mkReq (Just sel)) ["_nodes", "10.0.0.1", "reload_secure_settings"] + + describe "NodeInfoMetric JSON" $ do + it "renders NodeInfoMetricJVM as \"jvm\"" $ + encode NodeInfoMetricJVM `shouldBe` "\"jvm\"" + + it "renders NodeInfoMetricThreadPool as \"thread_pool\"" $ + encode NodeInfoMetricThreadPool `shouldBe` "\"thread_pool\"" + + it "rejects unknown metrics" $ + decode "\"bogus\"" `shouldBe` (Nothing :: Maybe NodeInfoMetric) + + mapM_ roundTripInfo allNodeInfoMetricsForRoundTrip + + describe "NodeStatsMetric JSON" $ do + it "renders NodeStatsMetricIndices as \"indices\"" $ + encode NodeStatsMetricIndices `shouldBe` "\"indices\"" + + it "renders NodeStatsMetricAdaptiveSelection as \"adaptive_selection\"" $ + encode NodeStatsMetricAdaptiveSelection `shouldBe` "\"adaptive_selection\"" + + it "rejects unknown metrics" $ + decode "\"bogus\"" `shouldBe` (Nothing :: Maybe NodeStatsMetric) + + mapM_ roundTripStats allNodeStatsMetricsForRoundTrip + + describe "NodeUsageMetric JSON" $ do + it "renders NodeUsageMetricRestActions as \"rest_actions\"" $ + encode NodeUsageMetricRestActions `shouldBe` "\"rest_actions\"" + + it "rejects unknown metrics" $ + decode "\"bogus\"" `shouldBe` (Nothing :: Maybe NodeUsageMetric) + + mapM_ roundTripUsage allNodeUsageMetricsForRoundTrip + where + roundTripInfo m = + it ("round-trips " <> show m) $ + decode (encode m) `shouldBe` (Just m :: Maybe NodeInfoMetric) + roundTripStats m = + it ("round-trips " <> show m) $ + decode (encode m) `shouldBe` (Just m :: Maybe NodeStatsMetric) + roundTripUsage m = + it ("round-trips " <> show m) $ + decode (encode m) `shouldBe` (Just m :: Maybe NodeUsageMetric) + -- Exhaustive lists of the named constructors (excluding the open-ended + -- 'Other*Metric Text' escape hatches). Replaces the previous + -- @[minBound .. maxBound]@ enumeration, which stopped being derivable + -- when the escape hatches landed. Listed inline here to keep the test + -- self-contained. + allNodeInfoMetricsForRoundTrip = + [ NodeInfoMetricSettings, + NodeInfoMetricOS, + NodeInfoMetricProcess, + NodeInfoMetricJVM, + NodeInfoMetricThreadPool, + NodeInfoMetricTransport, + NodeInfoMetricHTTP, + NodeInfoMetricPlugins, + NodeInfoMetricIngest, + NodeInfoMetricAggregations, + NodeInfoMetricIndices, + NodeInfoMetricDiscovery, + NodeInfoMetricScripting, + NodeInfoMetricAction + ] + allNodeStatsMetricsForRoundTrip = + [ NodeStatsMetricIndices, + NodeStatsMetricOS, + NodeStatsMetricProcess, + NodeStatsMetricJVM, + NodeStatsMetricThreadPool, + NodeStatsMetricFS, + NodeStatsMetricTransport, + NodeStatsMetricHTTP, + NodeStatsMetricBreakers, + NodeStatsMetricScript, + NodeStatsMetricDiscovery, + NodeStatsMetricIngest, + NodeStatsMetricAdaptiveSelection, + NodeStatsMetricScriptCache, + NodeStatsMetricIndexingPressure, + NodeStatsMetricCgroup + ] + allNodeUsageMetricsForRoundTrip = + [ NodeUsageMetricRestActions, + NodeUsageMetricAggregations + ] + +-- | Extract the top-level keys of the first (and typically only) entry +-- under @.nodes@ in a @_nodes/{sel}/info@ or @/_nodes/{sel}/stats@ +-- response body. Returns the empty list if the body doesn't match the +-- expected shape. +nodeMetricKeys :: BL.ByteString -> [T.Text] +nodeMetricKeys body = + case decode body :: Maybe Value of + Just topVal + | Just nodeData <- firstNodeObject topVal -> + toText <$> KM.keys nodeData + _ -> [] + where + firstNodeObject val = do + nodesObj <- parseMaybe (withObject "top" (.: "nodes")) val + case KM.toList nodesObj of + (_, Object fields) : _ -> Just fields + _ -> Nothing diff --git a/tests/Test/NotificationsSpec.hs b/tests/Test/NotificationsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/NotificationsSpec.hs @@ -0,0 +1,1980 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.NotificationsSpec (spec) where + +import Control.Concurrent (threadDelay) +import Control.Monad.Catch (bracket_) +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List qualified as L +import Data.Map.Strict qualified as Map +import Data.Text qualified as T +import Data.Time.Clock.POSIX (getPOSIXTime) +import Database.Bloodhound.OpenSearch2.Client qualified as OS2Client +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2Types +import Database.Bloodhound.OpenSearch3.Client qualified as OS3Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- --------------------------------------------------------------------------- +-- Sample bodies, drawn verbatim from the OS Notifications plugin docs +-- (). +-- --------------------------------------------------------------------------- + +-- | The canonical POST body for a Slack channel — exactly the shape +-- documented under "Create notification configuration". +sampleSlackConfigJson :: LBS.ByteString +sampleSlackConfigJson = + "{\ + \ \"name\": \"Sample Slack Channel\",\ + \ \"description\": \"This is a Slack channel\",\ + \ \"config_type\": \"slack\",\ + \ \"is_enabled\": true,\ + \ \"slack\": {\"url\": \"https://hooks.slack.com/services/T00000000/B00000000/XXXXXXXXXXXXXXXXXXXXXXXX\"}\ + \}" + +-- | An SNS config with the optional @role_arn@ omitted — exercises the +-- 'Maybe' field on 'SnsTransport'. +sampleSnsConfigNoRoleJson :: LBS.ByteString +sampleSnsConfigNoRoleJson = + "{\ + \ \"name\": \"SNS no role\",\ + \ \"config_type\": \"sns\",\ + \ \"sns\": {\"topic_arn\": \"arn:aws:sns:us-east-1:123:topic\"}\ + \}" + +-- | The POST request body wrapping a Slack config with a caller-supplied +-- @config_id@. +sampleCreateRequestJson :: LBS.ByteString +sampleCreateRequestJson = + "{\ + \ \"config_id\": \"sample-id\",\ + \ \"config\": {\ + \ \"name\": \"Sample Slack Channel\",\ + \ \"description\": \"This is a Slack channel\",\ + \ \"config_type\": \"slack\",\ + \ \"is_enabled\": true,\ + \ \"slack\": {\"url\": \"https://sample-slack-webhook\"}\ + \ }\ + \}" + +-- | The create response body — a single-field object echoing @config_id@. +sampleCreateResponseJson :: LBS.ByteString +sampleCreateResponseJson = "{\"config_id\":\"abc-123\"}" + +spec :: Spec +spec = describe "Notifications plugin" $ do + -- ======================================================================= + -- NotificationConfigType + -- ======================================================================= + describe "NotificationConfigType JSON" $ do + let cases = + [ (NotificationConfigTypeSlack, "slack"), + (NotificationConfigTypeChime, "chime"), + (NotificationConfigTypeWebhook, "webhook"), + (NotificationConfigTypeMicrosoftTeams, "microsoft_teams"), + (NotificationConfigTypeSns, "sns"), + (NotificationConfigTypeSesAccount, "ses_account"), + (NotificationConfigTypeSmtpAccount, "smtp_account"), + (NotificationConfigTypeEmailGroup, "email_group"), + (NotificationConfigTypeEmail, "email") + ] + forM_ cases $ \(t, wire) -> do + it ("encodes " <> show wire <> " to the documented wire string") $ do + encode t `shouldBe` "\"" <> LBS.fromStrict wire <> "\"" + it ("decodes the documented wire string " <> show wire) $ do + decode ("\"" <> LBS.fromStrict wire <> "\"" :: LBS.ByteString) + `shouldBe` Just t + + it "rejects an unknown config_type" $ do + decode "\"slack_v2\"" `shouldBe` (Nothing :: Maybe NotificationConfigType) + + it "rejects a non-string config_type" $ do + decode "42" `shouldBe` (Nothing :: Maybe NotificationConfigType) + + it "round-trips through ToJSON/FromJSON" $ + property $ \(t :: NotificationConfigType) -> + (decode . encode) t === Just t + + -- ======================================================================= + -- SlackTransport / ChimeTransport / WebhookTransport / MicrosoftTeams + -- ======================================================================= + describe "SlackTransport JSON" $ do + it "round-trips a url" $ do + let t = SlackTransport "https://hooks.slack.com/abc" + (decode . encode) t `shouldBe` Just t + + it "encodes to a single-field url object" $ + encode (SlackTransport "https://x") + `shouldBe` "{\"url\":\"https://x\"}" + + it "requires the url field" $ + decode "{}" `shouldBe` (Nothing :: Maybe SlackTransport) + + describe "ChimeTransport JSON" $ do + it "round-trips a url" $ do + let t = ChimeTransport "https://chime.webhook" + (decode . encode) t `shouldBe` Just t + it "encodes to a single-field url object" $ + encode (ChimeTransport "https://y") + `shouldBe` "{\"url\":\"https://y\"}" + + describe "WebhookTransport JSON" $ do + it "round-trips a url" $ do + let t = WebhookTransport "https://custom.example/hook" + (decode . encode) t `shouldBe` Just t + + describe "MicrosoftTeamsTransport JSON" $ do + it "round-trips a url" $ do + let t = MicrosoftTeamsTransport "https://teams.webhook" + (decode . encode) t `shouldBe` Just t + it "encodes under the microsoft_teams wire key when wrapped" $ do + let wrapped = NotificationTransportMicrosoftTeams (MicrosoftTeamsTransport "https://teams.webhook") + encode wrapped `shouldBe` "{\"microsoft_teams\":{\"url\":\"https://teams.webhook\"}}" + + -- ======================================================================= + -- SnsTransport (exercises Maybe field) + -- ======================================================================= + describe "SnsTransport JSON" $ do + it "round-trips with role_arn populated" $ do + let t = SnsTransport "arn:aws:sns:..." (Just "arn:aws:iam::role") + (decode . encode) t `shouldBe` Just t + + it "round-trips with role_arn omitted" $ do + let t = SnsTransport "arn:aws:sns:..." Nothing + (decode . encode) t `shouldBe` Just t + + it "omits role_arn when Nothing (wire shape)" $ + encode (SnsTransport "arn:aws:sns:..." Nothing) + `shouldBe` "{\"topic_arn\":\"arn:aws:sns:...\"}" + + it "requires topic_arn" $ + decode "{\"role_arn\":\"x\"}" `shouldBe` (Nothing :: Maybe SnsTransport) + + -- ======================================================================= + -- SesAccountTransport / SmtpAccountTransport + -- ======================================================================= + describe "SesAccountTransport JSON" $ do + it "round-trips the documented shape" $ do + let t = + SesAccountTransport + { sesAccountTransportRegion = "us-east-1", + sesAccountTransportRoleArn = "arn:aws:iam::012345678912:role/x", + sesAccountTransportFromAddress = "test@email.com" + } + (decode . encode) t `shouldBe` Just t + it "requires region, role_arn, from_address" $ + decode "{\"region\":\"us-east-1\"}" `shouldBe` (Nothing :: Maybe SesAccountTransport) + + describe "SmtpAccountTransport JSON" $ do + it "round-trips the documented shape" $ do + let t = + SmtpAccountTransport + { smtpAccountTransportHost = "smtp.example.com", + smtpAccountTransportPort = 587, + smtpAccountTransportMethod = SmtpMethodStartTls, + smtpAccountTransportFromAddress = "test@email.com" + } + (decode . encode) t `shouldBe` Just t + it "round-trips each SmtpMethod variant" $ + mapM_ + ( \m -> do + let t = SmtpAccountTransport "h" 25 m "f@e.com" + (decode . encode) t `shouldBe` Just t + ) + [SmtpMethodNone, SmtpMethodSsl, SmtpMethodStartTls] + it "rejects an unknown method" $ + ( decode "{\"host\":\"h\",\"port\":25,\"method\":\"bogus\",\"from_address\":\"f@e.com\"}" :: + Maybe SmtpAccountTransport + ) + `shouldBe` Nothing + + -- ======================================================================= + -- EmailRecipient / EmailGroupTransport / EmailTransport + -- ======================================================================= + describe "EmailRecipient JSON" $ do + it "round-trips an object {recipient: ...}" $ do + let r = EmailRecipient "alice@example.com" + (decode . encode) r `shouldBe` Just r + it "encodes to {\"recipient\":\"...\"}" $ + encode (EmailRecipient "x@y.com") `shouldBe` "{\"recipient\":\"x@y.com\"}" + it "accepts the bare-string variant shown in docs (decode-only)" $ + decode "\"alice@example.com\"" `shouldBe` Just (EmailRecipient "alice@example.com") + it "OS2: accepts the bare-string variant shown in docs (decode-only)" $ + decode "\"alice@example.com\"" `shouldBe` Just (OS2Types.EmailRecipient "alice@example.com") + + describe "EmailGroupTransport JSON" $ do + it "round-trips a non-empty recipient list" $ do + let t = + EmailGroupTransport + { emailGroupTransportRecipientList = + EmailRecipient "a@b.com" :| [EmailRecipient "c@d.com"] + } + (decode . encode) t `shouldBe` Just t + it "requires a non-empty recipient_list" $ + decode "{\"recipient_list\":[]}" `shouldBe` (Nothing :: Maybe EmailGroupTransport) + + describe "EmailTransport JSON" $ do + it "round-trips with email_group_id_list populated" $ do + let t = + EmailTransport + { emailTransportEmailAccountId = "smtp-1", + emailTransportRecipientList = EmailRecipient "x@y.com" :| [], + emailTransportEmailGroupIdList = Just ["g1", "g2"] + } + (decode . encode) t `shouldBe` Just t + it "round-trips with email_group_id_list omitted" $ do + let t = + EmailTransport + { emailTransportEmailAccountId = "smtp-1", + emailTransportRecipientList = EmailRecipient "x@y.com" :| [], + emailTransportEmailGroupIdList = Nothing + } + (decode . encode) t `shouldBe` Just t + it "omits email_group_id_list when Nothing (wire shape)" $ do + let bs = + LBS.toStrict . encode $ + EmailTransport + { emailTransportEmailAccountId = "smtp-1", + emailTransportRecipientList = EmailRecipient "x@y.com" :| [], + emailTransportEmailGroupIdList = Nothing + } + bs `shouldSatisfy` BS.isInfixOf "\"email_account_id\"" + -- Assert absence: a buggy encoder that emitted `email_group_id_list` + -- for `Nothing` would silently pass without this negative check. + bs `shouldSatisfy` not . BS.isInfixOf "email_group_id_list" + + -- ======================================================================= + -- NotificationTransport sum + -- ======================================================================= + describe "NotificationTransport JSON" $ do + it "encodes Slack variant under the slack wire key" $ do + let t = NotificationTransportSlack (SlackTransport "https://x") + encode t `shouldBe` "{\"slack\":{\"url\":\"https://x\"}}" + + it "encodes Sns variant under the sns wire key" $ do + let t = NotificationTransportSns (SnsTransport "arn:sns" Nothing) + encode t `shouldBe` "{\"sns\":{\"topic_arn\":\"arn:sns\"}}" + + it "encodes SmtpAccount variant under the smtp_account wire key" $ do + let t = + NotificationTransportSmtpAccount + ( SmtpAccountTransport + { smtpAccountTransportHost = "h", + smtpAccountTransportPort = 25, + smtpAccountTransportMethod = SmtpMethodStartTls, + smtpAccountTransportFromAddress = "f@e.com" + } + ) + bs = LBS.toStrict (encode t) + -- Aeson 2.x sorts object keys alphabetically on encode; assert each + -- substring is present rather than the exact byte ordering. + bs `shouldSatisfy` BS.isInfixOf "\"smtp_account\":" + bs `shouldSatisfy` BS.isInfixOf "\"host\":\"h\"" + bs `shouldSatisfy` BS.isInfixOf "\"port\":25" + bs `shouldSatisfy` BS.isInfixOf "\"method\":\"start_tls\"" + bs `shouldSatisfy` BS.isInfixOf "\"from_address\":\"f@e.com\"" + + it "encodes EmailGroup variant under the email_group wire key" $ do + let t = + NotificationTransportEmailGroup + ( EmailGroupTransport + { emailGroupTransportRecipientList = EmailRecipient "a@b" :| [] + } + ) + encode t + `shouldBe` "{\"email_group\":{\"recipient_list\":[{\"recipient\":\"a@b\"}]}}" + + it "decodes a single-variant transport body" $ + decode "{\"chime\":{\"url\":\"https://c\"}}" + `shouldBe` Just (NotificationTransportChime (ChimeTransport "https://c")) + + it "rejects an empty transport object" $ + decode "{}" `shouldBe` (Nothing :: Maybe NotificationTransport) + + it "rejects an unknown transport object" $ + decode "{\"unknown_transport\":{\"x\":1}}" + `shouldBe` (Nothing :: Maybe NotificationTransport) + + it "rejects a multi-transport object (server would reject anyway)" $ + -- Both 'slack' and 'chime' keys are present. The decoder detects + -- multiple known transport keys and parse-fails rather than + -- silently picking the first. + decode "{\"slack\":{\"url\":\"a\"},\"chime\":{\"url\":\"b\"}}" + `shouldBe` (Nothing :: Maybe NotificationTransport) + + -- ======================================================================= + -- transportConfigType invariant + -- ======================================================================= + describe "transportConfigType" $ do + it "recovers NotificationConfigTypeSlack from a Slack transport" $ + transportConfigType (NotificationTransportSlack (SlackTransport "x")) + `shouldBe` NotificationConfigTypeSlack + it "recovers NotificationConfigTypeMicrosoftTeams from a Teams transport" $ + transportConfigType + (NotificationTransportMicrosoftTeams (MicrosoftTeamsTransport "x")) + `shouldBe` NotificationConfigTypeMicrosoftTeams + it "recovers NotificationConfigTypeEmailGroup from an EmailGroup transport" $ + transportConfigType + ( NotificationTransportEmailGroup + (EmailGroupTransport (EmailRecipient "x" :| [])) + ) + `shouldBe` NotificationConfigTypeEmailGroup + + -- Parametric coverage across all 9 variants: prevents a future + -- copy-paste error in transportConfigType from going undetected. + let allTransports :: [(NotificationConfigType, NotificationTransport)] + allTransports = + [ (NotificationConfigTypeSlack, NotificationTransportSlack (SlackTransport "u")), + (NotificationConfigTypeChime, NotificationTransportChime (ChimeTransport "u")), + ( NotificationConfigTypeWebhook, + NotificationTransportWebhook (WebhookTransport "u") + ), + ( NotificationConfigTypeMicrosoftTeams, + NotificationTransportMicrosoftTeams (MicrosoftTeamsTransport "u") + ), + ( NotificationConfigTypeSns, + NotificationTransportSns (SnsTransport "arn" Nothing) + ), + ( NotificationConfigTypeSesAccount, + NotificationTransportSesAccount + (SesAccountTransport "us-east-1" "arn:role" "from@x.com") + ), + ( NotificationConfigTypeSmtpAccount, + NotificationTransportSmtpAccount + (SmtpAccountTransport "smtp.x" 587 SmtpMethodStartTls "from@x.com") + ), + ( NotificationConfigTypeEmailGroup, + NotificationTransportEmailGroup + (EmailGroupTransport (EmailRecipient "a@b" :| [])) + ), + ( NotificationConfigTypeEmail, + NotificationTransportEmail + ( EmailTransport + { emailTransportEmailAccountId = "smtp-1", + emailTransportRecipientList = EmailRecipient "x@y" :| [], + emailTransportEmailGroupIdList = Nothing + } + ) + ) + ] + + forM_ allTransports $ \(expectedType, transport) -> + it ("transportConfigType returns " <> show expectedType <> " for its variant") $ + transportConfigType transport `shouldBe` expectedType + + -- ======================================================================= + -- NotificationConfig + -- ======================================================================= + describe "NotificationConfig JSON" $ do + let slackConfig = + NotificationConfig + { notificationConfigName = "Sample Slack Channel", + notificationConfigDescription = Just "This is a Slack channel", + notificationConfigIsEnabled = Just True, + notificationConfigTransport = + NotificationTransportSlack (SlackTransport "https://sample-slack-webhook") + } + + it "decodes the documented Slack sample body" $ do + let Just decoded = decode sampleSlackConfigJson :: Maybe NotificationConfig + notificationConfigName decoded `shouldBe` "Sample Slack Channel" + notificationConfigDescription decoded `shouldBe` Just "This is a Slack channel" + notificationConfigIsEnabled decoded `shouldBe` Just True + + it "round-trips the documented Slack sample body" $ do + let Just decoded = decode sampleSlackConfigJson :: Maybe NotificationConfig + (decode . encode) decoded `shouldBe` Just decoded + + it "encodes config_type derived from the transport variant" $ do + let bs = encode slackConfig + LBS.toStrict bs `shouldSatisfy` BS.isInfixOf "\"config_type\":\"slack\"" + + it "encodes exactly one transport key matching config_type" $ do + let bs = LBS.toStrict (encode slackConfig) + BS.isInfixOf "\"slack\":" bs `shouldBe` True + BS.isInfixOf "\"sns\":" bs `shouldBe` False + BS.isInfixOf "\"email\":" bs `shouldBe` False + + it "decodes an SNS body without role_arn (optional field)" $ do + let Just (decoded :: NotificationConfig) = decode sampleSnsConfigNoRoleJson + case notificationConfigTransport decoded of + NotificationTransportSns sns -> snsTransportRoleArn sns `shouldBe` Nothing + _ -> expectationFailure "expected SNS transport" + + it "round-trips with all optional fields as Nothing" $ do + let cfg = + NotificationConfig + { notificationConfigName = "n", + notificationConfigDescription = Nothing, + notificationConfigIsEnabled = Nothing, + notificationConfigTransport = + NotificationTransportSlack (SlackTransport "u") + } + (decode . encode) cfg `shouldBe` Just cfg + + it "fails when config_type disagrees with the transport key" $ do + -- Body claims slack but only provides a chime block. The decoder + -- looks up the slack key on a slack config_type; finding nothing + -- parse-fails. + let bad = + "{\ + \ \"name\": \"x\",\ + \ \"config_type\": \"slack\",\ + \ \"chime\": {\"url\": \"https://c\"}\ + \}" + decode bad `shouldBe` (Nothing :: Maybe NotificationConfig) + + it "fails when the transport key is absent entirely" $ do + let bad = + "{\ + \ \"name\": \"x\",\ + \ \"config_type\": \"slack\"\ + \}" + decode bad `shouldBe` (Nothing :: Maybe NotificationConfig) + + -- Parametric coverage: round-trip a NotificationConfig built from + -- each of the 9 transport variants. This exercises both ToJSON + -- (transport key + derived config_type) and FromJSON (config_type + -- dispatch + transport-key lookup) for every variant — catches + -- typos in either direction. + let mkConfig t = + NotificationConfig + { notificationConfigName = "n", + notificationConfigDescription = Nothing, + notificationConfigIsEnabled = Nothing, + notificationConfigTransport = t + } + variants = + [ ( "slack", + NotificationTransportSlack (SlackTransport "u"), + "\"config_type\":\"slack\"", + "\"slack\":{\"url\":\"u\"}" + ), + ( "chime", + NotificationTransportChime (ChimeTransport "u"), + "\"config_type\":\"chime\"", + "\"chime\":{\"url\":\"u\"}" + ), + ( "webhook", + NotificationTransportWebhook (WebhookTransport "u"), + "\"config_type\":\"webhook\"", + "\"webhook\":{\"url\":\"u\"}" + ), + ( "microsoft_teams", + NotificationTransportMicrosoftTeams (MicrosoftTeamsTransport "u"), + "\"config_type\":\"microsoft_teams\"", + "\"microsoft_teams\":{\"url\":\"u\"}" + ), + ( "sns", + NotificationTransportSns (SnsTransport "arn" Nothing), + "\"config_type\":\"sns\"", + "\"sns\":{\"topic_arn\":\"arn\"}" + ), + ( "ses_account", + NotificationTransportSesAccount + (SesAccountTransport "us-east-1" "arn:role" "from@x.com"), + "\"config_type\":\"ses_account\"", + "\"ses_account\":" + ), + ( "smtp_account", + NotificationTransportSmtpAccount + (SmtpAccountTransport "smtp.x" 587 SmtpMethodStartTls "from@x.com"), + "\"config_type\":\"smtp_account\"", + "\"smtp_account\":" + ), + ( "email_group", + NotificationTransportEmailGroup + (EmailGroupTransport (EmailRecipient "a@b" :| [])), + "\"config_type\":\"email_group\"", + "\"email_group\":" + ), + ( "email", + NotificationTransportEmail + ( EmailTransport + { emailTransportEmailAccountId = "smtp-1", + emailTransportRecipientList = EmailRecipient "x@y" :| [], + emailTransportEmailGroupIdList = Nothing + } + ), + "\"config_type\":\"email\"", + "\"email\":" + ) + ] + + forM_ variants $ \(label, transport, expectedTypeSubstr, expectedTransportSubstr) -> do + it ("round-trips a NotificationConfig with " <> label <> " transport") $ do + let cfg = mkConfig transport + (decode . encode) cfg `shouldBe` Just cfg + it ("encodes " <> label <> " config_type derived from the transport") $ do + let bs = LBS.toStrict (encode (mkConfig transport)) + bs `shouldSatisfy` BS.isInfixOf expectedTypeSubstr + it ("encodes " <> label <> " under the matching transport key") $ do + let bs = LBS.toStrict (encode (mkConfig transport)) + bs `shouldSatisfy` BS.isInfixOf expectedTransportSubstr + + -- ======================================================================= + -- CreateNotificationConfigRequest + -- ======================================================================= + describe "CreateNotificationConfigRequest JSON" $ do + let slackConfig = + NotificationConfig + { notificationConfigName = "Sample Slack Channel", + notificationConfigDescription = Just "desc", + notificationConfigIsEnabled = Just True, + notificationConfigTransport = + NotificationTransportSlack (SlackTransport "https://x") + } + + it "round-trips with a caller-supplied config_id" $ do + let req = CreateNotificationConfigRequest (Just "sample-id") slackConfig + (decode . encode) req `shouldBe` Just req + + it "round-trips without a config_id (server will assign)" $ do + let req = CreateNotificationConfigRequest Nothing slackConfig + (decode . encode) req `shouldBe` Just req + + it "encodes both config_id and config when both are present" $ do + let req = CreateNotificationConfigRequest (Just "abc") slackConfig + bs = LBS.toStrict (encode req) + BS.isInfixOf "\"config_id\":\"abc\"" bs `shouldBe` True + BS.isInfixOf "\"config\":" bs `shouldBe` True + + it "omits config_id when Nothing" $ do + let req = CreateNotificationConfigRequest Nothing slackConfig + bs = LBS.toStrict (encode req) + BS.isInfixOf "config_id" bs `shouldBe` False + + it "decodes the documented sample body" $ do + let Just (decoded :: CreateNotificationConfigRequest) = decode sampleCreateRequestJson + createNotificationConfigRequestId decoded `shouldBe` Just "sample-id" + + it "ignores the docs' alternative 'id' field name (config_id is the documented one)" $ do + -- The plugin docs inconsistently show "id" in one example instead of + -- the documented "config_id". We read only "config_id" and ignore + -- the alternative, so the body parses to a request with + -- config_id=Nothing rather than a wire-shape error. This is the + -- silent-ignore path; an explicit parse-fail would require extra + -- work for no real safety gain since the server is the ultimate + -- authority on what it accepts. + let body = + "{\ + \ \"id\": \"sample-id\",\ + \ \"config\": {\ + \ \"name\": \"x\",\ + \ \"config_type\": \"slack\",\ + \ \"slack\": {\"url\": \"https://x\"}\ + \ }\ + \}" + Just (decoded :: CreateNotificationConfigRequest) = decode body + createNotificationConfigRequestId decoded `shouldBe` Nothing + + -- ======================================================================= + -- CreateNotificationConfigResponse + -- ======================================================================= + describe "CreateNotificationConfigResponse JSON" $ do + it "decodes the documented {config_id:...} body" $ do + let Just (decoded :: CreateNotificationConfigResponse) = decode sampleCreateResponseJson + createNotificationConfigResponseConfigId decoded `shouldBe` "abc-123" + + it "round-trips" $ do + let r = CreateNotificationConfigResponse "xyz" + (decode . encode) r `shouldBe` Just r + + it "fails when config_id is missing" $ + decode "{}" `shouldBe` (Nothing :: Maybe CreateNotificationConfigResponse) + + -- ======================================================================= + -- UpdateNotificationConfigRequest (PUT /_plugins/_notifications/configs/{id}) + -- ======================================================================= + describe "UpdateNotificationConfigRequest JSON" $ do + let slackConfig = + NotificationConfig + { notificationConfigName = "Sample Slack Channel", + notificationConfigDescription = Just "desc", + notificationConfigIsEnabled = Just True, + notificationConfigTransport = + NotificationTransportSlack (SlackTransport "https://x") + } + + it "round-trips a wrapped config" $ do + let req = UpdateNotificationConfigRequest slackConfig + (decode . encode) req `shouldBe` Just req + + it "encodes only the config key (no top-level config_id)" $ do + let req = UpdateNotificationConfigRequest slackConfig + bs = LBS.toStrict (encode req) + -- The update body identity is the URL path, not a body field; + -- a buggy encoder that emitted config_id would mislead callers + -- into thinking the update is idempotent on the body alone. + BS.isInfixOf "\"config\":" bs `shouldBe` True + BS.isInfixOf "\"config_id\"" bs `shouldBe` False + + it "decodes the documented PUT body verbatim" $ do + let body = + "{\ + \ \"config\": {\ + \ \"name\": \"Slack Channel\",\ + \ \"description\": \"This is an updated channel configuration\",\ + \ \"config_type\": \"slack\",\ + \ \"is_enabled\": true,\ + \ \"slack\": {\"url\": \"https://hooks.slack.com/sample-url\"}\ + \ }\ + \}" + Just (decoded :: UpdateNotificationConfigRequest) = decode body + notificationConfigName (updateNotificationConfigRequestConfig decoded) + `shouldBe` "Slack Channel" + + it "fails when the config key is absent" $ + decode "{}" `shouldBe` (Nothing :: Maybe UpdateNotificationConfigRequest) + + -- ======================================================================= + -- Endpoint shape + -- ======================================================================= + describe "createNotificationConfig endpoint shape (OpenSearch 3)" $ do + let cfg = + NotificationConfig + { notificationConfigName = "n", + notificationConfigDescription = Nothing, + notificationConfigIsEnabled = Nothing, + notificationConfigTransport = NotificationTransportSlack (SlackTransport "u") + } + + it "POSTs to /_plugins/_notifications/configs" $ do + let req = OS3Requests.createNotificationConfig cfg + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "configs"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the POST method" $ do + let req = OS3Requests.createNotificationConfig cfg + bhRequestMethod req `shouldBe` "POST" + + it "attaches a non-empty body" $ do + let req = OS3Requests.createNotificationConfig cfg + bhRequestBody req `shouldSatisfy` isJust + + it "forwards the config_id when supplied via With" $ do + let req = OS3Requests.createNotificationConfigWith (Just "my-id") cfg + Just body = bhRequestBody req + LBS.toStrict body `shouldSatisfy` BS.isInfixOf "\"config_id\":\"my-id\"" + + it "omits config_id from the body when the plain variant is used" $ do + let req = OS3Requests.createNotificationConfig cfg + Just body = bhRequestBody req + LBS.toStrict body `shouldSatisfy` not . BS.isInfixOf "config_id" + + -- ======================================================================= + -- Cross-backend parity: OS2 and OS3 must agree on path/method/body. + -- (Notifications plugin does not exist on OS1.) + -- ======================================================================= + describe "cross-backend parity (OS2 vs OS3)" $ do + let mkOS2 :: OS2Types.NotificationConfig + mkOS2 = + OS2Types.NotificationConfig + { OS2Types.notificationConfigName = "n", + OS2Types.notificationConfigDescription = Nothing, + OS2Types.notificationConfigIsEnabled = Nothing, + OS2Types.notificationConfigTransport = + OS2Types.NotificationTransportSlack (OS2Types.SlackTransport "u") + } + mkOS3 :: NotificationConfig + mkOS3 = + NotificationConfig + { notificationConfigName = "n", + notificationConfigDescription = Nothing, + notificationConfigIsEnabled = Nothing, + notificationConfigTransport = + NotificationTransportSlack (SlackTransport "u") + } + + it "createNotificationConfig emits identical paths across OS2/OS3" $ do + let p2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.createNotificationConfig mkOS2)) + p3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.createNotificationConfig mkOS3)) + p2 `shouldBe` ["_plugins", "_notifications", "configs"] + p3 `shouldBe` p2 + + it "createNotificationConfig emits identical methods across OS2/OS3" $ do + let methods = + [ bhRequestMethod (OS2Requests.createNotificationConfig mkOS2), + bhRequestMethod (OS3Requests.createNotificationConfig mkOS3) + ] + length (L.nub methods) `shouldBe` 1 + head methods `shouldBe` "POST" + + it "createNotificationConfig emits identical bodies across OS2/OS3" $ do + let bodies = + catMaybes + [ bhRequestBody (OS2Requests.createNotificationConfig mkOS2), + bhRequestBody (OS3Requests.createNotificationConfig mkOS3) + ] + length bodies `shouldBe` 2 + length (L.nub (L.map LBS.toStrict bodies)) `shouldBe` 1 + + it "createNotificationConfigWith emits identical bodies across OS2/OS3" $ do + let bodies = + catMaybes + [ bhRequestBody (OS2Requests.createNotificationConfigWith (Just "id") mkOS2), + bhRequestBody (OS3Requests.createNotificationConfigWith (Just "id") mkOS3) + ] + length bodies `shouldBe` 2 + length (L.nub (L.map LBS.toStrict bodies)) `shouldBe` 1 + + -- ======================================================================= + -- DeleteNotificationConfigResponse (DELETE /_plugins/_notifications/configs/{id}) + -- ======================================================================= + describe "DeleteNotificationConfigResponse JSON" $ do + it "decodes the documented single-id OK response" $ do + let decoded = + decode + "{\"delete_response_list\":{\"sample-id\":\"OK\"}}" :: + Maybe DeleteNotificationConfigResponse + deleteResponseList <$> decoded `shouldBe` Just (Map.singleton "sample-id" "OK") + + it "encodes back to the documented wire shape" $ do + let resp = + DeleteNotificationConfigResponse + { deleteResponseList = Map.singleton "sample-id" "OK" + } + encode resp + `shouldBe` "{\"delete_response_list\":{\"sample-id\":\"OK\"}}" + + it "round-trips through ToJSON/FromJSON" $ + property $ \(resp :: DeleteNotificationConfigResponse) -> + (decode . encode) resp === Just resp + + it "decodes an empty delete_response_list" $ do + let decoded = decode "{\"delete_response_list\":{}}" :: Maybe DeleteNotificationConfigResponse + deleteResponseList <$> decoded `shouldBe` Just Map.empty + + describe "deleteResponseStatus" $ do + it "returns the status for a present config_id" $ do + let resp = + DeleteNotificationConfigResponse + { deleteResponseList = Map.fromList [("a", "OK"), ("b", "FAIL")] + } + deleteResponseStatus "a" resp `shouldBe` Just "OK" + deleteResponseStatus "b" resp `shouldBe` Just "FAIL" + + it "returns Nothing for an absent config_id" $ do + let resp = DeleteNotificationConfigResponse {deleteResponseList = Map.singleton "a" "OK"} + deleteResponseStatus "nope" resp `shouldBe` Nothing + + describe "deleteResponseAllOK" $ do + it "is True when every entry is OK" $ do + let resp = + DeleteNotificationConfigResponse + { deleteResponseList = Map.fromList [("a", "OK"), ("b", "OK")] + } + deleteResponseAllOK resp `shouldBe` True + + it "is False when any entry is not OK" $ do + let resp = + DeleteNotificationConfigResponse + { deleteResponseList = Map.fromList [("a", "OK"), ("b", "FAIL")] + } + deleteResponseAllOK resp `shouldBe` False + + it "is True for the empty response" $ + deleteResponseAllOK (DeleteNotificationConfigResponse Map.empty) `shouldBe` True + + -- ======================================================================= + -- deleteNotificationConfig endpoint shape (pure, no live backend). + -- Mirrors the create-endpoint shape tests above; asserts the DELETE + -- method, the config_id-bearing path, no body, and OS2/OS3 parity. + -- ======================================================================= + describe "deleteNotificationConfig endpoint shape (OpenSearch 3)" $ do + it "DELETEs /_plugins/_notifications/configs/{config_id}" $ do + let req = OS3Requests.deleteNotificationConfig "abc-123" + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "configs", "abc-123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the config_id verbatim as the final path segment" $ do + let req = OS3Requests.deleteNotificationConfig "weird/id with spaces" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "configs", "weird/id with spaces"] + + it "carries no body" $ + bhRequestBody (OS3Requests.deleteNotificationConfig "x") `shouldBe` Nothing + + describe "deleteNotificationConfig endpoint shape (OpenSearch 2)" $ do + it "DELETEs /_plugins/_notifications/configs/{config_id}" $ do + let req = OS2Requests.deleteNotificationConfig "abc-123" + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "configs", "abc-123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "carries no body" $ + bhRequestBody (OS2Requests.deleteNotificationConfig "x") `shouldBe` Nothing + + describe "deleteNotificationConfig cross-backend parity (OS2 vs OS3)" $ do + let cfgId = "shared-id" + + it "emits identical paths across OS2/OS3" $ do + let p2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteNotificationConfig cfgId)) + p3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteNotificationConfig cfgId)) + p2 `shouldBe` ["_plugins", "_notifications", "configs", cfgId] + p3 `shouldBe` p2 + + it "emits identical methods across OS2/OS3" $ do + let m2 = bhRequestMethod (OS2Requests.deleteNotificationConfig cfgId) + m3 = bhRequestMethod (OS3Requests.deleteNotificationConfig cfgId) + m2 `shouldBe` "DELETE" + m3 `shouldBe` m2 + + it "emits identical (absent) bodies across OS2/OS3" $ do + let b2 = bhRequestBody (OS2Requests.deleteNotificationConfig cfgId) + b3 = bhRequestBody (OS3Requests.deleteNotificationConfig cfgId) + b2 `shouldBe` Nothing + b3 `shouldBe` b2 + + -- ======================================================================= + -- getNotificationConfigs / NotificationConfigEntry / GetNotificationConfigsResponse + -- (GET /_plugins/_notifications/configs) + -- ======================================================================= + describe "NotificationConfigEntry JSON" $ do + it "decodes the documented sample entry verbatim" $ do + let entryJson = + LBS.pack + "{\ + \ \"config_id\": \"sample-id\",\ + \ \"last_updated_time_ms\": 1652760532774,\ + \ \"created_time_ms\": 1652760532774,\ + \ \"config\": {\ + \ \"name\": \"Sample Slack Channel\",\ + \ \"description\": \"This is a Slack channel\",\ + \ \"config_type\": \"slack\",\ + \ \"is_enabled\": true,\ + \ \"slack\": {\"url\": \"https://sample-slack-webhook\"}\ + \ }\ + \}" + let Just decoded = decode entryJson :: Maybe NotificationConfigEntry + notificationConfigEntryConfigId decoded `shouldBe` "sample-id" + notificationConfigEntryCreatedTimeMs decoded `shouldBe` 1652760532774 + notificationConfigEntryLastUpdatedTimeMs decoded `shouldBe` 1652760532774 + notificationConfigName (notificationConfigEntryConfig decoded) + `shouldBe` "Sample Slack Channel" + + it "round-trips through ToJSON/FromJSON" $ do + let entry = + NotificationConfigEntry + { notificationConfigEntryConfigId = "abc", + notificationConfigEntryCreatedTimeMs = 1700000000000, + notificationConfigEntryLastUpdatedTimeMs = 1700000000001, + notificationConfigEntryConfig = + NotificationConfig + { notificationConfigName = "n", + notificationConfigDescription = Nothing, + notificationConfigIsEnabled = Nothing, + notificationConfigTransport = + NotificationTransportSlack (SlackTransport "u") + } + } + (decode . encode) entry `shouldBe` Just (entry :: NotificationConfigEntry) + + describe "GetNotificationConfigsResponse JSON" $ do + it "decodes the documented empty-list response" $ do + let Just decoded = decode "{\"start_index\":0,\"total_hits\":0,\"total_hit_relation\":\"eq\",\"config_list\":[]}" :: Maybe GetNotificationConfigsResponse + getNotificationConfigsResponseStartIndex decoded `shouldBe` 0 + getNotificationConfigsResponseTotalHits decoded `shouldBe` 0 + getNotificationConfigsResponseTotalHitRelation decoded `shouldBe` NotificationTotalRelationEq + getNotificationConfigsResponseConfigList decoded `shouldBe` [] + + it "decodes gte relation" $ do + let Just decoded = decode "{\"start_index\":0,\"total_hits\":5,\"total_hit_relation\":\"gte\",\"config_list\":[]}" :: Maybe GetNotificationConfigsResponse + getNotificationConfigsResponseTotalHitRelation decoded `shouldBe` NotificationTotalRelationGte + + it "round-trips an unknown relation value via Other" $ do + let resp = + GetNotificationConfigsResponse + { getNotificationConfigsResponseStartIndex = 0, + getNotificationConfigsResponseTotalHits = 0, + getNotificationConfigsResponseTotalHitRelation = NotificationTotalRelationOther "future", + getNotificationConfigsResponseConfigList = [] + } + (decode . encode) resp `shouldBe` Just (resp :: GetNotificationConfigsResponse) + + it "round-trips through ToJSON/FromJSON" $ do + let resp = + GetNotificationConfigsResponse + { getNotificationConfigsResponseStartIndex = 0, + getNotificationConfigsResponseTotalHits = 1, + getNotificationConfigsResponseTotalHitRelation = NotificationTotalRelationEq, + getNotificationConfigsResponseConfigList = [] + } + (decode . encode) resp `shouldBe` Just (resp :: GetNotificationConfigsResponse) + + describe "notificationListOptionsParams" $ do + it "defaultNotificationListOptions renders no params" $ + notificationListOptionsParams defaultNotificationListOptions `shouldBe` [] + + it "renders from_index and max_items as decimal strings" $ do + let opts = + defaultNotificationListOptions + { notificationListOptionsFromIndex = Just 10, + notificationListOptionsMaxItems = Just 25 + } + notificationListOptionsParams opts + `shouldBe` [("from_index", Just "10"), ("max_items", Just "25")] + + it "renders sort_order via notificationSortOrderText" $ do + let opts = + defaultNotificationListOptions + { notificationListOptionsSortOrder = Just NotificationSortOrderDesc + } + notificationListOptionsParams opts + `shouldBe` [("sort_order", Just "desc")] + + it "renders config_type via notificationConfigTypeText" $ do + let opts = + defaultNotificationListOptions + { notificationListOptionsConfigType = Just NotificationConfigTypeChime + } + notificationListOptionsParams opts + `shouldBe` [("config_type", Just "chime")] + + it "renders config_id verbatim" $ do + let opts = defaultNotificationListOptions {notificationListOptionsConfigId = Just "abc"} + notificationListOptionsParams opts `shouldBe` [("config_id", Just "abc")] + + it "renders config_id_list as a comma-separated string" $ do + let opts = + defaultNotificationListOptions + { notificationListOptionsConfigIdList = Just ["a", "b", "c"] + } + notificationListOptionsParams opts + `shouldBe` [("config_id_list", Just "a,b,c")] + + it "renders is_enabled as lowercase true/false" $ do + let trueOpts = defaultNotificationListOptions {notificationListOptionsIsEnabled = Just True} + falseOpts = defaultNotificationListOptions {notificationListOptionsIsEnabled = Just False} + notificationListOptionsParams trueOpts `shouldBe` [("is_enabled", Just "true")] + notificationListOptionsParams falseOpts `shouldBe` [("is_enabled", Just "false")] + + it "omits Nothing fields rather than rendering empty values" $ + notificationListOptionsParams defaultNotificationListOptions {notificationListOptionsSortField = Just "name"} + `shouldBe` [("sort_field", Just "name")] + + describe "getNotificationConfigs endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_notifications/configs with no query by default" $ do + let req = OS3Requests.getNotificationConfigs + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "configs"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "forwards options as query parameters via the With variant" $ do + let opts = defaultNotificationListOptions {notificationListOptionsMaxItems = Just 5} + req = OS3Requests.getNotificationConfigsWith opts + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("max_items", Just "5")] + + it "carries no body" $ + bhRequestBody OS3Requests.getNotificationConfigs `shouldBe` Nothing + + describe "getNotificationConfigs endpoint shape (OpenSearch 2)" $ do + it "GETs /_plugins/_notifications/configs with no query by default" $ do + let req = OS2Requests.getNotificationConfigs + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "configs"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "forwards options as query parameters via the With variant" $ do + let opts = + OS2Types.defaultNotificationListOptions + { OS2Types.notificationListOptionsConfigType = Just OS2Types.NotificationConfigTypeSns + } + req = OS2Requests.getNotificationConfigsWith opts + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("config_type", Just "sns")] + + describe "getNotificationConfigs cross-backend parity (OS2 vs OS3)" $ do + it "emits identical paths and queries for the default options" $ do + let r2 = OS2Requests.getNotificationConfigs + r3 = OS3Requests.getNotificationConfigs + getRawEndpoint (bhRequestEndpoint r2) `shouldBe` getRawEndpoint (bhRequestEndpoint r3) + getRawEndpointQueries (bhRequestEndpoint r2) `shouldBe` getRawEndpointQueries (bhRequestEndpoint r3) + bhRequestMethod r2 `shouldBe` bhRequestMethod r3 + + it "emits identical queries for a populated options record" $ do + let opts2 = + OS2Types.defaultNotificationListOptions + { OS2Types.notificationListOptionsFromIndex = Just 1, + OS2Types.notificationListOptionsMaxItems = Just 50, + OS2Types.notificationListOptionsSortOrder = Just OS2Types.NotificationSortOrderAsc, + OS2Types.notificationListOptionsConfigType = Just OS2Types.NotificationConfigTypeEmail + } + opts3 = + defaultNotificationListOptions + { notificationListOptionsFromIndex = Just 1, + notificationListOptionsMaxItems = Just 50, + notificationListOptionsSortOrder = Just NotificationSortOrderAsc, + notificationListOptionsConfigType = Just NotificationConfigTypeEmail + } + r2 = OS2Requests.getNotificationConfigsWith opts2 + r3 = OS3Requests.getNotificationConfigsWith opts3 + getRawEndpointQueries (bhRequestEndpoint r2) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint r3) + + -- ======================================================================= + -- getNotificationChannels / Channel / GetNotificationChannelsResponse + -- (GET /_plugins/_notifications/channels) + -- ======================================================================= + describe "Channel JSON" $ do + it "decodes the documented sample channel verbatim" $ do + let Just decoded = + decode + "{\ + \ \"config_id\": \"sample-id\",\ + \ \"name\": \"Sample Slack Channel\",\ + \ \"description\": \"This is a Slack channel\",\ + \ \"config_type\": \"slack\",\ + \ \"is_enabled\": true\ + \}" :: + Maybe Channel + channelConfigId decoded `shouldBe` "sample-id" + channelName decoded `shouldBe` "Sample Slack Channel" + channelDescription decoded `shouldBe` Just "This is a Slack channel" + channelConfigType decoded `shouldBe` NotificationConfigTypeSlack + channelIsEnabled decoded `shouldBe` True + + it "decodes a channel with an omitted description" $ do + let Just decoded = + decode + "{\ + \ \"config_id\": \"x\",\ + \ \"name\": \"n\",\ + \ \"config_type\": \"chime\",\ + \ \"is_enabled\": false\ + \}" :: + Maybe Channel + channelDescription decoded `shouldBe` Nothing + channelConfigType decoded `shouldBe` NotificationConfigTypeChime + channelIsEnabled decoded `shouldBe` False + + it "round-trips through ToJSON/FromJSON" $ do + let ch = + Channel + { channelConfigId = "abc", + channelName = "n", + channelDescription = Just "d", + channelConfigType = NotificationConfigTypeWebhook, + channelIsEnabled = True + } + (decode . encode) ch `shouldBe` Just (ch :: Channel) + + it "omits the description field on encode when Nothing" $ do + let ch = + Channel + { channelConfigId = "abc", + channelName = "n", + channelDescription = Nothing, + channelConfigType = NotificationConfigTypeWebhook, + channelIsEnabled = True + } + encode ch `shouldSatisfy` not . BS.isInfixOf "\"description\"" . LBS.toStrict + + describe "GetNotificationChannelsResponse JSON" $ do + it "decodes the documented empty-list response" $ do + let Just decoded = + decode + "{\"start_index\":0,\"total_hits\":0,\"total_hit_relation\":\"eq\",\"channel_list\":[]}" :: + Maybe GetNotificationChannelsResponse + getNotificationChannelsResponseStartIndex decoded `shouldBe` 0 + getNotificationChannelsResponseTotalHits decoded `shouldBe` 0 + getNotificationChannelsResponseTotalHitRelation decoded `shouldBe` NotificationTotalRelationEq + getNotificationChannelsResponseChannelList decoded `shouldBe` [] + + it "decodes the documented two-channel response" $ do + let Just decoded = + decode + "{\ + \ \"start_index\": 0,\ + \ \"total_hits\": 2,\ + \ \"total_hit_relation\": \"eq\",\ + \ \"channel_list\": [\ + \ {\ + \ \"config_id\": \"sample-id\",\ + \ \"name\": \"Sample Slack Channel\",\ + \ \"description\": \"This is a Slack channel\",\ + \ \"config_type\": \"slack\",\ + \ \"is_enabled\": true\ + \ },\ + \ {\ + \ \"config_id\": \"sample-id2\",\ + \ \"name\": \"Test chime channel\",\ + \ \"description\": \"A test chime channel\",\ + \ \"config_type\": \"chime\",\ + \ \"is_enabled\": true\ + \ }\ + \ ]\ + \}" :: + Maybe GetNotificationChannelsResponse + let channels = getNotificationChannelsResponseChannelList decoded + length channels `shouldBe` 2 + getNotificationChannelsResponseTotalHits decoded `shouldBe` 2 + -- Per-field assertions on each channel so a regression in + -- individual field parsing surfaces here, not just a count + -- mismatch. + let [c1, c2] = channels + channelConfigId c1 `shouldBe` "sample-id" + channelName c1 `shouldBe` "Sample Slack Channel" + channelDescription c1 `shouldBe` Just "This is a Slack channel" + channelConfigType c1 `shouldBe` NotificationConfigTypeSlack + channelIsEnabled c1 `shouldBe` True + channelConfigId c2 `shouldBe` "sample-id2" + channelName c2 `shouldBe` "Test chime channel" + channelConfigType c2 `shouldBe` NotificationConfigTypeChime + channelIsEnabled c2 `shouldBe` True + + describe "getNotificationChannels endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_notifications/channels with no query by default" $ do + let req = OS3Requests.getNotificationChannels + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "channels"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "forwards options as query parameters via the With variant" $ do + let opts = defaultNotificationListOptions {notificationListOptionsMaxItems = Just 3} + req = OS3Requests.getNotificationChannelsWith opts + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("max_items", Just "3")] + + it "carries no body" $ + bhRequestBody OS3Requests.getNotificationChannels `shouldBe` Nothing + + describe "getNotificationChannels endpoint shape (OpenSearch 2)" $ do + it "GETs /_plugins/_notifications/channels with no query by default" $ do + let req = OS2Requests.getNotificationChannels + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "channels"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "forwards options as query parameters via the With variant" $ do + let opts = + OS2Types.defaultNotificationListOptions + { OS2Types.notificationListOptionsConfigType = Just OS2Types.NotificationConfigTypeSesAccount + } + req = OS2Requests.getNotificationChannelsWith opts + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("config_type", Just "ses_account")] + + describe "getNotificationChannels cross-backend parity (OS2 vs OS3)" $ do + it "emits identical paths and queries for the default options" $ do + let r2 = OS2Requests.getNotificationChannels + r3 = OS3Requests.getNotificationChannels + getRawEndpoint (bhRequestEndpoint r2) `shouldBe` getRawEndpoint (bhRequestEndpoint r3) + getRawEndpointQueries (bhRequestEndpoint r2) `shouldBe` getRawEndpointQueries (bhRequestEndpoint r3) + bhRequestMethod r2 `shouldBe` bhRequestMethod r3 + + it "emits identical queries for a populated options record" $ do + let opts2 = + OS2Types.defaultNotificationListOptions + { OS2Types.notificationListOptionsSortOrder = Just OS2Types.NotificationSortOrderDesc, + OS2Types.notificationListOptionsSortField = Just "name" + } + opts3 = + defaultNotificationListOptions + { notificationListOptionsSortOrder = Just NotificationSortOrderDesc, + notificationListOptionsSortField = Just "name" + } + r2 = OS2Requests.getNotificationChannelsWith opts2 + r3 = OS3Requests.getNotificationChannelsWith opts3 + getRawEndpointQueries (bhRequestEndpoint r2) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint r3) + + -- ======================================================================= + -- NotificationFeaturesResponse (GET /_plugins/_notifications/features) + -- ======================================================================= + describe "NotificationFeaturesResponse JSON" $ do + it "decodes the documented features body verbatim" $ do + let body = + "{\ + \ \"allowed_config_type_list\": [\ + \ \"slack\",\ + \ \"chime\",\ + \ \"webhook\",\ + \ \"email\",\ + \ \"sns\",\ + \ \"ses_account\",\ + \ \"smtp_account\",\ + \ \"email_group\"\ + \ ],\ + \ \"plugin_features\": {\ + \ \"tooltip_support\": \"true\"\ + \ }\ + \}" + Just (decoded :: NotificationFeaturesResponse) = decode body + notificationFeaturesResponseAllowedConfigTypeList decoded + `shouldBe` [ NotificationConfigTypeSlack, + NotificationConfigTypeChime, + NotificationConfigTypeWebhook, + NotificationConfigTypeEmail, + NotificationConfigTypeSns, + NotificationConfigTypeSesAccount, + NotificationConfigTypeSmtpAccount, + NotificationConfigTypeEmailGroup + ] + notificationFeaturesResponsePluginFeatures decoded + `shouldBe` Map.singleton "tooltip_support" "true" + + it "decodes when plugin_features is absent (defensive .!=)" $ do + -- The docs always show plugin_features, but the server may omit + -- it on a stripped-down build; we decode such a body to the empty + -- map rather than parse-failing. + let body = + "{\"allowed_config_type_list\": [\"slack\"]}" + Just (decoded :: NotificationFeaturesResponse) = decode body + notificationFeaturesResponsePluginFeatures decoded `shouldBe` Map.empty + + it "fails when allowed_config_type_list is absent" $ + decode "{}" `shouldBe` (Nothing :: Maybe NotificationFeaturesResponse) + + it "fails on an unknown config_type inside the list" $ do + -- Reuses the NotificationConfigType fail-loud policy: a future + -- plugin release adding a tenth config_type surfaces as a + -- deliberate decode error rather than a silent drop. + let body = + "{\"allowed_config_type_list\": [\"slack\", \"future_transport\"]}" + decode body `shouldBe` (Nothing :: Maybe NotificationFeaturesResponse) + + it "round-trips through ToJSON/FromJSON" $ + property $ \(resp :: NotificationFeaturesResponse) -> + (decode . encode) resp === Just resp + + it "round-trips an empty allowed_config_type_list (no omitNulls stripping)" $ do + -- Pins the choice of `object` (not `omitNulls`) for the + -- ToJSON instance: a response type must round-trip every value + -- it can construct, including the empty list. omitNulls would + -- strip the empty Array, breaking the round-trip; the + -- QuickCheck property above does not catch this because the + -- Arbitrary instance uses listOf1 (non-empty), so this explicit + -- case closes the gap. + let resp = + NotificationFeaturesResponse + { notificationFeaturesResponseAllowedConfigTypeList = [], + notificationFeaturesResponsePluginFeatures = Map.empty + } + (decode . encode) resp `shouldBe` Just resp + + -- ======================================================================= + -- TestNotificationResponse + sub-types + -- (GET /_plugins/_notifications/feature/test/{config_id}) + -- ======================================================================= + describe "TestNotificationDeliveryStatus JSON" $ do + it "round-trips the documented shape" $ do + let s = TestNotificationDeliveryStatus "200" "ok" + (decode . encode) s `shouldBe` Just s + it "requires status_code and status_text" $ + decode "{\"status_code\":\"200\"}" + `shouldBe` (Nothing :: Maybe TestNotificationDeliveryStatus) + + describe "TestNotificationStatus JSON" $ do + it "decodes a slack status entry verbatim" $ do + let body = + "{\ + \ \"config_id\": \"abc\",\ + \ \"config_type\": \"slack\",\ + \ \"config_name\": \"sample-id\",\ + \ \"email_recipient_status\": [],\ + \ \"delivery_status\": {\ + \ \"status_code\": \"200\",\ + \ \"status_text\": \"delivered\"\ + \ }\ + \}" + Just (decoded :: TestNotificationStatus) = decode body + testNotificationStatusConfigId decoded `shouldBe` "abc" + testNotificationStatusConfigType decoded `shouldBe` NotificationConfigTypeSlack + testNotificationStatusConfigName decoded `shouldBe` "sample-id" + testNotificationStatusEmailRecipientStatus decoded `shouldBe` [] + testNotificationDeliveryStatusCode (testNotificationStatusDeliveryStatus decoded) + `shouldBe` "200" + + it "decodes when email_recipient_status is absent (defensive .!=)" $ do + -- The docs only show email_recipient_status as the empty list; + -- a non-email channel (slack/chime/...) has no recipients and + -- the server may omit the field entirely. + let body = + "{\ + \ \"config_id\": \"x\",\ + \ \"config_type\": \"chime\",\ + \ \"config_name\": \"n\",\ + \ \"delivery_status\": {\"status_code\": \"200\", \"status_text\": \"\"}\ + \}" + Just (decoded :: TestNotificationStatus) = decode body + testNotificationStatusEmailRecipientStatus decoded `shouldBe` [] + + it "fails when config_type is unknown" $ do + let body = + "{\ + \ \"config_id\": \"x\",\ + \ \"config_type\": \"future\",\ + \ \"config_name\": \"n\",\ + \ \"delivery_status\": {\"status_code\": \"200\", \"status_text\": \"\"}\ + \}" + decode body `shouldBe` (Nothing :: Maybe TestNotificationStatus) + + it "round-trips" $ + property $ \(s :: TestNotificationStatus) -> + (decode . encode) s === Just s + + describe "TestNotificationEventSource JSON" $ do + it "decodes the documented event_source verbatim" $ do + let body = + "{\ + \ \"title\": \"Test Message Title-0Jnlh4ABa4TCWn5C5H2G\",\ + \ \"reference_id\": \"0Jnlh4ABa4TCWn5C5H2G\",\ + \ \"severity\": \"info\",\ + \ \"tags\": []\ + \}" + Just (decoded :: TestNotificationEventSource) = decode body + testNotificationEventSourceTitle decoded `shouldBe` "Test Message Title-0Jnlh4ABa4TCWn5C5H2G" + testNotificationEventSourceSeverity decoded `shouldBe` "info" + testNotificationEventSourceTags decoded `shouldBe` [] + + it "decodes when tags is absent (defensive .!= [])" $ do + let body = + "{\"title\":\"t\",\"reference_id\":\"r\",\"severity\":\"info\"}" + Just (decoded :: TestNotificationEventSource) = decode body + testNotificationEventSourceTags decoded `shouldBe` [] + + it "round-trips" $ + property $ \(e :: TestNotificationEventSource) -> + (decode . encode) e === Just e + + describe "TestNotificationResponse JSON" $ do + it "decodes the documented send-test body verbatim" $ do + let body = + "{\ + \ \"event_source\": {\ + \ \"title\": \"Test Message Title-0Jnlh4ABa4TCWn5C5H2G\",\ + \ \"reference_id\": \"0Jnlh4ABa4TCWn5C5H2G\",\ + \ \"severity\": \"info\",\ + \ \"tags\": []\ + \ },\ + \ \"status_list\": [\ + \ {\ + \ \"config_id\": \"0Jnlh4ABa4TCWn5C5H2G\",\ + \ \"config_type\": \"slack\",\ + \ \"config_name\": \"sample-id\",\ + \ \"email_recipient_status\": [],\ + \ \"delivery_status\": {\ + \ \"status_code\": \"200\",\ + \ \"status_text\": \"delivered\"\ + \ }\ + \ }\ + \ ]\ + \}" + Just (decoded :: TestNotificationResponse) = decode body + testNotificationEventSourceSeverity (testNotificationResponseEventSource decoded) + `shouldBe` "info" + length (testNotificationResponseStatusList decoded) `shouldBe` 1 + + it "round-trips" $ + property $ \(r :: TestNotificationResponse) -> + (decode . encode) r === Just r + + -- ======================================================================= + -- getNotificationConfig endpoint shape (GET configs/{config_id}) + -- ======================================================================= + describe "getNotificationConfig endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_notifications/configs/{config_id}" $ do + let req = OS3Requests.getNotificationConfig "abc-123" + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "configs", "abc-123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "carries no body" $ + bhRequestBody (OS3Requests.getNotificationConfig "x") `shouldBe` Nothing + + describe "getNotificationConfig endpoint shape (OpenSearch 2)" $ do + it "GETs /_plugins/_notifications/configs/{config_id}" $ do + let req = OS2Requests.getNotificationConfig "abc-123" + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "configs", "abc-123"] + + describe "getNotificationConfig cross-backend parity (OS2 vs OS3)" $ do + it "emits identical paths/methods/queries for the same id" $ do + let r2 = OS2Requests.getNotificationConfig "shared-id" + r3 = OS3Requests.getNotificationConfig "shared-id" + getRawEndpoint (bhRequestEndpoint r2) `shouldBe` getRawEndpoint (bhRequestEndpoint r3) + bhRequestMethod r2 `shouldBe` bhRequestMethod r3 + getRawEndpointQueries (bhRequestEndpoint r2) `shouldBe` getRawEndpointQueries (bhRequestEndpoint r3) + + -- ======================================================================= + -- updateNotificationConfig endpoint shape (PUT configs/{config_id}) + -- ======================================================================= + describe "updateNotificationConfig endpoint shape (OpenSearch 3)" $ do + let cfg = + NotificationConfig + { notificationConfigName = "n", + notificationConfigDescription = Nothing, + notificationConfigIsEnabled = Nothing, + notificationConfigTransport = NotificationTransportSlack (SlackTransport "u") + } + it "PUTs to /_plugins/_notifications/configs/{config_id}" $ do + let req = OS3Requests.updateNotificationConfig "abc-123" cfg + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "configs", "abc-123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "wraps the config under the \"config\" key (not flat like create)" $ do + let req = OS3Requests.updateNotificationConfig "id" cfg + body = maybe (error "updateNotificationConfig must carry a body") id (bhRequestBody req) + bs = LBS.toStrict body + BS.isInfixOf "\"config\":" bs `shouldBe` True + -- A create-shaped body would carry a top-level config_id; the + -- update endpoint must NOT (identity is the URL path segment). + BS.isInfixOf "\"config_id\"" bs `shouldBe` False + it "attaches a non-empty body" $ + bhRequestBody (OS3Requests.updateNotificationConfig "x" cfg) `shouldSatisfy` isJust + + describe "updateNotificationConfig endpoint shape (OpenSearch 2)" $ do + it "PUTs to /_plugins/_notifications/configs/{config_id}" $ do + let cfg = + OS2Types.NotificationConfig + { OS2Types.notificationConfigName = "n", + OS2Types.notificationConfigDescription = Nothing, + OS2Types.notificationConfigIsEnabled = Nothing, + OS2Types.notificationConfigTransport = + OS2Types.NotificationTransportSlack (OS2Types.SlackTransport "u") + } + req = OS2Requests.updateNotificationConfig "abc-123" cfg + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "configs", "abc-123"] + + describe "updateNotificationConfig cross-backend parity (OS2 vs OS3)" $ do + it "emits identical paths/methods/bodies for the same id+config" $ do + let mkOS2 = + OS2Types.NotificationConfig + { OS2Types.notificationConfigName = "n", + OS2Types.notificationConfigDescription = Nothing, + OS2Types.notificationConfigIsEnabled = Nothing, + OS2Types.notificationConfigTransport = + OS2Types.NotificationTransportSlack (OS2Types.SlackTransport "u") + } + mkOS3 = + NotificationConfig + { notificationConfigName = "n", + notificationConfigDescription = Nothing, + notificationConfigIsEnabled = Nothing, + notificationConfigTransport = NotificationTransportSlack (SlackTransport "u") + } + r2 = OS2Requests.updateNotificationConfig "id" mkOS2 + r3 = OS3Requests.updateNotificationConfig "id" mkOS3 + getRawEndpoint (bhRequestEndpoint r2) `shouldBe` getRawEndpoint (bhRequestEndpoint r3) + bhRequestMethod r2 `shouldBe` bhRequestMethod r3 + let bodies = + catMaybes + [ bhRequestBody r2, + bhRequestBody r3 + ] + length bodies `shouldBe` 2 + length (L.nub (L.map LBS.toStrict bodies)) `shouldBe` 1 + + -- ======================================================================= + -- deleteNotificationConfigs endpoint shape + -- (DELETE configs/?config_id_list=id1,id2,...) + -- ======================================================================= + describe "deleteNotificationConfigs endpoint shape (OpenSearch 3)" $ do + it "DELETEs /_plugins/_notifications/configs with a config_id_list query" $ do + let req = OS3Requests.deleteNotificationConfigs ("a" :| ["b", "c"]) + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "configs"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("config_id_list", Just "a,b,c")] + it "serializes a single-id NonEmpty without trailing comma" $ do + let req = OS3Requests.deleteNotificationConfigs ("only" :| []) + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("config_id_list", Just "only")] + it "carries no body" $ + bhRequestBody (OS3Requests.deleteNotificationConfigs ("a" :| [])) `shouldBe` Nothing + + describe "deleteNotificationConfigs endpoint shape (OpenSearch 2)" $ do + it "DELETEs /_plugins/_notifications/configs with a config_id_list query" $ do + let req = OS2Requests.deleteNotificationConfigs ("a" :| ["b"]) + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "configs"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("config_id_list", Just "a,b")] + + describe "deleteNotificationConfigs cross-backend parity (OS2 vs OS3)" $ do + it "emits identical paths/methods/queries for the same id list" $ do + let ids = "x" :| ["y", "z"] + r2 = OS2Requests.deleteNotificationConfigs ids + r3 = OS3Requests.deleteNotificationConfigs ids + getRawEndpoint (bhRequestEndpoint r2) `shouldBe` getRawEndpoint (bhRequestEndpoint r3) + bhRequestMethod r2 `shouldBe` bhRequestMethod r3 + getRawEndpointQueries (bhRequestEndpoint r2) `shouldBe` getRawEndpointQueries (bhRequestEndpoint r3) + + -- ======================================================================= + -- getNotificationFeatures endpoint shape + -- (GET /_plugins/_notifications/features) + -- ======================================================================= + describe "getNotificationFeatures endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_notifications/features with no query" $ do + let req = OS3Requests.getNotificationFeatures + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "features"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "carries no body" $ + bhRequestBody OS3Requests.getNotificationFeatures `shouldBe` Nothing + + describe "getNotificationFeatures endpoint shape (OpenSearch 2)" $ do + it "GETs /_plugins/_notifications/features with no query" $ do + let req = OS2Requests.getNotificationFeatures + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "features"] + + describe "getNotificationFeatures cross-backend parity (OS2 vs OS3)" $ do + it "emits identical paths/methods/queries" $ do + let r2 = OS2Requests.getNotificationFeatures + r3 = OS3Requests.getNotificationFeatures + getRawEndpoint (bhRequestEndpoint r2) `shouldBe` getRawEndpoint (bhRequestEndpoint r3) + bhRequestMethod r2 `shouldBe` bhRequestMethod r3 + getRawEndpointQueries (bhRequestEndpoint r2) `shouldBe` getRawEndpointQueries (bhRequestEndpoint r3) + + -- ======================================================================= + -- sendTestNotification endpoint shape + -- (GET /_plugins/_notifications/feature/test/{config_id}) + -- ======================================================================= + describe "sendTestNotification endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_notifications/feature/test/{config_id}" $ do + let req = OS3Requests.sendTestNotification "abc-123" + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "feature", "test", "abc-123"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "carries no body" $ + bhRequestBody (OS3Requests.sendTestNotification "x") `shouldBe` Nothing + + describe "sendTestNotification endpoint shape (OpenSearch 2)" $ do + it "GETs /_plugins/_notifications/feature/test/{config_id}" $ do + let req = OS2Requests.sendTestNotification "abc-123" + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_notifications", "feature", "test", "abc-123"] + + describe "sendTestNotification cross-backend parity (OS2 vs OS3)" $ do + it "emits identical paths/methods/queries for the same id" $ do + let r2 = OS2Requests.sendTestNotification "shared-id" + r3 = OS3Requests.sendTestNotification "shared-id" + getRawEndpoint (bhRequestEndpoint r2) `shouldBe` getRawEndpoint (bhRequestEndpoint r3) + bhRequestMethod r2 `shouldBe` bhRequestMethod r3 + getRawEndpointQueries (bhRequestEndpoint r2) `shouldBe` getRawEndpointQueries (bhRequestEndpoint r3) + + -- ======================================================================= + -- Live integration: create -> list configs -> list channels -> delete + -- round-trip, gated to OpenSearch 2 and 3 (the Notifications plugin + -- shipped in OS 2.0; no OS1 twin). Each backend has its own Client + -- module (twin types), so we write one test per backend, gated via + -- os2OnlyIT / os3OnlyIT. A timestamp-suffixed config_id avoids + -- collisions across concurrent or failed runs; bracket_ guarantees + -- the delete runs even on assertion failure. + -- + -- The Notifications plugin persists configs to a system index + -- (@.opendistro-notifications-config@) whose default refresh interval + -- (~1s on OS2, shorter on OS3) means a freshly-created config is not + -- visible to GET immediately. 'waitFor' polls the listing until the + -- new config appears or a bounded timeout (5s) elapses. + -- ======================================================================= + describe "Notifications plugin live round-trip" $ do + let webhookConfigOS3 = + NotificationConfig + { notificationConfigName = "bloodhound test webhook", + notificationConfigDescription = Just "live round-trip fixture", + notificationConfigIsEnabled = Just True, + notificationConfigTransport = + NotificationTransportWebhook (WebhookTransport "https://example.invalid/hook") + } + webhookConfigOS2 = + OS2Types.NotificationConfig + { OS2Types.notificationConfigName = "bloodhound test webhook", + OS2Types.notificationConfigDescription = Just "live round-trip fixture", + OS2Types.notificationConfigIsEnabled = Just True, + OS2Types.notificationConfigTransport = + OS2Types.NotificationTransportWebhook (OS2Types.WebhookTransport "https://example.invalid/hook") + } + + os3It <- runIO os3OnlyIT + os3It "create -> list configs -> list channels -> delete (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let configId = T.pack ("bloodhound_test_notif_os3_" <> suffix) + bracket_ + ( do + createResp <- OS3Client.createNotificationConfigWith (Just configId) webhookConfigOS3 + liftIO $ + case createResp of + Left e -> expectationFailure ("Setup createNotificationConfigWith failed: " <> show e) + Right _ -> pure () + ) + (void $ OS3Client.deleteNotificationConfig configId) + $ do + configsResult <- + waitFor $ + do + configsResp <- OS3Client.getNotificationConfigs + pure $ case configsResp of + Right configs -> + Right (configId `elem` map notificationConfigEntryConfigId configs) + Left e -> Left e + liftIO $ + case configsResult of + Right True -> pure () + Right False -> + expectationFailure ("config_id " <> T.unpack configId <> " not found in getNotificationConfigs after polling") + Left e -> + expectationFailure ("getNotificationConfigs failed during polling: " <> show e) + channelsResult <- + waitFor $ + do + channelsResp <- OS3Client.getNotificationChannels + pure $ case channelsResp of + Right channels -> + Right (configId `elem` map channelConfigId channels) + Left e -> Left e + liftIO $ + case channelsResult of + Right True -> pure () + Right False -> + expectationFailure ("config_id " <> T.unpack configId <> " not found in getNotificationChannels after polling") + Left e -> + expectationFailure ("getNotificationChannels failed during polling: " <> show e) + -- getNotificationConfig (single): the per-id GET must + -- surface the same entry the list-all just found. + getConfigResult <- + waitFor $ + do + resp <- OS3Client.getNotificationConfig configId + pure $ case resp of + Right (Just entry) + | notificationConfigEntryConfigId entry == configId -> Right True + | otherwise -> Right False + Right Nothing -> Right False + Left e -> Left e + liftIO $ + case getConfigResult of + Right True -> pure () + Right False -> + expectationFailure ("getNotificationConfig did not return the config_id " <> T.unpack configId) + Left e -> + expectationFailure ("getNotificationConfig failed: " <> show e) + -- updateNotificationConfig: rename, then verify the new + -- name round-trips through getNotificationConfig. + let updatedConfig = + webhookConfigOS3 + { notificationConfigName = "bloodhound test webhook (renamed)" + } + updateResp <- OS3Client.updateNotificationConfig configId updatedConfig + liftIO $ + case updateResp of + Left e -> + expectationFailure ("updateNotificationConfig failed: " <> show e) + Right _ -> pure () + updatedNameResult <- + waitFor $ + do + resp <- OS3Client.getNotificationConfig configId + pure $ case resp of + Right (Just entry) -> + Right (notificationConfigName (notificationConfigEntryConfig entry) == "bloodhound test webhook (renamed)") + Right Nothing -> Right False + Left e -> Left e + liftIO $ + case updatedNameResult of + Right True -> pure () + Right False -> + expectationFailure ("updateNotificationConfig rename did not round-trip through getNotificationConfig for " <> T.unpack configId) + Left e -> + expectationFailure ("getNotificationConfig after update failed: " <> show e) + -- getNotificationFeatures: capability discovery. The test + -- cluster accepts webhook configs (we just created one), so + -- NotificationConfigTypeWebhook must be in the allowed list. + featuresResp <- OS3Client.getNotificationFeatures + liftIO $ + case featuresResp of + Left e -> + expectationFailure ("getNotificationFeatures failed: " <> show e) + Right feats -> + NotificationConfigTypeWebhook + `elem` notificationFeaturesResponseAllowedConfigTypeList feats + `shouldBe` True + -- sendTestNotification is deliberately NOT exercised here: + -- it triggers a real delivery attempt to the config's + -- transport (a POST to https://example.invalid/hook for + -- our fixture), which would fail with a DNS error and + -- pollute CI logs without proving anything the pure + -- endpoint-shape tests don't already cover. + + os2It <- runIO os2OnlyIT + os2It "create -> list configs -> list channels -> delete (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let configId = T.pack ("bloodhound_test_notif_os2_" <> suffix) + bracket_ + ( do + createResp <- OS2Client.createNotificationConfigWith (Just configId) webhookConfigOS2 + liftIO $ + case createResp of + Left e -> expectationFailure ("Setup createNotificationConfigWith failed: " <> show e) + Right _ -> pure () + ) + (void $ OS2Client.deleteNotificationConfig configId) + $ do + configsResult <- + waitFor $ + do + configsResp <- OS2Client.getNotificationConfigs + pure $ case configsResp of + Right configs -> + Right (configId `elem` map OS2Types.notificationConfigEntryConfigId configs) + Left e -> Left e + liftIO $ + case configsResult of + Right True -> pure () + Right False -> + expectationFailure ("config_id " <> T.unpack configId <> " not found in getNotificationConfigs after polling") + Left e -> + expectationFailure ("getNotificationConfigs failed during polling: " <> show e) + channelsResult <- + waitFor $ + do + channelsResp <- OS2Client.getNotificationChannels + pure $ case channelsResp of + Right channels -> + Right (configId `elem` map OS2Types.channelConfigId channels) + Left e -> Left e + liftIO $ + case channelsResult of + Right True -> pure () + Right False -> + expectationFailure ("config_id " <> T.unpack configId <> " not found in getNotificationChannels after polling") + Left e -> + expectationFailure ("getNotificationChannels failed during polling: " <> show e) + -- getNotificationConfig (single): the per-id GET must + -- surface the same entry the list-all just found. + getConfigResult <- + waitFor $ + do + resp <- OS2Client.getNotificationConfig configId + pure $ case resp of + Right (Just entry) + | OS2Types.notificationConfigEntryConfigId entry == configId -> Right True + | otherwise -> Right False + Right Nothing -> Right False + Left e -> Left e + liftIO $ + case getConfigResult of + Right True -> pure () + Right False -> + expectationFailure ("getNotificationConfig did not return the config_id " <> T.unpack configId) + Left e -> + expectationFailure ("getNotificationConfig failed: " <> show e) + -- updateNotificationConfig: rename, then verify the new + -- name round-trips through getNotificationConfig. + let updatedConfig = + webhookConfigOS2 + { OS2Types.notificationConfigName = "bloodhound test webhook (renamed)" + } + updateResp <- OS2Client.updateNotificationConfig configId updatedConfig + liftIO $ + case updateResp of + Left e -> + expectationFailure ("updateNotificationConfig failed: " <> show e) + Right _ -> pure () + updatedNameResult <- + waitFor $ + do + resp <- OS2Client.getNotificationConfig configId + pure $ case resp of + Right (Just entry) -> + Right + ( OS2Types.notificationConfigName + (OS2Types.notificationConfigEntryConfig entry) + == "bloodhound test webhook (renamed)" + ) + Right Nothing -> Right False + Left e -> Left e + liftIO $ + case updatedNameResult of + Right True -> pure () + Right False -> + expectationFailure ("updateNotificationConfig rename did not round-trip through getNotificationConfig for " <> T.unpack configId) + Left e -> + expectationFailure ("getNotificationConfig after update failed: " <> show e) + -- getNotificationFeatures: capability discovery. The test + -- cluster accepts webhook configs (we just created one), so + -- NotificationConfigTypeWebhook must be in the allowed list. + featuresResp <- OS2Client.getNotificationFeatures + liftIO $ + case featuresResp of + Left e -> + expectationFailure ("getNotificationFeatures failed: " <> show e) + Right feats -> + OS2Types.NotificationConfigTypeWebhook + `elem` OS2Types.notificationFeaturesResponseAllowedConfigTypeList feats + `shouldBe` True + +-- | Poll a query at 0.5s intervals until it returns @'Right' 'True'@ or +-- 10 attempts (5s total) elapse. Returns the last result so the caller +-- can fail with the actual server error rather than a misleading +-- \"not found\": a @'Left' e@ surfaces the 'EsError', a @'Right' +-- 'False'@ means the polling exhausted without the predicate ever +-- holding. Used to absorb the Notifications plugin's ~1-2s system-index +-- refresh delay on OS2. +waitFor :: (MonadIO m) => m (Either EsError Bool) -> m (Either EsError Bool) +waitFor check = go (0 :: Int) + where + go n = do + result <- check + case result of + Right True -> pure result + _ + | n >= 9 -> pure result + | otherwise -> do + liftIO $ threadDelay 500000 + go (n + 1) + +-- QuickCheck instances for NotificationConfigType roundtrip property. +-- We don't derive Arbitrary generically because the enum is closed; we +-- pick from the explicit list. +instance Arbitrary NotificationConfigType where + arbitrary = + elements + [ NotificationConfigTypeSlack, + NotificationConfigTypeChime, + NotificationConfigTypeWebhook, + NotificationConfigTypeMicrosoftTeams, + NotificationConfigTypeSns, + NotificationConfigTypeSesAccount, + NotificationConfigTypeSmtpAccount, + NotificationConfigTypeEmailGroup, + NotificationConfigTypeEmail + ] + shrink _ = [] + +-- Drives the DeleteNotificationConfigResponse round-trip property above. +-- Keys are short ASCII strings to keep the JSON readable on failure; the +-- plugin only documents @"OK"@ as a status value but the wire shape +-- permits any string, so the generator emits arbitrary status text to +-- exercise the parser's openness. +instance Arbitrary DeleteNotificationConfigResponse where + arbitrary = + DeleteNotificationConfigResponse . Map.fromList + <$> listOf + ( (,) + <$> (T.pack <$> listOf1 (elements ['a' .. 'z'])) + <*> (T.pack <$> listOf1 (elements ("OKFAILabc" :: String))) + ) + shrink (DeleteNotificationConfigResponse m) = + [ DeleteNotificationConfigResponse (Map.fromList smaller) + | smaller <- shrinkList (const []) (Map.toList m), + not (null smaller) + ] + +-- Drives the NotificationFeaturesResponse round-trip property. The +-- allowed_config_type_list is a non-empty subset of the 9-variant enum +-- (the docs example lists 8; real clusters vary), so we pick a random +-- non-empty sublist rather than a fixed one. The plugin_features map +-- reuses the DeleteNotificationConfigResponse hand-rolled Map pattern +-- (short ASCII keys/values keep failure output readable). +instance Arbitrary NotificationFeaturesResponse where + arbitrary = do + types <- listOf1 arbitrary + feats <- + Map.fromList + <$> listOf + ( (,) + <$> (T.pack <$> listOf1 (elements ['a' .. 'z'])) + <*> (T.pack <$> listOf1 (elements ("truefalse01" :: String))) + ) + pure + NotificationFeaturesResponse + { notificationFeaturesResponseAllowedConfigTypeList = types, + notificationFeaturesResponsePluginFeatures = feats + } + shrink (NotificationFeaturesResponse types feats) = + [ NotificationFeaturesResponse types' feats + | types' <- shrinkList (const []) types, + not (null types') + ] + ++ [ NotificationFeaturesResponse types (Map.fromList smaller) + | smaller <- shrinkList (const []) (Map.toList feats) + ] + +-- Drives the TestNotificationDeliveryStatus round-trip property. +-- status_code is typed as Text (the plugin emits "200" not 200); we +-- emit short numeric-looking strings to mirror the wire shape. +instance Arbitrary TestNotificationDeliveryStatus where + arbitrary = + TestNotificationDeliveryStatus + <$> (T.pack <$> listOf1 (elements ("0123456789" :: String))) + <*> (T.pack <$> listOf (elements ('a' : ['A' .. 'Z'] ++ "<>/= "))) + +-- Drives the TestNotificationStatus round-trip property. The +-- email_recipient_status field is opaque [Value]; the docs only ever +-- show it empty and the per-recipient object shape is under-documented, +-- so we generate the empty list rather than hand-roll a Value generator +-- (which would pull in quickcheck-instances for an Arbitrary Value). +-- No @shrink@ override: the property's job is to flag a round-trip +-- failure, and the inline Text generators (@listOf1 ...@) are simple +-- enough that a failure surfaces clearly without counterexample +-- minimisation. The non-empty @[Value]@ case is therefore unverified +-- by the property — the field is typed @[Value]@ for forward +-- compatibility but the parser's behaviour on a populated list is not +-- exercised here. +instance Arbitrary TestNotificationStatus where + arbitrary = + TestNotificationStatus + <$> (T.pack <$> listOf1 (elements ('a' : ['0' .. '9']))) + <*> arbitrary + <*> (T.pack <$> listOf1 (elements ['a' .. 'z'])) + <*> pure [] + <*> arbitrary + +-- Drives the TestNotificationEventSource round-trip property. severity +-- is typed as Text (the plugin emits "info"/"warning"/"critical" but +-- the enum is not fully documented); we emit short alphabetic strings. +instance Arbitrary TestNotificationEventSource where + arbitrary = + TestNotificationEventSource + <$> (T.pack <$> listOf1 (elements ['a' .. 'z'])) + <*> (T.pack <$> listOf1 (elements ('a' : ['0' .. '9']))) + <*> (T.pack <$> listOf1 (elements ['a' .. 'z'])) + <*> listOf (T.pack <$> listOf1 (elements ['a' .. 'z'])) + +-- Drives the TestNotificationResponse round-trip property. Composes +-- the event_source and a short status_list (capped at 2 entries to +-- keep the property fast under 100 samples + shrinks). +instance Arbitrary TestNotificationResponse where + arbitrary = do + src <- arbitrary + n <- choose (0, 2) + statuses <- replicateM n arbitrary + pure + TestNotificationResponse + { testNotificationResponseEventSource = src, + testNotificationResponseStatusList = statuses + } + shrink (TestNotificationResponse src statuses) = + [ TestNotificationResponse src smaller + | smaller <- shrinkList (const []) statuses + ] diff --git a/tests/Test/OSAsyncSearchSpec.hs b/tests/Test/OSAsyncSearchSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/OSAsyncSearchSpec.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.OSAsyncSearchSpec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List (sort) +import Data.Map.Strict qualified as Map +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types qualified as OS3Types +import TestsUtils.Import +import Prelude + +-- | Pure endpoint-shape tests for the OpenSearch async search plugin +-- (@\/_plugins\/_asynchronous_search@). These mirror the Elasticsearch +-- 'Test.AsyncSearchSpec' shape tests but assert the @\/_plugins\/@ path +-- prefix and the OS-specific function names. +-- +-- Only the OpenSearch 3 'Requests' module is exercised here: the three +-- functions produce identical 'BHRequest' values at runtime across +-- 'OpenSearch1.Requests', 'OpenSearch2.Requests' and 'OpenSearch3.Requests' +-- (the async search plugin ships in all three versions with the same surface; +-- only the source spelling differs — OS1 wraps path lists in 'mkEndpoint' +-- explicitly because it lacks @OverloadedLists@). The REST path is the +-- fully-spelled @\/_plugins\/_asynchronous_search@ on every OpenSearch +-- version. JSON decoding of the shared 'AsyncSearchResult' is already pinned +-- by 'Test.AsyncSearchSpec'. +spec :: Spec +spec = describe "OpenSearch Async Search API" $ do + describe "submitOSAsyncSearch endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "POSTs to /_plugins/_asynchronous_search with no query string" $ do + let search = mkSearch (Just (MatchAllQuery Nothing)) Nothing + req = OS3Requests.submitOSAsyncSearch @Value search + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_asynchronous_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches the encoded Search as the JSON body" $ do + let search = mkSearch (Just (MatchAllQuery Nothing)) Nothing + req = OS3Requests.submitOSAsyncSearch @Value search + bhRequestBody req `shouldBe` Just (encode search) + + it "tracks the input Search: a different query yields a different body" $ do + let reqA = OS3Requests.submitOSAsyncSearch @Value (mkSearch (Just (MatchAllQuery Nothing)) Nothing) + reqB = OS3Requests.submitOSAsyncSearch @Value (mkSearch (Just (TermQuery (Term "user" "bob") Nothing)) Nothing) + bhRequestBody reqA `shouldNotBe` bhRequestBody reqB + + describe "submitOSAsyncSearchWith URI parameters" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + -- OpenSearch documents only @wait_for_completion@, + -- @keep_on_completion@ and @keep_alive@ for the + -- @POST /_plugins/_asynchronous_search@ endpoint; the ES-only + -- 'assoBatchedReduceSize' and 'assoCcsMinimizeRoundtrips' fields + -- are silently dropped by 'osAsyncSearchSubmitOptionsParams'. + let search = mkSearch (Just (MatchAllQuery Nothing)) Nothing + + it "defaultAsyncSearchSubmitOptions emits no params" $ do + let req = OS3Requests.submitOSAsyncSearchWith @Value defaultAsyncSearchSubmitOptions search + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "defaultAsyncSearchSubmitOptions is byte-identical to submitOSAsyncSearch" $ do + let reqPlain = OS3Requests.submitOSAsyncSearch @Value search + reqDef = OS3Requests.submitOSAsyncSearchWith @Value defaultAsyncSearchSubmitOptions search + bhRequestMethod reqPlain `shouldBe` bhRequestMethod reqDef + getRawEndpoint (bhRequestEndpoint reqPlain) `shouldBe` getRawEndpoint (bhRequestEndpoint reqDef) + getRawEndpointQueries (bhRequestEndpoint reqPlain) `shouldBe` getRawEndpointQueries (bhRequestEndpoint reqDef) + bhRequestBody reqPlain `shouldBe` bhRequestBody reqDef + + it "forwards wait_for_completion=true" $ do + let opts = defaultAsyncSearchSubmitOptions {assoWaitForCompletion = Just True} + req = OS3Requests.submitOSAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("wait_for_completion", Just "true")] + + it "forwards keep_on_completion=true" $ do + let opts = defaultAsyncSearchSubmitOptions {assoKeepOnCompletion = Just True} + req = OS3Requests.submitOSAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("keep_on_completion", Just "true")] + + it "forwards keep_alive as the KeepAlive wire format" $ do + let opts = defaultAsyncSearchSubmitOptions {assoKeepAlive = Just (keepAliveDays 5)} + req = OS3Requests.submitOSAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("keep_alive", Just "5d")] + + it "forwards every OS-supported parameter at once (set semantics — order-insensitive)" $ do + let opts = + defaultAsyncSearchSubmitOptions + { assoWaitForCompletion = Just False, + assoKeepOnCompletion = Just True, + assoKeepAlive = Just (keepAliveHours 2) + } + req = OS3Requests.submitOSAsyncSearchWith @Value opts search + sort (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sort + [ ("wait_for_completion", Just "false"), + ("keep_on_completion", Just "true"), + ("keep_alive", Just "2h") + ] + + it "silently drops the ES-only batched_reduce_size on the OS path" $ do + let opts = defaultAsyncSearchSubmitOptions {assoBatchedReduceSize = Just 5} + req = OS3Requests.submitOSAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "silently drops the ES-only ccs_minimize_roundtrips on the OS path" $ do + let opts = defaultAsyncSearchSubmitOptions {assoCcsMinimizeRoundtrips = Just True} + req = OS3Requests.submitOSAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "silently drops both ES-only fields when set together on the OS path" $ do + let opts = + defaultAsyncSearchSubmitOptions + { assoBatchedReduceSize = Just 5, + assoCcsMinimizeRoundtrips = Just True + } + req = OS3Requests.submitOSAsyncSearchWith @Value opts search + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "produces the same path across OS1, OS2 and OS3 (path equivalence)" $ do + -- OS1 uses 'mkEndpoint' explicitly; OS2/OS3 use 'OverloadedLists'. + -- Guard against refactors that silently diverge the three modules. + let opts = defaultAsyncSearchSubmitOptions {assoWaitForCompletion = Just True} + path1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.submitOSAsyncSearchWith @Value opts search)) + path2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.submitOSAsyncSearchWith @Value opts search)) + path3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.submitOSAsyncSearchWith @Value opts search)) + qs1 = getRawEndpointQueries (bhRequestEndpoint (OS1Requests.submitOSAsyncSearchWith @Value opts search)) + qs2 = getRawEndpointQueries (bhRequestEndpoint (OS2Requests.submitOSAsyncSearchWith @Value opts search)) + qs3 = getRawEndpointQueries (bhRequestEndpoint (OS3Requests.submitOSAsyncSearchWith @Value opts search)) + path1 `shouldBe` ["_plugins", "_asynchronous_search"] + path1 `shouldBe` path2 + path2 `shouldBe` path3 + qs1 `shouldBe` qs2 + qs2 `shouldBe` qs3 + + describe "getOSAsyncSearch endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "GETs /_plugins/_asynchronous_search/{id} when given an AsyncSearchId" $ do + let req = OS3Requests.getOSAsyncSearch @Value (AsyncSearchId "FmRleEct") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_asynchronous_search", "FmRleEct"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses GET and attaches no body" $ do + let req = OS3Requests.getOSAsyncSearch @Value (AsyncSearchId "FmRleEct") + bhRequestMethod req `shouldBe` "GET" + bhRequestBody req `shouldBe` Nothing + + it "uses a distinct id in the path when given a different AsyncSearchId" $ do + let req = OS3Requests.getOSAsyncSearch @Value (AsyncSearchId "other-id") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_asynchronous_search", "other-id"] + + it "keeps the id as a single opaque path segment" $ do + let req = OS3Requests.getOSAsyncSearch @Value (AsyncSearchId "Fm_==_RxD_123") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_asynchronous_search", "Fm_==_RxD_123"] + + describe "deleteOSAsyncSearch endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "DELETEs /_plugins/_asynchronous_search/{id} when given an AsyncSearchId" $ do + let req = OS3Requests.deleteOSAsyncSearch (AsyncSearchId "FmRleEct") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_asynchronous_search", "FmRleEct"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses DELETE and does not attach a body (DELETE semantics)" $ do + let req = OS3Requests.deleteOSAsyncSearch (AsyncSearchId "FmRleEct") + bhRequestMethod req `shouldBe` "DELETE" + bhRequestBody req `shouldBe` Nothing + + it "uses a distinct id in the path when given a different AsyncSearchId" $ do + let req = OS3Requests.deleteOSAsyncSearch (AsyncSearchId "other-id") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_asynchronous_search", "other-id"] + + it "keeps the id as a single opaque path segment" $ do + let req = OS3Requests.deleteOSAsyncSearch (AsyncSearchId "Fm_==_RxD_123") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_asynchronous_search", "Fm_==_RxD_123"] + + describe "getOSAsyncSearchStats endpoint shape" $ do + it "GETs /_plugins/_asynchronous_search/stats with no body" $ do + let req = OS3Requests.getOSAsyncSearchStats + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_asynchronous_search", "stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "OS1/OS2/OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint OS1Requests.getOSAsyncSearchStats) + `shouldBe` getRawEndpoint (bhRequestEndpoint OS2Requests.getOSAsyncSearchStats) + getRawEndpoint (bhRequestEndpoint OS2Requests.getOSAsyncSearchStats) + `shouldBe` getRawEndpoint (bhRequestEndpoint OS3Requests.getOSAsyncSearchStats) + bhRequestMethod OS1Requests.getOSAsyncSearchStats + `shouldBe` bhRequestMethod OS3Requests.getOSAsyncSearchStats + + describe "AsyncSearchStatsResponse decoding (stats fixture)" $ do + let fixture = + LBS.pack + "{\"_nodes\":{\"total\":8,\"successful\":8,\"failed\":0},\ + \\"cluster_name\":\"264071961897:asynchronous-search\",\ + \\"nodes\":{\"JKEFl6pdRC-xNkKQauy7Yg\":{\"asynchronous_search_stats\":\ + \{\"submitted\":18236,\"initialized\":112,\"search_failed\":56,\ + \\"search_completed\":56,\"rejected\":18124,\"persist_failed\":0,\ + \\"cancelled\":1,\"running_current\":399,\"persisted\":100}}}}" + + it "decodes the documented stats fixture" $ do + let Just decoded = decode fixture :: Maybe OS3Types.AsyncSearchStatsResponse + let nodes_ = case OS3Types.asyncSearchStatsResponseNodes_ decoded of Just n -> n + OS3Types.asyncSearchStatsNodesTotal nodes_ `shouldBe` 8 + OS3Types.asyncSearchStatsNodesSuccessful nodes_ `shouldBe` 8 + OS3Types.asyncSearchStatsNodesFailed nodes_ `shouldBe` 0 + OS3Types.asyncSearchStatsResponseClusterName decoded `shouldBe` Just "264071961897:asynchronous-search" + let stats = case Map.lookup "JKEFl6pdRC-xNkKQauy7Yg" (OS3Types.asyncSearchStatsResponseNodes decoded) of Just s -> s + OS3Types.asyncSearchNodeStatsSubmitted stats `shouldBe` Just 18236 + OS3Types.asyncSearchNodeStatsRunningCurrent stats `shouldBe` Just 399 + OS3Types.asyncSearchNodeStatsCancelled stats `shouldBe` Just 1 diff --git a/tests/Test/ParseEsResponseSpec.hs b/tests/Test/ParseEsResponseSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ParseEsResponseSpec.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.ParseEsResponseSpec (spec) where + +import Data.Aeson (decode, eitherDecode) +import TestsUtils.Import +import Prelude + +-- | Pure unit tests for the empty-body-2xx handling fixed in bead +-- @bloodhound-vvj@. ES 7.17 returns HTTP 200 with Content-Length: 0 +-- for several endpoints typed as 'Acknowledged'; +-- 'parseEsResponse' normalises such an empty body to the JSON value +-- @null@ before invoking the 'FromJSON' instance, and the +-- 'Acknowledged' 'FromJSON' instance maps @null@ to 'Acknowledged' +-- @True@. These tests pin the second half of that mapping (the +-- 'Acknowledged' 'FromJSON' change). The 'parseEsResponse' +-- empty-body normalisation itself is covered end-to-end by the live +-- round-trip in 'Test.VotingConfigExclusionsSpec' (gated to ES +-- backends). Constructing a 'BHResponse' purely would require +-- reaching into http-client internals (its 'Response' constructor is +-- not exported from the public module), so the integration coverage +-- is left to the live test rather than duplicated here. +-- +-- Note: the OS k-NN\/Neural endpoints (covered by +-- 'Test.KnnWarmupSpec', 'Test.KnnClearCacheSpec', +-- 'Test.NeuralWarmupSpec', 'Test.NeuralClearCacheSpec') were +-- /suspected/ to need this same handling but turn out not to — see +-- their @pendingWith@ reasons for the separate OS library bugs +-- (wrong HTTP method, wrong response type) that block their live +-- round-trips. They do not exercise this normalisation. +spec :: Spec +spec = do + describe "Acknowledged FromJSON null-handling" $ do + it "decodes the literal JSON null as Acknowledged True" $ do + decode "null" `shouldBe` (Just (Acknowledged True)) + + it "still decodes {\"acknowledged\": true} as Acknowledged True" $ do + decode "{\"acknowledged\": true}" `shouldBe` (Just (Acknowledged True)) + + it "still decodes {\"acknowledged\": false} as Acknowledged False" $ do + decode "{\"acknowledged\": false}" `shouldBe` (Just (Acknowledged False)) + + it "still rejects a missing acknowledged key" $ do + decode "{}" `shouldBe` (Nothing :: Maybe Acknowledged) + + it "rejects non-object, non-null shapes (booleans, numbers, arrays)" $ do + decode "true" `shouldBe` (Nothing :: Maybe Acknowledged) + decode "42" `shouldBe` (Nothing :: Maybe Acknowledged) + decode "[]" `shouldBe` (Nothing :: Maybe Acknowledged) + + describe "Acknowledged round-trip with the empty-body normalisation" $ do + -- 'parseEsResponse' normalises an empty 2xx body to the literal + -- JSON @null@ before decoding. Pin the decode of that normalised + -- payload here so a regression in either half of the fix is + -- surfaced in this spec. + it "eitherDecode \"null\" succeeds for Acknowledged (mirrors parseEsResponse's normalisation)" $ do + eitherDecode "null" `shouldBe` (Right (Acknowledged True) :: Either String Acknowledged) + + -- Regression coverage for the 'EsError' 'FromJSON' instance. The OS + -- 1.3 server bug on @GET /_script_language@ returns HTTP 500 with a + -- body of + -- @{"error":{"root_cause":[{"type":"null_pointer_exception","reason":null}],"type":"null_pointer_exception","reason":null},"status":500}@. + -- The historical parser required @error.reason@ to be a non-null + -- 'Text' and so rejected this body, which left 'parseEsResponse' + -- unable to surface the failure as an 'EsError' and instead threw + -- 'EsProtocolException'. The instance is now null-tolerant: it + -- falls back to @error.type@, then a placeholder, and finally to a + -- catch-all parser so any future/unknown shape still yields an + -- 'EsError' rather than a protocol exception. + describe "EsError FromJSON null-tolerant reason" $ do + it "falls back to error.type when error.reason is null" $ do + decode + "{\"error\":{\"type\":\"null_pointer_exception\",\"reason\":null},\"status\":500}" + `shouldBe` Just (EsError (Just 500) "null_pointer_exception") + + it "uses error.reason when it is a string" $ do + decode + "{\"error\":{\"type\":\"some_type\",\"reason\":\"boom\"},\"status\":400}" + `shouldBe` Just (EsError (Just 400) "boom") + + it "falls back to error.type when error.reason is missing" $ do + decode + "{\"error\":{\"type\":\"illegal_argument_exception\"},\"status\":400}" + `shouldBe` Just (EsError (Just 400) "illegal_argument_exception") + + it "uses placeholder when neither reason nor type is present" $ do + decode "{\"error\":{},\"status\":500}" + `shouldBe` Just (EsError (Just 500) "unknown error") + + it "still parses the bare-string error shape" $ do + decode "{\"error\":\"something went wrong\",\"status\":500}" + `shouldBe` Just (EsError (Just 500) "something went wrong") + + it "falls back to cause.type when failures[].cause.reason is null" $ do + decode + "{\"failures\":[{\"status\":400,\"cause\":{\"type\":\"x\",\"reason\":null}}]}" + `shouldBe` Just (EsError (Just 400) "x") + + it "uses cause.reason when it is a string in the failures-array shape" $ do + decode + "{\"failures\":[{\"status\":422,\"cause\":{\"type\":\"y\",\"reason\":\"nope\"}}]}" + `shouldBe` Just (EsError (Just 422) "nope") + + it "catch-all surfaces unrecognised shapes as EsError rather than failing" $ do + decode "{\"weird\":\"shape\",\"status\":418}" + `shouldBe` Just (EsError (Just 418) "unrecognised error body") diff --git a/tests/Test/PendingTasksSpec.hs b/tests/Test/PendingTasksSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/PendingTasksSpec.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.PendingTasksSpec where + +import Data.Aeson.KeyMap qualified as KM +import Database.Bloodhound.Common.Client qualified as Client +import Database.Bloodhound.Common.Types +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + describe "cluster pending tasks API" $ do + -- The pending queue is almost always empty on a quiet test cluster, + -- so the live assertion only validates that the response decodes + -- (proving the @{"tasks": [...]}@ envelope is handled correctly). + it "getPendingTasks decodes the live response without error" $ + withTestEnv $ do + tasks <- Client.getPendingTasks + liftIO $ tasks `shouldSatisfy` (all pendingTaskPriorityMatches) + + -- ------------------------------------------------------------------ -- + -- Pure FromJSON/ToJSON round-trip (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "PendingTask JSON codec" $ do + let sampleTask :: Value + sampleTask = + object + [ "insert_order" .= (42 :: Int), + "priority" .= ("URGENT" :: Text), + "source" .= ("create-index [foo-12], message [...]" :: Text), + "executing" .= (False :: Bool), + "time_in_queue_millis" .= (1500 :: Int), + "time_in_queue" .= ("1.5s" :: Text) + ] + + it "decodes a fully-populated task" $ + case fromJSON @PendingTask sampleTask of + Success pt -> do + pendingTaskInsertOrder pt `shouldBe` 42 + pendingTaskPriority pt `shouldBe` PendingTaskUrgent + pendingTaskSource pt `shouldBe` "create-index [foo-12], message [...]" + pendingTaskExecuting pt `shouldBe` False + pendingTaskTimeInQueueMillis pt `shouldBe` 1500 + pendingTaskTimeInQueue pt `shouldBe` "1.5s" + Error err -> expectationFailure ("decode failed: " <> err) + + it "round-trips without dropping typed fields" $ + case fromJSON @PendingTask sampleTask of + Success pt -> + case toJSON pt of + Object reencoded -> + case fromJSON @PendingTask (Object reencoded) of + Success again -> again `shouldBe` pt + Error err -> expectationFailure ("re-decode failed: " <> err) + other -> expectationFailure ("re-encode produced non-object: " <> show other) + Error err -> expectationFailure ("initial decode failed: " <> err) + + it "preserves extra (untyped) fields through the round-trip" $ + let withExtra = + object + [ "insert_order" .= (1 :: Int), + "priority" .= ("HIGH" :: Text), + "source" .= ("shard-start [...]" :: Text), + "executing" .= (True :: Bool), + "time_in_queue_millis" .= (10 :: Int), + "time_in_queue" .= ("10ms" :: Text), + "future_field" .= ("forward-compatible value" :: Text) + ] + in case fromJSON @PendingTask withExtra of + Success pt -> + case toJSON pt of + Object reencoded -> + case fromJSON @PendingTask (Object reencoded) of + Success again -> do + again `shouldBe` pt + case pendingTaskOther again of + Object o -> KM.lookup "future_field" o `shouldBe` Just (String "forward-compatible value") + _ -> expectationFailure "future_field dropped from *Other round-trip" + Error err -> expectationFailure ("re-decode failed: " <> err) + other -> expectationFailure ("re-encode produced non-object: " <> show other) + Error err -> expectationFailure ("initial decode failed: " <> err) + + it "decodes every documented priority value" $ + mapM_ + ( \(wire, expected) -> + case fromJSON @PendingTaskPriority (String wire) of + Success got -> got `shouldBe` expected + Error err -> expectationFailure ("priority " <> show wire <> " failed: " <> err) + ) + [ ("IMMEDIATE", PendingTaskImmediate), + ("URGENT", PendingTaskUrgent), + ("HIGH", PendingTaskHigh), + ("NORMAL", PendingTaskNormal), + ("LOW", PendingTaskLow) + ] + + it "rejects an unknown priority value" $ + case fromJSON @PendingTaskPriority (String "NONSENSICAL") of + Success _ -> expectationFailure "expected unknown priority to fail decoding" + Error _ -> pure () + + it "decodes a minimal payload using sensible defaults for missing fields" $ + let minimal = object ["source" .= ("only-source" :: Text)] + in case fromJSON @PendingTask minimal of + Success pt -> do + pendingTaskSource pt `shouldBe` "only-source" + pendingTaskInsertOrder pt `shouldBe` 0 + pendingTaskPriority pt `shouldBe` PendingTaskNormal + pendingTaskExecuting pt `shouldBe` False + Error err -> expectationFailure ("decode failed: " <> err) + +-- | Every pending task carries one of the documented 'PendingTaskPriority' +-- values — used by the live test to confirm the decoded priority is in +-- the expected set. +pendingTaskPriorityMatches :: PendingTask -> Bool +pendingTaskPriorityMatches pt = + pendingTaskPriority pt + `elem` [ PendingTaskImmediate, + PendingTaskUrgent, + PendingTaskHigh, + PendingTaskNormal, + PendingTaskLow + ] diff --git a/tests/Test/PointInTimeSpec.hs b/tests/Test/PointInTimeSpec.hs --- a/tests/Test/PointInTimeSpec.hs +++ b/tests/Test/PointInTimeSpec.hs @@ -1,13 +1,870 @@ module Test.PointInTimeSpec (spec) where -import qualified Data.Text as Text -import qualified Database.Bloodhound.OpenSearch2.Client as ClientOS2 +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text qualified as Text +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Database.Bloodhound.ElasticSearch7.Client qualified as ClientES7 +import Database.Bloodhound.ElasticSearch7.Requests qualified as ES7Requests +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch9.Client qualified as ClientES9 +import Database.Bloodhound.ElasticSearch9.Requests qualified as ES9Requests +import Database.Bloodhound.ElasticSearch9.Types qualified as ES9Types +import Database.Bloodhound.OpenSearch2.Client qualified as ClientOS2 +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2Types +import Database.Bloodhound.OpenSearch3.Client qualified as ClientOS3 +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types qualified as OS3Types +import Optics (set, view) import TestsUtils.Common import TestsUtils.Import import Prelude +-- | The single 'testIndex' lifted into an 'IndexPattern', for the +-- 'openPointInTimeWith' / 'openPointInTimeWithBody' call sites that now +-- take an 'IndexPattern' target. +testPattern :: IndexPattern +testPattern = IndexPattern (unIndexName testIndex) + spec :: Spec spec = do + describe "KeepAlive rendering" $ do + it "renders a single-minute value as m" $ + keepAliveToText (keepAliveMinutes 1) `shouldBe` "1m" + + it "renders every supported unit suffix" $ do + keepAliveToText (keepAliveDays 1) `shouldBe` "1d" + keepAliveToText (keepAliveHours 1) `shouldBe` "1h" + keepAliveToText (keepAliveMinutes 1) `shouldBe` "1m" + keepAliveToText (keepAliveSeconds 30) `shouldBe` "30s" + keepAliveToText (keepAliveMilliseconds 500) `shouldBe` "500ms" + keepAliveToText (keepAliveMicroseconds 5) `shouldBe` "5micros" + keepAliveToText (keepAliveNanoseconds 7) `shouldBe` "7nanos" + + it "Show instance matches the wire format" $ + show (keepAliveSeconds 30) `shouldBe` "30s" + + describe "KeepAlive JSON" $ do + it "encodes as a JSON string in form" $ + decode (encode (keepAliveMinutes 1)) `shouldBe` Just ("1m" :: Text.Text) + + it "decodes a plain @1m@ string back to KeepAlive" $ + decode (encode ("1m" :: Text.Text)) `shouldBe` Just (keepAliveMinutes 1) + + it "round-trips through ToJSON/FromJSON for every unit" $ + mapM_ + (\ka -> (decode . encode) ka `shouldBe` Just ka) + [ keepAliveDays 2, + keepAliveHours 12, + keepAliveMinutes 1, + keepAliveSeconds 45, + keepAliveMilliseconds 250, + keepAliveMicroseconds 9, + keepAliveNanoseconds 3 + ] + + it "rejects malformed input (no magnitude)" $ + decode (encode ("" :: Text.Text)) `shouldBe` (Nothing :: Maybe KeepAlive) + + it "rejects malformed input (bad unit)" $ + decode (encode ("1x" :: Text.Text)) `shouldBe` (Nothing :: Maybe KeepAlive) + + it "rejects magnitudes that overflow Word32" $ + decode (encode ("4294967296s" :: Text.Text)) `shouldBe` (Nothing :: Maybe KeepAlive) + + it "accepts leading zeros in the magnitude" $ + decode (encode ("01s" :: Text.Text)) `shouldBe` Just (keepAliveSeconds 1) + + it "forwards zero durations as-is (the server will reject them)" $ do + keepAliveToText (keepAliveSeconds 0) `shouldBe` "0s" + getRawEndpointQueries + (bhRequestEndpoint (ES7Requests.openPointInTime testIndex (keepAliveSeconds 0))) + `shouldBe` [("keep_alive", Just "0s")] + + describe "PointInTime JSON" $ do + it "encodes to the wire object {\"id\",\"keep_alive\"} with KeepAlive rendered as " $ + encode (PointInTime "pit-id" (Just (keepAliveMinutes 1))) + `shouldBe` "{\"id\":\"pit-id\",\"keep_alive\":\"1m\"}" + + it "round-trips a PointInTime through ToJSON/FromJSON" $ do + let pit = PointInTime "pit-id" (Just (keepAliveMinutes 1)) + (decode . encode) pit `shouldBe` Just pit + + it "round-trips through ToJSON/FromJSON for every KeepAlive unit" $ + mapM_ + ( \ka -> do + let pit = PointInTime "pit-id" (Just ka) + (decode . encode) pit `shouldBe` Just pit + ) + [ keepAliveDays 2, + keepAliveHours 12, + keepAliveMinutes 1, + keepAliveSeconds 45, + keepAliveMilliseconds 250, + keepAliveMicroseconds 9, + keepAliveNanoseconds 3 + ] + + it "decodes a well-formed wire object into PointInTime" $ + decode "{\"id\":\"pit-id\",\"keep_alive\":\"1m\"}" + `shouldBe` Just (PointInTime "pit-id" (Just (keepAliveMinutes 1))) + + it "rejects malformed keep_alive values in the wire object" $ + decode "{\"id\":\"pit-id\",\"keep_alive\":\"1x\"}" + `shouldBe` (Nothing :: Maybe PointInTime) + + it "decodes a payload missing keep_alive (optional per spec) as Nothing" $ + decode "{\"id\":\"pit-id\"}" + `shouldBe` Just (PointInTime "pit-id" Nothing) + + it "pointInTimeKeepAliveLens round-trips a KeepAlive" $ do + let pit = PointInTime "pit-id" (Just (keepAliveMinutes 1)) + pit' = set pointInTimeKeepAliveLens (Just (keepAliveSeconds 30)) pit + view pointInTimeKeepAliveLens pit' `shouldBe` Just (keepAliveSeconds 30) + + describe "openPointInTime endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "ES7 emits /{index}/_pit with keep_alive as a query param (not in the path)" $ do + let req = ES7Requests.openPointInTime testIndex (keepAliveSeconds 30) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName testIndex, "_pit"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("keep_alive", Just "30s")] + + it "OS3 emits /{index}/_search/point_in_time with keep_alive as a query param" $ do + let req = OS3Requests.openPointInTime testIndex (keepAliveMinutes 5) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName testIndex, "_search", "point_in_time"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("keep_alive", Just "5m")] + + describe "listAllPITs endpoint shape" $ do + -- ES7/ES8/ES9 have no list-all-PITs endpoint: @GET /_pit@ returns + -- @405@ on every ES version (bloodhound-cfv). Only OpenSearch 2/3 + -- expose one, at @GET /_search/point_in_time/_all@. + it "OS2 emits GET /_search/point_in_time/_all with no query params" $ do + let req = OS2Requests.listAllPITs + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_search", "point_in_time", "_all"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "OS3 emits GET /_search/point_in_time/_all with no query params" $ do + let req = OS3Requests.listAllPITs + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_search", "point_in_time", "_all"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "deleteAllPITs endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + -- deleteAllPITs is bodyless (unlike closePointInTime, which is the + -- delete-by-ID endpoint carrying a ClosePointInTime body). + it "OS2 emits DELETE /_search/point_in_time/_all with no body and no query params" $ do + let req = OS2Requests.deleteAllPITs + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_search", "point_in_time", "_all"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "OS3 emits DELETE /_search/point_in_time/_all with no body and no query params" $ do + let req = OS3Requests.deleteAllPITs + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_search", "point_in_time", "_all"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "OS2 deleteAllPITs and closePointInTime hit different paths" $ do + let allReq = OS2Requests.deleteAllPITs + byIdReq = OS2Requests.closePointInTime (OS2Types.ClosePointInTime ["x"]) + getRawEndpoint (bhRequestEndpoint allReq) + `shouldBe` ["_search", "point_in_time", "_all"] + getRawEndpoint (bhRequestEndpoint byIdReq) + `shouldBe` ["_search", "point_in_time"] + bhRequestBody allReq `shouldBe` Nothing + bhRequestBody byIdReq `shouldNotBe` Nothing + + it "OS3 deleteAllPITs and closePointInTime hit different paths" $ do + let allReq = OS3Requests.deleteAllPITs + byIdReq = OS3Requests.closePointInTime (OS3Types.ClosePointInTime ["x"]) + getRawEndpoint (bhRequestEndpoint allReq) + `shouldBe` ["_search", "point_in_time", "_all"] + getRawEndpoint (bhRequestEndpoint byIdReq) + `shouldBe` ["_search", "point_in_time"] + bhRequestBody allReq `shouldBe` Nothing + bhRequestBody byIdReq `shouldNotBe` Nothing + + describe "deleteAllPITs JSON (OpenSearch 2)" $ + -- deleteAllPITs reuses the ClosePointInTimeResponse envelope + -- (@{\"pits\":[{successful,pit_id}]}@): the Delete All PITs API + -- processes each PIT individually and reports one result per PIT, + -- so the wire shape is shared with the delete-by-ID endpoint + -- (closePointInTime). This pins the decode of a multi-PIT + -- delete-all-style response through the shared type. + it "decodes a {pits:[{successful,pit_id}]} payload via ClosePointInTimeResponse" $ + decode + "{\"pits\":[{\"successful\":true,\"pit_id\":\"pit-1\"},{\"successful\":false,\"pit_id\":\"pit-2\"}]}" + `shouldBe` Just + ( OS2Types.ClosePointInTimeResponse + [ OS2Types.ClosePointInTimeResult True "pit-1", + OS2Types.ClosePointInTimeResult False "pit-2" + ] + ) + + describe "deleteAllPITs JSON (OpenSearch 3)" $ + it "decodes a {pits:[{successful,pit_id}]} payload via ClosePointInTimeResponse" $ + decode + "{\"pits\":[{\"successful\":true,\"pit_id\":\"pit-1\"},{\"successful\":false,\"pit_id\":\"pit-2\"}]}" + `shouldBe` Just + ( OS3Types.ClosePointInTimeResponse + [ OS3Types.ClosePointInTimeResult True "pit-1", + OS3Types.ClosePointInTimeResult False "pit-2" + ] + ) + + describe "deleteAllPITs empty response" $ do + -- Edge case: deleting all PITs when none are open yields an empty + -- pits array. The shared ClosePointInTimeResponse codec must accept + -- it (the cluster reported zero PITs to delete). + it "OS2 decodes an empty {pits:[]} payload" $ + decode "{\"pits\":[]}" + `shouldBe` Just (OS2Types.ClosePointInTimeResponse []) + + it "OS3 decodes an empty {pits:[]} payload" $ + decode "{\"pits\":[]}" + `shouldBe` Just (OS3Types.ClosePointInTimeResponse []) + + describe "OpenPointInTimeResponse JSON (OpenSearch 2)" $ do + -- creation_time is a POSIXMS millisecond count on the wire (a JSON + -- number); POSIXMS's codec is asymmetric (ToJSON renders the underlying + -- UTCTime as an ISO-8601 string, FromJSON expects a numeric ms count), + -- so we verify the decode direction with a millisecond payload and check + -- the parsed creation_time via its accessor rather than round-tripping. + -- Regression for bloodhound-8v0: the field was previously POSIXTime + -- (seconds), so a real ms value like 1658146050064 decoded to a date + -- off by 1000x. + it "decodes a create response with a millisecond creation_time" $ do + let decoded = + decode + "{\"pit_id\":\"pit-1\",\"_shards\":{\"total\":3,\"successful\":2,\"skipped\":1,\"failed\":0},\"creation_time\":1658146050064}" :: + Maybe OS2Types.OpenPointInTimeResponse + case decoded of + Just resp -> do + OS2Types.oos2PitId resp `shouldBe` "pit-1" + OS2Types.oos2Shards resp `shouldBe` ShardResult 3 2 1 0 + OS2Types.oos2CreationTime resp `shouldBe` posixMSFromMillis 1658146050064 + Nothing -> expectationFailure "expected a decoded OpenPointInTimeResponse" + + it "rejects a non-numeric creation_time" $ + decode + "{\"pit_id\":\"pit-1\",\"_shards\":{\"total\":3,\"successful\":2,\"skipped\":1,\"failed\":0},\"creation_time\":\"not-a-number\"}" + `shouldBe` (Nothing :: Maybe OS2Types.OpenPointInTimeResponse) + + describe "listAllPITs JSON (OpenSearch 2)" $ do + -- Note: PITInfo's keep_alive codec is asymmetric by design — FromJSON + -- parses the wire millisecond count (a bare JSON number), while ToJSON + -- re-renders it as a KeepAlive "ms" string. creation_time is a + -- POSIXMS millisecond count on the wire (mirroring OpenSearch 3), and + -- POSIXMS's ToJSON renders the underlying UTCTime as an ISO-8601 string + -- while FromJSON expects a numeric millisecond count, so both fields' + -- codecs are asymmetric by design. We only verify the decode direction + -- (the way a response flows off the wire), and check the pit_id / + -- keep_alive fields rather than reconstructing the POSIXMS value for + -- the field-match cases (avoids duplicating the parser's truncation + -- arithmetic here). + it "decodes a well-formed {\"pits\":[{\"pit_id\",\"creation_time\",\"keep_alive\"}]} payload" $ + decode + "{\"pits\":[{\"pit_id\":\"pit-1\",\"creation_time\":1700000000000,\"keep_alive\":60000}]}" + `shouldBe` Just + ( OS2Types.ListPITsResponse + [ OS2Types.PITInfo "pit-1" (posixMSFromMillis 1700000000000) (keepAliveMilliseconds 60000) + ] + ) + + it "the decoded pit_id and keep_alive match the wire payload" $ do + let decoded = + decode + "{\"pits\":[{\"pit_id\":\"pit-99\",\"creation_time\":1.0,\"keep_alive\":5000}]}" :: + Maybe OS2Types.ListPITsResponse + case decoded of + Just (OS2Types.ListPITsResponse [p]) -> do + OS2Types.pitInfoId p `shouldBe` "pit-99" + OS2Types.pitInfoKeepAlive p `shouldBe` keepAliveMilliseconds 5000 + _ -> expectationFailure "expected a single-element ListPITsResponse" + + it "decodes an empty pits array" $ + decode "{\"pits\":[]}" + `shouldBe` Just (OS2Types.ListPITsResponse []) + + it "rejects a missing pits field" $ + decode "{\"pit_id\":\"pit-1\"}" + `shouldBe` (Nothing :: Maybe OS2Types.ListPITsResponse) + + it "rejects a malformed pit_id in a pits element" $ + decode + "{\"pits\":[{\"pit_id\":42,\"creation_time\":1.0,\"keep_alive\":5000}]}" + `shouldBe` (Nothing :: Maybe OS2Types.ListPITsResponse) + + it "rejects a pits element that omits keep_alive (regression: old code required _shards instead)" $ + decode + "{\"pits\":[{\"pit_id\":\"pit-1\",\"creation_time\":1.0}]}" + `shouldBe` (Nothing :: Maybe OS2Types.ListPITsResponse) + + describe "listAllPITs JSON (OpenSearch 3)" $ do + -- Note: PITInfo's keep_alive codec is asymmetric (see OpenSearch 2 + -- note above), and POSIXMS's ToJSON renders the underlying UTCTime as + -- an ISO-8601 string while FromJSON expects a numeric millisecond + -- count, so both fields' codecs are asymmetric by design. We only + -- verify the decode direction, which is the direction a response flows + -- off the wire, and check the pit_id / keep_alive fields rather than + -- reconstructing the POSIXMS value (avoids duplicating the parser's + -- truncation arithmetic here). + it "decodes a well-formed {\"pits\":[{\"pit_id\",\"creation_time\",\"keep_alive\"}]} payload" $ + decode + "{\"pits\":[{\"pit_id\":\"pit-1\",\"creation_time\":1700000000123,\"keep_alive\":60000}]}" + `shouldBe` Just + ( OS3Types.ListPITsResponse + [ OS3Types.PITInfo + "pit-1" + (posixMSFromMillis 1700000000123) + (keepAliveMilliseconds 60000) + ] + ) + + it "the decoded pit_id and keep_alive match the wire payload" $ do + let decoded = + decode + "{\"pits\":[{\"pit_id\":\"pit-99\",\"creation_time\":1700000000000,\"keep_alive\":5000}]}" :: + Maybe OS3Types.ListPITsResponse + case decoded of + Just (OS3Types.ListPITsResponse [p]) -> do + OS3Types.pitInfoId p `shouldBe` "pit-99" + OS3Types.pitInfoKeepAlive p `shouldBe` keepAliveMilliseconds 5000 + _ -> expectationFailure "expected a single-element ListPITsResponse" + + it "decodes an empty pits array" $ + decode "{\"pits\":[]}" + `shouldBe` Just (OS3Types.ListPITsResponse []) + + it "rejects a missing pits field" $ + decode "{\"pit_id\":\"pit-1\"}" + `shouldBe` (Nothing :: Maybe OS3Types.ListPITsResponse) + + it "rejects a malformed pit_id in a pits element" $ + decode + "{\"pits\":[{\"pit_id\":42,\"creation_time\":1700000000123,\"keep_alive\":60000}]}" + `shouldBe` (Nothing :: Maybe OS3Types.ListPITsResponse) + + it "rejects a pits element that omits keep_alive (regression: old code required _shards instead)" $ + decode + "{\"pits\":[{\"pit_id\":\"pit-1\",\"creation_time\":1700000000123}]}" + `shouldBe` (Nothing :: Maybe OS3Types.ListPITsResponse) + + describe "closePointInTime JSON (OpenSearch 2)" $ do + it "encodes ClosePointInTime as {pit_id: [...]} (not the ES {id: ...})" $ + encode (OS2Types.ClosePointInTime ["pit-id-xyz"]) + `shouldBe` encode (object ["pit_id" .= (["pit-id-xyz"] :: [Text.Text])]) + + it "round-trips ClosePointInTime through ToJSON/FromJSON" $ do + let cpit = OS2Types.ClosePointInTime ["pit-id-xyz", "pit-id-2"] + decode (encode cpit) `shouldBe` Just cpit + + it "round-trips an empty ClosePointInTime (empty pit_id array)" $ do + let cpit = OS2Types.ClosePointInTime [] + decode (encode cpit) `shouldBe` Just cpit + + it "round-trips ClosePointInTimeResponse through ToJSON/FromJSON" $ do + let resp = + OS2Types.ClosePointInTimeResponse + [OS2Types.ClosePointInTimeResult True "pit-id-xyz"] + decode (encode resp) `shouldBe` Just resp + + it "decodes the documented {pits:[{successful,pit_id}]} payload" $ + decode "{\"pits\":[{\"successful\":true,\"pit_id\":\"pit-1\"}]}" + `shouldBe` Just + ( OS2Types.ClosePointInTimeResponse + [OS2Types.ClosePointInTimeResult True "pit-1"] + ) + + it "rejects the Elasticsearch {succeeded,num_freed} shape (regression)" $ + decode "{\"succeeded\":true,\"num_freed\":1}" + `shouldBe` (Nothing :: Maybe OS2Types.ClosePointInTimeResponse) + + describe "closePointInTime JSON (OpenSearch 3)" $ do + it "encodes ClosePointInTime as {pit_id: [...]} (not the ES {id: ...})" $ + encode (OS3Types.ClosePointInTime ["pit-id-xyz"]) + `shouldBe` encode (object ["pit_id" .= (["pit-id-xyz"] :: [Text.Text])]) + + it "round-trips ClosePointInTime through ToJSON/FromJSON" $ do + let cpit = OS3Types.ClosePointInTime ["pit-id-xyz", "pit-id-2"] + decode (encode cpit) `shouldBe` Just cpit + + it "round-trips an empty ClosePointInTime (empty pit_id array)" $ do + let cpit = OS3Types.ClosePointInTime [] + decode (encode cpit) `shouldBe` Just cpit + + it "round-trips ClosePointInTimeResponse through ToJSON/FromJSON" $ do + let resp = + OS3Types.ClosePointInTimeResponse + [OS3Types.ClosePointInTimeResult True "pit-id-xyz"] + decode (encode resp) `shouldBe` Just resp + + it "decodes the documented {pits:[{successful,pit_id}]} payload" $ + decode "{\"pits\":[{\"successful\":true,\"pit_id\":\"pit-1\"}]}" + `shouldBe` Just + ( OS3Types.ClosePointInTimeResponse + [OS3Types.ClosePointInTimeResult True "pit-1"] + ) + + it "rejects the Elasticsearch {succeeded,num_freed} shape (regression)" $ + decode "{\"succeeded\":true,\"num_freed\":1}" + `shouldBe` (Nothing :: Maybe OS3Types.ClosePointInTimeResponse) + + describe "PITOptions renderer" $ do + it "defaultPITOptions emits no pairs (no overhead beyond keep_alive)" $ + pitOptionsParams defaultPITOptions `shouldBe` [] + + it "osPITOptionsParams with defaultPITOptions emits no pairs" $ + osPITOptionsParams defaultPITOptions `shouldBe` [] + + it "pitOptionsParams renders routing, preference, expand_wildcards" $ do + let opts = + defaultPITOptions + { pitoRouting = Just "user-1", + pitoPreference = Just "_local", + pitoExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsHidden]) + } + -- The order is stable but unspecified; compare as a set via sorting. + -- The renderer emits exactly these three pairs. + sortPairs (pitOptionsParams opts) + `shouldBe` sortPairs + [ ("expand_wildcards", Just "open,hidden"), + ("preference", Just "_local"), + ("routing", Just "user-1") + ] + + it "pitOptionsParams drops OS-only allow_partial_pit_creation" $ do + let opts = + defaultPITOptions + { pitoAllowPartialPITCreation = Just True + } + pitOptionsParams opts `shouldBe` [] + + it "osPITOptionsParams renders all four fields when set" $ do + let opts = + defaultPITOptions + { pitoRouting = Just "user-1", + pitoPreference = Just "_local", + pitoExpandWildcards = Just (ExpandWildcardsClosed :| []), + pitoAllowPartialPITCreation = Just True + } + sortPairs (osPITOptionsParams opts) + `shouldBe` sortPairs + [ ("routing", Just "user-1"), + ("preference", Just "_local"), + ("expand_wildcards", Just "closed"), + ("allow_partial_pit_creation", Just "true") + ] + + it "osPITOptionsParams renders allow_partial_pit_creation=false when set to False" $ do + let opts = defaultPITOptions {pitoAllowPartialPITCreation = Just False} + osPITOptionsParams opts + `shouldBe` [("allow_partial_pit_creation", Just "false")] + + it "pitoRoutingLens round-trips" $ do + let opts = set pitoRoutingLens (Just "abc") defaultPITOptions + view pitoRoutingLens opts `shouldBe` Just "abc" + + it "pitoPreferenceLens round-trips" $ do + let opts = set pitoPreferenceLens (Just "_local") defaultPITOptions + view pitoPreferenceLens opts `shouldBe` Just "_local" + + it "pitoExpandWildcardsLens round-trips" $ do + let opts = set pitoExpandWildcardsLens (Just (ExpandWildcardsOpen :| [])) defaultPITOptions + view pitoExpandWildcardsLens opts `shouldBe` Just (ExpandWildcardsOpen :| []) + + it "pitoAllowPartialPITCreationLens round-trips" $ do + let opts = set pitoAllowPartialPITCreationLens (Just True) defaultPITOptions + view pitoAllowPartialPITCreationLens opts `shouldBe` Just True + + it "pitOptionsParams renders the ES-only ignore_unavailable, allow_partial_search_results, max_concurrent_shard_requests" $ do + let opts = + defaultPITOptions + { pitoIgnoreUnavailable = Just True, + pitoAllowPartialSearchResults = Just False, + pitoMaxConcurrentShardRequests = Just 16 + } + sortPairs (pitOptionsParams opts) + `shouldBe` sortPairs + [ ("ignore_unavailable", Just "true"), + ("allow_partial_search_results", Just "false"), + ("max_concurrent_shard_requests", Just "16") + ] + + it "pitOptionsParams emits a single ES-only param when only one is set" $ + pitOptionsParams (defaultPITOptions {pitoIgnoreUnavailable = Just True}) + `shouldBe` [("ignore_unavailable", Just "true")] + + it "osPITOptionsParams does NOT emit the ES-only params" $ do + let opts = + defaultPITOptions + { pitoIgnoreUnavailable = Just True, + pitoAllowPartialSearchResults = Just False, + pitoMaxConcurrentShardRequests = Just 16 + } + osPITOptionsParams opts `shouldBe` [] + + it "pitoIgnoreUnavailableLens round-trips" $ do + let opts = set pitoIgnoreUnavailableLens (Just True) defaultPITOptions + view pitoIgnoreUnavailableLens opts `shouldBe` Just True + + it "pitoAllowPartialSearchResultsLens round-trips" $ do + let opts = set pitoAllowPartialSearchResultsLens (Just False) defaultPITOptions + view pitoAllowPartialSearchResultsLens opts `shouldBe` Just False + + it "pitoMaxConcurrentShardRequestsLens round-trips" $ do + let opts = set pitoMaxConcurrentShardRequestsLens (Just 5) defaultPITOptions + view pitoMaxConcurrentShardRequestsLens opts `shouldBe` Just 5 + + describe "openPointInTimeWith endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "ES7 with defaultPITOptions is byte-identical to openPointInTime" $ do + let simpleReq = ES7Requests.openPointInTime testIndex (keepAliveSeconds 30) + withReq = ES7Requests.openPointInTimeWith testPattern (keepAliveSeconds 30) defaultPITOptions + getRawEndpoint (bhRequestEndpoint simpleReq) + `shouldBe` getRawEndpoint (bhRequestEndpoint withReq) + getRawEndpointQueries (bhRequestEndpoint simpleReq) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint withReq) + + it "ES7 forwards routing/preference/expand_wildcards (3 params)" $ do + let opts = + defaultPITOptions + { pitoRouting = Just "user-1", + pitoPreference = Just "_local", + pitoExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsHidden]) + } + req = ES7Requests.openPointInTimeWith testPattern (keepAliveSeconds 30) opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName testIndex, "_pit"] + -- The endpoint's queries carry keep_alive first (always), then the + -- three ES-recognized params. OS-only fields are NOT emitted. + sortPairs (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sortPairs + [ ("keep_alive", Just "30s"), + ("routing", Just "user-1"), + ("preference", Just "_local"), + ("expand_wildcards", Just "open,hidden") + ] + + it "ES7 does NOT emit OpenSearch-only allow_partial_pit_creation" $ do + let opts = + defaultPITOptions + { pitoAllowPartialPITCreation = Just True + } + req = ES7Requests.openPointInTimeWith testPattern (keepAliveSeconds 30) opts + -- Only keep_alive is present; the OS-only fields are silently dropped. + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("keep_alive", Just "30s")] + + it "ES9 forwards routing/preference/expand_wildcards (3 params, uses local ES9 builder)" $ do + let opts = + defaultPITOptions + { pitoRouting = Just "user-9", + pitoPreference = Just "_only_local", + pitoExpandWildcards = Just (ExpandWildcardsClosed :| []) + } + req = ES9Requests.openPointInTimeWith testPattern (keepAliveMinutes 2) opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName testIndex, "_pit"] + sortPairs (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sortPairs + [ ("keep_alive", Just "2m"), + ("routing", Just "user-9"), + ("preference", Just "_only_local"), + ("expand_wildcards", Just "closed") + ] + + it "ES9 does NOT emit OpenSearch-only allow_partial_pit_creation" $ do + let opts = + defaultPITOptions + { pitoAllowPartialPITCreation = Just True + } + req = ES9Requests.openPointInTimeWith testPattern (keepAliveSeconds 30) opts + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("keep_alive", Just "30s")] + + it "ES7 forwards the ES-only ignore_unavailable, allow_partial_search_results, max_concurrent_shard_requests" $ do + let opts = + defaultPITOptions + { pitoIgnoreUnavailable = Just True, + pitoAllowPartialSearchResults = Just False, + pitoMaxConcurrentShardRequests = Just 16 + } + req = ES7Requests.openPointInTimeWith testPattern (keepAliveSeconds 30) opts + sortPairs (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sortPairs + [ ("keep_alive", Just "30s"), + ("ignore_unavailable", Just "true"), + ("allow_partial_search_results", Just "false"), + ("max_concurrent_shard_requests", Just "16") + ] + + it "ES9 forwards the ES-only params" $ do + let opts = + defaultPITOptions + { pitoIgnoreUnavailable = Just False, + pitoMaxConcurrentShardRequests = Just 8 + } + req = ES9Requests.openPointInTimeWith testPattern (keepAliveMinutes 2) opts + sortPairs (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sortPairs + [ ("keep_alive", Just "2m"), + ("ignore_unavailable", Just "false"), + ("max_concurrent_shard_requests", Just "8") + ] + + it "OS2 does NOT emit the ES-only params" $ do + let opts = + defaultPITOptions + { pitoIgnoreUnavailable = Just True, + pitoAllowPartialSearchResults = Just False, + pitoMaxConcurrentShardRequests = Just 16 + } + req = OS2Requests.openPointInTimeWith testPattern (keepAliveMinutes 1) opts + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("keep_alive", Just "1m")] + + it "OS3 does NOT emit the ES-only params" $ do + let opts = + defaultPITOptions + { pitoIgnoreUnavailable = Just True, + pitoMaxConcurrentShardRequests = Just 16 + } + req = OS3Requests.openPointInTimeWith testPattern (keepAliveMinutes 1) opts + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("keep_alive", Just "1m")] + + it "OS2 forwards all four params (including allow_partial_pit_creation)" $ do + let opts = + defaultPITOptions + { pitoRouting = Just "user-2", + pitoPreference = Just "_local", + pitoExpandWildcards = Just (ExpandWildcardsOpen :| []), + pitoAllowPartialPITCreation = Just True + } + req = OS2Requests.openPointInTimeWith testPattern (keepAliveMinutes 1) opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName testIndex, "_search", "point_in_time"] + sortPairs (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sortPairs + [ ("keep_alive", Just "1m"), + ("routing", Just "user-2"), + ("preference", Just "_local"), + ("expand_wildcards", Just "open"), + ("allow_partial_pit_creation", Just "true") + ] + + it "OS3 forwards all four params (including allow_partial_pit_creation)" $ do + let opts = + defaultPITOptions + { pitoRouting = Just "user-3", + pitoPreference = Just "_local", + pitoExpandWildcards = Just (ExpandWildcardsOpen :| []), + pitoAllowPartialPITCreation = Just False + } + req = OS3Requests.openPointInTimeWith testPattern (keepAliveMinutes 1) opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName testIndex, "_search", "point_in_time"] + sortPairs (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sortPairs + [ ("keep_alive", Just "1m"), + ("routing", Just "user-3"), + ("preference", Just "_local"), + ("expand_wildcards", Just "open"), + ("allow_partial_pit_creation", Just "false") + ] + + it "OS2 with defaultPITOptions is byte-identical to openPointInTime" $ do + let simpleReq = OS2Requests.openPointInTime testIndex (keepAliveMinutes 5) + withReq = OS2Requests.openPointInTimeWith testPattern (keepAliveMinutes 5) defaultPITOptions + getRawEndpoint (bhRequestEndpoint simpleReq) + `shouldBe` getRawEndpoint (bhRequestEndpoint withReq) + getRawEndpointQueries (bhRequestEndpoint simpleReq) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint withReq) + + it "OS3 with defaultPITOptions is byte-identical to openPointInTime" $ do + let simpleReq = OS3Requests.openPointInTime testIndex (keepAliveMinutes 5) + withReq = OS3Requests.openPointInTimeWith testPattern (keepAliveMinutes 5) defaultPITOptions + getRawEndpoint (bhRequestEndpoint simpleReq) + `shouldBe` getRawEndpoint (bhRequestEndpoint withReq) + getRawEndpointQueries (bhRequestEndpoint simpleReq) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint withReq) + + describe "openPointInTimeWith multi-target (IndexPattern)" $ do + -- Pure checks that a comma-list or wildcard IndexPattern is rendered + -- verbatim as the first URL path segment. No live backend needed. + -- See bloodhound-6pcg: mkIndexName rejects '*' and ',', so the only + -- way to target multiple indices or a wildcard is via IndexPattern. + -- + -- These tests satisfy bloodhound-o8dc's wildcard-rendering + -- acceptance criterion: a wildcard target built without going + -- through mkIndexName (here: a literal IndexPattern "logs-*") + -- survives the renderer unchanged on every backend. + let commaPattern = IndexPattern "logs-2024,logs-2025" + wildcardPattern = IndexPattern "logs-*" + + it "ES7 renders a comma-joined IndexPattern as one path segment" $ do + let req = ES7Requests.openPointInTimeWith commaPattern (keepAliveSeconds 30) defaultPITOptions + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["logs-2024,logs-2025", "_pit"] + + it "ES7 renders a wildcard IndexPattern as one path segment" $ do + let req = ES7Requests.openPointInTimeWith wildcardPattern (keepAliveMinutes 1) defaultPITOptions + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["logs-*", "_pit"] + + it "ES9 renders a comma-joined IndexPattern as one path segment" $ do + let req = ES9Requests.openPointInTimeWith commaPattern (keepAliveSeconds 30) defaultPITOptions + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["logs-2024,logs-2025", "_pit"] + + it "ES9 renders a wildcard IndexPattern as one path segment" $ do + let req = ES9Requests.openPointInTimeWith wildcardPattern (keepAliveMinutes 1) defaultPITOptions + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["logs-*", "_pit"] + + it "OS2 renders a comma-joined IndexPattern as one path segment" $ do + let req = OS2Requests.openPointInTimeWith commaPattern (keepAliveMinutes 1) defaultPITOptions + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["logs-2024,logs-2025", "_search", "point_in_time"] + + it "OS2 renders a wildcard IndexPattern as one path segment" $ do + let req = OS2Requests.openPointInTimeWith wildcardPattern (keepAliveMinutes 1) defaultPITOptions + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["logs-*", "_search", "point_in_time"] + + it "OS3 renders a comma-joined IndexPattern as one path segment" $ do + let req = OS3Requests.openPointInTimeWith commaPattern (keepAliveMinutes 1) defaultPITOptions + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["logs-2024,logs-2025", "_search", "point_in_time"] + + it "OS3 renders a wildcard IndexPattern as one path segment" $ do + let req = OS3Requests.openPointInTimeWith wildcardPattern (keepAliveMinutes 1) defaultPITOptions + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["logs-*", "_search", "point_in_time"] + + it "ES7 openPointInTimeWithBody renders a wildcard IndexPattern target" $ do + let req = ES7Requests.openPointInTimeWithBody wildcardPattern (keepAliveMinutes 1) defaultOpenPointInTimeBody defaultPITOptions + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["logs-*", "_pit"] + + it "ES9 openPointInTimeWithBody renders a comma-joined IndexPattern target" $ do + let req = ES9Requests.openPointInTimeWithBody commaPattern (keepAliveMinutes 1) defaultOpenPointInTimeBody defaultPITOptions + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["logs-2024,logs-2025", "_pit"] + + it "openPointInTime convenience lifts a single IndexName into the path" $ do + -- Regression guard: openPointInTime (IndexName) must render the same + -- first path segment as openPointInTimeWith (IndexPattern ...) with the + -- lifted pattern. + let simpleReq = ES7Requests.openPointInTime testIndex (keepAliveSeconds 30) + withReq = ES7Requests.openPointInTimeWith testPattern (keepAliveSeconds 30) defaultPITOptions + getRawEndpoint (bhRequestEndpoint simpleReq) + `shouldBe` getRawEndpoint (bhRequestEndpoint withReq) + + describe "pitSearchWith export and reachability" $ do + -- Compile-time reachability guards: referencing the identifier at each + -- backend's Client surface + the dynamic dispatch forces the exporters + -- to ship it. Mirrors the closePointInTime ES8 guard above. + -- Instantiated at @BH IO [Hit Value]@ to resolve the FromJSON result + -- type; the action is built but never executed. + it "ES7 pitSearchWith is reachable through the Client API" $ + let guardExport :: BH IO () + guardExport = + void + ( ClientES7.pitSearchWith testPattern (keepAliveMinutes 1) (mkSearch Nothing Nothing) :: + BH IO [Hit Value] + ) + in guardExport `seq` (True `shouldBe` True) + + it "ES8 pitSearchWith is reachable through the Client API" $ + let guardExport :: BH IO () + guardExport = + void + ( ClientES8.pitSearchWith testPattern (keepAliveMinutes 1) (mkSearch Nothing Nothing) :: + BH IO [Hit Value] + ) + in guardExport `seq` (True `shouldBe` True) + + it "ES9 pitSearchWith is reachable through the Client API" $ + let guardExport :: BH IO () + guardExport = + void + ( ClientES9.pitSearchWith testPattern (keepAliveMinutes 1) (mkSearch Nothing Nothing) :: + BH IO [Hit Value] + ) + in guardExport `seq` (True `shouldBe` True) + + it "OS2 pitSearchWith is reachable through the Client API" $ + let guardExport :: BH IO () + guardExport = + void + ( ClientOS2.pitSearchWith testPattern (keepAliveMinutes 1) (mkSearch Nothing Nothing) :: + BH IO [Hit Value] + ) + in guardExport `seq` (True `shouldBe` True) + + it "OS3 pitSearchWith is reachable through the Client API" $ + let guardExport :: BH IO () + guardExport = + void + ( ClientOS3.pitSearchWith testPattern (keepAliveMinutes 1) (mkSearch Nothing Nothing) :: + BH IO [Hit Value] + ) + in guardExport `seq` (True `shouldBe` True) + + describe "OpenPointInTimeBody" $ do + it "defaultOpenPointInTimeBody encodes to {}" $ + encode defaultOpenPointInTimeBody `shouldBe` "{}" + + it "encodes an index_filter query and omits it when absent" $ do + let body = defaultOpenPointInTimeBody {pitBodyIndexFilter = Just (MatchAllQuery Nothing)} + decode (encode body) + `shouldBe` Just (object ["index_filter" .= MatchAllQuery Nothing]) + + it "pitBodyIndexFilterLens round-trips" $ do + let body = set pitBodyIndexFilterLens (Just (MatchAllQuery Nothing)) defaultOpenPointInTimeBody + view pitBodyIndexFilterLens body `shouldBe` Just (MatchAllQuery Nothing) + + it "ES7 openPointInTimeWithBody sends the body and reuses the openPointInTimeWith endpoint/queries" $ do + let opts = defaultPITOptions {pitoIgnoreUnavailable = Just True} + body = defaultOpenPointInTimeBody {pitBodyIndexFilter = Just (MatchAllQuery Nothing)} + reqBody = ES7Requests.openPointInTimeWithBody testPattern (keepAliveSeconds 30) body opts + reqNoBody = ES7Requests.openPointInTimeWith testPattern (keepAliveSeconds 30) opts + bhRequestBody reqBody `shouldBe` Just (encode body) + getRawEndpoint (bhRequestEndpoint reqBody) + `shouldBe` getRawEndpoint (bhRequestEndpoint reqNoBody) + sortPairs (getRawEndpointQueries (bhRequestEndpoint reqBody)) + `shouldBe` sortPairs (getRawEndpointQueries (bhRequestEndpoint reqNoBody)) + + it "ES7 openPointInTimeWithBody with defaultOpenPointInTimeBody sends {}" $ do + let req = ES7Requests.openPointInTimeWithBody testPattern (keepAliveMinutes 1) defaultOpenPointInTimeBody defaultPITOptions + bhRequestBody req `shouldBe` Just "{}" + + it "ES9 openPointInTimeWithBody sends the body to the local ES9 endpoint" $ do + let body = defaultOpenPointInTimeBody {pitBodyIndexFilter = Just (MatchAllQuery Nothing)} + req = ES9Requests.openPointInTimeWithBody testPattern (keepAliveMinutes 1) body defaultPITOptions + bhRequestBody req `shouldBe` Just (encode body) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` [unIndexName testIndex, "_pit"] + + describe "closePointInTime export (ElasticSearch 8)" $ + -- Regression: closePointInTime was defined and documented but absent + -- from the ES8 Client export list, making it unreachable for users + -- even though pitSearch and openPointInTime Haddocks point readers at + -- it. Every sibling backend (ES7, ES9, OS2, OS3) exports it. + -- Referencing the identifier here guards the export at compile time: + -- dropping it from the export list again breaks this module's build. + -- Instantiating at @BH IO@ satisfies both the 'MonadBH' and + -- 'WithBackend' constraints ('Backend (BH IO) = 'Dynamic' bypasses the + -- backend check); the action is built but never executed. + it "is reachable through the ES8 Client API" $ + let guardExport :: BH IO () + guardExport = void (ClientES8.closePointInTime (ClosePointInTime "never-run")) + in guardExport `seq` (True `shouldBe` True) + describe "Point in time (PIT) API (ElasticSearch 7)" $ do it' <- runIO esOnlyIT it' "returns a single document using the point in time (PIT) API" $ @@ -22,7 +879,7 @@ { size = Size 1 } regular_search <- searchTweet search - pit_search' <- pitSearch testIndex search :: BH IO [Hit Tweet] + pit_search' <- pitSearch testIndex (keepAliveMinutes 1) search :: BH IO [Hit Tweet] let pit_search = map hitSource pit_search' liftIO $ regular_search `shouldBe` Right exampleTweet -- Check that the size restriction is being honored @@ -45,13 +902,75 @@ } scan_search' <- scanSearch testIndex search :: BH IO [Hit Tweet] let scan_search = map hitSource scan_search' - pit_search' <- pitSearch testIndex search :: BH IO [Hit Tweet] + pit_search' <- pitSearch testIndex (keepAliveMinutes 1) search :: BH IO [Hit Tweet] let pit_search = map hitSource pit_search' let expectedHits = map Just docs liftIO $ scan_search `shouldMatchList` expectedHits liftIO $ pit_search `shouldMatchList` expectedHits + + describe "Point in time (PIT) API (ElasticSearch 9)" $ do + it "round-trips OpenPointInTimeResponse through ToJSON/FromJSON" $ do + let resp = + ES9Types.OpenPointInTimeResponse + "pit-id-xyz" + (ShardResult 2 2 0 0) + decode (encode resp) `shouldBe` Just resp + + it "OpenPointInTimeResponse always emits _shards (Required per docs)" $ do + let resp = ES9Types.OpenPointInTimeResponse "pit-id-xyz" (ShardResult 2 2 0 0) + encode resp + `shouldBe` encode + ( object + [ "id" .= ("pit-id-xyz" :: Text), + "_shards" .= object ["total" .= (2 :: Int), "successful" .= (2 :: Int), "skipped" .= (0 :: Int), "failed" .= (0 :: Int)] + ] + ) + + it "decodes an OpenPointInTimeResponse with a _shards summary" $ + decode + "{\"id\":\"pit-1\",\"_shards\":{\"total\":3,\"successful\":2,\"skipped\":1,\"failed\":0}}" + `shouldBe` Just + ( ES9Types.OpenPointInTimeResponse + "pit-1" + (ShardResult 3 2 1 0) + ) + + it "rejects an OpenPointInTimeResponse that omits _shards (Required per docs)" $ + decode "{\"id\":\"pit-1\"}" + `shouldBe` (Nothing :: Maybe ES9Types.OpenPointInTimeResponse) + + it "rejects a malformed _shards value in OpenPointInTimeResponse" $ + decode "{\"id\":\"pit-1\",\"_shards\":\"not-an-object\"}" + `shouldBe` (Nothing :: Maybe ES9Types.OpenPointInTimeResponse) + + it "round-trips ClosePointInTime through ToJSON/FromJSON" $ do + let cpit = ES9Types.ClosePointInTime "pit-id-xyz" + decode (encode cpit) `shouldBe` Just cpit + + it "round-trips ClosePointInTimeResponse through ToJSON/FromJSON" $ do + let resp = ES9Types.ClosePointInTimeResponse True 5 + decode (encode resp) `shouldBe` Just resp + + it' <- runIO es9OnlyIT + it' "uses the ES9 local PointInTime types (not the ES7 inherited ones)" $ + withTestEnv $ do + _ <- insertData + let search = + ( mkSearch + (Just $ MatchAllQuery Nothing) + Nothing + ) + { size = Size 1 + } + -- This exercises the ES9 client's pitSearch which uses OpenPointInTimeResponse { oes9PitId } + -- rather than the ES7 inherited field name oPitId. + pit_search' <- ClientES9.pitSearch testIndex (keepAliveMinutes 1) search :: BH IO [Hit Tweet] + let pit_search = map hitSource pit_search' + liftIO $ + pit_search `shouldMatchList` [Just exampleTweet] + xdescribe "Point in time (PIT) API (OpenSearch 2)" $ do it' <- runIO os2OnlyIT it' "returns a single document using the point in time (PIT) API" $ @@ -66,7 +985,7 @@ { size = Size 1 } regular_search <- searchTweet search - pit_search' <- ClientOS2.pitSearch testIndex search :: BH IO [Hit Tweet] + pit_search' <- ClientOS2.pitSearch testIndex (keepAliveMinutes 1) search :: BH IO [Hit Tweet] let pit_search = map hitSource pit_search' liftIO $ regular_search `shouldBe` Right exampleTweet -- Check that the size restriction is being honored @@ -89,10 +1008,23 @@ } scan_search' <- scanSearch testIndex search :: BH IO [Hit Tweet] let scan_search = map hitSource scan_search' - pit_search' <- ClientOS2.pitSearch testIndex search :: BH IO [Hit Tweet] + pit_search' <- ClientOS2.pitSearch testIndex (keepAliveMinutes 1) search :: BH IO [Hit Tweet] let pit_search = map hitSource pit_search' let expectedHits = map Just docs liftIO $ scan_search `shouldMatchList` expectedHits liftIO $ pit_search `shouldMatchList` expectedHits + +-- | Build a 'POSIXMS' from a millisecond count, mirroring the +-- 'FromJSON' instance's truncating behaviour so the expected value in +-- the OS3 decode test matches what the parser actually yields. +posixMSFromMillis :: Integer -> POSIXMS +posixMSFromMillis n = POSIXMS (posixSecondsToUTCTime (fromInteger (n `div` 1000))) + +-- | Order-insensitive comparison for @(key, value)@ query-param pairs. +-- 'withQueries' is order-insensitive, but the test-suite's @shouldBe@ +-- is not; this helper sorts both sides so a stable but unspecified +-- ordering does not cause spurious failures. +sortPairs :: [(Text.Text, Maybe Text.Text)] -> [(Text.Text, Maybe Text.Text)] +sortPairs = sortOn fst diff --git a/tests/Test/QueryRulesSpec.hs b/tests/Test/QueryRulesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/QueryRulesSpec.hs @@ -0,0 +1,628 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.QueryRulesSpec (spec) where + +import Data.Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust, isNothing) +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch8.Requests qualified as RequestsES8 +import Database.Bloodhound.ElasticSearch8.Types qualified as Types +import Database.Bloodhound.ElasticSearch9.Client qualified as ClientES9 +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import TestsUtils.Common +import TestsUtils.Import + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +spec :: Spec +spec = describe "Query Rules API (PUT/GET/DELETE/TEST /_query_rules/{ruleset_id})" $ do + describe "RulesetId / RuleId JSON" $ do + it "round-trips a RulesetId" $ do + let rid = Types.RulesetId "my-ruleset" + decode (encode rid) `shouldBe` Just rid + + it "round-trips a RuleId" $ do + let rid = Types.RuleId "my-rule" + decode (encode rid) `shouldBe` Just rid + + it "unRulesetId extracts the underlying Text" $ + Types.unRulesetId (Types.RulesetId "abc") `shouldBe` ("abc" :: Text) + + it "unRuleId extracts the underlying Text" $ + Types.unRuleId (Types.RuleId "abc") `shouldBe` ("abc" :: Text) + + describe "RuleType JSON" $ do + it "serializes PinnedRuleType as \"pinned\"" $ do + encode Types.PinnedRuleType `shouldBe` "\"pinned\"" + Types.ruleTypeToText Types.PinnedRuleType `shouldBe` "pinned" + + it "serializes ExcludeRuleType as \"exclude\"" $ do + encode Types.ExcludeRuleType `shouldBe` "\"exclude\"" + Types.ruleTypeToText Types.ExcludeRuleType `shouldBe` "exclude" + + it "round-trips PinnedRuleType" $ + decode (encode Types.PinnedRuleType) `shouldBe` Just Types.PinnedRuleType + + it "round-trips ExcludeRuleType" $ + decode (encode Types.ExcludeRuleType) `shouldBe` Just Types.ExcludeRuleType + + it "round-trips an unknown rule type via OtherRuleType" $ do + let t = Types.OtherRuleType "rewind" + decode (encode t) `shouldBe` Just t + Types.ruleTypeFromText "rewind" `shouldBe` t + + it "parses \"pinned\" as PinnedRuleType (not OtherRuleType)" $ + Types.ruleTypeFromText "pinned" `shouldBe` Types.PinnedRuleType + + it "parses \"exclude\" as ExcludeRuleType (not OtherRuleType)" $ + Types.ruleTypeFromText "exclude" `shouldBe` Types.ExcludeRuleType + + describe "Criterion JSON wire shape" $ do + it "encodes AlwaysCriterion with no metadata/values" $ do + encode Types.AlwaysCriterion `shouldBe` "{\"type\":\"always\"}" + decode (encode Types.AlwaysCriterion) `shouldBe` Just Types.AlwaysCriterion + + it "encodes GlobalCriterion with no metadata/values" $ do + encode Types.GlobalCriterion `shouldBe` "{\"type\":\"global\"}" + decode (encode Types.GlobalCriterion) `shouldBe` Just Types.GlobalCriterion + + it "parses \"global\" as GlobalCriterion (distinct from always)" $ do + let raw = LBS.pack "{\"type\":\"global\"}" + decode raw `shouldBe` Just Types.GlobalCriterion + encode Types.GlobalCriterion `shouldNotBe` encode Types.AlwaysCriterion + + it "encodes ExactCriterion with metadata + values array" $ do + let c = Types.ExactCriterion "user_country" (String "FR" :| []) + encode c + `shouldBe` "{\"metadata\":\"user_country\",\"type\":\"exact\",\"values\":[\"FR\"]}" + decode (encode c) `shouldBe` Just c + + it "encodes FuzzyCriterion" $ do + let c = Types.FuzzyCriterion "user_country" (String "FR" :| [String "DE"]) + encode c + `shouldBe` "{\"metadata\":\"user_country\",\"type\":\"fuzzy\",\"values\":[\"FR\",\"DE\"]}" + decode (encode c) `shouldBe` Just c + + it "encodes ContainsCriterion" $ do + let c = Types.ContainsCriterion "tag" (String "shoes" :| []) + encode c + `shouldBe` "{\"metadata\":\"tag\",\"type\":\"contains\",\"values\":[\"shoes\"]}" + decode (encode c) `shouldBe` Just c + + it "encodes PrefixCriterion" $ do + let c = Types.PrefixCriterion "q" (String "star" :| []) + encode c `shouldBe` "{\"metadata\":\"q\",\"type\":\"prefix\",\"values\":[\"star\"]}" + decode (encode c) `shouldBe` Just c + + it "encodes SuffixCriterion" $ do + let c = Types.SuffixCriterion "q" (String "wars" :| []) + encode c `shouldBe` "{\"metadata\":\"q\",\"type\":\"suffix\",\"values\":[\"wars\"]}" + decode (encode c) `shouldBe` Just c + + it "encodes GreaterThanCriterion" $ do + let c = Types.GreaterThanCriterion "age" (Number 30) + encode c `shouldBe` "{\"metadata\":\"age\",\"type\":\"gt\",\"values\":[30]}" + decode (encode c) `shouldBe` Just c + + it "encodes GreaterThanEqualCriterion" $ do + let c = Types.GreaterThanEqualCriterion "age" (Number 30) + encode c `shouldBe` "{\"metadata\":\"age\",\"type\":\"gte\",\"values\":[30]}" + decode (encode c) `shouldBe` Just c + + it "encodes LessThanCriterion" $ do + let c = Types.LessThanCriterion "age" (Number 30) + encode c `shouldBe` "{\"metadata\":\"age\",\"type\":\"lt\",\"values\":[30]}" + decode (encode c) `shouldBe` Just c + + it "encodes LessThanEqualCriterion" $ do + let c = Types.LessThanEqualCriterion "age" (Number 30) + encode c `shouldBe` "{\"metadata\":\"age\",\"type\":\"lte\",\"values\":[30]}" + decode (encode c) `shouldBe` Just c + + it "encodes GenericCriterion as raw JSON" $ do + let raw = + object + [ "type" .= ("future_type" :: Text), + "metadata" .= ("k" :: Text), + "values" .= [Number 42] + ] + c = Types.GenericCriterion raw + encode c `shouldBe` encode raw + decode (encode c) `shouldBe` Just c + + it "decodes an unknown criterion type as GenericCriterion" $ do + let raw = + LBS.pack + "{\"type\":\"future_type\",\"metadata\":\"k\",\"values\":[1]}" + case decode raw :: Maybe Types.Criterion of + Just (Types.GenericCriterion _) -> pure () + other -> expectationFailure $ "expected GenericCriterion, got: " <> show other + + it "rejects ExactCriterion with an empty values array" $ do + let raw = + LBS.pack + "{\"type\":\"exact\",\"metadata\":\"k\",\"values\":[]}" + (decode raw :: Maybe Types.Criterion) `shouldBe` Nothing + + it "rejects GreaterThanCriterion with multiple values" $ do + let raw = + LBS.pack + "{\"type\":\"gt\",\"metadata\":\"k\",\"values\":[1,2]}" + (decode raw :: Maybe Types.Criterion) `shouldBe` Nothing + + describe "PinnedDoc JSON" $ do + it "round-trips a doc with _index and _id" $ do + let d = Types.PinnedDoc (Just "my-index") "doc1" + decode (encode d) `shouldBe` Just d + + it "round-trips a doc with bare _id (omits _index)" $ do + let d = Types.PinnedDoc Nothing "doc1" + let json = encode d + json `shouldNotSatisfy` hasKey "_index" + decode (encode d) `shouldBe` Just d + + describe "PinnedActions JSON" $ do + it "omits docs/ids when not set" $ do + let pa = Types.PinnedActions [] [] + encode pa `shouldBe` "{}" + + it "emits docs when set" $ do + let pa = Types.PinnedActions [Types.PinnedDoc Nothing "a"] [] + let json = encode pa + json `shouldSatisfy` hasKey "docs" + json `shouldNotSatisfy` hasKey "ids" + json `shouldNotSatisfy` hasKey "organic" + + it "emits ids when set" $ do + let pa = Types.PinnedActions [] ["a", "b"] + let json = encode pa + json `shouldSatisfy` hasKey "ids" + json `shouldNotSatisfy` hasKey "docs" + + it "never emits organic (field removed)" $ do + let pa = Types.PinnedActions [Types.PinnedDoc (Just "idx") "a"] [] + encode pa `shouldNotSatisfy` hasKey "organic" + + it "decodes a missing docs/ids as empty lists" $ do + let raw = LBS.pack "{}" + case decode raw :: Maybe Types.PinnedActions of + Just pa -> do + Types.paDocs pa `shouldBe` [] + Types.paIds pa `shouldBe` [] + Nothing -> expectationFailure "failed to decode empty PinnedActions" + + it "tolerates a stray organic key from an old server response" $ do + let raw = LBS.pack "{\"organic\":[{\"_id\":\"x\"}],\"ids\":[\"a\"]}" + case decode raw :: Maybe Types.PinnedActions of + Just pa -> Types.paIds pa `shouldBe` ["a"] + Nothing -> + expectationFailure "stray organic key should be ignored, not rejected" + + describe "Rule JSON" $ do + it "round-trips a fully-populated pinned rule" $ do + let rule = + Types.Rule + { Types.rRuleId = "r1", + Types.rType = Types.PinnedRuleType, + Types.rCriteria = + [ Types.AlwaysCriterion, + Types.ExactCriterion + "user_country" + (String "FR" :| []) + ], + Types.rActions = + Types.PinnedActions + [Types.PinnedDoc (Just "movies") "tt0114709"] + [], + Types.rPriority = Nothing + } + decode (encode rule) `shouldBe` Just rule + + it "round-trips an exclude rule with ids actions" $ do + let rule = + Types.Rule + { Types.rRuleId = "r2", + Types.rType = Types.ExcludeRuleType, + Types.rCriteria = + [Types.GreaterThanCriterion "age" (Number 65)], + Types.rActions = Types.PinnedActions [] ["1", "2"], + Types.rPriority = Nothing + } + decode (encode rule) `shouldBe` Just rule + + it "encodes the rule_id, type, criteria, actions keys" $ do + let rule = + Types.Rule + { Types.rRuleId = "r1", + Types.rType = Types.PinnedRuleType, + Types.rCriteria = [Types.AlwaysCriterion], + Types.rActions = + Types.PinnedActions [Types.PinnedDoc Nothing "x"] [], + Types.rPriority = Nothing + } + let json = encode rule + json `shouldSatisfy` hasKey "rule_id" + json `shouldSatisfy` hasKey "type" + json `shouldSatisfy` hasKey "criteria" + json `shouldSatisfy` hasKey "actions" + + it "omits priority when it is Nothing" $ do + let rule = + Types.Rule + { Types.rRuleId = "r1", + Types.rType = Types.PinnedRuleType, + Types.rCriteria = [Types.AlwaysCriterion], + Types.rActions = Types.PinnedActions [] ["1"], + Types.rPriority = Nothing + } + encode rule `shouldNotSatisfy` hasKey "priority" + + it "emits priority as a number when set" $ do + let rule = + Types.Rule + { Types.rRuleId = "r1", + Types.rType = Types.PinnedRuleType, + Types.rCriteria = [Types.GlobalCriterion], + Types.rActions = Types.PinnedActions [] ["1"], + Types.rPriority = Just 5 + } + let json = encode rule + json `shouldSatisfy` hasKey "priority" + case decode json :: Maybe Types.Rule of + Just r -> Types.rPriority r `shouldBe` Just 5 + Nothing -> expectationFailure "failed to round-trip rule with priority" + + it "decodes a rule without priority as Nothing (backward compatible)" $ do + let raw = + LBS.pack + "{\"rule_id\":\"r1\",\"type\":\"pinned\",\"criteria\":[{\"type\":\"always\"}],\"actions\":{\"ids\":[\"1\"]}}" + case decode raw :: Maybe Types.Rule of + Just r -> Types.rPriority r `shouldBe` Nothing + Nothing -> expectationFailure "failed to decode rule without priority" + + describe "QueryRuleset JSON" $ do + it "round-trips an empty ruleset" $ do + let rs = Types.QueryRuleset [] + let json = encode rs + json `shouldBe` "{\"rules\":[]}" + decode json `shouldBe` Just rs + + it "round-trips a populated ruleset" $ do + let rs = + Types.QueryRuleset + [ Types.Rule + { Types.rRuleId = "r1", + Types.rType = Types.PinnedRuleType, + Types.rCriteria = [Types.AlwaysCriterion], + Types.rActions = + Types.PinnedActions + [Types.PinnedDoc (Just "i") "1"] + [], + Types.rPriority = Nothing + } + ] + decode (encode rs) `shouldBe` Just rs + + describe "QueryRulesetPutResponse JSON" $ do + it "decodes a created response" $ do + let raw = LBS.pack "{\"result\":\"created\"}" + case decode raw :: Maybe Types.QueryRulesetPutResponse of + Just resp -> Types.qrprResult resp `shouldBe` "created" + Nothing -> expectationFailure "failed to decode created response" + + it "decodes an updated response" $ do + let raw = LBS.pack "{\"result\":\"updated\"}" + case decode raw :: Maybe Types.QueryRulesetPutResponse of + Just resp -> Types.qrprResult resp `shouldBe` "updated" + Nothing -> expectationFailure "failed to decode updated response" + + it "round-trips" $ do + let resp = Types.QueryRulesetPutResponse "created" + decode (encode resp) `shouldBe` Just resp + + describe "QueryRulesetInfo JSON" $ do + it "round-trips a complete GET response" $ do + let info = + Types.QueryRulesetInfo + { Types.qriId = "my-ruleset", + Types.qriRules = + [ Types.Rule + { Types.rRuleId = "r1", + Types.rType = Types.PinnedRuleType, + Types.rCriteria = [Types.AlwaysCriterion], + Types.rActions = + Types.PinnedActions + [Types.PinnedDoc Nothing "1"] + [], + Types.rPriority = Nothing + } + ] + } + let json = encode info + json `shouldSatisfy` hasKey "ruleset_id" + json `shouldSatisfy` hasKey "rules" + decode json `shouldBe` Just info + + it "decodes a realistic ES GET response body" $ do + let raw = + LBS.pack + "{\"ruleset_id\":\"my-ruleset\",\"rules\":[{\"rule_id\":\"r1\",\"type\":\"pinned\",\"criteria\":[{\"type\":\"exact\",\"metadata\":\"user_country\",\"values\":[\"FR\"]}],\"actions\":{\"docs\":[{\"_index\":\"movies\",\"_id\":\"tt0114709\"}]}}]}" + case decode raw :: Maybe Types.QueryRulesetInfo of + Just info -> do + Types.qriId info `shouldBe` "my-ruleset" + case Types.qriRules info of + [rule] -> do + Types.unRuleId (Types.rRuleId rule) `shouldBe` "r1" + Types.rType rule `shouldBe` Types.PinnedRuleType + case Types.rCriteria rule of + [Types.ExactCriterion md vals] -> do + md `shouldBe` "user_country" + vals `shouldBe` (String "FR" :| []) + other -> + expectationFailure $ "expected ExactCriterion, got: " <> show other + Types.paDocs (Types.rActions rule) + `shouldBe` [Types.PinnedDoc (Just "movies") "tt0114709"] + other -> + expectationFailure $ "expected one rule, got: " <> show other + Nothing -> + expectationFailure "failed to decode QueryRulesetInfo" + + describe "QueryRulesetTest JSON" $ do + it "round-trips a non-empty match_criteria map" $ do + let body = + Types.QueryRulesetTest + { Types.qrtMatchCriteria = + Map.fromList + [ ("user_query", String "pugs"), + ("user_country", String "us") + ] + } + let json = encode body + json `shouldSatisfy` hasKey "match_criteria" + decode json `shouldBe` Just body + + it "decodes a realistic ES _test request body" $ do + let raw = + LBS.pack + "{\"match_criteria\":{\"user_query\":\"pugs\",\"user_country\":\"us\"}}" + case decode raw :: Maybe Types.QueryRulesetTest of + Just body -> + Map.lookup "user_query" (Types.qrtMatchCriteria body) + `shouldBe` Just (String "pugs") + Nothing -> + expectationFailure "failed to decode QueryRulesetTest" + + it "round-trips an empty match_criteria map" $ do + let body = Types.QueryRulesetTest Map.empty + decode (encode body) `shouldBe` Just body + + describe "QueryRulesetTestMatchedRule JSON" $ do + it "round-trips a matched-rule entry" $ do + let mr = + Types.QueryRulesetTestMatchedRule + { Types.qrtmrRulesetId = "my-ruleset", + Types.qrtmrRuleId = "my-rule1" + } + decode (encode mr) `shouldBe` Just mr + + it "decodes a realistic ES matched-rule entry" $ do + let raw = + LBS.pack + "{\"ruleset_id\":\"my-ruleset\",\"rule_id\":\"my-rule1\"}" + case decode raw :: Maybe Types.QueryRulesetTestMatchedRule of + Just mr -> do + Types.unRulesetId (Types.qrtmrRulesetId mr) `shouldBe` "my-ruleset" + Types.unRuleId (Types.qrtmrRuleId mr) `shouldBe` "my-rule1" + Nothing -> + expectationFailure "failed to decode QueryRulesetTestMatchedRule" + + describe "QueryRulesetTestResponse JSON" $ do + it "round-trips a complete response" $ do + let resp = + Types.QueryRulesetTestResponse + { Types.qrtTotal = 1, + Types.qrtMatched = + [ Types.QueryRulesetTestMatchedRule + { Types.qrtmrRulesetId = "my-ruleset", + Types.qrtmrRuleId = "my-rule1" + } + ] + } + let json = encode resp + json `shouldSatisfy` hasKey "total_matched_rules" + json `shouldSatisfy` hasKey "matched_rules" + decode json `shouldBe` Just resp + + it "decodes a realistic ES _test response body" $ do + let raw = + LBS.pack + "{\"total_matched_rules\":1,\"matched_rules\":[{\"ruleset_id\":\"my-ruleset\",\"rule_id\":\"my-rule1\"}]}" + case decode raw :: Maybe Types.QueryRulesetTestResponse of + Just resp -> do + Types.qrtTotal resp `shouldBe` 1 + case Types.qrtMatched resp of + [mr] -> + Types.unRuleId (Types.qrtmrRuleId mr) `shouldBe` "my-rule1" + other -> + expectationFailure $ "expected one matched rule, got: " <> show other + Nothing -> + expectationFailure "failed to decode QueryRulesetTestResponse" + + it "decodes a response with zero matched rules" $ do + let raw = + LBS.pack + "{\"total_matched_rules\":0,\"matched_rules\":[]}" + case decode raw :: Maybe Types.QueryRulesetTestResponse of + Just resp -> do + Types.qrtTotal resp `shouldBe` 0 + Types.qrtMatched resp `shouldBe` [] + Nothing -> + expectationFailure "failed to decode empty QueryRulesetTestResponse" + + describe "endpoint shape" $ do + it "PUTs to /_query_rules/ with a body (ES8)" $ do + let req = + RequestsES8.putQueryRuleset + "my-ruleset" + (Types.QueryRuleset []) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_query_rules", "my-ruleset"] + bhRequestBody req `shouldSatisfy` isJust + + it "GETs /_query_rules/ with no body (ES8)" $ do + let req = RequestsES8.getQueryRuleset "my-ruleset" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_query_rules", "my-ruleset"] + bhRequestBody req `shouldSatisfy` isNothing + + it "DELETEs /_query_rules/ with no body (ES8)" $ do + let req = RequestsES8.deleteQueryRuleset "my-ruleset" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_query_rules", "my-ruleset"] + bhRequestBody req `shouldSatisfy` isNothing + + it "POSTs to /_query_rules//_test with a body (ES8)" $ do + let req = + RequestsES8.testQueryRuleset + "my-ruleset" + (Types.QueryRulesetTest (Map.fromList [("user_query", String "pugs")])) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_query_rules", "my-ruleset", "_test"] + bhRequestBody req `shouldSatisfy` isJust + + it "ES9 request builders hit the same paths as ES8" $ do + let putReq = + RequestsES9.putQueryRuleset + "r" + (Types.QueryRuleset []) + let getReq = RequestsES9.getQueryRuleset "r" + let delReq = RequestsES9.deleteQueryRuleset "r" + let testReq = + RequestsES9.testQueryRuleset + "r" + (Types.QueryRulesetTest Map.empty) + getRawEndpoint (bhRequestEndpoint putReq) `shouldBe` ["_query_rules", "r"] + getRawEndpoint (bhRequestEndpoint getReq) `shouldBe` ["_query_rules", "r"] + getRawEndpoint (bhRequestEndpoint delReq) `shouldBe` ["_query_rules", "r"] + getRawEndpoint (bhRequestEndpoint testReq) `shouldBe` ["_query_rules", "r", "_test"] + bhRequestBody putReq `shouldSatisfy` isJust + bhRequestBody getReq `shouldSatisfy` isNothing + bhRequestBody delReq `shouldSatisfy` isNothing + bhRequestBody testReq `shouldSatisfy` isJust + + describe "live integration (requires ES8+ backend)" $ + backendSpecific [ElasticSearch8, ElasticSearch9] $ do + -- The positive PUT → GET → DELETE round-trip is gated in + -- production Elasticsearch behind a trial/enterprise license + -- (query rules are not available under the free basic license + -- that the docker-compose ES8/ES9 containers ship with). The + -- pure-JSON and endpoint-shape tests above exercise the + -- implementation in detail; this live test exists as a + -- manual smoke-test for clusters with an appropriate license. + it "round-trips a ruleset via PUT then GET then DELETE" $ + withTestEnv $ do + let ruleset = + Types.QueryRuleset + [ Types.Rule + { Types.rRuleId = "bloodhound-test-rule", + Types.rType = Types.PinnedRuleType, + Types.rCriteria = + [ Types.ExactCriterion + "user_country" + (String "FR" :| []) + ], + Types.rActions = + Types.PinnedActions + [ Types.PinnedDoc + (Just "bloodhound-tests-twitter-1") + "1" + ] + [], + Types.rPriority = Nothing + } + ] + rid = Types.RulesetId "bloodhound-test-query-rules" + _ <- + tryPerformBHRequest $ + RequestsES8.deleteQueryRuleset rid + backend <- liftIO detectBackendType + let putReq = + if backend == Just ElasticSearch9 + then ClientES9.putQueryRuleset rid ruleset + else ClientES8.putQueryRuleset rid ruleset + putResult <- tryEsError putReq + case putResult of + Left e + | errorStatus e == Just 403 + || "license" `T.isInfixOf` T.toLower (errorMessage e) -> + liftIO $ + pendingWith + "query rules require trial/enterprise license; \ + \skip on basic-license clusters" + Left e -> + liftIO $ + expectationFailure $ + "unexpected PUT error: " <> show e + Right putResp -> do + liftIO $ + Types.qrprResult putResp + `shouldSatisfy` (\r -> r == "created" || r == "updated") + info <- + if backend == Just ElasticSearch9 + then ClientES9.getQueryRuleset rid + else ClientES8.getQueryRuleset rid + liftIO $ length (Types.qriRules info) `shouldBe` 1 + -- _test: matching criteria should surface the rule. + let matchBody = + Types.QueryRulesetTest + (Map.fromList [("user_country", String "FR")]) + missBody = + Types.QueryRulesetTest + (Map.fromList [("user_country", String "US")]) + runTest = + if backend == Just ElasticSearch9 + then ClientES9.testQueryRuleset rid + else ClientES8.testQueryRuleset rid + matchResp <- runTest matchBody + liftIO $ do + Types.qrtTotal matchResp `shouldBe` 1 + length (Types.qrtMatched matchResp) `shouldBe` 1 + missResp <- runTest missBody + liftIO $ do + Types.qrtTotal missResp `shouldBe` 0 + Types.qrtMatched missResp `shouldBe` [] + _ <- + if backend == Just ElasticSearch9 + then ClientES9.deleteQueryRuleset rid + else ClientES8.deleteQueryRuleset rid + pure () + + it "DELETE of a non-existent ruleset surfaces a 4xx EsError" $ + withTestEnv $ do + result <- + tryPerformBHRequest $ + RequestsES8.deleteQueryRuleset + (Types.RulesetId "bloodhound-definitely-missing-ruleset") + case result of + Left e -> + case errorStatus e of + Just s -> liftIO $ (s >= 400 && s < 500) `shouldBe` True + Nothing -> + liftIO $ + expectationFailure $ + "expected a 4xx status, got none. Message: " + <> show (errorMessage e) + Right _ -> + liftIO $ + expectationFailure + "expected DELETE of a missing ruleset to fail, but it succeeded" diff --git a/tests/Test/QuerySpec.hs b/tests/Test/QuerySpec.hs --- a/tests/Test/QuerySpec.hs +++ b/tests/Test/QuerySpec.hs @@ -2,7 +2,7 @@ module Test.QuerySpec where -import qualified Data.Aeson.KeyMap as X +import Data.Aeson.KeyMap qualified as X import TestsUtils.Common import TestsUtils.Import @@ -106,7 +106,11 @@ liftIO $ myTweet `shouldBe` Right exampleTweet - it "returns document for common terms query" $ + -- The @common@ terms query was deprecated in ES 6.1 and removed in + -- ES 8.0 (OpenSearch, which forked from ES 7.10, still supports it). + -- Gate the live round-trip to backends whose major version is below 8. + esCommonIt <- runIO (withMajorVersionIT (< 8)) + esCommonIt "returns document for common terms query" $ withTestEnv $ do _ <- insertData let query = @@ -114,9 +118,9 @@ CommonTermsQuery (FieldName "user") (QueryString "bitemyapp") - (CutoffFrequency 0.0001) - Or - Or + (Just (CutoffFrequency 0.0001)) + (Just Or) + (Just Or) Nothing Nothing Nothing @@ -164,10 +168,68 @@ t2 `shouldBe` GetTemplateScript {getTemplateScriptLang = Nothing, getTemplateScriptSource = Nothing, getTemplateScriptOptions = Nothing, getTemplateScriptId = "myTemplate", getTemplateScriptFound = False} myTweet `shouldBe` Right exampleTweet + it "renderTemplate renders an inline template's mustache substitutions without executing it" $ + withTestEnv $ do + -- renderTemplate renders the body server-side without executing + -- a search, so no document needs to be indexed for this test. + let query = SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } } }" + templateParams = + TemplateQueryKeyValuePairs $ + X.fromList + [ ("my_field", "user"), + ("my_value", "bitemyapp") + ] + search = mkSearchTemplate (Right query) templateParams + rendered <- performBHRequest $ renderTemplate search + liftIO $ case rendered of + Left err -> + expectationFailure ("renderTemplate failed: " <> show err) + Right body -> do + -- The response wraps the resolved query under + -- @template_output@. Both the key (@{{my_field}}@) and the + -- value (@{{my_value}}@) must be substituted by mustache. + let expectedOutput = + object + [ "query" + .= object ["match" .= object ["user" .= String "bitemyapp"]] + ] + case body of + Object top -> X.lookup "template_output" top `shouldBe` Just expectedOutput + _ -> expectationFailure "expected a JSON object body" + + it "renderTemplate renders a stored template by id without executing it" $ + withTestEnv $ do + -- renderTemplate renders the body server-side without executing + -- a search, so no document needs to be indexed for this test. + let query = SearchTemplateSource "{\"query\": { \"match\" : { \"{{my_field}}\" : \"{{my_value}}\" } } }" + tid = SearchTemplateId "bh-render-template-spec" + templateParams = + TemplateQueryKeyValuePairs $ + X.fromList + [ ("my_field", "user"), + ("my_value", "bitemyapp") + ] + search = mkSearchTemplate (Left tid) templateParams + _ <- performBHRequest $ storeSearchTemplate tid query + rendered <- performBHRequest $ renderTemplate search + _ <- performBHRequest $ deleteSearchTemplate tid + liftIO $ case rendered of + Left err -> + expectationFailure ("renderTemplate by id failed: " <> show err) + Right body -> do + let expectedOutput = + object + [ "query" + .= object ["match" .= object ["user" .= String "bitemyapp"]] + ] + case body of + Object top -> X.lookup "template_output" top `shouldBe` Just expectedOutput + _ -> expectationFailure "expected a JSON object body" + it "returns document for wildcard query" $ withTestEnv $ do _ <- insertData - let query = QueryWildcardQuery $ WildcardQuery (FieldName "user") "bitemy*" Nothing + let query = QueryWildcardQuery $ WildcardQuery (FieldName "user") (Just "bitemy*") Nothing Nothing Nothing Nothing let search = mkSearch (Just query) Nothing myTweet <- searchTweet search liftIO $ diff --git a/tests/Test/RankEvalSpec.hs b/tests/Test/RankEvalSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RankEvalSpec.hs @@ -0,0 +1,631 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | Tests for the @POST /_rank_eval@ and @POST \/{index}\/_rank_eval@ +-- endpoints. +-- +-- The first sections are pure unit tests of the JSON instances and +-- 'RankEvalOptions' rendering — no live backend required. The last +-- section is live integration coverage under 'withTestEnv', which is +-- only meaningful when an Elasticsearch\/OpenSearch backend is +-- reachable on 'ES_TEST_SERVER' (default @http://localhost:9200@). +module Test.RankEvalSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as X +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List (sort) +import Data.Map.Strict qualified as M +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Common +import TestsUtils.Import + +-- --------------------------------------------------------------------------- +-- - URI param rendering +-- --------------------------------------------------------------------------- + +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + +-- --------------------------------------------------------------------------- +-- - Fixtures +-- --------------------------------------------------------------------------- + +-- | Response fixture modelled on the canonical ES example at +-- . +sampleRankEvalResponse :: LBS.ByteString +sampleRankEvalResponse = + "{\ + \ \"rank_eval_score\": 0.4347826086956522,\ + \ \"_shards\": {\"total\": 1, \"successful\": 1, \"skipped\": 0, \"failed\": 0},\ + \ \"details\": {\ + \ \"coffee_beans\": {\ + \ \"metric_score\": 1.0,\ + \ \"unrated_docs\": [\ + \ {\"_index\": \"my-index-000001\", \"_id\": \"dQfYfIkEcA24zrCA0p3U\"}\ + \ ],\ + \ \"hits\": [\ + \ {\"_index\": \"my-index-000001\", \"_id\": \"FojvYIkEcA24zrCA0p3W\", \"_score\": 0.5753642, \"rating\": 1}\ + \ ],\ + \ \"metric_details\": {\ + \ \"precision\": {\ + \ \"relevant_docs_retrieved\": 1,\ + \ \"docs_retrieved\": 1\ + \ }\ + \ }\ + \ }\ + \ },\ + \ \"failures\": {}\ + \}" + +-- | OpenSearch-shaped response. Two differences from ES: +-- +-- * Top-level score is keyed @metric_score@ (not @rank_eval_score@). +-- * No @_shards@ block. +-- * Each hit's @_index\/_id\/_score@ is nested under a @hit@ key. +-- +-- The 'FromJSON RankEvalResponse' / 'FromJSON RankEvalHit' instances +-- accept either shape; this fixture pins the OpenSearch side so a +-- future refactor that drops the tolerant parse is caught. +sampleOpenSearchRankEvalResponse :: LBS.ByteString +sampleOpenSearchRankEvalResponse = + "{\ + \ \"metric_score\": 1.0,\ + \ \"details\": {\ + \ \"coffee_beans\": {\ + \ \"metric_score\": 1.0,\ + \ \"unrated_docs\": [],\ + \ \"hits\": [\ + \ {\"hit\": {\"_index\": \"my-index-000001\", \"_id\": \"FojvYIkEcA24zrCA0p3W\", \"_score\": 0.5753642}, \"rating\": 1}\ + \ ],\ + \ \"metric_details\": {\ + \ \"mean_reciprocal_rank\": {\"first_relevant\": 1}\ + \ }\ + \ }\ + \ },\ + \ \"failures\": {}\ + \}" + +-- | A response with a non-empty 'rerResponseFailures' map: server may +-- report per-item errors when, e.g., the rated document does not exist +-- in the target index. +sampleRankEvalResponseWithFailure :: LBS.ByteString +sampleRankEvalResponseWithFailure = + "{\ + \ \"rank_eval_score\": 0.0,\ + \ \"_shards\": {\"total\": 1, \"successful\": 1, \"skipped\": 0, \"failed\": 0},\ + \ \"details\": {},\ + \ \"failures\": {\ + \ \"bad_request\": {\ + \ \"reason\": \"rated document does not exist\",\ + \ \"type\": \"illegal_argument_exception\"\ + \ }\ + \ }\ + \}" + +sampleRequest :: RankEvalRequest +sampleRequest = + RankEvalRequest + { rerRequests = + [ RankEvalRequestItem + { reiId = "q1", + reiRequest = mkSearch (Just (MatchAllQuery Nothing)) Nothing, + reiRatings = + [ DocumentRating + { drIndex = testIndex, + drId = DocId "1", + drRating = 1, + drPassthrough = Nothing + } + ], + reiTemplateId = Nothing, + reiParams = Nothing, + reiSummaryFields = Nothing, + reiIgnoreUnlabeled = Nothing + } + ], + rerMetric = Nothing, + rerMaxConcurrentSearches = Nothing + } + +-- --------------------------------------------------------------------------- +-- - Spec +-- --------------------------------------------------------------------------- + +spec :: Spec +spec = do + --------------------------------------------------------------------------- + -- URI param rendering + --------------------------------------------------------------------------- + describe "RankEvalOptions URI param rendering" $ do + it "defaultRankEvalOptions emits no params" $ + rankEvalOptionsParams defaultRankEvalOptions `shouldBe` [] + + it "omits search_type when set to the server default (QueryThenFetch)" $ do + let opts = defaultRankEvalOptions {reoSearchType = SearchTypeQueryThenFetch} + rankEvalOptionsParams opts `shouldBe` [] + + it "emits search_type only when set to DfsQueryThenFetch" $ do + let opts = defaultRankEvalOptions {reoSearchType = SearchTypeDfsQueryThenFetch} + rankEvalOptionsParams opts `shouldBe` [("search_type", Just "dfs_query_then_fetch")] + + it "renders Bool fields as true/false strings" $ do + let opts = + defaultRankEvalOptions + { reoAllowNoIndices = Just True, + reoIgnoreUnavailable = Just False + } + normalize (rankEvalOptionsParams opts) + `shouldBe` [ ("allow_no_indices", Just "true"), + ("ignore_unavailable", Just "false") + ] + + it "renders expand_wildcards as a comma-separated list" $ do + let opts = + defaultRankEvalOptions + { reoExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + rankEvalOptionsParams opts + `shouldBe` [("expand_wildcards", Just "open,closed")] + + it "emits every field when all are populated alongside DfsQueryThenFetch" $ do + let opts = + defaultRankEvalOptions + { reoSearchType = SearchTypeDfsQueryThenFetch, + reoAllowNoIndices = Just True, + reoExpandWildcards = Just (ExpandWildcardsOpen :| []), + reoIgnoreUnavailable = Just True + } + let rendered = rankEvalOptionsParams opts + length rendered `shouldBe` 4 + sort (map fst rendered) + `shouldBe` [ "allow_no_indices", + "expand_wildcards", + "ignore_unavailable", + "search_type" + ] + + --------------------------------------------------------------------------- + -- RankEvalMetric JSON + --------------------------------------------------------------------------- + describe "RankEvalMetric JSON" $ do + it "encodes MeanReciprocalRank under its server key" $ + encode (RankEvalMeanReciprocalRank defaultMeanReciprocalRankConfig) + `shouldBe` "{\"mean_reciprocal_rank\":{}}" + + it "encodes MeanReciprocalRank with k when set" $ + encode (RankEvalMeanReciprocalRank defaultMeanReciprocalRankConfig {mrrcK = Just 10}) + `shouldBe` "{\"mean_reciprocal_rank\":{\"k\":10}}" + + it "encodes Precision under its server key" $ + encode (RankEvalPrecision defaultPrecisionConfig {pcK = Just 5}) + `shouldBe` "{\"precision\":{\"k\":5}}" + + it "encodes Precision with all three config fields" $ do + -- NB: aeson 'object' sorts keys alphabetically; assert + -- structurally rather than on the exact wire bytes. + let encoded = + encode + ( RankEvalPrecision + defaultPrecisionConfig + { pcK = Just 5, + pcRelevantRatingThreshold = Just 1, + pcIgnoreUnlabeled = Just True + } + ) + let Just (top :: Object) = decode encoded + Just (Object (cfg :: Object)) = X.lookup "precision" top + X.lookup "k" cfg `shouldBe` Just (Number 5) + X.lookup "relevant_rating_threshold" cfg `shouldBe` Just (Number 1) + X.lookup "ignore_unlabeled" cfg `shouldBe` Just (Bool True) + + it "encodes Recall under its server key" $ + encode (RankEvalRecall defaultRecallConfig {rcK = Just 10, rcRelevantRatingThreshold = Just 2}) + `shouldBe` "{\"recall\":{\"k\":10,\"relevant_rating_threshold\":2}}" + + it "encodes DCG as an empty object" $ + encode RankEvalDCG `shouldBe` "{\"dcg\":{}}" + + it "encodes NDCG as an empty object" $ + encode RankEvalNDCG `shouldBe` "{\"ndcg\":{}}" + + it "encodes ExpectedReciprocalRank with k and maximum_relevance" $ + encode + ( RankEvalExpectedReciprocalRank + defaultExpectedReciprocalRankConfig + { errecK = Just 10, + errecMaximumRelevance = Just 3 + } + ) + `shouldBe` "{\"expected_reciprocal_rank\":{\"k\":10,\"maximum_relevance\":3}}" + + it "round-trips every constructor through ToJSON/FromJSON" $ do + let metrics = + [ RankEvalMeanReciprocalRank defaultMeanReciprocalRankConfig {mrrcK = Just 20}, + RankEvalPrecision defaultPrecisionConfig {pcK = Just 5, pcIgnoreUnlabeled = Just False}, + RankEvalRecall defaultRecallConfig {rcK = Just 10}, + RankEvalDCG, + RankEvalNDCG, + RankEvalExpectedReciprocalRank defaultExpectedReciprocalRankConfig {errecK = Just 5, errecMaximumRelevance = Just 2} + ] + forM_ metrics $ \m -> + (decode . encode) m `shouldBe` Just m + + it "decodes a metric when an unknown extra key is present" $ + -- The decoder must not bail on extension keys it doesn't + -- recognise; it picks the first known one. + decode "{\"future_metric\":{}, \"precision\":{\"k\":3}}" + `shouldBe` Just (RankEvalPrecision defaultPrecisionConfig {pcK = Just 3}) + + it "fails when no recognised metric key is present" $ do + let decoded = decode "{\"unknown_metric\":{}}" :: Maybe RankEvalMetric + decoded `shouldBe` Nothing + + --------------------------------------------------------------------------- + -- RankEvalRequest JSON + --------------------------------------------------------------------------- + describe "RankEvalRequest JSON" $ do + it "encodes a bare request as {\"requests\":[...]}" $ do + let Just (obj :: Object) = decode (encode sampleRequest) + X.lookup "requests" obj `shouldSatisfy` isJust + + it "omits the metric key when rerMetric is Nothing" $ do + let Just (obj :: Object) = decode (encode sampleRequest) + X.lookup "metric" obj `shouldBe` Nothing + + it "includes the metric key when rerMetric is Just" $ do + let req = sampleRequest {rerMetric = Just RankEvalDCG} + Just (obj :: Object) = decode (encode req) + X.lookup "metric" obj `shouldSatisfy` isJust + + it "omits max_concurrent_searches when rerMaxConcurrentSearches is Nothing" $ do + let Just (obj :: Object) = decode (encode sampleRequest) + X.lookup "max_concurrent_searches" obj `shouldBe` Nothing + + it "includes max_concurrent_searches as a number when rerMaxConcurrentSearches is Just" $ do + let req = sampleRequest {rerMaxConcurrentSearches = Just 4} + Just (obj :: Object) = decode (encode req) + X.lookup "max_concurrent_searches" obj `shouldSatisfy` isJust + + --------------------------------------------------------------------------- + -- DocumentRating JSON + --------------------------------------------------------------------------- + describe "DocumentRating JSON" $ do + it "encodes the _index/_id/rating triplet and omits passthrough when Nothing" $ do + -- NB: key order is unspecified; assert structurally. + let Just (obj :: Object) = + decode + ( encode + ( DocumentRating + { drIndex = testIndex, + drId = DocId "1", + drRating = 2, + drPassthrough = Nothing + } + ) + ) + X.lookup "_index" obj `shouldBe` Just (toJSON testIndex) + X.lookup "_id" obj `shouldBe` Just (toJSON (DocId "1")) + X.lookup "rating" obj `shouldBe` Just (Number 2) + X.lookup "passthrough" obj `shouldBe` Nothing + + it "encodes passthrough verbatim when present" $ + let passthrough = case object ["context" .= ("mobile" :: Text)] of Object o -> o; _ -> mempty + in do + let Just (obj :: Object) = + decode + ( encode + ( DocumentRating + { drIndex = testIndex, + drId = DocId "1", + drRating = 1, + drPassthrough = Just passthrough + } + ) + ) + X.lookup "_index" obj `shouldBe` Just (toJSON testIndex) + X.lookup "_id" obj `shouldBe` Just (toJSON (DocId "1")) + X.lookup "rating" obj `shouldBe` Just (Number 1) + -- passthrough carried through verbatim + let Just (Object (pt :: Object)) = X.lookup "passthrough" obj + X.lookup "context" pt `shouldBe` Just (String "mobile") + + it "round-trips through ToJSON/FromJSON (with passthrough)" $ do + let passthrough = case object ["note" .= ("x" :: Text)] of Object o -> o; _ -> mempty + original = + DocumentRating + { drIndex = testIndex, + drId = DocId "1", + drRating = 3, + drPassthrough = Just passthrough + } + (decode . encode) original `shouldBe` Just original + + it "round-trips a fractional rating through ToJSON/FromJSON" $ do + -- The rating is typed as 'Double' precisely so fractional + -- relevance scores (which both ES and OS accept) survive a + -- round-trip. + let original = + DocumentRating + { drIndex = testIndex, + drId = DocId "1", + drRating = 0.75, + drPassthrough = Nothing + } + (decode . encode) original `shouldBe` Just original + + --------------------------------------------------------------------------- + -- RankEvalRequestItem: summary_fields / ignore_unlabeled + --------------------------------------------------------------------------- + describe "RankEvalRequestItem summary_fields / ignore_unlabeled" $ do + it "omits summary_fields and ignore_unlabeled when both are Nothing" $ do + let item = + (head (rerRequests sampleRequest)) + { reiSummaryFields = Nothing, + reiIgnoreUnlabeled = Nothing + } + Just (obj :: Object) = decode (encode item) + X.lookup "summary_fields" obj `shouldBe` Nothing + X.lookup "ignore_unlabeled" obj `shouldBe` Nothing + + it "renders summary_fields as a JSON array of field names" $ do + let item = + (head (rerRequests sampleRequest)) + { reiSummaryFields = Just [FieldName "message", FieldName "user"] + } + Just (obj :: Object) = decode (encode item) + X.lookup "summary_fields" obj + `shouldBe` Just (toJSON ["message" :: Text, "user"]) + + it "renders ignore_unlabeled as a Bool when set" $ do + let item = + (head (rerRequests sampleRequest)) + { reiIgnoreUnlabeled = Just True + } + Just (obj :: Object) = decode (encode item) + X.lookup "ignore_unlabeled" obj `shouldBe` Just (Bool True) + + --------------------------------------------------------------------------- + -- RankEvalResponse JSON + --------------------------------------------------------------------------- + describe "RankEvalResponse JSON" $ do + it "decodes the canonical response fixture, preserving details and metric_details" $ do + let Just (decoded :: RankEvalResponse) = decode sampleRankEvalResponse + rerResponseScore decoded `shouldSatisfy` (\x -> x > 0 && x <= 1) + -- _shards total/successful parsed + shardTotal (rerResponseShards decoded) `shouldBe` 1 + shardsSuccessful (rerResponseShards decoded) `shouldBe` 1 + -- details keyed by request id + M.keysSet (rerResponseDetails decoded) `shouldBe` M.keysSet (M.singleton "coffee_beans" ()) + -- the metric_details shape survives + let Just detail = M.lookup "coffee_beans" (rerResponseDetails decoded) + redMetricScore detail `shouldBe` 1.0 + length (redHits detail) `shouldBe` 1 + -- failures present but empty + rerResponseFailures decoded `shouldBe` M.empty + + it "decodes the OpenSearch-shaped fixture (metric_score key, hit envelope, no _shards)" $ do + let Just (decoded :: RankEvalResponse) = decode sampleOpenSearchRankEvalResponse + -- metric_score read in place of rank_eval_score. + rerResponseScore decoded `shouldBe` 1.0 + -- No _shards block on OS → defaults to zero counts. + shardTotal (rerResponseShards decoded) `shouldBe` 0 + let Just detail = M.lookup "coffee_beans" (rerResponseDetails decoded) + length (redHits detail) `shouldBe` 1 + -- Hit fields extracted from the nested "hit" envelope. + let hit = head (redHits detail) + unIndexName (rehIndex hit) `shouldBe` "my-index-000001" + rehRating hit `shouldBe` Just 1 + + it "decodes a response with per-item failures into rerResponseFailures" $ do + let Just (decoded :: RankEvalResponse) = decode sampleRankEvalResponseWithFailure + M.keysSet (rerResponseFailures decoded) `shouldBe` M.keysSet (M.singleton "bad_request" ()) + rerResponseDetails decoded `shouldBe` M.empty + + it "treats missing 'details'/'failures' fields as empty maps" $ do + let Just (decoded :: RankEvalResponse) = + decode + "{\ + \ \"rank_eval_score\": 0.5,\ + \ \"_shards\": {\"total\": 1, \"successful\": 1, \"skipped\": 0, \"failed\": 0}\ + \}" + rerResponseDetails decoded `shouldBe` M.empty + rerResponseFailures decoded `shouldBe` M.empty + + --------------------------------------------------------------------------- + -- Endpoint wire shape + --------------------------------------------------------------------------- + describe "evaluateRank endpoint envelope" $ do + it "evaluateRank targets /_rank_eval with no query parameters" $ do + let req = Common.evaluateRank sampleRequest + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_rank_eval"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestMethod req `shouldBe` "POST" + bhRequestBody req `shouldSatisfy` isJust + + it "evaluateRankByIndex targets /{index}/_rank_eval" $ do + let req = Common.evaluateRankByIndex testIndex sampleRequest + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName testIndex, "_rank_eval"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "evaluateRankWith Nothing matches evaluateRank's path" $ do + let reqA = Common.evaluateRank sampleRequest + reqB = Common.evaluateRankWith Nothing defaultRankEvalOptions sampleRequest + getRawEndpoint (bhRequestEndpoint reqA) + `shouldBe` getRawEndpoint (bhRequestEndpoint reqB) + + it "evaluateRankWith (Just []) matches evaluateRank's path" $ do + let reqA = Common.evaluateRank sampleRequest + reqB = Common.evaluateRankWith (Just []) defaultRankEvalOptions sampleRequest + getRawEndpoint (bhRequestEndpoint reqA) + `shouldBe` getRawEndpoint (bhRequestEndpoint reqB) + + it "evaluateRankWith (Just [i]) matches evaluateRankByIndex's path" $ do + let reqA = Common.evaluateRankByIndex testIndex sampleRequest + reqB = Common.evaluateRankWith (Just [testIndex]) defaultRankEvalOptions sampleRequest + getRawEndpoint (bhRequestEndpoint reqA) + `shouldBe` getRawEndpoint (bhRequestEndpoint reqB) + + it "evaluateRankWith joins multiple indices with a comma" $ do + let req = + Common.evaluateRankWith + (Just [testIndex, testIndex]) + defaultRankEvalOptions + sampleRequest + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [ unIndexName testIndex <> "," <> unIndexName testIndex, + "_rank_eval" + ] + + it "evaluateRankWith forwards RankEvalOptions as query parameters" $ do + let opts = + defaultRankEvalOptions + { reoIgnoreUnavailable = Just True, + reoExpandWildcards = Just (ExpandWildcardsOpen :| []) + } + req = Common.evaluateRankWith (Just [testIndex]) opts sampleRequest + normalize (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [ ("expand_wildcards", Just "open"), + ("ignore_unavailable", Just "true") + ] + + --------------------------------------------------------------------------- + -- Live integration + --------------------------------------------------------------------------- + -- The local OpenSearch backend rejects requests with + -- @metric = Nothing@ (@Required [metric]@); always set one in live + -- tests even though the type allows it. + let liveMetric = RankEvalMeanReciprocalRank defaultMeanReciprocalRankConfig {mrrcK = Just 10} + sampleLiveRequest = sampleRequest {rerMetric = Just liveMetric} + describe "evaluateRank (integration)" $ do + it "evaluateRankByIndex scores the indexed tweet as relevant for a matching query" $ + withTestEnv $ do + _ <- insertData + let q = QueryMatchQuery $ mkMatchQuery (FieldName "message") (QueryString "haskell") + item = + RankEvalRequestItem + { reiId = "haskell-search", + reiRequest = (mkSearch (Just q) Nothing) {size = Size 1}, + reiRatings = + [ DocumentRating + { drIndex = testIndex, + drId = DocId "1", + drRating = 1, + drPassthrough = Nothing + } + ], + reiTemplateId = Nothing, + reiParams = Nothing, + reiSummaryFields = Nothing, + reiIgnoreUnlabeled = Nothing + } + req = + RankEvalRequest + { rerRequests = [item], + rerMetric = Just liveMetric, + rerMaxConcurrentSearches = Nothing + } + result <- tryPerformBHRequest $ Common.evaluateRankByIndex testIndex req + case result of + Left e -> + liftIO $ + expectationFailure $ + "expected a successful rank-eval, got EsError: " <> show e + Right resp -> + liftIO $ do + -- Perfect ranking => overall score is 1.0 across both + -- MRR and precision@k. We accept >= 0.99 to leave room + -- for floating-point noise. + rerResponseScore resp `shouldSatisfy` (>= 0.99) + -- The request id surfaces under details. + M.keysSet (rerResponseDetails resp) + `shouldBe` M.keysSet (M.singleton "haskell-search" ()) + -- No failures expected on a clean run. + rerResponseFailures resp `shouldBe` M.empty + + it "evaluateRankByIndex surfaces per-request details with hits and unrated_docs" $ + withTestEnv $ do + _ <- insertData + -- Index a second document we deliberately do NOT rate, so the + -- search returns it as an 'unrated_doc' in the breakdown. + _ <- insertOther + let q = QueryMatchQuery $ mkMatchQuery (FieldName "message") (QueryString "haskell") + item = + RankEvalRequestItem + { reiId = "mixed", + reiRequest = (mkSearch (Just q) Nothing) {size = Size 10}, + reiRatings = + [ DocumentRating + { drIndex = testIndex, + drId = DocId "1", + drRating = 1, + drPassthrough = Nothing + } + ], + reiTemplateId = Nothing, + reiParams = Nothing, + reiSummaryFields = Nothing, + reiIgnoreUnlabeled = Nothing + } + req = + RankEvalRequest + { rerRequests = [item], + rerMetric = Just liveMetric, + rerMaxConcurrentSearches = Nothing + } + result <- tryPerformBHRequest $ Common.evaluateRankByIndex testIndex req + case result of + Left e -> + liftIO $ + expectationFailure $ + "expected a successful rank-eval, got EsError: " <> show e + Right resp -> do + let Just detail = M.lookup "mixed" (rerResponseDetails resp) + liftIO $ do + -- At least one hit was returned by the search. + length (redHits detail) `shouldSatisfy` (>= 1) + -- DocId "1" should be among the rated hits with rating 1. + let ratedIds = [unpackId (rehId h) | h <- redHits detail] + "1" `elem` ratedIds `shouldBe` True + + it "evaluateRankWith surfaces per-request failures for a missing index" $ do + let missing = [qqIndexName|bloodhound-missing-index-rank-eval-spec|] + req = + Common.evaluateRankWith + (Just [missing]) + defaultRankEvalOptions + sampleLiveRequest + -- Two equally valid responses exist across backends: + -- * ES returns HTTP 404 → 'EsError' from 'tryEsError'. + -- * OpenSearch returns HTTP 200 with @failures@ populated on + -- the parsed 'RankEvalResponse' (and @metric_score: "NaN"@). + -- Accept either: the only invariant we pin is "the missing + -- index did not silently evaluate to a clean response". + result <- withTestEnv $ tryEsError (performBHRequest req) + case result of + Left _ -> pure () + Right resp -> + rerResponseFailures resp `shouldSatisfy` (not . M.null) + + it "evaluateRankWith forwards ignore_unavailable to keep a missing index from failing the request" $ + withTestEnv $ do + _ <- insertData + let missing = [qqIndexName|bloodhound-missing-index-rank-eval-spec|] + opts = defaultRankEvalOptions {reoIgnoreUnavailable = Just True} + req = + Common.evaluateRankWith + (Just [missing, testIndex]) + opts + sampleLiveRequest + -- The request should not raise an EsError. We don't assert on + -- the score (the missing index is silently dropped, leaving + -- testIndex to evaluate against itself), only on the absence + -- of an error path. + result <- tryEsError (performBHRequest req) + case result of + Left e -> + liftIO $ + expectationFailure $ + "expected success with ignore_unavailable=true, got EsError: " <> show e + Right _ -> pure () diff --git a/tests/Test/ReindexOptionsSpec.hs b/tests/Test/ReindexOptionsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ReindexOptionsSpec.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.ReindexOptionsSpec (spec) where + +import Data.List (sort) +import Data.Scientific (Scientific) +import Data.Text qualified as T +import Database.Bloodhound.Common.Types +import Test.Hspec (Spec, describe, it, shouldBe) + +-- | Stable ordering for equality. The renderer preserves field-declaration +-- order but tests compare the set of params, not the order. +normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] +normalize = sort + +-- | Boolean helpers rendered as @true@/@false@ strings. +boolTrue :: Maybe T.Text +boolTrue = Just "true" + +boolFalse :: Maybe T.Text +boolFalse = Just "false" + +spec :: Spec +spec = + describe "ReindexOptions URI param rendering" $ do + it "defaultReindexOptions emits no params" $ + reindexOptionsParams defaultReindexOptions + `shouldBe` [] + + describe "conflicts" $ do + it "ConflictsProceed renders as conflicts=proceed" $ do + let opts = defaultReindexOptions {rioConflicts = Just ConflictsProceed} + reindexOptionsParams opts `shouldBe` [("conflicts", Just "proceed")] + it "ConflictsAbort renders as conflicts=abort" $ do + let opts = defaultReindexOptions {rioConflicts = Just ConflictsAbort} + reindexOptionsParams opts `shouldBe` [("conflicts", Just "abort")] + + it "refresh renders via RefreshPolicy" $ do + let opts = defaultReindexOptions {rioRefresh = Just RefreshTrue} + reindexOptionsParams opts `shouldBe` [("refresh", Just "true")] + + it "timeout renders verbatim" $ do + let opts = defaultReindexOptions {rioTimeout = Just "5s"} + reindexOptionsParams opts `shouldBe` [("timeout", Just "5s")] + + it "scroll renders verbatim" $ do + let opts = defaultReindexOptions {rioScroll = Just "1m"} + reindexOptionsParams opts `shouldBe` [("scroll", Just "1m")] + + describe "wait_for_active_shards" $ do + it "AllActiveShards renders as wait_for_active_shards=all" $ do + let opts = defaultReindexOptions {rioWaitForActiveShards = Just AllActiveShards} + reindexOptionsParams opts `shouldBe` [("wait_for_active_shards", Just "all")] + it "ActiveShards n renders as wait_for_active_shards=" $ do + let opts = defaultReindexOptions {rioWaitForActiveShards = Just (ActiveShards 2)} + reindexOptionsParams opts `shouldBe` [("wait_for_active_shards", Just "2")] + + it "requests_per_second renders as decimal" $ do + let opts = defaultReindexOptions {rioRequestsPerSecond = Just 500} + reindexOptionsParams opts `shouldBe` [("requests_per_second", Just "500")] + + it "requests_per_second renders 0 (no throttling)" $ do + let opts = defaultReindexOptions {rioRequestsPerSecond = Just 0} + reindexOptionsParams opts `shouldBe` [("requests_per_second", Just "0")] + + describe "slices" $ do + it "SlicesAuto renders as slices=auto" $ do + let opts = defaultReindexOptions {rioSlices = Just SlicesAuto} + reindexOptionsParams opts `shouldBe` [("slices", Just "auto")] + it "SlicesCount n renders as slices=" $ do + let opts = defaultReindexOptions {rioSlices = Just (SlicesCount 4)} + reindexOptionsParams opts `shouldBe` [("slices", Just "4")] + + it "pipeline renders verbatim" $ do + let opts = defaultReindexOptions {rioPipeline = Just "my-pipe"} + reindexOptionsParams opts `shouldBe` [("pipeline", Just "my-pipe")] + + describe "require_alias" $ do + it "Just True renders as require_alias=true" $ do + let opts = defaultReindexOptions {rioRequireAlias = Just True} + reindexOptionsParams opts `shouldBe` [("require_alias", boolTrue)] + it "Just False renders as require_alias=false" $ do + let opts = defaultReindexOptions {rioRequireAlias = Just False} + reindexOptionsParams opts `shouldBe` [("require_alias", boolFalse)] + + it "max_docs renders as decimal" $ do + let opts = defaultReindexOptions {rioMaxDocs = Just 100} + reindexOptionsParams opts `shouldBe` [("max_docs", Just "100")] + + it "renders every field together when all are populated" $ do + let opts = + defaultReindexOptions + { rioConflicts = Just ConflictsProceed, + rioRefresh = Just RefreshWaitFor, + rioTimeout = Just "5s", + rioScroll = Just "1m", + rioWaitForActiveShards = Just (ActiveShards 1), + rioRequestsPerSecond = Just 100, + rioSlices = Just (SlicesCount 4), + rioPipeline = Just "my-pipe", + rioRequireAlias = Just True, + rioMaxDocs = Just 500 + } + normalize (reindexOptionsParams opts) + `shouldBe` normalize + [ ("conflicts", Just "proceed"), + ("refresh", Just "wait_for"), + ("timeout", Just "5s"), + ("scroll", Just "1m"), + ("wait_for_active_shards", Just "1"), + ("requests_per_second", Just "100"), + ("slices", Just "4"), + ("pipeline", Just "my-pipe"), + ("require_alias", boolTrue), + ("max_docs", Just "500") + ] + + -- RethrottleRate renders the value of the requests_per_second URI + -- parameter carried by 'rethrottleReindex'. Mirrors the examples in + -- the ES docs: -1 for unlimited, plain integers for whole rates + -- (no trailing .0), fractional form for decimals. + describe "RethrottleRate rendering" $ do + it "RethrottleUnlimited renders as -1" $ + renderRethrottleRate RethrottleUnlimited `shouldBe` "-1" + it "integer-valued rate renders without trailing .0" $ + renderRethrottleRate (RethrottlePerSecond 12) `shouldBe` "12" + it "fractional rate renders as a decimal" $ + renderRethrottleRate (RethrottlePerSecond (1.7 :: Scientific)) + `shouldBe` "1.7" + it "zero rate renders as 0" $ + renderRethrottleRate (RethrottlePerSecond 0) `shouldBe` "0" + -- A negative 'RethrottlePerSecond' is not validated (see the + -- Haddock on 'RethrottleRate') — it renders verbatim and collides + -- with 'RethrottleUnlimited' on the wire. ES treats any negative + -- value as unlimited, so the wire-level effect is the same; this + -- test pins down the chosen behaviour so future refactors notice + -- if they change it. + it "negative rate renders verbatim (collides with Unlimited)" $ + renderRethrottleRate (RethrottlePerSecond (-1)) `shouldBe` "-1" diff --git a/tests/Test/ReindexResponseSpec.hs b/tests/Test/ReindexResponseSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ReindexResponseSpec.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Test.ReindexResponseSpec (spec) where + +import Data.Aeson (decode, encode) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Maybe (isJust) +import Database.Bloodhound.Common.Types +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) +import Test.QuickCheck (property) +import TestsUtils.Generators () + +-- | A fully-populated ES reindex response carrying the six bead-named +-- fields added in bloodhound-04f.23 (commit 1: total, deleted, noops, +-- timed_out, retries{bulk,search}, throttled_until_millis). Mirrors the +-- documented example shape. +sampleFullResponse :: LBS.ByteString +sampleFullResponse = + LBS.pack + ( unlines + [ "{", + " \"took\": 3589,", + " \"updated\": 100,", + " \"created\": 200,", + " \"batches\": 1,", + " \"version_conflicts\": 0,", + " \"throttled_millis\": 0,", + " \"total\": 300,", + " \"deleted\": 0,", + " \"noops\": 0,", + " \"timed_out\": false,", + " \"retries\": {\"bulk\": 0, \"search\": 0},", + " \"throttled_until_millis\": 0", + "}" + ] + ) + +-- | Minimal response that only carries the formerly hard-required keys. +-- Confirms the relaxed decoder still reads them and that the new fields +-- default to 'Nothing'. +sampleMinimalResponse :: LBS.ByteString +sampleMinimalResponse = + LBS.pack + ( unlines + [ "{", + " \"updated\": 0,", + " \"created\": 0,", + " \"batches\": 0,", + " \"version_conflicts\": 0,", + " \"throttled_millis\": 0", + "}" + ] + ) + +-- | The complete documented response surface (commit 2): all seventeen +-- top-level fields, a nested 'ReindexRetries', a 'ReindexFailure' with +-- a depth-2 recursive @caused_by@ chain, and two 'ReindexSliceStatus' +-- entries (one fully populated, one with just a @cancelled@ reason). +sampleCompleteResponse :: LBS.ByteString +sampleCompleteResponse = + LBS.pack + ( unlines + [ "{", + " \"took\": 3589,", + " \"updated\": 100,", + " \"created\": 200,", + " \"batches\": 1,", + " \"version_conflicts\": 0,", + " \"throttled_millis\": 0,", + " \"total\": 300,", + " \"deleted\": 0,", + " \"noops\": 0,", + " \"timed_out\": false,", + " \"retries\": {\"bulk\": 0, \"search\": 0},", + " \"throttled_until_millis\": 0,", + " \"requests_per_second\": -1,", + " \"failures\": [", + " {", + " \"index\": \"src\",", + " \"id\": \"abc\",", + " \"status\": 409,", + " \"cause\": {", + " \"type\": \"version_conflict_engine_exception\",", + " \"reason\": \"[src][1]: version conflict\",", + " \"caused_by\": {", + " \"type\": \"inner_type\",", + " \"reason\": \"inner reason\"", + " }", + " }", + " }", + " ],", + " \"slices\": [", + " {", + " \"slice_id\": 0,", + " \"total\": 150,", + " \"updated\": 50,", + " \"created\": 100,", + " \"deleted\": 0,", + " \"batches\": 1,", + " \"version_conflicts\": 0,", + " \"noops\": 0,", + " \"retries\": {\"bulk\": 0, \"search\": 0},", + " \"throttled_millis\": 0,", + " \"throttled_until_millis\": 0,", + " \"requests_per_second\": -1,", + " \"throttled\": \"0s\",", + " \"throttled_until\": \"0s\"", + " },", + " {", + " \"slice_id\": 1,", + " \"cancelled\": \"user cancelled\"", + " }", + " ],", + " \"task\": \"rO0ABXN5\",", + " \"slice_id\": 0", + "}" + ] + ) + +spec :: Spec +spec = describe "ReindexResponse JSON" $ do + it "decodes a fully-populated response" $ do + let Just decoded = decode sampleFullResponse :: Maybe ReindexResponse + reindexResponseTook decoded `shouldBe` Just 3589 + reindexResponseUpdated decoded `shouldBe` Just 100 + reindexResponseCreated decoded `shouldBe` Just 200 + reindexResponseBatches decoded `shouldBe` Just 1 + reindexResponseVersionConflicts decoded `shouldBe` Just 0 + reindexResponseThrottledMillis decoded `shouldBe` Just 0 + reindexResponseTotal decoded `shouldBe` Just 300 + reindexResponseDeleted decoded `shouldBe` Just 0 + reindexResponseNoops decoded `shouldBe` Just 0 + reindexResponseTimedOut decoded `shouldBe` Just False + reindexResponseRetries decoded `shouldSatisfy` isJust + reindexResponseThrottledUntilMillis decoded `shouldBe` Just 0 + + it "decodes the nested retries object" $ do + let Just decoded = decode sampleFullResponse :: Maybe ReindexResponse + Just retries = reindexResponseRetries decoded + reindexRetriesBulk retries `shouldBe` Just 0 + reindexRetriesSearch retries `shouldBe` Just 0 + + it "decodes a minimal response with new fields all Nothing" $ do + let Just decoded = decode sampleMinimalResponse :: Maybe ReindexResponse + reindexResponseTook decoded `shouldBe` Nothing + reindexResponseUpdated decoded `shouldBe` Just 0 + reindexResponseCreated decoded `shouldBe` Just 0 + reindexResponseBatches decoded `shouldBe` Just 0 + reindexResponseVersionConflicts decoded `shouldBe` Just 0 + reindexResponseThrottledMillis decoded `shouldBe` Just 0 + reindexResponseTotal decoded `shouldBe` Nothing + reindexResponseDeleted decoded `shouldBe` Nothing + reindexResponseNoops decoded `shouldBe` Nothing + reindexResponseTimedOut decoded `shouldBe` Nothing + reindexResponseRetries decoded `shouldBe` Nothing + reindexResponseThrottledUntilMillis decoded `shouldBe` Nothing + + it "decodes the empty object as all Nothing" $ do + let Just decoded = decode "{}" :: Maybe ReindexResponse + reindexResponseTook decoded `shouldBe` Nothing + reindexResponseUpdated decoded `shouldBe` Nothing + reindexResponseThrottledMillis decoded `shouldBe` Nothing + reindexResponseRetries decoded `shouldBe` Nothing + reindexResponseThrottledUntilMillis decoded `shouldBe` Nothing + + it "round-trips a fully-populated response" $ do + let Just decoded = decode sampleFullResponse :: Maybe ReindexResponse + (decode . encode) decoded `shouldBe` Just decoded + + it "round-trips a minimal response" $ do + let Just decoded = decode sampleMinimalResponse :: Maybe ReindexResponse + (decode . encode) decoded `shouldBe` Just decoded + + describe "commit-2 fields on ReindexResponse" $ do + it "decodes the complete documented response surface" $ do + let Just decoded = decode sampleCompleteResponse :: Maybe ReindexResponse + reindexResponseRequestsPerSecond decoded `shouldBe` Just (-1) + reindexResponseTask decoded `shouldBe` Just "rO0ABXN5" + reindexResponseSliceId decoded `shouldBe` Just 0 + -- failures: single entry with depth-2 recursive cause + reindexResponseFailures decoded `shouldSatisfy` isJust + let Just (failure : _) = reindexResponseFailures decoded + reindexFailureIndex failure `shouldBe` Just "src" + reindexFailureId failure `shouldBe` Just "abc" + reindexFailureStatus failure `shouldBe` Just 409 + reindexFailureCause failure `shouldSatisfy` isJust + let Just cause = reindexFailureCause failure + reindexFailureCauseType cause `shouldBe` Just "version_conflict_engine_exception" + reindexFailureCauseReason cause `shouldBe` Just "[src][1]: version conflict" + -- recursive caused_by chain + reindexFailureCauseCausedBy cause `shouldSatisfy` isJust + let Just inner = reindexFailureCauseCausedBy cause + reindexFailureCauseType inner `shouldBe` Just "inner_type" + reindexFailureCauseReason inner `shouldBe` Just "inner reason" + reindexFailureCauseCausedBy inner `shouldBe` Nothing + -- slices: two entries, first fully populated, second cancelled + reindexResponseSlices decoded `shouldSatisfy` isJust + let Just (s0 : s1 : _) = reindexResponseSlices decoded + reindexSliceStatusSliceId s0 `shouldBe` Just 0 + reindexSliceStatusTotal s0 `shouldBe` Just 150 + reindexSliceStatusThrottled s0 `shouldBe` Just "0s" + reindexSliceStatusThrottledUntil s0 `shouldBe` Just "0s" + reindexSliceStatusCancelled s0 `shouldBe` Nothing + reindexSliceStatusSliceId s1 `shouldBe` Just 1 + reindexSliceStatusCancelled s1 `shouldBe` Just "user cancelled" + reindexSliceStatusTotal s1 `shouldBe` Nothing + + it "round-trips the complete documented response surface" $ do + let Just decoded = decode sampleCompleteResponse :: Maybe ReindexResponse + (decode . encode) decoded `shouldBe` Just decoded + + it "decodes a slice carrying a nested retries object" $ do + let bytes = + LBS.pack + ( unlines + [ "{\"slice_id\": 0, \"retries\": {\"bulk\": 2, \"search\": 1}}" + ] + ) + case decode bytes :: Maybe ReindexSliceStatus of + Just s -> do + reindexSliceStatusSliceId s `shouldBe` Just 0 + reindexSliceStatusRetries s `shouldSatisfy` isJust + let Just r = reindexSliceStatusRetries s + reindexRetriesBulk r `shouldBe` Just 2 + reindexRetriesSearch r `shouldBe` Just 1 + Nothing -> fail "expected a decoded ReindexSliceStatus, got Nothing" + + it "tolerates a failure entry with no cause" $ do + let bytes = LBS.pack "{\"index\":\"i\",\"id\":\"x\",\"status\":500}" + case decode bytes :: Maybe ReindexFailure of + Just f -> do + reindexFailureIndex f `shouldBe` Just "i" + reindexFailureId f `shouldBe` Just "x" + reindexFailureStatus f `shouldBe` Just 500 + reindexFailureCause f `shouldBe` Nothing + Nothing -> fail "expected a decoded ReindexFailure, got Nothing" + + describe "ReindexRetries JSON" $ do + it "decodes both fields" $ do + let Just decoded = decode "{\"bulk\": 3, \"search\": 1}" :: Maybe ReindexRetries + reindexRetriesBulk decoded `shouldBe` Just 3 + reindexRetriesSearch decoded `shouldBe` Just 1 + + it "decodes an empty object as all Nothing" $ + case decode "{}" :: Maybe ReindexRetries of + Just decoded -> do + reindexRetriesBulk decoded `shouldBe` Nothing + reindexRetriesSearch decoded `shouldBe` Nothing + Nothing -> fail "expected a decoded ReindexRetries, got Nothing" + + it "round-trips via encode . decode" $ do + let original = ReindexRetries {reindexRetriesBulk = Just 5, reindexRetriesSearch = Just 2} + (decode . encode) original `shouldBe` Just original + + it "never emits keys for Nothing fields" $ do + let encoded = encode (ReindexRetries {reindexRetriesBulk = Nothing, reindexRetriesSearch = Nothing}) + case decode encoded :: Maybe ReindexRetries of + Just decoded -> do + reindexRetriesBulk decoded `shouldBe` Nothing + reindexRetriesSearch decoded `shouldBe` Nothing + Nothing -> fail "expected a decoded ReindexRetries, got Nothing" + + describe "ReindexFailureCause JSON" $ do + it "decodes type and reason alone" $ + case decode "{\"type\":\"mapper_parsing_exception\",\"reason\":\"oops\"}" :: Maybe ReindexFailureCause of + Just c -> do + reindexFailureCauseType c `shouldBe` Just "mapper_parsing_exception" + reindexFailureCauseReason c `shouldBe` Just "oops" + reindexFailureCauseCausedBy c `shouldBe` Nothing + Nothing -> fail "expected a decoded ReindexFailureCause, got Nothing" + + it "decodes a recursive caused_by chain" $ do + let bytes = + LBS.pack + ( unlines + [ "{", + " \"type\": \"outer\",", + " \"caused_by\": {", + " \"type\": \"middle\",", + " \"caused_by\": {\"type\": \"inner\"}", + " }", + "}" + ] + ) + case decode bytes :: Maybe ReindexFailureCause of + Just c -> do + reindexFailureCauseType c `shouldBe` Just "outer" + let Just mid = reindexFailureCauseCausedBy c + reindexFailureCauseType mid `shouldBe` Just "middle" + let Just inner = reindexFailureCauseCausedBy mid + reindexFailureCauseType inner `shouldBe` Just "inner" + reindexFailureCauseCausedBy inner `shouldBe` Nothing + Nothing -> fail "expected a decoded ReindexFailureCause, got Nothing" + + it "decodes root_cause and suppressed as lists of causes" $ do + let bytes = + LBS.pack + ( unlines + [ "{", + " \"type\": \"top\",", + " \"root_cause\": [{\"type\":\"r1\"}],", + " \"suppressed\": [{\"type\":\"s1\"},{\"type\":\"s2\"}]", + "}" + ] + ) + case decode bytes :: Maybe ReindexFailureCause of + Just c -> do + let Just rc = reindexFailureCauseRootCause c + length rc `shouldBe` 1 + let Just sup = reindexFailureCauseSuppressed c + length sup `shouldBe` 2 + Nothing -> fail "expected a decoded ReindexFailureCause, got Nothing" + + it "round-trips via encode . decode" $ do + let original = + ReindexFailureCause + { reindexFailureCauseType = Just "t", + reindexFailureCauseReason = Just "r", + reindexFailureCauseStackTrace = Nothing, + reindexFailureCauseCausedBy = + Just + ReindexFailureCause + { reindexFailureCauseType = Just "inner", + reindexFailureCauseReason = Nothing, + reindexFailureCauseStackTrace = Nothing, + reindexFailureCauseCausedBy = Nothing, + reindexFailureCauseRootCause = Nothing, + reindexFailureCauseSuppressed = Nothing + }, + reindexFailureCauseRootCause = Nothing, + reindexFailureCauseSuppressed = Nothing + } + (decode . encode) original `shouldBe` Just original + + describe "ReindexFailure JSON" $ + it "round-trips via encode . decode" $ do + let original = + ReindexFailure + { reindexFailureIndex = Just "i", + reindexFailureId = Just "x", + reindexFailureStatus = Just 500, + reindexFailureCause = + Just + ReindexFailureCause + { reindexFailureCauseType = Just "t", + reindexFailureCauseReason = Just "r", + reindexFailureCauseStackTrace = Nothing, + reindexFailureCauseCausedBy = Nothing, + reindexFailureCauseRootCause = Nothing, + reindexFailureCauseSuppressed = Nothing + } + } + (decode . encode) original `shouldBe` Just original + + describe "ReindexSliceStatus JSON" $ + it "round-trips via encode . decode" $ do + let original = + ReindexSliceStatus + { reindexSliceStatusSliceId = Just 0, + reindexSliceStatusBatches = Just 1, + reindexSliceStatusCreated = Just 100, + reindexSliceStatusDeleted = Just 0, + reindexSliceStatusNoops = Just 0, + reindexSliceStatusRequestsPerSecond = Nothing, + reindexSliceStatusRetries = + Just + ReindexRetries + { reindexRetriesBulk = Just 0, + reindexRetriesSearch = Just 0 + }, + reindexSliceStatusThrottled = Just "0s", + reindexSliceStatusThrottledMillis = Just 0, + reindexSliceStatusThrottledUntil = Just "0s", + reindexSliceStatusThrottledUntilMillis = Just 0, + reindexSliceStatusTotal = Just 100, + reindexSliceStatusUpdated = Just 0, + reindexSliceStatusVersionConflicts = Just 0, + reindexSliceStatusCancelled = Nothing + } + (decode . encode) original `shouldBe` Just original + + describe "malformed inputs" $ do + it "rejects an array" $ do + let decoded = decode "[]" :: Maybe ReindexResponse + decoded `shouldBe` Nothing + + it "rejects a bare string" $ do + let decoded = decode "\"not-an-object\"" :: Maybe ReindexResponse + decoded `shouldBe` Nothing + + it "rejects null" $ do + let decoded = decode "null" :: Maybe ReindexResponse + decoded `shouldBe` Nothing + + it "rejects an array for retries" $ do + let decoded = decode "{\"retries\": []}" :: Maybe ReindexResponse + decoded `shouldBe` Nothing + + it "decodes an empty failures list as Just []" $ + case decode "{\"failures\": []}" :: Maybe ReindexResponse of + Just r -> reindexResponseFailures r `shouldBe` Just [] + Nothing -> fail "expected Just ReindexResponse with empty failures list" + + it "rejects an object for slices" $ do + let decoded = decode "{\"slices\": {}}" :: Maybe ReindexResponse + decoded `shouldBe` Nothing + + -- Property-based round-trips driven by the Arbitrary instances in + -- TestsUtils.Generators. Confirms ToJSON and FromJSON are exact + -- inverses on randomly generated values, not just hand-rolled samples. + describe "QuickCheck round-trips" $ do + it "ReindexRetries: decode . encode == id" $ + property $ + \r -> (decode . encode) (r :: ReindexRetries) == Just r + + it "ReindexResponse: decode . encode == id" $ + property $ + \r -> (decode . encode) (r :: ReindexResponse) == Just r + + it "ReindexFailureCause: decode . encode == id" $ + property $ + \r -> (decode . encode) (r :: ReindexFailureCause) == Just r + + it "ReindexFailure: decode . encode == id" $ + property $ + \r -> (decode . encode) (r :: ReindexFailure) == Just r + + it "ReindexSliceStatus: decode . encode == id" $ + property $ + \r -> (decode . encode) (r :: ReindexSliceStatus) == Just r diff --git a/tests/Test/ReindexSpec.hs b/tests/Test/ReindexSpec.hs --- a/tests/Test/ReindexSpec.hs +++ b/tests/Test/ReindexSpec.hs @@ -35,6 +35,47 @@ liftIO $ (map hitSource (hits (searchHits searchResult))) `shouldBe` [Just exampleTweet] + it "reindexWith forwards slices/max_docs URI params and reindexes synchronously" $ withTestEnv $ do + -- Seed the source with two distinct documents so rioMaxDocs has + -- something to cap. (insertData resets the index each call, so + -- use insertTweetWithDocId for the second insertion.) + _ <- insertData + _ <- insertTweetWithDocId (exampleTweetWithAge 99) "2" + let newIndex = [qqIndexName|bloodhound-tests-twitter-index-1-reindexed|] + opts = defaultReindexOptions {rioSlices = Just SlicesAuto, rioMaxDocs = Just 1} + _ <- tryPerformBHRequest $ deleteIndex newIndex + _ <- performBHRequest $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) newIndex + _ <- assertRight =<< tryPerformBHRequest (reindexWith opts $ mkReindexRequest testIndex newIndex) + _ <- performBHRequest $ refreshIndex newIndex + searchResult <- assertRight =<< tryPerformBHRequest (searchByIndex @Tweet newIndex (mkSearch Nothing Nothing)) + -- rioMaxDocs = 1 caps the destination to one document even though + -- the source has two. + liftIO $ length (hits (searchHits searchResult)) `shouldBe` 1 + + it "rethrottleReindex unthrottles an in-progress async reindex" $ withTestEnv $ do + _ <- insertData + let newIndex = [qqIndexName|bloodhound-tests-twitter-rethrottle-target|] + _ <- tryPerformBHRequest $ deleteIndex newIndex + _ <- + performBHRequest $ + createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) newIndex + -- Start the reindex throttled to 1 doc/sec so the task is still + -- running when the rethrottle lands. + let opts = defaultReindexOptions {rioRequestsPerSecond = Just 1} + taskNodeId <- assertRight =<< tryPerformBHRequest (reindexAsyncWith opts $ mkReindexRequest testIndex newIndex) + -- Race window: the single-doc reindex may finish before the + -- rethrottle reaches the server, in which case the response + -- carries an empty node list (the docstring on 'rethrottleReindex' + -- spells this out). When the task is still running the rethrottle + -- response lists it (>= 1 node). Either outcome is acceptable + -- here — the test exercises the wire path and decoder regardless. + _ <- performBHRequest $ rethrottleReindex taskNodeId RethrottleUnlimited + _ <- waitForTaskToComplete 10 taskNodeId + _ <- performBHRequest $ refreshIndex newIndex + searchResult <- assertRight =<< tryPerformBHRequest (searchByIndex newIndex (mkSearch Nothing Nothing)) + liftIO $ + map hitSource (hits (searchHits searchResult)) `shouldBe` [Just exampleTweet] + assertRight :: (Show a, MonadFail m) => Either a b -> m b assertRight (Left x) = fail $ "Expected Right, got Left: " <> show x assertRight (Right x) = pure x diff --git a/tests/Test/ReloadSearchAnalyzersSpec.hs b/tests/Test/ReloadSearchAnalyzersSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ReloadSearchAnalyzersSpec.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Test.ReloadSearchAnalyzersSpec (spec) where + +import Data.List (sort) +import Database.Bloodhound.Common.Types +import Optics (set, view) +import TestsUtils.Common +import TestsUtils.Import + +-- | Stable ordering for equality: 'withQueries' preserves the order in +-- which params are emitted, but the tests compare the @Set@ of params +-- to avoid coupling to internal field ordering. +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + +spec :: Spec +spec = do + -- ------------------------------------------------------------------ -- + -- Pure JSON decoder tests (no ES required). -- + -- ------------------------------------------------------------------ -- + describe "ReloadSearchAnalyzersResponse JSON parsing" $ do + let docBody = + "{\"_shards\":{\"total\":2,\"successful\":2,\"failed\":0},\ + \\"reload_details\":[{\"index\":\"my-index-000001\",\ + \\"reloaded_analyzers\":[\"my_synonyms\"],\ + \\"reloaded_node_ids\":[\"mfdqTXn_T7SGr2Ho2KT8uw\"]}]}" + minimalBody = + "{\"_shards\":{\"total\":0,\"successful\":0,\"failed\":0}}" + + it "parses the documented response (shards + one reload detail)" $ do + let Just (r :: ReloadSearchAnalyzersResponse) = decode docBody + shardTotal (rsarShards r) `shouldBe` 2 + shardsSuccessful (rsarShards r) `shouldBe` 2 + shardsFailed (rsarShards r) `shouldBe` 0 + -- skipped is absent in the doc example; parsed leniently as 0. + shardsSkipped (rsarShards r) `shouldBe` 0 + case rsarReloadDetails r of + [d] -> do + rdIndex d `shouldBe` [qqIndexName|my-index-000001|] + rdReloadedAnalyzers d `shouldBe` ["my_synonyms"] + rdReloadedNodeIds d `shouldBe` ["mfdqTXn_T7SGr2Ho2KT8uw"] + other -> + expectationFailure ("expected singleton reload_details, got " <> show other) + + it "parses the minimal response with no reload_details as []" $ do + let Just (r :: ReloadSearchAnalyzersResponse) = decode minimalBody + rsarReloadDetails r `shouldBe` [] + + it "round-trips the documented response via ToJSON/FromJSON" $ do + let Just (original :: ReloadSearchAnalyzersResponse) = decode docBody + reDecoded = decode (encode original) :: Maybe ReloadSearchAnalyzersResponse + Just original `shouldBe` reDecoded + + describe "ReloadDetail JSON parsing" $ do + let fullBody = + "{\"index\":\"my-index-000001\",\ + \\"reloaded_analyzers\":[\"a\",\"b\"],\ + \\"reloaded_node_ids\":[\"n1\"]}" + bareBody = "{\"index\":\"bare-idx\"}" + + it "parses all fields when present" $ do + let Just (d :: ReloadDetail) = decode fullBody + rdIndex d `shouldBe` [qqIndexName|my-index-000001|] + rdReloadedAnalyzers d `shouldBe` ["a", "b"] + rdReloadedNodeIds d `shouldBe` ["n1"] + + it "defaults the array fields to [] when absent" $ do + let Just (d :: ReloadDetail) = decode bareBody + rdIndex d `shouldBe` [qqIndexName|bare-idx|] + rdReloadedAnalyzers d `shouldBe` [] + rdReloadedNodeIds d `shouldBe` [] + + it "round-trips via ToJSON/FromJSON" $ do + let Just (original :: ReloadDetail) = decode fullBody + reDecoded = decode (encode original) :: Maybe ReloadDetail + Just original `shouldBe` reDecoded + + -- ------------------------------------------------------------------ -- + -- Optics. -- + -- ------------------------------------------------------------------ -- + describe "ReloadSearchAnalyzers lenses" $ do + it "rsarReloadDetailsLens is a lawful get/set" $ do + let Just (r :: ReloadSearchAnalyzersResponse) = + decode "{\"_shards\":{\"total\":1,\"successful\":1,\"failed\":0}}" + d = ReloadDetail [qqIndexName|ix|] ["an"] ["node"] + r' = set rsarReloadDetailsLens [d] r + view rsarReloadDetailsLens r' `shouldBe` [d] + + it "rdIndexLens is a lawful get/set" $ do + let d = ReloadDetail [qqIndexName|ix|] [] [] + d' = set rdIndexLens [qqIndexName|other|] d + view rdIndexLens d' `shouldBe` [qqIndexName|other|] + + -- ------------------------------------------------------------------ -- + -- Options rendering. -- + -- ------------------------------------------------------------------ -- + describe "ReloadSearchAnalyzersOptions URI param rendering" $ do + it "defaultReloadSearchAnalyzersOptions emits no params" $ + reloadSearchAnalyzersOptionsParams defaultReloadSearchAnalyzersOptions + `shouldBe` [] + + it "renders ignore_unavailable / allow_no_indices as true/false" $ do + let opts = + defaultReloadSearchAnalyzersOptions + { rsaoIgnoreUnavailable = Just False, + rsaoAllowNoIndices = Just True + } + normalize (reloadSearchAnalyzersOptionsParams opts) + `shouldBe` [ ("allow_no_indices", Just "true"), + ("ignore_unavailable", Just "false") + ] + + it "renders expand_wildcards as a comma-separated list" $ do + let opts = + defaultReloadSearchAnalyzersOptions + { rsaoExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + reloadSearchAnalyzersOptionsParams opts + `shouldBe` [("expand_wildcards", Just "open,closed")] + + -- ------------------------------------------------------------------ -- + -- Endpoint shape (BHRequest, no ES required). -- + -- ------------------------------------------------------------------ -- + describe "reloadSearchAnalyzers endpoint shape" $ do + let idx = [qqIndexName|my-idx|] + + it "POSTs /{index}/_reload_search_analyzers with no params by default" $ do + let req = reloadSearchAnalyzers idx + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["my-idx", "_reload_search_analyzers"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "sends an empty body" $ do + let req = reloadSearchAnalyzers idx + bhRequestBody req `shouldBe` Just "" + + it "forwards options as query params via the With variant" $ do + let opts = + defaultReloadSearchAnalyzersOptions + { rsaoIgnoreUnavailable = Just True + } + req = reloadSearchAnalyzersWith opts idx + lookup "ignore_unavailable" (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` Just (Just "true") diff --git a/tests/Test/RenderTemplateSpec.hs b/tests/Test/RenderTemplateSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RenderTemplateSpec.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.RenderTemplateSpec (spec) where + +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KM +import TestsUtils.Import +import Prelude + +-- | Pure endpoint-shape tests for the render-template endpoint +-- (@GET /_render/template@ and @GET /_render/template\/{id}@). No live +-- cluster round-trip — the live integration tests live next to the +-- existing search-template tests in 'Test.QuerySpec'. These pin the +-- wire contract: GET method (not POST, unlike every sibling +-- @*_search/template@ endpoint), GET-with-body (unusual for ES but +-- required here), path derived from the 'searchTemplate' field, and +-- the encoded 'SearchTemplate' carried verbatim as the body. +spec :: Spec +spec = describe "render template endpoint shape" $ do + let src = + SearchTemplateSource + "{\"query\":{\"match\":{\"{{field}}\":\"{{value}}\"}}}" + params = + TemplateQueryKeyValuePairs $ + KM.fromList + [ ("field", "user"), + ("value", "bitemyapp") + ] + inlineSearch = mkSearchTemplate (Right src) params + tid = SearchTemplateId "my-rendered-template" + storedSearch = mkSearchTemplate (Left tid) params + + describe "GET /_render/template (inline source)" $ do + it "uses the GET method (not POST like sibling _search/template)" $ do + bhRequestMethod (renderTemplate inlineSearch) `shouldBe` "GET" + + it "targets /_render/template with no trailing id segment" $ do + let req = renderTemplate inlineSearch + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_render", "template"] + + it "carries no query string" $ do + let req = renderTemplate inlineSearch + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches the encoded SearchTemplate as a body (GET-with-body)" $ do + let req = renderTemplate inlineSearch + bhRequestBody req `shouldSatisfy` isJust + + it "the body contains the inline source under the \"source\" key" $ do + let req = renderTemplate inlineSearch + bodyHasKey req "source" `shouldBe` True + + it "the body carries the params under the \"params\" key" $ do + let req = renderTemplate inlineSearch + bodyHasKey req "params" `shouldBe` True + + describe "GET /_render/template/{id} (stored template)" $ do + it "uses the GET method" $ do + bhRequestMethod (renderTemplate storedSearch) `shouldBe` "GET" + + it "targets /_render/template/{id} lifting the SearchTemplateId into the path" $ do + let req = renderTemplate storedSearch + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_render", "template", "my-rendered-template"] + + it "uses a distinct id in the path when given a different SearchTemplateId" $ do + let otherSearch = + mkSearchTemplate + (Left (SearchTemplateId "a-different-id")) + params + req = renderTemplate otherSearch + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_render", "template", "a-different-id"] + + it "keeps the id as a single opaque path segment" $ do + -- Client-side invariant only: the builder does not split an id + -- containing characters that look like path separators. A real + -- ES/OpenSearch server will reject ids containing @/@ as + -- malformed path segments — this test pins the *client's* + -- no-splitting behaviour, not server-side acceptance. + let weirdSearch = + mkSearchTemplate + (Left (SearchTemplateId "weird_42/id")) + params + req = renderTemplate weirdSearch + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_render", "template", "weird_42/id"] + + it "carries no query string" $ do + let req = renderTemplate storedSearch + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches the encoded SearchTemplate as a body (GET-with-body)" $ do + let req = renderTemplate storedSearch + bhRequestBody req `shouldSatisfy` isJust + + it "the body contains the id under the \"id\" key (the path wins server-side; the body copy is harmless)" $ do + -- The server takes the id from the path segment and ignores the + -- body copy; we send the SearchTemplate verbatim rather than + -- surgically stripping the id, so this asserts the simpler + -- invariant (whole SearchTemplate encoded) rather than a + -- body-shape special-case for the {id} path variant. + let req = renderTemplate storedSearch + bodyHasKey req "id" `shouldBe` True + + describe "renderTemplate is distinct from searchByIndexTemplate" $ do + -- Guards against an accidental copy-paste regression where + -- renderTemplate silently re-uses the @/_search/template@ endpoint. + -- The two APIs both take a 'SearchTemplate' body, but differ in + -- method (GET vs POST), path (@_render/template@ vs + -- @/_search/template@), and semantics (render-only vs + -- execute). The path + method are the distinguishing features. + let indexName = [qqIndexName|test-index|] + + it "uses GET, where searchByIndexTemplate uses POST" $ do + bhRequestMethod (renderTemplate inlineSearch) + `shouldNotBe` bhRequestMethod (searchByIndexTemplate @Aeson.Value indexName inlineSearch) + + it "uses the _render/template path, not the _search/template path" $ do + let renderPath = getRawEndpoint (bhRequestEndpoint (renderTemplate inlineSearch)) + searchPath = getRawEndpoint (bhRequestEndpoint (searchByIndexTemplate @Aeson.Value indexName inlineSearch)) + renderPath `shouldNotBe` searchPath + + it "the render path does not embed the IndexName (the endpoint is index-agnostic)" $ do + let renderPath = getRawEndpoint (bhRequestEndpoint (renderTemplate inlineSearch)) + renderPath `shouldNotContain` ["test-index"] + renderPath `shouldBe` ["_render", "template"] + + describe "renderTemplate body round-trips through SearchTemplate's ToJSON" $ do + -- Pins the invariant that the body is exactly the encoded + -- SearchTemplate (no envelope wrapper, no field stripping). A + -- future change that wrapped or rewrote the body would fail here. + it "inline body bytes equal encode of the SearchTemplate" $ do + let req = renderTemplate inlineSearch + bhRequestBody req `shouldBe` Just (Aeson.encode inlineSearch) + + it "stored-id body bytes equal encode of the SearchTemplate" $ do + let req = renderTemplate storedSearch + bhRequestBody req `shouldBe` Just (Aeson.encode storedSearch) + where + -- Total accessor: does the rendered request body decode to a JSON + -- object carrying the given key? Returns 'False' (rather than + -- throwing) when the body is absent or not a JSON object, so the + -- failing assertion points at the invariant under test rather than + -- at the partial pattern. + bodyHasKey :: BHRequest StatusDependant (ParsedEsResponse Aeson.Value) -> Aeson.Key -> Bool + bodyHasKey req key = + case bhRequestBody req of + Just body -> + case Aeson.decode body :: Maybe Aeson.Value of + Just (Aeson.Object o) -> KM.member key o + _ -> False + Nothing -> False diff --git a/tests/Test/RepositoriesMeteringSpec.hs b/tests/Test/RepositoriesMeteringSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RepositoriesMeteringSpec.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.RepositoriesMeteringSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import TestsUtils.Import +import Prelude + +-- | A canonical two-node response matching the documented ES shape: one +-- node with a metered S3 repository (every documented field populated) +-- and one node with an empty @repository_metering@ map. +sampleResponseBytes :: LBS.ByteString +sampleResponseBytes = + "{\ + \ \"_nodes\": {\"total\": 2, \"successful\": 2, \"failed\": 0},\ + \ \"cluster_name\": \"bloodhound-tests\",\ + \ \"nodes\": {\ + \ \"node-1\": {\ + \ \"repository_metering\": {\ + \ \"s3-repo:my-bucket:base/path\": {\ + \ \"cloud_provider\": \"aws\",\ + \ \"repo_type\": \"s3\",\ + \ \"repo_endpoint\": \"s3.amazonaws.com\",\ + \ \"repo_bucket\": \"my-bucket\",\ + \ \"repo_base_path\": \"base/path\",\ + \ \"creation_current_rate_limit\": {\"type\": \"bytes_per_second\", \"value\": 10485760},\ + \ \"deletion_current_rate_limit\": {\"type\": \"bytes_per_second\", \"value\": 10485760},\ + \ \"creation_total_count\": 42,\ + \ \"deletion_total_count\": 7\ + \ }\ + \ }\ + \ },\ + \ \"node-2\": {\ + \ \"repository_metering\": {}\ + \ }\ + \ }\ + \}" + +-- | A repository info payload carrying an unknown sibling field +-- (@future_field@) so the @rmiExtras@ round-trip catch-all is exercised. +sampleRepoInfoWithExtrasBytes :: LBS.ByteString +sampleRepoInfoWithExtrasBytes = + "{\ + \ \"cloud_provider\": \"gcp\",\ + \ \"repo_type\": \"gcs\",\ + \ \"future_field\": true\ + \}" + +spec :: Spec +spec = describe "Repositories metering API" $ do + describe "RepositoriesMeteringNodesSummary JSON" $ do + it "decodes a populated _nodes summary" $ do + let Just decoded = + decode "{ \"total\": 3, \"successful\": 2, \"failed\": 1 }" :: + Maybe RepositoriesMeteringNodesSummary + rmnsTotal decoded `shouldBe` 3 + rmnsSuccessful decoded `shouldBe` 2 + rmnsFailed decoded `shouldBe` 1 + + it "defaults missing counts to 0" $ do + let Just decoded = decode "{}" :: Maybe RepositoriesMeteringNodesSummary + rmnsTotal decoded `shouldBe` 0 + + it "round-trips through encode . decode" $ do + let original = RepositoriesMeteringNodesSummary 1 1 0 + Just roundTripped = decode (encode original) + roundTripped `shouldBe` original + + describe "RepositoryMeteringInfo JSON" $ do + it "decodes the documented fields" $ do + let Just decoded = + decode sampleRepoInfoWithExtrasBytes :: + Maybe RepositoryMeteringInfo + rmiCloudProvider decoded `shouldBe` Just "gcp" + rmiRepoType decoded `shouldBe` Just "gcs" + rmiRepoEndpoint decoded `shouldBe` Nothing + rmiCreationTotalCount decoded `shouldBe` Nothing + + it "preserves unknown fields in extras and round-trips" $ do + let Just decoded = + decode sampleRepoInfoWithExtrasBytes :: + Maybe RepositoryMeteringInfo + Just roundTripped = + decode (encode decoded) :: + Maybe RepositoryMeteringInfo + KM.lookup "future_field" (rmiExtras decoded) `shouldSatisfy` isJust + -- Known fields are NOT duplicated into extras. + KM.lookup "cloud_provider" (rmiExtras decoded) `shouldBe` Nothing + rmiCloudProvider roundTripped `shouldBe` Just "gcp" + KM.lookup "future_field" (rmiExtras roundTripped) `shouldSatisfy` isJust + + it "decodes a fully-populated metering entry" $ do + let body = + "{\ + \ \"cloud_provider\": \"azure\",\ + \ \"repo_type\": \"azure\",\ + \ \"repo_endpoint\": \"blob.core.windows.net\",\ + \ \"repo_bucket\": \"snapshots\",\ + \ \"repo_base_path\": \"repo\",\ + \ \"creation_current_rate_limit\": {\"type\": \"mb_per_second\", \"value\": 10},\ + \ \"deletion_current_rate_limit\": {\"type\": \"mb_per_second\", \"value\": 5},\ + \ \"creation_total_count\": 100,\ + \ \"deletion_total_count\": 20\ + \}" + Just decoded = decode body :: Maybe RepositoryMeteringInfo + rmiCloudProvider decoded `shouldBe` Just "azure" + rmiRepoBucket decoded `shouldBe` Just "snapshots" + rmiCreationTotalCount decoded `shouldBe` Just 100 + rmiDeletionTotalCount decoded `shouldBe` Just 20 + rmiCreationCurrentRateLimit decoded `shouldSatisfy` isJust + + it "decodes a minimal empty object without failure" $ do + let Just decoded = decode "{}" :: Maybe RepositoryMeteringInfo + rmiRepoType decoded `shouldBe` Nothing + KM.null (rmiExtras decoded) `shouldBe` True + + describe "NodeRepositoriesMetering JSON" $ do + it "unwraps the repository_metering key" $ do + let Just decoded = + decode "{ \"repository_metering\": {} }" :: + Maybe NodeRepositoriesMetering + KM.null (nrmRepositories decoded) `shouldBe` True + + it "defaults a missing repository_metering to empty" $ do + let Just decoded = decode "{}" :: Maybe NodeRepositoriesMetering + KM.null (nrmRepositories decoded) `shouldBe` True + + describe "RepositoriesMeteringResponse JSON" $ do + it "decodes a two-node response" $ do + let Just decoded = + decode sampleResponseBytes :: + Maybe RepositoriesMeteringResponse + rmrClusterName decoded `shouldBe` Just "bloodhound-tests" + rmnsTotal <$> rmrNodesSummary decoded `shouldBe` Just 2 + KM.size (rmrNodes decoded) `shouldBe` 2 + let Just node1 = KM.lookup "node-1" (rmrNodes decoded) + repos = nrmRepositories node1 + KM.size repos `shouldBe` 1 + let Just repo = KM.lookup "s3-repo:my-bucket:base/path" repos + rmiCloudProvider repo `shouldBe` Just "aws" + rmiCreationTotalCount repo `shouldBe` Just 42 + let Just node2 = KM.lookup "node-2" (rmrNodes decoded) + KM.null (nrmRepositories node2) `shouldBe` True + + it "round-trips a two-node response through encode . decode" $ do + let Just decoded = + decode sampleResponseBytes :: + Maybe RepositoriesMeteringResponse + Just roundTripped = + decode (encode decoded) :: + Maybe RepositoriesMeteringResponse + rmrClusterName roundTripped `shouldBe` Just "bloodhound-tests" + KM.size (rmrNodes roundTripped) `shouldBe` 2 + let Just node1 = KM.lookup "node-1" (rmrNodes roundTripped) + Just repo = + KM.lookup "s3-repo:my-bucket:base/path" (nrmRepositories node1) + rmiRepoType repo `shouldBe` Just "s3" + + it "decodes a response missing _nodes and cluster_name" $ do + let Just decoded = + decode "{ \"nodes\": {} }" :: + Maybe RepositoriesMeteringResponse + rmrNodesSummary decoded `shouldBe` Nothing + rmrClusterName decoded `shouldBe` Nothing + KM.null (rmrNodes decoded) `shouldBe` True + + it "encodes a minimal response, dropping Nothing fields (omitNulls)" $ do + let minimal = RepositoriesMeteringResponse Nothing Nothing mempty + encoded = encode minimal + -- @_nodes@/@cluster_name@ are 'Nothing' → dropped; @nodes@ is an + -- empty object (not 'Null') → kept. + encoded `shouldBe` "{\"nodes\":{}}" + decode encoded `shouldBe` Just minimal + + describe "getRepositoriesMetering endpoint shape" $ do + let mkReq = getRepositoriesMetering + it "is a GET with no body and no query params (cluster-wide)" $ do + let req = mkReq Nothing + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_nodes", "_repositories_metering"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "scopes to _local for Just LocalNode" $ do + let req = mkReq (Just LocalNode) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_nodes", "_local", "_repositories_metering"] + + it "scopes to _all for Just AllNodes" $ do + let req = mkReq (Just AllNodes) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_nodes", "_all", "_repositories_metering"] + + it "scopes to a comma-joined NodeList" $ do + let req = + mkReq + ( Just + (NodeList (NodeByName (NodeName "n1") :| [NodeByName (NodeName "n2")])) + ) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_nodes", "n1,n2", "_repositories_metering"] + + describe "deleteRepositoriesMetering endpoint shape" $ do + it "is a DELETE with no body (cluster-wide)" $ do + let req = deleteRepositoriesMetering Nothing + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_nodes", "_repositories_metering"] + bhRequestBody req `shouldBe` Nothing + + it "scopes to a node selection" $ do + let req = deleteRepositoriesMetering (Just AllNodes) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_nodes", "_all", "_repositories_metering"] diff --git a/tests/Test/RerouteSpec.hs b/tests/Test/RerouteSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RerouteSpec.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.RerouteSpec where + +import Data.Aeson qualified as Aeson +import Data.List qualified as L +import Data.List.NonEmpty qualified as NE +import Data.Text qualified as T +import Database.Bloodhound.Common.Client qualified as Client +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Common +import TestsUtils.Import + +-- | Encode a 'ToJSON' value and decode it straight back as an untyped +-- 'Value'. Object key order is normalised away by the round-trip, so the +-- resulting 'Value' compares equal regardless of the encoder's key order. +encodedAs :: (ToJSON a) => a -> Maybe Value +encodedAs = Aeson.decode . Aeson.encode + +spec :: Spec +spec = do + describe "RerouteCommand ToJSON" $ do + let idx = [qqIndexName|twitter|] + shard = ShardId 0 + n1 = NodeName "node-1" + n2 = NodeName "node-2" + + it "renders move as {\"move\":{index,shard,from_node,to_node}}" $ do + let cmd = RerouteMove idx shard n1 n2 + encodedAs cmd + `shouldBe` Just + ( object + [ "move" + .= object + [ "index" .= ("twitter" :: Text), + "shard" .= (0 :: Int), + "from_node" .= ("node-1" :: Text), + "to_node" .= ("node-2" :: Text) + ] + ] + ) + + it "renders cancel without allow_primary when it is Nothing" $ do + let cmd = RerouteCancel idx shard n1 Nothing + encodedAs cmd + `shouldBe` Just + ( object + [ "cancel" + .= object + [ "index" .= ("twitter" :: Text), + "shard" .= (0 :: Int), + "node" .= ("node-1" :: Text) + ] + ] + ) + + it "renders cancel with allow_primary when it is Just" $ do + let cmd = RerouteCancel idx shard n1 (Just True) + encodedAs cmd + `shouldBe` Just + ( object + [ "cancel" + .= object + [ "index" .= ("twitter" :: Text), + "shard" .= (0 :: Int), + "node" .= ("node-1" :: Text), + "allow_primary" .= True + ] + ] + ) + + it "renders allocate_replica as {\"allocate_replica\":{index,shard,node}}" $ do + let cmd = RerouteAllocateReplica idx shard n1 + encodedAs cmd + `shouldBe` Just + ( object + [ "allocate_replica" + .= object + [ "index" .= ("twitter" :: Text), + "shard" .= (0 :: Int), + "node" .= ("node-1" :: Text) + ] + ] + ) + + it "renders allocate_stale_primary with mandatory accept_data_loss" $ do + let cmd = RerouteAllocateStalePrimary idx shard n1 True + encodedAs cmd + `shouldBe` Just + ( object + [ "allocate_stale_primary" + .= object + [ "index" .= ("twitter" :: Text), + "shard" .= (0 :: Int), + "node" .= ("node-1" :: Text), + "accept_data_loss" .= True + ] + ] + ) + + it "renders allocate_empty_primary with mandatory accept_data_loss" $ do + let cmd = RerouteAllocateEmptyPrimary idx shard n2 False + encodedAs cmd + `shouldBe` Just + ( object + [ "allocate_empty_primary" + .= object + [ "index" .= ("twitter" :: Text), + "shard" .= (0 :: Int), + "node" .= ("node-2" :: Text), + "accept_data_loss" .= False + ] + ] + ) + + it "passes RerouteCmdOther through verbatim" $ do + let v = object ["allocate" .= object ["foo" .= ("bar" :: Text)]] :: Value + -- The opaque command object is sent unchanged. + encodedAs (RerouteCmdOther v) `shouldBe` Just v + + describe "rerouteCluster request body" $ do + it "wraps the commands in a {\"commands\":[...]} object" $ do + let idx = [qqIndexName|twitter|] + cmds = + [ RerouteMove idx (ShardId 0) (NodeName "a") (NodeName "b"), + RerouteCancel idx (ShardId 1) (NodeName "a") Nothing + ] + req = Common.rerouteCluster cmds + Just body = bhRequestBody req + Aeson.decode body `shouldBe` Just (object ["commands" .= cmds]) + + describe "rerouteOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultRerouteOptions emits no params" $ + rerouteOptionsParams defaultRerouteOptions `shouldBe` [] + + it "renders dry_run as lowercase true/false" $ do + let opts = defaultRerouteOptions {roDryRun = Just True} + normalize (rerouteOptionsParams opts) `shouldBe` [("dry_run", Just "true")] + let opts' = defaultRerouteOptions {roDryRun = Just False} + normalize (rerouteOptionsParams opts') `shouldBe` [("dry_run", Just "false")] + + it "renders explain as lowercase true/false" $ do + let opts = defaultRerouteOptions {roExplain = Just True} + normalize (rerouteOptionsParams opts) `shouldBe` [("explain", Just "true")] + + it "renders metric as a comma-separated list" $ do + let opts = defaultRerouteOptions {roMetric = Just ("blocks" NE.:| ["nodes"])} + normalize (rerouteOptionsParams opts) `shouldBe` [("metric", Just "blocks,nodes")] + + it "renders master_timeout and timeout as " $ do + let opts = + defaultRerouteOptions + { roMasterTimeout = Just (TimeUnitSeconds, 30), + roTimeout = Just (TimeUnitMinutes, 1) + } + normalize (rerouteOptionsParams opts) + `shouldBe` [("master_timeout", Just "30s"), ("timeout", Just "1m")] + + describe "RerouteResponse FromJSON" $ do + it "decodes a bare acknowledgement" $ do + let payload = "{\"acknowledged\":true}" + Just decoded = Aeson.decode payload :: Maybe RerouteResponse + rrAcknowledged decoded `shouldBe` True + rrState decoded `shouldBe` Nothing + rrExplanations decoded `shouldBe` Nothing + + it "decodes an acknowledgement carrying a cluster state (dry_run)" $ do + let payload = + "{\"acknowledged\":true,\"state\":{\"cluster_name\":\"es\",\ + \\"cluster_uuid\":\"uuid\",\"version\":7,\"state_uuid\":\"s\",\ + \\"master_node\":\"m\",\"nodes\":{},\"metadata\":{},\ + \\"routing_table\":{}}}" + Just decoded = Aeson.decode payload :: Maybe RerouteResponse + rrAcknowledged decoded `shouldBe` True + rrState decoded `shouldSatisfy` isJust + + it "decodes an acknowledgement carrying explanations (explain)" $ do + let payload = + "{\"acknowledged\":true,\"state\":{\"cluster_name\":\"es\",\ + \\"cluster_uuid\":\"u\",\"version\":1,\"state_uuid\":\"s\",\ + \\"nodes\":{}},\"explanations\":[{\"node\":\"n\",\"decisions\":[]}]}" + Just decoded = Aeson.decode payload :: Maybe RerouteResponse + rrAcknowledged decoded `shouldBe` True + rrExplanations decoded `shouldSatisfy` (maybe False (not . null)) + + it "rejects a payload missing the acknowledged key" $ + (Aeson.decode "{\"state\":{}}" :: Maybe RerouteResponse) `shouldBe` Nothing + + -- ------------------------------------------------------------------ -- + -- rerouteCluster endpoint shape: pure checks against the BHRequest -- + -- value; no live backend needed. Mirrors the updateClusterSettings -- + -- shape tests in Test.ClusterSettingsSpec. -- + -- ------------------------------------------------------------------ -- + describe "rerouteCluster endpoint shape" $ do + let cmds = [RerouteAllocateReplica [qqIndexName|twitter|] (ShardId 0) (NodeName "n")] + + it "POSTs /_cluster/reroute with no queries by default" $ do + let req = Common.rerouteCluster cmds + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_cluster", "reroute"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches the encoded commands as the request body" $ do + let req = Common.rerouteCluster cmds + bhRequestBody req `shouldBe` Just (encode (object ["commands" .= cmds])) + + it "forwards dry_run via rerouteClusterWith" $ do + let opts = defaultRerouteOptions {roDryRun = Just True} + req = Common.rerouteClusterWith opts cmds + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_cluster", "reroute"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("dry_run", Just "true")] + + -- ------------------------------------------------------------------ -- + -- Live round-trip: a dry_run reroute applies nothing to the cluster -- + -- but exercises the full RerouteResponse decoder (acknowledged + -- + -- ClusterState) against a real backend. -- + -- ------------------------------------------------------------------ -- + describe "rerouteClusterWith live dry-run round-trip" $ + it "dry_run=true with empty commands acknowledges and returns the state" $ + withTestEnv $ + do + let opts = defaultRerouteOptions {roDryRun = Just True} + resp <- Client.rerouteClusterWith opts [] + liftIO $ rrAcknowledged resp `shouldBe` True + -- ES 9 dropped the (very large) cluster @state@ from the + -- dry_run reroute response — only @acknowledged@ comes back. + -- ES 7/8 still include it, so the state assertion is gated + -- to majors below 9. + major <- liftIO fetchMajorVersion + liftIO $ when (major < 9) $ rrState resp `shouldSatisfy` isJust diff --git a/tests/Test/ResizeSpec.hs b/tests/Test/ResizeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ResizeSpec.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.ResizeSpec where + +import Control.Exception (finally) +import Data.Aeson.KeyMap qualified as KM +import Data.List qualified as L +import Database.Bloodhound.Common.Client qualified as Client +import Database.Bloodhound.Common.Requests as Requests +import TestsUtils.Common +import TestsUtils.Import + +-- Test fixtures: a source index plus one target per operation. Each +-- integration test seeds the source, runs the operation, then asserts +-- the target was created with the requested shard count. Cleanup is +-- always run before AND after so partial state from a previous failed +-- run does not poison the next one. +resizeSrcIndex :: IndexName +resizeSrcIndex = [qqIndexName|bh-resize-src|] + +shrinkTargetIndex :: IndexName +shrinkTargetIndex = [qqIndexName|bh-resize-shrunk|] + +splitTargetIndex :: IndexName +splitTargetIndex = [qqIndexName|bh-resize-split|] + +cloneTargetIndex :: IndexName +cloneTargetIndex = [qqIndexName|bh-resize-cloned|] + +-- | Delete every index used by this spec, ignoring any that do not +-- exist. Called both before seeding (defensive cleanup of leftover +-- state) and after the assertions (exception-safe teardown). +cleanupResizeIndices :: BH IO () +cleanupResizeIndices = do + _ <- tryEsError $ performBHRequest $ deleteIndex resizeSrcIndex + _ <- tryEsError $ performBHRequest $ deleteIndex shrinkTargetIndex + _ <- tryEsError $ performBHRequest $ deleteIndex splitTargetIndex + _ <- tryEsError $ performBHRequest $ deleteIndex cloneTargetIndex + pure () + +-- | Create @bh-resize-src@ with the requested primary shard count (and +-- zero replicas, to keep the operation local to a single node), then +-- mark it read-only. Shrink, split and clone all refuse to operate on +-- a source index that is still writable. +-- +-- Replica count is forced to zero because the docker-compose test +-- cluster is single-node; assigning replicas that can never be +-- allocated would leave the index YELLOW and could trip the +-- @wait_for_active_shards@ check on the resize call. +seedReadOnlySource :: ShardCount -> BH IO () +seedReadOnlySource shardCount = do + _ <- cleanupResizeIndices + let settings = IndexSettings shardCount (ReplicaCount 0) defaultIndexMappingsLimits + _ <- performBHRequest $ createIndex settings resizeSrcIndex + -- Source must be marked read-only before the resize call: shrink, + -- split and clone all refuse to operate on a still-writable index. + _ <- performBHRequest $ updateIndexSettings (BlocksWrite True :| []) resizeSrcIndex + pure () + +-- | Wait for the cluster to settle on the resize result and confirm +-- the target index exists with the expected shard count. ES returns +-- Acknowledged=True before the target is fully allocated, so we ask +-- the cluster to reach yellow health before reading it back. +assertTargetIndex :: IndexName -> ShardCount -> BH IO () +assertTargetIndex target expectedShards = do + _ <- performBHRequest $ Requests.waitForYellowIndex target + info <- performBHRequest $ getIndex target + liftIO $ do + iiIndexName info `shouldBe` target + indexShards (iiFixedSettings info) `shouldBe` expectedShards + +-- | Body for the three 'defaultResizeSettings' values: an empty object +-- because no @settings@ \/ @mappings@ \/ @aliases@ are supplied. + +-- Single-alias payload reused by the "carries aliases" assertion. +sampleAliases :: KM.KeyMap Value +sampleAliases = KM.singleton "bh-resize-alias" (object []) + +-- | Sort query-string pairs so the assertion is order-insensitive — +-- 'withQueries' is documented as order-insensitive, so the test +-- shouldn't depend on how the params happen to be sequenced. +normalizeQueryString :: (Ord a, Ord b) => [(a, b)] -> [(a, b)] +normalizeQueryString = L.sort + +spec :: Spec +spec = do + describe "shrinkIndex / splitIndex / cloneIndex (request shape)" $ do + -- The body builder delegates to 'createIndexOptionsBody', so an + -- empty 'ShrinkSettings' must produce an empty body (not 'Nothing', + -- not "{}") — the server treats an absent body as "copy source + -- verbatim", which is exactly the documented behaviour. + it "shrinkIndex with defaultShrinkSettings sends an empty body" $ do + let req = Requests.shrinkIndex resizeSrcIndex shrinkTargetIndex defaultShrinkSettings + bhRequestBody req `shouldBe` Just "" + + it "splitIndex with defaultSplitSettings sends an empty body" $ do + let req = Requests.splitIndex resizeSrcIndex splitTargetIndex defaultSplitSettings + bhRequestBody req `shouldBe` Just "" + + it "cloneIndex with defaultCloneSettings sends an empty body" $ do + let req = Requests.cloneIndex resizeSrcIndex cloneTargetIndex defaultCloneSettings + bhRequestBody req `shouldBe` Just "" + + -- When 'cioSettings' is populated, the body must contain a + -- top-level @settings.index.number_of_shards@ field — this is how + -- the caller tells the server the target shard count for shrink + -- (must be a divisor of the source) or split (must be a multiple). + it "shrinkIndex forwards cioSettings as {settings:{index:{...}}}" $ do + let settings = + ShrinkSettings + defaultCreateIndexOptions + { cioSettings = + Just $ + IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits + } + let req = Requests.shrinkIndex resizeSrcIndex shrinkTargetIndex settings + let expected = + object + [ "settings" + .= object + [ "index" + .= object + [ "number_of_shards" .= (1 :: Int), + "number_of_replicas" .= (0 :: Int), + "mapping" .= defaultIndexMappingsLimits + ] + ] + ] + (decode =<< bhRequestBody req) `shouldBe` Just expected + + -- Likewise, aliases supplied via 'cioAliases' must land under the + -- top-level @aliases@ key. Verified on cloneIndex so we exercise + -- the third newtype's path through 'resizeEndpoint'. + it "cloneIndex forwards cioAliases as {aliases:{...}}" $ do + let settings = + CloneSettings + defaultCreateIndexOptions + { cioAliases = Just sampleAliases + } + let req = Requests.cloneIndex resizeSrcIndex cloneTargetIndex settings + let expected = object ["aliases" .= object ["bh-resize-alias" .= object []]] + (decode =<< bhRequestBody req) `shouldBe` Just expected + + -- The newtypes must also forward URI parameters through + -- 'createIndexOptionsParams'. This is the whole point of wrapping + -- the full 'CreateIndexOptions' rather than rolling a narrower + -- record — the typed resize settings preserve the entire + -- body+param surface of create-index. + it "splitIndex forwards cioWaitForActiveShards / master_timeout / timeout as query params" $ do + let settings = + SplitSettings + defaultCreateIndexOptions + { cioWaitForActiveShards = Just AllActiveShards, + cioMasterTimeout = Just (TimeUnitSeconds, 30), + cioTimeout = Just (TimeUnitMilliseconds, 500) + } + let req = Requests.splitIndex resizeSrcIndex splitTargetIndex settings + normalizeQueryString (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [ ("master_timeout", Just "30s"), + ("timeout", Just "500ms"), + ("wait_for_active_shards", Just "all") + ] + + describe "shrinkIndex (integration)" $ do + -- Source @bh-resize-src@ has 2 primary shards; the shrink target + -- @bh-resize-shrunk@ requests 1 shard (1 is a divisor of 2). The + -- single-node docker-compose cluster satisfies the "all shards on + -- one node" precondition trivially. + it "shrinks a 2-shard source into a 1-shard target" $ + withTestEnv + ( do + _ <- seedReadOnlySource (ShardCount 2) + resp <- + Client.shrinkIndex + resizeSrcIndex + shrinkTargetIndex + ( ShrinkSettings + defaultCreateIndexOptions + { cioSettings = + Just $ + IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits + } + ) + liftIO $ resp `shouldBe` Acknowledged True + assertTargetIndex shrinkTargetIndex (ShardCount 1) + ) + `finally` withTestEnv cleanupResizeIndices + + describe "splitIndex (integration)" $ do + -- Source @bh-resize-src@ has 1 primary shard; the split target + -- @bh-resize-split@ requests 2 shards (2 is a multiple of 1). + it "splits a 1-shard source into a 2-shard target" $ + withTestEnv + ( do + _ <- seedReadOnlySource (ShardCount 1) + resp <- + Client.splitIndex + resizeSrcIndex + splitTargetIndex + ( SplitSettings + defaultCreateIndexOptions + { cioSettings = + Just $ + IndexSettings (ShardCount 2) (ReplicaCount 0) defaultIndexMappingsLimits + } + ) + liftIO $ resp `shouldBe` Acknowledged True + assertTargetIndex splitTargetIndex (ShardCount 2) + ) + `finally` withTestEnv cleanupResizeIndices + + describe "cloneIndex (integration)" $ do + -- Source @bh-resize-src@ has 1 primary shard; the clone target + -- @bh-resize-cloned@ requests no overriding settings, so it + -- inherits the source's shard count. + it "clones a 1-shard source into a 1-shard target" $ + withTestEnv + ( do + _ <- seedReadOnlySource (ShardCount 1) + resp <- Client.cloneIndex resizeSrcIndex cloneTargetIndex defaultCloneSettings + liftIO $ resp `shouldBe` Acknowledged True + assertTargetIndex cloneTargetIndex (ShardCount 1) + ) + `finally` withTestEnv cleanupResizeIndices diff --git a/tests/Test/ResolveClusterSpec.hs b/tests/Test/ResolveClusterSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ResolveClusterSpec.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.ResolveClusterSpec (spec) where + +import Data.Aeson +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Map.Strict qualified as M +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch9.Client qualified as ClientES9 +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import Database.Bloodhound.ElasticSearch9.Types qualified as ES9 +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +------------------------------------------------------------------------------ +-- Sample payloads (trimmed to the wire fields decoded by the types). +------------------------------------------------------------------------------ + +-- | Per-cluster entry with only the two required fields, as returned by +-- the bare @GET /_resolve/cluster@ form (no index matching). +sampleInfoMinimalBytes :: LBS.ByteString +sampleInfoMinimalBytes = + "{\ + \ \"connected\": true,\ + \ \"skip_unavailable\": false\ + \}" + +-- | Per-cluster entry with every optional field populated, as returned +-- when an index expression is supplied and the remote is recent enough +-- to report a version. +sampleInfoFullBytes :: LBS.ByteString +sampleInfoFullBytes = + "{\ + \ \"connected\": true,\ + \ \"skip_unavailable\": false,\ + \ \"matching_indices\": true,\ + \ \"error\": \"authorization error\",\n\ + \ \"version\": {\ + \ \"build_flavor\": \"default\",\ + \ \"minimum_index_compatibility_version\": \"8.0.0\",\ + \ \"minimum_wire_compatibility_version\": \"8.0.0\",\ + \ \"number\": \"9.0.0\"\ + \ }\ + \}" + +-- | Full @GET /_resolve/cluster@ response: a map keyed by cluster alias, +-- with the querying cluster under @"(local)"@ and one remote cluster. +sampleResponseBytes :: LBS.ByteString +sampleResponseBytes = + "{\ + \ \"(local)\": {\ + \ \"connected\": true,\ + \ \"skip_unavailable\": false\ + \ },\ + \ \"remote_cluster\": {\ + \ \"connected\": true,\ + \ \"skip_unavailable\": true,\ + \ \"matching_indices\": false,\ + \ \"version\": {\ + \ \"build_flavor\": \"default\",\ + \ \"minimum_index_compatibility_version\": \"8.0.0\",\ + \ \"minimum_wire_compatibility_version\": \"8.0.0\",\ + \ \"number\": \"9.0.0\"\ + \ }\ + \ }\ + \}" + +spec :: Spec +spec = do + -------------------------------------------------------------------------- + -- JSON (de)serialisation + -------------------------------------------------------------------------- + describe "ResolveClusterInfo JSON" $ do + it "decodes the minimal two-field form" $ do + let decoded = eitherDecode sampleInfoMinimalBytes :: Either String ES9.ResolveClusterInfo + decoded `shouldSatisfy` isRight + let Right info = decoded + ES9.rciConnected info `shouldBe` True + ES9.rciSkipUnavailable info `shouldBe` False + ES9.rciMatchingIndices info `shouldBe` Nothing + ES9.rciVersion info `shouldBe` Nothing + + it "decodes the full form with version and matching_indices" $ do + let decoded = eitherDecode sampleInfoFullBytes :: Either String ES9.ResolveClusterInfo + decoded `shouldSatisfy` isRight + let Right info = decoded + ES9.rciMatchingIndices info `shouldBe` Just True + ES9.rciError info `shouldBe` Just "authorization error" + ES9.rcvNumber <$> ES9.rciVersion info `shouldBe` Just "9.0.0" + + it "round-trips through encode/decode" $ do + let decoded = eitherDecode sampleInfoFullBytes :: Either String ES9.ResolveClusterInfo + decoded `shouldSatisfy` isRight + let Right info = decoded + eitherDecode (encode info) `shouldBe` Right info + + describe "ResolveClusterResponse JSON" $ do + it "decodes a map keyed by cluster alias" $ do + let decoded = eitherDecode sampleResponseBytes :: Either String ES9.ResolveClusterResponse + decoded `shouldSatisfy` isRight + let Right resp = decoded + let entries = ES9.resolveClusterResponseEntries resp + M.size entries `shouldBe` 2 + M.member "(local)" entries `shouldBe` True + M.member "remote_cluster" entries `shouldBe` True + + -------------------------------------------------------------------------- + -- Endpoint shape + -------------------------------------------------------------------------- + describe "resolveCluster endpoint shape" $ do + it "GETs /_resolve/cluster when given Nothing" $ do + let req = RequestsES9.resolveCluster Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_resolve", "cluster"] + + it "GETs /_resolve/cluster/{name} when given patterns" $ do + let req = RequestsES9.resolveCluster (Just ["logs-*"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_resolve", "cluster", "logs-*"] + + it "joins multiple patterns with a comma" $ do + let req = RequestsES9.resolveCluster (Just ["a", "b"]) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_resolve", "cluster", "a,b"] + + it "uses the GET method" $ do + let req = RequestsES9.resolveCluster Nothing + bhRequestMethod req `shouldBe` "GET" + + it "carries no request body" $ do + let req = RequestsES9.resolveCluster Nothing + bhRequestBody req `shouldBe` Nothing + + it "carries no query string by default" $ do + let req = RequestsES9.resolveCluster Nothing + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "renders expand_wildcards via resolveClusterWith" $ do + let opts = + ES9.defaultResolveClusterOptions + { ES9.rcoExpandWildcards = + Just (ExpandWildcardsOpen :| [ExpandWildcardsHidden]) + } + req = RequestsES9.resolveClusterWith opts (Just ["logs-*"]) + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("expand_wildcards", Just "open,hidden")] + + it "renders ignore_throttled via resolveClusterWith" $ do + let opts = + ES9.defaultResolveClusterOptions + { ES9.rcoIgnoreThrottled = Just True + } + req = RequestsES9.resolveClusterWith opts (Just ["logs-*"]) + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("ignore_throttled", Just "true")] + + it "renders ignore_throttled=false when set to False" $ do + let opts = + ES9.defaultResolveClusterOptions + { ES9.rcoIgnoreThrottled = Just False + } + req = RequestsES9.resolveClusterWith opts (Just ["logs-*"]) + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("ignore_throttled", Just "false")] + + it "omits ignore_throttled when Nothing (default)" $ do + let req = RequestsES9.resolveClusterWith ES9.defaultResolveClusterOptions (Just ["logs-*"]) + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + -------------------------------------------------------------------------- + -- Live integration (ES9 only). + -------------------------------------------------------------------------- + backendSpecific + [ElasticSearch9] + $ describe "Resolve cluster API (live integration)" + $ do + it "resolveCluster with an index pattern returns the local cluster" $ + withTestEnv $ do + -- 'GET /_resolve/cluster' with no index expression returns {} on a + -- single-node cluster with no remotes; the (local) entry only + -- appears once an index expression is supplied. + result <- tryEsError $ ClientES9.resolveCluster (Just ["bloodhound-tests-*"]) + liftIO $ + case result of + Left e + | endpointMissing e -> + pendingWith "resolve cluster requires Elasticsearch 9+" + _ -> pure () + case result of + Left e -> liftIO $ expectationFailure $ "resolveCluster failed: " <> show e + Right resp -> + liftIO $ + M.member "(local)" (ES9.resolveClusterResponseEntries resp) + `shouldBe` True + +-- | Detect the @no handler found for uri@shape returned by Elasticsearch +-- when an endpoint isn't registered on this version. Used to mark the +-- live tests as 'pendingWith' rather than failing. +endpointMissing :: EsError -> Bool +endpointMissing e = + "no handler found" `T.isInfixOf` T.toLower (errorMessage e) diff --git a/tests/Test/RolloverSpec.hs b/tests/Test/RolloverSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RolloverSpec.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.RolloverSpec where + +import Control.Exception (finally) +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as M +import Data.Text qualified as T +import Database.Bloodhound.Common.Client qualified as Client +import TestsUtils.Common +import TestsUtils.Import + +-- Test fixture: the alias @bh-rollover@ points at the write index +-- @bh-rollover-000001@. After 'rolloverIndex' the alias is repointed +-- at @bh-rollover-000002@ and the new index is created. +rolloverAliasName :: IndexAliasName +rolloverAliasName = IndexAliasName [qqIndexName|bh-rollover|] + +firstIndexName :: IndexName +firstIndexName = [qqIndexName|bh-rollover-000001|] + +secondIndexName :: IndexName +secondIndexName = [qqIndexName|bh-rollover-000002|] + +-- | Build the @cioAliases@ block that marks @bh-rollover@ as the write +-- index for @bh-rollover-000001@. The rollover API refuses to operate +-- on an alias that does not have a designated write index. +writeIndexAlias :: KM.KeyMap Value +writeIndexAlias = + KM.singleton "bh-rollover" (toJSON defaultIndexAliasCreate {aliasCreateIsWriteIndex = Just True}) + +-- | Tear down any indices + alias left over from a previous run. Both +-- possible target indices are deleted because rollover may have +-- advanced the suffix in an earlier run. +cleanupRollover :: BH IO () +cleanupRollover = do + _ <- tryEsError $ performBHRequest $ deleteIndex firstIndexName + _ <- tryEsError $ performBHRequest $ deleteIndex secondIndexName + pure () + +-- | Create @bh-rollover-000001@ with the alias @bh-rollover@ already +-- attached as the write index (see 'writeIndexAlias'). The rollover +-- API refuses to operate on an alias that does not have a designated +-- write index. +seedRolloverAlias :: BH IO () +seedRolloverAlias = do + _ <- cleanupRollover + let settings = IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits + let opts = + defaultCreateIndexOptions + { cioSettings = Just settings, + cioAliases = Just writeIndexAlias + } + _ <- performBHRequest $ createIndexOptions opts firstIndexName + pure () + +-- | 'True' when the conditions map contains a key mentioning the given +-- substring with the given boolean value. The server renders each +-- threshold as a display string (e.g. @"[max_docs: 1]"@) rather than +-- echoing the request shape. +conditionsHas :: T.Text -> Bool -> Maybe (M.Map T.Text Bool) -> Bool +conditionsHas substr val = + maybe + False + ( any + ( \(k, v) -> + T.isInfixOf substr k && v == val + ) + . M.toList + ) + +-- Test body for the conditions-met case. Exported so the spec can wrap +-- it in 'finally' for exception-safe cleanup. +conditionsMetAction :: BH IO () +conditionsMetAction = do + _ <- seedRolloverAlias + _ <- + performBHRequest $ + indexDocument + firstIndexName + defaultIndexDocumentSettings + exampleTweet + (DocId "1") + _ <- performBHRequest $ refreshIndex firstIndexName + resp <- + Client.rolloverIndex + rolloverAliasName + (Just (defaultRolloverConditions {rolloverConditionsMaxDocs = Just 1})) + liftIO $ do + rolloverResponseAcknowledged resp `shouldBe` True + rolloverResponseShardsAcknowledged resp `shouldBe` True + rolloverResponseRolledOver resp `shouldBe` True + rolloverResponseDryRun resp `shouldBe` False + rolloverResponseOldIndex resp `shouldBe` Just firstIndexName + rolloverResponseNewIndex resp `shouldBe` Just secondIndexName + conditionsHas "max_docs" True (rolloverResponseConditions resp) `shouldBe` True + +-- Test body for the unconditional-rollover case. +unconditionalAction :: BH IO () +unconditionalAction = do + _ <- seedRolloverAlias + resp <- Client.rolloverIndex rolloverAliasName Nothing + liftIO $ do + rolloverResponseAcknowledged resp `shouldBe` True + rolloverResponseRolledOver resp `shouldBe` True + rolloverResponseOldIndex resp `shouldBe` Just firstIndexName + rolloverResponseNewIndex resp `shouldBe` Just secondIndexName + -- With no conditions supplied, no threshold should be marked met. + let noMetThresholds = maybe True (all not . M.elems) (rolloverResponseConditions resp) + noMetThresholds `shouldBe` True + +-- Test body for the conditions-not-met case. +conditionsNotMetAction :: BH IO () +conditionsNotMetAction = do + _ <- seedRolloverAlias + resp <- + Client.rolloverIndex + rolloverAliasName + (Just (defaultRolloverConditions {rolloverConditionsMaxDocs = Just 100})) + liftIO $ do + rolloverResponseAcknowledged resp `shouldBe` False + rolloverResponseRolledOver resp `shouldBe` False + rolloverResponseOldIndex resp `shouldBe` Just firstIndexName + rolloverResponseNewIndex resp `shouldBe` Just secondIndexName + conditionsHas "max_docs" False (rolloverResponseConditions resp) `shouldBe` True + +spec :: Spec +spec = do + describe "rolloverIndex API" $ do + -- Successful rollover: max_docs=1 is satisfied by indexing exactly + -- one document before the call. ES swaps the alias to the new index + -- and reports both old_index and new_index. The server echoes the + -- condition back as a @Map Text Bool@ keyed by a human-readable + -- description like @"[max_docs: 1]"@. + -- + -- 'finally' ensures the indices are torn down even if an assertion + -- throws, so a failed run does not leak @bh-rollover-000001@ / + -- @bh-rollover-000002@ onto the server. + it "rolls the alias over to the next index when conditions are met" $ + withTestEnv conditionsMetAction `finally` withTestEnv cleanupRollover + + -- Rollover without any conditions: the server creates the new index + -- unconditionally and repoints the alias. This is the @Nothing@ + -- branch of the public API. + it "rolls over unconditionally when conditions are Nothing" $ + withTestEnv unconditionalAction `finally` withTestEnv cleanupRollover + + -- Rollover conditions not satisfied: max_docs is set higher than + -- the actual document count. The server reports @acknowledged=false@ + -- (no rollover performed) and @rolled_over=false@, and @conditions@ + -- shows the unmet threshold. The server still populates + -- @old_index@ / @new_index@ with the candidate names. + it "reports rolled_over=False when conditions are not met" $ + withTestEnv conditionsNotMetAction `finally` withTestEnv cleanupRollover + + -- The conditions block is omitted from the body when 'Nothing' is + -- passed; the body is the empty bytestring (not absent) so the + -- server treats the call as an unconditional rollover. + it "sends an empty body when conditions are Nothing" $ do + let req = rolloverIndex rolloverAliasName Nothing + bhRequestBody req `shouldBe` Just "" + + it "includes a conditions object when conditions are Just" $ do + let conditions = defaultRolloverConditions {rolloverConditionsMaxDocs = Just 5} + let req = rolloverIndex rolloverAliasName (Just conditions) + let expected = object ["conditions" .= object ["max_docs" .= (5 :: Int)]] + (decode =<< bhRequestBody req) `shouldBe` Just expected diff --git a/tests/Test/RollupSpec.hs b/tests/Test/RollupSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RollupSpec.hs @@ -0,0 +1,508 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.RollupSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict qualified as MapS +import TestsUtils.Import +import Prelude + +-- | The canonical @sensor@ PUT body, quoted verbatim from the +-- . +samplePutConfigBytes :: LBS.ByteString +samplePutConfigBytes = + "{\ + \ \"index_pattern\": \"sensor-*\",\ + \ \"rollup_index\": \"sensor_rollup\",\ + \ \"cron\": \"*/30 * * * * ?\",\ + \ \"page_size\": 1000,\ + \ \"groups\": {\ + \ \"date_histogram\": {\ + \ \"field\": \"timestamp\",\ + \ \"fixed_interval\": \"1h\",\ + \ \"delay\": \"7d\"\ + \ },\ + \ \"terms\": {\ + \ \"fields\": [\"node\"]\ + \ }\ + \ },\ + \ \"metrics\": [\ + \ {\"field\": \"temperature\", \"metrics\": [\"min\", \"max\", \"sum\"]},\ + \ {\"field\": \"voltage\", \"metrics\": [\"avg\"]}\ + \ ]\ + \}" + +-- | The @sensor@ job's @config@ as returned by GET, with the +-- server-injected @id@, the defaulted @time_zone@ and @timeout@. Verbatim +-- shape from the +-- . +sampleGetConfigBytes :: LBS.ByteString +sampleGetConfigBytes = + "{\ + \ \"id\": \"sensor\",\ + \ \"index_pattern\": \"sensor-*\",\ + \ \"rollup_index\": \"sensor_rollup\",\ + \ \"cron\": \"*/30 * * * * ?\",\ + \ \"groups\": {\ + \ \"date_histogram\": {\ + \ \"fixed_interval\": \"1h\",\ + \ \"delay\": \"7d\",\ + \ \"field\": \"timestamp\",\ + \ \"time_zone\": \"UTC\"\ + \ },\ + \ \"terms\": {\"fields\": [\"node\"]}\ + \ },\ + \ \"metrics\": [\ + \ {\"field\": \"temperature\", \"metrics\": [\"min\", \"max\", \"sum\"]},\ + \ {\"field\": \"voltage\", \"metrics\": [\"avg\"]}\ + \ ],\ + \ \"timeout\": \"20s\",\ + \ \"page_size\": 1000\ + \}" + +-- | A full @GET /_rollup/job/sensor@ response: a single job with config, +-- status (@stopped@, @upgraded_doc_id@ true) and zeroed stats. Shape from +-- the get-job docs. +sampleGetJobResponseBytes :: LBS.ByteString +sampleGetJobResponseBytes = + "{\ + \ \"jobs\": [\ + \ {\ + \ \"config\": {\ + \ \"id\": \"sensor\",\ + \ \"index_pattern\": \"sensor-*\",\ + \ \"rollup_index\": \"sensor_rollup\",\ + \ \"cron\": \"*/30 * * * * ?\",\ + \ \"groups\": {\ + \ \"date_histogram\": {\ + \ \"fixed_interval\": \"1h\", \"delay\": \"7d\",\ + \ \"field\": \"timestamp\", \"time_zone\": \"UTC\"\ + \ },\ + \ \"terms\": {\"fields\": [\"node\"]}\ + \ },\ + \ \"metrics\": [\ + \ {\"field\": \"temperature\", \"metrics\": [\"min\", \"max\", \"sum\"]},\ + \ {\"field\": \"voltage\", \"metrics\": [\"avg\"]}\ + \ ],\ + \ \"timeout\": \"20s\", \"page_size\": 1000\ + \ },\ + \ \"status\": {\"job_state\": \"stopped\", \"upgraded_doc_id\": true},\ + \ \"stats\": {\ + \ \"pages_processed\": 0, \"documents_processed\": 0,\ + \ \"rollups_indexed\": 0, \"trigger_count\": 0,\ + \ \"index_failures\": 0, \"index_time_in_ms\": 0, \"index_total\": 0,\ + \ \"search_failures\": 0, \"search_time_in_ms\": 0, \"search_total\": 0,\ + \ \"processing_time_in_ms\": 0, \"processing_total\": 0\ + \ }\ + \ }\ + \ ]\ + \}" + +-- | A populated @GET /_rollup/job/sensor/_stats@ response: a single +-- @job_stats@ entry with non-zero counters and a @started@ state. +sampleStatsResponseBytes :: LBS.ByteString +sampleStatsResponseBytes = + "{\ + \ \"job_stats\": [\ + \ {\ + \ \"job_id\": \"sensor\",\ + \ \"state\": {\"job_state\": \"started\", \"upgraded_doc_id\": true},\ + \ \"stats\": {\ + \ \"pages_processed\": 7, \"documents_processed\": 7000,\ + \ \"rollups_indexed\": 42, \"trigger_count\": 7,\ + \ \"index_failures\": 1, \"index_time_in_ms\": 123, \"index_total\": 43,\ + \ \"search_failures\": 0, \"search_time_in_ms\": 45, \"search_total\": 7,\ + \ \"processing_time_in_ms\": 89, \"processing_total\": 7\ + \ }\ + \ }\ + \ ]\ + \}" + +-- | The @GET /_rollup/data/sensor-*@ response, verbatim shape from the +-- . +sampleCapabilitiesResponseBytes :: LBS.ByteString +sampleCapabilitiesResponseBytes = + "{\ + \ \"sensor-*\": {\ + \ \"rollup_jobs\": [\ + \ {\ + \ \"job_id\": \"sensor\",\ + \ \"rollup_index\": \"sensor_rollup\",\ + \ \"index_pattern\": \"sensor-*\",\ + \ \"fields\": {\ + \ \"node\": [{\"agg\": \"terms\"}],\ + \ \"temperature\": [{\"agg\": \"min\"}, {\"agg\": \"max\"}, {\"agg\": \"sum\"}],\ + \ \"timestamp\": [{\"agg\": \"date_histogram\", \"time_zone\": \"UTC\", \"fixed_interval\": \"1h\", \"delay\": \"7d\"}],\ + \ \"voltage\": [{\"agg\": \"avg\"}]\ + \ }\ + \ }\ + \ ]\ + \ }\ + \}" + +spec :: Spec +spec = do + describe "RollupJobId JSON" $ do + it "round-trips as a bare JSON string" $ do + encode (RollupJobId "sensor") `shouldBe` "\"sensor\"" + decode "\"sensor\"" `shouldBe` Just (RollupJobId "sensor") + + it "rejects a non-string value" $ do + (decode "42" :: Maybe RollupJobId) `shouldBe` Nothing + + describe "RollupJobMetricAgg JSON" $ do + let table :: [(RollupJobMetricAgg, Text)] + table = + [ (RollupJobMetricAggAvg, "avg"), + (RollupJobMetricAggMax, "max"), + (RollupJobMetricAggMin, "min"), + (RollupJobMetricAggSum, "sum"), + (RollupJobMetricAggValueCount, "value_count") + ] + it "decodes the documented spellings" $ + mapM_ + ( \(agg, spelling) -> do + decode (encode agg) `shouldBe` Just agg + decode (encode spelling) `shouldBe` Just agg + ) + table + + it "encodes back to the wire spelling" $ + mapM_ + (\(agg, spelling) -> encode agg `shouldBe` encode spelling) + table + + it "absorbs an unknown metric into the Custom branch" $ do + let Just (RollupJobMetricAggCustom t) = + decode "\"cardinality\"" :: Maybe RollupJobMetricAgg + t `shouldBe` "cardinality" + + describe "RollupJobConfig JSON" $ do + it "decodes the PUT docs example" $ do + let Just decoded = decode samplePutConfigBytes :: Maybe RollupJobConfig + rjcId decoded `shouldBe` Nothing + unIndexPattern (rjcIndexPattern decoded) `shouldBe` "sensor-*" + unIndexName (rjcRollupIndex decoded) `shouldBe` "sensor_rollup" + rjcCron decoded `shouldBe` "*/30 * * * * ?" + rjcPageSize decoded `shouldBe` 1000 + rjcTimeout decoded `shouldBe` Nothing + -- @date_histogram@ is mandatory and present. + rdhgField (rgDateHistogram (rjcGroups decoded)) + `shouldBe` FieldName "timestamp" + rdhgFixedInterval (rgDateHistogram (rjcGroups decoded)) + `shouldBe` Just "1h" + rdhgTimeZone (rgDateHistogram (rjcGroups decoded)) + `shouldBe` Nothing + -- @terms@ group is present, @histogram@ is not. + rgTerms (rjcGroups decoded) `shouldSatisfy` isJust + rgHistogram (rjcGroups decoded) `shouldBe` Nothing + -- Two metrics were configured. + let Just metrics = rjcMetrics decoded + length metrics `shouldBe` 2 + rmField (NE.head metrics) `shouldBe` FieldName "temperature" + + it "decodes the GET config (server-injected id/time_zone/timeout)" $ do + let Just decoded = decode sampleGetConfigBytes :: Maybe RollupJobConfig + rjcId decoded `shouldBe` Just (RollupJobId "sensor") + rjcTimeout decoded `shouldBe` Just "20s" + rdhgTimeZone (rgDateHistogram (rjcGroups decoded)) + `shouldBe` Just "UTC" + + it "round-trips the GET config through encode . decode" $ do + let Just decoded = decode sampleGetConfigBytes :: Maybe RollupJobConfig + Just roundTripped = decode (encode decoded) :: Maybe RollupJobConfig + rjcId roundTripped `shouldBe` Just (RollupJobId "sensor") + rjcTimeout roundTripped `shouldBe` Just "20s" + rdhgTimeZone (rgDateHistogram (rjcGroups roundTripped)) + `shouldBe` Just "UTC" + + it "round-trips the PUT config without adding server-only fields" $ do + let Just decoded = decode samplePutConfigBytes :: Maybe RollupJobConfig + Just roundTripped = decode (encode decoded) :: Maybe RollupJobConfig + rjcId roundTripped `shouldBe` Nothing + rjcTimeout roundTripped `shouldBe` Nothing + rdhgTimeZone (rgDateHistogram (rjcGroups roundTripped)) + `shouldBe` Nothing + + it "preserves unknown sibling fields in extras" $ do + let bytes = + "{\ + \ \"index_pattern\": \"sensor-*\",\ + \ \"rollup_index\": \"sensor_rollup\",\ + \ \"cron\": \"*/1 * * * * ?\",\ + \ \"page_size\": 100,\ + \ \"groups\": {\"date_histogram\": {\"field\": \"timestamp\", \"fixed_interval\": \"1h\"}},\ + \ \"description\": \"sensor rollup\"\ + \}" + Just decoded = decode bytes :: Maybe RollupJobConfig + -- @description@ is unknown, so it lands in extras (and the known + -- keys are NOT duplicated there). + KM.lookup "description" (rjcExtras decoded) `shouldSatisfy` isJust + + it "accepts a bare-string terms fields list as a singleton" $ do + let bytes = + "{\ + \ \"index_pattern\": \"sensor-*\",\ + \ \"rollup_index\": \"sensor_rollup\",\ + \ \"cron\": \"*/1 * * * * ?\",\ + \ \"page_size\": 100,\ + \ \"groups\": {\ + \ \"date_histogram\": {\"field\": \"timestamp\", \"fixed_interval\": \"1h\"},\ + \ \"terms\": {\"fields\": \"node\"}\ + \ }\ + \}" + Just decoded = decode bytes :: Maybe RollupJobConfig + let Just terms = rgTerms (rjcGroups decoded) + rtgFields terms `shouldBe` (FieldName "node" :| []) + + describe "RollupJobState JSON" $ do + it "decodes the documented values" $ do + decode "\"stopped\"" `shouldBe` Just RollupJobStateStopped + decode "\"started\"" `shouldBe` Just RollupJobStateStarted + decode "\"indexing\"" `shouldBe` Just RollupJobStateIndexing + decode "\"abort\"" `shouldBe` Just RollupJobStateAbort + + it "encodes documented values back to the wire spelling" $ do + encode RollupJobStateStopped `shouldBe` "\"stopped\"" + encode RollupJobStateStarted `shouldBe` "\"started\"" + + it "absorbs an unknown state into the Custom branch" $ do + let Just (RollupJobStateCustom t) = + decode "\"retrying\"" :: Maybe RollupJobState + t `shouldBe` "retrying" + + describe "RollupJobStats JSON" $ do + it "defaults every counter to 0 on an empty object" $ do + let Just decoded = decode "{}" :: Maybe RollupJobStats + rstatPagesProcessed decoded `shouldBe` 0 + rstatDocumentsProcessed decoded `shouldBe` 0 + rstatTriggerCount decoded `shouldBe` 0 + + it "decodes the populated stats" $ do + let Just decoded = + decode + "{\ + \ \"pages_processed\": 7, \"documents_processed\": 7000,\ + \ \"rollups_indexed\": 42, \"trigger_count\": 7,\ + \ \"index_failures\": 1, \"index_time_in_ms\": 123,\ + \ \"index_total\": 43, \"search_failures\": 0,\ + \ \"search_time_in_ms\": 45, \"search_total\": 7,\ + \ \"processing_time_in_ms\": 89, \"processing_total\": 7\ + \}" :: + Maybe RollupJobStats + rstatPagesProcessed decoded `shouldBe` 7 + rstatRollupsIndexed decoded `shouldBe` 42 + rstatIndexTimeInMs decoded `shouldBe` 123 + + describe "GetRollupJobsResponse JSON" $ do + it "decodes the single-job GET response" $ do + let Just decoded = + decode sampleGetJobResponseBytes :: Maybe GetRollupJobsResponse + length (unGetRollupJobsResponse decoded) `shouldBe` 1 + let job = head (unGetRollupJobsResponse decoded) + rjsJobState (rjStatus job) `shouldBe` RollupJobStateStopped + rjsUpgradedDocId (rjStatus job) `shouldBe` Just True + rjcId (rjConfig job) `shouldBe` Just (RollupJobId "sensor") + -- All counters are zero on a freshly-created job. + rstatTriggerCount (rjStats job) `shouldBe` 0 + + it "round-trips the GET response through encode . decode" $ do + let Just decoded = + decode sampleGetJobResponseBytes :: Maybe GetRollupJobsResponse + Just roundTripped = + decode (encode decoded) :: Maybe GetRollupJobsResponse + length (unGetRollupJobsResponse roundTripped) `shouldBe` 1 + + describe "GetRollupJobStatsResponse JSON" $ do + it "decodes a populated job_stats response" $ do + let Just decoded = + decode sampleStatsResponseBytes :: Maybe GetRollupJobStatsResponse + length (unGetRollupJobStatsResponse decoded) `shouldBe` 1 + let entry = head (unGetRollupJobStatsResponse decoded) + rjseJobId entry `shouldBe` RollupJobId "sensor" + rjsJobState (rjseState entry) `shouldBe` RollupJobStateStarted + rstatPagesProcessed (rjseStats entry) `shouldBe` 7 + rstatRollupsIndexed (rjseStats entry) `shouldBe` 42 + + it "round-trips the stats response through encode . decode" $ do + let Just decoded = + decode sampleStatsResponseBytes :: Maybe GetRollupJobStatsResponse + Just roundTripped = + decode (encode decoded) :: Maybe GetRollupJobStatsResponse + length (unGetRollupJobStatsResponse roundTripped) `shouldBe` 1 + + describe "RollupCapabilitiesResponse JSON" $ do + it "decodes the get-rollup-caps response" $ do + let Just decoded = + decode sampleCapabilitiesResponseBytes :: + Maybe RollupCapabilitiesResponse + -- Keyed by the source index pattern. + let Just indexCaps = lookupRollupCapabilities "sensor-*" decoded + length (ricJobs indexCaps) `shouldBe` 1 + let jobCap = head (ricJobs indexCaps) + rjcJobId jobCap `shouldBe` RollupJobId "sensor" + unIndexName (rjcRollupIndexCap jobCap) `shouldBe` "sensor_rollup" + -- Four fields are eligible; @temperature@ supports min/max/sum. + length (rjcFields jobCap) `shouldBe` 4 + let Just tempCaps = lookup "temperature" (toList' (rjcFields jobCap)) + length tempCaps `shouldBe` 3 + rfcAgg (head tempCaps) `shouldBe` RollupCapabilityAggMin + -- @timestamp@ carries the date_histogram interval metadata. + let Just tsCaps = lookup "timestamp" (toList' (rjcFields jobCap)) + rfcFixedInterval (head tsCaps) `shouldBe` Just "1h" + rfcTimeZone (head tsCaps) `shouldBe` Just "UTC" + + it "returns Nothing for an unknown index pattern" $ do + let Just decoded = + decode sampleCapabilitiesResponseBytes :: + Maybe RollupCapabilitiesResponse + lookupRollupCapabilities "nope" decoded `shouldBe` Nothing + + it "round-trips the capabilities response through encode . decode" $ do + let Just decoded = + decode sampleCapabilitiesResponseBytes :: + Maybe RollupCapabilitiesResponse + Just roundTripped = + decode (encode decoded) :: Maybe RollupCapabilitiesResponse + lookupRollupCapabilities "sensor-*" roundTripped `shouldSatisfy` isJust + + describe "RollupCapabilityAgg JSON" $ do + it "decodes the documented agg spellings" $ do + decode "\"avg\"" `shouldBe` Just RollupCapabilityAggAvg + decode "\"terms\"" `shouldBe` Just RollupCapabilityAggTerms + decode "\"histogram\"" `shouldBe` Just RollupCapabilityAggHistogram + decode "\"date_histogram\"" + `shouldBe` Just RollupCapabilityAggDateHistogram + decode "\"value_count\"" + `shouldBe` Just RollupCapabilityAggValueCount + + it "absorbs an unknown agg into the Custom branch" $ do + let Just (RollupCapabilityAggCustom t) = + decode "\"percentiles\"" :: Maybe RollupCapabilityAgg + t `shouldBe` "percentiles" + + describe "RollupJobStarted / RollupJobStopped JSON" $ do + it "decodes {\"started\": true}" $ do + decode "{\"started\": true}" `shouldBe` Just (RollupJobStarted True) + it "decodes {\"stopped\": true}" $ do + decode "{\"stopped\": true}" `shouldBe` Just (RollupJobStopped True) + it "defaults started/stopped to True on a missing flag" $ do + decode "{}" `shouldBe` Just (RollupJobStarted True) + decode "{}" `shouldBe` Just (RollupJobStopped True) + + describe "StopRollupJobOptions params" $ do + it "default options emit no query params" $ do + stopRollupJobOptionsParams defaultStopRollupJobOptions + `shouldBe` [] + + it "emits wait_for_completion as true/false" $ do + let opts = + defaultStopRollupJobOptions + { srjoWaitForCompletion = Just True + } + stopRollupJobOptionsParams opts + `shouldBe` [("wait_for_completion", Just "true")] + + it "emits both params when both are set" $ do + let opts = + defaultStopRollupJobOptions + { srjoWaitForCompletion = Just False, + srjoTimeout = Just "10s" + } + stopRollupJobOptionsParams opts + `shouldContain` [("wait_for_completion", Just "false")] + stopRollupJobOptionsParams opts + `shouldContain` [("timeout", Just "10s")] + + describe "Endpoint shapes" $ do + it "putRollupJob is a PUT to /_rollup/job/{id} with the config body" $ do + let req = putRollupJob "sensor" (defaultRollupJobConfig (IndexPattern "sensor-*") (mkIndexName' "sensor_rollup") "*/1 * * * * ?" 100 (defaultRollupDateHistogramGroup (FieldName "timestamp") "1h")) + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_rollup", "job", "sensor"] + bhRequestBody req `shouldSatisfy` isJust + + it "getRollupJob (Nothing) lists all jobs" $ do + let req = getRollupJob Nothing + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_rollup", "job"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "getRollupJob (Just id) targets one job" $ do + let req = getRollupJob (Just "sensor") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_rollup", "job", "sensor"] + + it "deleteRollupJob is a DELETE to /_rollup/job/{id}" $ do + let req = deleteRollupJob "sensor" + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_rollup", "job", "sensor"] + bhRequestBody req `shouldBe` Nothing + + it "startRollupJob is a POST to /_rollup/job/{id}/_start with no body" $ do + let req = startRollupJob "sensor" + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_rollup", "job", "sensor", "_start"] + bhRequestBody req `shouldBe` Nothing + + it "stopRollupJob defaults to no query params" $ do + let req = stopRollupJob "sensor" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_rollup", "job", "sensor", "_stop"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "stopRollupJobWith forwards wait_for_completion and timeout" $ do + let opts = + defaultStopRollupJobOptions + { srjoWaitForCompletion = Just True, + srjoTimeout = Just "10s" + } + req = stopRollupJobWith "sensor" opts + getRawEndpointQueries (bhRequestEndpoint req) + `shouldContain` [("wait_for_completion", Just "true")] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldContain` [("timeout", Just "10s")] + + it "getRollupJobStats (Nothing) targets /_rollup/job/_stats" $ do + getRawEndpoint (bhRequestEndpoint (getRollupJobStats Nothing)) + `shouldBe` ["_rollup", "job", "_stats"] + getRawEndpoint (bhRequestEndpoint (getRollupJobStats (Just "sensor"))) + `shouldBe` ["_rollup", "job", "sensor", "_stats"] + + it "getRollupCapabilities targets /_rollup/data/{index}" $ do + getRawEndpoint + (bhRequestEndpoint (getRollupCapabilities (IndexPattern "sensor-*"))) + `shouldBe` ["_rollup", "data", "sensor-*"] + + it "getRollupIndexCapabilities targets /{target}/_rollup/data" $ do + getRawEndpoint + ( bhRequestEndpoint + (getRollupIndexCapabilities (mkIndexName' "sensor_rollup")) + ) + `shouldBe` ["sensor_rollup", "_rollup", "data"] + + it "rollupSearchByIndex is a GET to /{index}/_rollup_search with body" $ do + let req = rollupSearchByIndex (mkIndexName' "sensor_rollup") (mkSearch Nothing Nothing) :: BHRequest StatusDependant (SearchResult Value) + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["sensor_rollup", "_rollup_search"] + bhRequestBody req `shouldSatisfy` isJust + +-- | Local helpers to keep the endpoint-shape tests terse. @mkIndexName@ +-- returns 'Either' because rollup indices must satisfy the ES naming +-- rules; the test fixtures use valid names so the @Right@ is total. +mkIndexName' :: Text -> IndexName +mkIndexName' = either (error . ("bad IndexName: " <>) . show) id . mkIndexName + +-- | 'Data.Map.Strict.toList' pulled in under a short name for the +-- capabilities field-map assertions. +toList' :: MapS.Map k v -> [(k, v)] +toList' = MapS.toList diff --git a/tests/Test/RollupsSpec.hs b/tests/Test/RollupsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/RollupsSpec.hs @@ -0,0 +1,714 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.RollupsSpec (spec) where + +import Control.Monad.Catch (bracket_) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Fixed (Pico) +import Data.List (sort) +import Data.Text qualified as T +import Data.Time.Calendar (toGregorian) +import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime) +import Data.Time.LocalTime (TimeOfDay (..), timeToTimeOfDay) +import Database.Bloodhound.OpenSearch1.Client qualified as OS1Client +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch1.Types qualified as OS1Types +import Database.Bloodhound.OpenSearch2.Client qualified as OS2Client +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2Types +import Database.Bloodhound.OpenSearch3.Client qualified as OS3Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types qualified as OS3Types +import TestsUtils.Common + ( os1OnlyIT, + os2OnlyIT, + os3OnlyIT, + withTestEnv, + ) +import TestsUtils.Import +import Prelude + +-- --------------------------------------------------------------------------- +-- Sample fixtures, drawn verbatim from the OS Index Rollups plugin docs +-- (). +-- --------------------------------------------------------------------------- + +-- | A minimal create-request body wrapped in the @{"rollup": ...}@ envelope. +sampleCreateRequestJson :: LBS.ByteString +sampleCreateRequestJson = + "{\ + \ \"rollup\": {\ + \ \"source_index\": \"nyc-taxi-data\",\ + \ \"target_index\": \"rollup-nyc-taxi-data\",\ + \ \"schedule\": {\ + \ \"interval\": { \"period\": 1, \"unit\": \"Days\" }\ + \ },\ + \ \"description\": \"Example rollup job\",\ + \ \"enabled\": true,\ + \ \"page_size\": 200,\ + \ \"delay\": 0,\ + \ \"continuous\": false,\ + \ \"dimensions\": [\ + \ { \"date_histogram\": {\ + \ \"source_field\": \"tpep_pickup_datetime\",\ + \ \"fixed_interval\": \"1h\",\ + \ \"timezone\": \"America/Los_Angeles\"\ + \ } },\ + \ { \"terms\": { \"source_field\": \"PULocationID\" } }\ + \ ],\ + \ \"metrics\": [\ + \ { \"source_field\": \"passenger_count\",\ + \ \"metrics\": [ {\"avg\":{}}, {\"sum\":{}}, {\"max\":{}} ] }\ + \ ]\ + \ }\ + \}" + +-- | The PUT response envelope (snake_case @_seq_no@\/@_primary_term@). +samplePutResponseJson :: LBS.ByteString +samplePutResponseJson = + "{\ + \ \"_id\": \"example_rollup\",\ + \ \"_version\": 3,\ + \ \"_seq_no\": 1,\ + \ \"_primary_term\": 1,\ + \ \"rollup\": {\ + \ \"rollup_id\": \"example_rollup\",\ + \ \"enabled\": true,\ + \ \"schedule\": {\ + \ \"interval\": {\ + \ \"start_time\": 1680159934649,\ + \ \"period\": 1,\ + \ \"unit\": \"Days\",\ + \ \"schedule_delay\": 0\ + \ }\ + \ },\ + \ \"last_updated_time\": 1680159934649,\ + \ \"enabled_time\": 1680159934649,\ + \ \"schema_version\": 17,\ + \ \"source_index\": \"nyc-taxi-data\",\ + \ \"target_index\": \"rollup-nyc-taxi-data\",\ + \ \"metadata_id\": null,\ + \ \"page_size\": 200,\ + \ \"delay\": 0,\ + \ \"continuous\": false,\ + \ \"dimensions\": [\ + \ { \"date_histogram\": {\ + \ \"fixed_interval\": \"1h\",\ + \ \"source_field\": \"tpep_pickup_datetime\",\ + \ \"target_field\": \"tpep_pickup_datetime\",\ + \ \"timezone\": \"America/Los_Angeles\"\ + \ } },\ + \ { \"terms\": {\ + \ \"source_field\": \"PULocationID\",\ + \ \"target_field\": \"PULocationID\"\ + \ } }\ + \ ],\ + \ \"metrics\": [\ + \ { \"source_field\": \"passenger_count\",\ + \ \"metrics\": [ {\"avg\":{}}, {\"sum\":{}} ] }\ + \ ]\ + \ }\ + \}" + +-- | The GET response envelope (camelCase @_seqNo@\/@_primaryTerm@) — the +-- documented quirk that 'RollupResponse' must also decode. +sampleGetResponseJson :: LBS.ByteString +sampleGetResponseJson = + "{\ + \ \"_id\": \"example_rollup\",\ + \ \"_version\": 3,\ + \ \"_seqNo\": 1,\ + \ \"_primaryTerm\": 1,\ + \ \"rollup\": {\ + \ \"rollup_id\": \"example_rollup\",\ + \ \"enabled\": true,\ + \ \"schedule\": {\ + \ \"interval\": { \"period\": 1, \"unit\": \"Days\" }\ + \ },\ + \ \"source_index\": \"nyc-taxi-data\",\ + \ \"target_index\": \"rollup-nyc-taxi-data\",\ + \ \"page_size\": 200\ + \ }\ + \}" + +-- | The explain response when the job has not yet executed (both fields null). +sampleExplainNullJson :: LBS.ByteString +sampleExplainNullJson = + "{\ + \ \"example_rollup\": {\ + \ \"metadata_id\": null,\ + \ \"rollup_metadata\": null\ + \ }\ + \}" + +-- | The explain response after the job has executed. +sampleExplainExecutedJson :: LBS.ByteString +sampleExplainExecutedJson = + "{\ + \ \"example_rollup\": {\ + \ \"metadata_id\": \"GtWGlZwBm3bOohSSvi2r\",\ + \ \"rollup_metadata\": {\ + \ \"rollup_id\": \"example_rollup\",\ + \ \"last_updated_time\": 1772035161995,\ + \ \"status\": \"finished\",\ + \ \"failure_reason\": null,\ + \ \"stats\": {\ + \ \"pages_processed\": 2,\ + \ \"documents_processed\": 3,\ + \ \"rollups_indexed\": 3,\ + \ \"index_time_in_millis\": 28,\ + \ \"search_time_in_millis\": 46\ + \ }\ + \ }\ + \ }\ + \}" + +metricAggTable :: [(OS1Types.RollupMetricAgg, LBS.ByteString)] +metricAggTable = + [ (OS1Types.RollupMetricAvg, "{\"avg\":{}}"), + (OS1Types.RollupMetricSum, "{\"sum\":{}}"), + (OS1Types.RollupMetricMax, "{\"max\":{}}"), + (OS1Types.RollupMetricMin, "{\"min\":{}}"), + (OS1Types.RollupMetricValueCount, "{\"value_count\":{}}") + ] + +statusTable :: [(OS1Types.RollupStatus, T.Text)] +statusTable = + [ (OS1Types.RollupStatusInit, "init"), + (OS1Types.RollupStatusStarted, "started"), + (OS1Types.RollupStatusFinished, "finished"), + (OS1Types.RollupStatusFailed, "failed"), + (OS1Types.RollupStatusStopped, "stopped"), + (OS1Types.RollupStatusRetry, "retry") + ] + +intervalUnitTable :: [(OS1Types.RollupIntervalUnit, T.Text)] +intervalUnitTable = + [ (OS1Types.RollupIntervalUnitMinutes, "Minutes"), + (OS1Types.RollupIntervalUnitHours, "Hours"), + (OS1Types.RollupIntervalUnitDays, "Days"), + (OS1Types.RollupIntervalUnitWeeks, "Weeks"), + (OS1Types.RollupIntervalUnitMonths, "Months") + ] + +-- | A minimal OS1 'Rollup' for the pure endpoint-shape tests. Only the +-- required fields are populated; everything else is 'Nothing'/empty. +minimalOS1Rollup :: OS1Types.Rollup +minimalOS1Rollup = + OS1Types.Rollup + { OS1Types.rollupSourceIndex = "src", + OS1Types.rollupTargetIndex = "tgt", + OS1Types.rollupTargetIndexSettings = Nothing, + OS1Types.rollupSchedule = + OS1Types.RollupSchedule $ + OS1Types.RollupInterval + { OS1Types.rollupIntervalPeriod = Just 1, + OS1Types.rollupIntervalUnit = Just OS1Types.RollupIntervalUnitMinutes, + OS1Types.rollupIntervalStartTime = Nothing, + OS1Types.rollupIntervalScheduleDelay = Nothing, + OS1Types.rollupIntervalCron = Nothing + }, + OS1Types.rollupDescription = Nothing, + OS1Types.rollupEnabled = Nothing, + OS1Types.rollupContinuous = Nothing, + OS1Types.rollupPageSize = 100, + OS1Types.rollupDelay = Nothing, + OS1Types.rollupRoles = Nothing, + OS1Types.rollupRoutingField = Nothing, + OS1Types.rollupDimensions = [], + OS1Types.rollupMetrics = Nothing, + OS1Types.rollupErrorNotification = Nothing + } + +spec :: Spec +spec = describe "OpenSearch Index Rollups API" $ do + -- ======================================================================== + -- Pure JSON round-trip / wire-shape tests (no live cluster needed). + -- Only the OS1 Types are exercised for decoding: the three versions are + -- byte-identical (triple-duplicated), and the request-rendering parity + -- tests below pin the OS1/OS2/OS3 behavioural equivalence. + -- ======================================================================== + describe "RollupId JSON" $ do + it "encodes RollupId as a bare JSON string" $ do + encode (OS1Types.RollupId "example_rollup") + `shouldBe` "\"example_rollup\"" + it "decodes a bare JSON string into RollupId" $ do + decode "\"example_rollup\"" + `shouldBe` Just (OS1Types.RollupId "example_rollup") + it "round-trips RollupId through encode -> decode" $ do + let original = OS1Types.RollupId "round-trip-id" + (decode . encode) original `shouldBe` Just original + + describe "RollupMetricAgg JSON" $ do + it "encodes each constructor as a single-key object" $ + forM_ metricAggTable $ \(agg, expected) -> + encode agg `shouldBe` expected + it "decodes each documented single-key object back" $ + forM_ metricAggTable $ \(agg, wire) -> + decode wire `shouldBe` Just agg + it "decodes an unknown key via the Custom escape hatch" $ do + decode "{\"percentile\":{}}" + `shouldBe` Just (OS1Types.RollupMetricAggCustom "percentile") + it "rejects a multi-key object" $ + decode "{\"avg\":{},\"sum\":{}}" `shouldSatisfy` (isNothing :: Maybe OS1Types.RollupMetricAgg -> Bool) + + describe "RollupStatus JSON" $ do + it "encodes each documented status as the wire string" $ + forM_ statusTable $ \(st, wire) -> + encode st `shouldBe` encode (String wire) + it "decodes each documented status back" $ + forM_ statusTable $ \(st, wire) -> + decode (encode (String wire)) `shouldBe` Just st + it "decodes an unknown status via the Custom escape hatch" $ + decode "\"paused\"" `shouldBe` Just (OS1Types.RollupStatusCustom "paused") + + describe "RollupIntervalUnit JSON" $ do + it "encodes each documented unit as the wire string" $ + forM_ intervalUnitTable $ \(u, wire) -> + encode u `shouldBe` encode (String wire) + it "decodes each documented unit back" $ + forM_ intervalUnitTable $ \(u, wire) -> + decode (encode (String wire)) `shouldBe` Just u + + describe "RollupDimension JSON" $ do + it "encodes a date_histogram dimension as a single-key object" $ do + let dh = + OS1Types.RollupDateHistogram + { OS1Types.rollupDateHistogramSourceField = "ts", + OS1Types.rollupDateHistogramFixedInterval = Just "1h", + OS1Types.rollupDateHistogramCalendarInterval = Nothing, + OS1Types.rollupDateHistogramTimezone = Just "UTC", + OS1Types.rollupDateHistogramTargetField = Nothing + } + encode (OS1Types.RollupDimensionDateHistogram dh) + `shouldBe` encode (object ["date_histogram" .= dh]) + it "encodes a terms dimension as a single-key object" $ do + let t = OS1Types.RollupTerms {OS1Types.rollupTermsSourceField = "cat", OS1Types.rollupTermsTargetField = Nothing} + encode (OS1Types.RollupDimensionTerms t) + `shouldBe` encode (object ["terms" .= t]) + it "decodes a terms single-key object back" $ do + let t = OS1Types.RollupTerms {OS1Types.rollupTermsSourceField = "cat", OS1Types.rollupTermsTargetField = Nothing} + decode (encode (object ["terms" .= t])) + `shouldBe` Just (OS1Types.RollupDimensionTerms t) + + describe "Rollup request body (wrapper)" $ do + it "decodes the documented create-request fixture" $ do + let decoded = decode sampleCreateRequestJson :: Maybe OS1Types.RollupWrapper + decoded `shouldSatisfy` isJust + let Just (OS1Types.RollupWrapper r) = decoded + OS1Types.rollupSourceIndex r `shouldBe` "nyc-taxi-data" + OS1Types.rollupTargetIndex r `shouldBe` "rollup-nyc-taxi-data" + OS1Types.rollupPageSize r `shouldBe` 200 + length (OS1Types.rollupDimensions r) `shouldBe` 2 + it "round-trips a Rollup through encode -> decode" $ do + let Just (OS1Types.RollupWrapper r') = decode (encode (OS1Types.RollupWrapper minimalOS1Rollup)) + OS1Types.rollupSourceIndex r' `shouldBe` "src" + + describe "RollupResponse JSON (dual seq/primary casing)" $ do + it "decodes the PUT response (snake_case _seq_no/_primary_term)" $ do + let Just resp = decode samplePutResponseJson :: Maybe OS1Types.RollupResponse + OS1Types.rollupResponseId resp `shouldBe` "example_rollup" + OS1Types.rollupResponseSeqNo resp `shouldBe` Just 1 + OS1Types.rollupResponsePrimaryTerm resp `shouldBe` Just 1 + OS1Types.rollupResponseInnerSchemaVersion (OS1Types.rollupResponseRollup resp) + `shouldBe` Just 17 + it "decodes the GET response (camelCase _seqNo/_primaryTerm)" $ do + let Just resp = decode sampleGetResponseJson :: Maybe OS1Types.RollupResponse + OS1Types.rollupResponseId resp `shouldBe` "example_rollup" + OS1Types.rollupResponseSeqNo resp `shouldBe` Just 1 + OS1Types.rollupResponsePrimaryTerm resp `shouldBe` Just 1 + it "decodes a nullable metadata_id on the inner rollup" $ do + let Just resp = decode samplePutResponseJson :: Maybe OS1Types.RollupResponse + OS1Types.rollupResponseInnerMetadataId (OS1Types.rollupResponseRollup resp) + `shouldBe` Nothing + + describe "ExplainRollupResponse JSON" $ do + it "decodes the not-yet-executed shape (both fields null)" $ do + let Just resp = decode sampleExplainNullJson :: Maybe OS1Types.ExplainRollupResponse + OS1Types.explainRollupResponseLookup "example_rollup" resp `shouldSatisfy` isJust + let Just entry = OS1Types.explainRollupResponseLookup "example_rollup" resp + OS1Types.explainRollupEntryMetadataId entry `shouldBe` Nothing + OS1Types.explainRollupEntryRollupMetadata entry `shouldBe` Nothing + it "decodes the executed shape with stats and a finished status" $ do + let Just resp = decode sampleExplainExecutedJson :: Maybe OS1Types.ExplainRollupResponse + let Just entry = OS1Types.explainRollupResponseLookup "example_rollup" resp + OS1Types.explainRollupEntryMetadataId entry `shouldBe` Just "GtWGlZwBm3bOohSSvi2r" + let Just md = OS1Types.explainRollupEntryRollupMetadata entry + OS1Types.rollupMetadataStatus md `shouldBe` OS1Types.RollupStatusFinished + OS1Types.rollupMetadataFailureReason md `shouldBe` Nothing + OS1Types.rollupStatsDocumentsProcessed <$> OS1Types.rollupMetadataStats md `shouldBe` Just 3 + + -- ======================================================================== + -- Pure endpoint-shape tests (no live cluster needed). Each endpoint is + -- checked for method / path / query / body, and OS1/OS2/OS3 path parity + -- is asserted (the three modules are byte-identical; this guards against + -- refactors that silently diverge them). + -- ======================================================================== + describe "createRollup endpoint shape" $ do + let rid = OS1Types.RollupId "my_rollup" + it "PUTs to /_plugins/_rollup/jobs/{id} with no query string" $ do + let req = OS1Requests.createRollup rid minimalOS1Rollup + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_rollup", "jobs", "my_rollup"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "attaches the wrapped Rollup as the JSON body" $ do + let req = OS1Requests.createRollup rid minimalOS1Rollup + bhRequestBody req `shouldBe` Just (encode (OS1Types.RollupWrapper minimalOS1Rollup)) + + describe "createRollupWith optimistic concurrency" $ do + let rid = OS1Types.RollupId "my_rollup" + it "emits no query params when given Nothing" $ do + let req = OS1Requests.createRollupWith rid minimalOS1Rollup Nothing + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "emits if_seq_no and if_primary_term when given Just" $ do + let req = OS1Requests.createRollupWith rid minimalOS1Rollup (Just (5, 2)) + sort (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sort [("if_seq_no", Just "5"), ("if_primary_term", Just "2")] + + describe "getRollup endpoint shape" $ + it "GETs /_plugins/_rollup/jobs/{id} with no body" $ do + let req = OS1Requests.getRollup (OS1Types.RollupId "my_rollup") + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_rollup", "jobs", "my_rollup"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + describe "getAllRollups endpoint shape" $ + it "GETs /_plugins/_rollup/jobs with no body" $ do + let req = OS1Requests.getAllRollups + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_rollup", "jobs"] + bhRequestBody req `shouldBe` Nothing + + describe "deleteRollup endpoint shape" $ + it "DELETEs /_plugins/_rollup/jobs/{id} with no body" $ do + let req = OS1Requests.deleteRollup (OS1Types.RollupId "my_rollup") + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_rollup", "jobs", "my_rollup"] + bhRequestBody req `shouldBe` Nothing + + describe "startRollup endpoint shape" $ + it "POSTs /_plugins/_rollup/jobs/{id}/_start with no body" $ do + let req = OS1Requests.startRollup (OS1Types.RollupId "my_rollup") + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_rollup", "jobs", "my_rollup", "_start"] + bhRequestBody req `shouldBe` Nothing + + describe "stopRollup endpoint shape" $ + it "POSTs /_plugins/_rollup/jobs/{id}/_stop with no body" $ do + let req = OS1Requests.stopRollup (OS1Types.RollupId "my_rollup") + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_rollup", "jobs", "my_rollup", "_stop"] + bhRequestBody req `shouldBe` Nothing + + describe "explainRollup endpoint shape" $ + it "GETs /_plugins/_rollup/jobs/{id}/_explain with no body" $ do + let req = OS1Requests.explainRollup (OS1Types.RollupId "my_rollup") + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_rollup", "jobs", "my_rollup", "_explain"] + bhRequestBody req `shouldBe` Nothing + + describe "OS1/OS2/OS3 endpoint parity" $ do + let rid1 = OS1Types.RollupId "parity" + rid2 = OS2Types.RollupId "parity" + rid3 = OS3Types.RollupId "parity" + it "getRollup renders the same path across all three versions" $ do + let p1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.getRollup rid1)) + p2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.getRollup rid2)) + p3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.getRollup rid3)) + p1 `shouldBe` ["_plugins", "_rollup", "jobs", "parity"] + p1 `shouldBe` p2 + p2 `shouldBe` p3 + it "startRollup renders the same path across all three versions" $ do + let p1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.startRollup rid1)) + p2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.startRollup rid2)) + p3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.startRollup rid3)) + p1 `shouldBe` p2 + p2 `shouldBe` p3 + it "explainRollup renders the same path across all three versions" $ do + let p1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.explainRollup rid1)) + p2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.explainRollup rid2)) + p3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.explainRollup rid3)) + p1 `shouldBe` p2 + p2 `shouldBe` p3 + + -- ======================================================================== + -- Live integration tests (require the docker-compose cluster). One test + -- per backend, gated by osNOnlyIT. A timestamp-suffixed name avoids + -- collisions across runs; bracket_ guarantees the source + target + -- indices and the rollup job are torn down even on assertion failure. + -- The three versions are wire-identical, so the body is tripled (the + -- types are distinct at the Haskell level). + -- ======================================================================== + describe "Index Rollups plugin live round-trip" $ do + os1It <- runIO os1OnlyIT + os1It "create -> get -> start -> explain -> stop -> delete (OpenSearch 1)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let src = T.pack ("bloodhound_test_rollup_os1_" <> suffix <> "_src") + tgt = T.pack ("bloodhound_test_rollup_os1_" <> suffix <> "_tgt") + rid = T.pack ("bloodhound_test_rollup_os1_" <> suffix <> "_job") + Right srcIdx = mkIndexName src + bracket_ + (rollupSetupIndex srcIdx) + ( do + void $ OS1Client.deleteRollup (OS1Types.RollupId rid) + void $ performBHRequest $ deleteIndex srcIdx + ) + $ do + createResp <- OS1Client.createRollup (OS1Types.RollupId rid) (liveRollupOS1 src tgt) + liftIO $ case createResp of + Left e -> expectationFailure ("createRollup failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + getResp <- OS1Client.getRollup (OS1Types.RollupId rid) + liftIO $ assertRight "getRollup" getResp + startResp <- OS1Client.startRollup (OS1Types.RollupId rid) + liftIO $ assertRight "startRollup" startResp + explainResp <- OS1Client.explainRollup (OS1Types.RollupId rid) + liftIO $ assertRight "explainRollup" explainResp + stopResp <- OS1Client.stopRollup (OS1Types.RollupId rid) + liftIO $ assertRight "stopRollup" stopResp + os2It <- runIO os2OnlyIT + os2It "create -> get -> start -> explain -> stop -> delete (OpenSearch 2)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let src = T.pack ("bloodhound_test_rollup_os2_" <> suffix <> "_src") + tgt = T.pack ("bloodhound_test_rollup_os2_" <> suffix <> "_tgt") + rid = T.pack ("bloodhound_test_rollup_os2_" <> suffix <> "_job") + Right srcIdx = mkIndexName src + bracket_ + (rollupSetupIndex srcIdx) + ( do + void $ OS2Client.deleteRollup (OS2Types.RollupId rid) + void $ performBHRequest $ deleteIndex srcIdx + ) + $ do + createResp <- OS2Client.createRollup (OS2Types.RollupId rid) (liveRollupOS2 src tgt) + liftIO $ case createResp of + Left e -> expectationFailure ("createRollup failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + getResp <- OS2Client.getRollup (OS2Types.RollupId rid) + liftIO $ assertRight "getRollup" getResp + startResp <- OS2Client.startRollup (OS2Types.RollupId rid) + liftIO $ assertRight "startRollup" startResp + explainResp <- OS2Client.explainRollup (OS2Types.RollupId rid) + liftIO $ assertRight "explainRollup" explainResp + stopResp <- OS2Client.stopRollup (OS2Types.RollupId rid) + liftIO $ assertRight "stopRollup" stopResp + os3It <- runIO os3OnlyIT + os3It "create -> get -> start -> explain -> stop -> delete (OpenSearch 3)" $ + withTestEnv $ do + suffix <- liftIO $ show @Int . floor <$> getPOSIXTime + let src = T.pack ("bloodhound_test_rollup_os3_" <> suffix <> "_src") + tgt = T.pack ("bloodhound_test_rollup_os3_" <> suffix <> "_tgt") + rid = T.pack ("bloodhound_test_rollup_os3_" <> suffix <> "_job") + Right srcIdx = mkIndexName src + bracket_ + (rollupSetupIndex srcIdx) + ( do + void $ OS3Client.deleteRollup (OS3Types.RollupId rid) + void $ performBHRequest $ deleteIndex srcIdx + ) + $ do + createResp <- OS3Client.createRollup (OS3Types.RollupId rid) (liveRollupOS3 src tgt) + liftIO $ case createResp of + Left e -> expectationFailure ("createRollup failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + getResp <- OS3Client.getRollup (OS3Types.RollupId rid) + liftIO $ assertRight "getRollup" getResp + startResp <- OS3Client.startRollup (OS3Types.RollupId rid) + liftIO $ assertRight "startRollup" startResp + explainResp <- OS3Client.explainRollup (OS3Types.RollupId rid) + liftIO $ assertRight "explainRollup" explainResp + stopResp <- OS3Client.stopRollup (OS3Types.RollupId rid) + liftIO $ assertRight "stopRollup" stopResp + +-- | Build a typed OS1 'Rollup' for the live tests. +liveRollupOS1 :: T.Text -> T.Text -> OS1Types.Rollup +liveRollupOS1 src tgt = + OS1Types.Rollup + { OS1Types.rollupSourceIndex = src, + OS1Types.rollupTargetIndex = tgt, + OS1Types.rollupTargetIndexSettings = Nothing, + OS1Types.rollupSchedule = + OS1Types.RollupSchedule $ + OS1Types.RollupInterval + { OS1Types.rollupIntervalPeriod = Just 1, + OS1Types.rollupIntervalUnit = Just OS1Types.RollupIntervalUnitMinutes, + OS1Types.rollupIntervalStartTime = Nothing, + OS1Types.rollupIntervalScheduleDelay = Nothing, + OS1Types.rollupIntervalCron = Nothing + }, + OS1Types.rollupDescription = Just "bloodhound live test", + OS1Types.rollupEnabled = Just True, + OS1Types.rollupContinuous = Just False, + OS1Types.rollupPageSize = 200, + OS1Types.rollupDelay = Nothing, + OS1Types.rollupRoles = Nothing, + OS1Types.rollupRoutingField = Nothing, + OS1Types.rollupDimensions = + [ OS1Types.RollupDimensionDateHistogram $ + OS1Types.RollupDateHistogram + { OS1Types.rollupDateHistogramSourceField = "timestamp", + OS1Types.rollupDateHistogramFixedInterval = Just "1m", + OS1Types.rollupDateHistogramCalendarInterval = Nothing, + OS1Types.rollupDateHistogramTimezone = Just "UTC", + OS1Types.rollupDateHistogramTargetField = Nothing + } + ], + OS1Types.rollupMetrics = + Just + [ OS1Types.RollupMetric + { OS1Types.rollupMetricSourceField = "value", + OS1Types.rollupMetricMetrics = [OS1Types.RollupMetricAvg, OS1Types.RollupMetricSum] + } + ], + OS1Types.rollupErrorNotification = Nothing + } + +-- | Build a typed OS2 'Rollup' for the live tests. +liveRollupOS2 :: T.Text -> T.Text -> OS2Types.Rollup +liveRollupOS2 src tgt = + OS2Types.Rollup + { OS2Types.rollupSourceIndex = src, + OS2Types.rollupTargetIndex = tgt, + OS2Types.rollupTargetIndexSettings = Nothing, + OS2Types.rollupSchedule = + OS2Types.RollupSchedule $ + OS2Types.RollupInterval + { OS2Types.rollupIntervalPeriod = Just 1, + OS2Types.rollupIntervalUnit = Just OS2Types.RollupIntervalUnitMinutes, + OS2Types.rollupIntervalStartTime = Nothing, + OS2Types.rollupIntervalScheduleDelay = Nothing, + OS2Types.rollupIntervalCron = Nothing + }, + OS2Types.rollupDescription = Just "bloodhound live test", + OS2Types.rollupEnabled = Just True, + OS2Types.rollupContinuous = Just False, + OS2Types.rollupPageSize = 200, + OS2Types.rollupDelay = Nothing, + OS2Types.rollupRoles = Nothing, + OS2Types.rollupRoutingField = Nothing, + OS2Types.rollupDimensions = + [ OS2Types.RollupDimensionDateHistogram $ + OS2Types.RollupDateHistogram + { OS2Types.rollupDateHistogramSourceField = "timestamp", + OS2Types.rollupDateHistogramFixedInterval = Just "1m", + OS2Types.rollupDateHistogramCalendarInterval = Nothing, + OS2Types.rollupDateHistogramTimezone = Just "UTC", + OS2Types.rollupDateHistogramTargetField = Nothing + } + ], + OS2Types.rollupMetrics = + Just + [ OS2Types.RollupMetric + { OS2Types.rollupMetricSourceField = "value", + OS2Types.rollupMetricMetrics = [OS2Types.RollupMetricAvg, OS2Types.RollupMetricSum] + } + ], + OS2Types.rollupErrorNotification = Nothing + } + +-- | Build a typed OS3 'Rollup' for the live tests. +liveRollupOS3 :: T.Text -> T.Text -> OS3Types.Rollup +liveRollupOS3 src tgt = + OS3Types.Rollup + { OS3Types.rollupSourceIndex = src, + OS3Types.rollupTargetIndex = tgt, + OS3Types.rollupTargetIndexSettings = Nothing, + OS3Types.rollupSchedule = + OS3Types.RollupSchedule $ + OS3Types.RollupInterval + { OS3Types.rollupIntervalPeriod = Just 1, + OS3Types.rollupIntervalUnit = Just OS3Types.RollupIntervalUnitMinutes, + OS3Types.rollupIntervalStartTime = Nothing, + OS3Types.rollupIntervalScheduleDelay = Nothing, + OS3Types.rollupIntervalCron = Nothing + }, + OS3Types.rollupDescription = Just "bloodhound live test", + OS3Types.rollupEnabled = Just True, + OS3Types.rollupContinuous = Just False, + OS3Types.rollupPageSize = 200, + OS3Types.rollupDelay = Nothing, + OS3Types.rollupRoles = Nothing, + OS3Types.rollupRoutingField = Nothing, + OS3Types.rollupDimensions = + [ OS3Types.RollupDimensionDateHistogram $ + OS3Types.RollupDateHistogram + { OS3Types.rollupDateHistogramSourceField = "timestamp", + OS3Types.rollupDateHistogramFixedInterval = Just "1m", + OS3Types.rollupDateHistogramCalendarInterval = Nothing, + OS3Types.rollupDateHistogramTimezone = Just "UTC", + OS3Types.rollupDateHistogramTargetField = Nothing + } + ], + OS3Types.rollupMetrics = + Just + [ OS3Types.RollupMetric + { OS3Types.rollupMetricSourceField = "value", + OS3Types.rollupMetricMetrics = [OS3Types.RollupMetricAvg, OS3Types.RollupMetricSum] + } + ], + OS3Types.rollupErrorNotification = Nothing + } + +-- | Create the source index with one document. The @timestamp@ field +-- auto-maps to @date@ from the ISO-8601 string; @value@ auto-maps to a +-- numeric type. No explicit mapping is needed. +rollupSetupIndex :: IndexName -> BH IO () +rollupSetupIndex indexName = do + _ <- + performBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + indexName + nowMs <- liftIO $ round . (* 1000) <$> getPOSIXTime :: BH IO Integer + let ts = nowMs - 60000 + iso = T.pack (iso8601FromEpochMs ts) + _ <- + performBHRequest $ + indexDocument + indexName + defaultIndexDocumentSettings + (object ["timestamp" .= String iso, "value" .= Number 42]) + (DocId "1") + _ <- performBHRequest $ refreshIndex indexName + pure () + +-- | Assert a 'ParsedEsResponse' is 'Right', failing with the plugin +-- error message otherwise. +assertRight :: T.Text -> Either EsError a -> IO () +assertRight label r = + case r of + Left e -> + expectationFailure (T.unpack label <> " failed: " <> T.unpack (errorMessage e)) + Right _ -> pure () + +-- | Render epoch-ms as an ISO-8601 UTC string (mirrors the AD spec helper). +iso8601FromEpochMs :: Integer -> String +iso8601FromEpochMs ms = + let secs = ms `div` 1000 + UTCTime day secsOfDay = posixSecondsToUTCTime (fromIntegral secs) + (y, m, d) = toGregorian day + TimeOfDay hh mm ss = timeToTimeOfDay secsOfDay + pad2 n = let s = show n in if length s == 1 then "0" <> s else s + pad4 n = let s = show n in replicate (max 0 (4 - length s)) '0' <> s + in pad4 (fromIntegral y) + <> "-" + <> pad2 m + <> "-" + <> pad2 d + <> "T" + <> pad2 hh + <> ":" + <> pad2 mm + <> ":" + <> pad2 (floor @Pico ss) diff --git a/tests/Test/SLMSpec.hs b/tests/Test/SLMSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SLMSpec.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SLMSpec (spec) where + +import Data.Aeson +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Import +import Prelude + +samplePutBodyBytes :: LBS.ByteString +samplePutBodyBytes = + "{\ + \ \"schedule\": \"0 30 1 * * ?\",\ + \ \"name\": \"\",\ + \ \"repository\": \"my-repo\",\ + \ \"config\": {\ + \ \"ignore_unavailable\": false,\ + \ \"include_global_state\": false,\ + \ \"indices\": [\"data-*\", \"important\"],\ + \ \"partial\": false\ + \ },\ + \ \"retention\": {\ + \ \"expire_after\": \"30d\",\ + \ \"min_count\": 5,\ + \ \"max_count\": 50\ + \ }\ + \}" + +-- | Minimal @GET /_slm/policy@ response: outer object keyed by policy id, +-- each value carrying the @version@ / @modified_date@ / @policy@ fields. +sampleListResponseBytes :: LBS.ByteString +sampleListResponseBytes = + "{\ + \ \"nightly-snapshots\": {\ + \ \"version\": 7,\ + \ \"modified_date\": 1716940800000,\ + \ \"modified_date_string\": \"Wed May 28 20:00:00 UTC 2024\",\ + \ \"policy\": {\ + \ \"schedule\": \"0 30 1 * * ?\",\ + \ \"name\": \"\",\ + \ \"repository\": \"my-repo\",\ + \ \"retention\": {\"expire_after\": \"30d\", \"min_count\": 5, \"max_count\": 50}\ + \ }\ + \ }\ + \}" + +-- | Same policy but with @modified_date@ as an ISO-8601 string (ES 7.17+ +-- shape — drops the @*_string@ sibling). +sampleListResponseDateStringBytes :: LBS.ByteString +sampleListResponseDateStringBytes = + "{\ + \ \"nightly-snapshots\": {\ + \ \"version\": 12,\ + \ \"modified_date\": \"2024-05-29T13:37:00.000Z\",\ + \ \"policy\": {\ + \ \"schedule\": \"0 30 1 * * ?\",\ + \ \"name\": \"\",\ + \ \"repository\": \"my-repo\"\ + \ }\ + \ }\ + \}" + +spec :: Spec +spec = describe "Snapshot Lifecycle Management (SLM) API" $ do + describe "SLMPolicyId JSON" $ do + it "round-trips as a bare JSON string" $ do + let Just decoded = decode "\"my-policy\"" :: Maybe SLMPolicyId + unSLMPolicyId decoded `shouldBe` "my-policy" + encode (SLMPolicyId "my-policy") `shouldBe` "\"my-policy\"" + + it "rejects a non-string value" $ do + let decoded = decode "42" :: Maybe SLMPolicyId + decoded `shouldBe` Nothing + + describe "SLMPolicy JSON (PUT body)" $ do + it "encodes the carried Value verbatim (no 'policy' wrapping)" $ do + let body = object ["schedule" .= String "0 0 1 * * ?"] + encoded = encode (SLMPolicy body) + encoded `shouldBe` "{\"schedule\":\"0 0 1 * * ?\"}" + + it "decodes an object body verbatim" $ do + let Just decoded = decode samplePutBodyBytes :: Maybe SLMPolicy + Just expected = decode samplePutBodyBytes :: Maybe Value + unSLMPolicy decoded `shouldBe` expected + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode samplePutBodyBytes :: Maybe SLMPolicy + (decode . encode) decoded `shouldBe` Just decoded + + it "rejects a non-object body (array)" $ do + let decoded = decode "[1,2,3]" :: Maybe SLMPolicy + decoded `shouldBe` Nothing + + it "rejects a non-object body (bare number)" $ do + let decoded = decode "5" :: Maybe SLMPolicy + decoded `shouldBe` Nothing + + it "rejects invalid JSON" $ do + let decoded = decode "{ this is not json" :: Maybe SLMPolicy + decoded `shouldBe` Nothing + + describe "SLMPolicyInfo JSON" $ do + it "round-trips via the SLMPolicies wrapper (id preserved from key)" $ do + let Just decoded = decode sampleListResponseBytes :: Maybe SLMPolicies + infos = unSLMPolicies decoded + length infos `shouldBe` 1 + let info = head infos + slmPolicyInfoId info `shouldBe` SLMPolicyId "nightly-snapshots" + slmPolicyInfoVersion info `shouldBe` Just 7 + slmPolicyInfoModifiedDate info `shouldBe` Just 1716940800000 + slmPolicyInfoModifiedDateString info `shouldBe` Just "Wed May 28 20:00:00 UTC 2024" + + it "parses the modified_date-as-ISO-8601-string shape (ES 7.17+)" $ do + let Just decoded = decode sampleListResponseDateStringBytes :: Maybe SLMPolicies + info = head (unSLMPolicies decoded) + slmPolicyInfoModifiedDate info `shouldBe` Nothing + slmPolicyInfoModifiedDateString info `shouldBe` Just "2024-05-29T13:37:00.000Z" + + it "stamps a placeholder id when decoded standalone (overridden by SLMPolicies)" $ do + let body = + object + [ "version" .= (7 :: Int), + "policy" .= object ["schedule" .= String "0 30 1 * * ?"] + ] + Just decoded = decode (encode body) :: Maybe SLMPolicyInfo + slmPolicyInfoId decoded `shouldBe` SLMPolicyId "" + + it "standalone round-trip is stable (ToJSON does not emit the id)" $ do + let body = + object + [ "version" .= (3 :: Int), + "policy" .= object ["schedule" .= String "x"] + ] + Just decoded = decode (encode body) :: Maybe SLMPolicyInfo + reencoded = encode decoded + Just decodedAgain = decode reencoded :: Maybe SLMPolicyInfo + decodedAgain `shouldBe` decoded + -- The placeholder id survives the cycle; the body has no "id" key + -- because 'ToJSON' deliberately does not emit 'slmPolicyInfoId'. + slmPolicyInfoId decodedAgain `shouldBe` SLMPolicyId "" + + it "tolerates unknown sibling fields (forward-compatible)" $ do + let bytes = + encode + ( object + [ "version" .= (1 :: Int), + "policy" .= object ["schedule" .= String "x"], + "stats" .= object ["runs" .= (3 :: Int)] + ] + ) + Just decoded = decode bytes :: Maybe SLMPolicyInfo + slmPolicyInfoVersion decoded `shouldBe` Just 1 + + it "rejects an object missing the 'policy' field" $ do + let bytes = encode (object ["version" .= (1 :: Int)]) + decoded = decode bytes :: Maybe SLMPolicyInfo + decoded `shouldBe` Nothing + + it "tolerates missing optional fields" $ do + let body = object ["policy" .= object []] + Just decoded = decode (encode body) :: Maybe SLMPolicyInfo + slmPolicyInfoVersion decoded `shouldBe` Nothing + slmPolicyInfoModifiedDate decoded `shouldBe` Nothing + slmPolicyInfoModifiedDateString decoded `shouldBe` Nothing + + describe "SLMPolicies JSON" $ do + it "round-trips a multi-policy response preserving ids" $ do + let multi = + object + [ "policy-a" + .= object + [ "version" .= (1 :: Int), + "policy" .= object ["schedule" .= String "a"] + ], + "policy-b" + .= object + [ "version" .= (2 :: Int), + "policy" .= object ["schedule" .= String "b"] + ] + ] + Just decoded = decode (encode multi) :: Maybe SLMPolicies + length (unSLMPolicies decoded) `shouldBe` 2 + map (unSLMPolicyId . slmPolicyInfoId) (unSLMPolicies decoded) + `shouldMatchList` ["policy-a", "policy-b"] + (decode . encode) decoded `shouldBe` Just decoded + + it "decodes an empty policy object as an empty list" $ do + let Just decoded = decode "{}" :: Maybe SLMPolicies + unSLMPolicies decoded `shouldBe` [] + + it "rejects a non-object response (array)" $ do + let decoded = decode "[]" :: Maybe SLMPolicies + decoded `shouldBe` Nothing + + describe "SLMExecutionResult JSON" $ do + it "decodes {\"snapshot_name\": \"...\"} into a SnapshotName" $ do + let Just decoded = decode "{\"snapshot_name\":\"\"}" :: Maybe SLMExecutionResult + slmExecutionSnapshot decoded `shouldBe` SnapshotName "" + + it "round-trips through ToJSON/FromJSON" $ do + let result = SLMExecutionResult (SnapshotName "snap-1") + (decode . encode) result `shouldBe` Just result + + it "rejects an object missing 'snapshot_name'" $ do + let decoded = decode "{\"acknowledged\":true}" :: Maybe SLMExecutionResult + decoded `shouldBe` Nothing + + it "rejects a non-object body" $ do + let decoded = decode "\"just-a-string\"" :: Maybe SLMExecutionResult + decoded `shouldBe` Nothing + + describe "SLMOperationMode JSON" $ do + it "round-trips all three documented modes" $ do + encode SLMOperationModeRunning `shouldBe` "\"RUNNING\"" + encode SLMOperationModeStopping `shouldBe` "\"STOPPING\"" + encode SLMOperationModeStopped `shouldBe` "\"STOPPED\"" + decode "\"RUNNING\"" `shouldBe` Just SLMOperationModeRunning + decode "\"STOPPING\"" `shouldBe` Just SLMOperationModeStopping + decode "\"STOPPED\"" `shouldBe` Just SLMOperationModeStopped + + it "rejects an unknown mode" $ do + let decoded = decode "\"PAUSED\"" :: Maybe SLMOperationMode + decoded `shouldBe` Nothing + + it "rejects a non-string value" $ do + let decoded = decode "42" :: Maybe SLMOperationMode + decoded `shouldBe` Nothing + + describe "SLMStatus JSON" $ do + it "decodes a full status response with all fields" $ do + let bytes = + "{\ + \ \"operation_mode\": \"RUNNING\",\ + \ \"snapshot_deletion_count\": 3,\ + \ \"snapshot_creation_count\": 42\ + \}" + Just decoded = decode bytes :: Maybe SLMStatus + slmStatusOperationMode decoded `shouldBe` SLMOperationModeRunning + slmStatusSnapshotCreationCount decoded `shouldBe` Just 42 + slmStatusSnapshotDeletionCount decoded `shouldBe` Just 3 + + it "decodes a status response with only operation_mode (older ES)" $ do + let Just decoded = decode "{\"operation_mode\":\"STOPPED\"}" :: Maybe SLMStatus + slmStatusOperationMode decoded `shouldBe` SLMOperationModeStopped + slmStatusSnapshotCreationCount decoded `shouldBe` Nothing + slmStatusSnapshotDeletionCount decoded `shouldBe` Nothing + + it "tolerates unknown forward-compatible fields" $ do + let bytes = + "{\ + \ \"operation_mode\": \"STOPPING\",\ + \ \"retention_runs\": 7,\ + \ \"policy_protection_indicator\": {\"enabled\": true}\ + \}" + Just decoded = decode bytes :: Maybe SLMStatus + slmStatusOperationMode decoded `shouldBe` SLMOperationModeStopping + + it "rejects a status response missing operation_mode" $ do + let decoded = decode "{\"snapshot_creation_count\":1}" :: Maybe SLMStatus + decoded `shouldBe` Nothing + + it "round-trips through ToJSON/FromJSON" $ do + let status = SLMStatus {slmStatusOperationMode = SLMOperationModeRunning, slmStatusSnapshotCreationCount = Just 5, slmStatusSnapshotDeletionCount = Nothing} + (decode . encode) status `shouldBe` Just status + + describe "putSLMPolicy endpoint shape" $ do + let body = SLMPolicy (object ["schedule" .= String "0 0 1 * * ?"]) + req = Common.putSLMPolicy (SLMPolicyId "my-policy") body + + it "PUTs /_slm/policy/{id}" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "policy", "my-policy"] + + it "uses the PUT method" $ do + bhRequestMethod req `shouldBe` "PUT" + + it "attaches the encoded policy as the request body" $ do + bhRequestBody req `shouldBe` Just (encode body) + + it "carries no query string" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses a distinct id in the path when given a different SLMPolicyId" $ do + let req' = Common.putSLMPolicy (SLMPolicyId "other") body + getRawEndpoint (bhRequestEndpoint req') `shouldBe` ["_slm", "policy", "other"] + + describe "getSLMPolicy endpoint shape" $ do + it "GETs /_slm/policy when given Nothing" $ do + let req = Common.getSLMPolicy Nothing + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "policy"] + + it "GETs /_slm/policy/{id} when given a Just id" $ do + let req = Common.getSLMPolicy (Just (SLMPolicyId "nightly")) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "policy", "nightly"] + + it "uses the GET method" $ do + let req = Common.getSLMPolicy Nothing + bhRequestMethod req `shouldBe` "GET" + + it "carries no request body" $ do + let req = Common.getSLMPolicy Nothing + bhRequestBody req `shouldBe` Nothing + + it "carries no query string for either variant" $ do + let reqAll = Common.getSLMPolicy Nothing + reqOne = Common.getSLMPolicy (Just (SLMPolicyId "x")) + getRawEndpointQueries (bhRequestEndpoint reqAll) `shouldBe` [] + getRawEndpointQueries (bhRequestEndpoint reqOne) `shouldBe` [] + + describe "deleteSLMPolicy endpoint shape" $ do + let req = Common.deleteSLMPolicy (SLMPolicyId "stale") + + it "DELETEs /_slm/policy/{id}" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "policy", "stale"] + + it "uses the DELETE method" $ do + bhRequestMethod req `shouldBe` "DELETE" + + it "carries no request body" $ do + bhRequestBody req `shouldBe` Nothing + + it "carries no query string" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "substitutes the id into the path" $ do + let req' = Common.deleteSLMPolicy (SLMPolicyId "other") + getRawEndpoint (bhRequestEndpoint req') `shouldBe` ["_slm", "policy", "other"] + + describe "executeSLMPolicy endpoint shape" $ do + let req = Common.executeSLMPolicy (SLMPolicyId "nightly") + + it "POSTs /_slm/execute/{id}" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "execute", "nightly"] + + it "uses the POST method" $ do + bhRequestMethod req `shouldBe` "POST" + + it "sends an empty body" $ do + bhRequestBody req `shouldBe` Just "" + + it "carries no query string" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "substitutes the id into the path" $ do + let req' = Common.executeSLMPolicy (SLMPolicyId "hourly") + getRawEndpoint (bhRequestEndpoint req') `shouldBe` ["_slm", "execute", "hourly"] + + describe "getSLMStatus endpoint shape" $ do + let req = Common.getSLMStatus + + it "GETs /_slm/status" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "status"] + + it "uses the GET method" $ do + bhRequestMethod req `shouldBe` "GET" + + it "carries no request body" $ do + bhRequestBody req `shouldBe` Nothing + + it "carries no query string" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "stopSLM endpoint shape" $ do + let req = Common.stopSLM + + it "POSTs /_slm/stop" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "stop"] + + it "uses the POST method" $ do + bhRequestMethod req `shouldBe` "POST" + + it "sends an empty body" $ do + bhRequestBody req `shouldBe` Just "" + + it "carries no query string" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "startSLM endpoint shape" $ do + let req = Common.startSLM + + it "POSTs /_slm/start" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_slm", "start"] + + it "uses the POST method" $ do + bhRequestMethod req `shouldBe` "POST" + + it "sends an empty body" $ do + bhRequestBody req `shouldBe` Just "" + + it "carries no query string" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] diff --git a/tests/Test/SQLPPLSpec.hs b/tests/Test/SQLPPLSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SQLPPLSpec.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SQLPPLSpec (spec) where + +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List qualified as L +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch1.Types qualified as OS1Types +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2Types +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- --------------------------------------------------------------------------- +-- Sample bodies, drawn verbatim from the OS SQL and PPL API documentation +-- (). +-- --------------------------------------------------------------------------- + +-- | A representative first-page response from @POST /_plugins/_sql@, with +-- every field populated. Truncated @schema@ for brevity; the wire shape is +-- what matters. +sampleFirstPage :: LBS.ByteString +sampleFirstPage = + "{\ + \ \"schema\": [\ + \ {\"name\": \"firstname\", \"type\": \"text\"},\ + \ {\"name\": \"lastname\", \"type\": \"text\"}\ + \ ],\ + \ \"datarows\": [\ + \ [\"Cherry\", \"Carey\"],\ + \ [\"Lindsey\", \"Hawkins\"]\ + \ ],\ + \ \"total\": 956,\ + \ \"size\": 2,\ + \ \"status\": 200\ + \}" + +-- | A paginated first-page response with @fetch_size@ set: carries a +-- 'sqlResultCursor' in addition to the standard fields. +samplePaginatedFirstPage :: LBS.ByteString +samplePaginatedFirstPage = + "{\ + \ \"schema\": [{\"name\": \"firstname\", \"type\": \"text\"}],\ + \ \"cursor\": \"d:eyJhIjp7fSwicyI6IkRYRjFaWEo1UVc1a1JtVjBZMmdCQUFBQUFBQUFBQU1XZWpkdFRFRkZUMlpTZEZkeFdsWnJkRlZoYnpaeVVRPT0iLCJjIjpbeyJuYW1lIjoiZmlyc3RuYW1lIiwidHlwZSI6InRleHQifV0sImYiOjUsImkiOiJhY2NvdW50cyIsImwiOjk1MX0\",\ + \ \"total\": 956,\ + \ \"datarows\": [[\"Cherry\"], [\"Lindsey\"], [\"Sargent\"], [\"Campos\"], [\"Savannah\"]],\ + \ \"size\": 5,\ + \ \"status\": 200\ + \}" + +-- | A continuation response (cursor followed up via 'sqlQueryNextPage'). +-- Per the plugin spec, only @datarows@ and a new @cursor@ are present. +sampleContinuationPage :: LBS.ByteString +sampleContinuationPage = + "{\ + \ \"cursor\": \"d:eyJhIjp7fSwicyI6IkRYRjFaWEo1UVc1a1JtVjBZMmdCQUFBQUFBQUFBQU1XZWpkdFRFRkZUMlpTZEZkeFdsWnJkRlZoYnpaeVVRPT0iLCJjIjpbeyJuYW1lIjoiZmlyc3RuYW1lIiwidHlwZSI6InRleHQifV0sImYiOjUsImkiOiJhY2NvdW50cyIsImwiOjk1MX0abcde12345\",\ + \ \"datarows\": [[\"Abbey\"], [\"Chen\"], [\"Ani\"], [\"Peng\"], [\"John\"]]\ + \}" + +-- | The final continuation page: no @cursor@ because the server-side +-- context has been released automatically. +sampleFinalPage :: LBS.ByteString +sampleFinalPage = + "{\ + \ \"datarows\": [[\"Eve\"], [\"Mallory\"]\ + \ ]\ + \}" + +-- | A @POST /_plugins/_sql/close@ success response. +sampleCloseSuccess :: LBS.ByteString +sampleCloseSuccess = "{\"succeeded\":true}" + +sampleCloseFailure :: LBS.ByteString +sampleCloseFailure = "{\"succeeded\":false}" + +spec :: Spec +spec = describe "SQL & PPL plugin" $ do + describe "SQLColumn JSON" $ do + it "round-trips a name/type pair" $ do + let col = SQLColumn "firstname" "text" + decode (encode col) `shouldBe` Just col + + it "decodes the documented schema shape" $ do + let Just (decoded :: SQLColumn) = decode "{\"name\":\"age\",\"type\":\"long\"}" + sqlColumnName decoded `shouldBe` "age" + sqlColumnType decoded `shouldBe` "long" + + it "requires both fields" $ do + decode "{\"name\":\"x\"}" `shouldBe` (Nothing :: Maybe SQLColumn) + decode "{\"type\":\"x\"}" `shouldBe` (Nothing :: Maybe SQLColumn) + + describe "SQLCursor JSON" $ do + it "round-trips as a bare JSON string" $ do + let cur = SQLCursor "d:abc123" + encode cur `shouldBe` "\"d:abc123\"" + decode "\"d:abc123\"" `shouldBe` Just cur + + it "rejects a JSON object" $ do + decode "{}" `shouldBe` (Nothing :: Maybe SQLCursor) + + it "rejects a JSON array" $ do + decode "[]" `shouldBe` (Nothing :: Maybe SQLCursor) + + describe "SQLParameter JSON" $ do + it "round-trips a typed bind variable" $ do + let p = SQLParameter "integer" (toJSON (30 :: Int)) + decode (encode p) `shouldBe` Just p + + it "decodes the documented prepared-statement shape" $ do + let Just (decoded :: SQLParameter) = + decode "{\"type\":\"integer\",\"value\":30}" + sqlParameterType decoded `shouldBe` "integer" + sqlParameterValue decoded `shouldBe` toJSON (30 :: Int) + + it "requires both fields" $ do + decode "{\"type\":\"integer\"}" + `shouldBe` (Nothing :: Maybe SQLParameter) + + describe "SQLCursorRequest JSON" $ do + it "encodes as a single-key {\"cursor\": ...} object" $ do + let req = SQLCursorRequest (SQLCursor "d:xyz") + encoded = LBS.toStrict (encode req) + encoded `shouldBe` "{\"cursor\":\"d:xyz\"}" + + it "round-trips" $ do + let req = SQLCursorRequest (SQLCursor "d:xyz") + decode (encode req) `shouldBe` Just req + + it "rejects a body without cursor" $ do + decode "{\"query\":\"SELECT 1\"}" + `shouldBe` (Nothing :: Maybe SQLCursorRequest) + + describe "SQLCloseResult JSON" $ do + it "decodes the documented success body" $ do + let Just decoded = decode sampleCloseSuccess :: Maybe SQLCloseResult + sqlCloseResultSucceeded decoded `shouldBe` True + + it "decodes a failure body" $ do + let Just decoded = decode sampleCloseFailure :: Maybe SQLCloseResult + sqlCloseResultSucceeded decoded `shouldBe` False + + it "round-trips the success case" $ do + let Just decoded = decode sampleCloseSuccess :: Maybe SQLCloseResult + decode (encode decoded) `shouldBe` Just decoded + + it "requires the succeeded field" $ do + decode "{}" `shouldBe` (Nothing :: Maybe SQLCloseResult) + + describe "SQLResult JSON" $ do + it "decodes a full first-page response" $ do + let Just decoded = decode sampleFirstPage :: Maybe SQLResult + sqlResultSchema decoded + `shouldBe` Just [SQLColumn "firstname" "text", SQLColumn "lastname" "text"] + length (sqlResultDatarows decoded) `shouldBe` 2 + sqlResultTotal decoded `shouldBe` Just 956 + sqlResultSize decoded `shouldBe` Just 2 + sqlResultStatus decoded `shouldBe` Just 200 + sqlResultCursor decoded `shouldBe` Nothing + + it "decodes a paginated first-page response carrying a cursor" $ do + let Just decoded = decode samplePaginatedFirstPage :: Maybe SQLResult + sqlResultCursor decoded + `shouldBe` Just + ( SQLCursor + "d:eyJhIjp7fSwicyI6IkRYRjFaWEo1UVc1a1JtVjBZMmdCQUFBQUFBQUFBQU1XZWpkdFRFRkZUMlpTZEZkeFdsWnJkRlZoYnpaeVVRPT0iLCJjIjpbeyJuYW1lIjoiZmlyc3RuYW1lIiwidHlwZSI6InRleHQifV0sImYiOjUsImkiOiJhY2NvdW50cyIsImwiOjk1MX0" + ) + length (sqlResultDatarows decoded) `shouldBe` 5 + + it "decodes a continuation page that drops schema/total/size/status" $ do + let Just decoded = decode sampleContinuationPage :: Maybe SQLResult + sqlResultSchema decoded `shouldBe` Nothing + sqlResultTotal decoded `shouldBe` Nothing + sqlResultSize decoded `shouldBe` Nothing + sqlResultStatus decoded `shouldBe` Nothing + length (sqlResultDatarows decoded) `shouldBe` 5 + sqlResultCursor decoded `shouldSatisfy` isJust + + it "decodes a final page with no cursor" $ do + let Just decoded = decode sampleFinalPage :: Maybe SQLResult + sqlResultCursor decoded `shouldBe` Nothing + length (sqlResultDatarows decoded) `shouldBe` 2 + + it "tolerates unknown fields (forward compatibility)" $ do + let Just decoded = + decode + "{\"datarows\":[],\"future_field\":42}" :: + Maybe SQLResult + sqlResultDatarows decoded `shouldBe` [] + + it "requires the datarows field" $ do + decode "{\"schema\":[],\"total\":0}" + `shouldBe` (Nothing :: Maybe SQLResult) + + it "rejects a top-level array" $ do + decode "[]" `shouldBe` (Nothing :: Maybe SQLResult) + + it "rejects malformed JSON" $ do + decode "{ not json" `shouldBe` (Nothing :: Maybe SQLResult) + + it "round-trips a full first-page body through ToJSON/FromJSON" $ do + let Just decoded = decode sampleFirstPage :: Maybe SQLResult + (decode . encode) decoded `shouldBe` Just decoded + + it "round-trips a continuation page through ToJSON/FromJSON" $ do + let Just decoded = decode sampleContinuationPage :: Maybe SQLResult + (decode . encode) decoded `shouldBe` Just decoded + + it "ToJSON omits Nothing fields (no null leakage)" $ do + let Just decoded = decode sampleContinuationPage :: Maybe SQLResult + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` not . BS.isInfixOf "\"schema\"" + encoded `shouldSatisfy` not . BS.isInfixOf "\"total\"" + encoded `shouldSatisfy` BS.isInfixOf "\"cursor\"" + + describe "SQLRequest ToJSON" $ do + it "emits only query when no optional field is set" $ do + let req = SQLRequest "SELECT * FROM accounts" Nothing Nothing Nothing + encode req `shouldBe` "{\"query\":\"SELECT * FROM accounts\"}" + + it "emits filter, fetch_size, parameters when set" $ do + let filterVal = object ["term" .= object ["age" .= (30 :: Int)]] + req = + SQLRequest + { sqlRequestQuery = "SELECT * FROM t WHERE age > ?", + sqlRequestFilter = Just (toJSON filterVal), + sqlRequestFetchSize = Just 100, + sqlRequestParameters = Just [SQLParameter "integer" (toJSON (30 :: Int))] + } + encoded = LBS.toStrict (encode req) + encoded `shouldSatisfy` BS.isInfixOf "\"query\":" + encoded `shouldSatisfy` BS.isInfixOf "\"filter\":" + encoded `shouldSatisfy` BS.isInfixOf "\"fetch_size\":100" + encoded `shouldSatisfy` BS.isInfixOf "\"parameters\":[{\"type\":\"integer\",\"value\":30}]" + + it "round-trips a minimal request" $ do + let req = SQLRequest "SELECT 1" Nothing Nothing Nothing + decode (encode req) `shouldBe` Just req + + it "decodes a request body that only has query" $ do + let Just (decoded :: SQLRequest) = decode "{\"query\":\"SELECT 1\"}" + sqlRequestQuery decoded `shouldBe` "SELECT 1" + sqlRequestFilter decoded `shouldBe` Nothing + sqlRequestFetchSize decoded `shouldBe` Nothing + sqlRequestParameters decoded `shouldBe` Nothing + + describe "PPLRequest ToJSON" $ do + it "emits only query when no optional field is set" $ do + let req = PPLRequest "source=accounts | fields firstname" Nothing + encode req `shouldBe` "{\"query\":\"source=accounts | fields firstname\"}" + + it "emits filter when set" $ do + let filterVal = object ["match_all" .= object []] + req = + PPLRequest + "source=accounts | fields firstname" + (Just (toJSON filterVal)) + encoded = LBS.toStrict (encode req) + encoded `shouldSatisfy` BS.isInfixOf "\"filter\":" + + it "round-trips" $ do + let req = PPLRequest "source=accounts" Nothing + decode (encode req) `shouldBe` Just req + + it "decodes a request body that only has query" $ do + let Just (decoded :: PPLRequest) = decode "{\"query\":\"source=accounts\"}" + pplRequestQuery decoded `shouldBe` "source=accounts" + pplRequestFilter decoded `shouldBe` Nothing + + -- ========================================================================= + -- Endpoint shape (OS3). Pure checks against the BHRequest; no live backend. + -- ========================================================================= + + describe "sqlQuery endpoint shape (OpenSearch 3)" $ do + it "POSTs to /_plugins/_sql" $ do + let req = OS3Requests.sqlQuery (SQLRequest "SELECT 1" Nothing Nothing Nothing) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_sql"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the POST method" $ do + let req = OS3Requests.sqlQuery (SQLRequest "SELECT 1" Nothing Nothing Nothing) + bhRequestMethod req `shouldBe` "POST" + + it "attaches the encoded SQLRequest as body" $ do + let req = OS3Requests.sqlQuery (SQLRequest "SELECT 1" Nothing Nothing Nothing) + bhRequestBody req `shouldSatisfy` isJust + + it "carries the query string verbatim in the body" $ do + let req = OS3Requests.sqlQuery (SQLRequest "SELECT * FROM t" Nothing Nothing Nothing) + Just body = bhRequestBody req + LBS.toStrict body `shouldSatisfy` BS.isInfixOf "SELECT * FROM t" + + describe "sqlQueryNextPage endpoint shape (OpenSearch 3)" $ do + it "POSTs to the same /_plugins/_sql path with a cursor body" $ do + let req = OS3Requests.sqlQueryNextPage (SQLCursor "d:abc") + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_sql"] + bhRequestMethod req `shouldBe` "POST" + let Just body = bhRequestBody req + LBS.toStrict body `shouldBe` "{\"cursor\":\"d:abc\"}" + + describe "closeSqlCursor endpoint shape (OpenSearch 3)" $ do + it "POSTs to /_plugins/_sql/close with a cursor body" $ do + let req = OS3Requests.closeSqlCursor (SQLCursor "d:abc") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sql", "close"] + bhRequestMethod req `shouldBe` "POST" + let Just body = bhRequestBody req + LBS.toStrict body `shouldBe` "{\"cursor\":\"d:abc\"}" + + describe "explainSQL endpoint shape (OpenSearch 3)" $ do + it "POSTs to /_plugins/_sql/_explain" $ do + let req = OS3Requests.explainSQL (SQLRequest "SELECT 1" Nothing Nothing Nothing) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_sql", "_explain"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the POST method" $ do + let req = OS3Requests.explainSQL (SQLRequest "SELECT 1" Nothing Nothing Nothing) + bhRequestMethod req `shouldBe` "POST" + + it "attaches the encoded SQLRequest as body" $ do + let req = OS3Requests.explainSQL (SQLRequest "SELECT 1" Nothing Nothing Nothing) + bhRequestBody req `shouldSatisfy` isJust + + it "carries the query string verbatim in the body" $ do + let req = OS3Requests.explainSQL (SQLRequest "SELECT * FROM t" Nothing Nothing Nothing) + Just body = bhRequestBody req + LBS.toStrict body `shouldSatisfy` BS.isInfixOf "SELECT * FROM t" + + describe "pplQuery endpoint shape (OpenSearch 3)" $ do + it "POSTs to /_plugins/_ppl" $ do + let req = OS3Requests.pplQuery (PPLRequest "source=accounts" Nothing) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_ppl"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the POST method" $ do + let req = OS3Requests.pplQuery (PPLRequest "source=accounts" Nothing) + bhRequestMethod req `shouldBe` "POST" + + it "attaches the encoded PPLRequest as body" $ do + let req = OS3Requests.pplQuery (PPLRequest "source=accounts" Nothing) + bhRequestBody req `shouldSatisfy` isJust + + describe "explainPPL endpoint shape (OpenSearch 3)" $ do + it "POSTs to /_plugins/_ppl/_explain" $ do + let req = OS3Requests.explainPPL (PPLRequest "source=accounts" Nothing) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_plugins", "_ppl", "_explain"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the POST method" $ do + let req = OS3Requests.explainPPL (PPLRequest "source=accounts" Nothing) + bhRequestMethod req `shouldBe` "POST" + + it "attaches the encoded PPLRequest as body" $ do + let req = OS3Requests.explainPPL (PPLRequest "source=accounts" Nothing) + bhRequestBody req `shouldSatisfy` isJust + + it "carries the query string verbatim in the body" $ do + let req = OS3Requests.explainPPL (PPLRequest "source=accounts | fields firstname" Nothing) + Just body = bhRequestBody req + LBS.toStrict body `shouldSatisfy` BS.isInfixOf "source=accounts | fields firstname" + + -- ========================================================================= + -- Cross-backend parity: OS1, OS2, OS3 must agree on path/method/body. + -- ========================================================================= + + describe "cross-backend parity" $ do + -- Each OS version has its own SQLRequest/PPLRequest/SQLCursor types + -- (they live in distinct modules), so we build version-qualified values + -- and compare the wire output (path, method, body). + let q = "SELECT 1" :: Text + ppl = "source=accounts" :: Text + cur = "d:xyz" :: Text + + it "sqlQuery emits identical paths across OS1/OS2/OS3" $ do + let p1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.sqlQuery (OS1Types.SQLRequest q Nothing Nothing Nothing))) + p2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.sqlQuery (OS2Types.SQLRequest q Nothing Nothing Nothing))) + p3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.sqlQuery (SQLRequest q Nothing Nothing Nothing))) + p1 `shouldBe` ["_plugins", "_sql"] + p2 `shouldBe` p1 + p3 `shouldBe` p1 + + it "sqlQuery emits identical methods across OS1/OS2/OS3" $ do + let methods = + [ bhRequestMethod (OS1Requests.sqlQuery (OS1Types.SQLRequest q Nothing Nothing Nothing)), + bhRequestMethod (OS2Requests.sqlQuery (OS2Types.SQLRequest q Nothing Nothing Nothing)), + bhRequestMethod (OS3Requests.sqlQuery (SQLRequest q Nothing Nothing Nothing)) + ] + -- All three should be the same single method, i.e. exactly one unique value. + length (L.nub methods) `shouldBe` 1 + head methods `shouldBe` "POST" + + it "sqlQuery emits identical bodies across OS1/OS2/OS3" $ do + let bodies = + catMaybes + [ bhRequestBody (OS1Requests.sqlQuery (OS1Types.SQLRequest q Nothing Nothing Nothing)), + bhRequestBody (OS2Requests.sqlQuery (OS2Types.SQLRequest q Nothing Nothing Nothing)), + bhRequestBody (OS3Requests.sqlQuery (SQLRequest q Nothing Nothing Nothing)) + ] + length bodies `shouldBe` 3 + -- All three bodies should be byte-identical, so exactly one unique value. + length (L.nub (L.map LBS.toStrict bodies)) `shouldBe` 1 + + it "pplQuery emits identical paths across OS1/OS2/OS3" $ do + let p1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.pplQuery (OS1Types.PPLRequest ppl Nothing))) + p2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.pplQuery (OS2Types.PPLRequest ppl Nothing))) + p3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.pplQuery (PPLRequest ppl Nothing))) + p1 `shouldBe` ["_plugins", "_ppl"] + p2 `shouldBe` p1 + p3 `shouldBe` p1 + + it "closeSqlCursor emits identical paths across OS1/OS2/OS3" $ do + let p1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.closeSqlCursor (OS1Types.SQLCursor cur))) + p2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.closeSqlCursor (OS2Types.SQLCursor cur))) + p3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.closeSqlCursor (SQLCursor cur))) + p1 `shouldBe` ["_plugins", "_sql", "close"] + p2 `shouldBe` p1 + p3 `shouldBe` p1 + + it "sqlQueryNextPage emits identical paths across OS1/OS2/OS3" $ do + let p1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.sqlQueryNextPage (OS1Types.SQLCursor cur))) + p2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.sqlQueryNextPage (OS2Types.SQLCursor cur))) + p3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.sqlQueryNextPage (SQLCursor cur))) + p1 `shouldBe` ["_plugins", "_sql"] + p2 `shouldBe` p1 + p3 `shouldBe` p1 + + it "explainSQL emits identical paths across OS1/OS2/OS3" $ do + let p1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.explainSQL (OS1Types.SQLRequest q Nothing Nothing Nothing))) + p2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.explainSQL (OS2Types.SQLRequest q Nothing Nothing Nothing))) + p3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.explainSQL (SQLRequest q Nothing Nothing Nothing))) + p1 `shouldBe` ["_plugins", "_sql", "_explain"] + p2 `shouldBe` p1 + p3 `shouldBe` p1 + + it "explainSQL emits identical methods across OS1/OS2/OS3" $ do + let methods = + [ bhRequestMethod (OS1Requests.explainSQL (OS1Types.SQLRequest q Nothing Nothing Nothing)), + bhRequestMethod (OS2Requests.explainSQL (OS2Types.SQLRequest q Nothing Nothing Nothing)), + bhRequestMethod (OS3Requests.explainSQL (SQLRequest q Nothing Nothing Nothing)) + ] + length (L.nub methods) `shouldBe` 1 + head methods `shouldBe` "POST" + + it "explainSQL emits identical bodies across OS1/OS2/OS3" $ do + let bodies = + catMaybes + [ bhRequestBody (OS1Requests.explainSQL (OS1Types.SQLRequest q Nothing Nothing Nothing)), + bhRequestBody (OS2Requests.explainSQL (OS2Types.SQLRequest q Nothing Nothing Nothing)), + bhRequestBody (OS3Requests.explainSQL (SQLRequest q Nothing Nothing Nothing)) + ] + length bodies `shouldBe` 3 + length (L.nub (L.map LBS.toStrict bodies)) `shouldBe` 1 + + it "explainPPL emits identical paths across OS1/OS2/OS3" $ do + let p1 = getRawEndpoint (bhRequestEndpoint (OS1Requests.explainPPL (OS1Types.PPLRequest ppl Nothing))) + p2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.explainPPL (OS2Types.PPLRequest ppl Nothing))) + p3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.explainPPL (PPLRequest ppl Nothing))) + p1 `shouldBe` ["_plugins", "_ppl", "_explain"] + p2 `shouldBe` p1 + p3 `shouldBe` p1 + + it "explainPPL emits identical methods across OS1/OS2/OS3" $ do + let methods = + [ bhRequestMethod (OS1Requests.explainPPL (OS1Types.PPLRequest ppl Nothing)), + bhRequestMethod (OS2Requests.explainPPL (OS2Types.PPLRequest ppl Nothing)), + bhRequestMethod (OS3Requests.explainPPL (PPLRequest ppl Nothing)) + ] + length (L.nub methods) `shouldBe` 1 + head methods `shouldBe` "POST" + + it "explainPPL emits identical bodies across OS1/OS2/OS3" $ do + let bodies = + catMaybes + [ bhRequestBody (OS1Requests.explainPPL (OS1Types.PPLRequest ppl Nothing)), + bhRequestBody (OS2Requests.explainPPL (OS2Types.PPLRequest ppl Nothing)), + bhRequestBody (OS3Requests.explainPPL (PPLRequest ppl Nothing)) + ] + length bodies `shouldBe` 3 + length (L.nub (L.map LBS.toStrict bodies)) `shouldBe` 1 diff --git a/tests/Test/SQLStatsSpec.hs b/tests/Test/SQLStatsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SQLStatsSpec.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SQLStatsSpec (spec) where + +import Data.Aeson.Types qualified as Aeson +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List qualified as L +import Data.Map.Strict qualified as Map +import Database.Bloodhound.OpenSearch1.Requests qualified as OS1Requests +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types +import TestsUtils.Import +import Prelude + +-- --------------------------------------------------------------------------- +-- Sample bodies. +-- +-- The SQL plugin's @GET /_plugins/_sql/stats@ returns a flat JSON object +-- mapping metric-name strings to integer values. The metric-name set +-- grows across OpenSearch releases — 8 keys on 1.x (sampleOS1Response), +-- ~34 keys on 3.x (sampleOS3Response). The decoder is a flat 'Map', so +-- both shapes round-trip unchanged. +-- --------------------------------------------------------------------------- + +-- | The canonical 8-field response drawn verbatim from the OS 1.x SQL +-- plugin docs (@docs/user/admin/monitoring.rst@). Every value is a +-- JSON integer: counters are 'Integer', the @circuit_breaker@ gauge is +-- @0@ or @1@. +sampleOS1Response :: LBS.ByteString +sampleOS1Response = + "{\ + \ \"failed_request_count_cb\" : 0,\ + \ \"default_cursor_request_count\" : 10,\ + \ \"default_cursor_request_total\" : 3,\ + \ \"failed_request_count_cuserr\" : 0,\ + \ \"circuit_breaker\" : 0,\ + \ \"request_total\" : 70,\ + \ \"request_count\" : 0,\ + \ \"failed_request_count_syserr\" : 0\ + \}" + +-- | A synthetic 3.x response exercising the broader metric set the +-- plugin emits once PPL, datasource, async-query, EMR and streaming +-- metrics have landed. Every value is still a JSON integer. Used to +-- guard forward-compatibility: a decoder that hard-coded the 1.x key +-- set would silently drop these. +sampleOS3Response :: LBS.ByteString +sampleOS3Response = + "{\ + \ \"request_total\" : 130,\ + \ \"request_count\" : 5,\ + \ \"default_cursor_request_total\" : 12,\ + \ \"default_cursor_request_count\" : 2,\ + \ \"failed_request_count_syserr\" : 1,\ + \ \"failed_request_count_cuserr\" : 3,\ + \ \"failed_request_count_cb\" : 0,\ + \ \"circuit_breaker\" : 1,\ + \ \"ppl_request_total\" : 40,\ + \ \"ppl_request_count\" : 4,\ + \ \"ppl_failed_request_count_syserr\" : 0,\ + \ \"ppl_failed_request_count_cuserr\" : 1,\ + \ \"datasource_create_request_count\" : 2,\ + \ \"datasource_get_request_count\" : 17,\ + \ \"datasource_put_request_count\" : 0,\ + \ \"datasource_patch_request_count\" : 0,\ + \ \"datasource_delete_request_count\" : 0,\ + \ \"datasource_failed_request_count_syserr\" : 0,\ + \ \"datasource_failed_request_count_cuserr\" : 0,\ + \ \"async_query_create_api_request_count\" : 6,\ + \ \"async_query_get_api_request_count\" : 22,\ + \ \"async_query_cancel_api_request_count\" : 1,\ + \ \"emr_start_job_request_failure_count\" : 0,\ + \ \"streaming_job_housekeeper_task_failure_count\" : 0\ + \}" + +spec :: Spec +spec = describe "SQL Stats API" $ do + describe "SQLPluginStats JSON" $ do + it "decodes the documented 1.x response (8 fields)" $ do + let Just decoded = decode sampleOS1Response :: Maybe SQLPluginStats + entries = sqlPluginStatsEntries decoded + Map.size entries `shouldBe` 8 + Map.member "request_total" entries `shouldBe` True + Map.member "request_count" entries `shouldBe` True + Map.member "default_cursor_request_total" entries `shouldBe` True + Map.member "default_cursor_request_count" entries `shouldBe` True + Map.member "failed_request_count_syserr" entries `shouldBe` True + Map.member "failed_request_count_cuserr" entries `shouldBe` True + Map.member "failed_request_count_cb" entries `shouldBe` True + Map.member "circuit_breaker" entries `shouldBe` True + + it "preserves the documented 1.x integer values" $ do + let Just decoded = decode sampleOS1Response :: Maybe SQLPluginStats + entries = sqlPluginStatsEntries decoded + Map.lookup "request_total" entries `shouldBe` Just (toJSON (70 :: Int)) + Map.lookup "default_cursor_request_count" entries `shouldBe` Just (toJSON (10 :: Int)) + Map.lookup "circuit_breaker" entries `shouldBe` Just (toJSON (0 :: Int)) + Map.lookup "failed_request_count_cb" entries `shouldBe` Just (toJSON (0 :: Int)) + + it "decodes a current 3.x response (24 fields, forward compatibility)" $ do + let Just decoded = decode sampleOS3Response :: Maybe SQLPluginStats + entries = sqlPluginStatsEntries decoded + Map.size entries `shouldBe` 24 + -- The 1.x key set is fully preserved... + Map.member "request_total" entries `shouldBe` True + Map.member "circuit_breaker" entries `shouldBe` True + -- ...and the newer metric families are present too. + Map.member "ppl_request_total" entries `shouldBe` True + Map.member "datasource_create_request_count" entries `shouldBe` True + Map.member "async_query_create_api_request_count" entries `shouldBe` True + Map.member "emr_start_job_request_failure_count" entries `shouldBe` True + Map.member "streaming_job_housekeeper_task_failure_count" entries `shouldBe` True + + it "preserves the 3.x integer values verbatim" $ do + let Just decoded = decode sampleOS3Response :: Maybe SQLPluginStats + entries = sqlPluginStatsEntries decoded + Map.lookup "request_total" entries `shouldBe` Just (toJSON (130 :: Int)) + Map.lookup "circuit_breaker" entries `shouldBe` Just (toJSON (1 :: Int)) + Map.lookup "ppl_request_total" entries `shouldBe` Just (toJSON (40 :: Int)) + + it "tolerates unknown fields (inherent to the flat Map decoder)" $ do + let Just decoded = + decode + "{\"request_total\":1,\"future_metric\":99}" :: + Maybe SQLPluginStats + entries = sqlPluginStatsEntries decoded + Map.size entries `shouldBe` 2 + Map.member "future_metric" entries `shouldBe` True + + it "decodes an empty object as an empty map" $ do + let Just decoded = decode "{}" :: Maybe SQLPluginStats + sqlPluginStatsEntries decoded `shouldBe` Map.empty + + it "rejects a top-level null" $ + decode "null" `shouldBe` (Nothing :: Maybe SQLPluginStats) + + it "rejects a top-level array" $ + decode "[]" `shouldBe` (Nothing :: Maybe SQLPluginStats) + + it "rejects a top-level scalar" $ + decode "42" `shouldBe` (Nothing :: Maybe SQLPluginStats) + + it "rejects malformed JSON" $ + decode "{ not json" `shouldBe` (Nothing :: Maybe SQLPluginStats) + + it "round-trips the 1.x response through ToJSON/FromJSON" $ do + let Just decoded = decode sampleOS1Response :: Maybe SQLPluginStats + (decode . encode) decoded `shouldBe` Just decoded + + it "round-trips the 3.x response through ToJSON/FromJSON" $ do + let Just decoded = decode sampleOS3Response :: Maybe SQLPluginStats + (decode . encode) decoded `shouldBe` Just decoded + + it "ToJSON emits the documented keys" $ do + let Just decoded = decode sampleOS1Response :: Maybe SQLPluginStats + encoded = LBS.toStrict (encode decoded) + encoded `shouldSatisfy` BS.isInfixOf "\"request_total\"" + encoded `shouldSatisfy` BS.isInfixOf "\"circuit_breaker\"" + encoded `shouldSatisfy` BS.isInfixOf "\"default_cursor_request_count\"" + + it "lets callers decode individual metrics via aeson" $ do + let Just decoded = decode sampleOS1Response :: Maybe SQLPluginStats + Just (Aeson.Number n) = Map.lookup "request_total" (sqlPluginStatsEntries decoded) + n `shouldBe` 70 + + -- ========================================================================= + -- Endpoint shape. Pure checks against the BHRequest; no live backend. + -- ========================================================================= + + describe "getSQLStats endpoint shape (OpenSearch 3)" $ do + it "GETs /_plugins/_sql/stats" $ do + let req = OS3Requests.getSQLStats + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sql", "stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the GET method" $ + bhRequestMethod OS3Requests.getSQLStats `shouldBe` "GET" + + it "does not attach a body (GET semantics)" $ + bhRequestBody OS3Requests.getSQLStats `shouldBe` Nothing + + describe "getSQLStats endpoint shape (OpenSearch 2)" $ do + it "GETs /_plugins/_sql/stats" $ do + let req = OS2Requests.getSQLStats + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sql", "stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the GET method" $ + bhRequestMethod OS2Requests.getSQLStats `shouldBe` "GET" + + it "does not attach a body (GET semantics)" $ + bhRequestBody OS2Requests.getSQLStats `shouldBe` Nothing + + describe "getSQLStats endpoint shape (OpenSearch 1)" $ do + it "GETs /_plugins/_sql/stats" $ do + let req = OS1Requests.getSQLStats + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sql", "stats"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "uses the GET method" $ + bhRequestMethod OS1Requests.getSQLStats `shouldBe` "GET" + + it "does not attach a body (GET semantics)" $ + bhRequestBody OS1Requests.getSQLStats `shouldBe` Nothing + + -- ========================================================================= + -- Cross-backend parity: OS1, OS2, OS3 must agree on path/method/body. + -- ========================================================================= + + describe "getSQLStats cross-backend parity" $ do + it "emits identical paths across OS1/OS2/OS3" $ do + let p1 = getRawEndpoint (bhRequestEndpoint OS1Requests.getSQLStats) + p2 = getRawEndpoint (bhRequestEndpoint OS2Requests.getSQLStats) + p3 = getRawEndpoint (bhRequestEndpoint OS3Requests.getSQLStats) + p1 `shouldBe` ["_plugins", "_sql", "stats"] + p2 `shouldBe` p1 + p3 `shouldBe` p1 + + it "emits identical methods across OS1/OS2/OS3" $ do + let methods = + [ bhRequestMethod OS1Requests.getSQLStats, + bhRequestMethod OS2Requests.getSQLStats, + bhRequestMethod OS3Requests.getSQLStats + ] + length (L.nub methods) `shouldBe` 1 + head methods `shouldBe` "GET" + + it "emits no body on any version" $ do + let bodies = + [ bhRequestBody OS1Requests.getSQLStats, + bhRequestBody OS2Requests.getSQLStats, + bhRequestBody OS3Requests.getSQLStats + ] + L.nub bodies `shouldBe` [Nothing] diff --git a/tests/Test/SSESpec.hs b/tests/Test/SSESpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SSESpec.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Pure unit tests for the SSE parser +-- ('Database.Bloodhound.Internal.Utils.SSE'). The parser is exercised +-- against literal byte streams copied from the OpenSearch ML Commons +-- Execute Stream Agent documentation (both the conversational-agent +-- @data:@ framing and the AG-UI event framing), so these tests pin the +-- wire shape against future drift. No live cluster is required: a +-- 'Network.HTTP.Client.BodyReader' is synthesised from an in-memory +-- 'ByteString' via a small helper. +module Test.SSESpec (spec) where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Text (Text) +import Data.Text qualified as T +import Database.Bloodhound.Internal.Utils.SSE +import Network.HTTP.Client (BodyReader) +import Test.Hspec +import Prelude hiding (head) + +-- | Build a 'BodyReader' that yields the given bytes in one shot then +-- EOF. Mirrors how @http-client@ delivers a fully-buffered chunk for +-- small responses; sufficient for these parser tests. +mkBodyReader :: ByteString -> IO BodyReader +mkBodyReader bytes = do + ref <- newIORef bytes + pure $ + readIORef ref >>= \remaining -> + if BS.null remaining + then pure BS.empty + else do + writeIORef ref BS.empty + pure remaining + +spec :: Spec +spec = do + describe "SSE parser" $ do + it "parses a single data: event" $ do + br <- mkBodyReader "data: {\"hello\":1}\n\n" + st <- newSSEState br + ev <- readSSEEvent st + sseData <$> ev `shouldBe` Just "{\"hello\":1}" + sseEvent <$> ev `shouldBe` Just Nothing + + it "parses multiple consecutive events" $ do + br <- mkBodyReader "data: a\n\ndata: b\n\ndata: c\n\n" + st <- newSSEState br + e1 <- readSSEEvent st + e2 <- readSSEEvent st + e3 <- readSSEEvent st + e4 <- readSSEEvent st + sseData <$> e1 `shouldBe` Just "a" + sseData <$> e2 `shouldBe` Just "b" + sseData <$> e3 `shouldBe` Just "c" + e4 `shouldBe` Nothing + + it "joins multi-line data: fields with \\n (per spec)" $ do + br <- mkBodyReader "data: line1\ndata: line2\n\n" + st <- newSSEState br + ev <- readSSEEvent st + sseData <$> ev `shouldBe` Just "line1\nline2" + + it "strips a single leading space after the colon" $ do + br <- mkBodyReader "data: padded\n\n" + st <- newSSEState br + ev <- readSSEEvent st + -- Only the FIRST space is stripped; the rest are preserved. + sseData <$> ev `shouldBe` Just " padded" + + it "tolerates CRLF line endings" $ do + br <- mkBodyReader "data: crlf\r\n\r\n" + st <- newSSEState br + ev <- readSSEEvent st + sseData <$> ev `shouldBe` Just "crlf" + + it "ignores comment lines starting with :" $ do + br <- mkBodyReader ": this is a comment\ndata: real\n\n" + st <- newSSEState br + ev <- readSSEEvent st + sseData <$> ev `shouldBe` Just "real" + + it "parses event:/id:/retry: fields" $ do + br <- mkBodyReader "event: add\ndata: x\nid: 7\nretry: 3000\n\n" + st <- newSSEState br + ev <- readSSEEvent st + ev + `shouldBe` Just + (SSEEvent {sseEvent = Just "add", sseData = "x", sseId = Just "7", sseRetry = Just 3000}) + + it "handles incremental byte delivery (chunks smaller than a frame)" $ do + -- A BodyReader that yields 3 bytes at a time, simulating a slow + -- network stream. The parser must reassemble across reads. + ref <- newIORef ("data: hello\n\n" :: ByteString) + let br :: BodyReader + br = do + remaining <- readIORef ref + let (chunk, rest) = BS.splitAt 3 remaining + writeIORef ref rest + pure chunk + st <- newSSEState br + ev <- readSSEEvent st + sseData <$> ev `shouldBe` Just "hello" + + it "returns Nothing at end of stream" $ do + br <- mkBodyReader "" + st <- newSSEState br + ev <- readSSEEvent st + ev `shouldBe` Nothing + + it "dispatches a trailing partial event at EOF" $ do + br <- mkBodyReader "data: tail-no-separator" + st <- newSSEState br + ev <- readSSEEvent st + sseData <$> ev `shouldBe` Just "tail-no-separator" + + it "parses a realistic conversational-agent chunk sequence" $ do + let stream :: ByteString = + "data: {\"inference_results\":[{\"output\":[{\"name\":\"memory_id\",\"result\":\"m1\"}]}]}\n\n\ + \data: {\"inference_results\":[{\"output\":[{\"name\":\"response\",\"dataAsMap\":{\"content\":\"There\",\"is_last\":false}}]}]}\n\n\ + \data: {\"inference_results\":[{\"output\":[{\"name\":\"response\",\"dataAsMap\":{\"content\":\" are\",\"is_last\":false}}]}]}\n\n\ + \data: {\"inference_results\":[{\"output\":[{\"name\":\"response\",\"dataAsMap\":{\"content\":\"\",\"is_last\":true}}]}]}\n\n" + br <- mkBodyReader stream + st <- newSSEState br + chunks <- collect st 10 + length chunks `shouldBe` 4 + case chunks of + firstEv : _ -> sseData firstEv `shouldSatisfy` T.isInfixOf "memory_id" + [] -> expectationFailure "expected at least one chunk" + +-- | Collect up to @n@ events from the parser, then stop. +collect :: SSEState -> Int -> IO [SSEEvent] +collect _ 0 = pure [] +collect st n = do + next <- readSSEEvent st + case next of + Just ev -> (ev :) <$> collect st (n - 1) + Nothing -> pure [] diff --git a/tests/Test/ScanScrollSpec.hs b/tests/Test/ScanScrollSpec.hs --- a/tests/Test/ScanScrollSpec.hs +++ b/tests/Test/ScanScrollSpec.hs @@ -1,12 +1,13 @@ module Test.ScanScrollSpec (spec) where +import Database.Bloodhound.Client qualified as Client (clearScroll, getInitialScroll) import TestsUtils.Common import TestsUtils.Import import Prelude spec :: Spec spec = - describe "Scan & Scroll API" $ + describe "Scan & Scroll API" $ do it "returns documents using the scan&scroll API" $ withTestEnv $ do _ <- insertData @@ -25,3 +26,28 @@ regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored liftIO $ scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet] + + it "clearScroll frees a scroll context without error" $ + withTestEnv $ do + _ <- insertData + _ <- insertOther + let search = + ( mkSearch + (Just $ MatchAllQuery Nothing) + Nothing + ) + { size = Size 1 + } + initial <- Client.getInitialScroll testIndex search :: BH IO (ParsedEsResponse (SearchResult Tweet)) + case initial of + Left e -> + liftIO $ + expectationFailure ("getInitialScroll failed: " <> show e) + Right SearchResult {scrollId = Just sid} -> do + resp <- Client.clearScroll sid + liftIO $ do + clearScrollSucceeded resp `shouldBe` True + clearScrollNumFreed resp `shouldSatisfy` (>= 1) + Right _ -> + liftIO $ + expectationFailure "getInitialScroll returned no scrollId" diff --git a/tests/Test/ScriptContextsSpec.hs b/tests/Test/ScriptContextsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ScriptContextsSpec.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.ScriptContextsSpec (spec) where + +import Database.Bloodhound.Common.Types +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + -- ------------------------------------------------------------------ -- + -- Pure JSON decoder tests (no ES required). -- + -- ------------------------------------------------------------------ -- + describe "ScriptContextsResponse JSON parsing" $ do + let emptyBody = "{\"contexts\":[]}" + withMethodsBody = + "{\"contexts\":[{\"name\":\"aggs\",\"methods\":[\ + \{\"name\":\"execute\",\"return_type\":\"java.lang.Object\",\"params\":[]},\ + \{\"name\":\"getDoc\",\"return_type\":\"java.util.Map\",\"params\":[]}]}]}" + -- The @analysis@ context's execute is one of the few methods + -- that carries a non-empty params array; captured from a live + -- ES 7.17.25 cluster. + withParamsBody = + "{\"contexts\":[{\"name\":\"analysis\",\"methods\":[\ + \{\"name\":\"execute\",\"return_type\":\"boolean\",\ + \\"params\":[{\"type\":\"org.elasticsearch.analysis.common.AnalysisPredicateScript$Token\",\ + \\"name\":\"token\"}]}]}]}" + + it "parses the empty contexts array" $ do + let Just (r :: ScriptContextsResponse) = decode emptyBody + scrContexts r `shouldBe` [] + + it "parses contexts with zero-argument methods" $ do + let Just (r :: ScriptContextsResponse) = decode withMethodsBody + scrContexts r `shouldSatisfy` (not . null) + let ctx = head (scrContexts r) + sciName ctx `shouldBe` "aggs" + length (sciMethods ctx) `shouldBe` 2 + let m = head (sciMethods ctx) + scmName m `shouldBe` "execute" + scmReturnType m `shouldBe` "java.lang.Object" + scmParams m `shouldBe` [] + + it "parses a method with non-empty params (the `type` key)" $ do + let Just (r :: ScriptContextsResponse) = decode withParamsBody + let ctx = head (scrContexts r) + sciName ctx `shouldBe` "analysis" + let m = head (sciMethods ctx) + scmName m `shouldBe` "execute" + scmReturnType m `shouldBe` "boolean" + length (scmParams m) `shouldBe` 1 + let p = head (scmParams m) + scpName p `shouldBe` "token" + scpType p + `shouldBe` "org.elasticsearch.analysis.common.AnalysisPredicateScript$Token" + + it "treats a missing contexts key as the empty list" $ do + let Just (r :: ScriptContextsResponse) = decode "{}" + scrContexts r `shouldBe` [] + + it "round-trips the full response via ToJSON/FromJSON" $ do + let Just (original :: ScriptContextsResponse) = decode withParamsBody + reDecoded = decode (encode original) :: Maybe ScriptContextsResponse + Just original `shouldBe` reDecoded + + -- ------------------------------------------------------------------ -- + -- Endpoint shape: pure checks against the BHRequest value; no live -- + -- backend needed. -- + -- ------------------------------------------------------------------ -- + describe "getScriptContexts endpoint shape" $ do + it "GETs /_script_context with no body and no params" $ do + let req = getScriptContexts + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_script_context"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + -- ------------------------------------------------------------------ -- + -- Live backend tests (need ES on ES_TEST_SERVER, default 9200). -- + -- _script_context is served by ES 7.x/8.x/9.x and OpenSearch -- + -- 1.x/2.x/3.x. -- + -- ------------------------------------------------------------------ -- + describe "getScriptContexts live API" $ do + it "returns a non-empty contexts catalogue" $ + withTestEnv $ do + r <- performBHRequest getScriptContexts + liftIO $ scrContexts r `shouldSatisfy` (not . null) + it "every context has a name and at least an execute method" $ + withTestEnv $ do + r <- performBHRequest getScriptContexts + liftIO $ + mapM_ + ( \ctx -> do + sciName ctx `shouldSatisfy` (/= "") + map scmName (sciMethods ctx) `shouldContain` ["execute"] + ) + (scrContexts r) diff --git a/tests/Test/ScriptLanguagesSpec.hs b/tests/Test/ScriptLanguagesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ScriptLanguagesSpec.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.ScriptLanguagesSpec (spec) where + +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.Common.Types +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + -- ------------------------------------------------------------------ -- + -- Pure JSON decoder tests (no ES required). -- + -- ------------------------------------------------------------------ -- + describe "ScriptLanguagesResponse JSON parsing" $ do + let emptyBody = "{\"types_allowed\":[],\"language_contexts\":[]}" + -- Captured from a live ES 7.17.25 cluster (trimmed to the + -- expression + mustache languages; painless carries a long + -- contexts list omitted here for brevity). + fullBody = + "{\"types_allowed\":[\"inline\",\"stored\"],\ + \\"language_contexts\":[\ + \{\"language\":\"expression\",\"contexts\":[\"aggs\",\"field\",\"filter\"]},\ + \{\"language\":\"mustache\",\"contexts\":[\"template\"]}\ + \]}" + + it "parses the empty response" $ do + let Just (r :: ScriptLanguagesResponse) = decode emptyBody + slrTypesAllowed r `shouldBe` [] + slrLanguageContexts r `shouldBe` [] + + it "parses types_allowed and language_contexts" $ do + let Just (r :: ScriptLanguagesResponse) = decode fullBody + slrTypesAllowed r `shouldBe` ["inline", "stored"] + length (slrLanguageContexts r) `shouldBe` 2 + let firstCtx = head (slrLanguageContexts r) + slcLanguage firstCtx `shouldBe` ScriptLanguage "expression" + slcContexts firstCtx `shouldContain` ["aggs", "field", "filter"] + + it "treats missing arrays as the empty list" $ do + let Just (r :: ScriptLanguagesResponse) = decode "{}" + slrTypesAllowed r `shouldBe` [] + slrLanguageContexts r `shouldBe` [] + + it "round-trips the full response via ToJSON/FromJSON" $ do + let Just (original :: ScriptLanguagesResponse) = decode fullBody + reDecoded = decode (encode original) :: Maybe ScriptLanguagesResponse + Just original `shouldBe` reDecoded + + describe "ScriptLanguageContext JSON parsing" $ do + let body = + "{\"language\":\"painless\",\"contexts\":[\"aggs\",\"score\",\"update\"]}" + + it "parses language and contexts" $ do + let Just (c :: ScriptLanguageContext) = decode body + slcLanguage c `shouldBe` ScriptLanguage "painless" + slcContexts c `shouldBe` ["aggs", "score", "update"] + + it "uses parseJSON directly (covers the withObject path)" $ + case parseEither parseJSON (object ["language" .= String "expression"]) :: + Either String ScriptLanguageContext of + Right c -> slcLanguage c `shouldBe` ScriptLanguage "expression" + Left err -> expectationFailure ("parseJSON failed: " <> err) + + -- ------------------------------------------------------------------ -- + -- Endpoint shape: pure checks against the BHRequest value; no live -- + -- backend needed. -- + -- ------------------------------------------------------------------ -- + describe "getScriptLanguages endpoint shape" $ do + it "GETs /_script_language with no body and no params" $ do + let req = getScriptLanguages + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_script_language"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + -- ------------------------------------------------------------------ -- + -- Live backend tests (need ES on ES_TEST_SERVER, default 9200). -- + -- _script_language is served by ES 7.x/8.x/9.x and OpenSearch -- + -- 2.x/3.x, but returns HTTP 500 on OpenSearch 1.3 (a server bug: -- + -- null_pointer_exception in the response body). The block is gated -- + -- by 'backendSpecific' so the OS 1.3 matrix job marks it pending -- + -- instead of red. -- + -- ------------------------------------------------------------------ -- + describe "getScriptLanguages live API" + $ backendSpecific + [ ElasticSearch7, + ElasticSearch8, + ElasticSearch9, + OpenSearch2, + OpenSearch3 + ] + $ do + it "returns inline/stored as allowed types and a painless entry" $ + withTestEnv $ do + r <- performBHRequest getScriptLanguages + liftIO $ do + slrTypesAllowed r `shouldContain` ["inline", "stored"] + map slcLanguage (slrLanguageContexts r) + `shouldContain` [ScriptLanguage "painless"] diff --git a/tests/Test/ScriptSpec.hs b/tests/Test/ScriptSpec.hs --- a/tests/Test/ScriptSpec.hs +++ b/tests/Test/ScriptSpec.hs @@ -3,14 +3,14 @@ module Test.ScriptSpec (spec) where -import qualified Data.Aeson.KeyMap as X -import qualified Data.Map as M +import Data.Aeson.KeyMap qualified as X +import Data.Map qualified as M import TestsUtils.Common import TestsUtils.Import spec :: Spec -spec = - describe "Script" $ +spec = do + describe "Script" $ do it "returns a transformed document based on the script field" $ withTestEnv $ do _ <- insertData @@ -21,6 +21,7 @@ (Just (ScriptLanguage "painless")) (ScriptInline "doc['age'].value * 2") Nothing + Nothing sf = ScriptFields $ X.fromList [("test1", sfv)] @@ -31,3 +32,24 @@ hitFields (head (hits (searchHits sr))) liftIO $ results `shouldBe` HitFields (M.fromList [("test1", [Number 20000.0])]) + + -- bloodhound-04f.22: the 'options' field (e.g. mustache + -- @{"content_type": "application/json"}@) must be emitted on the + -- script object and survive a FromJSON/ToJSON round-trip. Pure test — + -- no cluster required. + it "emits and round-trips the options field" $ do + let opts = X.fromList [("content_type", String "application/json")] + script = + Script + (Just (ScriptLanguage "mustache")) + (ScriptInline "{{query}}") + Nothing + (Just opts) + expectedInner = + object + [ "lang" .= String "mustache", + "source" .= String "{{query}}", + "options" .= object ["content_type" .= String "application/json"] + ] + toJSON script `shouldBe` object ["script" .= expectedInner] + decode (encode script) `shouldBe` (Just script :: Maybe Script) diff --git a/tests/Test/ScrollSpec.hs b/tests/Test/ScrollSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ScrollSpec.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.ScrollSpec (spec) where + +import Data.Aeson + ( decode, + eitherDecode, + encode, + ) +import Data.Aeson.Types (parseEither, parseJSON) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Either (isLeft) +import Data.Maybe (isJust) +import Database.Bloodhound.Common.Types +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) +import Prelude + +-- Sample Clear Scroll response body, as documented by both Elasticsearch +-- and OpenSearch: +-- https://www.elastic.co/guide/en/elasticsearch/reference/current/clear-scroll-api.html +-- https://docs.opensearch.org/latest/api-reference/scroll-search/ +sampleClearScrollResponseBody :: LBS.ByteString +sampleClearScrollResponseBody = + LBS.pack + ( unlines + [ "{", + " \"succeeded\": true,", + " \"num_freed\": 2", + "}" + ] + ) + +spec :: Spec +spec = + describe "Clear Scroll API response" $ do + it "decodes a well-formed {succeeded,num_freed} body" $ do + let decoded = decode sampleClearScrollResponseBody :: Maybe ClearScrollResponse + decoded `shouldSatisfy` isJust + let Just r = decoded + clearScrollSucceeded r `shouldBe` True + clearScrollNumFreed r `shouldBe` 2 + + it "round-trips decode -> encode -> decode" $ do + let Just (r1 :: ClearScrollResponse) = decode sampleClearScrollResponseBody + let reencoded = encode r1 + decode reencoded `shouldBe` Just r1 + + it "rejects a body missing num_freed" $ do + let malformed = + LBS.pack + ( unlines + [ "{", + " \"succeeded\": true", + "}" + ] + ) + let result = parseEither parseJSON =<< eitherDecode malformed :: Either String ClearScrollResponse + result `shouldSatisfy` isLeft + + it "rejects a body missing succeeded" $ do + let malformed = + LBS.pack + ( unlines + [ "{", + " \"num_freed\": 1", + "}" + ] + ) + let result = parseEither parseJSON =<< eitherDecode malformed :: Either String ClearScrollResponse + result `shouldSatisfy` isLeft + + it "rejects a non-object body" $ do + let result = parseEither parseJSON =<< eitherDecode "[1,2,3]" :: Either String ClearScrollResponse + result `shouldSatisfy` isLeft + + describe "advanceScrollOptionsParams rendering" $ do + -- The renderer is the wire contract for the new @?rest_total_hits_as_int@ + -- parameter on @POST /_search/scroll@. These tests pin its output so + -- regressions are caught even without an integration test. + it "defaultAdvanceScrollOptions renders no parameters" $ do + advanceScrollOptionsParams defaultAdvanceScrollOptions + `shouldBe` [] + + it "asoRestTotalHitsAsInt = Just True renders rest_total_hits_as_int=true" $ do + let opts = defaultAdvanceScrollOptions {asoRestTotalHitsAsInt = Just True} + advanceScrollOptionsParams opts + `shouldBe` [("rest_total_hits_as_int", Just "true")] + + it "asoRestTotalHitsAsInt = Just False renders rest_total_hits_as_int=false" $ do + let opts = defaultAdvanceScrollOptions {asoRestTotalHitsAsInt = Just False} + advanceScrollOptionsParams opts + `shouldBe` [("rest_total_hits_as_int", Just "false")] + + describe "HitsTotal parses both wire shapes" $ do + -- The server emits the object form by default and the bare-integer + -- form when the client passes @?rest_total_hits_as_int=true@. Both + -- must decode into the same 'HitsTotal' value for the option to be + -- usable. + it "decodes the object form {value, relation}" $ do + let decoded = decode "{ \"value\": 5, \"relation\": \"eq\" }" :: Maybe HitsTotal + decoded `shouldBe` Just (HitsTotal 5 HTR_EQ) + + it "decodes a bare integer as value with relation=eq" $ do + let decoded = decode "5" :: Maybe HitsTotal + decoded `shouldBe` Just (HitsTotal 5 HTR_EQ) + + it "rejects a non-numeric, non-object scalar" $ do + let result = parseEither parseJSON =<< eitherDecode "\"five\"" :: Either String HitsTotal + result `shouldSatisfy` isLeft diff --git a/tests/Test/SearchAfterSpec.hs b/tests/Test/SearchAfterSpec.hs --- a/tests/Test/SearchAfterSpec.hs +++ b/tests/Test/SearchAfterSpec.hs @@ -1,7 +1,7 @@ module Test.SearchAfterSpec (spec) where import Control.Concurrent (threadDelay) -import qualified Data.Aeson as Aeson +import Data.Aeson qualified as Aeson import TestsUtils.Common import TestsUtils.Import import Prelude @@ -33,7 +33,23 @@ docvalueFields = Nothing, source = Nothing, suggestBody = Nothing, - pointInTime = Nothing + pointInTime = Nothing, + knnBody = Nothing, + osKnnBody = Nothing, + trackTotalHits = Nothing, + timeout = Nothing, + minScore = Nothing, + explain = Nothing, + searchVersion = Nothing, + seqNoPrimaryTerm = Nothing, + terminateAfter = Nothing, + stats = Nothing, + searchPipeline = Nothing, + storedFields = Nothing, + runtimeMappings = Nothing, + rescore = Nothing, + collapse = Nothing, + retriever = Nothing } when (majorVersion == 2) $ liftIO $ diff --git a/tests/Test/SearchApplicationsSpec.hs b/tests/Test/SearchApplicationsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SearchApplicationsSpec.hs @@ -0,0 +1,591 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.SearchApplicationsSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Maybe (isNothing) +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch8.Requests qualified as RequestsES8 +import Database.Bloodhound.ElasticSearch8.Types qualified as Types +import Database.Bloodhound.ElasticSearch9.Client qualified as ClientES9 +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import TestsUtils.Common +import TestsUtils.Import + +-- | Soft-test-index pair used in the integration round-trip; matches +-- the seed index name used by the rest of the test-suite so documents +-- are already present. +testAppIndices :: NonEmpty IndexName +testAppIndices = testIndex :| [] + +-- | Minimal 'SearchApplication' targeting 'testAppIndices' with no +-- template — accepted on every cluster (no template / no analytics +-- dependency), so the integration round-trip can run without a +-- template-rendering backend. +minimalApp :: Types.SearchApplication +minimalApp = + Types.SearchApplication + { Types.saIndices = testAppIndices, + Types.saAnalyticsCollectionName = Nothing, + Types.saTemplate = Nothing + } + +spec :: Spec +spec = + describe + "Search Applications API (PUT/GET/DELETE/POST-search/list/render on /_application/search_application)" + $ do + describe "SearchApplicationName JSON" $ do + it "round-trips a SearchApplicationName" $ do + let n = Types.SearchApplicationName "my-app" + decode (encode n) `shouldBe` Just n + + it "unSearchApplicationName extracts the underlying Text" $ + Types.unSearchApplicationName (Types.SearchApplicationName "abc") + `shouldBe` ("abc" :: Text) + + describe "SearchApplicationScriptBody wire shape" $ do + it "encodes InlineStringSource as {\"source\": \"...\"}" $ do + let b = Types.InlineStringSource "mustache template" + encode b `shouldBe` "{\"source\":\"mustache template\"}" + decode (encode b) `shouldBe` Just b + + it "encodes InlineObjectSource as {\"source\": {...}}" $ do + let v = object ["query" .= object ["match_all" .= object []]] + b = Types.InlineObjectSource v + encode b `shouldBe` "{\"source\":{\"query\":{\"match_all\":{}}}}" + decode (encode b) `shouldBe` Just b + + it "encodes StoredScriptId as {\"id\": \"...\"}" $ do + let b = Types.StoredScriptId "my-stored-script" + encode b `shouldBe` "{\"id\":\"my-stored-script\"}" + decode (encode b) `shouldBe` Just b + + it "rejects an object missing both source and id" $ + case decode "{}" :: Maybe Types.SearchApplicationScriptBody of + Just b -> + expectationFailure $ "expected parse failure, got: " <> show b + Nothing -> pure () + + it "rejects an object carrying both source and id" $ + case decode "{\"source\":\"x\",\"id\":\"y\"}" :: Maybe Types.SearchApplicationScriptBody of + Just b -> + expectationFailure $ "expected parse failure, got: " <> show b + Nothing -> pure () + + it "rejects a non-string / non-object source" $ + case decode "{\"source\":5}" :: Maybe Types.SearchApplicationScriptBody of + Just b -> + expectationFailure $ "expected parse failure, got: " <> show b + Nothing -> pure () + + describe "SearchApplicationTemplateScript wire shape" $ do + it "encodes an inline-string script with all optional fields omitted" $ do + let s = + Types.SearchApplicationTemplateScript + { Types.satsScriptBody = Types.InlineStringSource "q", + Types.satsParams = Nothing, + Types.satsLang = Nothing, + Types.satsOptions = Nothing + } + encode s `shouldBe` "{\"source\":\"q\"}" + decode (encode s) `shouldBe` Just s + + it "encodes a stored-id script with params/lang/options" $ do + let s = + Types.SearchApplicationTemplateScript + { Types.satsScriptBody = Types.StoredScriptId "sid", + Types.satsParams = Just (KM.fromList [("k", "v")]), + Types.satsLang = Just (ScriptLanguage "mustache"), + Types.satsOptions = Just (KM.fromList [("opt", "val")]) + } + -- Object key order is not pinned by aeson; assert round-trip + -- and that the encoded blob carries the expected keys. + decode (encode s) `shouldBe` Just s + let hasKey k bs = case decode bs :: Maybe Object of + Just o -> k `KM.member` o + Nothing -> False + hasKey "id" (encode s) `shouldBe` True + hasKey "lang" (encode s) `shouldBe` True + + it "round-trips an inline-object source" $ do + let v = object ["query" .= object ["match_all" .= object []]] + s = + Types.SearchApplicationTemplateScript + { Types.satsScriptBody = Types.InlineObjectSource v, + Types.satsParams = Nothing, + Types.satsLang = Nothing, + Types.satsOptions = Nothing + } + decode (encode s) `shouldBe` Just s + + describe "SearchApplicationTemplate wire shape" $ do + it "encodes a bare template (script only, no dictionary)" $ do + let t = + Types.SearchApplicationTemplate $ + Types.SearchApplicationTemplateScript + (Types.InlineStringSource "q") + Nothing + Nothing + Nothing + encode t `shouldBe` "{\"script\":{\"source\":\"q\"}}" + decode (encode t) `shouldBe` Just t + + it "never emits the removed dictionary key" $ do + let t = + Types.SearchApplicationTemplate $ + Types.SearchApplicationTemplateScript + (Types.StoredScriptId "sid") + Nothing + Nothing + Nothing + json = encode t + hasKey k bs = case decode bs :: Maybe Object of + Just o -> k `KM.member` o + Nothing -> False + hasKey "dictionary" json `shouldBe` False + + it "rejects a template object missing the required script key" $ + decode "{}" `shouldSatisfy` (isNothing :: Maybe Types.SearchApplicationTemplate -> Bool) + + it "rejects malformed input (non-object)" $ + decode (LBS.pack "42") `shouldSatisfy` (isNothing :: Maybe Types.SearchApplicationTemplate -> Bool) + + describe "SearchApplication wire shape" $ do + it "encodes minimal app (indices only)" $ do + let app = + Types.SearchApplication + { Types.saIndices = [qqIndexName|logs|] :| [], + Types.saAnalyticsCollectionName = Nothing, + Types.saTemplate = Nothing + } + encode app `shouldBe` "{\"indices\":[\"logs\"]}" + decode (encode app) `shouldBe` Just app + + it "encodes app with analytics collection + template" $ do + let app = + Types.SearchApplication + { Types.saIndices = [qqIndexName|logs|] :| [[qqIndexName|logs-2|]], + Types.saAnalyticsCollectionName = Just "my-analytics", + Types.saTemplate = + Just $ + Types.SearchApplicationTemplate $ + Types.SearchApplicationTemplateScript + (Types.InlineStringSource "q") + Nothing + Nothing + Nothing + } + decode (encode app) `shouldBe` Just app + + it "rejects an app with empty indices" $ + case decode "{\"indices\":[]}" :: Maybe Types.SearchApplication of + Just a -> + expectationFailure $ "expected parse failure, got: " <> show a + Nothing -> pure () + + describe "SearchApplicationInfo wire shape" $ do + it "decodes a full GET response" $ do + let raw = + "{\"name\":\"my-app\",\"indices\":[\"logs\"],\ + \\"analytics_collection_name\":\"coll\",\ + \\"updated_at_millis\":1682105622204}" + case decode raw :: Maybe Types.SearchApplicationInfo of + Just info -> do + Types.saiName info `shouldBe` Types.SearchApplicationName "my-app" + Types.saiIndices info `shouldBe` [[qqIndexName|logs|]] + Types.saiAnalyticsCollectionName info `shouldBe` Just "coll" + Types.saiUpdatedAtMillis info `shouldBe` Just 1682105622204 + Types.saiTemplate info `shouldBe` Nothing + Nothing -> + expectationFailure "failed to decode SearchApplicationInfo" + + it "round-trips a minimal info" $ do + let info = + Types.SearchApplicationInfo + { Types.saiName = "my-app", + Types.saiIndices = [[qqIndexName|logs|]], + Types.saiAnalyticsCollectionName = Nothing, + Types.saiTemplate = Nothing, + Types.saiUpdatedAtMillis = Nothing + } + decode (encode info) `shouldBe` Just info + + describe "SearchApplicationPutResponse JSON" $ do + it "decodes {\"result\":\"created\"}" $ do + case decode "{\"result\":\"created\"}" :: Maybe Types.SearchApplicationPutResponse of + Just r -> Types.saprResult r `shouldBe` "created" + Nothing -> expectationFailure "failed to decode" + + it "decodes {\"result\":\"updated\"}" $ do + case decode "{\"result\":\"updated\"}" :: Maybe Types.SearchApplicationPutResponse of + Just r -> Types.saprResult r `shouldBe` "updated" + Nothing -> expectationFailure "failed to decode" + + it "round-trips" $ do + let r = Types.SearchApplicationPutResponse "created" + decode (encode r) `shouldBe` Just r + + describe "SearchApplicationSearchParams JSON" $ do + it "omits params when not set" $ do + let p = Types.SearchApplicationSearchParams Nothing + encode p `shouldBe` "{}" + decode (encode p) `shouldBe` Just p + + it "round-trips with params" $ do + let p = + Types.SearchApplicationSearchParams $ + Just $ + KM.fromList + [("q", "bitemyapp"), ("filter", "verified")] + decode (encode p) `shouldBe` Just p + + describe "endpoint shape" $ do + it "PUTs to /_application/search_application/ with a body (ES8)" $ do + let req = RequestsES8.putSearchApplication "my-app" minimalApp + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "search_application", "my-app"] + bhRequestBody req `shouldSatisfy` isJust + + it "putSearchApplication emits no query params by default (ES8)" $ do + let req = RequestsES8.putSearchApplication "my-app" minimalApp + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "putSearchApplicationWith default options emits no query params (ES8)" $ do + let req = RequestsES8.putSearchApplicationWith "my-app" Types.defaultSearchApplicationPutOptions minimalApp + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "putSearchApplicationWith default opts is byte-for-byte identical to putSearchApplication (ES8)" $ do + let legacy = RequestsES8.putSearchApplication "my-app" minimalApp + withDef = RequestsES8.putSearchApplicationWith "my-app" Types.defaultSearchApplicationPutOptions minimalApp + getRawEndpoint (bhRequestEndpoint legacy) `shouldBe` getRawEndpoint (bhRequestEndpoint withDef) + getRawEndpointQueries (bhRequestEndpoint legacy) `shouldBe` getRawEndpointQueries (bhRequestEndpoint withDef) + bhRequestBody legacy `shouldBe` bhRequestBody withDef + + it "putSearchApplicationWith emits ?create=true when sapoCreate is Just True (ES8)" $ do + let opts = Types.defaultSearchApplicationPutOptions {Types.sapoCreate = Just True} + req = RequestsES8.putSearchApplicationWith "my-app" opts minimalApp + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "search_application", "my-app"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("create", Just "true")] + + it "putSearchApplicationWith emits ?create=false when sapoCreate is Just False (ES8)" $ do + let opts = Types.defaultSearchApplicationPutOptions {Types.sapoCreate = Just False} + req = RequestsES8.putSearchApplicationWith "my-app" opts minimalApp + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("create", Just "false")] + bhRequestBody req `shouldSatisfy` isJust + + it "GETs /_application/search_application/ with no body (ES8)" $ do + let req = RequestsES8.getSearchApplication "my-app" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "search_application", "my-app"] + bhRequestBody req `shouldSatisfy` isNothing + + it "DELETEs /_application/search_application/ with no body (ES8)" $ do + let req = RequestsES8.deleteSearchApplication "my-app" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "search_application", "my-app"] + bhRequestBody req `shouldSatisfy` isNothing + + it "POSTs to /_application/search_application//_search with no body when params are omitted (ES8)" $ do + let req = RequestsES8.searchApplication @() "my-app" Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "search_application", "my-app", "_search"] + it "POSTs to /_application/search_application//_search with a body when params are supplied (ES8)" $ do + let params = Types.SearchApplicationSearchParams (Just KM.empty) + req = RequestsES8.searchApplication @() "my-app" (Just params) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "search_application", "my-app", "_search"] + bhRequestBody req `shouldSatisfy` isJust + + it "ES9 request builders hit the same paths as ES8" $ do + let putReq = RequestsES9.putSearchApplication "r" minimalApp + getReq = RequestsES9.getSearchApplication "r" + delReq = RequestsES9.deleteSearchApplication "r" + searchReq = RequestsES9.searchApplication @() "r" Nothing + getRawEndpoint (bhRequestEndpoint putReq) + `shouldBe` ["_application", "search_application", "r"] + getRawEndpoint (bhRequestEndpoint getReq) + `shouldBe` ["_application", "search_application", "r"] + getRawEndpoint (bhRequestEndpoint delReq) + `shouldBe` ["_application", "search_application", "r"] + getRawEndpoint (bhRequestEndpoint searchReq) + `shouldBe` ["_application", "search_application", "r", "_search"] + bhRequestBody putReq `shouldSatisfy` isJust + bhRequestBody getReq `shouldSatisfy` isNothing + bhRequestBody delReq `shouldSatisfy` isNothing + + it "ES9 putSearchApplicationWith default opts emits no query params" $ do + let req = RequestsES9.putSearchApplicationWith "r" Types.defaultSearchApplicationPutOptions minimalApp + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "ES9 putSearchApplicationWith emits ?create=true matching ES8" $ do + let opts = Types.defaultSearchApplicationPutOptions {Types.sapoCreate = Just True} + es9Req = RequestsES9.putSearchApplicationWith "r" opts minimalApp + es8Req = RequestsES8.putSearchApplicationWith "r" opts minimalApp + getRawEndpoint (bhRequestEndpoint es9Req) + `shouldBe` getRawEndpoint (bhRequestEndpoint es8Req) + getRawEndpointQueries (bhRequestEndpoint es9Req) + `shouldBe` [("create", Just "true")] + + it "searchApplicationOptionsParams default emits no params" $ + Types.searchApplicationOptionsParams Types.defaultSearchApplicationOptions + `shouldBe` [] + it "searchApplicationOptionsParams renders typed_keys=true" $ + Types.searchApplicationOptionsParams + Types.defaultSearchApplicationOptions {Types.saoTypedKeys = Just True} + `shouldBe` [("typed_keys", Just "true")] + it "searchApplicationOptionsParams renders typed_keys=false" $ + Types.searchApplicationOptionsParams + Types.defaultSearchApplicationOptions {Types.saoTypedKeys = Just False} + `shouldBe` [("typed_keys", Just "false")] + + it "searchApplicationWith default opts is byte-identical to searchApplication (ES8)" $ do + let plain = RequestsES8.searchApplication @() "my-app" Nothing + withOpts = RequestsES8.searchApplicationWith @() "my-app" Nothing Types.defaultSearchApplicationOptions + getRawEndpoint (bhRequestEndpoint plain) `shouldBe` getRawEndpoint (bhRequestEndpoint withOpts) + getRawEndpointQueries (bhRequestEndpoint plain) `shouldBe` [] + getRawEndpointQueries (bhRequestEndpoint withOpts) `shouldBe` [] + it "searchApplicationWith attaches ?typed_keys=true (ES8)" $ do + let opts = Types.defaultSearchApplicationOptions {Types.saoTypedKeys = Just True} + req = RequestsES8.searchApplicationWith @() "my-app" Nothing opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "search_application", "my-app", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("typed_keys", Just "true")] + it "ES9 searchApplicationWith reuses the ES8 builder" $ do + let opts = Types.defaultSearchApplicationOptions {Types.saoTypedKeys = Just True} + req = RequestsES9.searchApplicationWith @() "r" Nothing opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "search_application", "r", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("typed_keys", Just "true")] + + it "searchApplicationListOptionsParams default emits no params" $ + Types.searchApplicationListOptionsParams Types.defaultSearchApplicationListOptions + `shouldBe` [] + it "searchApplicationListOptionsParams renders q only" $ + Types.searchApplicationListOptionsParams + Types.defaultSearchApplicationListOptions {Types.saloQ = Just "app*"} + `shouldBe` [("q", Just "app*")] + it "searchApplicationListOptionsParams renders from + size" $ + Types.searchApplicationListOptionsParams + Types.defaultSearchApplicationListOptions {Types.saloFrom = Just 0, Types.saloSize = Just 3} + `shouldBe` [("from", Just "0"), ("size", Just "3")] + it "searchApplicationListOptionsParams renders q + from + size" $ + Types.searchApplicationListOptionsParams + Types.defaultSearchApplicationListOptions {Types.saloQ = Just "app*", Types.saloFrom = Just 0, Types.saloSize = Just 3} + `shouldBe` [("q", Just "app*"), ("from", Just "0"), ("size", Just "3")] + + it "listSearchApplications GETs /_application/search_application with no body (ES8)" $ do + let req = RequestsES8.listSearchApplications + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "search_application"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldSatisfy` isNothing + it "listSearchApplications default opts is byte-identical to listSearchApplications (ES8)" $ do + let plain = RequestsES8.listSearchApplications + withDef = RequestsES8.listSearchApplicationsWith Types.defaultSearchApplicationListOptions + getRawEndpoint (bhRequestEndpoint plain) `shouldBe` getRawEndpoint (bhRequestEndpoint withDef) + getRawEndpointQueries (bhRequestEndpoint plain) `shouldBe` [] + getRawEndpointQueries (bhRequestEndpoint withDef) `shouldBe` [] + it "listSearchApplicationsWith attaches ?from&size&q (ES8)" $ do + let opts = Types.defaultSearchApplicationListOptions {Types.saloQ = Just "app*", Types.saloFrom = Just 0, Types.saloSize = Just 3} + req = RequestsES8.listSearchApplicationsWith opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "search_application"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("q", Just "app*"), ("from", Just "0"), ("size", Just "3")] + bhRequestBody req `shouldSatisfy` isNothing + it "ES9 listSearchApplications hits the same path as ES8" $ do + let es8Req = RequestsES8.listSearchApplications + es9Req = RequestsES9.listSearchApplications + getRawEndpoint (bhRequestEndpoint es9Req) + `shouldBe` getRawEndpoint (bhRequestEndpoint es8Req) + getRawEndpointQueries (bhRequestEndpoint es9Req) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint es8Req) + it "ES9 listSearchApplicationsWith matches ES8 with the same opts" $ do + let opts = Types.defaultSearchApplicationListOptions {Types.saloSize = Just 5} + es8Req = RequestsES8.listSearchApplicationsWith opts + es9Req = RequestsES9.listSearchApplicationsWith opts + getRawEndpoint (bhRequestEndpoint es9Req) + `shouldBe` getRawEndpoint (bhRequestEndpoint es8Req) + getRawEndpointQueries (bhRequestEndpoint es9Req) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint es8Req) + + it "renderSearchApplicationQuery POSTs to ...//_render_query when params are omitted (ES8)" $ do + let req = RequestsES8.renderSearchApplicationQuery "my-app" Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "search_application", "my-app", "_render_query"] + it "renderSearchApplicationQuery POSTs with a body when params are supplied (ES8)" $ do + let params = Types.SearchApplicationSearchParams (Just KM.empty) + req = RequestsES8.renderSearchApplicationQuery "my-app" (Just params) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_application", "search_application", "my-app", "_render_query"] + bhRequestBody req `shouldSatisfy` isJust + it "renderSearchApplicationQuery emits no query params (ES8)" $ do + let req = RequestsES8.renderSearchApplicationQuery "my-app" Nothing + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "ES9 renderSearchApplicationQuery hits the same path as ES8" $ do + let es8Req = RequestsES8.renderSearchApplicationQuery "r" Nothing + es9Req = RequestsES9.renderSearchApplicationQuery "r" Nothing + getRawEndpoint (bhRequestEndpoint es9Req) + `shouldBe` getRawEndpoint (bhRequestEndpoint es8Req) + getRawEndpointQueries (bhRequestEndpoint es9Req) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint es8Req) + + describe "SearchApplicationListResponse wire shape" $ do + it "decodes the documented list example (name + updated_at_millis per item)" $ do + let raw = + "{\"count\":2,\"results\":[\ + \{\"name\":\"app-1\",\"updated_at_millis\":1690981129366},\ + \{\"name\":\"app-2\",\"updated_at_millis\":1691501823939}]}" + case decode raw :: Maybe Types.SearchApplicationListResponse of + Just resp -> do + Types.salrCount resp `shouldBe` 2 + length (Types.salrResults resp) `shouldBe` 2 + Types.saiName (Types.salrResults resp !! 0) `shouldBe` "app-1" + Types.saiUpdatedAtMillis (Types.salrResults resp !! 0) `shouldBe` Just 1690981129366 + -- Absent optional fields default cleanly. + Types.saiIndices (Types.salrResults resp !! 0) `shouldBe` [] + Types.saiTemplate (Types.salrResults resp !! 1) `shouldBe` Nothing + Nothing -> + expectationFailure "failed to decode SearchApplicationListResponse" + + it "round-trips a response with full info items" $ do + let item = + Types.SearchApplicationInfo + { Types.saiName = "app-1", + Types.saiIndices = [[qqIndexName|logs|]], + Types.saiAnalyticsCollectionName = Nothing, + Types.saiTemplate = Nothing, + Types.saiUpdatedAtMillis = Just 1690981129366 + } + resp = Types.SearchApplicationListResponse 1 [item] + decode (encode resp) `shouldBe` Just resp + + it "decodes an empty results array" $ + case decode "{\"count\":0,\"results\":[]}" :: Maybe Types.SearchApplicationListResponse of + Just resp -> Types.salrCount resp `shouldBe` 0 + Nothing -> expectationFailure "failed to decode empty list response" + + it "tolerates a missing count (defaults to 0)" $ + case decode "{\"results\":[]}" :: Maybe Types.SearchApplicationListResponse of + Just resp -> Types.salrCount resp `shouldBe` 0 + Nothing -> expectationFailure "failed to decode list response without count" + + describe "live integration (requires ES8+ backend)" $ + backendSpecific [ElasticSearch8, ElasticSearch9] $ do + -- Search Applications are gated behind a platinum/enterprise + -- license in production Elasticsearch. The docker-compose + -- ES8/ES9 containers ship with the free basic license, so the + -- positive round-trip below will 'pendingWith' out on most + -- local clusters; the pure-JSON and endpoint-shape tests above + -- exercise the implementation in detail. + it "round-trips a search application via PUT then GET then DELETE" $ + withTestEnv $ do + let appName = Types.SearchApplicationName "bloodhound-test-search-app" + _ <- + tryPerformBHRequest $ + RequestsES8.deleteSearchApplication appName + backend <- liftIO detectBackendType + let putReq = + if backend == Just ElasticSearch9 + then ClientES9.putSearchApplication appName minimalApp + else ClientES8.putSearchApplication appName minimalApp + putResult <- tryEsError putReq + case putResult of + Left e + | errorStatus e == Just 403 + || "license" `T.isInfixOf` T.toLower (errorMessage e) -> + liftIO $ + pendingWith + "search applications require platinum/enterprise \ + \license; skip on basic-license clusters" + Left e -> + liftIO $ + expectationFailure $ + "unexpected PUT error: " <> show e + Right putResp -> do + liftIO $ + Types.saprResult putResp + `shouldSatisfy` (\r -> r == "created" || r == "updated") + info <- + if backend == Just ElasticSearch9 + then ClientES9.getSearchApplication appName + else ClientES8.getSearchApplication appName + liftIO $ do + Types.saiName info `shouldBe` appName + -- 'testIndex' may render as the literal index name + -- or as a hidden/system variant; assert on length + -- rather than the exact name to stay robust. + length (Types.saiIndices info) `shouldSatisfy` (>= 1) + _ <- + if backend == Just ElasticSearch9 + then ClientES9.deleteSearchApplication appName + else ClientES8.deleteSearchApplication appName + pure () + + it "DELETE of a non-existent application surfaces a 4xx EsError" $ + withTestEnv $ do + result <- + tryPerformBHRequest $ + RequestsES8.deleteSearchApplication + (Types.SearchApplicationName "bloodhound-definitely-missing-app") + case result of + Left e -> + case errorStatus e of + Just s -> liftIO $ (s >= 400 && s < 500) `shouldBe` True + Nothing -> + liftIO $ + expectationFailure $ + "expected a 4xx status, got none. Message: " + <> show (errorMessage e) + Right _ -> + liftIO $ + expectationFailure + "expected DELETE of a missing application to fail, but it succeeded" + + it "searchApplication POST targets /_search and returns a 4xx for a missing app" $ + withTestEnv $ do + result <- + tryPerformBHRequest $ + RequestsES8.searchApplication @Value + (Types.SearchApplicationName "bloodhound-definitely-missing-app") + Nothing + -- 'searchApplication' is 'StatusDependant' and returns a + -- 'ParsedEsResponse' (an inner 'Either EsError ...'), so a + -- server-side 4xx lands in the *inner* Left while + -- 'tryPerformBHRequest' supplies the *outer* Either. + liftIO $ case result of + Left e + | Just s <- errorStatus e -> (s >= 400 && s < 600) `shouldBe` True + | otherwise -> + expectationFailure $ + "expected an error status, got none. Message: " + <> show (errorMessage e) + -- The search-application feature is gated behind a + -- platinum\/enterprise license; the docker-compose ES8\/ES9 + -- containers ship with the free basic license and answer + -- with a 403 security_exception. Skip there, mirroring the + -- round-trip spec above. + Right (Left e) + | errorStatus e == Just 403 + || "license" `T.isInfixOf` T.toLower (errorMessage e) -> + pendingWith + "search applications require platinum/enterprise \ + \license; skip on basic-license clusters" + | Just s <- errorStatus e -> (s >= 400 && s < 600) `shouldBe` True + | otherwise -> + expectationFailure $ + "expected an error status, got none. Message: " + <> show (errorMessage e) + Right (Right _) -> + expectationFailure + "expected search against a missing application to fail, but it succeeded" diff --git a/tests/Test/SearchBodySpec.hs b/tests/Test/SearchBodySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SearchBodySpec.hs @@ -0,0 +1,983 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SearchBodySpec (spec) where + +import Data.Aeson + ( Value (..), + decode, + encode, + object, + toJSON, + (.=), + ) +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.Aeson.Types (Object) +import Data.HashMap.Strict (singleton) +import Data.List (sort) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Text (Text) +import Database.Bloodhound.Common.Requests (mkSearch) +import Database.Bloodhound.Common.Types +import Optics ((&), (?~), (^.)) +import Test.Hspec (Spec, describe, it, shouldBe, shouldNotBe) + +-- | Lookup helper: pull a single key's value from a rendered Search body. +-- Fails loudly (returns @Nothing@) if the rendered JSON isn't an object or +-- the key is absent. +lookupKey :: Text -> Value -> Maybe Value +lookupKey k (Object o) = KM.lookup (K.fromText k) o +lookupKey _ _ = Nothing + +-- | Membership test, also handling non-object rendered output. +hasKey :: Text -> Value -> Bool +hasKey k (Object o) = KM.member (K.fromText k) o +hasKey _ _ = False + +spec :: Spec +spec = do + specSearchBodyScalar + specRuntimeMappings + specRescore + specCollapse + specRetriever + +specSearchBodyScalar :: Spec +specSearchBodyScalar = do + describe "TrackTotalHits JSON instances" $ do + it "TrackTotalHitsAll renders as Boolean true" $ do + toJSON TrackTotalHitsAll `shouldBe` Bool True + + it "TrackTotalHitsOff renders as Boolean false" $ do + toJSON TrackTotalHitsOff `shouldBe` Bool False + + it "TrackTotalHitsUpTo renders as a Number" $ do + toJSON (TrackTotalHitsUpTo 1000) `shouldBe` Number 1000 + + it "FromJSON round-trips every constructor" $ do + decode (encode TrackTotalHitsAll) `shouldBe` Just TrackTotalHitsAll + decode (encode TrackTotalHitsOff) `shouldBe` Just TrackTotalHitsOff + decode (encode (TrackTotalHitsUpTo 42)) `shouldBe` Just (TrackTotalHitsUpTo 42) + + it "FromJSON accepts a raw numeric literal" $ do + decode "1234" `shouldBe` Just (TrackTotalHitsUpTo 1234) + + describe "Search body JSON: default shape" $ do + it "mkSearch with Nothing/Nothing emits only from, size, track_scores" $ do + let value = toJSON (mkSearch Nothing Nothing :: Search) + case value of + Object o -> + sortKeys o + `shouldBe` sortKeys + ( KM.fromList + [ (K.fromText "from", Number 0), + (K.fromText "size", Number 10), + (K.fromText "track_scores", Bool False) + ] + ) + _ -> error "expected object" + + it "mkSearch retains a stable wire shape regardless of new fields" $ do + -- Pins the JSON bytes of the common case so future field additions + -- can't silently change what we send. + encode (mkSearch Nothing Nothing :: Search) + `shouldBe` "{\"from\":0,\"size\":10,\"track_scores\":false}" + + describe "Search body JSON: each new scalar field renders under its wire key" $ do + let base = mkSearch Nothing Nothing :: Search + + it "track_total_hits: true via TrackTotalHitsAll" $ do + lookupKey "track_total_hits" (toJSON base {trackTotalHits = Just TrackTotalHitsAll}) + `shouldBe` Just (Bool True) + + it "track_total_hits: false via TrackTotalHitsOff" $ do + lookupKey "track_total_hits" (toJSON base {trackTotalHits = Just TrackTotalHitsOff}) + `shouldBe` Just (Bool False) + + it "track_total_hits: N via TrackTotalHitsUpTo" $ do + lookupKey "track_total_hits" (toJSON base {trackTotalHits = Just (TrackTotalHitsUpTo 5000)}) + `shouldBe` Just (Number 5000) + + it "timeout renders verbatim" $ do + lookupKey "timeout" (toJSON base {timeout = Just "1s"}) + `shouldBe` Just (String "1s") + + it "min_score renders as Number" $ do + lookupKey "min_score" (toJSON base {minScore = Just 0.5}) + `shouldBe` Just (Number 0.5) + + it "explain renders as Boolean" $ do + lookupKey "explain" (toJSON base {explain = Just True}) + `shouldBe` Just (Bool True) + + it "version renders as Boolean (field named searchVersion)" $ do + lookupKey "version" (toJSON base {searchVersion = Just True}) + `shouldBe` Just (Bool True) + + it "seq_no_primary_term renders as Boolean" $ do + lookupKey "seq_no_primary_term" (toJSON base {seqNoPrimaryTerm = Just True}) + `shouldBe` Just (Bool True) + + it "terminate_after renders as Number" $ do + lookupKey "terminate_after" (toJSON base {terminateAfter = Just 100}) + `shouldBe` Just (Number 100) + + it "stats renders as a JSON array of strings" $ do + lookupKey "stats" (toJSON base {stats = Just ["my_search", "audit"]}) + `shouldBe` Just (toJSON (["my_search", "audit"] :: [Text])) + + it "search_pipeline renders verbatim" $ do + lookupKey "search_pipeline" (toJSON base {searchPipeline = Just "my_pipeline"}) + `shouldBe` Just (String "my_pipeline") + + it "stored_fields renders as a JSON array of strings" $ do + lookupKey "stored_fields" (toJSON base {storedFields = Just [FieldName "user", FieldName "message"]}) + `shouldBe` Just (toJSON (["user", "message"] :: [Text])) + + describe "Search body JSON: absence semantics" $ do + it "omits the wire key when the field is Nothing" $ do + let rendered = toJSON (mkSearch Nothing Nothing :: Search) + -- All ten new keys must be absent. + hasKey "track_total_hits" rendered `shouldBe` False + hasKey "timeout" rendered `shouldBe` False + hasKey "min_score" rendered `shouldBe` False + hasKey "explain" rendered `shouldBe` False + hasKey "version" rendered `shouldBe` False + hasKey "seq_no_primary_term" rendered `shouldBe` False + hasKey "terminate_after" rendered `shouldBe` False + hasKey "stats" rendered `shouldBe` False + hasKey "search_pipeline" rendered `shouldBe` False + hasKey "stored_fields" rendered `shouldBe` False + + describe "Search body JSON: every new field populated" $ do + it "renders all ten new wire keys simultaneously" $ do + let s = + (mkSearch Nothing Nothing) + { trackTotalHits = Just (TrackTotalHitsUpTo 1000), + timeout = Just "5s", + minScore = Just 1.0, + explain = Just True, + searchVersion = Just False, + seqNoPrimaryTerm = Just True, + terminateAfter = Just 50, + stats = Just ["foo"], + searchPipeline = Just "pipeline-x", + storedFields = Just [FieldName "a"] + } + case toJSON s of + Object o -> do + -- Exactly the 10 new keys + from + size + track_scores = 13 keys total. + length (KM.keys o) `shouldBe` 13 + mapM_ + (\k -> KM.member (K.fromText k) o `shouldBe` True) + [ "track_total_hits", + "timeout", + "min_score", + "explain", + "version", + "seq_no_primary_term", + "terminate_after", + "stats", + "search_pipeline", + "stored_fields" + ] + _ -> error "expected object" + + describe "Search body JSON: lenses" $ do + it "trackTotalHitsLens round-trips" $ do + let s = mkSearch Nothing Nothing & trackTotalHitsLens ?~ TrackTotalHitsAll + s ^. trackTotalHitsLens `shouldBe` Just TrackTotalHitsAll + + it "searchVersionLens round-trips (disambiguates from Status.version)" $ do + let s = mkSearch Nothing Nothing & searchVersionLens ?~ True + s ^. searchVersionLens `shouldBe` Just True + + it "every new lens defaults to Nothing in mkSearch output" $ do + let s = mkSearch Nothing Nothing :: Search + s ^. trackTotalHitsLens `shouldBe` Nothing + s ^. timeoutLens `shouldBe` Nothing + s ^. minScoreLens `shouldBe` Nothing + s ^. explainLens `shouldBe` Nothing + s ^. searchVersionLens `shouldBe` Nothing + s ^. seqNoPrimaryTermLens `shouldBe` Nothing + s ^. terminateAfterLens `shouldBe` Nothing + s ^. statsLens `shouldBe` Nothing + s ^. searchPipelineLens `shouldBe` Nothing + s ^. storedFieldsLens `shouldBe` Nothing + +-- | Compare HashMaps by their key sets (order-independent). +sortKeys :: KM.KeyMap Value -> [K.Key] +sortKeys = sort . KM.keys + +-- --------------------------------------------------------------------------- +-- bloodhound-04f.7.1.1: runtimeMappings +-- --------------------------------------------------------------------------- + +specRuntimeMappings :: Spec +specRuntimeMappings = do + describe "RuntimeType JSON instances" $ do + it "renders every constructor as the expected lowercase string" $ do + toJSON RuntimeTypeBoolean `shouldBe` String "boolean" + toJSON RuntimeTypeDate `shouldBe` String "date" + toJSON RuntimeTypeDouble `shouldBe` String "double" + toJSON RuntimeTypeKeyword `shouldBe` String "keyword" + toJSON RuntimeTypeLong `shouldBe` String "long" + toJSON RuntimeTypeIP `shouldBe` String "ip" + + it "FromJSON round-trips every constructor" $ do + decode (encode RuntimeTypeBoolean) `shouldBe` Just RuntimeTypeBoolean + decode (encode RuntimeTypeDate) `shouldBe` Just RuntimeTypeDate + decode (encode RuntimeTypeDouble) `shouldBe` Just RuntimeTypeDouble + decode (encode RuntimeTypeKeyword) `shouldBe` Just RuntimeTypeKeyword + decode (encode RuntimeTypeLong) `shouldBe` Just RuntimeTypeLong + decode (encode RuntimeTypeIP) `shouldBe` Just RuntimeTypeIP + + describe "RuntimeScript JSON instances" $ do + it "round-trips with source only" $ do + let rs = RuntimeScript {runtimeScriptSource = "doc['x'].value", runtimeScriptParams = Nothing, runtimeScriptLang = Nothing} + decode (encode rs) `shouldBe` Just rs + + it "round-trips with source + lang" $ do + let rs = + RuntimeScript + { runtimeScriptSource = "emit(doc['x'].value * params['factor'])", + runtimeScriptParams = Nothing, + runtimeScriptLang = Just "painless" + } + decode (encode rs) `shouldBe` Just rs + + it "uses the lang wire key" $ do + let rs = RuntimeScript "doc['x'].value" Nothing (Just "expression") + lookupKey "lang" (toJSON rs) `shouldBe` Just (String "expression") + + describe "RuntimeMapping JSON instances" $ do + it "round-trips type-only mapping" $ do + let rm = RuntimeMapping {runtimeMappingType = RuntimeTypeKeyword, runtimeMappingScript = Nothing} + decode (encode rm) `shouldBe` Just rm + + it "round-trips mapping with script" $ do + let rm = + RuntimeMapping + { runtimeMappingType = RuntimeTypeLong, + runtimeMappingScript = + Just + RuntimeScript + { runtimeScriptSource = "emit(doc['x'].value)", + runtimeScriptParams = Nothing, + runtimeScriptLang = Nothing + } + } + decode (encode rm) `shouldBe` Just rm + + describe "RuntimeMappings JSON instances" $ do + it "renders as a bare JSON object keyed by field name" $ do + let rms = + RuntimeMappings $ + singleton + "day_of_week" + RuntimeMapping + { runtimeMappingType = RuntimeTypeKeyword, + runtimeMappingScript = + Just + RuntimeScript + { runtimeScriptSource = "emit(doc['timestamp'].value.dayOfWeekEnum)", + runtimeScriptParams = Nothing, + runtimeScriptLang = Nothing + } + } + case toJSON rms of + Object o -> do + KM.member (K.fromText "day_of_week") o `shouldBe` True + _ -> error "expected object" + + it "round-trips a single-entry map" $ do + let rms = + RuntimeMappings $ + singleton "qoy" $ + RuntimeMapping + { runtimeMappingType = RuntimeTypeDouble, + runtimeMappingScript = Nothing + } + decode (encode rms) `shouldBe` Just rms + + describe "Search body JSON: runtimeMappings field" $ do + let base = mkSearch Nothing Nothing :: Search + + it "omits runtime_mappings when Nothing" $ do + hasKey "runtime_mappings" (toJSON base) `shouldBe` False + + it "renders runtime_mappings when set" $ do + let s = + base + { runtimeMappings = + Just $ + RuntimeMappings $ + singleton "day_of_week" $ + RuntimeMapping + { runtimeMappingType = RuntimeTypeKeyword, + runtimeMappingScript = Nothing + } + } + hasKey "runtime_mappings" (toJSON s) `shouldBe` True + + it "runtimeMappingsLens round-trips" $ do + let s = mkSearch Nothing Nothing & runtimeMappingsLens ?~ RuntimeMappings (singleton "x" (RuntimeMapping RuntimeTypeBoolean Nothing)) + s ^. runtimeMappingsLens + `shouldBe` Just (RuntimeMappings (singleton "x" (RuntimeMapping RuntimeTypeBoolean Nothing))) + +-- --------------------------------------------------------------------------- +-- bloodhound-04f.7.1.2: rescore +-- --------------------------------------------------------------------------- + +specRescore :: Spec +specRescore = do + describe "RescoreScoreMode JSON instances" $ do + it "renders every constructor as the expected string" $ do + toJSON RescoreScoreModeAvg `shouldBe` String "avg" + toJSON RescoreScoreModeMax `shouldBe` String "max" + toJSON RescoreScoreModeMin `shouldBe` String "min" + toJSON RescoreScoreModeTotal `shouldBe` String "total" + toJSON RescoreScoreModeMultiply `shouldBe` String "multiply" + + it "FromJSON round-trips every constructor" $ do + decode (encode RescoreScoreModeAvg) `shouldBe` Just RescoreScoreModeAvg + decode (encode RescoreScoreModeMax) `shouldBe` Just RescoreScoreModeMax + decode (encode RescoreScoreModeMin) `shouldBe` Just RescoreScoreModeMin + decode (encode RescoreScoreModeTotal) `shouldBe` Just RescoreScoreModeTotal + decode (encode RescoreScoreModeMultiply) `shouldBe` Just RescoreScoreModeMultiply + + it "FromJSON accepts sum as an alias for total" $ do + decode "\"sum\"" `shouldBe` Just RescoreScoreModeTotal + + describe "RescoreQuery JSON instances" $ do + it "round-trips a minimal rescore query" $ do + let rq = + RescoreQuery + { rescoreQueryRescoreQuery = MatchAllQuery Nothing, + rescoreQueryQueryWeight = Nothing, + rescoreQueryRescoreQueryWeight = Nothing, + rescoreQueryScoreMode = Nothing + } + decode (encode rq) `shouldBe` Just rq + + it "round-trips a fully-populated rescore query" $ do + let rq = + RescoreQuery + { rescoreQueryRescoreQuery = MatchAllQuery Nothing, + rescoreQueryQueryWeight = Just 0.7, + rescoreQueryRescoreQueryWeight = Just 1.2, + rescoreQueryScoreMode = Just RescoreScoreModeMax + } + decode (encode rq) `shouldBe` Just rq + + it "uses the rescore_query wire key" $ do + lookupKey "rescore_query" (toJSON (RescoreQuery (MatchAllQuery Nothing) Nothing Nothing Nothing)) + `shouldBe` Just (toJSON (MatchAllQuery Nothing :: Query)) + + it "uses the score_mode wire key" $ do + lookupKey "score_mode" (toJSON (RescoreQuery (MatchAllQuery Nothing) Nothing Nothing (Just RescoreScoreModeAvg))) + `shouldBe` Just (String "avg") + + describe "Rescore JSON instances" $ do + it "round-trips a rescore clause" $ do + let r = + Rescore + { rescoreWindowSize = Just 100, + rescoreQueryBody = + RescoreQuery + { rescoreQueryRescoreQuery = MatchAllQuery Nothing, + rescoreQueryQueryWeight = Just 0.5, + rescoreQueryRescoreQueryWeight = Nothing, + rescoreQueryScoreMode = Just RescoreScoreModeTotal + } + } + decode (encode r) `shouldBe` Just r + + it "uses the window_size wire key" $ do + lookupKey "window_size" (toJSON (Rescore (Just 50) (RescoreQuery (MatchAllQuery Nothing) Nothing Nothing Nothing))) + `shouldBe` Just (Number 50) + + it "uses the query wire key" $ do + hasKey "query" (toJSON (Rescore Nothing (RescoreQuery (MatchAllQuery Nothing) Nothing Nothing Nothing))) + `shouldBe` True + + describe "Search body JSON: rescore field" $ do + let base = mkSearch Nothing Nothing :: Search + + it "omits rescore when Nothing" $ do + hasKey "rescore" (toJSON base) `shouldBe` False + + it "renders rescore as a JSON array when set" $ do + let s = + base + { rescore = + Just + [ Rescore + { rescoreWindowSize = Just 10, + rescoreQueryBody = + RescoreQuery + { rescoreQueryRescoreQuery = MatchAllQuery Nothing, + rescoreQueryQueryWeight = Nothing, + rescoreQueryRescoreQueryWeight = Nothing, + rescoreQueryScoreMode = Just RescoreScoreModeAvg + } + } + ] + } + rendered = toJSON s + isRescoreArray = case lookupKey "rescore" rendered of + Just (Array _) -> True + _ -> False + isRescoreArray `shouldBe` True + + it "rescoreLens round-trips" $ do + let clause = Rescore Nothing (RescoreQuery (MatchAllQuery Nothing) Nothing Nothing Nothing) + s = mkSearch Nothing Nothing & rescoreLens ?~ [clause] + s ^. rescoreLens `shouldBe` Just [clause] + +-- --------------------------------------------------------------------------- +-- bloodhound-04f.7.1.3: collapse +-- --------------------------------------------------------------------------- + +specCollapse :: Spec +specCollapse = do + describe "CollapseInnerHits JSON instances" $ do + it "round-trips an empty config" $ do + let ih = CollapseInnerHits {collapseInnerHitsName = Nothing, collapseInnerHitsSize = Nothing, collapseInnerHitsFrom = Nothing, collapseInnerHitsCollapse = Nothing} + decode (encode ih) `shouldBe` Just ih + + it "round-trips a populated config" $ do + let ih = + CollapseInnerHits + { collapseInnerHitsName = Just "latest_per_group", + collapseInnerHitsSize = Just 3, + collapseInnerHitsFrom = Just (From 0), + collapseInnerHitsCollapse = Nothing + } + decode (encode ih) `shouldBe` Just ih + + it "uses the name and size wire keys" $ do + let ih = CollapseInnerHits {collapseInnerHitsName = Just "g1", collapseInnerHitsSize = Just 5, collapseInnerHitsFrom = Nothing, collapseInnerHitsCollapse = Nothing} + lookupKey "name" (toJSON ih) `shouldBe` Just (String "g1") + lookupKey "size" (toJSON ih) `shouldBe` Just (Number 5) + + describe "Collapse JSON instances" $ do + it "round-trips a minimal collapse" $ do + let c = + Collapse + { collapseField = FieldName "category", + collapseInnerHits = Nothing, + collapseMaxConcurrentGroupSearches = Nothing + } + decode (encode c) `shouldBe` Just c + + it "round-trips a populated collapse with inner_hits and max_concurrent" $ do + let c = + Collapse + { collapseField = FieldName "user.id", + collapseInnerHits = + Just + [ CollapseInnerHits + { collapseInnerHitsName = Just "last_tweets", + collapseInnerHitsSize = Just 5, + collapseInnerHitsFrom = Nothing, + collapseInnerHitsCollapse = Nothing + } + ], + collapseMaxConcurrentGroupSearches = Just 4 + } + decode (encode c) `shouldBe` Just c + + it "round-trips nested collapse inside inner_hits (ES-correct shape)" $ do + let innerCollapse = + Collapse + { collapseField = FieldName "user.id", + collapseInnerHits = Nothing, + collapseMaxConcurrentGroupSearches = Nothing + } + ih = + CollapseInnerHits + { collapseInnerHitsName = Just "by_location", + collapseInnerHitsSize = Just 3, + collapseInnerHitsFrom = Nothing, + collapseInnerHitsCollapse = Just innerCollapse + } + outer = + Collapse + { collapseField = FieldName "geo.country_name", + collapseInnerHits = Just [ih], + collapseMaxConcurrentGroupSearches = Nothing + } + decode (encode outer) `shouldBe` Just outer + + it "uses the field wire key" $ do + lookupKey "field" (toJSON (Collapse (FieldName "host.name") Nothing Nothing)) + `shouldBe` Just (String "host.name") + + it "uses the max_concurrent_group_searches wire key" $ do + lookupKey "max_concurrent_group_searches" (toJSON (Collapse (FieldName "x") Nothing (Just 8))) + `shouldBe` Just (Number 8) + + describe "Search body JSON: collapse field" $ do + let base = mkSearch Nothing Nothing :: Search + + it "omits collapse when Nothing" $ do + hasKey "collapse" (toJSON base) `shouldBe` False + + it "renders collapse when set" $ do + let s = base {collapse = Just (Collapse (FieldName "user.id") Nothing Nothing)} + hasKey "collapse" (toJSON s) `shouldBe` True + + it "collapseLens round-trips" $ do + let c = Collapse (FieldName "x") Nothing Nothing + s = mkSearch Nothing Nothing & collapseLens ?~ c + s ^. collapseLens `shouldBe` Just c + +-- --------------------------------------------------------------------------- +-- bloodhound-04f.5.8.1: retrievers +-- --------------------------------------------------------------------------- + +specRetriever :: Spec +specRetriever = do + describe "StandardRetriever JSON instances" $ do + it "round-trips an empty config (query=Nothing renders as omitNulls elision)" $ do + let sr = mkStandardRetriever Nothing + decode (encode sr) `shouldBe` Just sr + + it "round-trips a populated config" $ do + let sr = mkStandardRetriever (Just (MatchAllQuery Nothing)) + decode (encode sr) `shouldBe` Just sr + + it "round-trips a fully-populated config (RetrieverBase + sort/collapse/search_after/terminate_after)" $ do + let sr = + (mkStandardRetriever (Just (MatchAllQuery Nothing))) + { srBase = + emptyRetrieverBase + { rbMinScore = Just 0.5, + rbName = Just "my-standard" + }, + srSearchAfter = Just [Number 1, String "abc"], + srTerminateAfter = Just 100, + srCollapse = Just (RetrieverCollapse (object ["field" .= String "user"])), + srSort = Just (toJSON ([DefaultSortSpec (mkSort (FieldName "ts") Descending)] :: Sort)) + } + decode (encode sr) `shouldBe` Just sr + + it "uses the query wire key and does not emit fields" $ do + let sr = mkStandardRetriever (Just (MatchAllQuery Nothing)) + lookupKey "query" (toJSON sr) `shouldBe` Just (toJSON (MatchAllQuery Nothing :: Query)) + -- The ES _types.StandardRetriever has no "fields" property (it lives + -- only on RRFRetriever); pin that it is never emitted. + hasKey "fields" (toJSON sr) `shouldBe` False + + it "DECODER FIXTURE: minimal standard retriever from ES docs" $ do + -- Matches the shape in the ES Retrievers docs: + -- { "standard": { "query": { "match_all": {} } } } + -- (Retriever wrapper tested under "Retriever sum-type wire shape") + (decode "{\"query\":{\"match_all\":{}}}" :: Maybe StandardRetriever) + `shouldBe` Just (mkStandardRetriever (Just (MatchAllQuery Nothing))) + + describe "KnnRetriever JSON instances" $ do + it "round-trips a minimal config (field only)" $ do + let k = mkKnnRetriever (FieldName "embedding") + decode (encode k) `shouldBe` Just k + + it "round-trips a fully-populated config" $ do + let k = + (mkKnnRetriever (FieldName "embedding")) + { knnrQueryVector = Just [0.1, 0.2, 0.3], + knnrK = Just 5, + knnrNumCandidates = Just 50, + knnrSimilarity = Just 0.9, + knnrVisitPercentage = Just 0.2, + knnrRescoreVector = Just (RescoreVector 3.0) + } + decode (encode k) `shouldBe` Just k + + it "uses the field/query_vector/k/num_candidates wire keys" $ do + let k = (mkKnnRetriever (FieldName "v")) {knnrQueryVector = Just [0.1], knnrK = Just 5, knnrNumCandidates = Just 10} + rendered = toJSON k + lookupKey "field" rendered `shouldBe` Just (String "v") + lookupKey "query_vector" rendered `shouldBe` Just (toJSON [0.1 :: Double]) + lookupKey "k" rendered `shouldBe` Just (Number 5) + lookupKey "num_candidates" rendered `shouldBe` Just (Number 10) + -- boost and inner_hits are NOT valid on the knn retriever. + hasKey "boost" rendered `shouldBe` False + hasKey "inner_hits" rendered `shouldBe` False + + it "DECODER FIXTURE: knn retriever body from ES docs" $ do + (decode "{\"field\":\"v\",\"query_vector\":[0.1,0.2],\"k\":10,\"num_candidates\":100}" :: Maybe KnnRetriever) + `shouldBe` Just + ( (mkKnnRetriever (FieldName "v")) + { knnrQueryVector = Just [0.1, 0.2], + knnrK = Just 10, + knnrNumCandidates = Just 100 + } + ) + + describe "TextSimilarityRetriever JSON instances" $ do + it "round-trips a minimal config (inference_id omitted)" $ do + let ts = + mkTextSimilarityRetriever + (RetrieverStandard (mkStandardRetriever Nothing)) + (FieldName "semantic_text") + "what is bloodhound?" + decode (encode ts) `shouldBe` Just ts + + it "round-trips a fully-populated config (incl. chunk_rescorer)" $ do + let ts = + ( mkTextSimilarityRetriever + (RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing)))) + (FieldName "semantic_text") + "what is bloodhound?" + ) + { tsInferenceId = Just ".rerank_v1", + tsRankWindowSize = Just 100, + tsChunkRescorer = + Just + ( ChunkRescorer + { crSize = Just 2, + crChunkingSettings = + Just + ( ChunkRescorerChunkingSettings + { crcsMaxChunkSize = 250, + crcsOverlap = Just 50, + crcsSentenceOverlap = Nothing, + crcsSeparatorGroup = Nothing, + crcsSeparators = Nothing, + crcsStrategy = Just ChunkingStrategySentence + } + ) + } + ) + } + decode (encode ts) `shouldBe` Just ts + + it "uses the retriever/field/inference_text/inference_id/rank_window_size wire keys" $ do + let ts = (mkTextSimilarityRetriever (RetrieverStandard (mkStandardRetriever Nothing)) (FieldName "f") "query text") {tsInferenceId = Just "mid", tsRankWindowSize = Just 50} + rendered = toJSON ts + hasKey "retriever" rendered `shouldBe` True + lookupKey "field" rendered `shouldBe` Just (String "f") + lookupKey "inference_text" rendered `shouldBe` Just (String "query text") + lookupKey "inference_id" rendered `shouldBe` Just (String "mid") + lookupKey "rank_window_size" rendered `shouldBe` Just (Number 50) + + it "DECODER FIXTURE: text_similarity_reranker body from ES docs" $ do + ( decode + "{\"retriever\":{\"standard\":{\"query\":{\"match_all\":{}}}},\"field\":\"semantic_text\",\"inference_text\":\"what is bloodhound?\"}" :: + Maybe TextSimilarityRetriever + ) + `shouldBe` Just + ( mkTextSimilarityRetriever + (RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing)))) + (FieldName "semantic_text") + "what is bloodhound?" + ) + + it "rejects a body missing the required inference_text field" $ do + ( decode + "{\"retriever\":{\"standard\":{}},\"field\":\"f\",\"inference_id\":\".rerank\"}" :: + Maybe TextSimilarityRetriever + ) + `shouldBe` Nothing + + describe "RrfRetriever JSON instances" $ do + it "round-trips a minimal config with bare entries" $ do + let rrf = mkRrfRetriever (RrfRetrieverEntryBare (RetrieverStandard (mkStandardRetriever Nothing)) :| []) + decode (encode rrf) `shouldBe` Just rrf + + it "round-trips a fully-populated config (weighted + bare entries, query/fields)" $ do + let std = RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing))) + knn = RetrieverKnn ((mkKnnRetriever (FieldName "embedding")) {knnrQueryVector = Just [0.1, 0.2, 0.3], knnrK = Just 5}) + rrf = + ( mkRrfRetriever + ( RrfRetrieverEntryWeighted std (Just 0.6) + :| [ RrfRetrieverEntryBare knn + ] + ) + ) + { rrfRankWindowSize = Just 100, + rrfRankConstant = Just 60, + rrfQuery = Just "elastic", + rrfFields = Just [FieldName "title"] + } + decode (encode rrf) `shouldBe` Just rrf + + it "uses the retrievers / rank_window_size / rank_constant wire keys (no window_size)" $ do + let rrf = (mkRrfRetriever (RrfRetrieverEntryBare (RetrieverStandard (mkStandardRetriever Nothing)) :| [])) {rrfRankWindowSize = Just 20, rrfRankConstant = Just 60} + rendered = toJSON rrf + hasKey "retrievers" rendered `shouldBe` True + lookupKey "rank_window_size" rendered `shouldBe` Just (Number 20) + lookupKey "rank_constant" rendered `shouldBe` Just (Number 60) + hasKey "window_size" rendered `shouldBe` False + + it "rejects an empty retrievers array (NonEmpty instance)" $ do + (decode "{\"retrievers\":[]}" :: Maybe RrfRetriever) `shouldBe` Nothing + + it "RRFRetrieverEntry: bare entry decodes from a bare retriever object" $ do + (decode "{\"standard\":{\"query\":{\"match_all\":{}}}}" :: Maybe RrfRetrieverEntry) + `shouldBe` Just (RrfRetrieverEntryBare (RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing))))) + + it "RRFRetrieverEntry: weighted entry decodes from {retriever, weight}" $ do + (decode "{\"retriever\":{\"standard\":{\"query\":{\"match_all\":{}}}},\"weight\":2.0}" :: Maybe RrfRetrieverEntry) + `shouldBe` Just (RrfRetrieverEntryWeighted (RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing)))) (Just 2.0)) + + describe "RuleRetriever JSON instances" $ do + it "round-trips a populated config" $ do + let child = RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing))) + rule = mkRuleRetriever ("my-ruleset" :| []) (KM.fromList [(K.fromText "query", String "elastic")]) child + decode (encode rule) `shouldBe` Just rule + + it "DECODER FIXTURE: decodes a single-string ruleset_ids into a NonEmpty" $ do + let body = "{\"ruleset_ids\":\"rs1\",\"match_criteria\":{},\"retriever\":{\"standard\":{\"query\":{\"match_all\":{}}}}}" + expected = + mkRuleRetriever + ("rs1" :| []) + mempty + (RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing)))) + (decode body :: Maybe RuleRetriever) `shouldBe` Just expected + + it "DECODER FIXTURE: decodes an array ruleset_ids" $ do + let body = "{\"ruleset_ids\":[\"rs1\",\"rs2\"],\"match_criteria\":{\"k\":\"v\"},\"retriever\":{\"standard\":{}},\"rank_window_size\":50}" + expected = + ( mkRuleRetriever + ("rs1" :| ["rs2"]) + (KM.fromList [(K.fromText "k", String "v")]) + (RetrieverStandard (mkStandardRetriever Nothing)) + ) + { ruleRankWindowSize = Just 50 + } + (decode body :: Maybe RuleRetriever) `shouldBe` Just expected + + describe "RescorerRetriever JSON instances" $ do + it "round-trips a config with a single rescore clause" $ do + let child = RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing))) + rr = mkRescorerRetriever child (RetrieverRescore (object ["window_size" .= Number 10]) :| []) + decode (encode rr) `shouldBe` Just rr + + it "DECODER FIXTURE: decodes a single-object rescore into a NonEmpty" $ do + let body = "{\"retriever\":{\"standard\":{\"query\":{\"match_all\":{}}}},\"rescore\":{\"window_size\":10}}" + expected = + mkRescorerRetriever + (RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing)))) + (RetrieverRescore (object ["window_size" .= Number 10]) :| []) + (decode body :: Maybe RescorerRetriever) `shouldBe` Just expected + + it "DECODER FIXTURE: decodes an array rescore" $ do + let body = "{\"retriever\":{\"standard\":{}},\"rescore\":[{\"window_size\":5},{\"window_size\":10}]}" + (decode body :: Maybe RescorerRetriever) `shouldNotBe` Nothing + + describe "LinearRetriever JSON instances" $ do + it "round-trips a populated config" $ do + let child = RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing))) + entry = LinearRetrieverEntry child 0.7 MinMaxNormalizer + lin = (mkLinearRetriever [entry]) {linearRankWindowSize = Just 100, linearNormalizer = Just L2NormNormalizer} + decode (encode lin) `shouldBe` Just lin + + it "uses the retrievers/weight/normalizer wire keys per entry" $ do + let child = RetrieverStandard (mkStandardRetriever Nothing) + rendered = toJSON (LinearRetrieverEntry child 0.5 NoNormalizer) + hasKey "retriever" rendered `shouldBe` True + lookupKey "weight" rendered `shouldBe` Just (Number 0.5) + lookupKey "normalizer" rendered `shouldBe` Just (String "none") + + it "ScoreNormalizer round-trips every constructor" $ do + decode (encode NoNormalizer) `shouldBe` Just NoNormalizer + decode (encode MinMaxNormalizer) `shouldBe` Just MinMaxNormalizer + decode (encode L2NormNormalizer) `shouldBe` Just L2NormNormalizer + + describe "PinnedRetriever JSON instances" $ do + it "round-trips a config with ids + docs" $ do + let Right idx = mkIndexName "my-index" + child = RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing))) + pin = + (mkPinnedRetriever child) + { pinnedIds = Just ["doc1", "doc2"], + pinnedDocs = Just [SpecifiedDocument (Just idx) (DocId "doc3")], + pinnedRankWindowSize = Just 50 + } + decode (encode pin) `shouldBe` Just pin + + it "SpecifiedDocument renders _id and _index wire keys" $ do + let Right idx = mkIndexName "my-index" + rendered = toJSON (SpecifiedDocument (Just idx) (DocId "doc1")) + lookupKey "_id" rendered `shouldBe` Just (String "doc1") + lookupKey "_index" rendered `shouldBe` Just (String "my-index") + + describe "DiversifyRetriever JSON instances" $ do + it "round-trips a fully-populated MMR config" $ do + let child = RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing))) + div = + (mkDiversifyRetriever (FieldName "category") child) + { diversifySize = Just 10, + diversifyRankWindowSize = Just 100, + diversifyQueryVector = Just [0.1, 0.2], + diversifyLambda = Just 0.5 + } + decode (encode div) `shouldBe` Just div + + it "DiversifyType renders and parses mmr" $ do + toJSON DiversifyMMR `shouldBe` String "mmr" + decode "\"mmr\"" `shouldBe` Just DiversifyMMR + (decode "\"unknown\"" :: Maybe DiversifyType) `shouldBe` Nothing + + describe "Retriever sum-type wire shape" $ do + it "ENCODER FIXTURE: standard retriever renders as the ES-doc shape" $ do + decode (encode (RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing))))) + `shouldBe` ( decode + "{\"standard\":{\"query\":{\"match_all\":{}}}}" :: + Maybe Value + ) + + it "ENCODER FIXTURE: rrf retriever renders as the ES-doc shape" $ do + let rrf = + RetrieverRRF + ( mkRrfRetriever + ( RrfRetrieverEntryBare + (RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing)))) + :| [ RrfRetrieverEntryBare + ( RetrieverKnn + ( (mkKnnRetriever (FieldName "my-vector")) + { knnrQueryVector = Just [0.1, 0.2], + knnrK = Just 10 + } + ) + ) + ] + ) + ) + { rrfRankWindowSize = Just 50, + rrfRankConstant = Just 60 + } + decode (encode rrf) + `shouldBe` ( decode + ( "{\"rrf\":" + <> "{\"retrievers\":[" + <> "{\"standard\":{\"query\":{\"match_all\":{}}}}," + <> "{\"knn\":{\"field\":\"my-vector\",\"query_vector\":[0.1,0.2],\"k\":10}}" + <> "]," + <> "\"rank_window_size\":50," + <> "\"rank_constant\":60" + <> "}}" + ) :: + Maybe Value + ) + + it "DECODER FIXTURE: standard retriever decodes from canonical ES JSON" $ do + (decode "{\"standard\":{\"query\":{\"match_all\":{}}}}" :: Maybe Retriever) + `shouldBe` Just (RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing)))) + + it "DECODER FIXTURE: text_similarity_reranker uses the post-8.14 key (not text_similarity)" $ do + let body = + "{\"text_similarity_reranker\":{\"retriever\":{\"standard\":{\"query\":{\"match_all\":{}}}},\"field\":\"semantic_text\",\"inference_text\":\"q\"}}" + (decode body :: Maybe Retriever) + `shouldBe` Just + ( RetrieverTextSimilarity + ( mkTextSimilarityRetriever + (RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing)))) + (FieldName "semantic_text") + "q" + ) + ) + + it "DECODER FIXTURE: rule retriever decodes from canonical ES JSON" $ do + let body = + "{\"rule\":{\"ruleset_ids\":\"rs\",\"match_criteria\":{},\"retriever\":{\"standard\":{\"query\":{\"match_all\":{}}}}}}" + (decode body :: Maybe Retriever) + `shouldBe` Just + ( RetrieverRule + ( mkRuleRetriever + ("rs" :| []) + mempty + (RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing)))) + ) + ) + + it "DECODER FIXTURE: linear retriever decodes from canonical ES JSON" $ do + let body = + "{\"linear\":{\"retrievers\":[{\"retriever\":{\"standard\":{\"query\":{\"match_all\":{}}}},\"weight\":1.0,\"normalizer\":\"none\"}]}}" + (decode body :: Maybe Retriever) + `shouldNotBe` Nothing + + it "DECODER FIXTURE: pinned retriever decodes from canonical ES JSON" $ do + let body = + "{\"pinned\":{\"retriever\":{\"standard\":{\"query\":{\"match_all\":{}}}},\"ids\":[\"a\",\"b\"]}}" + (decode body :: Maybe Retriever) `shouldNotBe` Nothing + + it "DECODER FIXTURE: diversify retriever decodes from canonical ES JSON" $ do + let body = + "{\"diversify\":{\"type\":\"mmr\",\"field\":\"cat\",\"retriever\":{\"standard\":{\"query\":{\"match_all\":{}}}},\"lambda\":0.5}}" + (decode body :: Maybe Retriever) `shouldNotBe` Nothing + + it "REJECTS the pre-8.14 text_similarity key (renamed to text_similarity_reranker)" $ do + let body = + "{\"text_similarity\":{\"retriever\":{\"standard\":{}},\"field\":\"f\",\"inference_text\":\"q\"}}" + (decode body :: Maybe Retriever) `shouldBe` Nothing + + it "rejects the legacy text_expansion key (not a retriever type in modern ES)" $ do + -- text_expansion is a Query DSL clause, not a retriever; it must + -- be wrapped inside a standard retriever's `query` field instead. + -- Verified against the ES9 OpenAPI spec + -- (_types.RetrieverContainer does not list text_expansion). + (decode "{\"text_expansion\":{\"query\":{}}}" :: Maybe Retriever) `shouldBe` Nothing + + it "rejects an unknown retriever tag" $ do + (decode "{\"unknown\":{}}" :: Maybe Retriever) `shouldBe` Nothing + + it "rejects a multi-key object" $ do + (decode "{\"standard\":{},\"rrf\":{}}" :: Maybe Retriever) `shouldBe` Nothing + + it "round-trips every constructor through ToJSON/FromJSON" $ do + let standard = RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing))) + knn = RetrieverKnn ((mkKnnRetriever (FieldName "embedding")) {knnrQueryVector = Just [0.1, 0.2, 0.3], knnrK = Just 5}) + rrfInner = (mkRrfRetriever (RrfRetrieverEntryBare standard :| [RrfRetrieverEntryBare knn])) {rrfRankWindowSize = Just 100, rrfRankConstant = Just 60} + rrf = RetrieverRRF rrfInner + tsInner = (mkTextSimilarityRetriever standard (FieldName "sem") "query text") {tsInferenceId = Just ".rerank", tsRankWindowSize = Just 100} + ts = RetrieverTextSimilarity tsInner + rule = RetrieverRule (mkRuleRetriever ("rs" :| []) mempty standard) + rescorer = RetrieverRescorer (mkRescorerRetriever standard (RetrieverRescore (object ["window_size" .= Number 10]) :| [])) + lin = RetrieverLinear (mkLinearRetriever [LinearRetrieverEntry standard 1.0 NoNormalizer]) + pin = RetrieverPinned ((mkPinnedRetriever standard) {pinnedIds = Just ["a"]}) + div = RetrieverDiversify ((mkDiversifyRetriever (FieldName "c") standard) {diversifyLambda = Just 0.5}) + decode (encode standard) `shouldBe` Just standard + decode (encode knn) `shouldBe` Just knn + decode (encode rrf) `shouldBe` Just rrf + decode (encode ts) `shouldBe` Just ts + decode (encode rule) `shouldBe` Just rule + decode (encode rescorer) `shouldBe` Just rescorer + decode (encode lin) `shouldBe` Just lin + decode (encode pin) `shouldBe` Just pin + decode (encode div) `shouldBe` Just div + + it "round-trips a 3-level nested tree (RRF(weighted) -> rule -> standard)" $ do + let leaf = RetrieverStandard (mkStandardRetriever (Just (MatchAllQuery Nothing))) + rule = RetrieverRule (mkRuleRetriever ("rs" :| []) mempty leaf) + tree = + RetrieverRRF + ( mkRrfRetriever + (RrfRetrieverEntryWeighted leaf (Just 0.5) :| [RrfRetrieverEntryBare rule]) + ) + decode (encode tree) `shouldBe` Just tree + + describe "Search body JSON: retriever field" $ do + let base = mkSearch Nothing Nothing :: Search + + it "omits retriever when Nothing" $ do + hasKey "retriever" (toJSON base) `shouldBe` False + + it "renders retriever when set" $ do + let s = base {retriever = Just (RetrieverStandard (mkStandardRetriever Nothing))} + hasKey "retriever" (toJSON s) `shouldBe` True + + it "mkSearch default shape is still byte-identical (retriever elided by omitNulls)" $ do + encode (mkSearch Nothing Nothing :: Search) + `shouldBe` "{\"from\":0,\"size\":10,\"track_scores\":false}" + + it "retrieverLens round-trips" $ do + let r = RetrieverStandard (mkStandardRetriever Nothing) + s = mkSearch Nothing Nothing & retrieverLens ?~ r + s ^. retrieverLens `shouldBe` Just r + + it "retrieverLens defaults to Nothing in mkSearch output" $ do + let s = mkSearch Nothing Nothing :: Search + s ^. retrieverLens `shouldBe` Nothing diff --git a/tests/Test/SearchIntegrationSpec.hs b/tests/Test/SearchIntegrationSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SearchIntegrationSpec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.SearchIntegrationSpec (spec) where + +import Data.List.NonEmpty qualified as NE +import TestsUtils.Common +import TestsUtils.Import + +-- | Live integration coverage for the @searchByIndexWith@ \/ @searchAllWith@ +-- \/ @searchByIndicesWith@ family. These tests verify that 'SearchOptions' +-- are accepted by a real backend (the params themselves are unit-tested in +-- "Test.SearchOptionsSpec"). Each case asserts that the same document that +-- 'searchByIndex' finds is also found when extra URI params are attached — +-- i.e. the params don't break the request envelope. +spec :: Spec +spec = + describe "Search *With URI params (integration)" $ do + it "searchByIndexWith defaultSearchOptions matches searchByIndex" $ + withTestEnv $ do + _ <- insertData + let query = TermQuery (Term "user" "bitemyapp") Nothing + let search = mkSearch (Just query) Nothing + withDefault <- performBHRequest $ searchByIndexWith @Tweet testIndex defaultSearchOptions search + plain <- performBHRequest $ searchByIndex testIndex search + liftIO $ + (hitSource <$> headMay (hits (searchHits withDefault))) + `shouldBe` (hitSource <$> headMay (hits (searchHits plain))) + + it "searchByIndexWith accepts preference and request_cache" $ + withTestEnv $ do + _ <- insertData + let query = TermQuery (Term "user" "bitemyapp") Nothing + let search = mkSearch (Just query) Nothing + let opts = + defaultSearchOptions + { soPreference = Just "_local", + soRequestCache = Just True + } + myTweet <- (>>= grabFirst) <$> tryPerformBHRequest (searchByIndexWith @Tweet testIndex opts search) + liftIO $ + myTweet `shouldBe` Right exampleTweet + + it "searchByIndexWith accepts typed_keys and seq_no_primary_term" $ + withTestEnv $ do + _ <- insertData + let search = mkSearch Nothing Nothing + let opts = + defaultSearchOptions + { soTypedKeys = Just True, + soSeqNoPrimaryTerm = Just True + } + result <- tryPerformBHRequest (searchByIndexWith @Tweet testIndex opts search) + liftIO $ + result `shouldSatisfy` isRight + + it "searchByIndicesWith searches across multiple indices" $ + withTestEnv $ do + _ <- insertData + let search = mkSearch Nothing Nothing + result <- tryPerformBHRequest (searchByIndicesWith @Tweet (testIndex NE.:| []) defaultSearchOptions search) + liftIO $ + result `shouldSatisfy` isRight + + it "searchAllWith searches every index" $ + withTestEnv $ do + _ <- insertData + let search = mkSearch Nothing Nothing + -- Decode as Value: /_search returns hits from system indices + -- (e.g. .tasks) whose _source is not Tweet-shaped. The point of + -- this case is to verify the request envelope is accepted. + result <- tryPerformBHRequest (searchAllWith @Value defaultSearchOptions search) + liftIO $ + result `shouldSatisfy` isRight diff --git a/tests/Test/SearchOptionsSpec.hs b/tests/Test/SearchOptionsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SearchOptionsSpec.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SearchOptionsSpec (spec) where + +import Data.List (sort) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Maybe (isJust) +import Data.Text (Text) +import Database.Bloodhound.Common.Requests (searchOptionsParams) +import Database.Bloodhound.Common.Types +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +-- | Stable ordering for equality: 'withQueries' preserves the order in +-- which params are emitted, but the tests compare the @Set@ of params to +-- avoid coupling to internal field ordering of 'SearchOptions'. +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + +spec :: Spec +spec = + describe "SearchOptions URI param rendering" $ do + it "defaultSearchOptions emits no params with the default SearchType" $ do + searchOptionsParams defaultSearchOptions SearchTypeQueryThenFetch + `shouldBe` [] + + it "defaultSearchOptions + DfsQueryThenFetch emits only search_type" $ do + searchOptionsParams defaultSearchOptions SearchTypeDfsQueryThenFetch + `shouldBe` [("search_type", Just "dfs_query_then_fetch")] + + it "emits search_type even when other params are set" $ do + let opts = + defaultSearchOptions + { soPreference = Just "_local" + } + normalize (searchOptionsParams opts SearchTypeDfsQueryThenFetch) + `shouldBe` [ ("preference", Just "_local"), + ("search_type", Just "dfs_query_then_fetch") + ] + + it "renders every Bool field as true/false strings" $ do + let opts = + defaultSearchOptions + { soAllowNoIndices = Just True, + soIgnoreUnavailable = Just False, + soRequestCache = Just True, + soTypedKeys = Just False, + soSeqNoPrimaryTerm = Just True, + soCcsMinimizeRoundtrips = Just False, + soAllowPartialSearchResults = Just True + } + normalize (searchOptionsParams opts SearchTypeQueryThenFetch) + `shouldBe` [ ("allow_no_indices", Just "true"), + ("allow_partial_search_results", Just "true"), + ("ccs_minimize_roundtrips", Just "false"), + ("ignore_unavailable", Just "false"), + ("request_cache", Just "true"), + ("seq_no_primary_term", Just "true"), + ("typed_keys", Just "false") + ] + + it "renders every Int field as decimal strings" $ do + let opts = + defaultSearchOptions + { soMaxConcurrentShardRequests = Just 16, + soBatchedReduceSize = Just 512, + soPreFilterShardSize = Just 128, + soMaxConcurrentSearches = Just 4 + } + normalize (searchOptionsParams opts SearchTypeQueryThenFetch) + `shouldBe` [ ("batched_reduce_size", Just "512"), + ("max_concurrent_searches", Just "4"), + ("max_concurrent_shard_requests", Just "16"), + ("pre_filter_shard_size", Just "128") + ] + + it "renders expand_wildcards as a comma-separated list of values" $ do + let opts = + defaultSearchOptions + { soExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + searchOptionsParams opts SearchTypeQueryThenFetch + `shouldBe` [("expand_wildcards", Just "open,closed")] + + it "renders a single expand_wildcards value without a trailing comma" $ do + let opts = + defaultSearchOptions + { soExpandWildcards = Just (ExpandWildcardsAll :| []) + } + searchOptionsParams opts SearchTypeQueryThenFetch + `shouldBe` [("expand_wildcards", Just "all")] + + it "renders preference and routing verbatim" $ do + let opts = + defaultSearchOptions + { soPreference = Just "_only_local", + soRouting = Just "route1,route2" + } + normalize (searchOptionsParams opts SearchTypeQueryThenFetch) + `shouldBe` [ ("preference", Just "_only_local"), + ("routing", Just "route1,route2") + ] + + it "renders _source as a true/false string" $ do + let opts = defaultSearchOptions {soSource = Just False} + searchOptionsParams opts SearchTypeQueryThenFetch + `shouldBe` [("_source", Just "false")] + + it "renders _source_includes and _source_excludes verbatim" $ do + let opts = + defaultSearchOptions + { soSourceIncludes = Just "metadata.*,name", + soSourceExcludes = Just "internal.*" + } + normalize (searchOptionsParams opts SearchTypeQueryThenFetch) + `shouldBe` [ ("_source_excludes", Just "internal.*"), + ("_source_includes", Just "metadata.*,name") + ] + + it "renders cancel_after_time_interval as " $ do + let opts = + defaultSearchOptions + { soCancelAfterTimeInterval = Just (TimeUnitSeconds, 5) + } + searchOptionsParams opts SearchTypeQueryThenFetch + `shouldBe` [("cancel_after_time_interval", Just "5s")] + + it "supports every TimeUnits suffix" $ do + let mk u = searchOptionsParams defaultSearchOptions {soCancelAfterTimeInterval = Just (u, 1)} SearchTypeQueryThenFetch + mk TimeUnitDays `shouldBe` [("cancel_after_time_interval", Just "1d")] + mk TimeUnitHours `shouldBe` [("cancel_after_time_interval", Just "1h")] + mk TimeUnitMinutes `shouldBe` [("cancel_after_time_interval", Just "1m")] + mk TimeUnitSeconds `shouldBe` [("cancel_after_time_interval", Just "1s")] + mk TimeUnitMilliseconds `shouldBe` [("cancel_after_time_interval", Just "1ms")] + mk TimeUnitMicroseconds `shouldBe` [("cancel_after_time_interval", Just "1micros")] + mk TimeUnitNanoseconds `shouldBe` [("cancel_after_time_interval", Just "1nanos")] + + it "emits the full param set when every field is populated" $ do + let opts = + defaultSearchOptions + { soAllowNoIndices = Just True, + soExpandWildcards = Just (ExpandWildcardsOpen :| []), + soIgnoreUnavailable = Just True, + soPreference = Just "_local", + soRouting = Just "r1", + soRequestCache = Just False, + soTypedKeys = Just True, + soSeqNoPrimaryTerm = Just True, + soMaxConcurrentShardRequests = Just 5, + soBatchedReduceSize = Just 128, + soCcsMinimizeRoundtrips = Just True, + soAllowPartialSearchResults = Just False, + soPreFilterShardSize = Just 128, + soCancelAfterTimeInterval = Just (TimeUnitSeconds, 3), + soMaxConcurrentSearches = Just 8, + soSource = Just True, + soSourceIncludes = Just "a,b", + soSourceExcludes = Just "c" + } + -- Use DfsQueryThenFetch to verify search_type is included exactly + -- once alongside the 18 SearchOptions keys, locking both the count + -- and the exact wire key set. + let rendered = searchOptionsParams opts SearchTypeDfsQueryThenFetch + length rendered `shouldBe` 19 + rendered `shouldSatisfy` all (isJust . snd) + sort (map fst rendered) + `shouldBe` sort + [ "_source", + "_source_excludes", + "_source_includes", + "allow_no_indices", + "allow_partial_search_results", + "batched_reduce_size", + "cancel_after_time_interval", + "ccs_minimize_roundtrips", + "expand_wildcards", + "ignore_unavailable", + "max_concurrent_searches", + "max_concurrent_shard_requests", + "pre_filter_shard_size", + "preference", + "request_cache", + "routing", + "search_type", + "seq_no_primary_term", + "typed_keys" + ] diff --git a/tests/Test/SearchShardsSpec.hs b/tests/Test/SearchShardsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SearchShardsSpec.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-x-partial #-} + +module Test.SearchShardsSpec (spec) where + +import Data.Aeson (Value (..), decode) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as BL8 +import Data.Map.Strict qualified as M +import Database.Bloodhound.Common.Requests qualified as Requests + ( getSearchShards, + getSearchShardsWith, + ) +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + describe "SearchShardsResponse JSON" $ do + it "decodes the canonical ES doc example with one STARTED primary" $ + let bytes = + BL8.pack + "{\"nodes\":{\"CBH3C4RiQcK3CxFvPJyFtQ\":{\"name\":\"elasticsearch1\",\"ephemeral_id\":\"DGt8SykXTlWz3GEQtdNfUA\",\"transport_address\":\"172.19.0.6:9300\",\"attributes\":{\"ml.machine_memory\":\"2147483648\"},\"roles\":[\"data\",\"master\"]}},\"indices\":{\"bloodhound-tests-twitter-gettask-opts\":{}},\"shards\":[[{\"state\":\"STARTED\",\"primary\":true,\"node\":\"CBH3C4RiQcK3CxFvPJyFtQ\",\"relocating_node\":null,\"shard\":0,\"index\":\"bloodhound-tests-twitter-gettask-opts\",\"allocation_id\":{\"id\":\"A4BybQlTS_mWcfqMiOR2zg\"}}]]}" + Just resp = decode bytes + nodes = searchShardsResponseNodes resp + Just (firstShardCopies : _) = Just (searchShardsResponseShards resp) + firstShard = head firstShardCopies + Just nodeId = searchShardsShardNode firstShard + Just nodeInfo = M.lookup nodeId nodes + in do + M.size nodes `shouldBe` 1 + searchShardsNodeName nodeInfo `shouldBe` Just "elasticsearch1" + searchShardsNodeTransportAddress nodeInfo `shouldBe` Just "172.19.0.6:9300" + searchShardsNodeRoles nodeInfo `shouldBe` Just ["data", "master"] + M.size (searchShardsResponseIndices resp) `shouldBe` 1 + searchShardsShardState firstShard `shouldBe` SearchShardsStateStarted + searchShardsShardPrimary firstShard `shouldBe` True + searchShardsShardRelocatingNode firstShard `shouldBe` Nothing + searchShardsShardAllocationId firstShard + `shouldBe` Just (M.singleton "id" "A4BybQlTS_mWcfqMiOR2zg") + unIndexName (searchShardsShardIndex firstShard) + `shouldBe` "bloodhound-tests-twitter-gettask-opts" + + it "decodes a response with empty nodes/indices/shards (no matching index)" $ + let bytes = BL8.pack "{\"nodes\":{},\"indices\":{},\"shards\":[]}" + Just resp = decode bytes :: Maybe SearchShardsResponse + in do + M.null (searchShardsResponseNodes resp) `shouldBe` True + M.null (searchShardsResponseIndices resp) `shouldBe` True + searchShardsResponseShards resp `shouldBe` [] + + it "treats missing nodes/indices/shards fields as empty" $ + let bytes = BL8.pack "{}" + Just resp = decode bytes :: Maybe SearchShardsResponse + in do + M.null (searchShardsResponseNodes resp) `shouldBe` True + M.null (searchShardsResponseIndices resp) `shouldBe` True + searchShardsResponseShards resp `shouldBe` [] + + it "decodes an unassigned shard (state=UNASSIGNED, node=null)" $ + let bytes = + BL8.pack + "{\"nodes\":{},\"indices\":{\"foo\":{}},\"shards\":[[{\"state\":\"UNASSIGNED\",\"primary\":false,\"node\":null,\"relocating_node\":null,\"shard\":1,\"index\":\"foo\"}]]}" + Just resp = decode bytes :: Maybe SearchShardsResponse + Just (copy : _) = Just (searchShardsResponseShards resp) + shard = head copy + in do + searchShardsShardState shard `shouldBe` SearchShardsStateUnassigned + searchShardsShardNode shard `shouldBe` Nothing + searchShardsShardPrimary shard `shouldBe` False + + it "preserves unknown sibling fields on a shard copy via searchShardsShardOther" $ + let bytes = + BL8.pack + "{\"nodes\":{},\"indices\":{\"foo\":{}},\"shards\":[[{\"state\":\"STARTED\",\"primary\":true,\"node\":\"n1\",\"relocating_node\":null,\"shard\":0,\"index\":\"foo\",\"allocation_id\":{\"id\":\"x\"},\"future_field\":42}]]}" + Just resp = decode bytes :: Maybe SearchShardsResponse + Just (copy : _) = Just (searchShardsResponseShards resp) + shard = head copy + Just (Object other) = searchShardsShardOther shard + in KM.size other `shouldSatisfy` (>= 1) + + it "preserves unknown sibling fields on a node via searchShardsNodeOther" $ + let bytes = + BL8.pack + "{\"nodes\":{\"n1\":{\"name\":\"n\",\"future_attr\":\"x\"}},\"indices\":{},\"shards\":[]}" + Just resp = decode bytes :: Maybe SearchShardsResponse + Just nodeInfo = M.lookup "n1" (searchShardsResponseNodes resp) + Just (Object other) = searchShardsNodeOther nodeInfo + in do + searchShardsNodeName nodeInfo `shouldBe` Just "n" + KM.size other `shouldSatisfy` (>= 1) + + it "round-trips an unknown shard state through SearchShardsStateOther" $ + let bytes = + BL8.pack + "{\"nodes\":{},\"indices\":{\"foo\":{}},\"shards\":[[{\"state\":\"WEIRD\",\"primary\":true,\"node\":\"n1\",\"relocating_node\":null,\"shard\":0,\"index\":\"foo\"}]]}" + Just resp = decode bytes :: Maybe SearchShardsResponse + Just (copy : _) = Just (searchShardsResponseShards resp) + shard = head copy + in searchShardsShardState shard `shouldBe` SearchShardsStateOther "WEIRD" + + describe "SearchShardsOptions params" $ do + it "renders nothing for defaultSearchShardsOptions" $ + searchShardsOptionsParams defaultSearchShardsOptions `shouldBe` [] + + it "renders local as a boolean string" $ + let opts = defaultSearchShardsOptions {sshoLocal = Just True} + in lookup "local" (searchShardsOptionsParams opts) `shouldBe` Just (Just "true") + + it "renders allow_no_indices as a boolean string" $ + let opts = defaultSearchShardsOptions {sshoAllowNoIndices = Just False} + in lookup "allow_no_indices" (searchShardsOptionsParams opts) + `shouldBe` Just (Just "false") + + it "renders expand_wildcards comma-joined" $ + let opts = + defaultSearchShardsOptions + { sshoExpandWildcards = Just [ExpandWildcardsOpen, ExpandWildcardsClosed] + } + in lookup "expand_wildcards" (searchShardsOptionsParams opts) + `shouldBe` Just (Just "open,closed") + + it "renders preference verbatim" $ + let opts = defaultSearchShardsOptions {sshoPreference = Just "_primary"} + in lookup "preference" (searchShardsOptionsParams opts) `shouldBe` Just (Just "_primary") + + it "renders routing comma-joined" $ + let opts = defaultSearchShardsOptions {sshoRouting = Just ["a", "b"]} + in lookup "routing" (searchShardsOptionsParams opts) `shouldBe` Just (Just "a,b") + + it "renders master_timeout via timeUnitsSuffix" $ + let opts = defaultSearchShardsOptions {sshoMasterTimeout = Just (TimeUnitSeconds, 30)} + in lookup "master_timeout" (searchShardsOptionsParams opts) `shouldBe` Just (Just "30s") + + it "omits master_timeout by default" $ + lookup "master_timeout" (searchShardsOptionsParams defaultSearchShardsOptions) + `shouldBe` Nothing + + describe "Search Shards endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "POSTs /_search_shards with no body" $ do + let req = Requests.getSearchShards Nothing + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_search_shards"] + bhRequestBody req `shouldBe` Nothing + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "treats Just [] the same as Nothing (single _search_shards segment)" $ do + let reqNo = Requests.getSearchShards Nothing + reqEmpty = Requests.getSearchShards (Just []) + getRawEndpoint (bhRequestEndpoint reqNo) + `shouldBe` getRawEndpoint (bhRequestEndpoint reqEmpty) + + it "comma-joins a non-empty index list into the leading segment" $ do + let req = Requests.getSearchShards (Just [[qqIndexName|twitter-1|], [qqIndexName|twitter-2|]]) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["twitter-1,twitter-2", "_search_shards"] + + it "honours SearchShardsOptions in the query string" $ do + let req = + Requests.getSearchShardsWith + (Just [[qqIndexName|twitter-1|]]) + defaultSearchShardsOptions {sshoPreference = Just "_primary"} + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("preference", Just "_primary")] + + describe "Search Shards endpoint" $ do + it "returns at least one assigned primary shard for the test index" $ + withTestEnv $ do + _ <- insertData + resp <- performBHRequest $ getSearchShards (Just [testIndex]) + liftIO $ do + let shards = searchShardsResponseShards resp + shards `shouldSatisfy` (not . null) + let allShards = concat shards + allShards `shouldSatisfy` any searchShardsShardPrimary + let testIndexShards = + filter + ((==) (unIndexName testIndex) . unIndexName . searchShardsShardIndex) + allShards + testIndexShards `shouldSatisfy` (not . null) + + it "exposes a node entry for every assigned shard's node id" $ + withTestEnv $ do + _ <- insertData + resp <- performBHRequest $ getSearchShards (Just [testIndex]) + liftIO $ do + let nodes = searchShardsResponseNodes resp + assignedNodeIds = + [ nid + | copy <- concat (searchShardsResponseShards resp), + Just nid <- [searchShardsShardNode copy] + ] + uniqueNodeIds = uniq assignedNodeIds + uniqueNodeIds `shouldSatisfy` (not . null) + mapM_ (\nid -> M.member nid nodes `shouldBe` True) uniqueNodeIds + + it "passes preference and routing via SearchShardsOptions without error" $ + withTestEnv $ do + _ <- insertData + resp <- + performBHRequest $ + getSearchShardsWith + (Just [testIndex]) + defaultSearchShardsOptions + { sshoPreference = Just "_local", + sshoRouting = Just ["user_1"] + } + liftIO $ + searchShardsResponseShards resp `shouldSatisfy` (not . null) + +-- | Local helper because we cannot use the lens from the module under +-- test in two different roles easily without an explicit accessor. +uniq :: (Eq a) => [a] -> [a] +uniq = go [] + where + go _ [] = [] + go seen (x : xs) + | x `elem` seen = go seen xs + | otherwise = x : go (x : seen) xs diff --git a/tests/Test/SearchableSnapshotsSpec.hs b/tests/Test/SearchableSnapshotsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SearchableSnapshotsSpec.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.SearchableSnapshotsSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Import +import Prelude + +-- | A representative mount request body carrying the required @index@ +-- plus the three documented optional fields. +sampleMountBodyBytes :: LBS.ByteString +sampleMountBodyBytes = + "{\ + \ \"index\": \"fs\",\ + \ \"renamed_index\": \"fs-mounted\",\ + \ \"index_settings\": {\"index.number_of_replicas\": 0},\ + \ \"ignore_index_settings\": [\"index.refresh_interval\"]\ + \}" + +spec :: Spec +spec = describe "Searchable Snapshots API" $ do + describe "SearchableSnapshotMount JSON (POST body)" $ do + it "decodes the documented fields" $ do + let Just decoded = decode sampleMountBodyBytes :: Maybe SearchableSnapshotMount + unIndexName (ssmIndex decoded) `shouldBe` "fs" + ssmRenamedIndex decoded `shouldBe` Just "fs-mounted" + ssmIgnoreIndexSettings decoded `shouldBe` Just ["index.refresh_interval"] + + it "requires the 'index' field" $ do + let decoded = decode "{\"renamed_index\": \"x\"}" :: Maybe SearchableSnapshotMount + decoded `shouldBe` Nothing + + it "tolerates missing optional fields" $ do + let Just decoded = decode "{\"index\": \"only\"}" :: Maybe SearchableSnapshotMount + unIndexName (ssmIndex decoded) `shouldBe` "only" + ssmRenamedIndex decoded `shouldBe` Nothing + ssmIgnoreIndexSettings decoded `shouldBe` Nothing + ssmExtras decoded `shouldBe` KM.empty + + it "preserves unknown sibling fields in extras (forward-compatible)" $ do + let bytes = encode (object ["index" .= String "idx", "future_field" .= (3 :: Int)]) + Just decoded = decode bytes :: Maybe SearchableSnapshotMount + unIndexName (ssmIndex decoded) `shouldBe` "idx" + KM.toList (ssmExtras decoded) `shouldSatisfy` any ((== "future_field") . fst) + -- full round-trip must survive (extras carry through encode too) + (decode . encode) decoded `shouldBe` Just decoded + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode sampleMountBodyBytes :: Maybe SearchableSnapshotMount + (decode . encode) decoded `shouldBe` Just decoded + + describe "SearchableSnapshotStorage JSON" $ do + it "round-trips the documented storage modes" $ do + encode SearchableSnapshotStorageSharedPartialCache + `shouldBe` "\"shared_partial_cache\"" + encode SearchableSnapshotStorageSharedCache + `shouldBe` "\"shared_cache\"" + decode "\"shared_partial_cache\"" + `shouldBe` Just SearchableSnapshotStorageSharedPartialCache + decode "\"shared_cache\"" + `shouldBe` Just SearchableSnapshotStorageSharedCache + + it "absorbs an unknown value into the custom branch" $ do + let Just decoded = decode "\"future_mode\"" :: Maybe SearchableSnapshotStorage + decoded `shouldBe` SearchableSnapshotStorageCustom "future_mode" + + describe "SearchableSnapshotMountOptions params" $ do + it "default options render no query string" $ do + searchableSnapshotMountOptionsParams defaultSearchableSnapshotMountOptions + `shouldBe` [] + + it "renders all three parameters when set" $ do + let opts = + defaultSearchableSnapshotMountOptions + { ssmoMasterTimeout = Just "30s", + ssmoWaitForCompletion = Just False, + ssmoStorage = Just SearchableSnapshotStorageSharedCache + } + searchableSnapshotMountOptionsParams opts + `shouldMatchList` [ ("master_timeout", Just "30s"), + ("wait_for_completion", Just "false"), + ("storage", Just "shared_cache") + ] + + it "omits Nothing fields" $ do + let opts = defaultSearchableSnapshotMountOptions {ssmoWaitForCompletion = Just True} + searchableSnapshotMountOptionsParams opts + `shouldBe` [("wait_for_completion", Just "true")] + + describe "SearchableSnapshotMountResponse JSON" $ do + it "decodes the wait_for_completion=true shape (snapshot object)" $ do + let bytes = encode (object ["snapshot" .= object ["snapshot" .= String "snap-1"]]) + Just decoded = decode bytes :: Maybe SearchableSnapshotMountResponse + ssmrSnapshot decoded `shouldSatisfy` isJust + + it "captures the wait_for_completion=false ack shape in extras" $ do + let bytes = + encode + ( object + [ "acknowledged" .= True, + "shards_acknowledged" .= True + ] + ) + Just decoded = decode bytes :: Maybe SearchableSnapshotMountResponse + ssmrSnapshot decoded `shouldBe` Nothing + KM.toList (ssmrExtras decoded) + `shouldSatisfy` any ((== "acknowledged") . fst) + + it "round-trips through ToJSON/FromJSON" $ do + let resp = + SearchableSnapshotMountResponse + { ssmrSnapshot = Just (object ["snapshot" .= String "s"]), + ssmrExtras = KM.empty + } + (decode . encode) resp `shouldBe` Just resp + + describe "SearchableSnapshotsStatsResponse JSON" $ do + it "decodes total/indices and tolerates absent nodes" $ do + let bytes = + encode + ( object + [ "total" .= object ["file_cache_size" .= (1024 :: Int)], + "indices" .= object ["fs" .= object ["local" .= object []]] + ] + ) + Just decoded = decode bytes :: Maybe SearchableSnapshotsStatsResponse + sssrTotal decoded `shouldSatisfy` isJust + sssrIndices decoded `shouldSatisfy` isJust + sssrNodes decoded `shouldBe` Nothing + + it "round-trips through ToJSON/FromJSON" $ do + let resp = + SearchableSnapshotsStatsResponse + { sssrTotal = Just (object []), + sssrIndices = Just (KM.singleton "fs" (object [])), + sssrNodes = Nothing, + sssrExtras = KM.empty + } + (decode . encode) resp `shouldBe` Just resp + + it "preserves extras carrying null/empty-array values (forward-compat)" $ do + -- omitNulls would silently drop these; 'object' must keep them. + let resp = + SearchableSnapshotsStatsResponse + { sssrTotal = Nothing, + sssrIndices = Nothing, + sssrNodes = Nothing, + sssrExtras = + KM.fromList + [ ("deprecated_field", Null), + ("empty_warnings", Array mempty) + ] + } + (decode . encode) resp `shouldBe` Just resp + + describe "SearchableSnapshotsCacheStatsResponse JSON" $ do + it "decodes the indices map" $ do + let bytes = encode (object ["indices" .= object ["fs" .= object []]]) + Just decoded = decode bytes :: Maybe SearchableSnapshotsCacheStatsResponse + sscsrIndices decoded `shouldSatisfy` isJust + + it "round-trips through ToJSON/FromJSON" $ do + let resp = + SearchableSnapshotsCacheStatsResponse + { sscsrIndices = Just (KM.singleton "fs" (object [])), + sscsrExtras = KM.empty + } + (decode . encode) resp `shouldBe` Just resp + + describe "mountSearchableSnapshot endpoint shape" $ do + let body = defaultSearchableSnapshotMount [qqIndexName|fs|] + req = Common.mountSearchableSnapshot (SnapshotRepoName "my-repo") (SnapshotName "snap-1") body + + it "POSTs /_snapshot/{repo}/{snapshot}/_mount" $ do + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_snapshot", "my-repo", "snap-1", "_mount"] + + it "uses the POST method" $ do + bhRequestMethod req `shouldBe` "POST" + + it "attaches the encoded body" $ do + bhRequestBody req `shouldBe` Just (encode body) + + it "carries no query string by default" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "forwards options as query params in the With variant" $ do + let opts = defaultSearchableSnapshotMountOptions {ssmoStorage = Just SearchableSnapshotStorageSharedCache} + req' = Common.mountSearchableSnapshotWith (SnapshotRepoName "r") (SnapshotName "s") body opts + getRawEndpointQueries (bhRequestEndpoint req') + `shouldBe` [("storage", Just "shared_cache")] + + describe "getSearchableSnapshotsStats endpoint shape" $ do + let req = Common.getSearchableSnapshotsStats + + it "GETs /_searchable_snapshots/stats" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_searchable_snapshots", "stats"] + + it "uses the GET method" $ do + bhRequestMethod req `shouldBe` "GET" + + it "carries no request body" $ do + bhRequestBody req `shouldBe` Nothing + + describe "getSearchableSnapshotsCacheStats endpoint shape" $ do + let req = Common.getSearchableSnapshotsCacheStats [qqIndexName|fs|] + + it "POSTs /_searchable_snapshots/{index}/_cache_stats" $ do + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_searchable_snapshots", "fs", "_cache_stats"] + + it "uses the POST method" $ do + bhRequestMethod req `shouldBe` "POST" + + it "sends an empty body" $ do + bhRequestBody req `shouldBe` Just "" + + describe "clearSearchableSnapshotsCache endpoint shape" $ do + let req = Common.clearSearchableSnapshotsCache [qqIndexName|fs|] + + it "POSTs /_searchable_snapshots/{index}/_clear_cache" $ do + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_searchable_snapshots", "fs", "_clear_cache"] + + it "uses the POST method (matches ES docs, not the bead's PUT)" $ do + bhRequestMethod req `shouldBe` "POST" + + it "sends an empty body" $ do + bhRequestBody req `shouldBe` Just "" diff --git a/tests/Test/SecurityAnalyticsSpec.hs b/tests/Test/SecurityAnalyticsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SecurityAnalyticsSpec.hs @@ -0,0 +1,1645 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Test.SecurityAnalyticsSpec (spec) where + +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Map.Strict qualified as M +import Data.Maybe (fromJust, isJust) +import Database.Bloodhound.OpenSearch2.Client qualified as OS2.Client +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch2.Types qualified as OS2A +import Database.Bloodhound.OpenSearch3.Client qualified as OS3.Client +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types qualified as OS3A +import TestsUtils.Common +import TestsUtils.Import +import Prelude + +-- | Pure endpoint-shape and decoder tests for the Security Analytics +-- plugin detector create\/get and rule search endpoints across +-- OpenSearch 2 and 3. Mirrors 'Test.AlertingSpec' for the shape +-- tests and decoder-fixture pinning. +-- +-- The detector 'SADetector' is modelled pragmatically (typed shell + +-- opaque aeson 'Value' catch-alls) following the 'Monitor' precedent. +-- These tests pin (a) the endpoint shape per backend, (b) OS2\/OS3 +-- cross-backend parity, (c) decoder round-trips for the documented +-- wire fixtures (incl. the severity-as-string and actions-as-array +-- gotchas), and (d) the rule-search envelope decoding. +-- +-- OpenSearch 1.3 does not ship the Security Analytics plugin (it was +-- introduced in OS 2.4), so the OS1 module deliberately does not +-- expose these endpoints; see the changelog entry for bloodhound-364b. +-- +-- The live round-trip is @pendingWith@'d: the CI docker-compose runs +-- Elasticsearch clusters only, so the Security Analytics plugin +-- (OS-specific) is not available in CI. Re-enable once a live OS +-- cluster is wired in (same precedent as 'Test.AlertingSpec' / +-- 'Test.KnnWarmupSpec' / 'Test.IsmSpec' live blocks). +spec :: Spec +spec = describe "Security Analytics detector and rule APIs" $ do + -- =========================================================== -- + -- Endpoint shape: OpenSearch 3 (detailed) -- + -- =========================================================== -- + describe "endpoint shape (OpenSearch 3)" $ do + it "createSADetector POSTs to /_plugins/_security_analytics/detectors with the encoded body" $ do + let req = OS3Requests.createSADetector os3SampleDetector + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "detectors"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + let body = fromJust (bhRequestBody req) + let decoded = (decode body :: Maybe OS3A.SADetector) + decoded `shouldSatisfy` \m -> isJust m && OS3A.saDetectorName (fromJust m) == "test-detector" + + it "getSADetector GETs /_plugins/_security_analytics/detectors/{id} with no body" $ do + let req = OS3Requests.getSADetector (OS3A.DetectorId "my-detector-id") + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "detectors", "my-detector-id"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "getSADetector keeps the id as a single opaque path segment" $ do + let req = OS3Requests.getSADetector (OS3A.DetectorId "my-detector_42") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "detectors", "my-detector_42"] + + it "searchSAPrePackagedRules POSTs to /_plugins/_security_analytics/rules/_search?pre_packaged=true" $ do + let req = OS3Requests.searchSAPrePackagedRules Nothing + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "rules", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("pre_packaged", Just "true")] + -- Default empty-body POST renders to the literal "{}". + bhRequestBody req `shouldBe` Just (encode (object [])) + + it "searchSACustomRules POSTs to /_plugins/_security_analytics/rules/_search?pre_packaged=false" $ do + let req = OS3Requests.searchSACustomRules Nothing + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "rules", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("pre_packaged", Just "false")] + + it "searchSAPrePackagedRules forwards the query body when supplied" $ do + let q = + OS3A.SARulesQuery + { OS3A.saRulesQueryFrom = Just 0, + OS3A.saRulesQuerySize = Just 20, + OS3A.saRulesQueryQuery = Nothing + } + let req = OS3Requests.searchSAPrePackagedRules (Just q) + let body = fromJust (bhRequestBody req) + -- The body must contain the from/size keys. + LBS.unpack body `shouldContain` "\"from\"" + LBS.unpack body `shouldContain` "\"size\"" + + it "createSACustomRule POSTs to /_plugins/_security_analytics/rules?category={logtype} with raw Sigma YAML body" $ do + let req = OS3Requests.createSACustomRule OS3A.SADetectorTypeWindows sampleSigmaYaml + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "rules"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("category", Just "windows")] + -- Body is the raw Sigma YAML text (NOT JSON-encoded). + let body = fromJust (bhRequestBody req) + LBS.unpack body `shouldContain` "title: Moriya Rootkit" + + it "createSACustomRule renders the category from saDetectorTypeText" $ do + let req = OS3Requests.createSACustomRule OS3A.SADetectorTypeLinux "title: x" + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("category", Just "linux")] + + it "updateSACustomRule PUTs to /_plugins/_security_analytics/rules/{id}?category={logtype} with no forced when False" $ do + let req = OS3Requests.updateSACustomRule (OS3A.RuleId "my-rule-id") OS3A.SADetectorTypeWindows False sampleSigmaYaml + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "rules", "my-rule-id"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("category", Just "windows")] + let body = fromJust (bhRequestBody req) + LBS.unpack body `shouldContain` "title: Moriya Rootkit" + + it "updateSACustomRule adds forced=true when forced" $ do + let req = OS3Requests.updateSACustomRule (OS3A.RuleId "my-rule-id") OS3A.SADetectorTypeWindows True sampleSigmaYaml + getRawEndpointQueries (bhRequestEndpoint req) + `shouldContain` [("forced", Just "true")] + + it "updateSACustomRule keeps the id as a single opaque path segment" $ do + let req = OS3Requests.updateSACustomRule (OS3A.RuleId "rule_42#v1") OS3A.SADetectorTypeWindows False "title: x" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "rules", "rule_42#v1"] + + it "deleteSACustomRule DELETEs /_plugins/_security_analytics/rules/{id} with no body and no forced when False" $ do + let req = OS3Requests.deleteSACustomRule (OS3A.RuleId "my-rule-id") False + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "rules", "my-rule-id"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "deleteSACustomRule adds forced=true when forced" $ do + let req = OS3Requests.deleteSACustomRule (OS3A.RuleId "my-rule-id") True + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("forced", Just "true")] + + it "deleteSACustomRule keeps the id as a single opaque path segment" $ do + let req = OS3Requests.deleteSACustomRule (OS3A.RuleId "rule_42#v1") False + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "rules", "rule_42#v1"] + + it "updateSADetector PUTs to /_plugins/_security_analytics/detectors/{id} with the encoded body" $ do + let req = OS3Requests.updateSADetector (OS3A.DetectorId "my-detector-id") os3SampleDetector + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "detectors", "my-detector-id"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + let body = fromJust (bhRequestBody req) + let decoded = (decode body :: Maybe OS3A.SADetector) + decoded `shouldSatisfy` \m -> isJust m && OS3A.saDetectorName (fromJust m) == "test-detector" + + it "deleteSADetector DELETEs /_plugins/_security_analytics/detectors/{id} with no body" $ do + let req = OS3Requests.deleteSADetector (OS3A.DetectorId "my-detector-id") + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "detectors", "my-detector-id"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + it "deleteSADetector keeps the id as a single opaque path segment" $ do + let req = OS3Requests.deleteSADetector (OS3A.DetectorId "my-detector_42") + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "detectors", "my-detector_42"] + + it "searchSADetectors POSTs to /_plugins/_security_analytics/detectors/_search with default {} body" $ do + let req = OS3Requests.searchSADetectors Nothing + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "detectors", "_search"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + -- Default empty-body POST renders to the literal "{}". + bhRequestBody req `shouldBe` Just (encode (object [])) + + it "searchSADetectors forwards the query body when supplied" $ do + let q = + OS3A.SADetectorsSearchQuery + { OS3A.saDetectorsSearchQueryFrom = Just 0, + OS3A.saDetectorsSearchQuerySize = Just 20, + OS3A.saDetectorsSearchQueryQuery = Nothing + } + let req = OS3Requests.searchSADetectors (Just q) + let body = fromJust (bhRequestBody req) + LBS.unpack body `shouldContain` "\"from\"" + LBS.unpack body `shouldContain` "\"size\"" + + -- =========================================================== -- + -- Endpoint shape: OpenSearch 2 (path/method parity) -- + -- =========================================================== -- + describe "endpoint shape (OpenSearch 2)" $ do + it "createSADetector POSTs to /_plugins/_security_analytics/detectors" $ do + let req = OS2Requests.createSADetector os2SampleDetector + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "detectors"] + + it "getSADetector GETs /_plugins/_security_analytics/detectors/{id}" $ do + let req = OS2Requests.getSADetector (OS2A.DetectorId "os2-id") + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "detectors", "os2-id"] + bhRequestBody req `shouldBe` Nothing + + it "searchSAPrePackagedRules POSTs with pre_packaged=true" $ do + let req = OS2Requests.searchSAPrePackagedRules Nothing + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("pre_packaged", Just "true")] + + it "searchSACustomRules POSTs with pre_packaged=false" $ do + let req = OS2Requests.searchSACustomRules Nothing + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("pre_packaged", Just "false")] + + it "createSACustomRule POSTs with category query param and raw YAML body" $ do + let req = OS2Requests.createSACustomRule OS2A.SADetectorTypeWindows sampleSigmaYaml + bhRequestMethod req `shouldBe` "POST" + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("category", Just "windows")] + + it "updateSACustomRule PUTs with category query param" $ do + let req = OS2Requests.updateSACustomRule (OS2A.RuleId "os2-id") OS2A.SADetectorTypeWindows False sampleSigmaYaml + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "rules", "os2-id"] + + it "deleteSACustomRule DELETEs /_plugins/_security_analytics/rules/{id}" $ do + let req = OS2Requests.deleteSACustomRule (OS2A.RuleId "os2-id") True + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "rules", "os2-id"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("forced", Just "true")] + + it "updateSADetector PUTs to /_plugins/_security_analytics/detectors/{id}" $ do + let req = OS2Requests.updateSADetector (OS2A.DetectorId "os2-id") os2SampleDetector + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "detectors", "os2-id"] + + it "deleteSADetector DELETEs /_plugins/_security_analytics/detectors/{id}" $ do + let req = OS2Requests.deleteSADetector (OS2A.DetectorId "os2-id") + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "detectors", "os2-id"] + bhRequestBody req `shouldBe` Nothing + + it "searchSADetectors POSTs to /_plugins/_security_analytics/detectors/_search" $ do + let req = OS2Requests.searchSADetectors Nothing + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_security_analytics", "detectors", "_search"] + + -- =========================================================== -- + -- Cross-backend parity (OS2, OS3 emit identical requests) -- + -- =========================================================== -- + describe "cross-backend parity (OS2/OS3)" $ do + let did2 = OS2A.DetectorId "shared-id" + did3 = OS3A.DetectorId "shared-id" + + it "createSADetector: OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.createSADetector os2SampleDetector)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.createSADetector os3SampleDetector)) + bhRequestMethod (OS2Requests.createSADetector os2SampleDetector) + `shouldBe` bhRequestMethod (OS3Requests.createSADetector os3SampleDetector) + + it "createSADetector: OS2, OS3 attach identical body bytes" $ do + let b2 = bhRequestBody (OS2Requests.createSADetector os2SampleDetector) + b3 = bhRequestBody (OS3Requests.createSADetector os3SampleDetector) + b2 `shouldBe` b3 + + it "getSADetector: OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.getSADetector did2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.getSADetector did3)) + bhRequestMethod (OS2Requests.getSADetector did2) + `shouldBe` bhRequestMethod (OS3Requests.getSADetector did3) + + it "searchSAPrePackagedRules: OS2, OS3 produce the same path and queries" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.searchSAPrePackagedRules Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.searchSAPrePackagedRules Nothing)) + getRawEndpointQueries (bhRequestEndpoint (OS2Requests.searchSAPrePackagedRules Nothing)) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint (OS3Requests.searchSAPrePackagedRules Nothing)) + + it "pre_packaged vs custom: same path, distinct query value" $ do + getRawEndpoint (bhRequestEndpoint (OS3Requests.searchSAPrePackagedRules Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.searchSACustomRules Nothing)) + getRawEndpointQueries (bhRequestEndpoint (OS3Requests.searchSAPrePackagedRules Nothing)) + `shouldNotBe` getRawEndpointQueries (bhRequestEndpoint (OS3Requests.searchSACustomRules Nothing)) + + it "updateSADetector: OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.updateSADetector did2 os2SampleDetector)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.updateSADetector did3 os3SampleDetector)) + bhRequestMethod (OS2Requests.updateSADetector did2 os2SampleDetector) + `shouldBe` bhRequestMethod (OS3Requests.updateSADetector did3 os3SampleDetector) + + it "updateSADetector: OS2, OS3 attach identical body bytes" $ do + let b2 = bhRequestBody (OS2Requests.updateSADetector did2 os2SampleDetector) + b3 = bhRequestBody (OS3Requests.updateSADetector did3 os3SampleDetector) + b2 `shouldBe` b3 + + it "deleteSADetector: OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteSADetector did2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteSADetector did3)) + bhRequestMethod (OS2Requests.deleteSADetector did2) + `shouldBe` bhRequestMethod (OS3Requests.deleteSADetector did3) + + it "searchSADetectors: OS2, OS3 produce the same path and queries" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.searchSADetectors Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.searchSADetectors Nothing)) + getRawEndpointQueries (bhRequestEndpoint (OS2Requests.searchSADetectors Nothing)) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint (OS3Requests.searchSADetectors Nothing)) + + let rid2 = OS2A.RuleId "shared-rule-id" + rid3 = OS3A.RuleId "shared-rule-id" + + it "createSACustomRule: OS2, OS3 produce the same path, method, and queries" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.createSACustomRule OS2A.SADetectorTypeWindows sampleSigmaYaml)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.createSACustomRule OS3A.SADetectorTypeWindows sampleSigmaYaml)) + getRawEndpointQueries (bhRequestEndpoint (OS2Requests.createSACustomRule OS2A.SADetectorTypeWindows sampleSigmaYaml)) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint (OS3Requests.createSACustomRule OS3A.SADetectorTypeWindows sampleSigmaYaml)) + bhRequestMethod (OS2Requests.createSACustomRule OS2A.SADetectorTypeWindows sampleSigmaYaml) + `shouldBe` bhRequestMethod (OS3Requests.createSACustomRule OS3A.SADetectorTypeWindows sampleSigmaYaml) + + it "createSACustomRule: OS2, OS3 attach identical body bytes" $ do + let b2 = bhRequestBody (OS2Requests.createSACustomRule OS2A.SADetectorTypeWindows sampleSigmaYaml) + b3 = bhRequestBody (OS3Requests.createSACustomRule OS3A.SADetectorTypeWindows sampleSigmaYaml) + b2 `shouldBe` b3 + + it "updateSACustomRule: OS2, OS3 produce the same path, method, and queries" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.updateSACustomRule rid2 OS2A.SADetectorTypeWindows True sampleSigmaYaml)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.updateSACustomRule rid3 OS3A.SADetectorTypeWindows True sampleSigmaYaml)) + getRawEndpointQueries (bhRequestEndpoint (OS2Requests.updateSACustomRule rid2 OS2A.SADetectorTypeWindows True sampleSigmaYaml)) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint (OS3Requests.updateSACustomRule rid3 OS3A.SADetectorTypeWindows True sampleSigmaYaml)) + + it "deleteSACustomRule: OS2, OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteSACustomRule rid2 False)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteSACustomRule rid3 False)) + bhRequestMethod (OS2Requests.deleteSACustomRule rid2 False) + `shouldBe` bhRequestMethod (OS3Requests.deleteSACustomRule rid3 False) + + it "deleteSACustomRule: forced flag produces the same query across backends" $ do + getRawEndpointQueries (bhRequestEndpoint (OS2Requests.deleteSACustomRule rid2 True)) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint (OS3Requests.deleteSACustomRule rid3 True)) + + -- =========================================================== -- + -- Decoder tests (OS3 types — identical instances across OS2-3) -- + -- =========================================================== -- + describe "SADetectorResponse decoding (create fixture)" $ do + -- Verbatim from the OS docs create-detector response example. + let fixture = + LBS.pack + "{\"_id\":\"dc2VB4QBrbtylUb_Hfa3\",\"_version\":1,\"detector\":{\"name\":\"nbReFCjlfn\",\"detector_type\":\"windows\",\"enabled\":true,\"schedule\":{\"period\":{\"interval\":1,\"unit\":\"MINUTES\"}},\"inputs\":[{\"detector_input\":{\"description\":\"windows detector for security analytics\",\"indices\":[\"windows\"],\"custom_rules\":[{\"id\":\"bc2RB4QBrbtylUb_1Pbm\"}],\"pre_packaged_rules\":[{\"id\":\"06724a9a-52fc-11ed-bdc3-0242ac120002\"}]}}],\"triggers\":[{\"id\":\"8qhrBoQBYK1JzUUDzH-N\",\"name\":\"test-trigger\",\"severity\":\"1\",\"types\":[],\"ids\":[\"06724a9a-52fc-11ed-bdc3-0242ac120002\"],\"sev_levels\":[],\"tags\":[\"attack.defense_evasion\"],\"actions\":[{\"id\":\"hVTLkZYzlA\",\"name\":\"hello_world\",\"destination_id\":\"6r8ZBoQBKW_6dKriacQb\",\"message_template\":{\"source\":\"Trigger: \",\"lang\":\"mustache\"},\"throttle_enabled\":false,\"subject_template\":{\"source\":\"Detector just entered alert status.\",\"lang\":\"mustache\"},\"throttle\":{\"value\":108,\"unit\":\"MINUTES\"}}]}],\"last_update_time\":\"2022-10-24T01:22:03.738379671Z\",\"enabled_time\":\"2022-10-24T01:22:03.738376103Z\"}}" + + it "decodes the documented create-response fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.SADetectorResponse + OS3A.saDetectorResponseId decoded `shouldBe` "dc2VB4QBrbtylUb_Hfa3" + OS3A.saDetectorResponseVersion decoded `shouldBe` 1 + let det = OS3A.saDetectorResponseDetector decoded + OS3A.saDetectorName det `shouldBe` "nbReFCjlfn" + OS3A.saDetectorType det `shouldBe` OS3A.SADetectorTypeWindows + OS3A.saDetectorEnabled det `shouldBe` Just True + -- last_update_time / enabled_time round-trip via the detectorOther catch-all + -- (not typed fields on SADetector). + length (OS3A.saDetectorInputs det) `shouldBe` 1 + length (OS3A.saDetectorTriggers det) `shouldBe` 1 + let trig = head (OS3A.saDetectorTriggers det) + OS3A.saTriggerName trig `shouldBe` "test-trigger" + -- severity is a string-encoded integer on the wire ("1"), NOT a number. + OS3A.saTriggerSeverity trig `shouldBe` "1" + OS3A.saTriggerIds trig `shouldBe` ["06724a9a-52fc-11ed-bdc3-0242ac120002"] + OS3A.saTriggerTags trig `shouldBe` ["attack.defense_evasion"] + -- actions is an ARRAY on the wire (docs table says Object — wrong). + length (OS3A.saTriggerActions trig) `shouldBe` 1 + let act = head (OS3A.saTriggerActions trig) + OS3A.saActionName act `shouldBe` Just "hello_world" + OS3A.saActionDestinationId act `shouldBe` Just "6r8ZBoQBKW_6dKriacQb" + OS3A.saActionThrottleEnabled act `shouldBe` Just False + let Just th = OS3A.saActionThrottle act + OS3A.saThrottleValue th `shouldBe` 108 + OS3A.saThrottleUnit th `shouldBe` "MINUTES" + + describe "SADetectorResponse decoding (get fixture)" $ do + -- Verbatim from the OS docs get-detector response example. + let fixture = + LBS.pack + "{\"_id\":\"x-dwFIYBT6_n8WeuQjo4\",\"_version\":1,\"detector\":{\"name\":\"DetectorTest1\",\"detector_type\":\"windows\",\"enabled\":true,\"schedule\":{\"period\":{\"interval\":1,\"unit\":\"MINUTES\"}},\"inputs\":[{\"detector_input\":{\"description\":\"Test and delete\",\"indices\":[\"windows1\"],\"custom_rules\":[],\"pre_packaged_rules\":[{\"id\":\"847def9e-924d-4e90-b7c4-5f581395a2b4\"}]}}],\"last_update_time\":\"2023-02-02T23:22:26.454Z\",\"enabled_time\":\"2023-02-02T23:22:26.454Z\"}}" + + it "decodes the documented get-response fixture (no triggers array)" $ do + let Just decoded = decode fixture :: Maybe OS3A.SADetectorResponse + OS3A.saDetectorResponseId decoded `shouldBe` "x-dwFIYBT6_n8WeuQjo4" + let det = OS3A.saDetectorResponseDetector decoded + OS3A.saDetectorName det `shouldBe` "DetectorTest1" + OS3A.saDetectorTriggers det `shouldBe` [] + length (OS3A.saDetectorInputs det) `shouldBe` 1 + let input = head (OS3A.saDetectorInputs det) + OS3A.saDetectorInputIndices input `shouldBe` ["windows1"] + length (OS3A.saDetectorInputPrePackagedRules input) `shouldBe` 1 + + describe "SADetector round-trip" $ do + it "round-trips through encode/decode on the typed fields" $ do + let encoded = encode os3SampleDetector + Just reDecoded = decode encoded :: Maybe OS3A.SADetector + OS3A.saDetectorName reDecoded `shouldBe` OS3A.saDetectorName os3SampleDetector + OS3A.saDetectorType reDecoded `shouldBe` OS3A.saDetectorType os3SampleDetector + OS3A.saDetectorSchedule reDecoded `shouldBe` OS3A.saDetectorSchedule os3SampleDetector + + describe "SADetectorType discriminator" $ do + it "decodes each documented detector_type value (lower-case form)" $ do + "linux" `decodesDetectorTypeTo` OS3A.SADetectorTypeLinux + "network" `decodesDetectorTypeTo` OS3A.SADetectorTypeNetwork + "windows" `decodesDetectorTypeTo` OS3A.SADetectorTypeWindows + "ad_ldap" `decodesDetectorTypeTo` OS3A.SADetectorTypeAdLdap + "apache_access" `decodesDetectorTypeTo` OS3A.SADetectorTypeApacheAccess + "cloudtrail" `decodesDetectorTypeTo` OS3A.SADetectorTypeCloudtrail + "dns" `decodesDetectorTypeTo` OS3A.SADetectorTypeDns + "s3" `decodesDetectorTypeTo` OS3A.SADetectorTypeS3 + + it "normalises upper-case to the canonical constructor" $ + "WINDOWS" `decodesDetectorTypeTo` OS3A.SADetectorTypeWindows + + it "round-trips through saDetectorTypeText (lower-case)" $ + OS3A.saDetectorTypeText OS3A.SADetectorTypeWindows `shouldBe` "windows" + + it "falls through to SADetectorTypeOther for an unknown value" $ + "future_log_type" `decodesDetectorTypeTo` OS3A.SADetectorTypeOther "future_log_type" + + describe "SASchedule decoding" $ do + it "decodes a period schedule" $ do + let Just s = decode "{\"period\":{\"interval\":5,\"unit\":\"HOURS\"}}" :: Maybe OS3A.SASchedule + Just (OS3A.PeriodSASchedule p) = Just s + OS3A.saSchedulePeriodInterval p `shouldBe` 5 + OS3A.saSchedulePeriodUnit p `shouldBe` "HOURS" + + it "falls through to OtherSASchedule for an unknown schedule kind" $ do + let Just s = decode "{\"custom\":{\"foo\":1}}" :: Maybe OS3A.SASchedule + Just (OS3A.OtherSASchedule _) = Just s + s `shouldBe` OS3A.OtherSASchedule (object ["custom" .= object ["foo" .= (1 :: Int)]]) + + describe "SATrigger severity-as-string gotcha" $ do + it "severity is decoded as a string (not a number) per the wire" $ do + let Just t = decode "{\"name\":\"x\",\"severity\":\"1\",\"actions\":[]}" :: Maybe OS3A.SATrigger + OS3A.saTriggerSeverity t `shouldBe` "1" + + it "defaults to \"1\" when severity is absent (matches server-injected default)" $ do + let Just t = decode "{\"name\":\"x\",\"actions\":[]}" :: Maybe OS3A.SATrigger + OS3A.saTriggerSeverity t `shouldBe` "1" + + describe "SARulesSearchResponse decoding (pre-packaged fixture)" $ do + -- Verbatim from the OS docs search pre-packaged rules response example. + let fixture = + LBS.pack + "{\"took\":3,\"timed_out\":false,\"_shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"hits\":{\"total\":{\"value\":1580,\"relation\":\"eq\"},\"max_score\":0.25863406,\"hits\":[{\"_index\":\".opensearch-pre-packaged-rules-config\",\"_id\":\"6KFv1IMBdLpXWBiBelZg\",\"_version\":1,\"_seq_no\":386,\"_primary_term\":1,\"_score\":0.25863406,\"_source\":{\"category\":\"windows\",\"title\":\"Change Outlook Security Setting in Registry\",\"log_source\":\"registry_set\",\"description\":\"Change outlook email security settings\",\"references\":[{\"value\":\"https://github.com/redcanaryco/atomic-red-team/blob/master/atomics/T1137/T1137.md\"}],\"tags\":[{\"value\":\"attack.persistence\"}],\"level\":\"medium\",\"false_positives\":[{\"value\":\"Administrative scripts\"}],\"author\":\"frack113\",\"status\":\"experimental\",\"last_update_time\":\"2021-12-28T00:00:00.000Z\",\"queries\":[{\"value\":\"TargetObject: *\\\\SOFTWARE*\"}],\"rule\":\"title: Change Outlook Security Setting in Registry\\nid: c3cefdf4-6703-4e1c-bad8-bf422fc5015a\\n\"}}]}}" + + it "decodes the documented pre-packaged search fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.SARulesSearchResponse + OS3A.saRulesSearchResponseTook decoded `shouldBe` 3 + OS3A.saRulesSearchResponseTimedOut decoded `shouldBe` False + OS3A.saRulesShardsTotal (OS3A.saRulesSearchResponseShards decoded) `shouldBe` 1 + OS3A.saRulesShardsSuccessful (OS3A.saRulesSearchResponseShards decoded) `shouldBe` 1 + OS3A.saRulesTotalValue (OS3A.saRulesSearchResponseTotal decoded) `shouldBe` 1580 + OS3A.saRulesTotalRelation (OS3A.saRulesSearchResponseTotal decoded) + `shouldBe` OS3A.SARulesTotalRelationEq + OS3A.saRulesSearchResponseMaxScore decoded `shouldBe` Just 0.25863406 + length (OS3A.saRulesSearchResponseHits decoded) `shouldBe` 1 + let hit = head (OS3A.saRulesSearchResponseHits decoded) + OS3A.saRuleHitId hit `shouldBe` "6KFv1IMBdLpXWBiBelZg" + OS3A.saRuleHitIndex hit `shouldBe` Just ".opensearch-pre-packaged-rules-config" + let rule = OS3A.saRuleHitSource hit + OS3A.saRuleCategory rule `shouldBe` Just "windows" + OS3A.saRuleTitle rule `shouldBe` Just "Change Outlook Security Setting in Registry" + OS3A.saRuleLevel rule `shouldBe` Just "medium" + OS3A.saRuleAuthor rule `shouldBe` Just "frack113" + length (OS3A.saRuleTags rule) `shouldBe` 1 + length (OS3A.saRuleReferences rule) `shouldBe` 1 + length (OS3A.saRuleQueries rule) `shouldBe` 1 + + it "saRulesSearchResponseRules projects the SARule list out" $ do + let Just decoded = decode fixture :: Maybe OS3A.SARulesSearchResponse + let rules = OS3A.saRulesSearchResponseRules decoded + length rules `shouldBe` 1 + OS3A.saRuleTitle (head rules) `shouldBe` Just "Change Outlook Security Setting in Registry" + + describe "SARulesSearchResponse decoding (custom fixture)" $ do + -- Verbatim from the OS docs search custom rules response example. + let fixture = + LBS.pack + "{\"took\":1,\"timed_out\":false,\"_shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"hits\":{\"total\":{\"value\":1,\"relation\":\"eq\"},\"max_score\":0.2876821,\"hits\":[{\"_index\":\".opensearch-custom-rules-config\",\"_id\":\"ZaFv1IMBdLpXWBiBa1XI\",\"_version\":2,\"_seq_no\":1,\"_primary_term\":1,\"_score\":0.2876821,\"_source\":{\"category\":\"windows\",\"title\":\"Moriya Rooskit\",\"log_source\":\"\",\"description\":\"Detects the use of Moriya rootkit\",\"references\":[{\"value\":\"https://securelist.com/operation-tunnelsnake-and-moriya-rootkit/101831\"}],\"tags\":[{\"value\":\"attack.persistence\"}],\"level\":\"critical\",\"false_positives\":[{\"value\":\"Unknown\"}],\"author\":\"Bhabesh Raj\",\"status\":\"experimental\",\"last_update_time\":\"2021-05-06T00:00:00.000Z\",\"queries\":[{\"value\":\"Provider_Name: \\\"Service Control Manager\\\"\"}],\"rule\":\"title: Moriya Rooskit\\nid: 25b9c01c-350d-4b95-bed1-836d04a4f324\\n\"}}]}}" + + it "decodes the documented custom search fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.SARulesSearchResponse + OS3A.saRulesTotalValue (OS3A.saRulesSearchResponseTotal decoded) `shouldBe` 1 + let rule = OS3A.saRuleHitSource (head (OS3A.saRulesSearchResponseHits decoded)) + OS3A.saRuleTitle rule `shouldBe` Just "Moriya Rooskit" + OS3A.saRuleLevel rule `shouldBe` Just "critical" + OS3A.saRuleLogSource rule `shouldBe` Just "" + length (OS3A.saRuleFalsePositives rule) `shouldBe` 1 + + describe "SARulesQuery rendering" $ do + it "defaultSARulesQuery renders to empty object" $ do + encode OS3A.defaultSARulesQuery `shouldBe` "{}" + + it "non-default fields are rendered" $ do + let q = + OS3A.SARulesQuery + { OS3A.saRulesQueryFrom = Just 0, + OS3A.saRulesQuerySize = Just 20, + OS3A.saRulesQueryQuery = Nothing + } + LBS.unpack (encode q) `shouldContain` "\"from\"" + LBS.unpack (encode q) `shouldContain` "\"size\"" + + describe "SADetectorsSearchResponse decoding (search fixture)" $ do + -- A realistic search-detectors response: the standard OpenSearch + -- search envelope with one detector document in hits.hits[]._source. + -- The _source is the stored detector (the SADetector body), NOT the + -- {_id,_version,detector:{...}} GET wrapper. + let fixture = + LBS.pack + "{\"took\":5,\"timed_out\":false,\"_shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"hits\":{\"total\":{\"value\":1,\"relation\":\"eq\"},\"max_score\":1.0,\"hits\":[{\"_index\":\".opendistro-security-analytics-detectors\",\"_id\":\"abc123\",\"_version\":1,\"_seq_no\":0,\"_primary_term\":1,\"_score\":1.0,\"_source\":{\"name\":\"my-detector\",\"detector_type\":\"windows\",\"type\":\"detector\",\"enabled\":true,\"schedule\":{\"period\":{\"interval\":1,\"unit\":\"MINUTES\"}},\"inputs\":[{\"detector_input\":{\"description\":\"test\",\"indices\":[\"windows\"],\"custom_rules\":[],\"pre_packaged_rules\":[{\"id\":\"rule-1\"}]}}],\"triggers\":[],\"last_update_time\":\"2023-01-01T00:00:00.000Z\",\"enabled_time\":\"2023-01-01T00:00:00.000Z\"}}]}}" + + it "decodes the search-detectors envelope" $ do + let Just decoded = decode fixture :: Maybe OS3A.SADetectorsSearchResponse + OS3A.saDetectorsSearchResponseTook decoded `shouldBe` 5 + OS3A.saDetectorsSearchResponseTimedOut decoded `shouldBe` False + OS3A.saDetectorsShardsTotal (OS3A.saDetectorsSearchResponseShards decoded) `shouldBe` 1 + OS3A.saDetectorsShardsSuccessful (OS3A.saDetectorsSearchResponseShards decoded) `shouldBe` 1 + OS3A.saDetectorsTotalValue (OS3A.saDetectorsSearchResponseTotal decoded) `shouldBe` 1 + OS3A.saDetectorsTotalRelation (OS3A.saDetectorsSearchResponseTotal decoded) + `shouldBe` OS3A.SADetectorsTotalRelationEq + OS3A.saDetectorsSearchResponseMaxScore decoded `shouldBe` Just 1.0 + length (OS3A.saDetectorsSearchResponseHits decoded) `shouldBe` 1 + let hit = head (OS3A.saDetectorsSearchResponseHits decoded) + OS3A.saDetectorHitId hit `shouldBe` "abc123" + OS3A.saDetectorHitIndex hit `shouldBe` Just ".opendistro-security-analytics-detectors" + OS3A.saDetectorHitSeqNo hit `shouldBe` Just 0 + let det = OS3A.saDetectorHitSource hit + OS3A.saDetectorName det `shouldBe` "my-detector" + OS3A.saDetectorType det `shouldBe` OS3A.SADetectorTypeWindows + OS3A.saDetectorEnabled det `shouldBe` Just True + + it "saDetectorsSearchResponseDetectors projects the SADetector list out" $ do + let Just decoded = decode fixture :: Maybe OS3A.SADetectorsSearchResponse + let dets = OS3A.saDetectorsSearchResponseDetectors decoded + length dets `shouldBe` 1 + OS3A.saDetectorName (head dets) `shouldBe` "my-detector" + + it "tolerates a missing max_score (Nothing)" $ do + let Just decoded = + decode + (LBS.pack "{\"took\":1,\"timed_out\":false,\"_shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"hits\":{\"total\":{\"value\":0,\"relation\":\"eq\"},\"hits\":[]}}") :: + Maybe OS3A.SADetectorsSearchResponse + OS3A.saDetectorsSearchResponseMaxScore decoded `shouldBe` Nothing + OS3A.saDetectorsSearchResponseHits decoded `shouldBe` [] + + describe "DeleteSADetectorResponse decoding (delete fixture)" $ do + -- The delete-detector response is the bare Elasticsearch + -- delete-document body (no `acknowledged` key), identical in shape + -- to DeleteMonitorResponse / DeleteDestinationResponse. + let fixture = + LBS.pack + "{\"_index\":\".opendistro-security-analytics-detectors\",\"_id\":\"abc123\",\"_version\":2,\"result\":\"deleted\",\"forced_refresh\":true,\"_shards\":{\"total\":2,\"successful\":2,\"skipped\":0,\"failed\":0},\"_seq_no\":3,\"_primary_term\":1}" + + it "decodes the documented delete-detector fixture (full shape)" $ do + let Just decoded = decode fixture :: Maybe OS3A.DeleteSADetectorResponse + OS3A.deleteSADetectorResponseIndex decoded `shouldBe` Just ".opendistro-security-analytics-detectors" + OS3A.deleteSADetectorResponseId decoded `shouldBe` "abc123" + OS3A.deleteSADetectorResponseVersion decoded `shouldBe` 2 + OS3A.deleteSADetectorResponseResult decoded `shouldBe` Just "deleted" + OS3A.deleteSADetectorResponseForcedRefresh decoded `shouldBe` Just True + let Just sh = OS3A.deleteSADetectorResponseShards decoded + OS3A.saDetectorsShardsTotal sh `shouldBe` 2 + OS3A.saDetectorsShardsSuccessful sh `shouldBe` 2 + OS3A.deleteSADetectorResponseSeqNo decoded `shouldBe` Just 3 + OS3A.deleteSADetectorResponsePrimaryTerm decoded `shouldBe` Just 1 + + it "decodes the minimal {_id,_version} fixture (OS 2.x/3.x shape, live-verified bead bloodhound-z5j)" $ do + let minimal = LBS.pack "{\"_id\":\"abc123\",\"_version\":1}" + Just decoded = decode minimal :: Maybe OS3A.DeleteSADetectorResponse + OS3A.deleteSADetectorResponseId decoded `shouldBe` "abc123" + OS3A.deleteSADetectorResponseVersion decoded `shouldBe` 1 + OS3A.deleteSADetectorResponseIndex decoded `shouldBe` Nothing + OS3A.deleteSADetectorResponseResult decoded `shouldBe` Nothing + OS3A.deleteSADetectorResponseForcedRefresh decoded `shouldBe` Nothing + OS3A.deleteSADetectorResponseShards decoded `shouldBe` Nothing + OS3A.deleteSADetectorResponseSeqNo decoded `shouldBe` Nothing + OS3A.deleteSADetectorResponsePrimaryTerm decoded `shouldBe` Nothing + + it "round-trips through encode/decode" $ do + let Just decoded = decode fixture :: Maybe OS3A.DeleteSADetectorResponse + decode (encode decoded) `shouldBe` Just decoded + + describe "SADetectorsSearchQuery rendering" $ do + it "defaultSADetectorsSearchQuery renders to empty object" $ + encode OS3A.defaultSADetectorsSearchQuery `shouldBe` "{}" + + it "non-default fields are rendered" $ do + let q = + OS3A.SADetectorsSearchQuery + { OS3A.saDetectorsSearchQueryFrom = Just 0, + OS3A.saDetectorsSearchQuerySize = Just 20, + OS3A.saDetectorsSearchQueryQuery = Nothing + } + LBS.unpack (encode q) `shouldContain` "\"from\"" + LBS.unpack (encode q) `shouldContain` "\"size\"" + + describe "SARuleResponse decoding (create fixture)" $ do + -- Verbatim from the OS docs create-custom-rule response example. + let fixture = + LBS.pack + "{\"_id\":\"M1Rm1IMByX0LvTiGvde2\",\"_version\":1,\"rule\":{\"category\":\"windows\",\"title\":\"Moriya Rootkit\",\"log_source\":\"\",\"description\":\"Detects the use of Moriya rootkit as described in the securelist's Operation TunnelSnake report\",\"tags\":[{\"value\":\"attack.persistence\"},{\"value\":\"attack.privilege_escalation\"},{\"value\":\"attack.t1543.003\"}],\"references\":[{\"value\":\"https://securelist.com/operation-tunnelsnake-and-moriya-rootkit/101831\"}],\"level\":\"critical\",\"false_positives\":[{\"value\":\"Unknown\"}],\"author\":\"Bhabesh Raj\",\"status\":\"experimental\",\"last_update_time\":\"2021-05-06T00:00:00.000Z\",\"rule\":\"title: Moriya Rootkit\\nid: 25b9c01c-350d-4b95-bed1-836d04a4f324\\n\"}}" + + it "decodes the documented create-rule fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.SARuleResponse + OS3A.saRuleResponseId decoded `shouldBe` "M1Rm1IMByX0LvTiGvde2" + OS3A.saRuleResponseVersion decoded `shouldBe` 1 + let rule = OS3A.saRuleResponseRule decoded + OS3A.saRuleCategory rule `shouldBe` Just "windows" + OS3A.saRuleTitle rule `shouldBe` Just "Moriya Rootkit" + OS3A.saRuleLevel rule `shouldBe` Just "critical" + OS3A.saRuleAuthor rule `shouldBe` Just "Bhabesh Raj" + length (OS3A.saRuleTags rule) `shouldBe` 3 + -- The server echoes the original Sigma YAML verbatim in `rule`. + OS3A.saRuleRule rule `shouldSatisfy` isJust + + -- The SARule round-trip is not perfectly lossless: the underlying + -- SARule ToJSON instance renders @queries:[]@ on re-encode even when + -- the original fixture omits the key (mergeIgnoringNulls treats an + -- empty array as non-null). This is a pre-existing property of the + -- SARule type, not of the SARuleResponse wrapper; the decode test + -- above fully validates the FromJSON instance. + + describe "DeleteSARuleResponse decoding (delete fixture)" $ do + -- The delete-rule response is the bare Elasticsearch delete-document + -- body (no `acknowledged` key), identical in shape to + -- DeleteSADetectorResponse. + let fixture = + LBS.pack + "{\"_index\":\".opensearch-custom-rules-config\",\"_id\":\"abc123\",\"_version\":2,\"result\":\"deleted\",\"forced_refresh\":true,\"_shards\":{\"total\":2,\"successful\":2,\"skipped\":0,\"failed\":0},\"_seq_no\":3,\"_primary_term\":1}" + + it "decodes the documented delete-rule fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.DeleteSARuleResponse + OS3A.deleteSARuleResponseIndex decoded `shouldBe` ".opensearch-custom-rules-config" + OS3A.deleteSARuleResponseId decoded `shouldBe` "abc123" + OS3A.deleteSARuleResponseVersion decoded `shouldBe` 2 + OS3A.deleteSARuleResponseResult decoded `shouldBe` "deleted" + OS3A.deleteSARuleResponseForcedRefresh decoded `shouldBe` True + OS3A.saRulesShardsTotal (OS3A.deleteSARuleResponseShards decoded) `shouldBe` 2 + OS3A.deleteSARuleResponseSeqNo decoded `shouldBe` 3 + OS3A.deleteSARuleResponsePrimaryTerm decoded `shouldBe` 1 + + it "round-trips through encode/decode" $ do + let Just decoded = decode fixture :: Maybe OS3A.DeleteSARuleResponse + decode (encode decoded) `shouldBe` Just decoded + + -- =========================================================== -- + -- Mappings API (4 endpoints: view / create / get / update) -- + -- =========================================================== -- + describe "Mappings API endpoint shape (OpenSearch 3)" $ do + it "getSAMappingsView GETs /_plugins/_security_analytics/mappings/view with the encoded body" $ do + let req = + OS3A.SAMappingsViewRequest + { OS3A.saMappingsViewIndexName = "windows", + OS3A.saMappingsViewRuleTopic = "windows" + } + r = OS3Requests.getSAMappingsView req + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "mappings", "view"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + let body = fromJust (bhRequestBody r) + LBS.unpack body `shouldContain` "\"index_name\"" + LBS.unpack body `shouldContain` "\"rule_topic\"" + + it "createSAMappings POSTs to /_plugins/_security_analytics/mappings with the encoded body" $ do + let req = + OS3A.SACreateMappingsRequest + { OS3A.saCreateMappingsIndexName = "windows", + OS3A.saCreateMappingsRuleTopic = "windows", + OS3A.saCreateMappingsPartial = Just True, + OS3A.saCreateMappingsAliasMappings = + OS3A.SAMappingsBody + { OS3A.saMappingsBodyProperties = mempty, + OS3A.saMappingsBodyOther = Null + } + } + r = OS3Requests.createSAMappings req + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "mappings"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + let body = fromJust (bhRequestBody r) + LBS.unpack body `shouldContain` "\"alias_mappings\"" + LBS.unpack body `shouldContain` "\"partial\"" + + it "getSAMappings GETs /_plugins/_security_analytics/mappings?index_name={name} with no body" $ do + let r = OS3Requests.getSAMappings "windows" + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "mappings"] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldBe` [("index_name", Just "windows")] + bhRequestBody r `shouldBe` Nothing + + it "updateSAMappings PUTs to /_plugins/_security_analytics/mappings with the encoded body" $ do + let req = + OS3A.SAUpdateMappingsRequest + { OS3A.saUpdateMappingsIndexName = "windows", + OS3A.saUpdateMappingsField = "CommandLine", + OS3A.saUpdateMappingsAlias = "windows-event_data-CommandLine" + } + r = OS3Requests.updateSAMappings req + bhRequestMethod r `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "mappings"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + let body = fromJust (bhRequestBody r) + LBS.unpack body `shouldContain` "\"field\"" + LBS.unpack body `shouldContain` "\"alias\"" + + describe "Mappings API endpoint shape (OpenSearch 2)" $ do + it "getSAMappingsView GETs .../mappings/view" $ do + let r = OS2Requests.getSAMappingsView (OS2A.SAMappingsViewRequest "windows" "windows") + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "mappings", "view"] + + it "getSAMappings GETs with the index_name query" $ do + let r = OS2Requests.getSAMappings "windows" + getRawEndpointQueries (bhRequestEndpoint r) + `shouldBe` [("index_name", Just "windows")] + + it "updateSAMappings PUTs to .../mappings" $ do + let r = OS2Requests.updateSAMappings (OS2A.SAUpdateMappingsRequest "windows" "CommandLine" "alias") + bhRequestMethod r `shouldBe` "PUT" + + describe "Mappings API cross-backend parity (OS2/OS3)" $ do + let viewReq2 = OS2A.SAMappingsViewRequest "windows" "windows" + viewReq3 = OS3A.SAMappingsViewRequest "windows" "windows" + updReq2 = OS2A.SAUpdateMappingsRequest "windows" "f" "a" + updReq3 = OS3A.SAUpdateMappingsRequest "windows" "f" "a" + + it "getSAMappingsView: OS2/OS3 produce the same path, method, and queries" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.getSAMappingsView viewReq2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.getSAMappingsView viewReq3)) + bhRequestMethod (OS2Requests.getSAMappingsView viewReq2) + `shouldBe` bhRequestMethod (OS3Requests.getSAMappingsView viewReq3) + getRawEndpointQueries (bhRequestEndpoint (OS2Requests.getSAMappingsView viewReq2)) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint (OS3Requests.getSAMappingsView viewReq3)) + + it "getSAMappings: OS2/OS3 produce the same path and index_name query" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.getSAMappings "windows")) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.getSAMappings "windows")) + getRawEndpointQueries (bhRequestEndpoint (OS2Requests.getSAMappings "windows")) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint (OS3Requests.getSAMappings "windows")) + + it "updateSAMappings: OS2/OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.updateSAMappings updReq2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.updateSAMappings updReq3)) + bhRequestMethod (OS2Requests.updateSAMappings updReq2) + `shouldBe` bhRequestMethod (OS3Requests.updateSAMappings updReq3) + + describe "SAMappingsViewResponse decoding (view fixture)" $ do + let fixture = + LBS.pack + "{\"properties\":{\"windows-event_data-CommandLine\":{\"path\":\"CommandLine\",\"type\":\"alias\"},\"event_uid\":{\"path\":\"EventID\",\"type\":\"alias\"}},\"unmapped_index_fields\":[\"windows-event_data-CommandLine\",\"src_ip\",\"sha1\"]}" + + it "decodes the documented view-response fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.SAMappingsViewResponse + M.size (OS3A.saMappingsViewResponseProperties decoded) `shouldBe` 2 + length (OS3A.saMappingsViewResponseUnmappedIndexFields decoded) `shouldBe` 3 + let Just prop = M.lookup "event_uid" (OS3A.saMappingsViewResponseProperties decoded) + OS3A.saMappingPropertyPath prop `shouldBe` Just "EventID" + OS3A.saMappingPropertyType prop `shouldBe` Just "alias" + let Just prop2 = M.lookup "windows-event_data-CommandLine" (OS3A.saMappingsViewResponseProperties decoded) + OS3A.saMappingPropertyPath prop2 `shouldBe` Just "CommandLine" + + it "preserves an unknown forward-compat key via the catch-all" $ do + let lbs = LBS.pack "{\"properties\":{},\"unmapped_index_fields\":[],\"future_key\":42}" + Just decoded = decode lbs :: Maybe OS3A.SAMappingsViewResponse + LBS.unpack (encode decoded) `shouldContain` "\"future_key\"" + + describe "SAGetMappingsResponse decoding (get fixture)" $ do + let fixture = + LBS.pack + "{\"windows\":{\"mappings\":{\"properties\":{\"windows-event_data-CommandLine\":{\"type\":\"alias\",\"path\":\"CommandLine\"},\"event_uid\":{\"type\":\"alias\",\"path\":\"EventID\"}}}}}" + + it "decodes the documented get-mappings fixture (keyed by index name)" $ do + let Just decoded = decode fixture :: Maybe OS3A.SAGetMappingsResponse + M.size decoded `shouldBe` 1 + let Just idx = M.lookup "windows" decoded + bodyMap = OS3A.saMappingsIndexBodyMappings idx + M.size (OS3A.saMappingsBodyProperties bodyMap) `shouldBe` 2 + let Just prop = M.lookup "event_uid" (OS3A.saMappingsBodyProperties bodyMap) + OS3A.saMappingPropertyType prop `shouldBe` Just "alias" + OS3A.saMappingPropertyPath prop `shouldBe` Just "EventID" + + describe "SAMappings ack decoding" $ do + it "create/update mappings {\"acknowledged\":true} decodes as Acknowledged True" $ do + let Just decoded = decode "{\"acknowledged\":true}" :: Maybe Acknowledged + isAcknowledged decoded `shouldBe` True + + describe "SAMappings request rendering" $ do + it "SAMappingsViewRequest round-trips through encode/decode" $ do + let req = OS3A.SAMappingsViewRequest "windows" "windows" + decode (encode req) `shouldBe` Just req + + it "SAUpdateMappingsRequest round-trips through encode/decode" $ do + let req = OS3A.SAUpdateMappingsRequest "windows" "CommandLine" "alias" + decode (encode req) `shouldBe` Just req + + it "SACreateMappingsRequest omits partial when Nothing" $ + let req = + OS3A.SACreateMappingsRequest + "windows" + "windows" + Nothing + (OS3A.SAMappingsBody mempty Null) + in LBS.unpack (encode req) `shouldNotContain` "\"partial\"" + + it "SACreateMappingsRequest includes partial when Just" $ + let req = + OS3A.SACreateMappingsRequest + "windows" + "windows" + (Just True) + (OS3A.SAMappingsBody mempty Null) + in LBS.unpack (encode req) `shouldContain` "\"partial\"" + + it "SACreateMappingsRequest includes partial as false when Just False" $ + let req = + OS3A.SACreateMappingsRequest + "windows" + "windows" + (Just False) + (OS3A.SAMappingsBody mempty Null) + in LBS.unpack (encode req) `shouldContain` "false" + + -- =========================================================== -- + -- Alerts, Findings, Correlation, Log type APIs -- + -- (bloodhound-2cu). Endpoint shape per backend + JSON -- + -- fixtures + rendering round-trips. Live round-trips stay -- + -- @pendingWith@ per the CI-docker-compose precedent -- + -- (bloodhound-dln). -- + -- =========================================================== -- + describe "Alerts/Findings/Correlation/LogType endpoint shape (OpenSearch 3)" $ do + it "getSAAlertsWith GETs /alerts with the options as queries" $ do + let opts = + OS3A.defaultSAGetAlertsOptions + { OS3A.saGetAlertsOptionsDetectorId = Just "d1", + OS3A.saGetAlertsOptionsAlertState = Just OS3A.SAAlertStateActive, + OS3A.saGetAlertsOptionsSize = Just 10 + } + r = OS3Requests.getSAAlertsWith opts + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "alerts"] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldContain` [("detector_id", Just "d1")] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldContain` [("alertState", Just "ACTIVE")] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldContain` [("size", Just "10")] + bhRequestBody r `shouldBe` Nothing + + it "getSAAlertsWith renders no queries when given defaultSAGetAlertsOptions" $ do + let r = OS3Requests.getSAAlertsWith OS3A.defaultSAGetAlertsOptions + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + + it "getSAAlerts GETs /alerts?detector_id={id} and is a projected [SAAlert]" $ do + let r = OS3Requests.getSAAlerts (OS3A.DetectorId "d1") + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "alerts"] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldBe` [("detector_id", Just "d1")] + + it "acknowledgeSADetectorAlerts POSTs /detectors/{id}/_acknowledge/alerts with {\"alerts\":[...]} body" $ do + let r = OS3Requests.acknowledgeSADetectorAlerts (OS3A.DetectorId "d1") ["a1", "a2"] + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "detectors", "d1", "_acknowledge", "alerts"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + let body = fromJust (bhRequestBody r) + LBS.unpack body `shouldContain` "\"alerts\"" + LBS.unpack body `shouldContain` "\"a1\"" + LBS.unpack body `shouldContain` "\"a2\"" + + it "searchSAFindings GETs /findings/_search with the options as queries" $ do + let opts = + OS3A.defaultSASearchFindingsOptions + { OS3A.saSearchFindingsOptionsSeverity = Just OS3A.SASeverityHigh, + OS3A.saSearchFindingsOptionsDetectionType = Just OS3A.SADetectionTypeRule + } + r = OS3Requests.searchSAFindings opts + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "findings", "_search"] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldContain` [("severity", Just "high")] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldContain` [("detectionType", Just "rule")] + + it "createSACorrelationRule POSTs /correlation/rules with the encoded body" $ do + let req = + OS3A.CreateSACorrelationRuleRequest + [ OS3A.SACorrelateEntry "vpc_flow" "dstaddr:4.5.6.7" "network", + OS3A.SACorrelateEntry "windows" "winlog.event_data.X:Y" "windows" + ] + r = OS3Requests.createSACorrelationRule req + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "correlation", "rules"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + let body = fromJust (bhRequestBody r) + LBS.unpack body `shouldContain` "\"correlate\"" + LBS.unpack body `shouldContain` "\"vpc_flow\"" + LBS.unpack body `shouldContain` "\"network\"" + + it "getSACorrelations GETs /correlations with start/end timestamps" $ do + let opts = + OS3A.defaultGetSACorrelationsOptions + { OS3A.getSACorrelationsOptionsStartTimestamp = Just 1689289210000, + OS3A.getSACorrelationsOptionsEndTimestamp = Just 1689300010000 + } + r = OS3Requests.getSACorrelations opts + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "correlations"] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldBe` [ ("start_timestamp", Just "1689289210000"), + ("end_timestamp", Just "1689300010000") + ] + + it "findSACorrelation GETs /findings/correlate with required+optional params" $ do + let opts = + OS3A.defaultFindSACorrelationOptions + { OS3A.findSACorrelationOptionsFinding = Just "f1", + OS3A.findSACorrelationOptionsDetectorType = Just "ad_ldap", + OS3A.findSACorrelationOptionsNearbyFindings = Just 20, + OS3A.findSACorrelationOptionsTimeWindow = Just "10m" + } + r = OS3Requests.findSACorrelation opts + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "findings", "correlate"] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldContain` [("finding", Just "f1")] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldContain` [("detector_type", Just "ad_ldap")] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldContain` [("nearby_findings", Just "20")] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldContain` [("time_window", Just "10m")] + + it "searchSACorrelationAlerts GETs /correlationAlerts with optional filter" $ do + let opts = + OS3A.SearchSACorrelationAlertsOptions + { OS3A.searchSACorrelationAlertsOptionsCorrelationRuleId = Just "rule1" + } + r = OS3Requests.searchSACorrelationAlerts opts + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "correlationAlerts"] + getRawEndpointQueries (bhRequestEndpoint r) + `shouldBe` [("correlation_rule_id", Just "rule1")] + + it "acknowledgeSACorrelationAlerts POSTs /_acknowledge/correlationAlerts with {\"alertIds\":[...]} body" $ do + let r = OS3Requests.acknowledgeSACorrelationAlerts ["ca1", "ca2"] + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "_acknowledge", "correlationAlerts"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + let body = fromJust (bhRequestBody r) + LBS.unpack body `shouldContain` "\"alertIds\"" + LBS.unpack body `shouldContain` "\"ca1\"" + LBS.unpack body `shouldNotContain` "\"alerts\"" + + it "createSALogType POSTs /logtype with the encoded body" $ do + let req = + OS3A.SALogType + { OS3A.saLogTypeName = "custom1", + OS3A.saLogTypeDescription = Just "desc", + OS3A.saLogTypeSource = Just OS3A.SALogTypeSourceCustom, + OS3A.saLogTypeTags = Nothing, + OS3A.saLogTypeOther = Null + } + r = OS3Requests.createSALogType req + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "logtype"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + let body = fromJust (bhRequestBody r) + LBS.unpack body `shouldContain` "\"name\"" + LBS.unpack body `shouldContain` "\"Custom\"" + + it "searchSALogTypes POSTs /logtype/_search with the (possibly default) body" $ do + let r = OS3Requests.searchSALogTypes Nothing + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "logtype", "_search"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + let body = fromJust (bhRequestBody r) + LBS.unpack body `shouldContain` "match_all" + + it "updateSALogType PUTs /logtype/{id} with the encoded body" $ do + let req = + OS3A.SALogType + { OS3A.saLogTypeName = "custom1", + OS3A.saLogTypeDescription = Just "updated", + OS3A.saLogTypeSource = Just OS3A.SALogTypeSourceCustom, + OS3A.saLogTypeTags = Nothing, + OS3A.saLogTypeOther = Null + } + r = OS3Requests.updateSALogType "lt1" req + bhRequestMethod r `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "logtype", "lt1"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + + it "deleteSALogType DELETEs /logtype/{id} with no body" $ do + let r = OS3Requests.deleteSALogType "lt1" + bhRequestMethod r `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "logtype", "lt1"] + getRawEndpointQueries (bhRequestEndpoint r) `shouldBe` [] + bhRequestBody r `shouldBe` Nothing + + it "getSAAlerts keeps the detector_id as a single opaque path segment" $ + getRawEndpoint (bhRequestEndpoint (OS3Requests.getSAAlerts (OS3A.DetectorId "a/b"))) + `shouldBe` ["_plugins", "_security_analytics", "alerts"] + + describe "Alerts/Findings/Correlation/LogType endpoint shape (OpenSearch 2)" $ do + it "getSAAlertsWith GETs .../alerts" $ do + let r = OS2Requests.getSAAlertsWith OS2A.defaultSAGetAlertsOptions + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "alerts"] + + it "acknowledgeSADetectorAlerts POSTs .../detectors/{id}/_acknowledge/alerts" $ do + let r = OS2Requests.acknowledgeSADetectorAlerts (OS2A.DetectorId "d1") ["a1"] + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "detectors", "d1", "_acknowledge", "alerts"] + + it "searchSAFindings GETs .../findings/_search" $ do + let r = OS2Requests.searchSAFindings OS2A.defaultSASearchFindingsOptions + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "findings", "_search"] + + it "createSACorrelationRule POSTs .../correlation/rules" $ do + let r = OS2Requests.createSACorrelationRule (OS2A.CreateSACorrelationRuleRequest []) + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "correlation", "rules"] + + it "getSACorrelations GETs .../correlations" $ do + let r = OS2Requests.getSACorrelations OS2A.defaultGetSACorrelationsOptions + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "correlations"] + + it "findSACorrelation GETs .../findings/correlate" $ do + let r = OS2Requests.findSACorrelation OS2A.defaultFindSACorrelationOptions + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "findings", "correlate"] + + it "searchSACorrelationAlerts GETs .../correlationAlerts" $ do + let r = OS2Requests.searchSACorrelationAlerts OS2A.defaultSearchSACorrelationAlertsOptions + bhRequestMethod r `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "correlationAlerts"] + + it "acknowledgeSACorrelationAlerts POSTs .../_acknowledge/correlationAlerts" $ do + let r = OS2Requests.acknowledgeSACorrelationAlerts [] + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "_acknowledge", "correlationAlerts"] + + it "createSALogType POSTs .../logtype" $ do + let r = OS2Requests.createSALogType (OS2A.SALogType "n" Nothing Nothing Nothing Null) + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "logtype"] + + it "searchSALogTypes POSTs .../logtype/_search" $ do + let r = OS2Requests.searchSALogTypes Nothing + bhRequestMethod r `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint r) + `shouldBe` ["_plugins", "_security_analytics", "logtype", "_search"] + + it "updateSALogType PUTs .../logtype/{id}" $ do + let r = OS2Requests.updateSALogType "lt1" (OS2A.SALogType "n" Nothing Nothing Nothing Null) + bhRequestMethod r `shouldBe` "PUT" + + it "deleteSALogType DELETEs .../logtype/{id}" $ do + let r = OS2Requests.deleteSALogType "lt1" + bhRequestMethod r `shouldBe` "DELETE" + + describe "Alerts/Findings/Correlation/LogType cross-backend parity (OS2/OS3)" $ do + let alertOpts2 = OS2A.defaultSAGetAlertsOptions + alertOpts3 = OS3A.defaultSAGetAlertsOptions + ackBody = ["a1" :: Text] + corrReq2 = OS2A.CreateSACorrelationRuleRequest [] + corrReq3 = OS3A.CreateSACorrelationRuleRequest [] + logType2 = OS2A.SALogType "n" Nothing Nothing Nothing Null + logType3 = OS3A.SALogType "n" Nothing Nothing Nothing Null + + it "getSAAlertsWith: OS2/OS3 produce the same path, method, and queries" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.getSAAlertsWith alertOpts2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.getSAAlertsWith alertOpts3)) + bhRequestMethod (OS2Requests.getSAAlertsWith alertOpts2) + `shouldBe` bhRequestMethod (OS3Requests.getSAAlertsWith alertOpts3) + getRawEndpointQueries (bhRequestEndpoint (OS2Requests.getSAAlertsWith alertOpts2)) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint (OS3Requests.getSAAlertsWith alertOpts3)) + + it "acknowledgeSADetectorAlerts: OS2/OS3 produce the same path, method, and body" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.acknowledgeSADetectorAlerts (OS2A.DetectorId "d") ackBody)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.acknowledgeSADetectorAlerts (OS3A.DetectorId "d") ackBody)) + bhRequestBody (OS2Requests.acknowledgeSADetectorAlerts (OS2A.DetectorId "d") ackBody) + `shouldBe` bhRequestBody (OS3Requests.acknowledgeSADetectorAlerts (OS3A.DetectorId "d") ackBody) + + it "searchSAFindings: OS2/OS3 produce the same path and method" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.searchSAFindings OS2A.defaultSASearchFindingsOptions)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.searchSAFindings OS3A.defaultSASearchFindingsOptions)) + bhRequestMethod (OS2Requests.searchSAFindings OS2A.defaultSASearchFindingsOptions) + `shouldBe` bhRequestMethod (OS3Requests.searchSAFindings OS3A.defaultSASearchFindingsOptions) + + it "createSACorrelationRule: OS2/OS3 produce the same path, method, and body" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.createSACorrelationRule corrReq2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.createSACorrelationRule corrReq3)) + bhRequestBody (OS2Requests.createSACorrelationRule corrReq2) + `shouldBe` bhRequestBody (OS3Requests.createSACorrelationRule corrReq3) + + it "getSACorrelations: OS2/OS3 produce the same path and method" $ + getRawEndpoint (bhRequestEndpoint (OS2Requests.getSACorrelations OS2A.defaultGetSACorrelationsOptions)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.getSACorrelations OS3A.defaultGetSACorrelationsOptions)) + + it "findSACorrelation: OS2/OS3 produce the same path and method" $ + getRawEndpoint (bhRequestEndpoint (OS2Requests.findSACorrelation OS2A.defaultFindSACorrelationOptions)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.findSACorrelation OS3A.defaultFindSACorrelationOptions)) + + it "searchSACorrelationAlerts: OS2/OS3 produce the same path and method" $ + getRawEndpoint (bhRequestEndpoint (OS2Requests.searchSACorrelationAlerts OS2A.defaultSearchSACorrelationAlertsOptions)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.searchSACorrelationAlerts OS3A.defaultSearchSACorrelationAlertsOptions)) + + it "acknowledgeSACorrelationAlerts: OS2/OS3 produce the same path, method, and body" $ do + getRawEndpoint (bhRequestEndpoint (OS2Requests.acknowledgeSACorrelationAlerts ackBody)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.acknowledgeSACorrelationAlerts ackBody)) + bhRequestBody (OS2Requests.acknowledgeSACorrelationAlerts ackBody) + `shouldBe` bhRequestBody (OS3Requests.acknowledgeSACorrelationAlerts ackBody) + + it "createSALogType: OS2/OS3 produce the same path and method" $ + getRawEndpoint (bhRequestEndpoint (OS2Requests.createSALogType logType2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.createSALogType logType3)) + + it "searchSALogTypes: OS2/OS3 produce the same path and method" $ + getRawEndpoint (bhRequestEndpoint (OS2Requests.searchSALogTypes Nothing)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.searchSALogTypes Nothing)) + + it "updateSALogType: OS2/OS3 produce the same path and method" $ + getRawEndpoint (bhRequestEndpoint (OS2Requests.updateSALogType "lt" logType2)) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.updateSALogType "lt" logType3)) + + it "deleteSALogType: OS2/OS3 produce the same path and method" $ + getRawEndpoint (bhRequestEndpoint (OS2Requests.deleteSALogType "lt")) + `shouldBe` getRawEndpoint (bhRequestEndpoint (OS3Requests.deleteSALogType "lt")) + + describe "SAAlertState / SADetectionType / SASeverity / SALogTypeSource enums" $ do + it "SAAlertState round-trips every documented value" $ do + OS3A.saAlertStateText OS3A.SAAlertStateActive `shouldBe` "ACTIVE" + OS3A.saAlertStateText OS3A.SAAlertStateAcknowledged `shouldBe` "ACKNOWLEDGED" + OS3A.saAlertStateText OS3A.SAAlertStateCompleted `shouldBe` "COMPLETED" + OS3A.saAlertStateText OS3A.SAAlertStateError `shouldBe` "ERROR" + OS3A.saAlertStateText OS3A.SAAlertStateDeleted `shouldBe` "DELETED" + decode "\"ACTIVE\"" `shouldBe` Just OS3A.SAAlertStateActive + decode "\"DELETED\"" `shouldBe` Just OS3A.SAAlertStateDeleted + decode "\"FUTURE\"" `shouldBe` Just (OS3A.SAAlertStateOther "FUTURE") + + it "SADetectionType round-trips rule/threat" $ do + OS3A.saDetectionTypeText OS3A.SADetectionTypeRule `shouldBe` "rule" + decode "\"threat\"" `shouldBe` Just OS3A.SADetectionTypeThreat + + it "SASeverity round-trips every documented value" $ do + OS3A.saSeverityText OS3A.SASeverityCritical `shouldBe` "critical" + decode "\"low\"" `shouldBe` Just OS3A.SASeverityLow + + it "SALogTypeSource round-trips Sigma/Custom/Other" $ do + OS3A.saLogTypeSourceText OS3A.SALogTypeSourceSigma `shouldBe` "Sigma" + OS3A.saLogTypeSourceText OS3A.SALogTypeSourceCustom `shouldBe` "Custom" + decode "\"Custom\"" `shouldBe` Just OS3A.SALogTypeSourceCustom + decode "\"Future\"" `shouldBe` Just (OS3A.SALogTypeSourceOther "Future") + + describe "SAGetAlertsResponse decoding (get-alerts fixture)" $ do + let fixture = + LBS.pack + "{\"alerts\":[{\"detector_id\":\"detector_12345\",\"id\":\"alert_id_1\",\ + \\"version\":-3,\"schema_version\":0,\"trigger_id\":\"trig1\",\ + \\"trigger_name\":\"my_trigger\",\"finding_ids\":[\"finding_id_1\"],\ + \\"related_doc_ids\":[\"docId1\"],\"state\":\"ACTIVE\",\ + \\"error_message\":null,\"alert_history\":[],\"severity\":null,\ + \\"action_execution_results\":[{\"action_id\":\"action_id_1\",\ + \\"last_execution_time\":1665693544996,\"throttled_count\":0}],\ + \\"start_time\":\"2022-10-13T20:39:04.995023Z\",\ + \\"last_notification_time\":\"2022-10-13T20:39:04.995028Z\",\ + \\"end_time\":\"2022-10-13T20:39:04.995027Z\",\ + \\"acknowledged_time\":\"2022-10-13T20:39:04.995028Z\"}],\ + \\"total_alerts\":1,\"detectorType\":\"windows\"}" + + it "decodes the documented get-alerts fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.SAGetAlertsResponse + OS3A.saGetAlertsResponseTotalAlerts decoded `shouldBe` Just 1 + OS3A.saGetAlertsResponseDetectorType decoded `shouldBe` Just "windows" + let [alert] = OS3A.saGetAlertsResponseAlerts decoded + OS3A.saAlertId alert `shouldBe` Just "alert_id_1" + OS3A.saAlertDetectorId alert `shouldBe` Just "detector_12345" + OS3A.saAlertVersion alert `shouldBe` Just (-3) + OS3A.saAlertState alert `shouldBe` Just OS3A.SAAlertStateActive + OS3A.saAlertFindingIds alert `shouldBe` Just ["finding_id_1"] + OS3A.saAlertStartTime alert `shouldBe` Just "2022-10-13T20:39:04.995023Z" + let [action] = fromJust (OS3A.saAlertActionExecutionResults alert) + OS3A.saActionExecutionResultActionId action `shouldBe` Just "action_id_1" + OS3A.saActionExecutionResultLastExecutionTime action `shouldBe` Just 1665693544996 + + it "decodes an empty alerts array" $ do + let Just decoded = decode "{\"alerts\":[],\"total_alerts\":0}" :: Maybe OS3A.SAGetAlertsResponse + OS3A.saGetAlertsResponseAlerts decoded `shouldBe` [] + + describe "AcknowledgeSADetectorAlertsResponse decoding (ack fixture)" $ do + let reqFixture = LBS.pack "{\"alerts\":[\"id1\",\"id2\"]}" + respFixture = + LBS.pack + "{\"acknowledged\":[{\"id\":\"id1\",\"state\":\"ACTIVE\",\"severity\":\"1\"}],\ + \\"failed\":[],\"missing\":[]}" + + it "acknowledge request renders as {\"alerts\":[...]} (snake_case)" $ do + let Just decoded = decode reqFixture :: Maybe OS3A.AcknowledgeSADetectorAlertsRequest + OS3A.acknowledgeSADetectorAlertsRequestAlerts decoded `shouldBe` ["id1", "id2"] + + it "decodes the documented ack-response fixture" $ do + let Just decoded = decode respFixture :: Maybe OS3A.AcknowledgeSADetectorAlertsResponse + let [alert] = OS3A.acknowledgeSADetectorAlertsResponseAcknowledged decoded + OS3A.saAlertId alert `shouldBe` Just "id1" + OS3A.saAlertSeverity alert `shouldBe` Just "1" + + describe "SASearchFindingsResponse decoding (findings fixture)" $ do + let fixture = + LBS.pack + "{\"total_findings\":1,\"findings\":[{\"detectorId\":\"d1\",\"id\":\"f1\",\ + \\"related_doc_ids\":[\"1\"],\"index\":\"smallidx\",\ + \\"queries\":[{\"id\":\"q1\",\"name\":\"q1\",\"fields\":[],\ + \\"query\":\"field1: *value1*\",\"tags\":[\"high\",\"ad_ldap\"]}],\ + \\"timestamp\":1708647166500,\ + \\"document_list\":[{\"index\":\"smallidx\",\"id\":\"1\",\"found\":true,\ + \\"document\":\"{\\\"field1\\\":\\\"value1\\\"}\"}]}]}" + + it "decodes the documented findings fixture (camelCase detectorId)" $ do + let Just decoded = decode fixture :: Maybe OS3A.SASearchFindingsResponse + OS3A.saSearchFindingsResponseTotalFindings decoded `shouldBe` Just 1 + let [f] = OS3A.saSearchFindingsResponseFindings decoded + OS3A.saFindingDetectorId f `shouldBe` Just "d1" + OS3A.saFindingId f `shouldBe` Just "f1" + OS3A.saFindingTimestamp f `shouldBe` Just 1708647166500 + let [q] = fromJust (OS3A.saFindingQueries f) + OS3A.saFindingQueryTags q `shouldBe` Just ["high", "ad_ldap"] + let [d] = fromJust (OS3A.saFindingDocumentList f) + OS3A.saFindingDocumentFound d `shouldBe` Just True + -- the @document@ field is a JSON-stringified source, NOT a nested object + OS3A.saFindingDocumentDocument d `shouldBe` Just "{\"field1\":\"value1\"}" + + describe "CreateSACorrelationRuleResponse decoding (create fixture)" $ do + let fixture = + LBS.pack + "{\"_id\":\"DxKEUIkBpIjg64IK4nXg\",\"_version\":1,\ + \\"rule\":{\"name\":null,\"correlate\":[{\"index\":\"vpc_flow\",\ + \\"query\":\"dstaddr:4.5.6.7\",\"category\":\"network\"}]}}" + + it "decodes the documented create-correlation-rule fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.CreateSACorrelationRuleResponse + OS3A.createSACorrelationRuleResponseId decoded `shouldBe` "DxKEUIkBpIjg64IK4nXg" + OS3A.createSACorrelationRuleResponseVersion decoded `shouldBe` 1 + let rule = OS3A.createSACorrelationRuleResponseRule decoded + OS3A.saCorrelationRuleName rule `shouldBe` Nothing + let [entry] = OS3A.saCorrelationRuleCorrelate rule + OS3A.saCorrelateEntryIndex entry `shouldBe` "vpc_flow" + + describe "GetSACorrelationsResponse decoding (time-window fixture)" $ do + let fixture = + LBS.pack + "{\"findings\":[{\"finding1\":\"f1\",\"logType1\":\"network\",\ + \\"finding2\":\"f2\",\"logType2\":\"test_windows\",\ + \\"rules\":[\"nqI2TokBgL5wWFPZ6Gfu\"]}]}" + + it "decodes the documented correlations fixture (camelCase logType1/2)" $ do + let Just decoded = decode fixture :: Maybe OS3A.GetSACorrelationsResponse + let [cf] = OS3A.getSACorrelationsResponseFindings decoded + OS3A.saCorrelationFindingFinding1 cf `shouldBe` Just "f1" + OS3A.saCorrelationFindingLogType1 cf `shouldBe` Just "network" + OS3A.saCorrelationFindingFinding2 cf `shouldBe` Just "f2" + OS3A.saCorrelationFindingRules cf `shouldBe` Just ["nqI2TokBgL5wWFPZ6Gfu"] + + describe "FindSACorrelationResponse decoding (correlate fixture)" $ do + let fixture = + LBS.pack + "{\"findings\":[{\"finding\":\"5c661104-aaa9-484b-a91f-9cad4ae6d5f5\",\ + \\"detector_type\":\"others_application\",\"score\":0.000015182109564193524}]}" + + it "decodes the documented find-correlation fixture (snake_case detector_type)" $ do + let Just decoded = decode fixture :: Maybe OS3A.FindSACorrelationResponse + let [s] = OS3A.findSACorrelationResponseFindings decoded + OS3A.saCorrelationScoreFinding s `shouldBe` Just "5c661104-aaa9-484b-a91f-9cad4ae6d5f5" + OS3A.saCorrelationScoreDetectorType s `shouldBe` Just "others_application" + OS3A.saCorrelationScoreScore s `shouldSatisfy` maybe False (>= 0) + + describe "SearchSACorrelationAlertsResponse decoding (list fixture)" $ do + let fixture = + LBS.pack + "{\"correlationAlerts\":[{\"correlated_finding_ids\":[\"cf1\"],\ + \\"correlation_rule_id\":\"cr1\",\"correlation_rule_name\":\"rule-corr\",\ + \\"user\":null,\"id\":\"ca1\",\"version\":1,\"schema_version\":1,\ + \\"trigger_name\":\"trigger1\",\"state\":\"ACTIVE\",\ + \\"error_message\":null,\"severity\":\"1\",\ + \\"action_execution_results\":[{\"action_id\":\"act1\",\ + \\"last_execution_time\":1718824628257,\"throttled_count\":0}],\ + \\"start_time\":\"2024-06-19T20:37:08.257Z\",\ + \\"end_time\":\"2024-06-19T20:42:08.257Z\",\"acknowledged_time\":null}],\ + \\"total_alerts\":1}" + + it "decodes the documented correlation-alerts fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.SearchSACorrelationAlertsResponse + OS3A.searchSACorrelationAlertsResponseTotalAlerts decoded `shouldBe` Just 1 + let [ca] = OS3A.searchSACorrelationAlertsResponseCorrelationAlerts decoded + OS3A.saCorrelationAlertId ca `shouldBe` Just "ca1" + OS3A.saCorrelationAlertCorrelationRuleId ca `shouldBe` Just "cr1" + OS3A.saCorrelationAlertCorrelatedFindingIds ca `shouldBe` Just ["cf1"] + OS3A.saCorrelationAlertState ca `shouldBe` Just OS3A.SAAlertStateActive + OS3A.saCorrelationAlertSeverity ca `shouldBe` Just "1" + -- the typed action_execution_results (S4 fix: matches SAAlert's typing) + let [action] = fromJust (OS3A.saCorrelationAlertActionExecutionResults ca) + OS3A.saActionExecutionResultActionId action `shouldBe` Just "act1" + OS3A.saActionExecutionResultThrottledCount action `shouldBe` Just 0 + + describe "AcknowledgeSACorrelationAlerts (request + response) decoding" $ do + let reqFixture = LBS.pack "{\"alertIds\":[\"ca1\",\"ca2\"]}" + respFixture = + LBS.pack + "{\"acknowledged\":[{\"id\":\"ca1\",\"state\":\"ACTIVE\"}],\"failed\":[]}" + + it "acknowledge request renders as {\"alertIds\":[...]} (camelCase, NOT alerts)" $ do + let Just decoded = decode reqFixture :: Maybe OS3A.AcknowledgeSACorrelationAlertsRequest + OS3A.acknowledgeSACorrelationAlertsRequestAlertIds decoded `shouldBe` ["ca1", "ca2"] + LBS.unpack (encode (OS3A.AcknowledgeSACorrelationAlertsRequest ["x"])) + `shouldContain` "\"alertIds\"" + + it "decodes the documented ack-correlation-alerts fixture (NO missing key)" $ do + let Just decoded = decode respFixture :: Maybe OS3A.AcknowledgeSACorrelationAlertsResponse + let [ca] = OS3A.acknowledgeSACorrelationAlertsResponseAcknowledged decoded + OS3A.saCorrelationAlertId ca `shouldBe` Just "ca1" + + describe "SALogType / SALogTypeResponse decoding (create fixture)" $ do + let reqFixture = + LBS.pack + "{\"description\":\"custom-log-type-desc\",\"name\":\"custom-log-type4\",\ + \\"source\":\"Custom\"}" + respFixture = + LBS.pack + "{\"_id\":\"m98uk4kBlb9cbROIpEj2\",\"_version\":1,\ + \\"logType\":{\"name\":\"custom-log-type4\",\ + \\"description\":\"custom-log-type-desc\",\"source\":\"Custom\",\ + \\"tags\":{\"correlation_id\":27}}}" + + it "decodes a documented log-type request body" $ do + let Just decoded = decode reqFixture :: Maybe OS3A.SALogType + OS3A.saLogTypeName decoded `shouldBe` "custom-log-type4" + OS3A.saLogTypeSource decoded `shouldBe` Just OS3A.SALogTypeSourceCustom + + it "decodes the documented log-type create/update fixture (camelCase logType wrapper)" $ do + let Just decoded = decode respFixture :: Maybe OS3A.SALogTypeResponse + OS3A.saLogTypeResponseId decoded `shouldBe` "m98uk4kBlb9cbROIpEj2" + OS3A.saLogTypeResponseVersion decoded `shouldBe` 1 + let lt = OS3A.saLogTypeResponseLogType decoded + OS3A.saLogTypeName lt `shouldBe` "custom-log-type4" + let tags = fromJust (OS3A.saLogTypeTags lt) + OS3A.saLogTypeTagsCorrelationId tags `shouldBe` Just 27 + + describe "SALogTypesSearchResponse decoding (search fixture)" $ do + let fixture = + LBS.pack + "{\"took\":3,\"timed_out\":false,\"_shards\":{\"total\":1,\ + \\"successful\":1,\"skipped\":0,\"failed\":0},\ + \\"hits\":{\"total\":{\"value\":26,\"relation\":\"eq\"},\ + \\"max_score\":2.0,\"hits\":[{\"_index\":\".opensearch-sap-log-types-config\",\ + \\"_id\":\"s3\",\"_score\":2.0,\ + \\"_source\":{\"name\":\"s3\",\"description\":\"Windows logs\",\ + \\"source\":\"Sigma\",\"tags\":{\"correlation_id\":21}}},{\ + \\"_index\":\".opensearch-sap-log-types-config\",\"_id\":\"custom1\",\ + \\"_score\":2.0,\"_source\":{\"name\":\"custom-lt\",\"description\":\"d\",\ + \\"source\":\"Custom\",\"tags\":null}}]}}" + + it "decodes the documented log-type search fixture (standard OS search envelope)" $ do + let Just decoded = decode fixture :: Maybe OS3A.SALogTypesSearchResponse + OS3A.saLogTypesSearchResponseTook decoded `shouldBe` Just 3 + let total = fromJust (OS3A.saLogTypesSearchResponseHitsTotal decoded) + OS3A.saLogTypesTotalValue total `shouldBe` 26 + OS3A.saLogTypesTotalRelation total `shouldBe` OS3A.SALogTypesTotalRelationEq + length (OS3A.saLogTypesSearchResponseHits decoded) `shouldBe` 2 + let lts = OS3A.saLogTypesSearchResponseLogTypes decoded + length lts `shouldBe` 2 + -- Check fields individually (the saLogTypeOther catch-all breaks structural equality) + OS3A.saLogTypeName (head lts) `shouldBe` "s3" + OS3A.saLogTypeDescription (head lts) `shouldBe` Just "Windows logs" + OS3A.saLogTypeSource (head lts) `shouldBe` Just OS3A.SALogTypeSourceSigma + let Just tags = OS3A.saLogTypeTags (head lts) + OS3A.saLogTypeTagsCorrelationId tags `shouldBe` Just 21 + + it "tolerates null tags on a custom log type" $ do + let Just decoded = decode fixture :: Maybe OS3A.SALogTypesSearchResponse + lts = OS3A.saLogTypesSearchResponseLogTypes decoded + OS3A.saLogTypeTags (lts !! 1) `shouldBe` Nothing + + describe "DeleteSALogTypeResponse decoding (delete fixture)" $ do + let fixture = LBS.pack "{\"_id\":\"m98uk4kBlb9cbROIpEj2\",\"_version\":1}" + + it "decodes the documented delete-log-type fixture" $ do + let Just decoded = decode fixture :: Maybe OS3A.DeleteSALogTypeResponse + OS3A.deleteSALogTypeResponseId decoded `shouldBe` "m98uk4kBlb9cbROIpEj2" + OS3A.deleteSALogTypeResponseVersion decoded `shouldBe` 1 + + describe "Alerts/Findings/Correlation/LogType request rendering" $ do + it "CreateSACorrelationRuleRequest round-trips through encode/decode" $ do + let req = OS3A.CreateSACorrelationRuleRequest [OS3A.SACorrelateEntry "i" "q" "c"] + decode (encode req) `shouldBe` Just req + + it "SACorrelateEntry round-trips" $ do + let e = OS3A.SACorrelateEntry "vpc_flow" "dstaddr:1.2.3.4" "network" + decode (encode e) `shouldBe` Just e + + it "SALogType renders with documented fields (omits Nothing tags)" $ do + let req = OS3A.SALogType "n" (Just "d") (Just OS3A.SALogTypeSourceCustom) Nothing Null + body = encode req + LBS.unpack body `shouldContain` "\"name\"" + LBS.unpack body `shouldContain` "\"Custom\"" + LBS.unpack body `shouldNotContain` "\"tags\"" + + it "SALogType preserves an unknown forward-compat key via the catch-all" $ do + let lbs = LBS.pack "{\"name\":\"n\",\"future_key\":42}" + Just decoded = decode lbs :: Maybe OS3A.SALogType + OS3A.saLogTypeName decoded `shouldBe` "n" + LBS.unpack (encode decoded) `shouldContain` "\"future_key\"" + + it "defaultSALogTypeSearchQuery renders as {\"query\":{\"match_all\":{}}}" $ do + LBS.unpack (encode OS3A.defaultSALogTypeSearchQuery) `shouldContain` "match_all" + + it "AcknowledgeSADetectorAlertsRequest round-trips" $ do + let req = OS3A.AcknowledgeSADetectorAlertsRequest ["a", "b"] + decode (encode req) `shouldBe` Just req + + it "AcknowledgeSACorrelationAlertsRequest round-trips (camelCase alertIds)" $ do + let req = OS3A.AcknowledgeSACorrelationAlertsRequest ["a", "b"] + decode (encode req) `shouldBe` Just req + LBS.unpack (encode req) `shouldContain` "\"alertIds\"" + + describe "Alerts/Findings/Correlation/LogType live round-trip (gated)" $ do + os2It <- runIO os2OnlyIT + os3It <- runIO os3OnlyIT + + os2It "OS2: getSAAlerts/Findings/Correlations/LogTypes stay pending (no live fixtures yet)" $ + pendingWith + "Live round-trips for the alerts/findings/correlation/log-type \ + \endpoints are not yet wired (require a Security Analytics \ + \detector with findings/alerts set up). The endpoint shapes and \ + \wire formats are pinned by the pure tests above; live \ + \verification tracked as a follow-up." + + os3It "OS3: getSAAlerts/Findings/Correlations/LogTypes stay pending (no live fixtures yet)" $ + pendingWith + "Live round-trips for the alerts/findings/correlation/log-type \ + \endpoints are not yet wired (require a Security Analytics \ + \detector with findings/alerts set up). The endpoint shapes and \ + \wire formats are pinned by the pure tests above; live \ + \verification tracked as a follow-up." + + -- =========================================================== -- + -- Live round-trip: gated per-OS with os{n}OnlyIT (the -- + -- 'Test.NeuralClearCacheSpec' pattern). Wire shapes -- + -- live-verified on OS 2.19.5 and 3.7.0 (bead bloodhound-z5j). -- + -- -- + -- The DELETE-detector response shape is version-dependent: OS -- + -- 2.x/3.x return only @{_id,_version}@. The detector input -- + -- requires a pre-existing index, so @windows@ is created in -- + -- setup. -- + -- =========================================================== -- + describe "deleteSADetector live round-trip (version-dependent shape)" $ do + os2It <- runIO os2OnlyIT + os3It <- runIO os3OnlyIT + + let ensureWindowsIndex = + tryEsError + ( void $ + performBHRequest $ + createIndex + (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) + [qqIndexName|windows|] + ) + + os2It "OS2: create -> delete returns the minimal {_id,_version} body" $ + withTestEnv $ do + _ <- ensureWindowsIndex + resp <- OS2.Client.createSADetector os2SampleDetector + let did = OS2A.DetectorId (OS2A.saDetectorResponseId resp) + del <- OS2.Client.deleteSADetector did + liftIO $ do + OS2A.deleteSADetectorResponseId del `shouldBe` OS2A.saDetectorResponseId resp + OS2A.deleteSADetectorResponseVersion del `shouldSatisfy` (>= 1) + OS2A.deleteSADetectorResponseIndex del `shouldBe` Nothing + OS2A.deleteSADetectorResponseShards del `shouldBe` Nothing + OS2A.deleteSADetectorResponseResult del `shouldBe` Nothing + + os3It "OS3: create -> delete returns the minimal {_id,_version} body" $ + withTestEnv $ do + _ <- ensureWindowsIndex + resp <- OS3.Client.createSADetector os3SampleDetector + let did = OS3A.DetectorId (OS3A.saDetectorResponseId resp) + del <- OS3.Client.deleteSADetector did + liftIO $ do + OS3A.deleteSADetectorResponseId del `shouldBe` OS3A.saDetectorResponseId resp + OS3A.deleteSADetectorResponseVersion del `shouldSatisfy` (>= 1) + OS3A.deleteSADetectorResponseIndex del `shouldBe` Nothing + OS3A.deleteSADetectorResponseShards del `shouldBe` Nothing + OS3A.deleteSADetectorResponseResult del `shouldBe` Nothing + +-- ---------------------------------------------------------------- -- +-- Sample fixtures (structurally identical across OS2/OS3; -- +-- nominally distinct types, so one per backend). -- +-- ---------------------------------------------------------------- -- + +os3SampleDetector :: OS3A.SADetector +os3SampleDetector = + OS3A.SADetector + { OS3A.saDetectorName = "test-detector", + OS3A.saDetectorType = OS3A.SADetectorTypeWindows, + OS3A.saDetectorKind = Just "detector", + OS3A.saDetectorEnabled = Just True, + OS3A.saDetectorSchedule = + OS3A.PeriodSASchedule (OS3A.SASchedulePeriod 1 "MINUTES"), + OS3A.saDetectorInputs = + [ OS3A.SADetectorInput + { OS3A.saDetectorInputDescription = Just "windows detector for security analytics", + OS3A.saDetectorInputIndices = ["windows"], + OS3A.saDetectorInputCustomRules = [], + OS3A.saDetectorInputPrePackagedRules = + [OS3A.SARuleReference "06724a9a-52fc-11ed-bdc3-0242ac120002"], + OS3A.saDetectorInputOther = Null + } + ], + OS3A.saDetectorTriggers = + [ OS3A.SATrigger + { OS3A.saTriggerId = Just "test-trigger-id", + OS3A.saTriggerName = "test-trigger", + OS3A.saTriggerSeverity = "1", + OS3A.saTriggerIds = [], + OS3A.saTriggerTypes = [], + OS3A.saTriggerTags = ["attack.defense_evasion"], + OS3A.saTriggerSevLevels = [], + OS3A.saTriggerActions = [], + OS3A.saTriggerOther = Null + } + ], + OS3A.saDetectorOther = Null + } + +os2SampleDetector :: OS2A.SADetector +os2SampleDetector = + OS2A.SADetector + { OS2A.saDetectorName = "test-detector", + OS2A.saDetectorType = OS2A.SADetectorTypeWindows, + OS2A.saDetectorKind = Just "detector", + OS2A.saDetectorEnabled = Just True, + OS2A.saDetectorSchedule = + OS2A.PeriodSASchedule (OS2A.SASchedulePeriod 1 "MINUTES"), + OS2A.saDetectorInputs = + [ OS2A.SADetectorInput + { OS2A.saDetectorInputDescription = Just "windows detector for security analytics", + OS2A.saDetectorInputIndices = ["windows"], + OS2A.saDetectorInputCustomRules = [], + OS2A.saDetectorInputPrePackagedRules = + [OS2A.SARuleReference "06724a9a-52fc-11ed-bdc3-0242ac120002"], + OS2A.saDetectorInputOther = Null + } + ], + OS2A.saDetectorTriggers = + [ OS2A.SATrigger + { OS2A.saTriggerId = Just "test-trigger-id", + OS2A.saTriggerName = "test-trigger", + OS2A.saTriggerSeverity = "1", + OS2A.saTriggerIds = [], + OS2A.saTriggerTypes = [], + OS2A.saTriggerTags = ["attack.defense_evasion"], + OS2A.saTriggerSevLevels = [], + OS2A.saTriggerActions = [], + OS2A.saTriggerOther = Null + } + ], + OS2A.saDetectorOther = Null + } + +-- | Helper assertion: the given wire string decodes to the expected +-- 'SADetectorType'. +decodesDetectorTypeTo :: Text -> OS3A.SADetectorType -> Expectation +decodesDetectorTypeTo wire expected = + decode (encode wire) `shouldBe` Just expected + +-- | A sample Sigma rule document (raw YAML text), verbatim from the +-- OS docs create-custom-rule example. Used to assert that the rule +-- CRUD request builders forward the body verbatim (not JSON-encoded). +sampleSigmaYaml :: Text +sampleSigmaYaml = + "title: Moriya Rootkit\n\ + \id: 25b9c01c-350d-4b95-bed1-836d04a4f324\n\ + \description: Detects the use of Moriya rootkit\n\ + \status: experimental\n\ + \author: Bhabesh Raj\n\ + \logsource:\n\ + \ product: windows\n\ + \ service: system\n\ + \detection:\n\ + \ selection:\n\ + \ Provider_Name: 'Service Control Manager'\n\ + \ EventID: 7045\n\ + \ ServiceName: ZzNetSvc\n\ + \ condition: selection\n\ + \level: critical\n\ + \falsepositives:\n\ + \ - Unknown" diff --git a/tests/Test/SecurityApiKeysSpec.hs b/tests/Test/SecurityApiKeysSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SecurityApiKeysSpec.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SecurityApiKeysSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as L +import TestsUtils.Import +import Prelude + +-- | @POST /_security/api_key@ response — the plaintext @api_key@ and the +-- base64 @encoded@ token are present ONLY here. +sampleCreatedBytes :: L.ByteString +sampleCreatedBytes = + "{\ + \ \"id\": \"VuaCfGJBC186LdfnLWIw\",\ + \ \"name\": \"my-api-key\",\ + \ \"api_key\": \"ui2lp2x2ninwsksjdb2ws6g_\",\ + \ \"encoded\": \"VnVhQ2ZHSkJDMTg2TGRmbkxXSXc6dWkybHAyeDJuaW53c2tnamIyd3M2Z18=\",\ + \ \"metadata\": {\"app\": \"beta\"}\ + \}" + +-- | One entry from @GET /_security/api_key@ — NO @api_key@ \/ @encoded@. +sampleRetrieveEntryBytes :: L.ByteString +sampleRetrieveEntryBytes = + "{\ + \ \"id\": \"VuaCfGJBC186LdfnLWIw\",\ + \ \"name\": \"my-api-key\",\ + \ \"creation\": 1550761411000,\ + \ \"expiration\": 1550800000000,\ + \ \"invalidated\": false,\ + \ \"username\": \"alice\",\ + \ \"realm\": \"reserved\",\ + \ \"role_descriptors\": {\ + \ \"my-role\": {\ + \ \"cluster\": [\"monitor\"],\ + \ \"indices\": [{\"names\": [\"*\"], \"privileges\": [\"read\"]}]\ + \ }\ + \ }\ + \}" + +-- | @DELETE /_security/api_key@ response with a partial failure. +sampleInvalidateBytes :: L.ByteString +sampleInvalidateBytes = + "{\ + \ \"invalidated_api_keys\": [\"id1\"],\ + \ \"previously_owned_api_keys\": [],\ + \ \"error_count\": 1,\ + \ \"error_details\": [\ + \ {\"id\": \"id2\", \"type\": \"exception\", \"reason\": \"not found\"}\ + \ ]\ + \}" + +-- | @POST /_security/_query/api_key@ response: @total@ \/ @count@, a +-- page of @api_keys@ (each carrying query-only fields @realm_type@ \/ +-- @_sort@ that fall into 'ApiKeyInfo''s extras), plus a top-level +-- @aggregations@ blob that falls into 'qkrExtras'. +sampleQueryBytes :: L.ByteString +sampleQueryBytes = + "{\"total\": 2, \"count\": 1, \"api_keys\": [{\"id\": \"id1\", \"name\": \"n1\", \"realm_type\": \"reserved\", \"_sort\": [\"x\"]}], \"aggregations\": {\"foo\": {}}}" + +spec :: Spec +spec = do + describe "ApiKeyCreatedResponse" $ do + it "decodes the plaintext secret + encoded token" $ do + let Just c = decode sampleCreatedBytes :: Maybe ApiKeyCreatedResponse + akcId c `shouldBe` "VuaCfGJBC186LdfnLWIw" + akcName c `shouldBe` "my-api-key" + akcApiKey c `shouldBe` Just "ui2lp2x2ninwsksjdb2ws6g_" + akcEncoded c `shouldSatisfy` isJust + KM.lookup "app" (fromMaybe KM.empty (akcMetadata c)) `shouldSatisfy` isJust + + it "tolerates an absent api_key (older ES)" $ do + let Just c = decode "{\"id\":\"i\",\"name\":\"n\"}" :: Maybe ApiKeyCreatedResponse + akcApiKey c `shouldBe` Nothing + + describe "ApiKeyInfo" $ do + it "decodes WITHOUT api_key / encoded and embeds role_descriptors" $ do + let Just i = decode sampleRetrieveEntryBytes :: Maybe ApiKeyInfo + akiId i `shouldBe` "VuaCfGJBC186LdfnLWIw" + akiCreation i `shouldBe` Just 1550761411000 + akiInvalidated i `shouldBe` Just False + akiRealm i `shouldBe` Just "reserved" + -- role_descriptors reuses the Role type. + case akiRoleDescriptors i of + Just [(RoleName "my-role", role)] -> + rCluster role `shouldBe` ["monitor"] + other -> expectationFailure ("expected one role descriptor, got " <> show other) + + it "preserves unknown sibling fields in extras (forward-compat)" $ do + let bytes = + "{\ + \ \"id\": \"i\",\ + \ \"name\": \"n\",\ + \ \"agent\": \"kibana\",\ + \ \"creation_by\": \"alice\"\ + \}" + let Just i = decode bytes :: Maybe ApiKeyInfo + KM.lookup "agent" (akiExtras i) `shouldSatisfy` isJust + KM.lookup "creation_by" (akiExtras i) `shouldSatisfy` isJust + -- Stable round-trip: extras survive encode . decode. + let Just rt = decode (encode i) :: Maybe ApiKeyInfo + KM.lookup "agent" (akiExtras rt) `shouldSatisfy` isJust + + describe "CreateApiKeyRequest" $ do + it "omits role_descriptors when empty" $ do + let req = defaultCreateApiKeyRequest "my-key" + encode req `shouldBe` "{\"name\":\"my-key\"}" + + it "encodes role_descriptors keyed by role name and round-trips" $ do + let role = defaultRole {rCluster = ["monitor"]} + req = + (defaultCreateApiKeyRequest "my-key") + { cakRoleDescriptors = Just [(RoleName "my-role", role)], + cakExpiration = Just "1d" + } + let Just rt = decode (encode req) :: Maybe CreateApiKeyRequest + cakName rt `shouldBe` "my-key" + cakExpiration rt `shouldBe` Just "1d" + case cakRoleDescriptors rt of + Just [(RoleName "my-role", role')] -> rCluster role' `shouldBe` ["monitor"] + other -> expectationFailure ("expected one role descriptor, got " <> show other) + + describe "GrantApiKeyRequest" $ do + it "round-trips a password grant" $ do + let req = + GrantApiKeyRequest + { ggrGrantType = GrantTypePassword, + ggrAccessToken = Nothing, + ggrUsername = Just "alice", + ggrPassword = Just "pw", + ggrApiKey = defaultApiKeySpec "granted", + ggrRunAs = Nothing + } + let Just rt = decode (encode req) :: Maybe GrantApiKeyRequest + ggrGrantType rt `shouldBe` GrantTypePassword + ggrUsername rt `shouldBe` Just "alice" + + it "rejects an unknown grant_type" $ do + decode "{\"grant_type\":\"weird\",\"api_key\":{\"name\":\"n\"}}" + `shouldBe` (Nothing :: Maybe GrantApiKeyRequest) + + describe "RetrieveApiKeyRequest" $ do + it "encodes only the set filters" $ do + let req = (defaultRetrieveApiKeyRequest) {rakOwner = Just True} + encode req `shouldBe` "{\"owner\":true}" + + describe "InvalidateApiKeyResponse" $ do + it "decodes a partial failure" $ do + let Just r = decode sampleInvalidateBytes :: Maybe InvalidateApiKeyResponse + iarInvalidatedApiKeys r `shouldBe` ["id1"] + iarErrorCount r `shouldBe` Just 1 + length (iarErrorDetails r) `shouldBe` 1 + case iarErrorDetails r of + (e : _) -> iaeReason e `shouldBe` Just "not found" + [] -> expectationFailure "expected error details" + + describe "UpdateApiKeyRequest" $ do + it "encodes role_descriptors + metadata and round-trips" $ do + let req = + UpdateApiKeyRequest + { uakRoleDescriptors = + Just [(RoleName "r", defaultRole {rCluster = ["monitor"]})], + uakMetadata = Just (KM.fromList [("k", "v")]) + } + let Just rt = decode (encode req) :: Maybe UpdateApiKeyRequest + case uakRoleDescriptors rt of + Just [(RoleName "r", role)] -> rCluster role `shouldBe` ["monitor"] + other -> expectationFailure ("expected one role descriptor, got " <> show other) + KM.lookup "k" (fromMaybe KM.empty (uakMetadata rt)) `shouldSatisfy` isJust + + describe "QueryApiKeyRequest" $ do + it "default encodes to {}" $ + encode defaultQueryApiKeyRequest `shouldBe` "{}" + + it "encodes query/from/size and round-trips" $ do + let req = + defaultQueryApiKeyRequest + { qakQuery = Just (object ["match_all" .= object []]), + qakFrom = Just 0, + qakSize = Just 10 + } + let Just rt = decode (encode req) :: Maybe QueryApiKeyRequest + qakFrom rt `shouldBe` Just 0 + qakSize rt `shouldBe` Just 10 + qakQuery rt `shouldSatisfy` isJust + + it "decodes aggregations from the long-form 'aggregations' key" $ do + let Just rt = decode "{\"aggregations\":{\"x\":{}}}" :: Maybe QueryApiKeyRequest + qakAggregations rt `shouldSatisfy` isJust + -- round-trips + let Just rt2 = decode (encode rt) :: Maybe QueryApiKeyRequest + qakAggregations rt2 `shouldSatisfy` isJust + + describe "QueryApiKeyResponse" $ do + it "decodes total/count, embeds ApiKeyInfo, absorbs response + per-key extras" $ do + let Just r = decode sampleQueryBytes :: Maybe QueryApiKeyResponse + qkrTotal r `shouldBe` Just 2 + qkrCount r `shouldBe` Just 1 + length (qkrApiKeys r) `shouldBe` 1 + case qkrApiKeys r of + (info : _) -> do + akiId info `shouldBe` "id1" + -- query-only sibling fields land in the ApiKeyInfo extras + KM.lookup "realm_type" (akiExtras info) `shouldSatisfy` isJust + KM.lookup "_sort" (akiExtras info) `shouldSatisfy` isJust + [] -> expectationFailure "expected one api_key" + -- top-level unknown fields (e.g. aggregations) land in qkrExtras + KM.lookup "aggregations" (qkrExtras r) `shouldSatisfy` isJust + -- stable round-trip: extras survive encode . decode + let Just rt = decode (encode r) :: Maybe QueryApiKeyResponse + KM.lookup "aggregations" (qkrExtras rt) `shouldSatisfy` isJust diff --git a/tests/Test/SecurityAuthenticateSpec.hs b/tests/Test/SecurityAuthenticateSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SecurityAuthenticateSpec.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SecurityAuthenticateSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as L +import TestsUtils.Import +import Prelude + +-- | @GET /_security/_authenticate@ response for the reserved @elastic@ +-- user, including an @api_key@ sibling that should survive in 'authExtras'. +sampleAuthenticateBytes :: L.ByteString +sampleAuthenticateBytes = + "{\ + \ \"username\": \"elastic\",\ + \ \"roles\": [\"superuser\"],\ + \ \"full_name\": null,\ + \ \"email\": null,\ + \ \"metadata\": {\"_reserved\": true},\ + \ \"enabled\": true,\ + \ \"authentication_realm\": {\"name\": \"reserved\", \"type\": \"reserved\"},\ + \ \"lookup_realm\": {\"name\": \"reserved\", \"type\": \"reserved\"},\ + \ \"authentication_provider\": \"reserved\",\ + \ \"principal\": \"elastic\",\ + \ \"api_key\": {\"id\": \"k1\", \"name\": \"key\"}\ + \}" + +-- | @GET /_security/_whoami@ response (ES 7.16+) carrying the optional +-- @principal@ / @delegate@ fields. +sampleWhoAmIBytes :: L.ByteString +sampleWhoAmIBytes = + "{\ + \ \"username\": \"radmin\",\ + \ \"roles\": [\"superuser\"],\ + \ \"principal\": \"radmin\",\ + \ \"delegate\": false,\ + \ \"authentication_realm\": {\"name\": \"file\", \"type\": \"file\"},\ + \ \"lookup_realm\": {\"name\": \"file\", \"type\": \"file\"}\ + \}" + +spec :: Spec +spec = do + describe "AuthenticateResponse" $ do + it "decodes username, roles, realms, provider, principal" $ do + let Just r = decode sampleAuthenticateBytes :: Maybe AuthenticateResponse + authUsername r `shouldBe` "elastic" + authRoles r `shouldBe` [RoleName "superuser"] + authEnabled r `shouldBe` Just True + authAuthenticationProvider r `shouldBe` Just "reserved" + authPrincipal r `shouldBe` Just "elastic" + case authAuthenticationRealm r of + Just realm -> do + srName realm `shouldBe` Just "reserved" + srType realm `shouldBe` Just "reserved" + Nothing -> expectationFailure "expected an authentication_realm" + + it "preserves unknown sibling fields (api_key) in extras and round-trips" $ do + let Just r = decode sampleAuthenticateBytes :: Maybe AuthenticateResponse + KM.lookup "api_key" (authExtras r) `shouldSatisfy` isJust + let Just rt = decode (encode r) :: Maybe AuthenticateResponse + KM.lookup "api_key" (authExtras rt) `shouldSatisfy` isJust + + it "tolerates a minimal response (just username)" $ do + let Just r = decode "{\"username\":\"u\"}" :: Maybe AuthenticateResponse + authUsername r `shouldBe` "u" + authRoles r `shouldBe` [] + authAuthenticationRealm r `shouldBe` Nothing + + describe "WhoAmIResponse" $ do + it "decodes principal / delegate / realms" $ do + let Just resp = decode sampleWhoAmIBytes :: Maybe WhoAmIResponse + wmUsername resp `shouldBe` "radmin" + wmPrincipal resp `shouldBe` Just "radmin" + wmDelegate resp `shouldBe` Just False + case wmAuthenticationRealm resp of + SecurityRealm {..} -> do + srName `shouldBe` Just "file" + srType `shouldBe` Just "file" + + it "tolerates an absent delegate / principal / lookup_realm" $ do + let bytes = + "{\ + \ \"username\": \"x\",\ + \ \"roles\": [],\ + \ \"authentication_realm\": {\"name\":\"n\",\"type\":\"t\"}\ + \}" + let Just resp = decode bytes :: Maybe WhoAmIResponse + wmPrincipal resp `shouldBe` Nothing + wmDelegate resp `shouldBe` Nothing + wmLookupRealm resp `shouldBe` Nothing + + it "round-trips" $ do + let Just resp = decode sampleWhoAmIBytes :: Maybe WhoAmIResponse + let Just rt = decode (encode resp) :: Maybe WhoAmIResponse + wmUsername rt `shouldBe` wmUsername resp + wmDelegate rt `shouldBe` wmDelegate resp + + describe "LogoutRequest" $ do + it "encodes the token and omits an absent refresh_token" $ do + encode (defaultLogoutRequest "abc123") `shouldBe` "{\"token\":\"abc123\"}" + + it "round-trips with an optional refresh_token" $ do + let req = + (defaultLogoutRequest "abc123") + { lrRefreshToken = Just "rt456" + } + let Just rt = decode (encode req) :: Maybe LogoutRequest + lrToken rt `shouldBe` "abc123" + lrRefreshToken rt `shouldBe` Just "rt456" + + describe "LogoutResponse" $ do + it "decodes {changed: true}" $ do + let Just resp = decode "{\"changed\":true}" :: Maybe LogoutResponse + loChanged resp `shouldBe` True + + it "decodes {changed: false}" $ do + let Just resp = decode "{\"changed\":false}" :: Maybe LogoutResponse + loChanged resp `shouldBe` False + + it "round-trips" $ do + let resp = LogoutResponse {loChanged = True} + decode (encode resp) `shouldBe` Just resp diff --git a/tests/Test/SecurityPrivilegesSpec.hs b/tests/Test/SecurityPrivilegesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SecurityPrivilegesSpec.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SecurityPrivilegesSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NE +import TestsUtils.Import +import Prelude + +spec :: Spec +spec = do + describe "FieldSecurity" $ do + it "round-trips grant + except arrays" $ do + let fs = + FieldSecurity + { fsGrant = Just (FieldName "a" :| [FieldName "b"]), + fsExcept = Just (FieldName "secret" :| []) + } + let Just decoded = decode (encode fs) :: Maybe FieldSecurity + (NE.toList <$> fsGrant decoded) `shouldBe` Just [FieldName "a", FieldName "b"] + (NE.toList <$> fsExcept decoded) `shouldBe` Just [FieldName "secret"] + + it "decodes a bare-string grant as a singleton list" $ do + let Just fs = decode "{\"grant\":\"email\"}" :: Maybe FieldSecurity + (NE.toList <$> fsGrant fs) `shouldBe` Just [FieldName "email"] + fsExcept fs `shouldBe` Nothing + + it "treats an empty grant array as Nothing" $ do + let Just fs = decode "{\"grant\":[]}" :: Maybe FieldSecurity + fsGrant fs `shouldBe` Nothing + + describe "IndexPrivilege" $ do + it "round-trips a full entry with field_security, query and extras" $ do + let bytes = + "{\ + \ \"names\": [\"logs-*\", \"metrics-*\"],\ + \ \"privileges\": [\"read\", \"view_index_metadata\"],\ + \ \"field_security\": {\"grant\": [\"a\"], \"except\": [\"b\"]},\ + \ \"query\": {\"term\": {\"active\": true}},\ + \ \"description\": \"custom note\"\ + \}" + let Just decoded = decode bytes :: Maybe IndexPrivilege + NE.toList (ipNames decoded) + `shouldBe` [IndexPattern "logs-*", IndexPattern "metrics-*"] + NE.toList (ipPrivileges decoded) + `shouldBe` ["read", "view_index_metadata"] + ipFieldSecurity decoded `shouldSatisfy` isJust + ipQuery decoded `shouldSatisfy` isJust + -- The unknown @description@ survives in extras. + KM.lookup "description" (ipExtras decoded) `shouldSatisfy` isJust + -- Round-trip is stable. + let Just rt = decode (encode decoded) :: Maybe IndexPrivilege + NE.toList (ipNames rt) `shouldBe` [IndexPattern "logs-*", IndexPattern "metrics-*"] + + it "decodes a bare-string names field" $ do + let Just decoded = decode "{\"names\":\"logs\",\"privileges\":[\"read\"]}" :: Maybe IndexPrivilege + NE.toList (ipNames decoded) `shouldBe` [IndexPattern "logs"] + + it "rejects an empty names array" $ do + decode "{\"names\":[],\"privileges\":[\"read\"]}" `shouldBe` (Nothing :: Maybe IndexPrivilege) + + it "rejects names missing entirely" $ do + decode "{\"privileges\":[\"read\"]}" `shouldBe` (Nothing :: Maybe IndexPrivilege) + + describe "ApplicationPrivilege" $ do + it "round-trips application + privileges + resources + extras" $ do + let bytes = + "{\ + \ \"application\": \"myapp\",\ + \ \"privileges\": [\"read\", \"write\"],\ + \ \"resources\": [\"index:1\", \"*\"],\ + \ \"note\": \"extra\"\ + \}" + let Just decoded = decode bytes :: Maybe ApplicationPrivilege + apvApplication decoded `shouldBe` "myapp" + apvPrivileges decoded `shouldBe` ["read", "write"] + apvResources decoded `shouldBe` ["index:1", "*"] + KM.lookup "note" (apvExtras decoded) `shouldSatisfy` isJust + + it "tolerates an absent resources field" $ do + let Just decoded = + decode + "{\"application\":\"myapp\",\"privileges\":[\"read\"]}" :: + Maybe ApplicationPrivilege + apvResources decoded `shouldBe` [] + + it "decodes a bare-string privileges field" $ do + let Just decoded = + decode + "{\"application\":\"myapp\",\"privileges\":\"read\",\"resources\":[\"*\"]}" :: + Maybe ApplicationPrivilege + apvPrivileges decoded `shouldBe` ["read"] + + describe "ActionName" $ do + it "round-trips through JSON and IsString" $ do + let Just decoded = decode "\"data:read/*\"" :: Maybe ActionName + decoded `shouldBe` "data:read/*" + encode decoded `shouldBe` "\"data:read/*\"" + + describe "ApplicationPrivilegeDefinition" $ do + it "round-trips actions + metadata + extras" $ do + let bytes = + "{\ + \ \"actions\": [\"data:read/*\", \"action:login\"],\ + \ \"metadata\": {\"description\": \"Read access\"},\ + \ \"comment\": \"extra\"\ + \}" + Just decoded = decode bytes :: Maybe ApplicationPrivilegeDefinition + NE.toList (apdActions decoded) `shouldBe` ["data:read/*", "action:login"] + apdMetadata decoded `shouldSatisfy` isJust + KM.lookup "comment" (apdExtras decoded) `shouldSatisfy` isJust + let Just rt = decode (encode decoded) :: Maybe ApplicationPrivilegeDefinition + NE.toList (apdActions rt) `shouldBe` ["data:read/*", "action:login"] + KM.lookup "comment" (apdExtras rt) `shouldSatisfy` isJust + + it "decodes a bare-string action as a singleton" $ do + let Just decoded = decode "{\"actions\":\"action:login\"}" :: Maybe ApplicationPrivilegeDefinition + NE.toList (apdActions decoded) `shouldBe` ["action:login"] + + it "rejects an empty actions array" $ do + decode "{\"actions\":[]}" `shouldBe` (Nothing :: Maybe ApplicationPrivilegeDefinition) + + it "rejects actions missing entirely" $ do + decode "{\"metadata\":{}}" `shouldBe` (Nothing :: Maybe ApplicationPrivilegeDefinition) + + describe "ApplicationPrivilegeInfo" $ do + it "decodes the GET leaf with application, name, actions, metadata" $ do + let bytes = + "{\ + \ \"application\": \"myapp\",\ + \ \"name\": \"read\",\ + \ \"actions\": [\"data:read/*\", \"action:login\"],\ + \ \"metadata\": {\"description\": \"Read access to myapp\"}\ + \}" + Just decoded = decode bytes :: Maybe ApplicationPrivilegeInfo + apiApplication decoded `shouldBe` "myapp" + apiName decoded `shouldBe` "read" + apiActions decoded `shouldBe` ["data:read/*", "action:login"] + apiMetadata decoded `shouldSatisfy` isJust + + it "tolerates absent actions (defaults to [])" $ do + let Just decoded = decode "{\"application\":\"myapp\",\"name\":\"read\"}" :: Maybe ApplicationPrivilegeInfo + apiActions decoded `shouldBe` [] + + it "carries unknown fields in extras" $ do + let Just decoded = decode "{\"application\":\"myapp\",\"name\":\"read\",\"actions\":[\"*\"],\"note\":\"x\"}" :: Maybe ApplicationPrivilegeInfo + KM.lookup "note" (apiExtras decoded) `shouldSatisfy` isJust + + describe "PrivilegesListResponse" $ do + it "decodes the two-level {app:{name:leaf}} envelope" $ do + let bytes = + "{\"myapp\":{\"read\":{\"application\":\"myapp\",\"name\":\"read\",\"actions\":[\"data:read/*\"]}}}" + Just decoded = decode bytes :: Maybe PrivilegesListResponse + case privilegesListEntries decoded of + [(ApplicationName app, [(ApplicationPrivilegeName priv, info)])] -> do + app `shouldBe` "myapp" + priv `shouldBe` "read" + apiApplication info `shouldBe` "myapp" + apiActions info `shouldBe` ["data:read/*"] + other -> expectationFailure $ "unexpected entries: " <> show other + + it "round-trips a multi-app, multi-privilege envelope" $ do + let bytes = + "{\ + \ \"app01\": {\ + \ \"read\": {\"application\": \"app01\", \"name\": \"read\", \"actions\": [\"*\"]},\ + \ \"write\": {\"application\": \"app01\", \"name\": \"write\", \"actions\": [\"data:write/*\"]}\ + \ },\ + \ \"app02\": {\ + \ \"all\": {\"application\": \"app02\", \"name\": \"all\", \"actions\": [\"*\"]}\ + \ }\ + \}" + Just decoded = decode bytes :: Maybe PrivilegesListResponse + Just rt = decode (encode decoded) :: Maybe PrivilegesListResponse + length (privilegesListEntries decoded) `shouldBe` 2 + privilegesListEntries rt `shouldBe` privilegesListEntries decoded + + describe "PrivilegeCreatedResponse" $ do + it "decodes {app:{name:{created:true}}} to created True" $ do + let Just decoded = decode "{\"myapp\":{\"read\":{\"created\":true}}}" :: Maybe PrivilegeCreatedResponse + pcCreated decoded `shouldBe` True + + it "decodes created:false on update" $ do + let Just decoded = decode "{\"myapp\":{\"read\":{\"created\":false}}}" :: Maybe PrivilegeCreatedResponse + pcCreated decoded `shouldBe` False + + it "re-decodes after encode to the same value" $ do + let Just decoded = decode "{\"myapp\":{\"read\":{\"created\":true}}}" :: Maybe PrivilegeCreatedResponse + Just rt = decode (encode decoded) :: Maybe PrivilegeCreatedResponse + rt `shouldBe` decoded + + describe "PrivilegeDeletedResponse" $ do + it "decodes {app:{name:{found:true}}}" $ do + let Just decoded = decode "{\"myapp\":{\"read\":{\"found\":true}}}" :: Maybe PrivilegeDeletedResponse + pdFound decoded `shouldBe` Just True + + it "decodes found:false when the privilege was absent" $ do + let Just decoded = decode "{\"myapp\":{\"read\":{\"found\":false}}}" :: Maybe PrivilegeDeletedResponse + pdFound decoded `shouldBe` Just False + + it "re-decodes after encode to the same value (bare-leaf fallback)" $ do + let Just decoded = decode "{\"myapp\":{\"read\":{\"found\":true}}}" :: Maybe PrivilegeDeletedResponse + Just rt = decode (encode decoded) :: Maybe PrivilegeDeletedResponse + rt `shouldBe` decoded + + describe "ClearPrivilegeCacheResponse" $ do + it "decodes an empty object" $ do + let Just decoded = decode "{}" :: Maybe ClearPrivilegeCacheResponse + cpcBody decoded `shouldBe` KM.empty + + it "round-trips an arbitrary object body" $ do + let bytes = "{\"cleared\":[\"myapp\"]}" + Just decoded = decode bytes :: Maybe ClearPrivilegeCacheResponse + Just rt = decode (encode decoded) :: Maybe ClearPrivilegeCacheResponse + rt `shouldBe` decoded diff --git a/tests/Test/SecurityRoleMappingsSpec.hs b/tests/Test/SecurityRoleMappingsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SecurityRoleMappingsSpec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SecurityRoleMappingsSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as L +import TestsUtils.Import +import Prelude + +-- | A role mapping with a nested @any -> all -> field@ rule tree. +sampleMappingBytes :: L.ByteString +sampleMappingBytes = + "{\ + \ \"enabled\": true,\ + \ \"roles\": [\"admin\"],\ + \ \"rules\": {\ + \ \"any\": [\ + \ {\"field\": {\"username\": \"alice\"}},\ + \ {\"all\": [\ + \ {\"field\": {\"realm.name\": \"ad\"}},\ + \ {\"field\": {\"groups\": \"cn=admins\"}}\ + \ ]}\ + \ ]\ + \ },\ + \ \"metadata\": {\"version\": 1}\ + \}" + +-- | A mapping using the @except@ composite rule. +sampleExceptMappingBytes :: L.ByteString +sampleExceptMappingBytes = + "{\ + \ \"roles\": [\"user\"],\ + \ \"rules\": {\"except\": {\"field\": {\"username\": \"blacklist\"}}}\ + \}" + +spec :: Spec +spec = do + describe "RoleMapping" $ do + it "decodes a nested any/all/field rule tree" $ do + let Just decoded = decode sampleMappingBytes :: Maybe RoleMapping + romEnabled decoded `shouldBe` Just True + romRoles decoded `shouldBe` [RoleName "admin"] + -- The top rule is an @any@ over two branches. + case romRules decoded of + RuleAny branches -> + length (branches) `shouldBe` 2 + other -> expectationFailure ("expected RuleAny, got " <> show other) + -- Stable round-trip. + let Just rt = decode (encode decoded) :: Maybe RoleMapping + romRoles rt `shouldBe` [RoleName "admin"] + + it "decodes the except composite rule" $ do + let Just decoded = decode sampleExceptMappingBytes :: Maybe RoleMapping + case romRules decoded of + RuleExcept (RuleField km) -> + KM.lookup "username" km `shouldSatisfy` isJust + other -> expectationFailure ("expected RuleExcept (RuleField), got " <> show other) + + it "encodes a field rule as {field: {...}}" $ do + let rule = RuleField (KM.singleton "dn" "CN=alice") + decode (encode rule) `shouldBe` Just (rule :: RoleMappingRule) + + describe "RoleMappingRule" $ do + it "rejects an empty object" $ do + decode "{}" `shouldBe` (Nothing :: Maybe RoleMappingRule) + + it "preserves an unknown rule kind verbatim" $ do + let decoded = decode "{\"future_rule\":{\"x\":1}}" :: Maybe RoleMappingRule + decoded `shouldSatisfy` isJust + case decoded of + Just (RuleCustom _ _) -> True `shouldBe` True + other -> expectationFailure ("expected RuleCustom, got " <> show other) + + describe "RoleMappingsListResponse" $ do + it "decodes an object keyed by mapping name" $ do + let bytes = + "{\ + \ \"mapping1\": {\ + \ \"roles\": [\"admin\"],\ + \ \"rules\": {\"field\": {\"username\": \"x\"}}\ + \ }\ + \}" + let Just resp = decode bytes :: Maybe RoleMappingsListResponse + length (roleMappingsListEntries resp) `shouldBe` 1 diff --git a/tests/Test/SecurityRolesSpec.hs b/tests/Test/SecurityRolesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SecurityRolesSpec.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SecurityRolesSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as L +import TestsUtils.Import +import Prelude + +-- | A role body exercising every typed field, matching the ES 7.17 docs +-- example shape. +sampleRoleBytes :: L.ByteString +sampleRoleBytes = + "{\ + \ \"cluster\": [\"monitor\", \"manage\"],\ + \ \"indices\": [\ + \ {\ + \ \"names\": [\"events-*\"],\ + \ \"privileges\": [\"read\"],\ + \ \"field_security\": {\"grant\": [\"category\"], \"except\": [\"secret\"]},\ + \ \"query\": {\"match_all\": {}}\ + \ }\ + \ ],\ + \ \"applications\": [\ + \ {\"application\": \"myapp\", \"privileges\": [\"read\"], \"resources\": [\"*\"]}\ + \ ],\ + \ \"run_as\": [\"other_user\"],\ + \ \"metadata\": {\"version\": 1}\ + \}" + +-- | A role returned by @GET /_security/role@ — note @transient_metadata@ +-- which is present only on retrieval. +sampleRoleWithTransientBytes :: L.ByteString +sampleRoleWithTransientBytes = + "{\ + \ \"cluster\": [\"monitor\"],\ + \ \"transient_metadata\": {\"_reserved\": true},\ + \ \"metadata\": {\"version\": 1},\ + \ \"description\": \"doc string\"\ + \}" + +spec :: Spec +spec = do + describe "Role" $ do + it "round-trips a full role body" $ do + let Just decoded = decode sampleRoleBytes :: Maybe Role + rCluster decoded `shouldBe` ["monitor", "manage"] + length (rIndices decoded) `shouldBe` 1 + rRunAs decoded `shouldBe` ["other_user"] + KM.lookup "version" (rMetadata decoded) `shouldSatisfy` isJust + -- Stable round-trip. + let Just rt = decode (encode decoded) :: Maybe Role + rCluster rt `shouldBe` ["monitor", "manage"] + rRunAs rt `shouldBe` ["other_user"] + + it "captures transient_metadata and extras on decode" $ do + let Just decoded = decode sampleRoleWithTransientBytes :: Maybe Role + rTransientMetadata decoded `shouldSatisfy` isJust + KM.lookup "description" (rExtras decoded) `shouldSatisfy` isJust + -- transient_metadata is NOT dumped into extras. + KM.lookup "transient_metadata" (rExtras decoded) `shouldBe` Nothing + + it "decodes an empty role" $ do + let Just decoded = decode "{}" :: Maybe Role + rCluster decoded `shouldBe` [] + rIndices decoded `shouldBe` [] + + describe "RoleCreatedResponse" $ do + it "decodes the nested {role:{created}} envelope" $ do + let Just rc = decode "{\"role\":{\"created\":true}}" :: Maybe RoleCreatedResponse + rcCreated rc `shouldBe` True + it "encodes back to the nested envelope" $ do + encode (RoleCreatedResponse False) `shouldBe` "{\"role\":{\"created\":false}}" + + describe "RoleDeletedResponse" $ do + it "decodes found + acknowledged" $ do + let Just rd = decode "{\"found\":true,\"acknowledged\":true}" :: Maybe RoleDeletedResponse + rdFound rd `shouldBe` Just True + rdAcknowledged rd `shouldBe` True + it "tolerates an absent found field" $ do + let Just rd = decode "{\"acknowledged\":true}" :: Maybe RoleDeletedResponse + rdFound rd `shouldBe` Nothing + + describe "RolesListResponse" $ do + it "decodes an object keyed by role name" $ do + let bytes = + "{\ + \ \"admin\": {\ + \ \"cluster\": [\"all\"]\ + \ },\ + \ \"reader\": {\ + \ \"indices\": [{\"names\": [\"*\"], \"privileges\": [\"read\"]}]\ + \ }\ + \}" + let Just resp = decode bytes :: Maybe RolesListResponse + length (rolesListEntries resp) `shouldBe` 2 + -- Round-trip reproduces the object-keyed shape. + let Just rt = decode (encode resp) :: Maybe RolesListResponse + length (rolesListEntries rt) `shouldBe` 2 + + describe "ClearRoleCacheResponse" $ do + it "decodes the cleared list" $ do + let Just c = decode "{\"cleared\":[\"admin\",\"reader\"]}" :: Maybe ClearRoleCacheResponse + clearedRoles c `shouldBe` ["admin", "reader"] diff --git a/tests/Test/SecurityServiceAccountsSpec.hs b/tests/Test/SecurityServiceAccountsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SecurityServiceAccountsSpec.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SecurityServiceAccountsSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as L +import Data.List (lookup) +import TestsUtils.Import +import Prelude + +-- | @GET /_security/service/elastic/fleet-server@ response, keyed by the +-- full principal (documented 7.17 example, trimmed). The +-- @role_descriptor@ is structurally a 'Role'. +sampleServiceAccountBytes :: L.ByteString +sampleServiceAccountBytes = + "{\ + \ \"elastic/fleet-server\": {\ + \ \"role_descriptor\": {\ + \ \"cluster\": [\"monitor\", \"manage_own_api_key\"],\ + \ \"indices\": [\ + \ {\ + \ \"names\": [\"logs-*\"],\ + \ \"privileges\": [\"write\", \"create_index\"]\ + \ }\ + \ ],\ + \ \"applications\": [],\ + \ \"run_as\": [],\ + \ \"metadata\": {},\ + \ \"transient_metadata\": {\"enabled\": true}\ + \ }\ + \ }\ + \}" + +-- | @POST .../credential/token/token1@ success response carrying the +-- one-time secret bearer value. +sampleCreateServiceTokenBytes :: L.ByteString +sampleCreateServiceTokenBytes = + "{\ + \ \"created\": true,\ + \ \"token\": {\ + \ \"name\": \"token1\",\ + \ \"value\": \"AAEAAWVsYXN0aWM...vZmxlZXQtc2VydmVyL3Rva2VuMTo3TFdaSDZ\"\ + \ }\ + \}" + +-- | @GET .../credential@ response listing index-backed tokens and +-- file-backed node credentials (documented 7.17 example). +sampleServiceCredentialsBytes :: L.ByteString +sampleServiceCredentialsBytes = + "{\ + \ \"service_account\": \"elastic/fleet-server\",\ + \ \"count\": 3,\ + \ \"tokens\": {\ + \ \"token1\": {},\ + \ \"token42\": {}\ + \ },\ + \ \"nodes_credentials\": {\ + \ \"_nodes\": {\"total\": 3, \"successful\": 3, \"failed\": 0},\ + \ \"file_tokens\": {\"my-token\": {\"nodes\": [\"node0\", \"node1\"]}}\ + \ }\ + \}" + +-- | @DELETE .../credential/token/{token_name}@ success response. +sampleDeleteServiceTokenBytes :: L.ByteString +sampleDeleteServiceTokenBytes = "{\"found\": true}" + +spec :: Spec +spec = describe "Security service accounts" $ do + describe "ServiceAccountsListResponse" $ do + it "decodes a service account keyed by principal" $ do + let Just decoded = decode sampleServiceAccountBytes :: Maybe ServiceAccountsListResponse + Just account = lookup "elastic/fleet-server" (serviceAccountsListEntries decoded) + Just roleDescriptor = saRoleDescriptor account + rCluster roleDescriptor `shouldBe` ["monitor", "manage_own_api_key"] + length (rIndices roleDescriptor) `shouldBe` 1 + rTransientMetadata roleDescriptor `shouldSatisfy` isJust + + it "round-trips through encode . decode" $ do + let Just decoded = decode sampleServiceAccountBytes :: Maybe ServiceAccountsListResponse + Just roundTripped = decode (encode decoded) :: Maybe ServiceAccountsListResponse + Just account = lookup "elastic/fleet-server" (serviceAccountsListEntries roundTripped) + Just roleDescriptor = saRoleDescriptor account + rCluster roleDescriptor `shouldBe` ["monitor", "manage_own_api_key"] + + it "decodes an empty object to no entries" $ do + let Just decoded = decode "{}" :: Maybe ServiceAccountsListResponse + serviceAccountsListEntries decoded `shouldBe` [] + + describe "CreateServiceTokenResponse" $ do + it "decodes the created flag and the secret token" $ do + let Just decoded = decode sampleCreateServiceTokenBytes :: Maybe CreateServiceTokenResponse + cstrCreated decoded `shouldBe` Just True + let Just secret = cstrToken decoded + stsName secret `shouldBe` Just "token1" + stsValue secret `shouldSatisfy` isJust + + it "round-trips through encode . decode" $ do + let Just decoded = decode sampleCreateServiceTokenBytes :: Maybe CreateServiceTokenResponse + Just roundTripped = decode (encode decoded) :: Maybe CreateServiceTokenResponse + Just secret = cstrToken roundTripped + stsName secret `shouldBe` Just "token1" + cstrCreated roundTripped `shouldBe` Just True + + describe "GetServiceCredentialsResponse" $ do + it "decodes the tokens map and node credentials" $ do + let Just decoded = decode sampleServiceCredentialsBytes :: Maybe GetServiceCredentialsResponse + gscrServiceAccount decoded `shouldBe` Just "elastic/fleet-server" + gscrCount decoded `shouldBe` Just 3 + let Just tokens = gscrTokens decoded + KM.size tokens `shouldBe` 2 + gscrNodesCredentials decoded `shouldSatisfy` isJust + + it "round-trips through encode . decode" $ do + let Just decoded = decode sampleServiceCredentialsBytes :: Maybe GetServiceCredentialsResponse + Just roundTripped = decode (encode decoded) :: Maybe GetServiceCredentialsResponse + gscrCount roundTripped `shouldBe` Just 3 + gscrServiceAccount roundTripped `shouldBe` Just "elastic/fleet-server" + + describe "ServiceTokenDeletedResponse" $ do + it "decodes the found flag" $ do + let Just decoded = decode sampleDeleteServiceTokenBytes :: Maybe ServiceTokenDeletedResponse + stdFound decoded `shouldBe` Just True + stdExtras decoded `shouldBe` KM.empty diff --git a/tests/Test/SecuritySsoSpec.hs b/tests/Test/SecuritySsoSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SecuritySsoSpec.hs @@ -0,0 +1,400 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Test.SecuritySsoSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as L +import TestsUtils.Import +import Prelude + +------------------------------------------------------------------------------ +-- Fixtures (verbatim from the ES 7.17 REST docs) +------------------------------------------------------------------------------ + +-- | @POST /_security/oauth2/token@ response — @password@ grant with the +-- nested @authentication@ block (the access + refresh token pair). +sampleGetTokenPasswordBytes :: L.ByteString +sampleGetTokenPasswordBytes = + "{\ + \ \"access_token\": \"dGhpcyBpcyBub3QgYSByZWFsIHRva2VuIGJ1dCBpdCBpcyBvbmx5IHRlc3QgZGF0YS4gZG8gbm90IHRyeSB0byByZWFkIHRva2VuIQ==\",\ + \ \"type\": \"Bearer\",\ + \ \"expires_in\": 1200,\ + \ \"refresh_token\": \"vLBPvmAB6KvwvJZr27cS\",\ + \ \"authentication\": {\ + \ \"username\": \"test_admin\",\ + \ \"roles\": [\"superuser\"],\ + \ \"full_name\": null,\ + \ \"email\": null,\ + \ \"metadata\": {},\ + \ \"enabled\": true,\ + \ \"authentication_realm\": {\"name\": \"file\", \"type\": \"file\"},\ + \ \"lookup_realm\": {\"name\": \"file\", \"type\": \"file\"},\ + \ \"authentication_type\": \"realm\"\ + \ }\ + \}" + +-- | @POST /_security/oauth2/token@ response — @client_credentials@ grant +-- (NO refresh token). +sampleGetTokenClientCredentialsBytes :: L.ByteString +sampleGetTokenClientCredentialsBytes = + "{\ + \ \"access_token\": \"dGhpcyBpcyBub3QgYSByZWFsIHRva2VuIGJ1dCBpdCBpcyBvbmx5IHRlc3QgZGF0YS4gZG8gbm90IHRyeSB0byByZWFkIHRva2VuIQ==\",\ + \ \"type\": \"Bearer\",\ + \ \"expires_in\": 1200,\ + \ \"authentication\": {\ + \ \"username\": \"test_admin\",\ + \ \"roles\": [\"superuser\"],\ + \ \"full_name\": null,\ + \ \"email\": null,\ + \ \"metadata\": {},\ + \ \"enabled\": true,\ + \ \"authentication_realm\": {\"name\": \"file\", \"type\": \"file\"},\ + \ \"lookup_realm\": {\"name\": \"file\", \"type\": \"file\"},\ + \ \"authentication_type\": \"realm\"\ + \ }\ + \}" + +-- | @DELETE /_security/oauth2/token@ response with a partial failure +-- (recursive @caused_by@ in the error chain). +sampleInvalidateTokenBytes :: L.ByteString +sampleInvalidateTokenBytes = + "{\ + \ \"invalidated_tokens\": 9,\ + \ \"previously_invalidated_tokens\": 15,\ + \ \"error_count\": 2,\ + \ \"error_details\": [\ + \ {\ + \ \"type\": \"exception\",\ + \ \"reason\": \"Elasticsearch exception [type=exception, reason=foo]\",\ + \ \"caused_by\": {\ + \ \"type\": \"illegal_argument_exception\",\ + \ \"reason\": \"Elasticsearch exception [type=illegal_argument_exception, reason=bar]\"\ + \ }\ + \ }\ + \ ]\ + \}" + +-- | @POST /_security/saml/authenticate@ response (access + refresh token, +-- username, realm; no @type@). +sampleSamlAuthenticateBytes :: L.ByteString +sampleSamlAuthenticateBytes = + "{\ + \ \"access_token\": \"46ToAxZVaXVVZTVKOVF5YU04ZFJVUDVSZlV3\",\ + \ \"username\": \"Bearer\",\ + \ \"expires_in\": 1200,\ + \ \"refresh_token\": \"mJdXLtmvTUSpoLwMvdBt_w\",\ + \ \"realm\": \"saml1\"\ + \}" + +-- | @POST /_security/oidc/authenticate@ response (access + refresh token, +-- @type@; no @username@/@realm@). +sampleOidcAuthenticateBytes :: L.ByteString +sampleOidcAuthenticateBytes = + "{\ + \ \"access_token\": \"dGhpcyBpcyBub3QgYSByZWFsIHRva2VuIGJ1dCBpdCBpcyBvbmx5IHRlc3QgZGF0YS4gZG8gbm90IHRyeSB0byByZWFkIHRva2VuIQ==\",\ + \ \"type\": \"Bearer\",\ + \ \"expires_in\": 1200,\ + \ \"refresh_token\": \"vLBPvmAB6KvwvJZr27cS\"\ + \}" + +-- | @POST /_security/saml/prepare@ response. +sampleSamlPrepareBytes :: L.ByteString +sampleSamlPrepareBytes = + "{\ + \ \"redirect\": \"https://my-idp.org/login?SAMLRequest=fVJdc6...\",\ + \ \"realm\": \"saml1\",\ + \ \"id\": \"_989a34500a4f5bf0f00d195aa04a7804b4ed42a1\"\ + \}" + +-- | @POST /_security/oidc/prepare@ response (server-generated state/nonce). +sampleOidcPrepareBytes :: L.ByteString +sampleOidcPrepareBytes = + "{\ + \ \"redirect\": \"http://127.0.0.1:8080/c2id-login?scope=openid&response_type=id_token\",\ + \ \"state\": \"4dbrihtIAt3wBTwo6DxK-vdk-sSyDBV8Yf0AjdkdT5I\",\ + \ \"nonce\": \"WaBPH0KqPVdG5HHdSxPRjfoZbXMCicm5v1OiAj0DUFM\",\ + \ \"realm\": \"oidc1\"\ + \}" + +spec :: Spec +spec = do + describe "OAuth2GrantType" $ do + it "round-trips the four documented grant types" $ do + encode OAuth2GrantPassword `shouldBe` "\"password\"" + encode OAuth2GrantKerberos `shouldBe` "\"_kerberos\"" + encode OAuth2GrantClientCredentials + `shouldBe` "\"client_credentials\"" + encode OAuth2GrantRefreshToken `shouldBe` "\"refresh_token\"" + decode "\"_kerberos\"" `shouldBe` (Just OAuth2GrantKerberos :: Maybe OAuth2GrantType) + + it "rejects an unknown grant_type" $ do + decode "\"weird\"" + `shouldBe` (Nothing :: Maybe OAuth2GrantType) + + describe "GetTokenRequest" $ do + it "encodes only client_credentials when that grant is selected" $ do + let req = defaultGetTokenRequest + encode req `shouldBe` "{\"grant_type\":\"client_credentials\"}" + + it "encodes a password grant and round-trips it" $ do + let req = + defaultGetTokenRequest + { gtqGrantType = OAuth2GrantPassword, + gtqUsername = Just "test_admin", + gtqPassword = Just "x-pack-test-password" + } + let Just rt = decode (encode req) :: Maybe GetTokenRequest + gtqGrantType rt `shouldBe` OAuth2GrantPassword + gtqUsername rt `shouldBe` Just "test_admin" + gtqPassword rt `shouldBe` Just "x-pack-test-password" + + it "round-trips a refresh_token grant" $ do + let req = + defaultGetTokenRequest + { gtqGrantType = OAuth2GrantRefreshToken, + gtqRefreshToken = Just "vLBPvmAB6KvwvJZr27cS" + } + let Just rt = decode (encode req) :: Maybe GetTokenRequest + gtqGrantType rt `shouldBe` OAuth2GrantRefreshToken + gtqRefreshToken rt `shouldBe` Just "vLBPvmAB6KvwvJZr27cS" + + it "round-trips a _kerberos grant" $ do + let req = + defaultGetTokenRequest + { gtqGrantType = OAuth2GrantKerberos, + gtqKerberosTicket = Just "YIIB6wYJKoZIhvcSAQICAQ" + } + let Just rt = decode (encode req) :: Maybe GetTokenRequest + gtqGrantType rt `shouldBe` OAuth2GrantKerberos + gtqKerberosTicket rt `shouldBe` Just "YIIB6wYJKoZIhvcSAQICAQ" + + describe "GetTokenResponse" $ do + it "decodes the password-grant response with nested authentication" $ do + let Just r = decode sampleGetTokenPasswordBytes :: Maybe GetTokenResponse + gtrAccessToken r `shouldBe` "dGhpcyBpcyBub3QgYSByZWFsIHRva2VuIGJ1dCBpdCBpcyBvbmx5IHRlc3QgZGF0YS4gZG8gbm90IHRyeSB0byByZWFkIHRva2VuIQ==" + gtrType r `shouldBe` Just "Bearer" + gtrExpiresIn r `shouldBe` 1200 + gtrRefreshToken r `shouldBe` Just "vLBPvmAB6KvwvJZr27cS" + case gtrAuthentication r of + Just auth -> do + taUsername auth `shouldBe` Just "test_admin" + taRoles auth `shouldBe` Just ["superuser"] + -- null full_name/email decode to Nothing. + taFullName auth `shouldBe` Nothing + taEmail auth `shouldBe` Nothing + taEnabled auth `shouldBe` Just True + taAuthenticationType auth `shouldBe` Just "realm" + case taAuthenticationRealm auth of + Just realm -> do + sriName realm `shouldBe` Just "file" + sriType realm `shouldBe` Just "file" + Nothing -> expectationFailure "expected authentication_realm" + Nothing -> expectationFailure "expected authentication block" + + it "decodes the client_credentials response WITHOUT a refresh token" $ do + let Just r = + decode sampleGetTokenClientCredentialsBytes :: + Maybe GetTokenResponse + gtrRefreshToken r `shouldBe` Nothing + gtrAuthentication r `shouldSatisfy` isJust + + it "preserves unknown authentication sibling fields in extras" $ do + let bytes = + "{\ + \ \"access_token\": \"a\",\ + \ \"type\": \"Bearer\",\ + \ \"expires_in\": 1200,\ + \ \"authentication\": {\ + \ \"username\": \"u\",\ + \ \"roles\": [],\ + \ \"full_name\": null,\ + \ \"email\": null,\ + \ \"metadata\": {},\ + \ \"enabled\": true,\ + \ \"authentication_realm\": {\"name\": \"file\", \"type\": \"file\"},\ + \ \"lookup_realm\": {\"name\": \"file\", \"type\": \"file\"},\ + \ \"authentication_type\": \"realm\",\ + \ \"future_field\": 42\ + \ }\ + \}" + let Just r = decode bytes :: Maybe GetTokenResponse + case gtrAuthentication r of + Just auth -> + KM.lookup "future_field" (taExtras auth) `shouldSatisfy` isJust + Nothing -> expectationFailure "expected authentication block" + -- Stable round-trip: extras survive encode . decode. + let Just rt = decode (encode r) :: Maybe GetTokenResponse + case gtrAuthentication rt of + Just auth -> + KM.lookup "future_field" (taExtras auth) `shouldSatisfy` isJust + Nothing -> expectationFailure "expected authentication block" + + describe "TokenAuthentication" $ do + it "tolerates a null email/full_name (decode to Nothing)" $ do + let bytes = + "{\ + \ \"username\": \"u\",\ + \ \"roles\": [\"r\"],\ + \ \"full_name\": null,\ + \ \"email\": null\ + \}" + let Just auth = decode bytes :: Maybe TokenAuthentication + taUsername auth `shouldBe` Just "u" + taFullName auth `shouldBe` Nothing + taEmail auth `shouldBe` Nothing + + describe "InvalidateTokenRequest" $ do + it "encodes a single access-token selector" $ do + let req = + defaultInvalidateTokenRequest {ittToken = Just "abc"} + encode req `shouldBe` "{\"token\":\"abc\"}" + + it "round-trips a realm_name + username bulk selector" $ do + let req = + defaultInvalidateTokenRequest + { ittRealmName = Just "saml1", + ittUsername = Just "myuser" + } + let Just rt = decode (encode req) :: Maybe InvalidateTokenRequest + ittRealmName rt `shouldBe` Just "saml1" + ittUsername rt `shouldBe` Just "myuser" + + describe "InvalidateTokenResponse" $ do + it "decodes a partial failure with a recursive caused_by chain" $ do + let Just r = decode sampleInvalidateTokenBytes :: Maybe InvalidateTokenResponse + itrInvalidatedTokens r `shouldBe` 9 + itrPreviouslyInvalidatedTokens r `shouldBe` 15 + itrErrorCount r `shouldBe` Just 2 + case itrErrorDetails r of + (e : _) -> case iteCausedBy e of + Just cb -> do + iteType cb `shouldBe` Just "illegal_argument_exception" + iteReason cb `shouldSatisfy` isJust + Nothing -> expectationFailure "expected caused_by" + [] -> expectationFailure "expected error details" + + describe "SsoTokenResponse" $ do + it "decodes a SAML authenticate response (username/realm, no type)" $ do + let Just r = decode sampleSamlAuthenticateBytes :: Maybe SsoTokenResponse + strAccessToken r `shouldBe` "46ToAxZVaXVVZTVKOVF5YU04ZFJVUDVSZlV3" + strUsername r `shouldBe` Just "Bearer" + strRealm r `shouldBe` Just "saml1" + strRefreshToken r `shouldBe` Just "mJdXLtmvTUSpoLwMvdBt_w" + strType r `shouldBe` Nothing + + it "decodes an OIDC authenticate response (type, no username/realm)" $ do + let Just r = decode sampleOidcAuthenticateBytes :: Maybe SsoTokenResponse + strType r `shouldBe` Just "Bearer" + strUsername r `shouldBe` Nothing + strRealm r `shouldBe` Nothing + strRefreshToken r `shouldBe` Just "vLBPvmAB6KvwvJZr27cS" + + describe "SamlPrepareRequest / SamlPrepareResponse" $ do + it "encodes a realm selector and round-trips" $ do + let req = defaultSamlPrepareRequest {sprRealm = Just "saml1"} + encode req `shouldBe` "{\"realm\":\"saml1\"}" + it "encodes an acs selector" $ do + let req = + defaultSamlPrepareRequest + { sprAcs = Just "https://kibana.org/api/security/saml/callback" + } + encode req + `shouldBe` "{\"acs\":\"https://kibana.org/api/security/saml/callback\"}" + it "decodes the prepare response (id/realm/redirect)" $ do + let Just r = decode sampleSamlPrepareBytes :: Maybe SamlPrepareResponse + sppId r `shouldBe` "_989a34500a4f5bf0f00d195aa04a7804b4ed42a1" + sppRealm r `shouldBe` "saml1" + sppRedirect r `shouldBe` "https://my-idp.org/login?SAMLRequest=fVJdc6..." + + describe "SamlAuthenticateRequest / SamlLogoutRequest" $ do + it "round-trips an authenticate request (content/ids/realm)" $ do + let req = + SamlAuthenticateRequest + { sarContent = "PHNhbWxwOlJlc3BvbnNl...", + sarIds = ["4fee3b046395c4e751011e97f8900b5273d56685"], + sarRealm = Just "saml1" + } + let Just rt = decode (encode req) :: Maybe SamlAuthenticateRequest + sarContent rt `shouldBe` "PHNhbWxwOlJlc3BvbnNl..." + sarIds rt `shouldBe` ["4fee3b046395c4e751011e97f8900b5273d56685"] + sarRealm rt `shouldBe` Just "saml1" + it "round-trips a logout request (token + refresh_token)" $ do + let req = + SamlLogoutRequest + { slrToken = "46ToAxZVaXVVZTVKOVF5YU04ZFJVUDVSZlV3", + slrRefreshToken = Just "mJdXLtmvTUSpoLwMvdBt_w" + } + let Just rt = decode (encode req) :: Maybe SamlLogoutRequest + slrToken rt `shouldBe` "46ToAxZVaXVVZTVKOVF5YU04ZFJVUDVSZlV3" + slrRefreshToken rt `shouldBe` Just "mJdXLtmvTUSpoLwMvdBt_w" + + describe "OidcPrepareRequest / OidcPrepareResponse" $ do + it "encodes a realm selector" $ do + let req = defaultOidcPrepareRequest {oprRealm = Just "oidc1"} + encode req `shouldBe` "{\"realm\":\"oidc1\"}" + it "round-trips the 3rd-party-SSO iss + login_hint variant" $ do + let req = + defaultOidcPrepareRequest + { oprIss = Just "http://127.0.0.1:8080", + oprLoginHint = Just "this_is_an_opaque_string" + } + let Just rt = decode (encode req) :: Maybe OidcPrepareRequest + oprIss rt `shouldBe` Just "http://127.0.0.1:8080" + oprLoginHint rt `shouldBe` Just "this_is_an_opaque_string" + it "encodes caller-supplied state + nonce" $ do + let req = + defaultOidcPrepareRequest + { oprRealm = Just "oidc1", + oprState = Just "lGYK0EcSLjqH6pkT5EVZjC6eIW5YCGgywj2sxROO", + oprNonce = Just "zOBXLJGUooRrbLbQk5YCcyC8AXw3iloynvluYhZ5" + } + let Just rt = decode (encode req) :: Maybe OidcPrepareRequest + oprState rt `shouldBe` Just "lGYK0EcSLjqH6pkT5EVZjC6eIW5YCGgywj2sxROO" + oprNonce rt `shouldBe` Just "zOBXLJGUooRrbLbQk5YCcyC8AXw3iloynvluYhZ5" + it "decodes the prepare response (redirect/state/nonce/realm)" $ do + let Just r = decode sampleOidcPrepareBytes :: Maybe OidcPrepareResponse + oppRealm r `shouldBe` Just "oidc1" + oppState r `shouldBe` "4dbrihtIAt3wBTwo6DxK-vdk-sSyDBV8Yf0AjdkdT5I" + oppNonce r `shouldBe` "WaBPH0KqPVdG5HHdSxPRjfoZbXMCicm5v1OiAj0DUFM" + + describe "OidcAuthenticateRequest / OidcLogoutRequest" $ do + it "round-trips an authenticate request (redirect_uri/state/nonce)" $ do + let req = + OidcAuthenticateRequest + { oarRedirectUri = + "https://oidc-kibana.elastic.co:5603/api/security/oidc/callback?code=jtI3Ntt8v3_XvcLzCFGq&state=4dbrihtIAt3wBTwo6DxK-vdk-sSyDBV8Yf0AjdkdT5I", + oarState = "4dbrihtIAt3wBTwo6DxK-vdk-sSyDBV8Yf0AjdkdT5I", + oarNonce = "WaBPH0KqPVdG5HHdSxPRjfoZbXMCicm5v1OiAj0DUFM", + oarRealm = Just "oidc1" + } + let Just rt = decode (encode req) :: Maybe OidcAuthenticateRequest + oarState rt `shouldBe` "4dbrihtIAt3wBTwo6DxK-vdk-sSyDBV8Yf0AjdkdT5I" + oarNonce rt `shouldBe` "WaBPH0KqPVdG5HHdSxPRjfoZbXMCicm5v1OiAj0DUFM" + oarRealm rt `shouldBe` Just "oidc1" + it "encodes with the token wire spelling (not access_token)" $ do + let req = + OidcLogoutRequest + { olrToken = "dGhpcyBpcyBub3QgYSByZWFsIHRva2Vu...", + olrRefreshToken = Just "vLBPvmAB6KvwvJZr27cS" + } + let Just obj = decode (encode req) :: Maybe Object + KM.member "token" obj `shouldBe` True + KM.member "access_token" obj `shouldBe` False + KM.member "refresh_token" obj `shouldBe` True + it "decodes a logout request that used the access_token spelling" $ do + let bytes = + "{\"access_token\":\"dGhpcyBpcyBub3QgYSByZWFsIHRva2Vu\",\"refresh_token\":\"vLBPvmAB6KvwvJZr27cS\"}" + let Just r = decode bytes :: Maybe OidcLogoutRequest + olrToken r `shouldBe` "dGhpcyBpcyBub3QgYSByZWFsIHRva2Vu" + olrRefreshToken r `shouldBe` Just "vLBPvmAB6KvwvJZr27cS" + + describe "SsoRedirectResponse" $ do + it "decodes a redirect URL (SAML/OIDC logout)" $ do + let bytes = "{\"redirect\": \"https://my-idp.org/logout/SAMLRequest=....\"}" + let Just r = decode bytes :: Maybe SsoRedirectResponse + srdRedirect r `shouldBe` Just "https://my-idp.org/logout/SAMLRequest=...." + it "tolerates an absent redirect" $ do + let Just r = decode "{}" :: Maybe SsoRedirectResponse + srdRedirect r `shouldBe` Nothing diff --git a/tests/Test/SecurityUsersSpec.hs b/tests/Test/SecurityUsersSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SecurityUsersSpec.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SecurityUsersSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as L +import TestsUtils.Import +import Prelude + +-- | A single-user GET response entry — ES emits @null@ for unset +-- full_name / email. +sampleUserBytes :: L.ByteString +sampleUserBytes = + "{\ + \ \"username\": \"alice\",\ + \ \"roles\": [\"admin\", \"reader\"],\ + \ \"full_name\": null,\ + \ \"email\": \"alice@example.com\",\ + \ \"enabled\": true,\ + \ \"metadata\": {\"_reserved\": true}\ + \}" + +-- | @POST /_security/user/{username}/_has_privileges@ response. +sampleHasPrivilegesResponseBytes :: L.ByteString +sampleHasPrivilegesResponseBytes = + "{\ + \ \"username\": \"alice\",\ + \ \"has_all_requested\": false,\ + \ \"cluster\": {\"monitor\": true, \"manage\": false},\ + \ \"index\": {\ + \ \"logs-*\": {\"read\": true, \"write\": false}\ + \ },\ + \ \"application\": {\ + \ \"myapp\": {\"resource:1\": {\"read\": true}}\ + \ }\ + \}" + +-- | @GET /_security/user/_privileges@ response. +sampleUserPrivilegesBytes :: L.ByteString +sampleUserPrivilegesBytes = + "{\ + \ \"username\": \"alice\",\ + \ \"cluster\": [\"monitor\", \"read_ilm\"],\ + \ \"index\": [\ + \ {\"names\": [\"logs-*\"], \"privileges\": [\"read\"]}\ + \ ],\ + \ \"application\": [\ + \ {\"application\": \"myapp\", \"privileges\": [\"read\"], \"resources\": [\"*\"]}\ + \ ],\ + \ \"run_as\": [\"other\"]\ + \}" + +spec :: Spec +spec = do + describe "User" $ do + it "decodes with null full_name and keeps extras" $ do + let Just u = decode sampleUserBytes :: Maybe User + uUsername u `shouldBe` "alice" + uRoles u `shouldBe` [RoleName "admin", RoleName "reader"] + uFullName u `shouldBe` Nothing + uEmail u `shouldBe` Just "alice@example.com" + uEnabled u `shouldBe` True + + it "defaults enabled to true when absent" $ do + let Just u = decode "{\"username\":\"x\"}" :: Maybe User + uEnabled u `shouldBe` True + + describe "UserCreateBody" $ do + it "omits Nothing fields on encode (omitNulls drops the empty roles array)" $ do + let body = defaultUserCreateBody + encode body `shouldBe` "{\"metadata\":{}}" + + it "round-trips a body with password and roles" $ do + let body = + (defaultUserCreateBody) + { ucbPassword = Just "secret", + ucbRoles = [RoleName "admin"] + } + let Just rt = decode (encode body) :: Maybe UserCreateBody + ucbPassword rt `shouldBe` Just "secret" + ucbRoles rt `shouldBe` [RoleName "admin"] + + describe "UserCreatedResponse" $ do + it "decodes {created:bool}" $ do + let Just uc = decode "{\"created\":true}" :: Maybe UserCreatedResponse + ucCreated uc `shouldBe` True + + describe "UserDeletedResponse" $ do + it "decodes found + acknowledged" $ do + let Just ud = decode "{\"found\":true,\"acknowledged\":true}" :: Maybe UserDeletedResponse + udFound ud `shouldBe` Just True + + describe "UsersListResponse" $ do + it "decodes an object keyed by username" $ do + let bytes = + "{\ + \ \"alice\": {\"username\":\"alice\",\"roles\":[\"admin\"]},\ + \ \"bob\": {\"username\":\"bob\",\"roles\":[]}\ + \}" + let Just resp = decode bytes :: Maybe UsersListResponse + length (usersListEntries resp) `shouldBe` 2 + + describe "HasPrivilegesRequest" $ do + it "encodes the nested index/application structure and round-trips" $ do + let req = + (defaultHasPrivilegesRequest) + { hprCluster = ["monitor"], + hprIndex = [(IndexPattern "logs-*", ["read", "write"])], + hprApplication = + [ ( "myapp", + [("resource:1", ["read"])] + ) + ] + } + let bytes = encode req + -- Round-trip recovers the request, proving the nested + -- index/application structure survived encode→decode intact. + let Just rt = decode bytes :: Maybe HasPrivilegesRequest + hprCluster rt `shouldBe` ["monitor"] + hprIndex rt `shouldBe` [(IndexPattern "logs-*", ["read", "write"])] + hprApplication rt `shouldBe` [("myapp", [("resource:1", ["read"])])] + + describe "HasPrivilegesResponse" $ do + it "decodes the nested boolean tree" $ do + let Just resp = decode sampleHasPrivilegesResponseBytes :: Maybe HasPrivilegesResponse + hpUsername resp `shouldBe` "alice" + hpHasAllRequested resp `shouldBe` False + -- Cluster section: monitor=true, manage=false. + lookup "monitor" (hpCluster resp) `shouldBe` Just True + lookup "manage" (hpCluster resp) `shouldBe` Just False + -- Index section: one pattern, read=true. + case hpIndex resp of + [(_, ixResults)] -> lookup "read" ixResults `shouldBe` Just True + other -> expectationFailure ("expected one index entry, got " <> show other) + -- Application section nested two levels deep. + case hpApplication resp of + [("myapp", resResults)] -> + case lookup "resource:1" resResults of + Just appPrivs -> lookup "read" appPrivs `shouldBe` Just True + Nothing -> expectationFailure "missing resource:1" + other -> expectationFailure ("expected myapp, got " <> show other) + + describe "UserPrivileges" $ do + it "decodes cluster/index/application/run_as" $ do + let Just up = decode sampleUserPrivilegesBytes :: Maybe UserPrivileges + upCluster up `shouldBe` ["monitor", "read_ilm"] + length (upIndex up) `shouldBe` 1 + upRunAs up `shouldBe` ["other"] + + describe "ChangePasswordBody" $ do + it "encodes {password}" $ do + encode (ChangePasswordBody "pw") `shouldBe` "{\"password\":\"pw\"}" diff --git a/tests/Test/SimulateIngestSpec.hs b/tests/Test/SimulateIngestSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SimulateIngestSpec.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SimulateIngestSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import Database.Bloodhound.ElasticSearch9.Types qualified as Types +import TestsUtils.Import + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +-- | Extract the inner doc of the first response entry; the decode tests +-- feed known non-empty responses so the empty case is unreachable. +firstRespDoc :: Types.SimulateIngestResponse -> Types.SimulateIngestResponseInner +firstRespDoc r = case Types.sirResponseDocs r of + (d : _) -> Types.srdDoc d + [] -> error "firstRespDoc: empty SimulateIngestResponse" + +spec :: Spec +spec = + describe "Simulate ingest v2 API (GET/POST /_ingest/_simulate, /_ingest/{index}/_simulate)" $ do + describe "SimulateIngestMergeType" $ do + it "renders index/template as text" $ do + Types.simulateIngestMergeTypeToText Types.SimulateIngestMergeIndex + `shouldBe` ("index" :: Text) + Types.simulateIngestMergeTypeToText Types.SimulateIngestMergeTemplate + `shouldBe` ("template" :: Text) + + it "round-trips via fromText" $ + mapM_ + ( \mt -> + Types.simulateIngestMergeTypeFromText + (Types.simulateIngestMergeTypeToText mt) + `shouldBe` Just mt + ) + [minBound .. maxBound] + + it "rejects unknown values" $ + Types.simulateIngestMergeTypeFromText "bogus" + `shouldBe` (Nothing :: Maybe Types.SimulateIngestMergeType) + + describe "simulateIngestOptionsParams URI rendering" $ do + it "defaultSimulateIngestOptions emits no params" $ + Types.simulateIngestOptionsParams Types.defaultSimulateIngestOptions + `shouldBe` [] + + it "renders pipeline and merge_type" $ do + let opts = + Types.defaultSimulateIngestOptions + { Types.sioPipeline = Just "my-pipeline", + Types.sioMergeType = Just Types.SimulateIngestMergeTemplate + } + Types.simulateIngestOptionsParams opts + `shouldBe` [("pipeline", Just "my-pipeline"), ("merge_type", Just "template")] + + it "renders only the set field" $ do + let opts = + Types.defaultSimulateIngestOptions + { Types.sioMergeType = Just Types.SimulateIngestMergeIndex + } + Types.simulateIngestOptionsParams opts + `shouldBe` [("merge_type", Just "index")] + + describe "SimulateIngestDoc JSON" $ do + it "encodes a doc, omitting optional id/index" $ do + let doc = + Types.SimulateIngestDoc + { Types.sidId = Nothing, + Types.sidIndex = Nothing, + Types.sidSource = object ["foo" .= ("bar" :: Text)] + } + encode doc `shouldBe` "{\"_source\":{\"foo\":\"bar\"}}" + + it "encodes id and index when present" $ do + let doc = + Types.SimulateIngestDoc + { Types.sidId = Just "123", + Types.sidIndex = Just "my-index", + Types.sidSource = object ["foo" .= ("bar" :: Text)] + } + decode (encode doc) `shouldBe` Just doc + + it "decodes the documented example" $ do + let raw = + LBS.pack + "{\"_id\":\"123\",\"_index\":\"my-index\",\"_source\":{\"foo\":\"bar\"}}" + case decode raw :: Maybe Types.SimulateIngestDoc of + Just doc -> Types.sidId doc `shouldBe` Just "123" + Nothing -> expectationFailure "failed to decode SimulateIngestDoc" + + describe "SimulateIngestRequest JSON" $ do + it "encodes a minimal request (docs only)" $ do + let req = + Types.SimulateIngestRequest + { Types.sirDocs = + [ Types.SimulateIngestDoc + { Types.sidId = Just "123", + Types.sidIndex = Just "my-index", + Types.sidSource = object ["foo" .= ("bar" :: Text)] + } + ], + Types.sirComponentTemplateSubstitutions = Nothing, + Types.sirIndexTemplateSubstitutions = Nothing, + Types.sirMappingAddition = Nothing + } + hasKey "component_template_substitutions" (encode req) `shouldBe` False + decode (encode req) `shouldBe` Just req + + it "always emits the required docs key, even when empty" $ do + let req = + Types.SimulateIngestRequest + { Types.sirDocs = [], + Types.sirComponentTemplateSubstitutions = Nothing, + Types.sirIndexTemplateSubstitutions = Nothing, + Types.sirMappingAddition = Nothing + } + hasKey "docs" (encode req) `shouldBe` True + + it "decodes a request, defaulting docs to []" $ + case decode (LBS.pack "{}") :: Maybe Types.SimulateIngestRequest of + Just req -> length (Types.sirDocs req) `shouldBe` 0 + Nothing -> expectationFailure "failed to decode empty SimulateIngestRequest" + + describe "SimulateIngestResponse JSON" $ do + it "decodes a documented response entry" $ do + let raw = + LBS.pack + "{\"docs\":[{\"doc\":{\"_id\":\"123\",\"_index\":\"my-index\",\"_source\":{\"foo\":\"bar\"},\"executed_pipelines\":[\"my-pipeline\"]}}]}" + case decode raw :: Maybe Types.SimulateIngestResponse of + Just resp -> do + length (Types.sirResponseDocs resp) `shouldBe` 1 + let inner = firstRespDoc resp + Types.siriExecutedPipelines inner + `shouldBe` ["my-pipeline"] + Nothing -> expectationFailure "failed to decode SimulateIngestResponse" + + it "defaults executed_pipelines to [] when omitted" $ do + let raw = + LBS.pack + "{\"docs\":[{\"doc\":{\"_id\":\"1\",\"_index\":\"i\",\"_source\":{}}}]}" + case decode raw :: Maybe Types.SimulateIngestResponse of + Just resp -> + Types.siriExecutedPipelines + (firstRespDoc resp) + `shouldBe` [] + Nothing -> expectationFailure "failed to decode SimulateIngestResponse" + + it "round-trips an inner entry, preserving executed_pipelines" $ do + let inner = + Types.SimulateIngestResponseInner + { Types.siriId = Just "1", + Types.siriIndex = Just "i", + Types.siriSource = Just (object ["foo" .= ("bar" :: Text)]), + Types.siriExecutedPipelines = [], + Types.siriIgnoredFields = Nothing, + Types.siriError = Nothing, + Types.siriEffectiveMapping = Nothing + } + hasKey "executed_pipelines" (encode inner) `shouldBe` True + decode (encode inner) `shouldBe` Just inner + + it "decodes an entry carrying an error object" $ do + let raw = + LBS.pack + "{\"docs\":[{\"doc\":{\"_source\":{},\"executed_pipelines\":[],\"error\":{\"type\":\"x\",\"reason\":\"y\"}}}]}" + case decode raw :: Maybe Types.SimulateIngestResponse of + Just resp -> + Types.siriError + (firstRespDoc resp) + `shouldSatisfy` isJust + Nothing -> expectationFailure "failed to decode SimulateIngestResponse" + + describe "endpoint shape" $ do + it "POSTs /_ingest/_simulate with a body" $ do + let req = + RequestsES9.simulateIngest + ( Types.SimulateIngestRequest + { Types.sirDocs = [], + Types.sirComponentTemplateSubstitutions = Nothing, + Types.sirIndexTemplateSubstitutions = Nothing, + Types.sirMappingAddition = Nothing + } + ) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "_simulate"] + bhRequestBody req `shouldSatisfy` isJust + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "simulateIngestWith appends pipeline/merge_type params" $ do + let opts = + Types.defaultSimulateIngestOptions + { Types.sioPipeline = Just "p" + } + req = + RequestsES9.simulateIngestWith + ( Types.SimulateIngestRequest + { Types.sirDocs = [], + Types.sirComponentTemplateSubstitutions = Nothing, + Types.sirIndexTemplateSubstitutions = Nothing, + Types.sirMappingAddition = Nothing + } + ) + opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "_simulate"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("pipeline", Just "p")] + + it "POSTs /_ingest//_simulate" $ + case mkIndexName "my-index" of + Left _ -> expectationFailure "mkIndexName rejected a valid name" + Right idx -> do + let req = + RequestsES9.simulateIngestIndex + idx + ( Types.SimulateIngestRequest + { Types.sirDocs = [], + Types.sirComponentTemplateSubstitutions = Nothing, + Types.sirIndexTemplateSubstitutions = Nothing, + Types.sirMappingAddition = Nothing + } + ) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "my-index", "_simulate"] + bhRequestBody req `shouldSatisfy` isJust + + it "simulateIngestIndexWith appends pipeline/merge_type params" $ + case mkIndexName "my-index" of + Left _ -> expectationFailure "mkIndexName rejected a valid name" + Right idx -> do + let opts = + Types.defaultSimulateIngestOptions + { Types.sioMergeType = Just Types.SimulateIngestMergeIndex + } + req = + RequestsES9.simulateIngestIndexWith + idx + ( Types.SimulateIngestRequest + { Types.sirDocs = [], + Types.sirComponentTemplateSubstitutions = Nothing, + Types.sirIndexTemplateSubstitutions = Nothing, + Types.sirMappingAddition = Nothing + } + ) + opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "my-index", "_simulate"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("merge_type", Just "index")] + + it "GETs /_ingest/_simulate with a body" $ do + let req = + RequestsES9.simulateIngestGet + ( Types.SimulateIngestRequest + { Types.sirDocs = [], + Types.sirComponentTemplateSubstitutions = Nothing, + Types.sirIndexTemplateSubstitutions = Nothing, + Types.sirMappingAddition = Nothing + } + ) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "_simulate"] + -- GET-form still carries the required docs body (getWithBody). + bhRequestBody req `shouldSatisfy` isJust + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "simulateIngestWithGet appends pipeline/merge_type params" $ do + let opts = + Types.defaultSimulateIngestOptions + { Types.sioPipeline = Just "p" + } + req = + RequestsES9.simulateIngestWithGet + ( Types.SimulateIngestRequest + { Types.sirDocs = [], + Types.sirComponentTemplateSubstitutions = Nothing, + Types.sirIndexTemplateSubstitutions = Nothing, + Types.sirMappingAddition = Nothing + } + ) + opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "_simulate"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("pipeline", Just "p")] + + it "GETs /_ingest//_simulate with a body" $ + case mkIndexName "my-index" of + Left _ -> expectationFailure "mkIndexName rejected a valid name" + Right idx -> do + let req = + RequestsES9.simulateIngestIndexGet + idx + ( Types.SimulateIngestRequest + { Types.sirDocs = [], + Types.sirComponentTemplateSubstitutions = Nothing, + Types.sirIndexTemplateSubstitutions = Nothing, + Types.sirMappingAddition = Nothing + } + ) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "my-index", "_simulate"] + bhRequestBody req `shouldSatisfy` isJust + + it "simulateIngestIndexWithGet appends pipeline/merge_type params" $ + case mkIndexName "my-index" of + Left _ -> expectationFailure "mkIndexName rejected a valid name" + Right idx -> do + let opts = + Types.defaultSimulateIngestOptions + { Types.sioMergeType = Just Types.SimulateIngestMergeIndex + } + req = + RequestsES9.simulateIngestIndexWithGet + idx + ( Types.SimulateIngestRequest + { Types.sirDocs = [], + Types.sirComponentTemplateSubstitutions = Nothing, + Types.sirIndexTemplateSubstitutions = Nothing, + Types.sirMappingAddition = Nothing + } + ) + opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_ingest", "my-index", "_simulate"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("merge_type", Just "index")] diff --git a/tests/Test/SnapshotManagementSpec.hs b/tests/Test/SnapshotManagementSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SnapshotManagementSpec.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SnapshotManagementSpec (spec) where + +import Data.Aeson (Value (..), decode, encode, object, (.=)) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List (sort) +import Data.Map.Strict qualified as Map +import Database.Bloodhound.OpenSearch2.Requests qualified as OS2Requests +import Database.Bloodhound.OpenSearch3.Requests qualified as OS3Requests +import Database.Bloodhound.OpenSearch3.Types qualified as OS3 +import TestsUtils.Import +import Prelude + +-- | Pure endpoint-shape and JSON-decoding tests for the OpenSearch Snapshot +-- Management (SM) plugin (@\/_plugins\/_sm\/policies@). No live backend +-- needed: every assertion runs against the in-memory 'BHRequest' produced +-- by the OS3 'Requests' module, or against JSON fixtures quoted verbatim +-- from the SM API docs. +-- +-- The OS2 and OS3 'Requests' modules produce byte-identical 'BHRequest's +-- at runtime (the SM type modules are byte-identical mirrors of each +-- other). The SM plugin was introduced in OpenSearch 2.1, so OS1 does not +-- carry this surface; following the 'Test.OSAsyncSearchSpec' precedent we +-- exercise OS3 for the detailed shape assertions and add a cross-version +-- equivalence check on one representative endpoint ('getSMPolicies') to +-- guard against refactors that silently diverge the two modules. +-- +-- See +spec :: Spec +spec = describe "OpenSearch Snapshot Management (SM) API" $ do + -- =============================================================== + -- Endpoint-shape tests (no live backend) + -- =============================================================== + describe "postSMPolicy endpoint shape" $ do + let body = + OS3.SMPolicyBody + { OS3.smPolicyBodyDescription = Just "Daily snapshot policy", + OS3.smPolicyBodyEnabled = Just True, + OS3.smPolicyBodyCreation = Nothing, + OS3.smPolicyBodyDeletion = Nothing, + OS3.smPolicyBodySnapshotConfig = Nothing, + OS3.smPolicyBodyNotification = Nothing + } + req = OS3Requests.postSMPolicy (OS3.SMPolicyName "daily-policy") body + + it "POSTs to /_plugins/_sm/policies/{policy_name} with no query string" $ do + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sm", "policies", "daily-policy"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "attaches the encoded SMPolicyBody as the JSON body" $ do + let Just bytes = bhRequestBody req + LBS.unpack bytes `shouldContain` "\"description\"" + LBS.unpack bytes `shouldContain` "Daily snapshot policy" + + describe "putSMPolicyWith endpoint shape" $ do + let body = OS3.SMPolicyBody Nothing Nothing Nothing Nothing Nothing Nothing + req = OS3Requests.putSMPolicyWith (OS3.SMPolicyName "p") body 7 3 + + it "PUTs to /_plugins/_sm/policies/{policy_name} with if_seq_no / if_primary_term" $ do + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sm", "policies", "p"] + sort (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sort + [ ("if_seq_no", Just "7"), + ("if_primary_term", Just "3") + ] + + describe "getSMPolicy endpoint shape" $ do + it "GETs /_plugins/_sm/policies/{policy_name} with no body / query" $ do + let req = OS3Requests.getSMPolicy (OS3.SMPolicyName "daily-policy") + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sm", "policies", "daily-policy"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Nothing + + describe "getSMPolicies endpoint shape" $ do + it "GETs /_plugins/_sm/policies with no query string by default" $ do + let req = OS3Requests.getSMPolicies Nothing + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sm", "policies"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "forwards the documented pagination/sort/queryString parameters" $ do + let q = + OS3.GetSMPoliciesQuery + { OS3.getSMPoliciesQueryFrom = Just 0, + OS3.getSMPoliciesQuerySize = Just 20, + OS3.getSMPoliciesQuerySortField = Just "sm_policy.name", + OS3.getSMPoliciesQuerySortOrder = Just "desc", + OS3.getSMPoliciesQueryQueryString = Just "*" + } + req = OS3Requests.getSMPolicies (Just q) + sort (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sort + [ ("from", Just "0"), + ("size", Just "20"), + ("sortField", Just "sm_policy.name"), + ("sortOrder", Just "desc"), + ("queryString", Just "*") + ] + + it "defaultGetSMPoliciesQuery emits no parameters" $ do + let req = OS3Requests.getSMPolicies (Just OS3.defaultGetSMPoliciesQuery) + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "produces the same path across OS2 and OS3 (path equivalence)" $ do + let path2 = getRawEndpoint (bhRequestEndpoint (OS2Requests.getSMPolicies Nothing)) + path3 = getRawEndpoint (bhRequestEndpoint (OS3Requests.getSMPolicies Nothing)) + path2 `shouldBe` ["_plugins", "_sm", "policies"] + path2 `shouldBe` path3 + + describe "deleteSMPolicy endpoint shape" $ do + it "DELETEs /_plugins/_sm/policies/{policy_name} with no body / query" $ do + let req = OS3Requests.deleteSMPolicy (OS3.SMPolicyName "daily-policy") + bhRequestMethod req `shouldBe` "DELETE" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sm", "policies", "daily-policy"] + bhRequestBody req `shouldBe` Nothing + + describe "startSMPolicy endpoint shape" $ do + it "POSTs (no body) to /_plugins/_sm/policies/{policy_name}/_start" $ do + let req = OS3Requests.startSMPolicy (OS3.SMPolicyName "daily-policy") + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sm", "policies", "daily-policy", "_start"] + bhRequestBody req `shouldBe` Nothing + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "stopSMPolicy endpoint shape" $ do + it "POSTs (no body) to /_plugins/_sm/policies/{policy_name}/_stop" $ do + let req = OS3Requests.stopSMPolicy (OS3.SMPolicyName "daily-policy") + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sm", "policies", "daily-policy", "_stop"] + bhRequestBody req `shouldBe` Nothing + + describe "explainSMPolicies endpoint shape" $ do + it "GETs /_plugins/_sm/policies/{pattern}/_explain" $ do + let req = OS3Requests.explainSMPolicies "daily*" + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sm", "policies", "daily*", "_explain"] + bhRequestBody req `shouldBe` Nothing + + it "forwards the comma-separated list verbatim as one path segment" $ do + let req = OS3Requests.explainSMPolicies "policy-a,policy-b" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_plugins", "_sm", "policies", "policy-a,policy-b", "_explain"] + + -- =============================================================== + -- JSON-decoding tests (verbatim doc fixtures) + -- =============================================================== + describe "SMPolicyResponse decoding (Create/Get fixture)" $ do + -- Verbatim from the SM API docs: POST /_plugins/_sm/policies/daily-policy + let fixture = + LBS.pack + "{\"_id\":\"daily-policy-sm-policy\",\"_version\":5,\"_seq_no\":54983,\ + \\"_primary_term\":21,\"sm_policy\":{\"name\":\"daily-policy\",\ + \\"description\":\"Daily snapshot policy\",\"schema_version\":15,\ + \\"creation\":{\"schedule\":{\"cron\":{\"expression\":\"0 8 * * *\",\ + \\"timezone\":\"UTC\"}},\"time_limit\":\"1h\"},\"deletion\":{\"schedule\":\ + \{\"cron\":{\"expression\":\"0 1 * * *\",\"timezone\":\ + \\"America/Los_Angeles\"}},\"condition\":{\"max_age\":\"7d\",\ + \\"min_count\":7,\"max_count\":21},\"time_limit\":\"1h\",\ + \\"snapshot_pattern\":\"external-backup-*\"},\"snapshot_config\":\ + \{\"indices\":\"*\",\"metadata\":{\"any_key\":\"any_value\"},\ + \\"ignore_unavailable\":\"true\",\"timezone\":\ + \\"America/Los_Angeles\",\"include_global_state\":\"false\",\ + \\"date_format\":\"yyyy-MM-dd-HH:mm\",\"repository\":\"s3-repo\",\ + \\"partial\":\"true\"},\"schedule\":{\"interval\":{\"start_time\":\ + \1656425122909,\"period\":1,\"unit\":\"Minutes\"}},\"enabled\":true,\ + \\"last_updated_time\":1656425122909,\"enabled_time\":1656425122909,\ + \\"notification\":{\"channel\":{\"id\":\"NC3OpoEBzEoHMX183R3f\"},\ + \\"conditions\":{\"creation\":true,\"deletion\":false,\"failure\":false,\ + \\"time_limit_exceeded\":false}}}}" + + it "decodes the documented Create/Get fixture" $ do + let Just decoded = decode fixture :: Maybe OS3.SMPolicyResponse + OS3.smPolicyResponseId decoded `shouldBe` Just "daily-policy-sm-policy" + OS3.smPolicyResponseVersion decoded `shouldBe` Just 5 + OS3.smPolicyResponseSeqNo decoded `shouldBe` Just 54983 + OS3.smPolicyResponsePrimaryTerm decoded `shouldBe` Just 21 + let Just policy = OS3.smPolicyResponseSMPolicy decoded + OS3.smPolicyName policy `shouldBe` Just "daily-policy" + OS3.smPolicySchemaVersion policy `shouldBe` Just 15 + OS3.smPolicyLastUpdatedTime policy `shouldBe` Just 1656425122909 + + it "parses lenient booleans in snapshot_config (string \"true\"/\"false\")" $ do + let Just decoded = decode fixture :: Maybe OS3.SMPolicyResponse + Just policy = OS3.smPolicyResponseSMPolicy decoded + Just cfg = OS3.smPolicyBodySnapshotConfig (OS3.smPolicyBody policy) + OS3.smSnapshotConfigIgnoreUnavailable cfg `shouldBe` Just True + OS3.smSnapshotConfigIncludeGlobalState cfg `shouldBe` Just False + OS3.smSnapshotConfigPartial cfg `shouldBe` Just True + + it "parses snapshot_config.repository / indices / metadata verbatim" $ do + let Just decoded = decode fixture :: Maybe OS3.SMPolicyResponse + Just policy = OS3.smPolicyResponseSMPolicy decoded + Just cfg = OS3.smPolicyBodySnapshotConfig (OS3.smPolicyBody policy) + OS3.smSnapshotConfigRepository cfg `shouldBe` Just "s3-repo" + OS3.smSnapshotConfigIndices cfg `shouldBe` Just "*" + OS3.smSnapshotConfigMetadata cfg `shouldBe` Just (Map.fromList [("any_key", "any_value")]) + + it "parses the notification channel + conditions" $ do + let Just decoded = decode fixture :: Maybe OS3.SMPolicyResponse + Just policy = OS3.smPolicyResponseSMPolicy decoded + Just notif = OS3.smPolicyBodyNotification (OS3.smPolicyBody policy) + Just chan = OS3.smNotificationChannel notif + Just conds = OS3.smNotificationConditions notif + OS3.smNotificationChannelId chan `shouldBe` "NC3OpoEBzEoHMX183R3f" + OS3.smNotificationConditionsCreation conds `shouldBe` Just True + OS3.smNotificationConditionsDeletion conds `shouldBe` Just False + + it "parses creation/deletion cron schedules and time_limits" $ do + let Just decoded = decode fixture :: Maybe OS3.SMPolicyResponse + Just policy = OS3.smPolicyResponseSMPolicy decoded + Just creation = OS3.smPolicyBodyCreation (OS3.smPolicyBody policy) + Just deletion = OS3.smPolicyBodyDeletion (OS3.smPolicyBody policy) + OS3.smCreationTimeLimit creation `shouldBe` Just "1h" + OS3.smDeletionTimeLimit deletion `shouldBe` Just "1h" + OS3.smDeletionSnapshotPattern deletion `shouldBe` Just "external-backup-*" + + describe "SMPolicyResponse decoding (Get fixture without notification)" $ do + -- Verbatim from the docs: GET /_plugins/_sm/policies/daily-policy, + -- demonstrating that notification is genuinely optional. + let fixture = + LBS.pack + "{\"_id\":\"daily-policy-sm-policy\",\"_version\":6,\"_seq_no\":44696,\ + \\"_primary_term\":19,\"sm_policy\":{\"name\":\"daily-policy\",\ + \\"description\":\"Daily snapshot policy\",\"schema_version\":15,\ + \\"creation\":{\"schedule\":{\"cron\":{\"expression\":\"0 8 * * *\",\ + \\"timezone\":\"UTC\"}},\"time_limit\":\"1h\"},\"deletion\":{\"schedule\":\ + \{\"cron\":{\"expression\":\"0 1 * * *\",\"timezone\":\ + \\"America/Los_Angeles\"}},\"condition\":{\"max_age\":\"7d\",\ + \\"min_count\":7,\"max_count\":21},\"time_limit\":\"1h\",\ + \\"snapshot_pattern\":\"external-backup-*\"},\"snapshot_config\":\ + \{\"metadata\":{\"any_key\":\"any_value\"},\"ignore_unavailable\":\ + \\"true\",\"include_global_state\":\"false\",\"date_format\":\ + \\"yyyy-MM-dd-HH:mm\",\"repository\":\"s3-repo\",\"partial\":\ + \\"true\"},\"schedule\":{\"interval\":{\"start_time\":1656341042874,\ + \\"period\":1,\"unit\":\"Minutes\"}},\"enabled\":true,\ + \\"last_updated_time\":1656341042874,\"enabled_time\":1656341042874}}" + + it "decodes cleanly when notification is absent" $ do + let Just decoded = decode fixture :: Maybe OS3.SMPolicyResponse + Just policy = OS3.smPolicyResponseSMPolicy decoded + OS3.smPolicyBodyNotification (OS3.smPolicyBody policy) `shouldBe` Nothing + + describe "DeleteSMPolicyResponse decoding (fixture)" $ do + -- Verbatim from the docs: DELETE /_plugins/_sm/policies/daily-policy + let fixture = + LBS.pack + "{\"_index\":\".opendistro-ism-config\",\"_id\":\ + \\"daily-policy-sm-policy\",\"_version\":8,\"result\":\"deleted\",\ + \\"forced_refresh\":true,\"_shards\":{\"total\":2,\"successful\":2,\ + \\"failed\":0},\"_seq_no\":45366,\"_primary_term\":20}" + + it "decodes the documented delete envelope" $ do + let Just decoded = decode fixture :: Maybe OS3.DeleteSMPolicyResponse + OS3.deleteSMPolicyResponseIndex decoded `shouldBe` Just ".opendistro-ism-config" + OS3.deleteSMPolicyResponseId decoded `shouldBe` Just "daily-policy-sm-policy" + OS3.deleteSMPolicyResponseVersion decoded `shouldBe` Just 8 + OS3.deleteSMPolicyResponseResult decoded `shouldBe` Just "deleted" + OS3.deleteSMPolicyResponseForcedRefresh decoded `shouldBe` Just True + OS3.deleteSMPolicyResponseSeqNo decoded `shouldBe` Just 45366 + + describe "SMExplainResponse decoding (fixture)" $ do + -- Verbatim from the docs: GET /_plugins/_sm/policies/daily*/_explain + let fixture = + LBS.pack + "{\"policies\":[{\"name\":\"daily-policy\",\"creation\":\ + \{\"current_state\":\"CREATION_START\",\"trigger\":{\"time\":\ + \1656403200000}},\"deletion\":{\"current_state\":\ + \\"DELETION_START\",\"trigger\":{\"time\":1656403200000}},\ + \\"policy_seq_no\":44696,\"policy_primary_term\":19,\"enabled\":true}]}" + + it "decodes the documented explain fixture" $ do + let Just decoded = decode fixture :: Maybe OS3.SMExplainResponse + let entry = head (OS3.smExplainResponsePolicies decoded) + OS3.smExplainEntryName entry `shouldBe` Just "daily-policy" + OS3.smExplainEntryPolicySeqNo entry `shouldBe` Just 44696 + OS3.smExplainEntryPolicyPrimaryTerm entry `shouldBe` Just 19 + OS3.smExplainEntryEnabled entry `shouldBe` Just True + let Just creation = OS3.smExplainEntryCreation entry + OS3.smExplainWorkflowCurrentState creation `shouldBe` Just "CREATION_START" + let Just trigger = OS3.smExplainWorkflowTrigger creation + OS3.smExplainTriggerTime trigger `shouldBe` Just 1656403200000 + + -- =============================================================== + -- Lenient / inconsistent-input tests + -- =============================================================== + describe "SMSnapshotConfig lenient bool parsing" $ do + it "accepts native Bool for ignore_unavailable / include_global_state / partial" $ do + let fixture = + LBS.pack + "{\"repository\":\"r\",\"ignore_unavailable\":true,\ + \\"include_global_state\":false,\"partial\":true}" + Just cfg = decode fixture :: Maybe OS3.SMSnapshotConfig + OS3.smSnapshotConfigIgnoreUnavailable cfg `shouldBe` Just True + OS3.smSnapshotConfigIncludeGlobalState cfg `shouldBe` Just False + OS3.smSnapshotConfigPartial cfg `shouldBe` Just True + + it "accepts string \"true\"/\"false\" for the same fields (case-insensitive)" $ do + let fixture = + LBS.pack + "{\"repository\":\"r\",\"ignore_unavailable\":\"TRUE\",\ + \\"include_global_state\":\"False\",\"partial\":\"true\"}" + Just cfg = decode fixture :: Maybe OS3.SMSnapshotConfig + OS3.smSnapshotConfigIgnoreUnavailable cfg `shouldBe` Just True + OS3.smSnapshotConfigIncludeGlobalState cfg `shouldBe` Just False + OS3.smSnapshotConfigPartial cfg `shouldBe` Just True + + it "forwards unknown snapshot_config keys through Extras" $ do + let fixture = + LBS.pack + "{\"repository\":\"r\",\"custom_key\":\"custom_value\"}" + Just cfg = decode fixture :: Maybe OS3.SMSnapshotConfig + OS3.smSnapshotConfigRepository cfg `shouldBe` Just "r" + + describe "SMDeletion condition / delete_condition key acceptance" $ do + it "decodes the JSON-example key \"condition\"" $ do + let fixture = + LBS.pack + "{\"condition\":{\"max_age\":\"7d\",\"max_count\":21,\"min_count\":7}}" + Just decoded = decode fixture :: Maybe OS3.SMDeletion + Just cond = OS3.smDeletionCondition decoded + OS3.smDeleteConditionMaxAge cond `shouldBe` Just "7d" + OS3.smDeleteConditionMaxCount cond `shouldBe` Just 21 + + it "also accepts the parameter-table key \"delete_condition\"" $ do + let fixture = + LBS.pack + "{\"delete_condition\":{\"max_age\":\"14d\",\"max_count\":50}}" + Just decoded = decode fixture :: Maybe OS3.SMDeletion + Just cond = OS3.smDeletionCondition decoded + OS3.smDeleteConditionMaxAge cond `shouldBe` Just "14d" + OS3.smDeleteConditionMaxCount cond `shouldBe` Just 50 + + describe "getSMPoliciesQueryParams rendering" $ do + it "renders nothing for the default query" $ do + OS3.getSMPoliciesQueryParams OS3.defaultGetSMPoliciesQuery `shouldBe` [] + + it "renders every set field, skipping Nothing" $ do + let q = + OS3.defaultGetSMPoliciesQuery + { OS3.getSMPoliciesQuerySize = Just 50, + OS3.getSMPoliciesQuerySortOrder = Just "asc" + } + sort (OS3.getSMPoliciesQueryParams q) + `shouldBe` sort [("size", Just "50"), ("sortOrder", Just "asc")] + + describe "SMPolicyBody round-trip" $ do + it "encodes a minimal body without the optional keys" $ do + let body = + OS3.SMPolicyBody + { OS3.smPolicyBodyDescription = Nothing, + OS3.smPolicyBodyEnabled = Nothing, + OS3.smPolicyBodyCreation = Nothing, + OS3.smPolicyBodyDeletion = Nothing, + OS3.smPolicyBodySnapshotConfig = Nothing, + OS3.smPolicyBodyNotification = Nothing + } + bytes = encode body + LBS.unpack bytes `shouldBe` "{}" + + it "encodes a notification block and decodes it back" $ do + let notif = + OS3.SMNotification + { OS3.smNotificationChannel = + Just (OS3.SMNotificationChannel "ch-1"), + OS3.smNotificationConditions = + Just + ( OS3.SMNotificationConditions + { OS3.smNotificationConditionsCreation = Just True, + OS3.smNotificationConditionsDeletion = Nothing, + OS3.smNotificationConditionsFailure = Nothing, + OS3.smNotificationConditionsTimeLimitExceeded = Nothing + } + ) + } + body = + OS3.SMPolicyBody + { OS3.smPolicyBodyDescription = Just "rt", + OS3.smPolicyBodyEnabled = Just True, + OS3.smPolicyBodyCreation = Nothing, + OS3.smPolicyBodyDeletion = Nothing, + OS3.smPolicyBodySnapshotConfig = Nothing, + OS3.smPolicyBodyNotification = Just notif + } + Just decoded = decode (encode body) :: Maybe OS3.SMPolicyBody + OS3.smPolicyBodyDescription decoded `shouldBe` Just "rt" + OS3.smPolicyBodyEnabled decoded `shouldBe` Just True + OS3.smNotificationChannelId + <$> (OS3.smNotificationChannel =<< OS3.smPolicyBodyNotification decoded) + `shouldBe` Just "ch-1" diff --git a/tests/Test/SnapshotsSpec.hs b/tests/Test/SnapshotsSpec.hs --- a/tests/Test/SnapshotsSpec.hs +++ b/tests/Test/SnapshotsSpec.hs @@ -5,11 +5,13 @@ module Test.SnapshotsSpec (spec) where -import qualified Data.Aeson.KeyMap as X -import qualified Data.List as L -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Network.HTTP.Types.Method as NHTM +import Control.Monad.Catch (MonadMask, bracket, bracket_, finally) +import Data.Aeson.KeyMap qualified as X +import Data.HashMap.Strict qualified as HM +import Data.List qualified as L +import Data.Text qualified as T +import Data.Vector qualified as V +import Network.HTTP.Types.Method qualified as NHTM import TestsUtils.Common import TestsUtils.Generators () import TestsUtils.Import @@ -20,6 +22,571 @@ prop "SnapshotRepo laws" $ \fsr -> fromGSnapshotRepo (toGSnapshotRepo fsr) === Right (fsr :: FsSnapshotRepo) + describe "SnapshotStatus JSON parsing" $ do + let inProgressBody = + "{\"snapshots\":[{\"snapshot\":\"snap-1\",\"repository\":\"repo-1\",\"uuid\":\"abc-123\",\"state\":\"STARTED\",\"include_global_state\":true,\"shards_stats\":{\"initializing\":0,\"started\":1,\"finalizing\":0,\"done\":1,\"failed\":0,\"total\":2},\"stats\":{\"incremental\":{\"file_count\":4,\"size_in_bytes\":5412},\"total\":{\"file_count\":4,\"size_in_bytes\":5412},\"start_time_in_millis\":1750452674327,\"time_in_millis\":189},\"indices\":{\"index-1\":{\"shards_stats\":{\"initializing\":0,\"started\":1,\"finalizing\":0,\"done\":0,\"failed\":0,\"total\":1},\"stats\":{\"incremental\":{\"file_count\":2,\"size_in_bytes\":100},\"total\":{\"file_count\":2,\"size_in_bytes\":100}},\"shards\":{\"0\":{\"stage\":\"STARTED\",\"stats\":{\"incremental\":{\"file_count\":1,\"size_in_bytes\":50}},\"node\":\"VJzy6aKJSVKwcfjIFBPXxw\"},\"1\":{\"stage\":\"FAILURE\",\"reason\":\"disk full\",\"node\":\"VJzy6aKJSVKwcfjIFBPXxw\"}}}}}]}" + + minimalBody = + "{\"snapshots\":[{\"snapshot\":\"snap-2\",\"repository\":\"repo-1\",\"uuid\":\"def-456\",\"state\":\"SUCCESS\",\"include_global_state\":false,\"shards_stats\":{\"initializing\":0,\"started\":0,\"finalizing\":0,\"done\":2,\"failed\":0,\"total\":2}}]}" + + it "parses a full in-progress status response" $ + case parseEither parseJSON =<< eitherDecode inProgressBody :: Either String SSs of + Right (SSs [status]) -> do + snapshotStatusSnapshot status `shouldBe` SnapshotName "snap-1" + snapshotStatusRepository status `shouldBe` SnapshotRepoName "repo-1" + snapshotStatusUuid status `shouldBe` "abc-123" + snapshotStatusState status `shouldBe` SnapshotStarted + snapshotStatusIncludeGlobalState status `shouldBe` True + snapShardStatsTotal (snapshotStatusShardsStats status) `shouldBe` 2 + HM.keys (snapshotStatusIndices status) `shouldBe` ["index-1"] + other -> expectationFailure ("expected singleton SnapshotStatus list, got " <> show other) + + it "captures the FAILURE shard stage and reason field" $ + case parseEither parseJSON =<< eitherDecode inProgressBody :: Either String SSs of + Right (SSs [status]) -> do + let indices = snapshotStatusIndices status + Just indexStatus = HM.lookup "index-1" indices + Just failedShard = HM.lookup "1" (sisShards indexStatus) + snapShardStatusStage failedShard `shouldBe` ShardSnapshotFailure + snapShardStatusReason failedShard `shouldBe` Just "disk full" + other -> expectationFailure ("expected singleton SnapshotStatus list, got " <> show other) + + it "parses a minimal completed snapshot status" $ + case parseEither parseJSON =<< eitherDecode minimalBody :: Either String SSs of + Right (SSs [status]) -> do + snapshotStatusState status `shouldBe` SnapshotSuccess + snapshotStatusIndices status `shouldBe` mempty + snapshotStatusStats status `shouldBe` Nothing + other -> expectationFailure ("expected minimal parse, got " <> show other) + + it "rejects an invalid shard stage token" $ do + let bad = + "{\"snapshot\":\"s\",\"repository\":\"r\",\"uuid\":\"u\",\"state\":\"SUCCESS\",\"shards_stats\":{\"initializing\":0,\"started\":0,\"finalizing\":0,\"done\":0,\"failed\":0,\"total\":0},\"indices\":{\"i\":{\"shards_stats\":{\"initializing\":0,\"started\":0,\"finalizing\":0,\"done\":0,\"failed\":0,\"total\":0},\"shards\":{\"0\":{\"stage\":\"BOGUS\"}}}}}" + case parseEither parseJSON =<< eitherDecode bad :: Either String SnapshotStatus of + Left _ -> return () + Right v -> expectationFailure ("expected stage parsing failure, got " <> show v) + + describe "SnapshotInfo JSON parsing" $ do + let -- Realistic modern (ES 7+/OS) response carrying the six + -- optional fields. The other fields mirror what the server + -- returns for a completed snapshot. + fullBody = + "{\"snapshots\":[{\"snapshot\":\"snap-1\",\"repository\":\"repo-1\",\"uuid\":\"abc-123\",\"state\":\"SUCCESS\",\"version_id\":8170000,\"version\":\"8.17.0\",\"include_global_state\":true,\"metadata\":{\"created_by\":\"backup-job\"},\"data_streams\":[\"logs-stream\",\"metrics-stream\"],\"feature_states\":[{\"feature_name\":\"kibana\",\"indices\":[\".kibana_1\"]},{\"feature_name\":\"transforms\",\"indices\":[\".transform-indices-000001\"]}],\"shards\":{\"total\":2,\"successful\":2,\"skipped\":0,\"failed\":0},\"failures\":[],\"duration_in_millis\":134,\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674327,\"indices\":[\"index-1\"]}]}" + + -- Older server response (pre-ES 7) without any of the six + -- optional fields. Must still parse with all six accessors + -- returning 'Nothing'. + legacyBody = + "{\"snapshots\":[{\"snapshot\":\"snap-2\",\"state\":\"SUCCESS\",\"shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"failures\":[],\"duration_in_millis\":50,\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674411,\"indices\":[]}]}" + + it "parses the modern fields (version_id, version, include_global_state, metadata)" $ + case parseEither parseJSON =<< eitherDecode fullBody :: Either String SIs of + Right (SIs [info]) -> do + snapInfoName info `shouldBe` SnapshotName "snap-1" + -- 'snapInfoUuid' is introduced in bloodhound-kc1; pin it + -- here so future refactors don't drop the field. The + -- fixture carries @"uuid":"abc-123"@. + snapInfoUuid info `shouldBe` Just "abc-123" + snapInfoState info `shouldBe` SnapshotSuccess + snapInfoVersionId info `shouldBe` Just 8170000 + snapInfoVersion info `shouldBe` Just "8.17.0" + snapInfoIncludeGlobalState info `shouldBe` Just True + -- metadata preserved verbatim as a JSON object + case snapInfoMetadata info of + Just o -> X.lookup "created_by" o `shouldBe` Just "backup-job" + Nothing -> expectationFailure "expected metadata object, got Nothing" + snapInfoDataStreams info `shouldBe` Just ["logs-stream", "metrics-stream"] + case snapInfoFeatureStates info of + Just [fs1, fs2] -> do + snapshotFeatureStateName fs1 `shouldBe` "kibana" + map unIndexName (snapshotFeatureStateIndices fs1) `shouldBe` [".kibana_1"] + snapshotFeatureStateName fs2 `shouldBe` "transforms" + map unIndexName (snapshotFeatureStateIndices fs2) + `shouldBe` [".transform-indices-000001"] + other -> + expectationFailure ("expected two feature states, got " <> show other) + other -> expectationFailure ("expected singleton SnapshotInfo list, got " <> show other) + + it "leaves the new fields as Nothing when absent (legacy payloads)" $ + case parseEither parseJSON =<< eitherDecode legacyBody :: Either String SIs of + Right (SIs [info]) -> do + snapInfoName info `shouldBe` SnapshotName "snap-2" + snapInfoUuid info `shouldBe` Nothing + snapInfoVersionId info `shouldBe` Nothing + snapInfoVersion info `shouldBe` Nothing + snapInfoIncludeGlobalState info `shouldBe` Nothing + snapInfoMetadata info `shouldBe` Nothing + snapInfoDataStreams info `shouldBe` Nothing + snapInfoFeatureStates info `shouldBe` Nothing + other -> expectationFailure ("expected singleton SnapshotInfo list, got " <> show other) + + it "parses data_streams and feature_states from a minimal body" $ do + let dataStreamsBody = + "{\"snapshots\":[{\"snapshot\":\"snap-ds\",\"state\":\"SUCCESS\",\"shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"failures\":[],\"duration_in_millis\":10,\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674451,\"indices\":[],\"data_streams\":[\"logs\",\"metrics\"],\"feature_states\":[{\"feature_name\":\"geoip\",\"indices\":[\".geoip_databases\"]}]}]}" + case parseEither parseJSON =<< eitherDecode dataStreamsBody :: Either String SIs of + Right (SIs [info]) -> do + snapInfoName info `shouldBe` SnapshotName "snap-ds" + snapInfoDataStreams info `shouldBe` Just ["logs", "metrics"] + case snapInfoFeatureStates info of + Just [fs] -> do + snapshotFeatureStateName fs `shouldBe` "geoip" + map unIndexName (snapshotFeatureStateIndices fs) + `shouldBe` [".geoip_databases"] + other -> + expectationFailure ("expected one feature state, got " <> show other) + other -> expectationFailure ("expected singleton SnapshotInfo list, got " <> show other) + + it "treats empty arrays as Just [] and supports field asymmetry" $ do + -- feature_states present but empty: Just [], NOT Nothing. And + -- the two fields are independent (data_streams populated here). + let asymBody = + "{\"snapshots\":[{\"snapshot\":\"snap-asym\",\"state\":\"SUCCESS\",\"shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"failures\":[],\"duration_in_millis\":10,\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674451,\"indices\":[],\"data_streams\":[\"logs\"],\"feature_states\":[]}]}" + case parseEither parseJSON =<< eitherDecode asymBody :: Either String SIs of + Right (SIs [info]) -> do + snapInfoName info `shouldBe` SnapshotName "snap-asym" + snapInfoDataStreams info `shouldBe` Just ["logs"] + snapInfoFeatureStates info `shouldBe` Just [] + other -> expectationFailure ("expected singleton SnapshotInfo list, got " <> show other) + + it "parses an empty metadata object as Just (preserved verbatim)" $ do + let emptyMetaBody = + "{\"snapshots\":[{\"snapshot\":\"snap-3\",\"state\":\"SUCCESS\",\"version_id\":7170000,\"version\":\"7.17.0\",\"include_global_state\":false,\"metadata\":{},\"shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"failures\":[],\"duration_in_millis\":10,\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674451,\"indices\":[]}]}" + case parseEither parseJSON =<< eitherDecode emptyMetaBody :: Either String SIs of + Right (SIs [info]) -> do + snapInfoName info `shouldBe` SnapshotName "snap-3" + -- metadata is present (not Nothing) but empty + snapInfoMetadata info `shouldSatisfy` isJust + case snapInfoMetadata info of + Just o -> X.null o `shouldBe` True + Nothing -> return () + other -> expectationFailure ("expected singleton SnapshotInfo list, got " <> show other) + + describe "CreateSnapshotResponse JSON parsing" $ do + -- wait_for_completion=false (the default): the server returns + -- {"acknowledged": }. + it "decodes the acknowledged shape (wait_for_completion=false)" $ do + let body = "{\"acknowledged\":true}" + case parseEither parseJSON =<< eitherDecode body :: Either String CreateSnapshotResponse of + Right (CreateSnapshotAcknowledged (Acknowledged ack)) -> ack `shouldBe` True + other -> + expectationFailure ("expected CreateSnapshotAcknowledged, got " <> show other) + + -- wait_for_completion=true: the server returns a full snapshot + -- object {"snapshot": {…}} with the SnapshotInfo shape. + it "decodes the completed snapshot shape (wait_for_completion=true)" $ do + let body = + "{\"snapshot\":{\"snapshot\":\"snap-1\",\"uuid\":\"abc-123\",\ + \\"state\":\"SUCCESS\",\ + \\"shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\ + \\"failures\":[],\"duration_in_millis\":50,\ + \\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674411,\ + \\"indices\":[]}}" + case parseEither parseJSON =<< eitherDecode body :: Either String CreateSnapshotResponse of + Right (CreateSnapshotCompleted (SnapshotResponse info)) -> do + snapInfoName info `shouldBe` SnapshotName "snap-1" + snapInfoUuid info `shouldBe` Just "abc-123" + snapInfoState info `shouldBe` SnapshotSuccess + other -> + expectationFailure ("expected CreateSnapshotCompleted, got " <> show other) + + -- When both keys are present (ES never legitimately returns both), + -- the @"snapshot"@ key takes priority, matching the documented + -- wait_for_completion=true shape. + it "prefers the snapshot key when both snapshot and acknowledged are present" $ do + let body = + "{\"acknowledged\":true,\"snapshot\":{\"snapshot\":\"snap-1\",\"state\":\"SUCCESS\",\ + \\"shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\ + \\"failures\":[],\"duration_in_millis\":50,\ + \\"end_time_in_millis\":1750452674461,\"start_time_in_millis\":1750452674411,\ + \\"indices\":[]}}" + case parseEither parseJSON =<< eitherDecode body :: Either String CreateSnapshotResponse of + Right completed@(CreateSnapshotCompleted _) -> completed `seq` return () + other -> + expectationFailure ("expected CreateSnapshotCompleted, got " <> show other) + + it "rejects an object with neither acknowledged nor snapshot" $ do + let body = "{\"foo\":1}" + case parseEither parseJSON =<< eitherDecode body :: Either String CreateSnapshotResponse of + Right other -> expectationFailure ("expected parse failure, got " <> show other) + Left _ -> return () + + describe "SnapshotSelectionOptions params" $ do + it "defaultSnapshotSelectionOptions renders no query string" $ + snapshotSelectionOptionsParams defaultSnapshotSelectionOptions `shouldBe` [] + + it "renders every field when set" $ do + let opts = + defaultSnapshotSelectionOptions + { ssoMasterTimeout = Just (TimeUnitSeconds, 30), + ssoVerbose = Just True, + ssoIndexDetails = Just False, + ssoIncludeRepository = Just True, + ssoSort = Just SortSnapshotByDuration, + ssoOrder = Just SortOrderDesc, + ssoSize = Just 10, + ssoOffset = Just 0, + ssoAfter = Just "snap-1", + ssoFromSortValue = Just "2020-01-01T00:00:00Z", + ssoIgnoreUnavailableSnapshots = Just True, + ssoIndexNames = Just False, + ssoSlmPolicyFilter = Just "policy-1" + } + L.sortOn fst (snapshotSelectionOptionsParams opts) + `shouldBe` L.sortOn + fst + [ ("master_timeout", Just "30s"), + ("verbose", Just "true"), + ("index_details", Just "false"), + ("include_repository", Just "true"), + ("sort", Just "duration"), + ("order", Just "desc"), + ("size", Just "10"), + ("offset", Just "0"), + ("after", Just "snap-1"), + ("from_sort_value", Just "2020-01-01T00:00:00Z"), + ("ignore_unavailable", Just "true"), + ("index_names", Just "false"), + ("slm_policy_filter", Just "policy-1") + ] + + it "renders each SnapshotSortField wire token" $ + map renderSnapshotSortField [SortSnapshotByStartTime, SortSnapshotByDuration, SortSnapshotByName, SortSnapshotByRepository, SortSnapshotByIndices] + `shouldBe` ["start_time", "duration", "name", "repository", "indices"] + + it "renders each SnapshotSortOrder wire token" $ + map renderSnapshotSortOrder [SortOrderAsc, SortOrderDesc] + `shouldBe` ["asc", "desc"] + + it "omits every new field by default" $ + snapshotSelectionOptionsParams defaultSnapshotSelectionOptions `shouldBe` [] + + describe "SnapshotMasterTimeoutOptions params" $ do + it "defaultSnapshotMasterTimeoutOptions renders no query string" $ + snapshotMasterTimeoutOptionsParams defaultSnapshotMasterTimeoutOptions `shouldBe` [] + + it "renders master_timeout when set" $ do + let opts = defaultSnapshotMasterTimeoutOptions {smtoMasterTimeout = Just (TimeUnitSeconds, 30)} + snapshotMasterTimeoutOptionsParams opts `shouldBe` [("master_timeout", Just "30s")] + + it "renders master_timeout with each TimeUnits suffix" $ do + let mk u = defaultSnapshotMasterTimeoutOptions {smtoMasterTimeout = Just (u, 5)} + map snapshotMasterTimeoutOptionsParams (map mk [TimeUnitDays, TimeUnitHours, TimeUnitMinutes, TimeUnitSeconds, TimeUnitMilliseconds]) + `shouldBe` [ [("master_timeout", Just "5d")], + [("master_timeout", Just "5h")], + [("master_timeout", Just "5m")], + [("master_timeout", Just "5s")], + [("master_timeout", Just "5ms")] + ] + + -- ------------------------------------------------------------------ -- + -- Endpoint shape: pure checks against the BHRequest value; no live -- + -- backend needed. Mirrors the putILMPolicy / updateClusterSettings -- + -- shape tests. -- + -- ------------------------------------------------------------------ -- + describe "createSnapshot endpoint shape" $ do + let repo = SnapshotRepoName "repo-1" + snap = SnapshotName "snap-1" + + it "POSTs /_snapshot/{repo}/{snap} with only wait_for_completion by default" $ do + let req = createSnapshot repo snap defaultSnapshotCreateSettings + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "repo-1", "snap-1"] + L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` L.sortOn fst [("wait_for_completion", Just "false")] + + it "omits master_timeout when snapMasterTimeout is Nothing" $ + ( lookup "master_timeout" . getRawEndpointQueries . bhRequestEndpoint $ + createSnapshot repo snap defaultSnapshotCreateSettings + ) + `shouldBe` Nothing + + it "forwards master_timeout when snapMasterTimeout is set" $ do + let settings = defaultSnapshotCreateSettings {snapMasterTimeout = Just (TimeUnitMilliseconds, 500)} + req = createSnapshot repo snap settings + lookup "master_timeout" (getRawEndpointQueries (bhRequestEndpoint req)) `shouldBe` Just (Just "500ms") + + it "omits metadata and feature_states from the body when Nothing" $ do + let req = createSnapshot repo snap defaultSnapshotCreateSettings + case decode =<< bhRequestBody req :: Maybe Object of + Just o -> do + X.lookup "metadata" o `shouldBe` Nothing + X.lookup "feature_states" o `shouldBe` Nothing + Nothing -> expectationFailure "expected a JSON object body" + + it "includes metadata and feature_states in the body when set" $ do + let settings = + defaultSnapshotCreateSettings + { snapMetadata = Just (X.singleton "created_by" (String "backup-job")), + snapFeatureStates = Just ("data_streams" :| ["templates"]) + } + req = createSnapshot repo snap settings + case decode =<< bhRequestBody req :: Maybe Object of + Just o -> do + X.lookup "metadata" o `shouldBe` Just (object ["created_by" .= ("backup-job" :: Text)]) + X.lookup "feature_states" o `shouldBe` Just (toJSON (["data_streams", "templates"] :: [Text])) + Nothing -> expectationFailure "expected a JSON object body" + + it "serializes snapIncludeGlobalState under include_global_state (regression: was ignore_global_state)" $ do + let reqOn = createSnapshot repo snap defaultSnapshotCreateSettings {snapIncludeGlobalState = True} + reqOff = createSnapshot repo snap defaultSnapshotCreateSettings {snapIncludeGlobalState = False} + case decode =<< bhRequestBody reqOn :: Maybe Object of + Just o -> do + X.lookup "include_global_state" o `shouldBe` Just (Bool True) + X.lookup "ignore_global_state" o `shouldBe` Nothing + Nothing -> expectationFailure "expected a JSON object body for snapIncludeGlobalState=True" + case decode =<< bhRequestBody reqOff :: Maybe Object of + Just o -> do + X.lookup "include_global_state" o `shouldBe` Just (Bool False) + X.lookup "ignore_global_state" o `shouldBe` Nothing + Nothing -> expectationFailure "expected a JSON object body for snapIncludeGlobalState=False" + + describe "restoreSnapshot endpoint shape" $ do + let repo = SnapshotRepoName "repo-1" + snap = SnapshotName "snap-1" + + it "forwards master_timeout via snapRestoreMasterTimeout" $ do + let settings = defaultSnapshotRestoreSettings {snapRestoreMasterTimeout = Just (TimeUnitSeconds, 30)} + req = restoreSnapshot repo snap settings + lookup "master_timeout" (getRawEndpointQueries (bhRequestEndpoint req)) `shouldBe` Just (Just "30s") + + it "omits master_timeout by default" $ + ( lookup "master_timeout" . getRawEndpointQueries . bhRequestEndpoint $ + restoreSnapshot repo snap defaultSnapshotRestoreSettings + ) + `shouldBe` Nothing + + describe "updateSnapshotRepo endpoint shape" $ do + it "forwards master_timeout and verify=false" $ do + let settings = + defaultSnapshotRepoUpdateSettings + { repoUpdateVerify = False, + repoUpdateMasterTimeout = Just (TimeUnitSeconds, 30) + } + repo = FsSnapshotRepo (SnapshotRepoName "r") "/tmp/r" True Nothing Nothing Nothing + req = updateSnapshotRepo settings repo + L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [("master_timeout", Just "30s"), ("verify", Just "false")] + + it "emits only master_timeout when verify=True (default)" $ do + let settings = defaultSnapshotRepoUpdateSettings {repoUpdateMasterTimeout = Just (TimeUnitMinutes, 1)} + repo = FsSnapshotRepo (SnapshotRepoName "r") "/tmp/r" True Nothing Nothing Nothing + req = updateSnapshotRepo settings repo + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("master_timeout", Just "1m")] + + it "forwards timeout alongside master_timeout and verify=false" $ do + let settings = + defaultSnapshotRepoUpdateSettings + { repoUpdateVerify = False, + repoUpdateMasterTimeout = Just (TimeUnitSeconds, 30), + repoUpdateTimeout = Just (TimeUnitMinutes, 1) + } + repo = FsSnapshotRepo (SnapshotRepoName "r") "/tmp/r" True Nothing Nothing Nothing + req = updateSnapshotRepo settings repo + L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [ ("master_timeout", Just "30s"), + ("timeout", Just "1m"), + ("verify", Just "false") + ] + + it "omits timeout by default" $ + ( lookup "timeout" . getRawEndpointQueries . bhRequestEndpoint $ + updateSnapshotRepo + defaultSnapshotRepoUpdateSettings + (FsSnapshotRepo (SnapshotRepoName "r") "/tmp/r" True Nothing Nothing Nothing) + ) + `shouldBe` Nothing + + describe "snapshot *With endpoint shapes" $ do + it "getSnapshotReposWith attaches master_timeout and local" $ do + let opts = + defaultSnapshotRepoGetOptions + { srgoLocal = Just True, + srgoMasterTimeout = Just (TimeUnitSeconds, 30) + } + req = getSnapshotReposWith AllSnapshotRepos opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "_all"] + L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [("local", Just "true"), ("master_timeout", Just "30s")] + + it "omits local by default in getSnapshotReposWith" $ + ( lookup "local" . getRawEndpointQueries . bhRequestEndpoint $ + getSnapshotReposWith AllSnapshotRepos defaultSnapshotRepoGetOptions + ) + `shouldBe` Nothing + + it "getSnapshotReposWith default mirrors getSnapshotRepos" $ do + let viaPlain = getSnapshotRepos AllSnapshotRepos + viaWith = getSnapshotReposWith AllSnapshotRepos defaultSnapshotRepoGetOptions + getRawEndpointQueries (bhRequestEndpoint viaPlain) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint viaWith) + + it "verifySnapshotRepoWith attaches master_timeout and timeout" $ do + let opts = + defaultSnapshotRepoTimeoutOptions + { srtoTimeout = Just (TimeUnitSeconds, 30), + srtoMasterTimeout = Just (TimeUnitMinutes, 1) + } + req = verifySnapshotRepoWith (SnapshotRepoName "r") opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "r", "_verify"] + L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [("master_timeout", Just "1m"), ("timeout", Just "30s")] + + it "verifySnapshotRepoWith default mirrors verifySnapshotRepo" $ do + let viaPlain = verifySnapshotRepo (SnapshotRepoName "r") + viaWith = verifySnapshotRepoWith (SnapshotRepoName "r") defaultSnapshotRepoTimeoutOptions + getRawEndpointQueries (bhRequestEndpoint viaPlain) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint viaWith) + + it "deleteSnapshotRepoWith attaches master_timeout and timeout" $ do + let opts = + defaultSnapshotRepoTimeoutOptions + { srtoTimeout = Just (TimeUnitSeconds, 30), + srtoMasterTimeout = Just (TimeUnitMinutes, 1) + } + req = deleteSnapshotRepoWith (SnapshotRepoName "r") opts + bhRequestMethod req `shouldBe` "DELETE" + L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [("master_timeout", Just "1m"), ("timeout", Just "30s")] + + it "deleteSnapshotRepoWith default mirrors deleteSnapshotRepo" $ do + let viaPlain = deleteSnapshotRepo (SnapshotRepoName "r") + viaWith = deleteSnapshotRepoWith (SnapshotRepoName "r") defaultSnapshotRepoTimeoutOptions + getRawEndpointQueries (bhRequestEndpoint viaPlain) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint viaWith) + + it "deleteSnapshotWith attaches master_timeout" $ do + let opts = defaultSnapshotMasterTimeoutOptions {smtoMasterTimeout = Just (TimeUnitSeconds, 30)} + req = deleteSnapshotWith (SnapshotRepoName "r") (SnapshotName "s") opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "r", "s"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("master_timeout", Just "30s")] + + it "getSnapshotStatusWith attaches master_timeout and ignore_unavailable" $ do + let opts = + defaultSnapshotStatusOptions + { sstoIgnoreUnavailable = Just True, + sstoMasterTimeout = Just (TimeUnitSeconds, 30) + } + req = getSnapshotStatusWith (SnapshotRepoName "r") (SnapshotName "s") opts + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "r", "s", "_status"] + L.sortOn fst (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` [("ignore_unavailable", Just "true"), ("master_timeout", Just "30s")] + + it "getSnapshotStatusWith default mirrors getSnapshotStatus" $ do + let viaPlain = getSnapshotStatus (SnapshotRepoName "r") (SnapshotName "s") + viaWith = + getSnapshotStatusWith + (SnapshotRepoName "r") + (SnapshotName "s") + defaultSnapshotStatusOptions + getRawEndpointQueries (bhRequestEndpoint viaPlain) + `shouldBe` getRawEndpointQueries (bhRequestEndpoint viaWith) + + describe "cleanupSnapshotRepo endpoint shape" $ do + let repo = SnapshotRepoName "repo-1" + + it "POSTs /_snapshot/{repo}/_cleanup with empty body by default" $ do + let req = cleanupSnapshotRepo repo + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "repo-1", "_cleanup"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + bhRequestBody req `shouldBe` Just "" + + it "omits master_timeout by default" $ + ( lookup "master_timeout" . getRawEndpointQueries . bhRequestEndpoint $ + cleanupSnapshotRepo repo + ) + `shouldBe` Nothing + + describe "cleanupSnapshotRepoWith endpoint shape" $ do + let repo = SnapshotRepoName "r" + opts = defaultSnapshotMasterTimeoutOptions {smtoMasterTimeout = Just (TimeUnitSeconds, 30)} + + it "attaches master_timeout when set" $ do + let req = cleanupSnapshotRepoWith repo opts + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "r", "_cleanup"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [("master_timeout", Just "30s")] + + it "default mirrors cleanupSnapshotRepo byte-for-byte" $ do + let viaPlain = cleanupSnapshotRepo repo + viaWith = cleanupSnapshotRepoWith repo defaultSnapshotMasterTimeoutOptions + getRawEndpoint (bhRequestEndpoint viaPlain) `shouldBe` getRawEndpoint (bhRequestEndpoint viaWith) + getRawEndpointQueries (bhRequestEndpoint viaPlain) `shouldBe` getRawEndpointQueries (bhRequestEndpoint viaWith) + bhRequestMethod viaPlain `shouldBe` bhRequestMethod viaWith + bhRequestBody viaPlain `shouldBe` bhRequestBody viaWith + + describe "SnapshotCleanupResult JSON parsing" $ do + let typicalBody = "{\"results\":{\"deleted_bytes\":20,\"deleted_blobs\":5}}" + zeroBody = "{\"results\":{\"deleted_bytes\":0,\"deleted_blobs\":0}}" + + it "parses a typical cleanup response" $ + case parseEither parseJSON =<< eitherDecode typicalBody :: Either String SnapshotCleanupResult of + Right result -> do + snapshotCleanupDeletedBytes result `shouldBe` 20 + snapshotCleanupDeletedBlobs result `shouldBe` 5 + other -> expectationFailure ("expected SnapshotCleanupResult, got " <> show other) + + it "parses a nothing-to-cleanup response (zero counts)" $ + case parseEither parseJSON =<< eitherDecode zeroBody :: Either String SnapshotCleanupResult of + Right result -> do + snapshotCleanupDeletedBytes result `shouldBe` 0 + snapshotCleanupDeletedBlobs result `shouldBe` 0 + other -> expectationFailure ("expected zero SnapshotCleanupResult, got " <> show other) + + it "rejects a payload missing the results wrapper" $ do + let bad = "{\"deleted_bytes\":20,\"deleted_blobs\":5}" + case parseEither parseJSON =<< eitherDecode bad :: Either String SnapshotCleanupResult of + Left _ -> return () + Right v -> expectationFailure ("expected parse failure, got " <> show v) + + describe "cloneSnapshot endpoint shape" $ do + let repo = SnapshotRepoName "repo-1" + src = SnapshotName "snap-1" + target = SnapshotName "clone-1" + + it "PUTs /_snapshot/{repo}/{src}/_clone/{target} with target in path, not body" $ do + let req = cloneSnapshot repo src target defaultSnapshotCloneSettings + bhRequestMethod req `shouldBe` "PUT" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_snapshot", "repo-1", "snap-1", "_clone", "clone-1"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + case decode =<< bhRequestBody req :: Maybe Object of + Just o -> X.lookup "target" o `shouldBe` Nothing + Nothing -> expectationFailure "expected a JSON object body" + + it "omits indices from the body when snapCloneIndices is Nothing" $ do + let req = cloneSnapshot repo src target defaultSnapshotCloneSettings + case decode =<< bhRequestBody req :: Maybe Object of + Just o -> X.lookup "indices" o `shouldBe` Nothing + Nothing -> expectationFailure "expected a JSON object body" + + it "serializes snapCloneIndices as a comma-separated string under indices" $ do + let settings = + defaultSnapshotCloneSettings + { snapCloneIndices = Just (IndexList ([qqIndexName|idx-a|] :| [[qqIndexName|idx-b|]])) + } + req = cloneSnapshot repo src target settings + case decode =<< bhRequestBody req :: Maybe Object of + Just o -> X.lookup "indices" o `shouldBe` Just (String "idx-a,idx-b") + Nothing -> expectationFailure "expected a JSON object body" + + it "renders AllIndexes as \"_all\" under indices" $ do + let settings = defaultSnapshotCloneSettings {snapCloneIndices = Just AllIndexes} + req = cloneSnapshot repo src target settings + case decode =<< bhRequestBody req :: Maybe Object of + Just o -> X.lookup "indices" o `shouldBe` Just (String "_all") + Nothing -> expectationFailure "expected a JSON object body" + + it "omits master_timeout by default" $ + ( lookup "master_timeout" . getRawEndpointQueries . bhRequestEndpoint $ + cloneSnapshot repo src target defaultSnapshotCloneSettings + ) + `shouldBe` Nothing + + it "forwards master_timeout when snapCloneMasterTimeout is set" $ do + let settings = defaultSnapshotCloneSettings {snapCloneMasterTimeout = Just (TimeUnitSeconds, 30)} + req = cloneSnapshot repo src target settings + lookup "master_timeout" (getRawEndpointQueries (bhRequestEndpoint req)) `shouldBe` Just (Just "30s") + describe "Snapshot repos" $ do it "always parses all snapshot repos API" $ when' canSnapshot $ @@ -92,6 +659,52 @@ [] -> expectationFailure "There were no snapshots" snaps -> expectationFailure ("Expected 1 snapshot but got" <> show (length snaps)) + it "getSnapshotsWith default options mirrors getSnapshots and exposes version metadata" $ + when' canSnapshot $ + withTestEnv $ do + let r1n = SnapshotRepoName "bloodhound-repo1" + withSnapshotRepo r1n $ \_ -> do + let s1n = SnapshotName "example-snapshot" + withSnapshot r1n s1n $ do + let sel = SnapshotList (ExactSnap s1n :| []) + viaPlain <- performBHRequest $ getSnapshots r1n sel + viaWith <- performBHRequest $ getSnapshotsWith r1n sel defaultSnapshotSelectionOptions + liftIO $ do + -- Same snapshot name set, proving the default-options + -- wire call is observationally equivalent. + map snapInfoName viaWith `shouldBe` map snapInfoName viaPlain + case viaWith of + [snap] + | snapInfoState snap == SnapshotSuccess -> do + -- version_id/version are emitted by every + -- snapshot-capable server we test against; we + -- assert presence rather than an exact value + -- so the test does not bit-rot across engine + -- versions. + case snapInfoVersionId snap of + Just _ -> return () + Nothing -> expectationFailure "expected version_id in modern snapshot response" + | otherwise -> expectationFailure ("snapshot not SUCCESS: " <> show snap) + other -> expectationFailure ("expected singleton via getSnapshotsWith, got " <> show other) + + it "can fetch shard-level status of a completed snapshot" $ + when' canSnapshot $ + withTestEnv $ do + let r1n = SnapshotRepoName "bloodhound-repo1" + withSnapshotRepo r1n $ \_ -> do + let s1n = SnapshotName "example-snapshot" + withSnapshot r1n s1n $ do + res <- performBHRequest $ getSnapshotStatus r1n s1n + liftIO $ case res of + [status] + | snapshotStatusSnapshot status == s1n + && snapshotStatusRepository status == r1n + && snapshotStatusState status == SnapshotSuccess -> + return () + | otherwise -> expectationFailure (show status) + [] -> expectationFailure "There were no snapshot statuses" + statuses -> expectationFailure ("Expected 1 status but got" <> show (length statuses)) + describe "Snapshot restore" $ do it "can restore a snapshot that we create" $ when' canSnapshot $ @@ -195,7 +808,16 @@ where alloc = do resp <- performBHRequest $ createSnapshot srn sn createSettings - liftIO $ resp `shouldBe` Acknowledged True + liftIO $ + case resp of + -- snapWaitForCompletion=True, so the server returns a full + -- snapshot object, not the {"acknowledged": true} envelope. + CreateSnapshotCompleted (SnapshotResponse info) + | snapInfoState info == SnapshotSuccess -> pure () + _ -> + expectationFailure $ + "expected CreateSnapshotCompleted with a successful snapshot, got: " + <> show resp -- We'll make this synchronous for testing purposes createSettings = defaultSnapshotCreateSettings diff --git a/tests/Test/SortingSpec.hs b/tests/Test/SortingSpec.hs --- a/tests/Test/SortingSpec.hs +++ b/tests/Test/SortingSpec.hs @@ -30,7 +30,23 @@ source = Nothing, docvalueFields = Nothing, suggestBody = Nothing, - pointInTime = Nothing + pointInTime = Nothing, + knnBody = Nothing, + osKnnBody = Nothing, + trackTotalHits = Nothing, + timeout = Nothing, + minScore = Nothing, + explain = Nothing, + searchVersion = Nothing, + seqNoPrimaryTerm = Nothing, + terminateAfter = Nothing, + stats = Nothing, + searchPipeline = Nothing, + storedFields = Nothing, + runtimeMappings = Nothing, + rescore = Nothing, + collapse = Nothing, + retriever = Nothing } result <- searchTweets search let myTweet = result >>= grabFirst diff --git a/tests/Test/SourceFilteringSpec.hs b/tests/Test/SourceFilteringSpec.hs --- a/tests/Test/SourceFilteringSpec.hs +++ b/tests/Test/SourceFilteringSpec.hs @@ -2,7 +2,7 @@ module Test.SourceFilteringSpec (spec) where -import qualified Data.Aeson.KeyMap as X +import Data.Aeson.KeyMap qualified as X import TestsUtils.Common import TestsUtils.Import diff --git a/tests/Test/StreamsSpec.hs b/tests/Test/StreamsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/StreamsSpec.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.StreamsSpec (spec) where + +import Data.Aeson +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.ElasticSearch9.Requests qualified as RequestsES9 +import Database.Bloodhound.ElasticSearch9.Types qualified as Types +import TestsUtils.Import + +spec :: Spec +spec = describe "Streams API (/_streams/*)" $ do + describe "StreamName JSON" $ do + it "round-trips a StreamName" $ do + let n = Types.StreamName "logs.otel" + decode (encode n) `shouldBe` Just n + + it "unStreamName extracts the underlying Text" $ + Types.unStreamName (Types.StreamName "logs") + `shouldBe` ("logs" :: Text) + + describe "StreamStatus JSON" $ do + it "encodes as {enabled: bool}" $ do + encode (Types.StreamStatus True) + `shouldBe` "{\"enabled\":true}" + encode (Types.StreamStatus False) + `shouldBe` "{\"enabled\":false}" + + it "decodes {enabled: true}" $ + decode (LBS.pack "{\"enabled\":true}") + `shouldBe` Just (Types.StreamStatus True) + + describe "StreamsStatusResponse JSON" $ do + it "decodes a map of named streams (keys contain dots)" $ do + let raw = + LBS.pack + "{\"logs\":{\"enabled\":true},\"logs.otel\":{\"enabled\":false},\"logs.ecs\":{\"enabled\":true}}" + case decode raw :: Maybe Types.StreamsStatusResponse of + Just resp -> do + Types.streamStatusFor "logs" resp + `shouldBe` Just (Types.StreamStatus True) + Types.streamStatusFor "logs.otel" resp + `shouldBe` Just (Types.StreamStatus False) + Types.streamStatusFor "logs.ecs" resp + `shouldBe` Just (Types.StreamStatus True) + Types.streamStatusFor "missing" resp + `shouldBe` (Nothing :: Maybe Types.StreamStatus) + Nothing -> + expectationFailure "failed to decode StreamsStatusResponse" + + it "decodes an empty object to an empty map" $ + case decode (LBS.pack "{}") :: Maybe Types.StreamsStatusResponse of + Just resp -> + Types.streamStatusFor "anything" resp + `shouldBe` (Nothing :: Maybe Types.StreamStatus) + Nothing -> + expectationFailure "failed to decode empty StreamsStatusResponse" + + it "round-trips a populated response" $ do + let raw = + LBS.pack + "{\"logs\":{\"enabled\":true},\"logs.ecs\":{\"enabled\":false}}" + case decode raw :: Maybe Types.StreamsStatusResponse of + Just resp -> decode (encode resp) `shouldBe` Just resp + Nothing -> expectationFailure "failed to decode StreamsStatusResponse" + + describe "streamsActionOptionsParams URI rendering" $ do + it "defaultStreamsActionOptions emits no params" $ + Types.streamsActionOptionsParams Types.defaultStreamsActionOptions + `shouldBe` [] + + it "renders master_timeout and timeout" $ do + let opts = + Types.defaultStreamsActionOptions + { Types.saoMasterTimeout = Just "30s", + Types.saoTimeout = Just "1m" + } + Types.streamsActionOptionsParams opts + `shouldBe` [("master_timeout", Just "30s"), ("timeout", Just "1m")] + + it "renders only the set field" $ do + let opts = + Types.defaultStreamsActionOptions + { Types.saoTimeout = Just "1m" + } + Types.streamsActionOptionsParams opts + `shouldBe` [("timeout", Just "1m")] + + describe "getStreamsStatusOptionsParams URI rendering" $ do + it "defaultGetStreamsStatusOptions emits no params" $ + Types.getStreamsStatusOptionsParams Types.defaultGetStreamsStatusOptions + `shouldBe` [] + + it "renders master_timeout" $ do + let opts = + Types.defaultGetStreamsStatusOptions + { Types.gssoMasterTimeout = Just (TimeUnitSeconds, 30) + } + Types.getStreamsStatusOptionsParams opts + `shouldBe` [("master_timeout", Just "30s")] + + it "renders a minute duration with the m suffix" $ do + let opts = + Types.defaultGetStreamsStatusOptions + { Types.gssoMasterTimeout = Just (TimeUnitMinutes, 1) + } + Types.getStreamsStatusOptionsParams opts + `shouldBe` [("master_timeout", Just "1m")] + + describe "endpoint shape" $ do + it "GETs /_streams/status with no body" $ do + let req = RequestsES9.getStreamsStatus + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_streams", "status"] + bhRequestBody req `shouldSatisfy` isNothing + + it "getStreamsStatusWith appends master_timeout query param" $ do + let opts = + Types.defaultGetStreamsStatusOptions + { Types.gssoMasterTimeout = Just (TimeUnitSeconds, 30) + } + req = RequestsES9.getStreamsStatusWith opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_streams", "status"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("master_timeout", Just "30s")] + + it "POSTs /_streams//_enable with an empty body" $ do + let req = RequestsES9.enableStream "logs" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_streams", "logs", "_enable"] + bhRequestBody req `shouldSatisfy` isJust + + it "enableStreamWith appends timeout query params" $ do + let opts = + Types.defaultStreamsActionOptions + { Types.saoMasterTimeout = Just "10s" + } + req = RequestsES9.enableStreamWith "logs.otel" opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_streams", "logs.otel", "_enable"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("master_timeout", Just "10s")] + + it "POSTs /_streams//_disable with an empty body" $ do + let req = RequestsES9.disableStream "logs.ecs" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_streams", "logs.ecs", "_disable"] + bhRequestBody req `shouldSatisfy` isJust + + it "disableStreamWith appends timeout query params" $ do + let opts = + Types.defaultStreamsActionOptions + { Types.saoTimeout = Just "5s" + } + req = RequestsES9.disableStreamWith "logs" opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_streams", "logs", "_disable"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("timeout", Just "5s")] diff --git a/tests/Test/SuggestSpec.hs b/tests/Test/SuggestSpec.hs --- a/tests/Test/SuggestSpec.hs +++ b/tests/Test/SuggestSpec.hs @@ -2,11 +2,15 @@ module Test.SuggestSpec (spec) where +import Data.Aeson (decode, encode) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Map.Strict qualified as Map import TestsUtils.Common import TestsUtils.Import spec :: Spec -spec = +spec = do describe "Suggest" $ it "returns a search suggestion using the phrase suggester" $ withTestEnv $ do @@ -19,3 +23,149 @@ expectedText = Just "use haskell" sr <- performBHRequest $ searchByIndex @Tweet testIndex search liftIO $ (suggestOptionsText . head . suggestResponseOptions . head . nsrResponses <$> suggest sr) `shouldBe` expectedText + + -- ---------------------------------------------------------------------- + -- Unit tests for the term / completion / context suggester additions + -- (bloodhound-04f.10). These pin the wire shape of each new + -- 'SuggestType' constructor and verify the documented round-trip + -- behaviour, including the 'SuggestTypeCustom' escape hatch and the + -- intent-only nature of 'SuggestTypeContextSuggester'. + describe "SuggestType term/completion/context wire shape" $ do + it "renders a term suggester under the \"term\" tag" $ do + let body = encode (SuggestTypeTermSuggester (mkTermSuggester (FieldName "message"))) + -- @suggest_mode@ is non-'Maybe' (defaults to @missing@) so it is + -- always emitted, mirroring 'DirectGenerators' on encode. + body `shouldBe` "{\"term\":{\"field\":\"message\",\"suggest_mode\":\"missing\"}}" + + it "renders a completion suggester under the \"completion\" tag" $ do + let body = encode (SuggestTypeCompletionSuggester (mkCompletionSuggester (FieldName "suggest"))) + body `shouldBe` "{\"completion\":{\"field\":\"suggest\"}}" + + it "renders a context suggester under the \"completion\" tag (wire-identical to completion)" $ do + -- The context suggester is not a separate wire endpoint: it + -- serialises as @completion@ so the server accepts the request. + -- The constructor exists only to signal caller intent. + let cs = mkContextSuggester (mkCompletionSuggester (FieldName "suggest")) + encode (SuggestTypeContextSuggester cs) + `shouldBe` "{\"completion\":{\"field\":\"suggest\"}}" + + it "renders the custom escape hatch under its caller-supplied tag" $ do + let payload = object ["prefix" .= String "ni"] + encode (SuggestTypeCustom "mySuggester" payload) + `shouldBe` "{\"mySuggester\":{\"prefix\":\"ni\"}}" + + it "wraps a typed suggester in a named Suggest envelope" $ do + let named = Suggest "tring" "my-suggest" (SuggestTypeTermSuggester (mkTermSuggester (FieldName "message"))) + encode named + `shouldBe` "{\"my-suggest\":{\"term\":{\"field\":\"message\",\"suggest_mode\":\"missing\"}},\"text\":\"tring\"}" + + describe "SuggestType term/completion/context decoding" $ do + it "decodes a {\"term\": ...} body as SuggestTypeTermSuggester" $ do + let Just (st :: SuggestType) = decode "{\"term\":{\"field\":\"message\"}}" + case st of + SuggestTypeTermSuggester ts -> + unFieldName (termSuggesterField ts) `shouldBe` "message" + other -> + expectationFailure $ "expected SuggestTypeTermSuggester, got " <> show other + + it "decodes a {\"completion\": ...} body as SuggestTypeCompletionSuggester" $ do + let Just (st :: SuggestType) = decode "{\"completion\":{\"field\":\"suggest\"}}" + case st of + SuggestTypeCompletionSuggester cs -> + unFieldName (completionSuggesterField cs) `shouldBe` "suggest" + other -> + expectationFailure $ "expected SuggestTypeCompletionSuggester, got " <> show other + + it "decodes an unknown tag as SuggestTypeCustom (lossless round-trip)" $ do + let raw = "{\"futureSuggester\":{\"foo\":1}}" :: LBS.ByteString + Just (st :: SuggestType) = decode raw + case st of + SuggestTypeCustom tag payload -> do + tag `shouldBe` "futureSuggester" + -- The Value payload is preserved verbatim, so encode . decode + -- is the identity for unknown tags. + encode st `shouldBe` raw + other -> + expectationFailure $ "expected SuggestTypeCustom, got " <> show other + + it "treats a context suggester's wire form as a completion suggester on decode" $ do + -- Encoding then decoding a 'SuggestTypeContextSuggester' yields a + -- 'SuggestTypeCompletionSuggester': this is by design (the two + -- are wire-identical; see 'SuggestType' docs) and is why the + -- 'Arbitrary SuggestType' generator omits the context variant. + let cs = mkContextSuggester (mkCompletionSuggester (FieldName "suggest")) + encoded = encode (SuggestTypeContextSuggester cs) + Just (decoded :: SuggestType) = decode encoded + case decoded of + SuggestTypeCompletionSuggester _ -> pure () + other -> + expectationFailure $ + "expected the context suggester to decode as completion, got " + <> show other + + it "rejects a multi-key or non-object body" $ do + decode "{\"term\":{\"field\":\"x\"},\"phrase\":{}}" `shouldBe` (Nothing :: Maybe SuggestType) + decode "[1,2,3]" `shouldBe` (Nothing :: Maybe SuggestType) + + describe "TermSuggester tuning knobs" $ do + it "serialises sort and string_distance as their documented string forms" $ do + let ts = + (mkTermSuggester (FieldName "message")) + { termSuggesterSort = Just TermSuggesterSortFrequency, + termSuggesterStringDistance = Just TermSuggesterStringDistanceJaroWinkler + } + let Just (decodedTs :: TermSuggester) = decode (encode ts) + termSuggesterSort decodedTs `shouldBe` Just TermSuggesterSortFrequency + termSuggesterStringDistance decodedTs `shouldBe` Just TermSuggesterStringDistanceJaroWinkler + + it "defaults suggest_mode to missing when omitted on decode" $ do + let Just (decodedTs :: TermSuggester) = decode "{\"field\":\"message\"}" + termSuggesterSuggestMode decodedTs `shouldBe` DirectGeneratorSuggestModeMissing + + describe "CompletionSuggester contexts" $ do + it "serialises a non-empty contexts map under \"contexts\"" $ do + let cs = + (mkCompletionSuggester (FieldName "suggest")) + { completionSuggesterContexts = + Just $ + Map.fromList + [ ("color", ContextQueryValueText "red" :| []), + ("place", ContextQueryValueBoosted "nyc" 2 :| []) + ] + } + let Just (decodedCs :: CompletionSuggester) = decode (encode cs) + completionSuggesterContexts decodedCs + `shouldBe` Just + ( Map.fromList + [ ("color", ContextQueryValueText "red" :| []), + ("place", ContextQueryValueBoosted "nyc" 2 :| []) + ] + ) + + it "renders Just Map.empty as \"contexts\": {} and round-trips back to Just Map.empty" $ do + -- @Nothing@ and @Just mempty@ must be distinguishable on the wire + -- (otherwise the Arbitrary-driven round-trip in JSONSpec would + -- fail); @Just mempty@ therefore renders as an empty object. + let cs = (mkCompletionSuggester (FieldName "suggest")) {completionSuggesterContexts = Just Map.empty} + encode cs `shouldBe` "{\"contexts\":{},\"field\":\"suggest\"}" + let Just (decodedCs :: CompletionSuggester) = decode (encode cs) + completionSuggesterContexts decodedCs `shouldBe` Just Map.empty + + it "omits the contexts field entirely when it is Nothing" $ do + let cs = mkCompletionSuggester (FieldName "suggest") + encode cs `shouldBe` "{\"field\":\"suggest\"}" + let Just (decodedCs :: CompletionSuggester) = decode (encode cs) + completionSuggesterContexts decodedCs `shouldBe` Nothing + + describe "SuggestType round-trip" $ do + -- The QuickCheck @propJSON (Proxy :: Proxy Suggest)@ property in + -- JSONSpec covers the generated variants; these cases pin + -- specific interesting shapes that are unlikely to be hit by the + -- generator. + it "round-trips a minimal term suggester" $ do + let st = SuggestTypeTermSuggester (mkTermSuggester (FieldName "message")) + (decode . encode) st `shouldBe` Just st + + it "round-trips a minimal completion suggester" $ do + let st = SuggestTypeCompletionSuggester (mkCompletionSuggester (FieldName "suggest")) + (decode . encode) st `shouldBe` Just st diff --git a/tests/Test/SyncedFlushSpec.hs b/tests/Test/SyncedFlushSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SyncedFlushSpec.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-warnings-deprecations #-} + +module Test.SyncedFlushSpec (spec) where + +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy qualified as LBS +import Data.List (sort) +import Database.Bloodhound.ElasticSearch7.Requests qualified as Requests +import Database.Bloodhound.ElasticSearch7.Types qualified as ES7Types +import Optics (set, view) +import TestsUtils.Common +import TestsUtils.Import + +-- | Stable ordering for equality. +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + +-- | Documented success response: every shard sync-flushed cleanly, no +-- per-index @failures@ array. +sampleSuccessBytes :: LBS.ByteString +sampleSuccessBytes = + "{\"_shards\":{\"total\":2,\"successful\":2,\"failed\":0},\ + \\"my-index-000001\":{\"total\":2,\"successful\":2,\"failed\":0}}" + +-- | Documented partial-failure response: one shard group failed with a +-- per-shard @failures@ entry carrying a nested @routing@ object. +sampleFailureBytes :: LBS.ByteString +sampleFailureBytes = + "{\"_shards\":{\"total\":4,\"successful\":1,\"failed\":1},\ + \\"my-index-000001\":{\"total\":4,\"successful\":3,\"failed\":1,\ + \\"failures\":[{\"shard\":1,\"reason\":\"unexpected error\",\ + \\"routing\":{\"state\":\"STARTED\",\"primary\":false,\ + \\"node\":\"SZNr2J_ORxKTLUCydGX4zA\",\"relocating_node\":null,\ + \\"shard\":1,\"index\":\"my-index-000001\"}}]}}" + +spec :: Spec +spec = do + -- ------------------------------------------------------------------ -- + -- Pure JSON decoder tests (no ES required). -- + -- ------------------------------------------------------------------ -- + describe "SyncedFlushResult JSON parsing" $ do + it "peels _shards and collects the per-index shard groups" $ do + let Just (r :: ES7Types.SyncedFlushResult) = decode sampleSuccessBytes + shards = ES7Types.sfrShards r + shardTotal shards `shouldBe` 2 + shardsSuccessful shards `shouldBe` 2 + case KM.lookup "my-index-000001" (ES7Types.sfrIndices r) of + Just grp -> do + ES7Types.sfsgTotal grp `shouldBe` 2 + ES7Types.sfsgSuccessful grp `shouldBe` 2 + ES7Types.sfsgFailed grp `shouldBe` 0 + ES7Types.sfsgFailures grp `shouldBe` [] + Nothing -> expectationFailure "expected my-index-000001 entry" + + it "parses a per-index failures array with nested routing" $ do + let Just (r :: ES7Types.SyncedFlushResult) = decode sampleFailureBytes + shards = ES7Types.sfrShards r + shardsFailed shards `shouldBe` 1 + case KM.lookup "my-index-000001" (ES7Types.sfrIndices r) of + Just grp -> do + ES7Types.sfsgFailed grp `shouldBe` 1 + case ES7Types.sfsgFailures grp of + [fail_] -> do + ES7Types.sffShard fail_ `shouldBe` 1 + ES7Types.sffReason fail_ `shouldBe` "unexpected error" + ES7Types.sffRouting fail_ `shouldNotBe` Nothing + _ -> expectationFailure "expected exactly one failure" + Nothing -> expectationFailure "expected my-index-000001 entry" + + it "round-trips the success response via ToJSON/FromJSON" $ do + let Just (original :: ES7Types.SyncedFlushResult) = decode sampleSuccessBytes + reDecoded = decode (encode original) :: Maybe ES7Types.SyncedFlushResult + Just original `shouldBe` reDecoded + + it "round-trips the failure response via ToJSON/FromJSON" $ do + let Just (original :: ES7Types.SyncedFlushResult) = decode sampleFailureBytes + reDecoded = decode (encode original) :: Maybe ES7Types.SyncedFlushResult + Just original `shouldBe` reDecoded + + it "tolerates a response with only _shards (empty index map)" $ do + let Just (r :: ES7Types.SyncedFlushResult) = + decode "{\"_shards\":{\"total\":0,\"successful\":0,\"failed\":0}}" + ES7Types.sfrIndices r `shouldBe` mempty + + it "tolerates a per-index group missing the failures array" $ do + let Just (r :: ES7Types.SyncedFlushResult) = + decode + "{\"_shards\":{\"total\":1,\"successful\":1,\"failed\":0},\ + \\"idx\":{\"total\":1,\"successful\":1,\"failed\":0}}" + case KM.lookup "idx" (ES7Types.sfrIndices r) of + Just grp -> ES7Types.sfsgFailures grp `shouldBe` [] + Nothing -> expectationFailure "expected idx entry" + + describe "SyncedFlushFailure JSON parsing" $ do + it "parses a minimal failure with only shard and reason" $ do + let Just (f :: ES7Types.SyncedFlushFailure) = + decode "{\"shard\":3,\"reason\":\"[2] ongoing operations on primary\"}" + ES7Types.sffShard f `shouldBe` 3 + ES7Types.sffReason f `shouldBe` "[2] ongoing operations on primary" + ES7Types.sffRouting f `shouldBe` Nothing + + it "round-trips via ToJSON/FromJSON" $ do + let Just (original :: ES7Types.SyncedFlushFailure) = + decode "{\"shard\":1,\"reason\":\"x\"}" + reDecoded = decode (encode original) :: Maybe ES7Types.SyncedFlushFailure + Just original `shouldBe` reDecoded + + -- ------------------------------------------------------------------ -- + -- Optics. -- + -- ------------------------------------------------------------------ -- + describe "SyncedFlush lenses" $ do + it "sfoIgnoreUnavailableLens is a lawful get/set" $ do + let opts = set ES7Types.sfoIgnoreUnavailableLens (Just True) ES7Types.defaultSyncedFlushOptions + view ES7Types.sfoIgnoreUnavailableLens opts `shouldBe` Just True + + it "sffShardLens is a lawful get/set" $ do + let f = ES7Types.SyncedFlushFailure {ES7Types.sffShard = 0, ES7Types.sffReason = "", ES7Types.sffRouting = Nothing} + f' = set ES7Types.sffShardLens 7 f + view ES7Types.sffShardLens f' `shouldBe` (7 :: Int) + + it "sfsgFailedLens is a lawful get/set" $ do + let g = ES7Types.SyncedFlushShardGroup {ES7Types.sfsgTotal = 0, ES7Types.sfsgSuccessful = 0, ES7Types.sfsgFailed = 0, ES7Types.sfsgFailures = []} + g' = set ES7Types.sfsgFailedLens 2 g + view ES7Types.sfsgFailedLens g' `shouldBe` (2 :: Int) + + -- ------------------------------------------------------------------ -- + -- Options rendering. -- + -- ------------------------------------------------------------------ -- + describe "SyncedFlushOptions URI param rendering" $ do + it "defaultSyncedFlushOptions emits no query string" $ + ES7Types.syncedFlushOptionsParams ES7Types.defaultSyncedFlushOptions + `shouldBe` [] + + it "renders the optional params when set" $ do + let opts = + ES7Types.defaultSyncedFlushOptions + { ES7Types.sfoIgnoreUnavailable = Just True, + ES7Types.sfoAllowNoIndices = Just False, + ES7Types.sfoExpandWildcards = Just (ExpandWildcardsOpen :| []) + } + normalize (ES7Types.syncedFlushOptionsParams opts) + `shouldBe` [ ("allow_no_indices", Just "false"), + ("expand_wildcards", Just "open"), + ("ignore_unavailable", Just "true") + ] + + -- ------------------------------------------------------------------ -- + -- Endpoint shape (BHRequest, no ES required). -- + -- ------------------------------------------------------------------ -- + describe "syncedFlushIndex endpoint shape" $ do + let idx = [qqIndexName|my-idx|] + + it "POSTs /{index}/_flush/synced with no query string by default" $ do + let req = Requests.syncedFlushIndex idx + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["my-idx", "_flush", "synced"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [] + + it "sends an empty body" $ do + let req = Requests.syncedFlushIndex idx + bhRequestBody req `shouldBe` Just "" + + it "forwards options via the With variant" $ do + let opts = ES7Types.defaultSyncedFlushOptions {ES7Types.sfoIgnoreUnavailable = Just True} + req = Requests.syncedFlushIndexWith opts idx + lookup "ignore_unavailable" (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` Just (Just "true") diff --git a/tests/Test/SynonymsSpec.hs b/tests/Test/SynonymsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/SynonymsSpec.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.SynonymsSpec (spec) where + +import Data.Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch8.Requests qualified as RequestsES8 +import Database.Bloodhound.ElasticSearch8.Types qualified as Types +import TestsUtils.Common +import TestsUtils.Import + +hasKey :: Key -> LBS.ByteString -> Bool +hasKey k bs = case decode bs of + Just (Object obj) -> k `KM.member` obj + _ -> False + +spec :: Spec +spec = describe "Synonyms API (PUT/GET/DELETE /_synonyms/{synonyms_set_id})" $ do + describe "SynonymsSetId JSON" $ do + it "round-trips a SynonymsSetId" $ do + let sid = Types.SynonymsSetId "my-synonyms-set" + decode (encode sid) `shouldBe` Just sid + + it "unSynonymsSetId extracts the underlying Text" $ + Types.unSynonymsSetId (Types.SynonymsSetId "abc") `shouldBe` ("abc" :: Text) + + describe "SynonymRule JSON wire shape" $ do + it "encodes a rule with an id as {id, synonyms}" $ do + let rule = Types.SynonymRule (Just "test-1") "hello, hi" + encode rule + `shouldBe` "{\"id\":\"test-1\",\"synonyms\":\"hello, hi\"}" + decode (encode rule) `shouldBe` Just rule + + it "omits id when Nothing (server mints one)" $ do + let rule = Types.SynonymRule Nothing "bye, goodbye" + hasKey "id" (encode rule) `shouldBe` False + encode rule `shouldBe` "{\"synonyms\":\"bye, goodbye\"}" + decode (encode rule) `shouldBe` Just rule + + it "decodes a rule that omits id" $ do + let raw = LBS.pack "{\"synonyms\":\"universe, cosmos\"}" + decode raw `shouldBe` Just (Types.SynonymRule Nothing "universe, cosmos") + + it "decodes a full GET-style rule with id" $ do + let raw = LBS.pack "{\"id\":\"test-2\",\"synonyms\":\"test => check\"}" + decode raw `shouldBe` Just (Types.SynonymRule (Just "test-2") "test => check") + + describe "SynonymsSet (PUT body) JSON" $ do + it "encodes as {synonyms_set: [...]}" $ do + let body = + Types.SynonymsSet + [ Types.SynonymRule (Just "test-1") "hello, hi", + Types.SynonymRule Nothing "bye, goodbye" + ] + encode body + `shouldBe` "{\"synonyms_set\":[{\"id\":\"test-1\",\"synonyms\":\"hello, hi\"},{\"synonyms\":\"bye, goodbye\"}]}" + decode (encode body) `shouldBe` Just body + + it "encodes an empty set as {synonyms_set: []}" $ + encode (Types.SynonymsSet []) + `shouldBe` "{\"synonyms_set\":[]}" + + it "decodes the documented PUT example verbatim" $ do + let raw = + LBS.pack + "{\"synonyms_set\":[{\"id\":\"test-1\",\"synonyms\":\"hello, hi\"},{\"synonyms\":\"bye, goodbye\"},{\"id\":\"test-2\",\"synonyms\":\"test => check\"}]}" + case decode raw :: Maybe Types.SynonymsSet of + Just (Types.SynonymsSet rules) -> length rules `shouldBe` 3 + Nothing -> expectationFailure "failed to decode SynonymsSet" + + describe "SynonymsSetInfo (GET response) JSON" $ do + it "decodes the documented GET response verbatim" $ do + let raw = + LBS.pack + "{\"count\":3,\"synonyms_set\":[{\"id\":\"test-1\",\"synonyms\":\"hello, hi\"},{\"id\":\"test-2\",\"synonyms\":\"bye, goodbye\"},{\"id\":\"test-3\",\"synonyms\":\"test => check\"}]}" + case decode raw :: Maybe Types.SynonymsSetInfo of + Just info -> do + Types.ssiCount info `shouldBe` 3 + length (Types.ssiRules info) `shouldBe` 3 + Nothing -> + expectationFailure "failed to decode SynonymsSetInfo" + + it "defaults missing count/synonyms_set to 0/[]" $ do + let raw = LBS.pack "{}" + case decode raw :: Maybe Types.SynonymsSetInfo of + Just info -> do + Types.ssiCount info `shouldBe` 0 + Types.ssiRules info `shouldBe` [] + Nothing -> + expectationFailure "failed to decode empty SynonymsSetInfo" + + it "round-trips a populated response" $ do + let info = + Types.SynonymsSetInfo + { Types.ssiCount = 1, + Types.ssiRules = [Types.SynonymRule (Just "a") "x, y"] + } + decode (encode info) `shouldBe` Just info + + describe "SynonymsSetPutResponse JSON" $ do + it "decodes {acknowledged: true}" $ do + let raw = LBS.pack "{\"acknowledged\":true}" + decode raw `shouldBe` Just (Types.SynonymsSetPutResponse (Just True) Nothing) + + it "decodes {result: updated} (reload path)" $ do + let raw = LBS.pack "{\"result\":\"updated\"}" + decode raw `shouldBe` Just (Types.SynonymsSetPutResponse Nothing (Just "updated")) + + it "decodes both fields when present" $ do + let raw = LBS.pack "{\"acknowledged\":true,\"result\":\"created\"}" + decode raw `shouldBe` Just (Types.SynonymsSetPutResponse (Just True) (Just "created")) + + describe "synonymsGetOptionsParams URI rendering" $ do + it "defaultSynonymsGetOptions emits no params" $ + Types.synonymsGetOptionsParams Types.defaultSynonymsGetOptions + `shouldBe` [] + + it "renders from and size" $ do + let opts = + Types.defaultSynonymsGetOptions + { Types.sgoFrom = Just 5, + Types.sgoSize = Just 20 + } + Types.synonymsGetOptionsParams opts + `shouldBe` [("from", Just "5"), ("size", Just "20")] + + it "renders only the set fields" $ do + let opts = + Types.defaultSynonymsGetOptions + { Types.sgoSize = Just 50 + } + Types.synonymsGetOptionsParams opts + `shouldBe` [("size", Just "50")] + + describe "endpoint shape" $ do + it "PUTs to /_synonyms/ with a body (ES8)" $ do + let req = + RequestsES8.putSynonymsSet + "my-synonyms-set" + (Types.SynonymsSet [Types.SynonymRule Nothing "a, b"]) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_synonyms", "my-synonyms-set"] + bhRequestBody req `shouldSatisfy` isJust + + it "GETs /_synonyms/ with no body (ES8)" $ do + let req = RequestsES8.getSynonymsSet "my-synonyms-set" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_synonyms", "my-synonyms-set"] + bhRequestBody req `shouldSatisfy` isNothing + + it "getSynonymsSetWith appends from/size query params" $ do + let opts = + Types.defaultSynonymsGetOptions + { Types.sgoFrom = Just 1, + Types.sgoSize = Just 2 + } + req = RequestsES8.getSynonymsSetWith "my-synonyms-set" opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_synonyms", "my-synonyms-set"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("from", Just "1"), ("size", Just "2")] + bhRequestBody req `shouldSatisfy` isNothing + + it "DELETEs /_synonyms/ with no body (ES8)" $ do + let req = RequestsES8.deleteSynonymsSet "my-synonyms-set" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_synonyms", "my-synonyms-set"] + bhRequestBody req `shouldSatisfy` isNothing + + describe "live integration (requires ES8+ backend)" $ + backendSpecific [ElasticSearch8] $ do + -- Search synonyms are available under the free basic license in + -- ES 8.x, so the round-trip below should run on the docker-compose + -- ES8 container. It still tolerates a privilege failure + -- (manage_search_synonyms cluster privilege) by pending. + it "round-trips a synonyms set via PUT then GET then DELETE" $ + withTestEnv $ do + let sid = Types.SynonymsSetId "bloodhound-test-synonyms" + body = + Types.SynonymsSet + [ Types.SynonymRule (Just "test-1") "hello, hi", + Types.SynonymRule Nothing "bye, goodbye" + ] + _ <- + tryPerformBHRequest $ + RequestsES8.deleteSynonymsSet sid + putResult <- tryEsError (ClientES8.putSynonymsSet sid body) + case putResult of + Left e + | errorStatus e == Just 403 + || "privilege" `T.isInfixOf` T.toLower (errorMessage e) -> + liftIO $ + pendingWith + "synonyms API requires manage_search_synonyms \ + \privilege; skip on locked-down clusters" + Left e -> + liftIO $ + expectationFailure $ + "unexpected PUT error: " <> show e + Right _putResp -> do + info <- ClientES8.getSynonymsSet sid + liftIO $ do + Types.ssiCount info `shouldBe` 2 + length (Types.ssiRules info) `shouldBe` 2 + _ <- ClientES8.deleteSynonymsSet sid + pure () + + it "DELETE of a non-existent synonyms set surfaces a 4xx EsError" $ + withTestEnv $ do + result <- + tryPerformBHRequest $ + RequestsES8.deleteSynonymsSet + (Types.SynonymsSetId "bloodhound-definitely-missing-synonyms") + case result of + Left e -> + case errorStatus e of + Just s -> liftIO $ (s >= 400 && s < 500) `shouldBe` True + Nothing -> + liftIO $ + expectationFailure $ + "expected a 4xx status, got none. Message: " + <> show (errorMessage e) + Right _ -> + liftIO $ + expectationFailure + "expected DELETE of a missing synonyms set to fail, but it succeeded" diff --git a/tests/Test/TasksSpec.hs b/tests/Test/TasksSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/TasksSpec.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} + +module Test.TasksSpec (spec) where + +import Control.Concurrent (threadDelay) +import Data.List qualified as L +import Data.Text qualified as T +import Numeric.Natural +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + -- ------------------------------------------------------------------ -- + -- FromJSON decoding (pure, no ES required) -- + -- ------------------------------------------------------------------ -- + describe "TaskListResponse FromJSON" $ do + let singleTask = + "{\"nodes\":{\"n1\":{" + <> "\"name\":\"node-1\"," + <> "\"transport_address\":\"127.0.0.1:9300\"," + <> "\"host\":\"127.0.0.1\"," + <> "\"ip\":\"127.0.0.1\"," + <> "\"tasks\":{\"n1:42\":{" + <> "\"node\":\"n1\"," + <> "\"id\":42," + <> "\"type\":\"transport\"," + <> "\"action\":\"indices:data/write/reindex\"," + <> "\"description\":\"reindex [bloodhound-tests-twitter-1]\"," + <> "\"start_time_in_millis\":1700000000000," + <> "\"running_time_in_nanos\":5000000000," + <> "\"cancellable\":true," + <> "\"parent_task_id\":\"n1:1\"" + <> "}}}}}" + + it "parses a nodes-grouped response and stamps the node id" $ do + let parsed = decode singleTask :: Maybe TaskListResponse + parsed `shouldSatisfy` isJust + case parsed of + Just resp -> do + length (taskListResponseNodes resp) `shouldBe` 1 + case taskListResponseNodes resp of + (node : _) -> taskListNodeId node `shouldBe` "n1" + _ -> expectationFailure "expected at least one node" + Nothing -> expectationFailure "expected TaskListResponse parse" + + it "flattens to a single TaskInfo with the expected fields" $ + case decode singleTask :: Maybe TaskListResponse of + Just resp -> + case taskListFlat resp of + [t] -> do + taskInfoNode t `shouldBe` "n1" + taskInfoId t `shouldBe` 42 + taskInfoType t `shouldBe` "transport" + taskInfoAction t `shouldBe` "indices:data/write/reindex" + taskInfoDescription t `shouldBe` Just "reindex [bloodhound-tests-twitter-1]" + taskInfoStartTimeInMillis t `shouldBe` 1700000000000 + taskInfoRunningTimeInNanos t `shouldBe` 5000000000 + taskInfoCancellable t `shouldBe` True + taskInfoParentTaskId t `shouldBe` Just "n1:1" + _ -> expectationFailure "expected exactly one task" + Nothing -> expectationFailure "expected TaskListResponse parse" + + it "parses a node with no tasks into an empty flat list" $ do + let payload = + "{\"nodes\":{\"n1\":{\"name\":\"node-1\",\"tasks\":{}}}}" + case decode payload :: Maybe TaskListResponse of + Just resp -> taskListFlat resp `shouldBe` [] + Nothing -> expectationFailure "expected TaskListResponse parse" + + it "tolerates a missing tasks key on a node" $ do + let payload = + "{\"nodes\":{\"n1\":{\"name\":\"node-1\"}}}" + case decode payload :: Maybe TaskListResponse of + Just resp -> taskListFlat resp `shouldBe` [] + Nothing -> expectationFailure "expected TaskListResponse parse" + + it "parses multiple nodes and tasks" $ do + let payload = + "{\"nodes\":{" + <> "\"n1\":{\"tasks\":{\"n1:1\":{\"node\":\"n1\",\"id\":1,\"type\":\"transport\",\"action\":\"a1\",\"start_time_in_millis\":1,\"running_time_in_nanos\":1,\"cancellable\":false}}}," + <> "\"n2\":{\"tasks\":{\"n2:2\":{\"node\":\"n2\",\"id\":2,\"type\":\"transport\",\"action\":\"a2\",\"start_time_in_millis\":2,\"running_time_in_nanos\":2,\"cancellable\":true}}}" + <> "}}" + case decode payload :: Maybe TaskListResponse of + Just resp -> do + let tasks = taskListFlat resp + L.sort (taskInfoAction <$> tasks) `shouldBe` ["a1", "a2"] + -- payload omits description / parent_task_id, so the .:? + -- decode path must yield Nothing for every task. + let descriptions = taskInfoDescription <$> tasks + parents = taskInfoParentTaskId <$> tasks + all isNothing descriptions `shouldBe` True + all isNothing parents `shouldBe` True + Nothing -> expectationFailure "expected TaskListResponse parse" + + -- ------------------------------------------------------------------ -- + -- Task FromJSON (pure, no ES required) -- + -- ------------------------------------------------------------------ -- + describe "Task FromJSON" $ do + let fullTask = + "{\"node\":\"n1\"," + <> "\"id\":42," + <> "\"type\":\"transport\"," + <> "\"action\":\"indices:data/write/reindex\"," + <> "\"status\":{\"created\":0,\"batches\":1}," + <> "\"description\":\"reindex [bloodhound-tests-twitter-1]\"," + <> "\"start_time_in_millis\":1700000000000," + <> "\"running_time_in_nanos\":5000000000," + <> "\"cancellable\":true," + <> "\"parent_task_id\":\"n1:1\"," + <> "\"headers\":{\"X-Opaque-Id\":\"abc\"}" + <> "}" + + it "decodes parent_task_id and headers when present" $ + case decode fullTask :: Maybe (Task Value) of + Just t -> do + taskParentTaskId t `shouldBe` Just "n1:1" + taskHeaders t `shouldSatisfy` isJust + Nothing -> expectationFailure "expected Task parse" + + it "yields Nothing for parent_task_id and headers when absent" $ do + let payload = + "{\"node\":\"n1\"," + <> "\"id\":42," + <> "\"type\":\"transport\"," + <> "\"action\":\"indices:data/write/reindex\"," + <> "\"status\":{}," + <> "\"description\":\"reindex\"," + <> "\"start_time_in_millis\":1700000000000," + <> "\"running_time_in_nanos\":5000000000," + <> "\"cancellable\":true" + <> "}" + case decode payload :: Maybe (Task Value) of + Just t -> do + taskParentTaskId t `shouldBe` Nothing + taskHeaders t `shouldBe` Nothing + Nothing -> expectationFailure "expected Task parse" + + it "preserves the \"-1\" sentinel for parent_task_id verbatim" $ do + let payload = + "{\"node\":\"n1\"," + <> "\"id\":42," + <> "\"type\":\"transport\"," + <> "\"action\":\"indices:data/write/reindex\"," + <> "\"status\":{}," + <> "\"description\":\"reindex\"," + <> "\"start_time_in_millis\":1700000000000," + <> "\"running_time_in_nanos\":5000000000," + <> "\"cancellable\":true," + <> "\"parent_task_id\":\"-1\"" + <> "}" + case decode payload :: Maybe (Task Value) of + Just t -> taskParentTaskId t `shouldBe` Just "-1" + Nothing -> expectationFailure "expected Task parse" + + -- ------------------------------------------------------------------ -- + -- TaskResponse FromJSON (pure, no ES required) -- + -- -- + -- Elasticsearch emits the completed-task result under the -- + -- historically-misspelled @reponse@ key, while OpenSearch emits it -- + -- under the correctly-spelled @response@ key. The decoder must -- + -- accept both (preferring @response@) or silently drop the result on -- + -- OpenSearch. -- + -- ------------------------------------------------------------------ -- + describe "TaskResponse FromJSON" $ do + let minTask = + "\"task\":{\"node\":\"n1\"," + <> "\"id\":42," + <> "\"type\":\"transport\"," + <> "\"action\":\"indices:data/write/reindex\"," + <> "\"status\":{}," + <> "\"description\":\"reindex\"," + <> "\"start_time_in_millis\":1," + <> "\"running_time_in_nanos\":1," + <> "\"cancellable\":true" + <> "}" + + it "decodes the ES-style \"reponse\" (historical typo) result key" $ do + let payload = "{\"completed\":true," <> minTask <> ",\"reponse\":\"es-result\"}" + case decode payload :: Maybe (TaskResponse Value) of + Just r -> taskResponseResponse r `shouldBe` Just (String "es-result") + Nothing -> expectationFailure "expected TaskResponse parse" + + it "decodes the OpenSearch \"response\" result key (regression: was silently dropped)" $ do + let payload = "{\"completed\":true," <> minTask <> ",\"response\":\"os-result\"}" + case decode payload :: Maybe (TaskResponse Value) of + Just r -> taskResponseResponse r `shouldBe` Just (String "os-result") + Nothing -> expectationFailure "expected TaskResponse parse" + + it "prefers \"response\" over \"reponse\" when both keys are present" $ do + let payload = "{\"completed\":true," <> minTask <> ",\"response\":\"os\",\"reponse\":\"es\"}" + case decode payload :: Maybe (TaskResponse Value) of + Just r -> taskResponseResponse r `shouldBe` Just (String "os") + Nothing -> expectationFailure "expected TaskResponse parse" + + it "yields Nothing for the result when neither key is present" $ do + let payload = "{\"completed\":false," <> minTask <> "}" + case decode payload :: Maybe (TaskResponse Value) of + Just r -> taskResponseResponse r `shouldBe` Nothing + Nothing -> expectationFailure "expected TaskResponse parse" + + -- ------------------------------------------------------------------ -- + -- taskListOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "taskListOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultTaskListOptions emits no params" $ + taskListOptionsParams defaultTaskListOptions + `shouldBe` [] + + it "renders nodes as a comma-joined list" $ do + let opts = + defaultTaskListOptions + { taskListOptionsNodes = Just ["node-a", "node-b"] + } + taskListOptionsParams opts + `shouldBe` [("nodes", Just "node-a,node-b")] + + it "renders actions as a comma-joined list" $ do + let opts = + defaultTaskListOptions + { taskListOptionsActions = + Just ["indices:data/write/reindex", "indices:data/read/search"] + } + taskListOptionsParams opts + `shouldBe` [("actions", Just "indices:data/write/reindex,indices:data/read/search")] + + it "renders booleans as lowercase true/false" $ do + let opts = + defaultTaskListOptions + { taskListOptionsDetailed = Just True, + taskListOptionsWaitForCompletion = Just False + } + normalize (taskListOptionsParams opts) + `shouldBe` [ ("detailed", Just "true"), + ("wait_for_completion", Just "false") + ] + + it "renders parent_task_id verbatim" $ do + let opts = + defaultTaskListOptions + { taskListOptionsParentTaskId = Just "n1:1" + } + taskListOptionsParams opts + `shouldBe` [("parent_task_id", Just "n1:1")] + + it "renders timeout as " $ do + let opts = + defaultTaskListOptions + { taskListOptionsTimeout = Just (TimeUnitSeconds, 30) + } + taskListOptionsParams opts + `shouldBe` [("timeout", Just "30s")] + + it "renders group_by via renderTaskListGroupBy" $ do + let opts = + defaultTaskListOptions + { taskListOptionsGroupBy = Just TaskListGroupByParents + } + taskListOptionsParams opts + `shouldBe` [("group_by", Just "parents")] + + it "emits every param together when all are set" $ do + let opts = + defaultTaskListOptions + { taskListOptionsNodes = Just ["n1"], + taskListOptionsActions = Just ["indices:data/write/reindex"], + taskListOptionsDetailed = Just True, + taskListOptionsParentTaskId = Just "n1:0", + taskListOptionsWaitForCompletion = Just True, + taskListOptionsTimeout = Just (TimeUnitMilliseconds, 500), + taskListOptionsGroupBy = Just TaskListGroupByNodes + } + normalize (taskListOptionsParams opts) + `shouldBe` [ ("actions", Just "indices:data/write/reindex"), + ("detailed", Just "true"), + ("group_by", Just "nodes"), + ("nodes", Just "n1"), + ("parent_task_id", Just "n1:0"), + ("timeout", Just "500ms"), + ("wait_for_completion", Just "true") + ] + + -- ------------------------------------------------------------------ -- + -- taskGetOptionsParams: pure URI rendering (no ES required) -- + -- ------------------------------------------------------------------ -- + describe "taskGetOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultTaskGetOptions emits no params" $ + taskGetOptionsParams defaultTaskGetOptions + `shouldBe` [] + + it "renders wait_for_completion as lowercase true/false" $ do + let trueOpts = defaultTaskGetOptions {taskGetOptionsWaitForCompletion = Just True} + falseOpts = defaultTaskGetOptions {taskGetOptionsWaitForCompletion = Just False} + taskGetOptionsParams trueOpts + `shouldBe` [("wait_for_completion", Just "true")] + taskGetOptionsParams falseOpts + `shouldBe` [("wait_for_completion", Just "false")] + + it "renders timeout as " $ do + let opts = defaultTaskGetOptions {taskGetOptionsTimeout = Just (TimeUnitSeconds, 30)} + taskGetOptionsParams opts + `shouldBe` [("timeout", Just "30s")] + + it "emits both params together when all are set" $ do + let opts = + defaultTaskGetOptions + { taskGetOptionsWaitForCompletion = Just True, + taskGetOptionsTimeout = Just (TimeUnitMilliseconds, 500) + } + normalize (taskGetOptionsParams opts) + `shouldBe` [ ("timeout", Just "500ms"), + ("wait_for_completion", Just "true") + ] + + -- ------------------------------------------------------------------ -- + -- Live integration (requires ES/OpenSearch at ES_TEST_SERVER) -- + -- ------------------------------------------------------------------ -- + describe "listTasks live" $ do + it "returns the responding node when called unfiltered" $ + withTestEnv $ do + resp <- performBHRequest $ listTasks Nothing + liftIO $ length (taskListResponseNodes resp) `shouldSatisfy` (>= 1) + + it "accepts detailed=true and still parses" $ + withTestEnv $ do + let opts = defaultTaskListOptions {taskListOptionsDetailed = Just True} + resp <- performBHRequest $ listTasks (Just opts) + liftIO $ length (taskListResponseNodes resp) `shouldSatisfy` (>= 1) + + -- ------------------------------------------------------------------ -- + -- getTask / getTaskWith live (requires ES/OpenSearch at ES_TEST_SERVER) -- + -- ------------------------------------------------------------------ -- + describe "getTaskWith live" $ do + it "getTask polls a reindex task to completion" $ + withTestEnv $ do + _ <- insertData + let target = [qqIndexName|bloodhound-tests-twitter-gettask-default|] + _ <- tryPerformBHRequest $ deleteIndex target + _ <- + performBHRequest $ + createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) target + taskNodeId <- assertRight =<< tryPerformBHRequest (reindexAsync $ mkReindexRequest testIndex target) + resp <- waitForCompletion 10 taskNodeId + liftIO $ taskResponseCompleted resp `shouldBe` True + + it "getTaskWith forwards wait_for_completion=true and returns a completed TaskResponse" $ + withTestEnv $ do + _ <- insertData + let target = [qqIndexName|bloodhound-tests-twitter-gettask-opts|] + _ <- tryPerformBHRequest $ deleteIndex target + _ <- + performBHRequest $ + createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) target + taskNodeId <- assertRight =<< tryPerformBHRequest (reindexAsync $ mkReindexRequest testIndex target) + -- The single-doc reindex typically finishes in milliseconds, so + -- wait_for_completion=true returns immediately with a completed + -- TaskResponse rather than exercising the blocking path; the + -- assertion holds either way. + let opts = + defaultTaskGetOptions + { taskGetOptionsWaitForCompletion = Just True + } + resp <- assertRight =<< tryPerformBHRequest (getTaskWith @ReindexResponse opts taskNodeId) + liftIO $ taskResponseCompleted resp `shouldBe` True + + -- ------------------------------------------------------------------ -- + -- cancelTask live (requires ES/OpenSearch at ES_TEST_SERVER) -- + -- ------------------------------------------------------------------ -- + describe "cancelTask live" $ do + it "cancels a running async reindex and lists the cancelled task" $ + withTestEnv $ do + _ <- insertData + let target = [qqIndexName|bloodhound-tests-twitter-cancel-target|] + _ <- tryPerformBHRequest $ deleteIndex target + _ <- + performBHRequest $ + createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) target + taskNodeId <- assertRight =<< tryPerformBHRequest (reindexAsync $ mkReindexRequest testIndex target) + -- Small race window: the single-doc reindex may finish before the + -- cancel lands, in which case the response lists no nodes. When the + -- task is still running the cancel response lists it (>= 1 node). + cancelled <- performBHRequest $ cancelTask taskNodeId + liftIO $ length (taskListResponseNodes cancelled) `shouldSatisfy` (>= 1) + +assertRight :: (Show a, MonadFail m) => Either a b -> m b +assertRight (Left x) = fail $ "Expected Right, got Left: " <> show x +assertRight (Right x) = pure x + +-- | Poll getTask until the task reports completed or the retry budget +-- runs out. The response is returned so its @completed@ flag can be +-- asserted. +waitForCompletion :: + (MonadBH m, MonadFail m) => + Natural -> + TaskNodeId -> + m (TaskResponse ReindexResponse) +waitForCompletion 0 taskNodeId = + fail $ "Timed out waiting for task to complete, taskNodeId = " <> show taskNodeId +waitForCompletion n taskNodeId = do + resp <- assertRight =<< tryPerformBHRequest (getTask taskNodeId) + if taskResponseCompleted resp + then pure resp + else liftIO (threadDelay 100000) >> waitForCompletion (n - 1) taskNodeId diff --git a/tests/Test/TemplatesSpec.hs b/tests/Test/TemplatesSpec.hs --- a/tests/Test/TemplatesSpec.hs +++ b/tests/Test/TemplatesSpec.hs @@ -1,12 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Test.TemplatesSpec (spec) where +import Control.Exception (SomeException) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as AKM +import Data.List qualified as L +import Data.Text qualified as T import TestsUtils.Common import TestsUtils.Import spec :: Spec -spec = +spec = do describe "template API" $ do it "can create a template" $ withTestEnv $ do @@ -19,6 +25,55 @@ exists <- performBHRequest $ templateExists (TemplateName "tweet-tpl") liftIO $ exists `shouldBe` True + it "getTemplate (Just name) returns the template we PUT" $ + withTestEnv $ do + let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1) defaultIndexMappingsLimits)) (toJSON TweetMapping) + _ <- performBHRequest $ putTemplate idxTpl (TemplateName "tweet-tpl") + infos <- performBHRequest $ getTemplate (Just (TemplateNamePattern "tweet-tpl")) + liftIO $ map tiName infos `shouldBe` [TemplateName "tweet-tpl"] + liftIO $ case infos of + [info] -> + -- The server may synthesise default @settings@ on GET (e.g. + -- @refresh_interval@), and @mappings@ echoes what we PUT but + -- possibly with extra ES-internal keys. Assert only on the + -- invariant part of the body: the patterns we registered. + tiIndexPatterns info `shouldBe` [IndexPattern "tweet-*"] + _ -> expectationFailure ("expected a singleton list but got " <> show infos) + + it "getTemplate Nothing lists templates including ours" $ + withTestEnv $ do + let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1) defaultIndexMappingsLimits)) (toJSON TweetMapping) + _ <- performBHRequest $ putTemplate idxTpl (TemplateName "tweet-tpl") + infos <- performBHRequest $ getTemplate Nothing + -- Membership rather than equality: a shared cluster will almost + -- always have other legacy templates (e.g. built-ins on ES 7). + liftIO $ TemplateName "tweet-tpl" `elem` map tiName infos `shouldBe` True + + it "getTemplate accepts a wildcard pattern" $ + withTestEnv $ do + let idxTpl = IndexTemplate [IndexPattern "tweet-*"] (Just (IndexSettings (ShardCount 1) (ReplicaCount 1) defaultIndexMappingsLimits)) (toJSON TweetMapping) + _ <- performBHRequest $ putTemplate idxTpl (TemplateName "tweet-tpl") + infos <- performBHRequest $ getTemplate (Just (TemplateNamePattern "tweet-*")) + liftIO $ TemplateName "tweet-tpl" `elem` map tiName infos `shouldBe` True + + it "getTemplate surfaces a non-matching pattern as an error" $ + withTestEnv $ do + -- On ES 8+ the server returns a parseable error body and the + -- request surfaces as 'Left EsError' via 'tryPerformBHRequest'. + -- On ES 7 the legacy @GET /_template/@ endpoint + -- returns a 404 with an empty @{}@ body, which the client + -- cannot decode as an 'EsError' and so throws + -- 'EsProtocolException'. Both are valid failure modes; we just + -- assert the request does not succeed. + result <- + try $ + performBHRequest $ + getTemplate (Just (TemplateNamePattern "definitely-not-a-real-template-xyz")) + liftIO $ case result of + Left (_ :: SomeException) -> return () + Right infos -> + expectationFailure ("expected a failure but got " <> show infos) + it "can delete a template" $ withTestEnv $ do resp <- performBHRequest $ deleteTemplate (TemplateName "tweet-tpl") @@ -28,3 +83,933 @@ withTestEnv $ do exists <- performBHRequest $ templateExists (TemplateName "tweet-tpl") liftIO $ exists `shouldBe` False + + -- ------------------------------------------------------------------ -- + -- Composable index templates (PUT /_index_template/{name}). -- + -- ------------------------------------------------------------------ -- + describe "composable index template API" $ do + let content = + ComposableTemplateContent + { -- The composable template's @settings@ field is flat + -- (@number_of_shards@ lives directly under @settings@), + -- /not/ the wrapped @{"settings":{"index":{...}}}@ shape + -- produced by 'IndexSettings'\'s 'ToJSON'. Pass a flat + -- object here. + ctcSettings = + Just + ( Aeson.object + [ "number_of_shards" Aeson..= (1 :: Int), + "number_of_replicas" Aeson..= (1 :: Int) + ] + ), + ctcMappings = Just (toJSON TweetMapping), + ctcAliases = Nothing + } + tpl = + ComposableTemplate + { ctIndexPatterns = [IndexPattern "composable-tweet-*"], + ctTemplate = Just content, + ctPriority = Just 100, + ctVersion = Nothing, + ctComposedOf = Nothing, + ctAllowAutoCreate = Nothing + } + name = TemplateName "bh-composable-tpl" + + it "putIndexTemplate returns Acknowledged True" $ + withTestEnv $ do + resp <- performBHRequest $ putIndexTemplate name tpl + liftIO $ resp `shouldBe` Acknowledged True + + it "putIndexTemplate is idempotent (re-PUT succeeds)" $ + withTestEnv $ do + resp <- performBHRequest $ putIndexTemplate name tpl + liftIO $ resp `shouldBe` Acknowledged True + + it "putIndexTemplateWith create=true fails when the template already exists" $ + withTestEnv $ do + -- Ensure the template exists (idempotent upsert). + _ <- performBHRequest $ putIndexTemplate name tpl + -- create=true must refuse to overwrite an existing template. + result <- + tryPerformBHRequest $ + putIndexTemplateWith name tpl defaultComposableTemplateOptions {ctoCreate = Just True} + liftIO $ case result of + Left _ -> return () + Right _ -> expectationFailure "expected create=true to fail but the PUT succeeded" + + it "getIndexTemplate (Just name) returns the template we PUT" $ + withTestEnv $ do + _ <- performBHRequest $ putIndexTemplate name tpl + infos <- performBHRequest $ getIndexTemplate (Just (TemplateNamePattern "bh-composable-tpl")) + liftIO $ map itiName infos `shouldBe` [name] + liftIO $ case infos of + [info] -> do + -- The server normalizes the body on GET (wraps settings + -- under "index", stringifies numbers, echoes + -- "composed_of": []), so we only assert on the fields ES + -- preserves verbatim: the index patterns and priority. + ctIndexPatterns (itiIndexTemplate info) `shouldBe` ctIndexPatterns tpl + ctPriority (itiIndexTemplate info) `shouldBe` ctPriority tpl + _ -> expectationFailure ("expected a singleton list but got " <> show infos) + + it "getIndexTemplate Nothing lists templates including ours" $ + withTestEnv $ do + _ <- performBHRequest $ putIndexTemplate name tpl + infos <- performBHRequest $ getIndexTemplate Nothing + liftIO $ name `elem` map itiName infos `shouldBe` True + + it "getIndexTemplate accepts a wildcard pattern" $ + withTestEnv $ do + _ <- performBHRequest $ putIndexTemplate name tpl + infos <- performBHRequest $ getIndexTemplate (Just (TemplateNamePattern "bh-composable-*")) + -- Membership rather than singleton equality: a previous, + -- independently-created template with the same prefix would + -- make a strict @[name]@ assertion flaky on a shared cluster. + liftIO $ name `elem` map itiName infos `shouldBe` True + + it "getIndexTemplate surfaces a non-matching pattern as an EsError (404)" $ + withTestEnv $ do + result <- + tryPerformBHRequest $ + getIndexTemplate (Just (TemplateNamePattern "definitely-not-a-real-template-xyz")) + liftIO $ case result of + Left _ -> return () + Right infos -> + expectationFailure ("expected a 404 EsError but got " <> show infos) + + it "deleteIndexTemplate returns Acknowledged True after PUT" $ + withTestEnv $ do + _ <- performBHRequest $ putIndexTemplate name tpl + resp <- performBHRequest $ deleteIndexTemplate name + liftIO $ resp `shouldBe` Acknowledged True + + it "deleteIndexTemplate makes a subsequent GET 404" $ + withTestEnv $ do + _ <- performBHRequest $ putIndexTemplate name tpl + _ <- performBHRequest $ deleteIndexTemplate name + result <- + tryPerformBHRequest $ + getIndexTemplate (Just (TemplateNamePattern "bh-composable-tpl")) + liftIO $ case result of + Left _ -> return () + Right infos -> + expectationFailure + ("expected a 404 EsError after deleteIndexTemplate but got " <> show infos) + + it "deleteIndexTemplate surfaces a missing template as an EsError (404)" $ + withTestEnv $ do + result <- + tryPerformBHRequest $ + deleteIndexTemplate (TemplateName "bh-composable-not-actually-present") + liftIO $ case result of + Left _ -> return () + Right ack -> + expectationFailure + ("expected a 404 EsError but got " <> show ack) + + -- ---------------------------------------------------------------- + -- POST /_index_template/_simulate (bloodhound-04f.2.17.5). + -- Tests 1 and 3 use patterns disjoint from @composable-tweet-*@ + -- (the patterns of @bh-composable-tpl@ above) so execution order + -- does not matter — the simulate validation rejects requests + -- whose priority conflicts with an existing template that matches + -- the same index name. + -- ---------------------------------------------------------------- + it "simulateIndexTemplate returns the resolved template body" $ + withTestEnv $ do + let isoTpl = + ComposableTemplate + { ctIndexPatterns = [IndexPattern "bh-simulate-iso-*"], + ctTemplate = + Just + ( ComposableTemplateContent + { ctcSettings = + Just + ( Aeson.object + ["number_of_shards" Aeson..= (1 :: Int)] + ), + ctcMappings = Nothing, + ctcAliases = Nothing + } + ), + ctPriority = Just 200, + ctVersion = Nothing, + ctComposedOf = Nothing, + ctAllowAutoCreate = Nothing + } + simulated <- + performBHRequest $ + simulateIndexTemplate isoTpl + -- The simulated template merges settings/mappings/aliases from + -- the supplied body plus any component templates referenced. + -- We assert on the settings we supplied (number_of_shards=1) + -- being present in the resolved body, rather than on the full + -- merged shape (which can include server-added defaults). + liftIO $ + ctcSettings (stTemplate simulated) + `shouldSatisfy` isJust + + it "simulateIndexTemplate includes an existing overlapping template" $ + withTestEnv $ do + -- Persist @tpl@ under @name@, then simulate a sibling template + -- whose index_patterns overlap @name@'s. The persisted @name@ + -- must appear in the simulated overlapping list. The cleanup + -- runs before the assertion so an HUnit failure does not leak + -- @bh-composable-tpl@ onto a shared cluster. + _ <- performBHRequest $ putIndexTemplate name tpl + let overlappingTpl = + ComposableTemplate + { ctIndexPatterns = [IndexPattern "composable-tweet-extra-*"], + ctTemplate = Just content, + -- Priority lower than @name@'s 100 so the simulate + -- validation does not flag a priority conflict. + ctPriority = Just 50, + ctVersion = Nothing, + ctComposedOf = Nothing, + ctAllowAutoCreate = Nothing + } + simulated <- + performBHRequest $ + simulateIndexTemplate overlappingTpl + -- Clean up before asserting so an HUnit failure does not leave + -- @name@ behind on a shared cluster. The PUT is idempotent so + -- a leftover from a previous run is fine, but cleanup is still + -- polite. + _ <- tryPerformBHRequest $ deleteIndexTemplate name + -- @composable-tweet-*@ (from @name@) overlaps our simulated + -- @composable-tweet-extra-*@ patterns, so @name@ should be in + -- the overlapping list. Membership-only because a shared + -- cluster may carry unrelated overlapping templates too. + liftIO $ + name + `elem` mapMaybe stoName (stOverlapping simulated) + `shouldBe` True + + it "simulateIndexTemplateWith with default options behaves like simulateIndexTemplate" $ + withTestEnv $ do + let isoTpl = + ComposableTemplate + { ctIndexPatterns = [IndexPattern "bh-simulate-with-*"], + ctTemplate = + Just + ( ComposableTemplateContent + { ctcSettings = + Just + ( Aeson.object + ["number_of_shards" Aeson..= (1 :: Int)] + ), + ctcMappings = Nothing, + ctcAliases = Nothing + } + ), + ctPriority = Just 200, + ctVersion = Nothing, + ctComposedOf = Nothing, + ctAllowAutoCreate = Nothing + } + -- defaultComposableTemplateOptions emits no query string, so + -- the wire request is byte-for-byte identical to the parameter- + -- less variant. We assert both calls succeed and return a + -- resolved template with the supplied settings present. + r1 <- performBHRequest $ simulateIndexTemplate isoTpl + r2 <- + performBHRequest $ + simulateIndexTemplateWith isoTpl defaultComposableTemplateOptions + liftIO $ + ctcSettings (stTemplate r1) `shouldSatisfy` isJust + liftIO $ + ctcSettings (stTemplate r2) `shouldSatisfy` isJust + + it "simulateIndex resolves a hypothetical name against a PUT template" $ + withTestEnv $ do + -- Persist @tpl@ under @name@ (patterns @composable-tweet-*@), + -- then simulate the index name @composable-tweet-simulated@ which + -- the template should match. The resolved body must carry the + -- settings we PUT. Cleanup before the assertion so an HUnit + -- failure does not leak the template onto a shared cluster. + _ <- performBHRequest $ putIndexTemplate name tpl + simulated <- + performBHRequest $ + simulateIndex [qqIndexName|composable-tweet-simulated|] + _ <- tryPerformBHRequest $ deleteIndexTemplate name + liftIO $ + ctcSettings (stTemplate simulated) + `shouldSatisfy` isJust + + it "simulateIndex resolves a name with no matching template to an empty-ish body" $ + withTestEnv $ do + -- A name matching no registered template returns a + -- 'SimulatedTemplate' whose @template@ is present (carrying only + -- server defaults) and whose @overlapping@ is empty. This pins + -- the read-only contract: the endpoint always succeeds for a + -- syntactically valid name, regardless of template coverage. + simulated <- + performBHRequest $ + simulateIndex [qqIndexName|bh-simulate-index-no-match-2026|] + liftIO $ + stOverlapping simulated `shouldBe` [] + + -- ------------------------------------------------------------------ -- + -- composableTemplateOptionsParams: pure URI rendering (no ES needed) -- + -- ------------------------------------------------------------------ -- + describe "composableTemplateOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultComposableTemplateOptions emits no params" $ + composableTemplateOptionsParams defaultComposableTemplateOptions + `shouldBe` [] + + it "renders create as lowercase true/false" $ do + let opts = defaultComposableTemplateOptions {ctoCreate = Just True} + composableTemplateOptionsParams opts `shouldBe` [("create", Just "true")] + let opts' = defaultComposableTemplateOptions {ctoCreate = Just False} + composableTemplateOptionsParams opts' `shouldBe` [("create", Just "false")] + + it "renders master_timeout as " $ do + let opts = defaultComposableTemplateOptions {ctoMasterTimeout = Just (TimeUnitSeconds, 30)} + composableTemplateOptionsParams opts `shouldBe` [("master_timeout", Just "30s")] + + it "renders cause as the raw text" $ do + let opts = defaultComposableTemplateOptions {ctoCause = Just "reload"} + composableTemplateOptionsParams opts `shouldBe` [("cause", Just "reload")] + + it "emits every param together when all are set" $ do + let opts = + defaultComposableTemplateOptions + { ctoCreate = Just True, + ctoMasterTimeout = Just (TimeUnitMilliseconds, 500), + ctoCause = Just "reload" + } + normalize (composableTemplateOptionsParams opts) + `shouldBe` [ ("cause", Just "reload"), + ("create", Just "true"), + ("master_timeout", Just "500ms") + ] + + -- ------------------------------------------------------------------ -- + -- ComposableTemplate JSON: pure, no ES required. -- + -- Locks in conditional emission of optional fields (absent when -- + -- Nothing) and required index_patterns. -- + -- ------------------------------------------------------------------ -- + describe "ComposableTemplate JSON" $ do + let decodeAsObject :: Aeson.Value -> Maybe Aeson.Object + decodeAsObject (Aeson.Object o) = Just o + decodeAsObject _ = Nothing + minimalCt = + ComposableTemplate + { ctIndexPatterns = [IndexPattern "log-*"], + ctTemplate = Nothing, + ctPriority = Nothing, + ctVersion = Nothing, + ctComposedOf = Nothing, + ctAllowAutoCreate = Nothing + } + + it "emits only index_patterns when everything else is Nothing" $ do + let encoded = Aeson.encode minimalCt + wireObject = Aeson.decode' encoded >>= decodeAsObject + wireObject `shouldSatisfy` maybe False ((== 1) . length . AKM.keys) + wireObject `shouldSatisfy` maybe False (AKM.member "index_patterns") + + it "roundtrips a fully-populated template" $ do + let fullContent = + ComposableTemplateContent + { ctcSettings = Just (Aeson.object ["index.refresh_interval" Aeson..= ("1s" :: T.Text)]), + ctcMappings = Just (toJSON TweetMapping), + ctcAliases = Just (AKM.singleton "live" (Aeson.object [])) + } + ct = + ComposableTemplate + { ctIndexPatterns = [IndexPattern "tweet-*"], + ctTemplate = Just fullContent, + ctPriority = Just 100, + ctVersion = Just 3, + ctComposedOf = Just [TemplateName "ct-base"], + ctAllowAutoCreate = Just True + } + encoded = Aeson.encode ct + decoded = Aeson.decode' encoded :: Maybe ComposableTemplate + decoded `shouldBe` Just ct + + it "roundtrips the minimal template (optional fields absent on the wire)" $ do + let encoded = Aeson.encode minimalCt + decoded = Aeson.decode' encoded :: Maybe ComposableTemplate + decoded `shouldBe` Just minimalCt + let wireObject = Aeson.decode' encoded >>= decodeAsObject + wireObject `shouldSatisfy` maybe False (not . AKM.member "template") + wireObject `shouldSatisfy` maybe False (not . AKM.member "priority") + + -- ------------------------------------------------------------------ -- + -- IndexTemplateInfo / GetIndexTemplatesResponse JSON: -- + -- pure, no ES required. Locks in the GET /_index_template envelope -- + -- shape: {"index_templates": [{"name": ..., "index_template": {...}}]} -- + -- ------------------------------------------------------------------ -- + describe "IndexTemplateInfo JSON" $ do + let -- A representative composable-template body matching the wire + -- format ES returns from GET /_index_template. + sampleBody :: ComposableTemplate + sampleBody = + ComposableTemplate + { ctIndexPatterns = [IndexPattern "tweet-*"], + ctTemplate = Nothing, + ctPriority = Just 50, + ctVersion = Nothing, + ctComposedOf = Nothing, + ctAllowAutoCreate = Nothing + } + + it "decodes a single {name, index_template} entry" $ do + let payload = + Aeson.object + [ "name" Aeson..= ("tweet-tpl" :: T.Text), + "index_template" Aeson..= sampleBody + ] + decoded = Aeson.decode' (Aeson.encode payload) :: Maybe IndexTemplateInfo + decoded + `shouldBe` Just + ( IndexTemplateInfo + { itiName = TemplateName "tweet-tpl", + itiIndexTemplate = sampleBody + } + ) + + it "roundtrips an IndexTemplateInfo" $ do + let info = + IndexTemplateInfo + { itiName = TemplateName "logs-tpl", + itiIndexTemplate = sampleBody + } + encoded = Aeson.encode info + decoded = Aeson.decode' encoded :: Maybe IndexTemplateInfo + decoded `shouldBe` Just info + + it "decodes the full {\"index_templates\": [...]} envelope" $ do + let entries = + [ IndexTemplateInfo + { itiName = TemplateName "a", + itiIndexTemplate = sampleBody + }, + IndexTemplateInfo + { itiName = TemplateName "b", + itiIndexTemplate = sampleBody + } + ] + envelope = GetIndexTemplatesResponse entries + encoded = Aeson.encode envelope + decoded = Aeson.decode' encoded :: Maybe GetIndexTemplatesResponse + decoded `shouldBe` Just envelope + getIndexTemplatesResponseTemplates <$> decoded `shouldBe` Just entries + + it "decodes an empty envelope to an empty list" $ do + let encoded = Aeson.encode (Aeson.object ["index_templates" Aeson..= ([] :: [Aeson.Value])]) + decoded = Aeson.decode' encoded :: Maybe GetIndexTemplatesResponse + decoded `shouldBe` Just (GetIndexTemplatesResponse []) + + -- ------------------------------------------------------------------ -- + -- SimulatedTemplate JSON: pure, no ES required. Locks in the -- + -- @POST /_index_template/_simulate@ response shape: -- + -- {"template": {settings,mappings,aliases}, "overlapping": [{name,..}]} -- + -- and the bare-request-body invariant (no @index_template@ wrapper). -- + -- ------------------------------------------------------------------ -- + describe "SimulatedTemplate JSON" $ do + let -- A representative @POST /_index_template/_simulate@ response + -- payload mirroring the wire format ES returns. + sampleResponse :: Aeson.Value + sampleResponse = + Aeson.object + [ "template" + Aeson..= Aeson.object + [ "settings" + Aeson..= Aeson.object + ["number_of_shards" Aeson..= (1 :: Int)], + "mappings" Aeson..= Aeson.object ["properties" Aeson..= Aeson.object []] + ], + "overlapping" + Aeson..= [ Aeson.object + [ "name" Aeson..= ("logs" :: T.Text), + "index_patterns" Aeson..= ["logs-*" :: T.Text] + ] + ] + ] + + it "decodes template settings + overlapping name and patterns" $ do + let decoded = Aeson.decode' (Aeson.encode sampleResponse) :: Maybe SimulatedTemplate + decoded `shouldSatisfy` isJust + let Just st = decoded + -- The resolved template body reuses ComposableTemplateContent; + -- the server-emitted settings survive in the *Other blob. + ctcSettings (stTemplate st) `shouldSatisfy` isJust + length (stOverlapping st) `shouldBe` 1 + case stOverlapping st of + [ov] -> do + stoName ov `shouldBe` Just (TemplateName "logs") + stoIndexPatterns ov `shouldBe` [IndexPattern "logs-*"] + _ -> expectationFailure "expected a singleton overlapping list" + + it "tolerates a payload missing the overlapping key (defaults to [])" $ do + let payload = + Aeson.object + [ "template" + Aeson..= Aeson.object + ["settings" Aeson..= Aeson.object ["number_of_shards" Aeson..= (1 :: Int)]] + ] + decoded = Aeson.decode' (Aeson.encode payload) :: Maybe SimulatedTemplate + stOverlapping <$> decoded `shouldBe` Just [] + + it "tolerates a payload missing the template key (defaults to empty content)" $ do + -- The server always emits @template@ today, but the decoder is + -- lenient so a forward-incompatible response still decodes. + let payload = Aeson.object ["overlapping" Aeson..= ([] :: [Aeson.Value])] + Just decoded = Aeson.decode' (Aeson.encode payload) :: Maybe SimulatedTemplate + stTemplate decoded + `shouldBe` ComposableTemplateContent + { ctcSettings = Nothing, + ctcMappings = Nothing, + ctcAliases = Nothing + } + + it "SimulatedTemplateOverlap tolerates a missing name (defaults to Nothing)" $ do + let payload = + Aeson.object + [ "index_patterns" Aeson..= ["metrics-*" :: T.Text] + ] + decoded = Aeson.decode' (Aeson.encode payload) :: Maybe SimulatedTemplateOverlap + stoName <$> decoded `shouldBe` Just Nothing + stoIndexPatterns <$> decoded `shouldBe` Just [IndexPattern "metrics-*"] + + it "SimulatedTemplateOverlap tolerates a missing index_patterns (defaults to [])" $ do + let payload = Aeson.object ["name" Aeson..= ("only-name" :: T.Text)] + decoded = Aeson.decode' (Aeson.encode payload) :: Maybe SimulatedTemplateOverlap + stoName <$> decoded `shouldBe` Just (Just (TemplateName "only-name")) + stoIndexPatterns <$> decoded `shouldBe` Just [] + + it "round-trips a fully-populated SimulatedTemplate (typed fields + stOther preserved)" $ do + let st = + SimulatedTemplate + { stTemplate = + ComposableTemplateContent + { ctcSettings = Just (Aeson.object ["number_of_shards" Aeson..= (1 :: Int)]), + ctcMappings = Nothing, + ctcAliases = Nothing + }, + stOverlapping = + [ SimulatedTemplateOverlap + { stoName = Just (TemplateName "logs"), + stoIndexPatterns = [IndexPattern "logs-*"], + stoOther = + Aeson.object + ["name" Aeson..= ("logs" :: T.Text), "index_patterns" Aeson..= ["logs-*" :: T.Text]] + } + ], + stOther = Aeson.object ["template" Aeson..= Aeson.object []] + } + encoded = Aeson.encode st + decoded = Aeson.decode' encoded :: Maybe SimulatedTemplate + -- The typed projections survive round-trip unchanged; the *Other + -- blob also survives because the typed keys take precedence on + -- merge and the verbatim ones are kept. + decoded `shouldSatisfy` isJust + let Just again = decoded + stOverlapping again `shouldBe` stOverlapping st + ctcSettings (stTemplate again) `shouldBe` ctcSettings (stTemplate st) + + it "simulateIndexTemplate request body is the bare ComposableTemplate (no index_template wrapper)" $ do + -- The wire body matches the @PUT /_index_template/{name}@ shape + -- verbatim (validated end-to-end by the live tests below); this + -- pure test pins the @index_template@-wrapper-must-not-appear + -- invariant so a future change to 'simulateIndexTemplate' that + -- reintroduces it fails here rather than at the cluster edge. + let ct = + ComposableTemplate + { ctIndexPatterns = [IndexPattern "tweet-*"], + ctTemplate = Nothing, + ctPriority = Just 50, + ctVersion = Nothing, + ctComposedOf = Nothing, + ctAllowAutoCreate = Nothing + } + wireObject = + Aeson.decode' (Aeson.encode ct) >>= \case + (Aeson.Object o) -> Just o + _ -> Nothing + wireObject `shouldSatisfy` maybe False (not . AKM.member "index_template") + wireObject `shouldSatisfy` maybe False (AKM.member "index_patterns") + + -- ------------------------------------------------------------------ -- + -- simulateIndex endpoint shape (POST /_index_template/_simulate_index/{name}). -- + -- Pure wire-shape pins; the SimulatedTemplate response decoder is -- + -- covered by the "SimulatedTemplate JSON" section above (shared with -- + -- the simulateIndexTemplate sibling). -- + -- ------------------------------------------------------------------ -- + describe "simulateIndex endpoint shape" $ do + let idxName = [qqIndexName|logs-2026-06-21|] + + it "POSTs to /_index_template/_simulate_index/{name}" $ do + let req = simulateIndex idxName + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_index_template", "_simulate_index", "logs-2026-06-21"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + it "uses the POST method" $ do + let req = simulateIndex idxName + bhRequestMethod req `shouldBe` "POST" + it "attaches an empty body (the index name carries all the input)" $ do + let req = simulateIndex idxName + -- emptyBody is the empty string; the server treats the absence of + -- a body as "resolve against the already-registered templates". + -- A {} body would be rejected (the server then requires an + -- index_patterns field), so we pin the empty-string invariant. + bhRequestBody req `shouldBe` Just "" + it "is distinct from simulateIndexTemplate (different path, no body arg)" $ do + -- Guard against a copy-paste regression where simulateIndex might + -- accidentally hit the sibling _simulate endpoint (which takes a + -- ComposableTemplate body) instead of _simulate_index/{name}. + let ct = + ComposableTemplate + { ctIndexPatterns = [IndexPattern "logs-*"], + ctTemplate = Nothing, + ctPriority = Nothing, + ctVersion = Nothing, + ctComposedOf = Nothing, + ctAllowAutoCreate = Nothing + } + indexReq = simulateIndex idxName + templateReq = simulateIndexTemplate ct + getRawEndpoint (bhRequestEndpoint indexReq) + `shouldNotBe` getRawEndpoint (bhRequestEndpoint templateReq) + it "simulateIndexWith renders master_timeout as a query parameter" $ do + let opts = defaultComposableTemplateOptions {ctoMasterTimeout = Just (TimeUnitSeconds, 30)} + req = simulateIndexWith idxName opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_index_template", "_simulate_index", "logs-2026-06-21"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("master_timeout", Just "30s")] + it "simulateIndexWith defaultComposableTemplateOptions emits no query" $ do + let req = simulateIndexWith idxName defaultComposableTemplateOptions + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + -- ------------------------------------------------------------------ -- + -- Component templates (PUT /_component_template/{name}). -- + -- ------------------------------------------------------------------ -- + describe "component template API" $ do + let content = + ComposableTemplateContent + { ctcSettings = + Just + ( Aeson.object + [ "number_of_shards" Aeson..= (1 :: Int), + "number_of_replicas" Aeson..= (1 :: Int) + ] + ), + ctcMappings = Just (toJSON TweetMapping), + ctcAliases = Nothing + } + tpl = + ComponentTemplate + { cpTemplate = Just content, + cpVersion = Just 1, + cpMeta = Nothing, + cpDeprecated = Nothing + } + name = TemplateName "bh-component-tpl" + + it "putComponentTemplate returns Acknowledged True" $ + withTestEnv $ do + resp <- performBHRequest $ putComponentTemplate name tpl + liftIO $ resp `shouldBe` Acknowledged True + + it "putComponentTemplate is idempotent (re-PUT succeeds)" $ + withTestEnv $ do + resp <- performBHRequest $ putComponentTemplate name tpl + liftIO $ resp `shouldBe` Acknowledged True + + it "deleteComponentTemplate returns Acknowledged True for an existing template" $ + withTestEnv $ do + _ <- performBHRequest $ putComponentTemplate name tpl + resp <- performBHRequest $ deleteComponentTemplate name + liftIO $ resp `shouldBe` Acknowledged True + + it "deleteComponentTemplate on a missing template yields EsError" $ do + result <- + withTestEnv $ + tryEsError (performBHRequest $ deleteComponentTemplate (TemplateName "bh-component-tpl-missing-04f-2-17-8")) + case result of + Left _ -> pure () + Right _ -> expectationFailure "expected EsError for missing component template, got success" + + it "getComponentTemplate (Just name) returns the template we PUT" $ + withTestEnv $ do + _ <- performBHRequest $ putComponentTemplate name tpl + infos <- performBHRequest $ getComponentTemplate (Just (TemplateNamePattern "bh-component-tpl")) + liftIO $ map ctiName infos `shouldBe` [name] + liftIO $ case infos of + [info] -> do + -- The server may normalise the inner @template@ body + -- (re-serialise settings, drop empty objects), so we only + -- assert on the typed metadata that round-trips verbatim: + -- @version@. + cpVersion (ctiComponentTemplate info) `shouldBe` cpVersion tpl + _ -> expectationFailure ("expected a singleton list but got " <> show infos) + + it "getComponentTemplate Nothing lists templates including ours" $ + withTestEnv $ do + _ <- performBHRequest $ putComponentTemplate name tpl + infos <- performBHRequest $ getComponentTemplate Nothing + liftIO $ name `elem` map ctiName infos `shouldBe` True + + it "getComponentTemplate accepts a wildcard pattern" $ + withTestEnv $ do + _ <- performBHRequest $ putComponentTemplate name tpl + infos <- performBHRequest $ getComponentTemplate (Just (TemplateNamePattern "bh-component-*")) + -- Membership rather than singleton equality: a previous, + -- independently-created template with the same prefix would + -- make a strict @[name]@ assertion flaky on a shared cluster. + liftIO $ name `elem` map ctiName infos `shouldBe` True + + it "getComponentTemplate surfaces a non-matching pattern as an EsError (404)" $ + withTestEnv $ do + result <- + tryPerformBHRequest $ + getComponentTemplate (Just (TemplateNamePattern "definitely-not-a-real-component-template-xyz")) + liftIO $ case result of + Left _ -> return () + Right infos -> + expectationFailure ("expected a 404 EsError but got " <> show infos) + + -- ------------------------------------------------------------------ -- + -- ComponentTemplate JSON: pure, no ES required. -- + -- Locks in conditional emission of optional fields (absent when -- + -- Nothing) and the @_meta@ underscore key. -- + -- ------------------------------------------------------------------ -- + describe "ComponentTemplate JSON" $ do + let decodeAsObject :: Aeson.Value -> Maybe Aeson.Object + decodeAsObject (Aeson.Object o) = Just o + decodeAsObject _ = Nothing + minimalCp = + ComponentTemplate + { cpTemplate = Nothing, + cpVersion = Nothing, + cpMeta = Nothing, + cpDeprecated = Nothing + } + + it "emits no fields when everything is Nothing" $ do + let encoded = Aeson.encode minimalCp + wireObject = Aeson.decode' encoded >>= decodeAsObject + wireObject `shouldSatisfy` isJust + wireObject `shouldSatisfy` maybe True AKM.null + wireObject `shouldSatisfy` maybe False (not . AKM.member "template") + wireObject `shouldSatisfy` maybe False (not . AKM.member "_meta") + + it "encodes cpMeta under the _meta (underscore) key" $ do + let cp = + minimalCp + { cpMeta = Just (AKM.singleton "owner" (Aeson.String "dev")) + } + wireObject = Aeson.decode' (Aeson.encode cp) >>= decodeAsObject + wireObject `shouldSatisfy` maybe False (AKM.member "_meta") + wireObject `shouldSatisfy` maybe False (not . AKM.member "meta") + + it "roundtrips a fully-populated component template" $ do + let fullContent = + ComposableTemplateContent + { ctcSettings = Just (Aeson.object ["index.refresh_interval" Aeson..= ("1s" :: T.Text)]), + ctcMappings = Just (toJSON TweetMapping), + ctcAliases = Just (AKM.singleton "live" (Aeson.object [])) + } + cp = + ComponentTemplate + { cpTemplate = Just fullContent, + cpVersion = Just 3, + cpMeta = Just (AKM.singleton "owner" (Aeson.String "dev")), + cpDeprecated = Just True + } + encoded = Aeson.encode cp + decoded = Aeson.decode' encoded :: Maybe ComponentTemplate + decoded `shouldBe` Just cp + + it "roundtrips the minimal component template (optional fields absent on the wire)" $ do + let encoded = Aeson.encode minimalCp + decoded = Aeson.decode' encoded :: Maybe ComponentTemplate + decoded `shouldBe` Just minimalCp + + -- ------------------------------------------------------------------ -- + -- TemplateInfo / GetTemplatesResponse JSON: pure, no ES required. -- + -- Locks in the legacy @GET /_template@ envelope shape: -- + -- {name1: body1, name2: body2, ...} with the outer key lifted into -- + -- each entry's tiName. -- + -- ------------------------------------------------------------------ -- + describe "TemplateInfo JSON" $ do + let sampleBody :: Aeson.Value + sampleBody = + Aeson.object + [ "order" Aeson..= (0 :: Int), + "index_patterns" Aeson..= ["tweet-*" :: T.Text], + "mappings" Aeson..= toJSON TweetMapping + ] + -- Build a TemplateInfo by decoding the body and stamping on the + -- name (mirrors what GetTemplatesResponse's decoder does). + withBody :: TemplateName -> Aeson.Value -> TemplateInfo + withBody name body = + ( case Aeson.decode' (Aeson.encode body) :: Maybe TemplateInfo of + Just info -> info + Nothing -> error "TemplateInfo JSON fixture did not decode" + ) + { tiName = name + } + + it "decodes the legacy {name: body} envelope and lifts the key into tiName" $ do + let payload = Aeson.object ["tweet-tpl" Aeson..= sampleBody] + decoded = Aeson.decode' (Aeson.encode payload) :: Maybe GetTemplatesResponse + decoded `shouldSatisfy` isJust + let infos = getTemplatesResponseTemplates <$> decoded + infos `shouldBe` Just [TemplateName "tweet-tpl" `withBody` sampleBody] + + it "decodes a multi-key envelope to a list in document order" $ do + let payload = + Aeson.object + [ "a-tpl" Aeson..= sampleBody, + "b-tpl" Aeson..= sampleBody + ] + decoded = Aeson.decode' (Aeson.encode payload) :: Maybe GetTemplatesResponse + -- We do not assert the *order* of the decoded list (KeyMap + -- iteration order is unspecified); membership of both names is + -- sufficient. + let names = (map tiName . getTemplatesResponseTemplates) <$> decoded + -- TemplateName has no Ord instance; sort by the underlying + -- text instead. + toTexts = map (\(TemplateName n) -> n) + fmap (L.sort . toTexts) names + `shouldBe` Just ["a-tpl", "b-tpl"] + + it "decodes an empty object envelope to an empty list" $ do + let encoded = Aeson.encode (Aeson.object []) + decoded = Aeson.decode' encoded :: Maybe GetTemplatesResponse + decoded `shouldBe` Just (GetTemplatesResponse []) + + it "treats absent optional body fields as Nothing/[]" $ do + -- Only the name comes from the key; the body is @{}@. + let payload = Aeson.object ["bare-tpl" Aeson..= Aeson.object []] + decoded = Aeson.decode' (Aeson.encode payload) :: Maybe GetTemplatesResponse + expected = + TemplateInfo + { tiName = TemplateName "bare-tpl", + tiOrder = Nothing, + tiIndexPatterns = [], + tiSettings = Nothing, + tiMappings = Nothing, + tiAliases = Nothing, + tiVersion = Nothing + } + decoded `shouldBe` Just (GetTemplatesResponse [expected]) + + it "roundtrips a TemplateInfo via the standalone-body shape" $ do + let info = + TemplateInfo + { tiName = TemplateName "roundtrip-tpl", + tiOrder = Just 5, + tiIndexPatterns = [IndexPattern "logs-*"], + tiSettings = Nothing, + tiMappings = Just (toJSON TweetMapping), + tiAliases = Just (AKM.singleton "live" (Aeson.object [])), + tiVersion = Just 2 + } + -- TemplateInfo's ToJSON emits the *body* (no name field); + -- decoding back as a standalone TemplateInfo leaves tiName + -- empty, so we re-inject it. + body = Aeson.encode info + decodedBody = Aeson.decode' body :: Maybe TemplateInfo + decodedBody `shouldBe` Just info {tiName = TemplateName ""} + + it "GetTemplatesResponse roundtrips (key lifted in, then back out)" $ do + let info = + TemplateInfo + { tiName = TemplateName "rt-tpl", + tiOrder = Just 1, + tiIndexPatterns = [IndexPattern "tweet-*"], + tiSettings = Nothing, + tiMappings = Nothing, + tiAliases = Nothing, + tiVersion = Nothing + } + envelope = GetTemplatesResponse [info] + encoded = Aeson.encode envelope + decoded = Aeson.decode' encoded :: Maybe GetTemplatesResponse + decoded `shouldBe` Just envelope + + -- ------------------------------------------------------------------ -- + -- ComponentTemplateInfo / GetComponentTemplatesResponse JSON: -- + -- pure, no ES required. Locks in the GET /_component_template -- + -- envelope shape: -- + -- {"component_templates": [{"name": ..., "component_template": {...}}]} -- + -- ------------------------------------------------------------------ -- + describe "ComponentTemplateInfo JSON" $ do + let -- A representative component-template body matching the wire + -- format ES returns from GET /_component_template. + sampleBody :: ComponentTemplate + sampleBody = + ComponentTemplate + { cpTemplate = Nothing, + cpVersion = Just 7, + cpMeta = Nothing, + cpDeprecated = Nothing + } + + it "decodes a single {name, component_template} entry" $ do + let payload = + Aeson.object + [ "name" Aeson..= ("component-tpl" :: T.Text), + "component_template" Aeson..= sampleBody + ] + decoded = Aeson.decode' (Aeson.encode payload) :: Maybe ComponentTemplateInfo + decoded + `shouldBe` Just + ( ComponentTemplateInfo + { ctiName = TemplateName "component-tpl", + ctiComponentTemplate = sampleBody + } + ) + + it "roundtrips a ComponentTemplateInfo" $ do + let info = + ComponentTemplateInfo + { ctiName = TemplateName "logs-component", + ctiComponentTemplate = sampleBody + } + encoded = Aeson.encode info + decoded = Aeson.decode' encoded :: Maybe ComponentTemplateInfo + decoded `shouldBe` Just info + + it "decodes the full {\"component_templates\": [...]} envelope" $ do + let entries = + [ ComponentTemplateInfo + { ctiName = TemplateName "a", + ctiComponentTemplate = sampleBody + }, + ComponentTemplateInfo + { ctiName = TemplateName "b", + ctiComponentTemplate = sampleBody + } + ] + envelope = GetComponentTemplatesResponse entries + encoded = Aeson.encode envelope + decoded = Aeson.decode' encoded :: Maybe GetComponentTemplatesResponse + decoded `shouldBe` Just envelope + getComponentTemplatesResponseTemplates <$> decoded `shouldBe` Just entries + + it "decodes an empty envelope to an empty list" $ do + let encoded = Aeson.encode (Aeson.object ["component_templates" Aeson..= ([] :: [Aeson.Value])]) + decoded = Aeson.decode' encoded :: Maybe GetComponentTemplatesResponse + decoded `shouldBe` Just (GetComponentTemplatesResponse []) + where + -- Build a TemplateInfo by decoding the body and stamping on the + -- name (mirrors what GetTemplatesResponse's decoder does). + withBody :: TemplateName -> Aeson.Value -> TemplateInfo + withBody name body = + ( case Aeson.decode' (Aeson.encode body) :: Maybe TemplateInfo of + Just info -> info + Nothing -> error "TemplateInfo JSON fixture did not decode" + ) + { tiName = name + } diff --git a/tests/Test/TermVectorsOptionsSpec.hs b/tests/Test/TermVectorsOptionsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/TermVectorsOptionsSpec.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.TermVectorsOptionsSpec (spec) where + +import Data.List (sort) +import Data.Text qualified as T +import Database.Bloodhound.Common.Types +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) + +-- | Stable ordering for equality. The renderer preserves field-declaration +-- order but tests should compare the set of params, not the order. +normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] +normalize = sort + +-- | Boolean helpers rendered as @true@/@false@ strings. +boolTrue :: Maybe T.Text +boolTrue = Just "true" + +boolFalse :: Maybe T.Text +boolFalse = Just "false" + +spec :: Spec +spec = + describe "TermVectorsOptions URI param rendering" $ do + it "defaultTermVectorsOptions emits no params" $ + termVectorsOptionsParams defaultTermVectorsOptions + `shouldBe` [] + + it "preference renders verbatim" $ do + let opts = defaultTermVectorsOptions {tvoPreference = Just "_local"} + termVectorsOptionsParams opts `shouldBe` [("preference", Just "_local")] + + describe "realtime" $ do + it "Just True renders as realtime=true" $ do + let opts = defaultTermVectorsOptions {tvoRealtime = Just True} + termVectorsOptionsParams opts `shouldBe` [("realtime", boolTrue)] + it "Just False renders as realtime=false" $ do + let opts = defaultTermVectorsOptions {tvoRealtime = Just False} + termVectorsOptionsParams opts `shouldBe` [("realtime", boolFalse)] + + it "routing renders verbatim" $ do + let opts = defaultTermVectorsOptions {tvoRouting = Just "user-42"} + termVectorsOptionsParams opts `shouldBe` [("routing", Just "user-42")] + + it "version renders as integer text" $ do + let opts = defaultTermVectorsOptions {tvoVersion = Just 7} + termVectorsOptionsParams opts `shouldBe` [("version", Just "7")] + + it "version renders 0 verbatim (no non-positive filtering)" $ do + -- The renderer must not validate; the server does. Pin this so a + -- future "drop non-positive versions" change is caught here. + let opts = defaultTermVectorsOptions {tvoVersion = Just 0} + termVectorsOptionsParams opts `shouldBe` [("version", Just "0")] + + describe "version_type" $ do + it "internal renders as version_type=internal" $ do + let opts = defaultTermVectorsOptions {tvoVersionType = Just VersionTypeInternal} + termVectorsOptionsParams opts `shouldBe` [("version_type", Just "internal")] + it "external renders as version_type=external" $ do + let opts = defaultTermVectorsOptions {tvoVersionType = Just VersionTypeExternal} + termVectorsOptionsParams opts `shouldBe` [("version_type", Just "external")] + it "external_gte renders as version_type=external_gte" $ do + let opts = defaultTermVectorsOptions {tvoVersionType = Just VersionTypeExternalGTE} + termVectorsOptionsParams opts `shouldBe` [("version_type", Just "external_gte")] + + it "renders every field together when all are populated" $ do + let opts = + defaultTermVectorsOptions + { tvoPreference = Just "_local", + tvoRealtime = Just False, + tvoRouting = Just "user-42", + tvoVersion = Just 7, + tvoVersionType = Just VersionTypeExternalGTE + } + let rendered = termVectorsOptionsParams opts + -- Exactly the 5 documented termvectors URI parameters. + length rendered `shouldBe` 5 + rendered `shouldSatisfy` all (isJust . snd) + normalize rendered + `shouldBe` sort + [ ("preference", Just "_local"), + ("realtime", Just "false"), + ("routing", Just "user-42"), + ("version", Just "7"), + ("version_type", Just "external_gte") + ] + where + isJust (Just _) = True + isJust Nothing = False diff --git a/tests/Test/TermVectorsSpec.hs b/tests/Test/TermVectorsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/TermVectorsSpec.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-x-partial #-} + +module Test.TermVectorsSpec (spec) where + +import Data.Aeson (decode, encode, object, (.=)) +import Data.Aeson.Key (fromText) +import Data.Aeson.Types (parseMaybe, withObject) +import Data.ByteString.Lazy.Char8 qualified as BL8 +import Data.HashMap.Strict qualified as HM +import Data.Maybe (isJust) +import Data.Text (Text) +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + describe "TermVectors JSON round-trip" $ do + let lookupField :: Value -> Text -> Maybe Value + lookupField json field = + parseMaybe (withObject "req" $ \o -> o .: fromText field) json + + it "encodes a minimal TermVectorsRequest (all Nothing) as an empty object" $ + let json = toJSON defaultTermVectorsRequest :: Value + in json `shouldBe` object [] + + it "omits Nothing fields and includes set flags" $ + let req = + ( defaultTermVectorsRequest + { termVectorsRequestFields = Just [FieldName "message", FieldName "user"], + termVectorsRequestTermStatistics = Just True, + termVectorsRequestPositions = Just False + } + ) + json = toJSON req + in do + lookupField json "fields" + `shouldBe` Just (toJSON ["message" :: Text, "user"]) + lookupField json "term_statistics" `shouldBe` Just (toJSON True) + lookupField json "positions" `shouldBe` Just (toJSON False) + lookupField json "offsets" `shouldBe` (Nothing :: Maybe Value) + lookupField json "filter" `shouldBe` (Nothing :: Maybe Value) + + it "encodes a TermVectorsFilter, omitting Nothing thresholds" $ + let f = + defaultTermVectorsFilter + { termVectorsFilterMaxNumTerms = Just 3, + termVectorsFilterMinTermFreq = Just 1 + } + json = toJSON f + in do + lookupField json "max_num_terms" `shouldBe` Just (toJSON (3 :: Int)) + lookupField json "min_term_freq" `shouldBe` Just (toJSON (1 :: Int)) + lookupField json "max_term_freq" `shouldBe` (Nothing :: Maybe Value) + + it "encodes a request with a nested filter block" $ + let req = + defaultTermVectorsRequest + { termVectorsRequestFilter = + Just defaultTermVectorsFilter {termVectorsFilterMaxNumTerms = Just 5} + } + json = toJSON req + in lookupField json "filter" `shouldBe` Just (object ["max_num_terms" .= (5 :: Int)]) + + it "decodes a full Elasticsearch term-vectors response" $ + let bytes = + BL8.pack + "{\"_index\":\"my-index-000001\",\"_id\":\"1\",\"_version\":1,\"found\":true,\"took\":0,\"term_vectors\":{\"text\":{\"field_statistics\":{\"sum_doc_freq\":6,\"doc_count\":1,\"sum_ttf\":5},\"terms\":{\"foo\":{\"doc_freq\":1,\"ttf\":1,\"term_freq\":1,\"tokens\":[{\"position\":0,\"start_offset\":0,\"end_offset\":3,\"payload\":\"payload0\"}]}}}}}" + Just resp = decode bytes + in do + termVectorsIndex resp `shouldBe` "my-index-000001" + termVectorsId resp `shouldBe` DocId "1" + termVectorsVersion resp `shouldBe` Just 1 + termVectorsFound resp `shouldBe` True + termVectorsTook resp `shouldBe` Just 0 + HM.size (termVectorsFieldVectors resp) `shouldBe` 1 + + it "decodes the per-field block, statistics and tokens" $ + let bytes = + BL8.pack + "{\"_index\":\"idx\",\"_id\":\"a\",\"found\":true,\"term_vectors\":{\"text\":{\"field_statistics\":{\"sum_doc_freq\":6,\"doc_count\":1,\"sum_ttf\":5},\"terms\":{\"foo\":{\"doc_freq\":1,\"ttf\":1,\"term_freq\":1,\"tokens\":[{\"position\":0,\"start_offset\":0,\"end_offset\":3,\"payload\":\"payload0\"}]}}}}}" + Just resp = decode bytes :: Maybe TermVectors + Just block = HM.lookup (FieldName "text") (termVectorsFieldVectors resp) + Just stats = fieldTermVectorsFieldStatistics block + Just term = HM.lookup "foo" (fieldTermVectorsTerms block) + token = head (termVectorStatsTokens term) + in do + fieldStatisticsDocCount stats `shouldBe` Just 1 + fieldStatisticsSumDocFreq stats `shouldBe` Just 6 + fieldStatisticsSumTotalTermFreq stats `shouldBe` Just 5 + termVectorStatsTermFreq term `shouldBe` Just 1 + termVectorStatsDocFreq term `shouldBe` Just 1 + termVectorStatsTotalTermFreq term `shouldBe` Just 1 + termVectorTokenPosition token `shouldBe` Just 0 + termVectorTokenPayload token `shouldBe` Just "payload0" + + it "decodes an OpenSearch-style response omitting optional statistics" $ + let bytes = + BL8.pack + "{\"_index\":\"idx\",\"_id\":\"a\",\"found\":true,\"term_vectors\":{\"text\":{\"terms\":{\"bar\":{\"term_freq\":1,\"tokens\":[{\"position\":0,\"start_offset\":0,\"end_offset\":3}]}}}}}" + Just resp = decode bytes :: Maybe TermVectors + Just block = HM.lookup (FieldName "text") (termVectorsFieldVectors resp) + Just term = HM.lookup "bar" (fieldTermVectorsTerms block) + token = head (termVectorStatsTokens term) + in do + fieldTermVectorsFieldStatistics block `shouldBe` Nothing + termVectorStatsDocFreq term `shouldBe` Nothing + termVectorStatsTotalTermFreq term `shouldBe` Nothing + termVectorStatsTermFreq term `shouldBe` Just 1 + termVectorTokenPayload token `shouldBe` Nothing + + it "decodes multiple fields and a term with multiple tokens" $ + let bytes = + BL8.pack + "{\"_index\":\"idx\",\"_id\":\"a\",\"found\":true,\"term_vectors\":{\"title\":{\"terms\":{\"foo\":{\"term_freq\":2,\"tokens\":[{\"position\":0,\"start_offset\":0,\"end_offset\":3},{\"position\":2,\"start_offset\":5,\"end_offset\":8}]}}},\"body\":{\"terms\":{\"bar\":{\"term_freq\":1,\"tokens\":[{\"position\":0,\"start_offset\":0,\"end_offset\":3}]}}}}}" + Just resp = decode bytes :: Maybe TermVectors + fields = termVectorsFieldVectors resp + Just titleBlock = HM.lookup (FieldName "title") fields + Just bodyBlock = HM.lookup (FieldName "body") fields + Just fooTerm = HM.lookup "foo" (fieldTermVectorsTerms titleBlock) + fooTokens = termVectorStatsTokens fooTerm + in do + HM.size fields `shouldBe` 2 + HM.size (fieldTermVectorsTerms titleBlock) `shouldBe` 1 + HM.size (fieldTermVectorsTerms bodyBlock) `shouldBe` 1 + length fooTokens `shouldBe` 2 + termVectorTokenPosition (fooTokens !! 0) `shouldBe` Just 0 + termVectorTokenPosition (fooTokens !! 1) `shouldBe` Just 2 + + it "decodes a found=false response with no term_vectors key" $ + let bytes = + BL8.pack "{\"_index\":\"idx\",\"_id\":\"missing\",\"found\":false}" + Just resp = decode bytes :: Maybe TermVectors + in do + termVectorsFound resp `shouldBe` False + HM.size (termVectorsFieldVectors resp) `shouldBe` 0 + + it "produces valid JSON with expected keys for a fully-populated request body" $ + let req = + defaultTermVectorsRequest + { termVectorsRequestFields = Just [FieldName "msg"], + termVectorsRequestOffsets = Just True, + termVectorsRequestPositions = Just True, + termVectorsRequestTermStatistics = Just True, + termVectorsRequestFieldStatistics = Just True, + termVectorsRequestPayload = Just False, + termVectorsRequestFilter = + Just + defaultTermVectorsFilter + { termVectorsFilterMaxNumTerms = Just 10, + termVectorsFilterMinTermFreq = Just 2 + } + } + encoded = encode req + bytes = BL8.unpack encoded + in do + bytes `shouldContain` "\"fields\"" + bytes `shouldContain` "\"offsets\"" + bytes `shouldContain` "\"positions\"" + bytes `shouldContain` "\"term_statistics\"" + bytes `shouldContain` "\"field_statistics\"" + bytes `shouldContain` "\"payload\"" + bytes `shouldContain` "\"filter\"" + bytes `shouldContain` "\"max_num_terms\"" + + describe "MultiTermVectors JSON round-trip" $ do + it "encodes a minimal MultiTermVectorsDoc as just {_id}" $ + let doc = mkMultiTermVectorsDoc (DocId "1") + json = toJSON doc :: Value + in json `shouldBe` object ["_id" .= DocId "1"] + + it "omits _index when not set, includes it when set" $ + let without = toJSON (mkMultiTermVectorsDoc (DocId "1")) :: Value + withIdx = + toJSON + (mkMultiTermVectorsDoc (DocId "1")) + { multiTermVectorsDocIndex = Just testIndex + } :: + Value + lookupField :: Value -> Text -> Maybe Value + lookupField v field = + parseMaybe (withObject "doc" $ \o -> o .: fromText field) v + in do + lookupField without "_index" `shouldBe` Nothing + lookupField withIdx "_index" `shouldBe` Just (toJSON testIndex) + + it "encodes parameter overrides alongside _id and _index" $ + let doc = + (mkMultiTermVectorsDoc (DocId "42")) + { multiTermVectorsDocIndex = Just testIndex, + multiTermVectorsDocFields = Just [FieldName "message"], + multiTermVectorsDocTermStatistics = Just True, + multiTermVectorsDocOffsets = Just False + } + bytes = BL8.unpack (encode doc) + in do + bytes `shouldContain` "\"_id\":\"42\"" + bytes `shouldContain` "\"_index\"" + bytes `shouldContain` "\"fields\":[\"message\"]" + bytes `shouldContain` "\"term_statistics\":true" + bytes `shouldContain` "\"offsets\":false" + -- Fields the caller left as Nothing must be omitted. + bytes `shouldNotContain` "\"positions\"" + bytes `shouldNotContain` "\"payload\"" + bytes `shouldNotContain` "\"filter\"" + + it "encodes a MultiTermVectors body as {docs:[...]}" $ + let body = + MultiTermVectors + [ mkMultiTermVectorsDoc (DocId "1"), + mkMultiTermVectorsDoc (DocId "2") + ] + Just obj = decode (encode body) :: Maybe Value + lookupDocs :: Value -> Maybe [Value] + lookupDocs v = + parseMaybe (withObject "body" $ \o -> o .: "docs") v + in length <$> lookupDocs obj `shouldBe` Just (2 :: Int) + + it "encodes an empty docs list as {docs:[]}" $ + encode (MultiTermVectors []) `shouldBe` "{\"docs\":[]}" + + it "decodes a realistic MultiTermVectorsResponse with two docs" $ + let bytes = + BL8.pack + "{\"docs\":[{\"_index\":\"idx\",\"_id\":\"1\",\"found\":true,\"term_vectors\":{\"text\":{\"terms\":{\"foo\":{\"term_freq\":1}}}}},{\"_index\":\"idx\",\"_id\":\"2\",\"found\":false}]}" + Just resp = decode bytes :: Maybe MultiTermVectorsResponse + docs = multiTermVectorsResponseDocs resp + in do + length docs `shouldBe` 2 + termVectorsFound (docs !! 0) `shouldBe` True + termVectorsFound (docs !! 1) `shouldBe` False + + it "rejects a MultiTermVectorsResponse missing the docs key" $ + let bytes = BL8.pack "{\"notdocs\":[]}" + result = decode bytes :: Maybe MultiTermVectorsResponse + in result `shouldBe` Nothing + + it "round-trips MultiTermVectors through encode/decode preserving doc count" $ + let body = + MultiTermVectors + [ (mkMultiTermVectorsDoc (DocId "a")) + { multiTermVectorsDocIndex = Just testIndex, + multiTermVectorsDocFields = Just [FieldName "f1", FieldName "f2"] + }, + (mkMultiTermVectorsDoc (DocId "b")) + { multiTermVectorsDocFilter = + Just + defaultTermVectorsFilter + { termVectorsFilterMaxNumTerms = Just 5 + } + } + ] + decoded = decode (encode body) :: Maybe Value + lookupDocs :: Value -> Maybe [Value] + lookupDocs v = + parseMaybe (withObject "body" $ \o -> o .: "docs") v + in do + -- Body has the right envelope shape. + lookupDocs <$> decoded `shouldSatisfy` isJust + -- Encode is stable: re-encoding the decoded JSON produces the same bytes. + encode decoded `shouldBe` encode body + + -- Pure endpoint-shape tests (no live backend required): pin the + -- request builders' path, method, and query-string surface so a + -- future refactor cannot silently change the wire shape or drop the + -- URI-level parameters introduced for the @...With@ variants. + describe "TermVectors request envelope shape" $ do + let idx = testIndex + docId = DocId "42" + body = defaultTermVectorsRequest + opts = + defaultTermVectorsOptions + { tvoPreference = Just "_local", + tvoRealtime = Just False, + tvoRouting = Just "user-42", + tvoVersion = Just 7, + tvoVersionType = Just VersionTypeExternalGTE + } + + it "getTermVectors targets /{index}/_termvectors/{id} with no query params" $ do + let req = getTermVectors idx docId body + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName idx, "_termvectors", "42"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "getTermVectorsWith surfaces TermVectorsOptions as the query string" $ do + let req = getTermVectorsWith opts idx docId body + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName idx, "_termvectors", "42"] + -- Path is unchanged; the five URI params ride on the query string. + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` termVectorsOptionsParams opts + + it "getMultiTermVectors targets /_mtermvectors with no query params" $ do + let req = getMultiTermVectors (MultiTermVectors []) + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_mtermvectors"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "getMultiTermVectorsWith surfaces TermVectorsOptions as the query string" $ do + let req = getMultiTermVectorsWith opts (MultiTermVectors []) + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_mtermvectors"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` termVectorsOptionsParams opts + + it "getMultiTermVectorsByIndex targets /{index}/_mtermvectors with no query params" $ do + let req = getMultiTermVectorsByIndex idx [docId] + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName idx, "_mtermvectors"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "getMultiTermVectorsByIndexWith surfaces TermVectorsOptions as the query string" $ do + let req = getMultiTermVectorsByIndexWith opts idx [docId] + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` [unIndexName idx, "_mtermvectors"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` termVectorsOptionsParams opts + + describe "TermVectors endpoint" $ do + -- The body of these tests needs a live ES/OpenSearch at the URL + -- pointed to by ES_TEST_SERVER (default http://localhost:9200). + it "returns found=true and the message field for an indexed document" $ + withTestEnv $ do + _ <- createExampleIndex + _ <- insertData + let req = + defaultTermVectorsRequest + { termVectorsRequestFields = Just [FieldName "message"], + termVectorsRequestTermStatistics = Just True, + termVectorsRequestFieldStatistics = Just True, + termVectorsRequestOffsets = Just True, + termVectorsRequestPositions = Just True + } + resp <- performBHRequest $ getTermVectors testIndex (DocId "1") req + _ <- deleteExampleIndex + liftIO $ do + termVectorsFound resp `shouldBe` True + termVectorsId resp `shouldBe` DocId "1" + HM.lookup (FieldName "message") (termVectorsFieldVectors resp) + `shouldSatisfy` isJust + + it "returns found=false for a missing document" $ + withTestEnv $ do + _ <- createExampleIndex + let req = defaultTermVectorsRequest + resp <- performBHRequest $ getTermVectors testIndex (DocId "does-not-exist") req + _ <- deleteExampleIndex + liftIO $ termVectorsFound resp `shouldBe` False + + describe "MultiTermVectors endpoint" $ do + -- The body of these tests needs a live ES/OpenSearch at the URL + -- pointed to by ES_TEST_SERVER (default http://localhost:9200). + it "returns one entry per requested document (index in URL)" $ + withTestEnv $ do + _ <- createExampleIndex + _ <- insertData + -- Index a second document so we have two to multi-get. + _ <- + performBHRequest $ + indexDocument + testIndex + defaultIndexDocumentSettings + (object ["message" .= String "second doc"]) + (DocId "2") + _ <- performBHRequest $ refreshIndex testIndex + resp <- + performBHRequest $ + getMultiTermVectorsByIndex testIndex [DocId "1", DocId "2"] + _ <- deleteExampleIndex + liftIO $ do + let docs = multiTermVectorsResponseDocs resp + length docs `shouldBe` 2 + termVectorsFound (docs !! 0) `shouldBe` True + termVectorsFound (docs !! 1) `shouldBe` True + + it "returns found=false for missing documents in the batch" $ + withTestEnv $ do + _ <- createExampleIndex + _ <- insertData + resp <- + performBHRequest $ + getMultiTermVectorsByIndex + testIndex + [DocId "1", DocId "does-not-exist"] + _ <- deleteExampleIndex + liftIO $ do + let docs = multiTermVectorsResponseDocs resp + length docs `shouldBe` 2 + termVectorsFound (docs !! 0) `shouldBe` True + termVectorsFound (docs !! 1) `shouldBe` False + + it "accepts the cross-index body variant with _index on each doc" $ + withTestEnv $ do + _ <- createExampleIndex + _ <- insertData + let body = + MultiTermVectors + [ (mkMultiTermVectorsDoc (DocId "1")) + { multiTermVectorsDocIndex = Just testIndex, + multiTermVectorsDocFields = Just [FieldName "message"] + } + ] + resp <- performBHRequest $ getMultiTermVectors body + _ <- deleteExampleIndex + liftIO $ do + let docs = multiTermVectorsResponseDocs resp + length docs `shouldBe` 1 + termVectorsFound (docs !! 0) `shouldBe` True diff --git a/tests/Test/TermsEnumSpec.hs b/tests/Test/TermsEnumSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/TermsEnumSpec.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-x-partial #-} + +module Test.TermsEnumSpec (spec) where + +import Data.Aeson.Key qualified as AK +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as BL8 +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch7.Client qualified as ClientES7 +import Database.Bloodhound.ElasticSearch7.Requests qualified as Requests +import Database.Bloodhound.ElasticSearch7.Types qualified as ES7Types +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch9.Client qualified as ClientES9 +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + describe "TermsEnumRequest JSON" $ do + it "encodes a field-only request as {\"field\":\"user\"}" $ + let req = ES7Types.defaultTermsEnumRequest (FieldName "user") + Object o = toJSON req + in KM.toList o `shouldBe` [(AK.fromString "field", String "user")] + + it "includes optional fields when provided and always carries field" $ + let req = + (ES7Types.defaultTermsEnumRequest (FieldName "user")) + { ES7Types.termsEnumRequestString = Just "bit", + ES7Types.termsEnumRequestSize = Just 5, + ES7Types.termsEnumRequestTimeout = Just "1s", + ES7Types.termsEnumRequestCaseInsensitive = Just True, + ES7Types.termsEnumRequestIndexFilter = Just (MatchAllQuery Nothing), + ES7Types.termsEnumRequestSearchAfter = Just "last-term" + } + Object o = toJSON req + in do + KM.lookup (AK.fromString "field") o `shouldBe` Just (String "user") + KM.lookup (AK.fromString "string") o `shouldBe` Just (String "bit") + KM.lookup (AK.fromString "size") o `shouldBe` Just (toJSON (5 :: Int)) + KM.lookup (AK.fromString "timeout") o `shouldBe` Just (String "1s") + KM.lookup (AK.fromString "case_insensitive") o `shouldBe` Just (Bool True) + KM.member (AK.fromString "index_filter") o `shouldBe` True + KM.lookup (AK.fromString "index_filter") o `shouldBe` Just (toJSON (MatchAllQuery Nothing)) + KM.lookup (AK.fromString "search_after") o `shouldBe` Just (String "last-term") + -- Removed fields copied by mistake from _field_caps: the + -- server silently ignores them. Their absence is the fix. + KM.member (AK.fromString "searchable") o `shouldBe` False + KM.member (AK.fromString "aggregatable") o `shouldBe` False + + describe "TermsEnumOptions params" $ do + it "renders nothing for defaultTermsEnumOptions" $ + ES7Types.termsEnumOptionsParams ES7Types.defaultTermsEnumOptions `shouldBe` [] + + it "renders allow_no_indices as a boolean string" $ + let opts = ES7Types.defaultTermsEnumOptions {ES7Types.teoAllowNoIndices = Just False} + in lookup "allow_no_indices" (ES7Types.termsEnumOptionsParams opts) `shouldBe` Just (Just "false") + + it "renders ignore_unavailable as a boolean string" $ + let opts = ES7Types.defaultTermsEnumOptions {ES7Types.teoIgnoreUnavailable = Just True} + in lookup "ignore_unavailable" (ES7Types.termsEnumOptionsParams opts) `shouldBe` Just (Just "true") + + it "renders expand_wildcards comma-joined" $ + let opts = + ES7Types.defaultTermsEnumOptions + { ES7Types.teoExpandWildcards = Just [ExpandWildcardsOpen, ExpandWildcardsClosed] + } + in lookup "expand_wildcards" (ES7Types.termsEnumOptionsParams opts) + `shouldBe` Just (Just "open,closed") + + describe "TermsEnumResponse JSON" $ do + it "decodes the canonical ES doc example" $ + let bytes = + BL8.pack + "{\"_shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\"terms\":[\"bitemyapp\",\"notmyapp\"],\"complete\":true}" + Just resp = decode bytes :: Maybe ES7Types.TermsEnumResponse + in do + ES7Types.termsEnumResponseComplete resp `shouldBe` True + ES7Types.termsEnumResponseTerms resp + `shouldBe` [ES7Types.TermValue "bitemyapp", ES7Types.TermValue "notmyapp"] + ES7Types.termsEnumResponseShards resp `shouldSatisfy` isJust + + it "defaults missing terms to []" $ + let bytes = BL8.pack "{\"complete\":true}" + Just resp = decode bytes :: Maybe ES7Types.TermsEnumResponse + in ES7Types.termsEnumResponseTerms resp `shouldBe` [] + + it "defaults missing complete to False (conservative)" $ + let bytes = BL8.pack "{\"terms\":[\"foo\"]}" + Just resp = decode bytes :: Maybe ES7Types.TermsEnumResponse + in ES7Types.termsEnumResponseComplete resp `shouldBe` False + + it "treats missing _shards as Nothing" $ + let bytes = BL8.pack "{\"terms\":[\"foo\"],\"complete\":true}" + Just resp = decode bytes :: Maybe ES7Types.TermsEnumResponse + in ES7Types.termsEnumResponseShards resp `shouldBe` Nothing + + it "decodes an empty terms array" $ + let bytes = BL8.pack "{\"terms\":[],\"complete\":false}" + Just resp = decode bytes :: Maybe ES7Types.TermsEnumResponse + in ES7Types.termsEnumResponseTerms resp `shouldBe` [] + + describe "Terms Enum endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + it "GETs /{index}/_terms_enum with a body" $ do + let req = Requests.getTermsEnum (Just [[qqIndexName|twitter|]]) (FieldName "user") Nothing + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["twitter", "_terms_enum"] + bhRequestBody req `shouldSatisfy` isJust + + it "encodes the field (and optional string) into the request body" $ do + let req = Requests.getTermsEnum (Just [[qqIndexName|twitter|]]) (FieldName "user") (Just "bit") + Just body = bhRequestBody req + Just (Object o) = decode body :: Maybe Value + in KM.lookup (AK.fromString "field") o `shouldBe` Just (String "user") + + it "comma-joins a non-empty index list into the leading segment" $ do + let req = Requests.getTermsEnum (Just [[qqIndexName|twitter-1|], [qqIndexName|twitter-2|]]) (FieldName "user") Nothing + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["twitter-1,twitter-2", "_terms_enum"] + + it "treats Just [] the same as Nothing (bare _terms_enum path)" $ do + let reqNo = Requests.getTermsEnum Nothing (FieldName "user") Nothing + reqEmpty = Requests.getTermsEnum (Just []) (FieldName "user") Nothing + getRawEndpoint (bhRequestEndpoint reqNo) + `shouldBe` getRawEndpoint (bhRequestEndpoint reqEmpty) + + it "honours TermsEnumOptions in the query string" $ do + let req = + Requests.getTermsEnumWith + (Just [[qqIndexName|twitter|]]) + ( ES7Types.defaultTermsEnumOptions + { ES7Types.teoAllowNoIndices = Just True + } + ) + (ES7Types.defaultTermsEnumRequest (FieldName "user")) + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("allow_no_indices", Just "true")] + + describe "Terms Enum endpoint" $ + backendSpecific [ElasticSearch7, ElasticSearch8, ElasticSearch9] $ do + -- _terms_enum only enumerates keyword / numeric / ip / boolean + -- fields; the test mapping's "user" is an analyzed text field and + -- returns no terms, so the live assertions target the "extra" + -- keyword field populated by 'insertExtra'. + it "returns the indexed term for a keyword field" $ + withTestEnv $ do + _ <- insertData + _ <- insertExtra + resp <- getTermsEnumForBackend (Just [testIndex]) (FieldName "extra") Nothing + liftIO $ + ES7Types.termsEnumResponseTerms resp + `shouldSatisfy` elem (ES7Types.TermValue "blah blah") + + it "narrows results with the string prefix" $ + withTestEnv $ do + _ <- insertData + _ <- insertExtra + resp <- getTermsEnumForBackend (Just [testIndex]) (FieldName "extra") (Just "blah") + liftIO $ do + let terms = ES7Types.termsEnumResponseTerms resp + terms `shouldSatisfy` all (\(ES7Types.TermValue t) -> "blah" `T.isPrefixOf` t) + terms `shouldSatisfy` elem (ES7Types.TermValue "blah blah") + + it "returns no terms for a non-matching prefix" $ + withTestEnv $ do + _ <- insertData + _ <- insertExtra + resp <- getTermsEnumForBackend (Just [testIndex]) (FieldName "extra") (Just "zzzzz") + liftIO $ + ES7Types.termsEnumResponseTerms resp `shouldBe` [] + +-- | Dispatch to the right getTermsEnum client based on the detected +-- backend. The wire format is identical across ES 7.10+, 8.x and 9.x; +-- the dispatch exists only because each version has its own +-- 'WithBackend' constraint. +getTermsEnumForBackend :: + Maybe [IndexName] -> + FieldName -> + Maybe Text -> + BH IO ES7Types.TermsEnumResponse +getTermsEnumForBackend mIndices field mString = do + backend <- liftIO detectBackendType + case backend of + Just ElasticSearch7 -> ClientES7.getTermsEnum mIndices field mString + Just ElasticSearch8 -> ClientES8.getTermsEnum mIndices field mString + Just ElasticSearch9 -> ClientES9.getTermsEnum mIndices field mString + _ -> ClientES8.getTermsEnum mIndices field mString diff --git a/tests/Test/TextStructureSpec.hs b/tests/Test/TextStructureSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/TextStructureSpec.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.TextStructureSpec (spec) where + +import Data.Aeson (decode, encode) +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List (sort) +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.ElasticSearch8.Client qualified as ClientES8 +import Database.Bloodhound.ElasticSearch8.Requests qualified as RequestsES8 +import Database.Bloodhound.ElasticSearch8.Types qualified as Types +import TestsUtils.Common +import TestsUtils.Import + +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + +spec :: Spec +spec = + describe "Text structure API (find_message_structure, find_field_structure, test_grok_pattern)" $ do + describe "FindMessageStructureRequest JSON" $ do + it "encodes as {messages: [...]}" $ do + let req = Types.FindMessageStructureRequest ["line one", "line two"] + encode req + `shouldBe` "{\"messages\":[\"line one\",\"line two\"]}" + decode (encode req) `shouldBe` Just req + + it "encodes an empty message list as {messages: []}" $ + encode (Types.FindMessageStructureRequest []) + `shouldBe` "{\"messages\":[]}" + + it "decodes a response missing the messages key as []" $ + decode "{}" `shouldBe` Just (Types.FindMessageStructureRequest []) + + describe "TestGrokPatternRequest JSON" $ do + it "encodes as {grok_pattern, text}" $ do + let req = + Types.TestGrokPatternRequest + "%{IP:ip}" + ["127.0.0.1"] + encode req + `shouldBe` "{\"grok_pattern\":\"%{IP:ip}\",\"text\":[\"127.0.0.1\"]}" + decode (encode req) `shouldBe` Just req + + it "decodes a body missing the text key as []" $ do + let raw = LBS.pack "{\"grok_pattern\":\"%{IP:ip}\"}" + decode raw + `shouldBe` Just (Types.TestGrokPatternRequest "%{IP:ip}" []) + + describe "TestGrokPatternResponse JSON" $ do + it "decodes a populated matches array" $ do + let raw = + LBS.pack + "{\"matches\":[{\"ip\":\"127.0.0.1\"},{}]}" + case decode raw :: Maybe Types.TestGrokPatternResponse of + Just resp -> length (Types.tgprMatches resp) `shouldBe` 2 + Nothing -> expectationFailure "failed to decode TestGrokPatternResponse" + + it "decodes a missing matches key as []" $ + decode "{}" + `shouldBe` Just (Types.TestGrokPatternResponse []) + + it "round-trips a populated response" $ do + let resp = Types.TestGrokPatternResponse {Types.tgprMatches = []} + decode (encode resp) `shouldBe` Just resp + + describe "findMessageStructureOptionsParams URI rendering" $ do + it "defaultFindMessageStructureOptions emits no params" $ + Types.findMessageStructureOptionsParams Types.defaultFindMessageStructureOptions + `shouldBe` [] + + it "renders the message-classifier overrides" $ do + let opts = + Types.defaultFindMessageStructureOptions + { Types.fmsoFormat = Just "ndjson", + Types.fmsoExplain = Just True, + Types.fmsoEcsCompatibility = Just "v1" + } + normalize (Types.findMessageStructureOptionsParams opts) + `shouldBe` sort + [ ("ecs_compatibility", Just "v1"), + ("explain", Just "true"), + ("format", Just "ndjson") + ] + + describe "findFieldStructureOptionsParams URI rendering" $ do + it "defaultFindFieldStructureOptions emits no params" $ + Types.findFieldStructureOptionsParams Types.defaultFindFieldStructureOptions + `shouldBe` [] + + it "renders the required index/field plus overrides" $ do + let opts = + Types.defaultFindFieldStructureOptions + { Types.ffsoIndex = Just "logs", + Types.ffsoField = Just "message", + Types.ffsoDocumentsToSample = Just 1000, + Types.ffsoExplain = Just True + } + normalize (Types.findFieldStructureOptionsParams opts) + `shouldBe` sort + [ ("documents_to_sample", Just "1000"), + ("explain", Just "true"), + ("field", Just "message"), + ("index", Just "logs") + ] + + describe "testGrokPatternOptionsParams URI rendering" $ do + it "defaultTestGrokPatternOptions emits no params" $ + Types.testGrokPatternOptionsParams Types.defaultTestGrokPatternOptions + `shouldBe` [] + + it "renders ecs_compatibility" $ + Types.testGrokPatternOptionsParams + Types.defaultTestGrokPatternOptions + { Types.tgpoEcsCompatibility = Just "v1" + } + `shouldBe` [("ecs_compatibility", Just "v1")] + + describe "endpoint shape" $ do + it "POSTs /_text_structure/find_message_structure with a JSON body" $ do + let req = + RequestsES8.findMessageStructure + (Types.FindMessageStructureRequest ["a", "b"]) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_text_structure", "find_message_structure"] + bhRequestBody req `shouldSatisfy` isJust + + it "findMessageStructureWith appends query params" $ do + let opts = + Types.defaultFindMessageStructureOptions + { Types.fmsoFormat = Just "ndjson" + } + req = + RequestsES8.findMessageStructureWith + opts + (Types.FindMessageStructureRequest ["a"]) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_text_structure", "find_message_structure"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("format", Just "ndjson")] + + it "GETs /_text_structure/find_field_structure with no body" $ do + let req = RequestsES8.findFieldStructure "logs" "message" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_text_structure", "find_field_structure"] + bhRequestBody req `shouldSatisfy` isNothing + normalize (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sort [("field", Just "message"), ("index", Just "logs")] + + it "findFieldStructureWith forwards extra overrides" $ do + let opts = + Types.defaultFindFieldStructureOptions + { Types.ffsoIndex = Just "logs", + Types.ffsoField = Just "message", + Types.ffsoDocumentsToSample = Just 500 + } + req = RequestsES8.findFieldStructureWith opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_text_structure", "find_field_structure"] + bhRequestBody req `shouldSatisfy` isNothing + normalize (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` sort + [ ("documents_to_sample", Just "500"), + ("field", Just "message"), + ("index", Just "logs") + ] + + it "POSTs /_text_structure/test_grok_pattern with a JSON body" $ do + let req = + RequestsES8.testGrokPattern + (Types.TestGrokPatternRequest "%{IP:ip}" ["1.2.3.4"]) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_text_structure", "test_grok_pattern"] + bhRequestBody req `shouldSatisfy` isJust + + it "testGrokPatternWith appends ecs_compatibility" $ do + let req = + RequestsES8.testGrokPatternWith + Types.defaultTestGrokPatternOptions + { Types.tgpoEcsCompatibility = Just "v1" + } + (Types.TestGrokPatternRequest "%{IP:ip}" ["1.2.3.4"]) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_text_structure", "test_grok_pattern"] + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("ecs_compatibility", Just "v1")] + + describe "live integration (requires ES8+ backend)" $ + backendSpecific [ElasticSearch8] $ do + it "test_grok_pattern classifies a simple IP pattern" $ + withTestEnv $ do + resp <- + ClientES8.testGrokPattern + (Types.TestGrokPatternRequest "%{IP:ip}" ["127.0.0.1"]) + liftIO $ length (Types.tgprMatches resp) `shouldBe` 1 diff --git a/tests/Test/TransformSpec.hs b/tests/Test/TransformSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/TransformSpec.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.TransformSpec (spec) where + +import Data.Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.List.NonEmpty qualified as NE +import TestsUtils.Import +import Prelude + +-- | Construct an 'IndexName' from a literal known to be valid (all the +-- samples here are lowercase and within the documented rules). +idxName :: Text -> IndexName +idxName t = case mkIndexName t of + Right n -> n + Left e -> error ("invalid index name " <> show t <> ": " <> show e) + +-- | A canonical pivot transform PUT body matching the ES 7.17 docs example. +-- The @pivot@ body is opaque on the Haskell side (group_by\/aggregations +-- DSL), so it round-trips verbatim. +samplePivotConfigBytes :: LBS.ByteString +samplePivotConfigBytes = + "{\ + \ \"source\": {\"index\": \"kibana_sample_data_ecommerce\"},\ + \ \"dest\": {\"index\": \"kibana_sample_data_ecommerce_transform\"},\ + \ \"pivot\": {\ + \ \"group_by\": {\"customer_id\": {\"terms\": {\"field\": \"customer_id\"}}},\ + \ \"aggregations\": {\"order_count\": {\"value_count\": {\"field\": \"order_id\"}}}\ + \ },\ + \ \"description\": \"ecommerce transform\",\ + \ \"frequency\": \"1m\"\ + \}" + +-- | A latest transform PUT body exercising the typed 'TransformLatest' path. +sampleLatestConfigBytes :: LBS.ByteString +sampleLatestConfigBytes = + "{\ + \ \"source\": {\"index\": [\"logs-*\"]},\ + \ \"dest\": {\"index\": \"latest-logs\", \"pipeline\": \"logs-pipeline\"},\ + \ \"latest\": {\ + \ \"unique_key\": [\"host\", \"service\"],\ + \ \"sort\": \"@timestamp\"\ + \ }\ + \}" + +-- | A continuous transform config carrying a typed @sync@ and @settings@, +-- plus an unknown sibling field (@_meta@-like) preserved in 'tcExtras'. +sampleContinuousConfigBytes :: LBS.ByteString +sampleContinuousConfigBytes = + "{\ + \ \"source\": {\ + \ \"index\": \"events-*\",\ + \ \"query\": {\"match_all\": {}}\ + \ },\ + \ \"dest\": {\"index\": \"events-summary\"},\ + \ \"pivot\": {\"group_by\": {}, \"aggregations\": {}},\ + \ \"sync\": {\ + \ \"time\": {\ + \ \"field\": \"@timestamp\",\ + \ \"delay\": \"60s\"\ + \ }\ + \ },\ + \ \"settings\": {\ + \ \"max_page_search_size\": 500,\ + \ \"docs_per_second\": 200,\ + \ \"align_checkpoints\": true,\ + \ \"dates_as_epoch_millis\": false\ + \ },\ + \ \"created_by\": \"system\"\ + \}" + +-- | A full @GET /_transform@ response with two entries (pivot + latest), +-- including the GET-only @id@ and @version@ fields. +sampleListResponseBytes :: LBS.ByteString +sampleListResponseBytes = + "{\ + \ \"count\": 2,\ + \ \"transforms\": [\ + \ {\ + \ \"id\": \"ecommerce-transform\",\ + \ \"source\": {\"index\": \"ecommerce\"},\ + \ \"dest\": {\"index\": \"ecommerce-summary\"},\ + \ \"pivot\": {\"group_by\": {}, \"aggregations\": {}},\ + \ \"version\": \"7.17.0\"\ + \ },\ + \ {\ + \ \"id\": \"latest-transform\",\ + \ \"source\": {\"index\": \"logs\"},\ + \ \"dest\": {\"index\": \"latest-logs\"},\ + \ \"latest\": {\"unique_key\": [\"host\"], \"sort\": \"@timestamp\"}\ + \ }\ + \ ]\ + \}" + +-- | A @GET /_transform/_stats@ response carrying the state enum and document +-- counters. +sampleStatsResponseBytes :: LBS.ByteString +sampleStatsResponseBytes = + "{\ + \ \"count\": 1,\ + \ \"transforms\": [\ + \ {\ + \ \"id\": \"ecommerce-transform\",\ + \ \"state\": \"started\",\ + \ \"health\": \"green\",\ + \ \"checkpointing\": {\"last\": {\"checkpoint\": 1}},\ + \ \"documents_indexed\": 1000,\ + \ \"documents_processed\": 1200,\ + \ \"documents_deleted\": 0,\ + \ \"documents_failed\": 0\ + \ }\ + \ ]\ + \}" + +-- | A @GET /_transform/{id}/_explain@ response. +sampleExplainResponseBytes :: LBS.ByteString +sampleExplainResponseBytes = + "{\ + \ \"transforms\": [\ + \ {\ + \ \"id\": \"ecommerce-transform\",\ + \ \"state\": {\"task_state\": \"started\"},\ + \ \"checkpointing\": {\"last\": {\"checkpoint\": 1}}\ + \ }\ + \ ]\ + \}" + +-- | A @POST /_transform/_preview@ response. +samplePreviewResponseBytes :: LBS.ByteString +samplePreviewResponseBytes = + "{\ + \ \"preview\": [{\"order_count\": 42}],\ + \ \"generated_dest_index\": {\ + \ \"mappings\": {\"properties\": {\"order_count\": {\"type\": \"long\"}}}\ + \ }\ + \}" + +spec :: Spec +spec = do + describe "TransformState JSON" $ do + it "decodes documented states" $ do + decode "\"started\"" `shouldBe` (Just TransformStateStarted :: Maybe TransformState) + decode "\"stopped\"" `shouldBe` (Just TransformStateStopped :: Maybe TransformState) + decode "\"failed\"" `shouldBe` (Just TransformStateFailed :: Maybe TransformState) + decode "\"indexing\"" `shouldBe` (Just TransformStateIndexing :: Maybe TransformState) + + it "round-trips a custom state through the escape hatch" $ do + let Just (TransformStateCustom t) = + decode "\"restarting\"" :: Maybe TransformState + t `shouldBe` "restarting" + encode (TransformStateCustom "restarting") `shouldBe` "\"restarting\"" + + describe "TransformHealth JSON" $ do + it "decodes documented health values" $ do + decode "\"green\"" `shouldBe` (Just TransformHealthGreen :: Maybe TransformHealth) + decode "\"yellow\"" `shouldBe` (Just TransformHealthYellow :: Maybe TransformHealth) + decode "\"red\"" `shouldBe` (Just TransformHealthRed :: Maybe TransformHealth) + + it "round-trips a custom health through the escape hatch" $ do + let Just (TransformHealthCustom t) = + decode "\"unknown\"" :: Maybe TransformHealth + t `shouldBe` "unknown" + + describe "TransformConfig JSON (PUT body)" $ do + it "decodes a canonical pivot transform" $ do + let Just decoded = decode samplePivotConfigBytes :: Maybe TransformConfig + NE.toList (tsocIndex (tcSource decoded)) + `shouldBe` [IndexPattern "kibana_sample_data_ecommerce"] + tdestIndex (tcDest decoded) `shouldBe` idxName "kibana_sample_data_ecommerce_transform" + -- The pivot body is carried as an opaque Value. + tcPivot decoded `shouldSatisfy` isJust + tcLatest decoded `shouldBe` Nothing + tcDescription decoded `shouldBe` Just "ecommerce transform" + tcFrequency decoded `shouldBe` Just "1m" + tcId decoded `shouldBe` Nothing + + it "decodes a latest transform with typed latest config" $ do + let Just decoded = decode sampleLatestConfigBytes :: Maybe TransformConfig + -- A bare-string-free array index list. + NE.toList (tsocIndex (tcSource decoded)) `shouldBe` [IndexPattern "logs-*"] + tdestPipeline (tcDest decoded) `shouldBe` Just "logs-pipeline" + tcPivot decoded `shouldBe` Nothing + let Just latest = tcLatest decoded + NE.toList (tlUniqueKey latest) + `shouldBe` [FieldName "host", FieldName "service"] + tlSort latest `shouldBe` FieldName "@timestamp" + + it "preserves an opaque query, typed sync/settings and unknown fields in extras" $ do + let Just decoded = decode sampleContinuousConfigBytes :: Maybe TransformConfig + -- The opaque query survives on the source. + tsocQuery (tcSource decoded) `shouldSatisfy` isJust + -- The sync.time sub-object is typed. + let Just sync = tcSync decoded + Just syncTime = tsyTime sync + tstField syncTime `shouldBe` FieldName "@timestamp" + tstDelay syncTime `shouldBe` Just "60s" + -- The settings scalars are typed. + let Just settings = tcSettings decoded + tsMaxPageSearchSize settings `shouldBe` Just 500 + tsDocsPerSecond settings `shouldBe` Just 200 + tsAlignCheckpoints settings `shouldBe` Just True + tsDatesAsEpochMillis settings `shouldBe` Just False + -- The unknown @created_by@ key survives in the config extras catch-all. + KM.lookup "created_by" (tcExtras decoded) `shouldSatisfy` isJust + + it "round-trips a pivot config through encode . decode" $ do + let Just decoded = decode samplePivotConfigBytes :: Maybe TransformConfig + Just roundTripped = decode (encode decoded) :: Maybe TransformConfig + NE.toList (tsocIndex (tcSource roundTripped)) + `shouldBe` [IndexPattern "kibana_sample_data_ecommerce"] + tcDescription roundTripped `shouldBe` Just "ecommerce transform" + tcPivot roundTripped `shouldSatisfy` isJust + + it "round-trips a continuous config with extras through encode . decode" $ do + let Just decoded = decode sampleContinuousConfigBytes :: Maybe TransformConfig + Just roundTripped = decode (encode decoded) :: Maybe TransformConfig + -- The extras catch-all preserves the unknown sibling. + KM.lookup "created_by" (tcExtras roundTripped) `shouldSatisfy` isJust + -- The known @sync@ key is NOT duplicated into extras. + KM.lookup "sync" (tcExtras roundTripped) `shouldBe` Nothing + + it "rejects a config missing required 'source'" $ do + let decoded = + decode + "{\"dest\":{\"index\":\"d\"},\"pivot\":{}}" :: + Maybe TransformConfig + decoded `shouldBe` Nothing + + it "rejects a config missing required 'dest'" $ do + let decoded = + decode + "{\"source\":{\"index\":\"s\"},\"pivot\":{}}" :: + Maybe TransformConfig + decoded `shouldBe` Nothing + + it "rejects a source with an empty 'index' array" $ do + let decoded = + decode + "{\"source\":{\"index\":[]},\"dest\":{\"index\":\"d\"},\"pivot\":{}}" :: + Maybe TransformConfig + decoded `shouldBe` Nothing + + it "accepts a bare-string 'index' and normalises it to a singleton list" $ do + let Just decoded = + decode + "{\"source\":{\"index\":\"single\"},\"dest\":{\"index\":\"d\"},\"pivot\":{}}" :: + Maybe TransformConfig + NE.toList (tsocIndex (tcSource decoded)) `shouldBe` [IndexPattern "single"] + + describe "TransformLatest JSON" $ do + it "rejects a latest with an empty 'unique_key' array" $ do + let decoded = + decode + "{\"unique_key\":[],\"sort\":\"ts\"}" :: + Maybe TransformLatest + decoded `shouldBe` Nothing + + it "accepts a bare-string 'unique_key'" $ do + let Just decoded = + decode + "{\"unique_key\":\"host\",\"sort\":\"ts\"}" :: + Maybe TransformLatest + NE.toList (tlUniqueKey decoded) `shouldBe` [FieldName "host"] + + describe "TransformsResponse JSON (GET response)" $ do + it "decodes the {count, transforms:[...]} envelope" $ do + let Just decoded = decode sampleListResponseBytes :: Maybe TransformsResponse + trCount decoded `shouldBe` Just 2 + length (trTransforms decoded) `shouldBe` 2 + let firstCfg = head (trTransforms decoded) + tcId firstCfg `shouldBe` Just (TransformId "ecommerce-transform") + tcPivot firstCfg `shouldSatisfy` isJust + let secondCfg = trTransforms decoded !! 1 + tcId secondCfg `shouldBe` Just (TransformId "latest-transform") + tcLatest secondCfg `shouldSatisfy` isJust + + it "re-encodes to the same envelope shape" $ do + let Just decoded = decode sampleListResponseBytes :: Maybe TransformsResponse + Just reparsed = decode (encode decoded) :: Maybe TransformsResponse + trCount reparsed `shouldBe` Just 2 + length (trTransforms reparsed) `shouldBe` 2 + + describe "TransformStatsResponse JSON" $ do + it "decodes the state enum and document counters" $ do + let Just decoded = decode sampleStatsResponseBytes :: Maybe TransformStatsResponse + tstrCount decoded `shouldBe` Just 1 + length (tstrStats decoded) `shouldBe` 1 + let entry = head (tstrStats decoded) + tstatId entry `shouldBe` Just (TransformId "ecommerce-transform") + tstatState entry `shouldBe` Just TransformStateStarted + tstatHealth entry `shouldBe` Just TransformHealthGreen + tstatDocumentsIndexed entry `shouldBe` Just 1000 + tstatDocumentsProcessed entry `shouldBe` Just 1200 + -- The opaque checkpointing object survives. + tstatCheckpointing entry `shouldSatisfy` isJust + + it "round-trips through encode . decode" $ do + let Just decoded = decode sampleStatsResponseBytes :: Maybe TransformStatsResponse + Just reparsed = decode (encode decoded) :: Maybe TransformStatsResponse + tstatState (head (tstrStats reparsed)) `shouldBe` Just TransformStateStarted + + describe "TransformExplainResponse JSON" $ do + it "decodes the transforms array carrying the id plus extras" $ do + let Just decoded = decode sampleExplainResponseBytes :: Maybe TransformExplainResponse + length (texrTransforms decoded) `shouldBe` 1 + let entry = head (texrTransforms decoded) + teeId entry `shouldBe` Just (TransformId "ecommerce-transform") + -- The version-dependent @state@ sub-object survives in extras. + KM.lookup "state" (teeExtras entry) `shouldSatisfy` isJust + + describe "PreviewTransformResponse JSON" $ do + it "decodes the preview array and generated dest index" $ do + let Just decoded = decode samplePreviewResponseBytes :: Maybe PreviewTransformResponse + prtvPreview decoded `shouldSatisfy` isJust + prtvGeneratedDestIndex decoded `shouldSatisfy` isJust + length <$> prtvPreview decoded `shouldBe` Just 1 + + describe "PutTransformResponse / DeleteTransformResponse / StopTransformResponse JSON" $ do + it "decodes a PUT response" $ do + let Just decoded = decode "{\"id\":\"x\",\"acknowledged\":true}" :: Maybe PutTransformResponse + ptrId decoded `shouldBe` Just (TransformId "x") + ptrAcknowledged decoded `shouldBe` Just True + + it "decodes a DELETE response with deleted_tasks_count (ES 8+)" $ do + let Just decoded = + decode + "{\"acknowledged\":true,\"deleted_tasks_count\":1}" :: + Maybe DeleteTransformResponse + dtrAcknowledged decoded `shouldBe` Just True + dtrDeletedTasksCount decoded `shouldBe` Just 1 + + it "decodes a STOP response with stopped flag (ES 8+)" $ do + let Just decoded = + decode + "{\"acknowledged\":true,\"stopped\":true}" :: + Maybe StopTransformResponse + stopTAcknowledged decoded `shouldBe` Just True + stopTStopped decoded `shouldBe` Just True + + describe "options params" $ do + it "default options render no query string" $ do + putTransformOptionsParams defaultPutTransformOptions `shouldBe` [] + getTransformsOptionsParams defaultGetTransformsOptions `shouldBe` [] + stopTransformOptionsParams defaultStopTransformOptions `shouldBe` [] + + it "bool params render as true/false strings" $ do + let opts = + defaultPutTransformOptions + { ptoDeferValidation = Just True + } + putTransformOptionsParams opts + `shouldBe` [("defer_validation", Just "true")] + + it "from/size render via showText" $ do + let opts = + defaultGetTransformsOptions + { gtoFrom = Just 10, + gtoSize = Just 25 + } + getTransformsOptionsParams opts + `shouldBe` [("from", Just "10"), ("size", Just "25")] + + it "wait_for_completion passes the timeout string through" $ do + let opts = + defaultStopTransformOptions + { sopoWaitForCompletion = Just "30s" + } + stopTransformOptionsParams opts + `shouldBe` [("wait_for_completion", Just "30s")] + + describe "defaultTransformConfig" $ do + it "builds a minimal config with no pivot/latest" $ do + let cfg = + defaultTransformConfig + (defaultTransformSource (IndexPattern "src")) + (defaultTransformDestination (idxName "dst")) + NE.toList (tsocIndex (tcSource cfg)) `shouldBe` [IndexPattern "src"] + tdestIndex (tcDest cfg) `shouldBe` idxName "dst" + tcPivot cfg `shouldBe` Nothing + tcLatest cfg `shouldBe` Nothing + tcExtras cfg `shouldBe` KM.empty diff --git a/tests/Test/TypesSpec.hs b/tests/Test/TypesSpec.hs --- a/tests/Test/TypesSpec.hs +++ b/tests/Test/TypesSpec.hs @@ -2,7 +2,7 @@ module Test.TypesSpec (spec) where -import qualified Data.Text as T +import Data.Text qualified as T import TestsUtils.Common import TestsUtils.Generators () import TestsUtils.Import @@ -59,3 +59,23 @@ mkIndexName ".." `shouldBe` Left "Is (.|..)" it "Regular should work" $ mkIndexName "hello-world_42" `shouldBe` Right [qqIndexName|hello-world_42|] + + describe "mkIndexPattern" $ do + -- See bloodhound-o8dc: mkIndexName rejects '*', ',', etc., so + -- wildcard / multi-index targets must be built as an IndexPattern + -- via mkIndexPattern. These pin the contract: pattern syntax is + -- permitted, URL-corrupting characters are not. + it "Accepts a wildcard pattern" $ + mkIndexPattern "logs-*" `shouldBe` Right (IndexPattern "logs-*") + it "Accepts a comma-separated list" $ + mkIndexPattern "logs-2024,logs-2025" `shouldBe` Right (IndexPattern "logs-2024,logs-2025") + it "Accepts a leading wildcard" $ + mkIndexPattern "*_audit" `shouldBe` Right (IndexPattern "*_audit") + it "Rejects the empty string" $ + mkIndexPattern "" `shouldBe` Left "Is empty" + it "Rejects a slash (would corrupt the URL path)" $ + mkIndexPattern "a/b" `shouldBe` Left "Includes [/?#]" + it "Rejects a question mark (would inject a query string)" $ + mkIndexPattern "a?b" `shouldBe` Left "Includes [/?#]" + it "Rejects a hash (would inject a fragment)" $ + mkIndexPattern "a#b" `shouldBe` Left "Includes [/?#]" diff --git a/tests/Test/ValidateSpec.hs b/tests/Test/ValidateSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/ValidateSpec.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Test.ValidateSpec (spec) where + +import Data.List (sort) +import Database.Bloodhound.Common.Types +import TestsUtils.Common +import TestsUtils.Import + +-- | Stable ordering for equality: 'withQueries' preserves the order in +-- which params are emitted, but the tests compare the @Set@ of params +-- to avoid coupling to internal field ordering of 'ValidateOptions'. +normalize :: [(Text, Maybe Text)] -> [(Text, Maybe Text)] +normalize = sort + +spec :: Spec +spec = do + -- ------------------------------------------------------------------ -- + -- Pure JSON decoder tests (no ES required). -- + -- ------------------------------------------------------------------ -- + describe "ValidateQueryResponse JSON parsing" $ do + let minimalBody = "{\"valid\":true}" + withShardsBody = + "{\"valid\":true,\ + \\"_shards\":{\"total\":2,\"successful\":2,\"skipped\":0,\"failed\":0}}" + withExplanationsBody = + "{\"valid\":false,\ + \\"_shards\":{\"total\":1,\"successful\":1,\"skipped\":0,\"failed\":0},\ + \\"explanations\":[{\"index\":\"my-idx-000001\",\"valid\":false,\ + \\"error\":\"failed to parse query [foo]\"}]}" + + it "parses the minimal {\"valid\":bool} response" $ do + let Just (r :: ValidateQueryResponse) = decode minimalBody + validateQueryResponseValid r `shouldBe` True + validateQueryResponseShards r `shouldBe` Nothing + validateQueryResponseExplanations r `shouldBe` Nothing + + it "parses _shards when present (all=true form)" $ do + let Just (r :: ValidateQueryResponse) = decode withShardsBody + validateQueryResponseValid r `shouldBe` True + case validateQueryResponseShards r of + Just cs -> do + csTotal cs `shouldBe` 2 + csSuccessful cs `shouldBe` 2 + csSkipped cs `shouldBe` 0 + csFailed cs `shouldBe` 0 + Nothing -> expectationFailure "expected _shards object, got Nothing" + validateQueryResponseExplanations r `shouldBe` Nothing + + it "parses explanations when present (explain=true form)" $ do + let Just (r :: ValidateQueryResponse) = decode withExplanationsBody + validateQueryResponseValid r `shouldBe` False + case validateQueryResponseExplanations r of + Just [e] -> do + validateExplanationIndex e `shouldBe` Just [qqIndexName|my-idx-000001|] + validateExplanationValid e `shouldBe` False + validateExplanationError e `shouldBe` Just "failed to parse query [foo]" + validateExplanationExplanation e `shouldBe` Nothing + other -> + expectationFailure ("expected singleton explanations list, got " <> show other) + + it "round-trips the full response via ToJSON/FromJSON" $ do + let Just (original :: ValidateQueryResponse) = decode withExplanationsBody + reDecoded = decode (encode original) :: Maybe ValidateQueryResponse + Just original `shouldBe` reDecoded + + describe "ValidateExplanation JSON parsing" $ do + let fullBody = + "{\"index\":\"my-idx-000001\",\"shard\":\"0\",\"valid\":true,\ + \\"explanation\":\"+*:* #*:*\"}" + minimalBody = "{\"valid\":true}" + + it "parses all fields when present" $ do + let Just (e :: ValidateExplanation) = decode fullBody + validateExplanationIndex e `shouldBe` Just [qqIndexName|my-idx-000001|] + validateExplanationShard e `shouldBe` Just "0" + validateExplanationValid e `shouldBe` True + validateExplanationExplanation e `shouldBe` Just "+*:* #*:*" + validateExplanationError e `shouldBe` Nothing + + it "parses the minimal {\"valid\":bool} form" $ do + let Just (e :: ValidateExplanation) = decode minimalBody + validateExplanationValid e `shouldBe` True + validateExplanationIndex e `shouldBe` Nothing + + it "uses parseJSON directly (covers the withObject path)" $ + case parseEither parseJSON (object ["valid" .= True]) :: Either String ValidateExplanation of + Right e -> validateExplanationValid e `shouldBe` True + Left err -> expectationFailure ("parseJSON failed: " <> err) + + -- ------------------------------------------------------------------ -- + -- URI param rendering (no ES required). -- + -- ------------------------------------------------------------------ -- + describe "ValidateOptions URI param rendering" $ do + it "defaultValidateOptions emits no params" $ + validateOptionsParams defaultValidateOptions `shouldBe` [] + + it "renders explain and all as true/false strings" $ do + let opts = + defaultValidateOptions + { voExplain = Just True, + voAll = Just False + } + normalize (validateOptionsParams opts) + `shouldBe` [ ("all", Just "false"), + ("explain", Just "true") + ] + + it "renders expand_wildcards as a comma-separated list" $ do + let opts = + defaultValidateOptions + { voExpandWildcards = Just (ExpandWildcardsOpen :| [ExpandWildcardsClosed]) + } + validateOptionsParams opts + `shouldBe` [("expand_wildcards", Just "open,closed")] + + it "renders default_operator in canonical uppercase form" $ do + let optsAnd = defaultValidateOptions {voDefaultOperator = Just And} + optsOr = defaultValidateOptions {voDefaultOperator = Just Or} + normalize (validateOptionsParams optsAnd) `shouldBe` [("default_operator", Just "AND")] + normalize (validateOptionsParams optsOr) `shouldBe` [("default_operator", Just "OR")] + + it "emits the full param set when every field is populated" $ do + let opts = + defaultValidateOptions + { voExplain = Just True, + voAll = Just True, + voRewrite = Just "constant_score_boolean", + voIgnoreUnavailable = Just True, + voAllowNoIndices = Just True, + voExpandWildcards = Just (ExpandWildcardsOpen :| []), + voQ = Just "foo:bar", + voAnalyzer = Just "standard", + voAnalyzeWildcard = Just True, + voDefaultOperator = Just And, + voDf = Just "foo", + voLenient = Just True, + voDefaultField = Just "foo" + } + let rendered = validateOptionsParams opts + length rendered `shouldBe` 13 + map snd rendered `shouldSatisfy` all isJust + sort (map fst rendered) + `shouldBe` sort + [ "allow_no_indices", + "all", + "analyze_wildcard", + "analyzer", + "default_field", + "default_operator", + "df", + "expand_wildcards", + "explain", + "ignore_unavailable", + "lenient", + "q", + "rewrite" + ] + + -- ------------------------------------------------------------------ -- + -- Endpoint shape: pure checks against the BHRequest value; no live -- + -- backend needed. Mirrors the putILMPolicy / createSnapshot shape -- + -- tests. -- + -- ------------------------------------------------------------------ -- + describe "validateQuery endpoint shape" $ do + let idx = [qqIndexName|my-idx|] + q = ValidateQuery (MatchAllQuery Nothing) + + it "POSTs /{index}/_validate/query with no params by default" $ do + let req = validateQuery idx q + bhRequestMethod req `shouldBe` "POST" + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["my-idx", "_validate", "query"] + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "wraps the Query as {\"query\":...} in the body" $ do + let req = validateQuery idx q + bhRequestBody req `shouldSatisfy` isJust + + it "forwards explain=true as a query param" $ do + let opts = defaultValidateOptions {voExplain = Just True} + req = validateQueryWith (Just [idx]) opts q + lookup "explain" (getRawEndpointQueries (bhRequestEndpoint req)) + `shouldBe` Just (Just "true") + + it "builds /_validate/query (no index segment) for Nothing / Just []" $ do + let reqNothing = validateQueryWith Nothing defaultValidateOptions q + reqEmpty = validateQueryWith (Just []) defaultValidateOptions q + getRawEndpoint (bhRequestEndpoint reqNothing) `shouldBe` ["_validate", "query"] + getRawEndpoint (bhRequestEndpoint reqEmpty) `shouldBe` ["_validate", "query"] + + it "comma-joins multiple indices" $ do + let idx2 = [qqIndexName|other-idx|] + req = validateQueryWith (Just [idx, idx2]) defaultValidateOptions q + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["my-idx,other-idx", "_validate", "query"] + + -- ------------------------------------------------------------------ -- + -- Live backend tests (need ES on ES_TEST_SERVER). The pure tests -- + -- above are the must-haves; these exercise the wire round-trip. -- + -- ------------------------------------------------------------------ -- + describe "validateQuery live API" $ do + it "validateQuery accepts a match_all on the test index (valid:true)" $ + withTestEnv $ do + _ <- insertData + r <- + performBHRequest $ + validateQuery testIndex (ValidateQuery (MatchAllQuery Nothing)) + liftIO $ validateQueryResponseValid r `shouldBe` True + + it "validateAll matches validateQuery against the test index" $ + withTestEnv $ do + _ <- insertData + let q = ValidateQuery (MatchAllQuery Nothing) + viaAll <- performBHRequest $ validateAll q + viaIdx <- performBHRequest $ validateQuery testIndex q + liftIO $ do + validateQueryResponseValid viaAll + `shouldBe` validateQueryResponseValid viaIdx + -- validateAll hits POST /_validate/query (no index path), + -- which is the form that surfaces the @_shards@ summary. + validateQueryResponseShards viaAll `shouldSatisfy` (\case Just _ -> True; Nothing -> False) + + it "validateQueryWith explain=true surfaces a non-empty explanations array" $ + withTestEnv $ do + _ <- insertData + r <- + performBHRequest $ + validateQueryWith + (Just [testIndex]) + defaultValidateOptions {voExplain = Just True} + (ValidateQuery (MatchAllQuery Nothing)) + liftIO $ + validateQueryResponseExplanations r `shouldSatisfy` \case + Just xs -> not (null xs) + Nothing -> False diff --git a/tests/Test/VectorTileSpec.hs b/tests/Test/VectorTileSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/VectorTileSpec.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-x-partial #-} + +module Test.VectorTileSpec (spec) where + +import Data.Aeson (decode, encode) +import Data.ByteString.Lazy.Char8 qualified as BL8 +import Database.Bloodhound.Common.Requests qualified as Requests + ( searchVectorTile, + searchVectorTileWith, + ) +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + describe "VectorTileGridAgg JSON" $ do + it "encodes geotile as \"geotile\"" $ + encode VectorTileGridAggGeotile `shouldBe` "\"geotile\"" + + it "encodes geohex as \"geohex\"" $ + encode VectorTileGridAggGeohex `shouldBe` "\"geohex\"" + + it "decodes \"geotile\" / \"geohex\" and rejects unknown values" $ do + decode "\"geotile\"" `shouldBe` Just VectorTileGridAggGeotile + decode "\"geohex\"" `shouldBe` Just VectorTileGridAggGeohex + decode "\"bogus\"" `shouldBe` (Nothing :: Maybe VectorTileGridAgg) + + describe "VectorTileGridType JSON" $ do + it "round-trips grid / point / centroid" $ do + encode VectorTileGridTypeGrid `shouldBe` "\"grid\"" + encode VectorTileGridTypePoint `shouldBe` "\"point\"" + encode VectorTileGridTypeCentroid `shouldBe` "\"centroid\"" + decode "\"point\"" `shouldBe` Just VectorTileGridTypePoint + decode "\"bogus\"" `shouldBe` (Nothing :: Maybe VectorTileGridType) + + describe "Tile coordinate newtypes JSON" $ do + it "TileZoom / TileX / TileY encode as bare numbers" $ do + encode (TileZoom 13 :: TileZoom) `shouldBe` "13" + encode (TileX 4207 :: TileX) `shouldBe` "4207" + encode (TileY 2692 :: TileY) `shouldBe` "2692" + + it "round-trip via decode" $ do + decode "13" `shouldBe` Just (TileZoom 13 :: TileZoom) + decode "0" `shouldBe` Just (TileX 0 :: TileX) + decode "4294967295" `shouldBe` Just (TileY 4294967295 :: TileY) + + describe "VectorTileOptions params" $ do + it "renders nothing for defaultVectorTileOptions" $ + vectorTileOptionsParams defaultVectorTileOptions `shouldBe` [] + + it "renders exact_bounds as a boolean string" $ + let opts = defaultVectorTileOptions {vtoExactBounds = Just True} + in lookup "exact_bounds" (vectorTileOptionsParams opts) `shouldBe` Just (Just "true") + + it "renders with_labels as a boolean string" $ + let opts = defaultVectorTileOptions {vtoWithLabels = Just False} + in lookup "with_labels" (vectorTileOptionsParams opts) `shouldBe` Just (Just "false") + + it "renders extent as a number string" $ + let opts = defaultVectorTileOptions {vtoExtent = Just 2048} + in lookup "extent" (vectorTileOptionsParams opts) `shouldBe` Just (Just "2048") + + it "renders size as a number string" $ + let opts = defaultVectorTileOptions {vtoSize = Just 1000} + in lookup "size" (vectorTileOptionsParams opts) `shouldBe` Just (Just "1000") + + it "renders grid_precision as a number string" $ + let opts = defaultVectorTileOptions {vtoGridPrecision = Just 4} + in lookup "grid_precision" (vectorTileOptionsParams opts) `shouldBe` Just (Just "4") + + it "renders grid_agg as the wire value" $ + let opts = defaultVectorTileOptions {vtoGridAgg = Just VectorTileGridAggGeohex} + in lookup "grid_agg" (vectorTileOptionsParams opts) `shouldBe` Just (Just "geohex") + + it "renders grid_type as the wire value" $ + let opts = defaultVectorTileOptions {vtoGridType = Just VectorTileGridTypeCentroid} + in lookup "grid_type" (vectorTileOptionsParams opts) `shouldBe` Just (Just "centroid") + + it "renders track_total_hits=true for All" $ + let opts = defaultVectorTileOptions {vtoTrackTotalHits = Just VectorTileTrackTotalHitsAll} + in lookup "track_total_hits" (vectorTileOptionsParams opts) `shouldBe` Just (Just "true") + + it "renders track_total_hits=false for Off" $ + let opts = defaultVectorTileOptions {vtoTrackTotalHits = Just VectorTileTrackTotalHitsOff} + in lookup "track_total_hits" (vectorTileOptionsParams opts) `shouldBe` Just (Just "false") + + it "renders track_total_hits=N for UpTo" $ + let opts = defaultVectorTileOptions {vtoTrackTotalHits = Just (VectorTileTrackTotalHitsUpTo 1000)} + in lookup "track_total_hits" (vectorTileOptionsParams opts) `shouldBe` Just (Just "1000") + + it "renders every option at once, preserving order" $ + let opts = + defaultVectorTileOptions + { vtoExactBounds = Just True, + vtoExtent = Just 4096, + vtoGridAgg = Just VectorTileGridAggGeotile, + vtoGridPrecision = Just 8, + vtoGridType = Just VectorTileGridTypeGrid, + vtoSize = Just 10000, + vtoTrackTotalHits = Just VectorTileTrackTotalHitsAll, + vtoWithLabels = Just True + } + params = vectorTileOptionsParams opts + in params + `shouldBe` [ ("exact_bounds", Just "true"), + ("extent", Just "4096"), + ("grid_agg", Just "geotile"), + ("grid_precision", Just "8"), + ("grid_type", Just "grid"), + ("size", Just "10000"), + ("track_total_hits", Just "true"), + ("with_labels", Just "true") + ] + + describe "searchVectorTile endpoint shape" $ do + -- Pure checks against the BHRequest shape; no live backend needed. + let idx = [qqIndexName|museums|] + field = FieldName "location" + zoom = TileZoom 13 + x = TileX 4207 + y = TileY 2692 + search = mkSearch (Just (MatchAllQuery Nothing)) Nothing + + it "GETs /{index}/_mvt/{field}/{zoom}/{x}/{y} with a JSON body" $ do + let req = Requests.searchVectorTile idx field zoom x y search + bhRequestMethod req `shouldBe` "GET" + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["museums", "_mvt", "location", "13", "4207", "2692"] + bhRequestBody req `shouldSatisfy` isJust + + it "serialises the Search body as a JSON object" $ do + let req = Requests.searchVectorTile idx field zoom x y search + Just body = bhRequestBody req + Just value = decode body :: Maybe Value + case value of + Object _ -> pure () + _ -> expectationFailure "searchVectorTile body should be a JSON object" + + it "uses no URI parameters by default" $ do + let req = Requests.searchVectorTile idx field zoom x y search + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "forwards VectorTileOptions as URI parameters" $ do + let opts = defaultVectorTileOptions {vtoExtent = Just 2048, vtoGridPrecision = Just 2} + req = Requests.searchVectorTileWith idx field zoom x y opts search + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("extent", Just "2048"), ("grid_precision", Just "2")] + + it "builds the canonical ES docs example URL" $ do + -- Example from the ES docs: + -- GET museums/_mvt/location/13/4207/2692 + let req = Requests.searchVectorTile idx field zoom x y search + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["museums", "_mvt", "location", "13", "4207", "2692"] + + it "accepts tile coordinate 0/0/0 (whole-world tile)" $ do + let req = Requests.searchVectorTile idx field (TileZoom 0) (TileX 0) (TileY 0) search + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["museums", "_mvt", "location", "0", "0", "0"] + + describe "searchVectorTile binary response" $ + -- Live integration smoke test. The MVT endpoint requires a geo_point + -- or geo_shape field; if the test backend doesn't have one, the + -- request fails with a structured EsError. Either outcome exercises + -- the binary-response decoder: success returns raw bytes; failure + -- parses the JSON error body. The test passes as long as the + -- decoder produces one of these outcomes rather than blowing up. + it "returns bytes or a structured EsError on a live cluster" $ + withTestEnv $ do + _ <- insertData + result <- + tryPerformBHRequest $ + Requests.searchVectorTile + testIndex + (FieldName "user") + (TileZoom 0) + (TileX 0) + (TileY 0) + (mkSearch (Just (MatchAllQuery Nothing)) Nothing) + case result of + Right bytes -> + liftIO $ (BL8.length bytes >= 0) `shouldBe` True + Left (_ :: EsError) -> + -- Server-side rejection (e.g. field is not a geo_point); + -- the binary decoder correctly surfaced the JSON error. + pure () diff --git a/tests/Test/VotingConfigExclusionsSpec.hs b/tests/Test/VotingConfigExclusionsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/VotingConfigExclusionsSpec.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.VotingConfigExclusionsSpec where + +import Data.ByteString.Lazy.Char8 qualified as BL +import Data.List qualified as L +import Data.Text qualified as T +import Database.Bloodhound.Client.Cluster (BackendType (..)) +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Common +import TestsUtils.Import + +spec :: Spec +spec = do + -- ---------------------------------------------------------------- -- + -- votingConfigExclusionOptionsParams: pure URI rendering (no ES). -- + -- ---------------------------------------------------------------- -- + describe "votingConfigExclusionOptionsParams URI rendering" $ do + let normalize :: [(T.Text, Maybe T.Text)] -> [(T.Text, Maybe T.Text)] + normalize = L.sort + + it "defaultVotingConfigExclusionOptions emits no params" $ + votingConfigExclusionOptionsParams defaultVotingConfigExclusionOptions + `shouldBe` [] + + it "renders node_ids as a comma-separated list" $ do + let opts = + defaultVotingConfigExclusionOptions + { votingConfigExclusionOptionsNodeIds = + [FullNodeId "node-a", FullNodeId "node-b"] + } + votingConfigExclusionOptionsParams opts + `shouldBe` [("node_ids", Just "node-a,node-b")] + + it "renders node_names as a comma-separated list" $ do + let opts = + defaultVotingConfigExclusionOptions + { votingConfigExclusionOptionsNodeNames = + [NodeName "node-1", NodeName "node-2", NodeName "node-3"] + } + votingConfigExclusionOptionsParams opts + `shouldBe` [("node_names", Just "node-1,node-2,node-3")] + + it "renders both node_ids and node_names together" $ do + let opts = + defaultVotingConfigExclusionOptions + { votingConfigExclusionOptionsNodeIds = [FullNodeId "a1"], + votingConfigExclusionOptionsNodeNames = [NodeName "n1"] + } + normalize (votingConfigExclusionOptionsParams opts) + `shouldBe` [ ("node_ids", Just "a1"), + ("node_names", Just "n1") + ] + + it "omits an empty list rather than rendering an empty string" $ do + let opts = + defaultVotingConfigExclusionOptions + { votingConfigExclusionOptionsNodeIds = [], + votingConfigExclusionOptionsNodeNames = [NodeName "only-name"] + } + votingConfigExclusionOptionsParams opts + `shouldBe` [("node_names", Just "only-name")] + + -- ---------------------------------------------------------------- -- + -- updateVotingConfigExclusions endpoint shape: pure checks against -- + -- the BHRequest value; no live backend needed. -- + -- ---------------------------------------------------------------- -- + describe "updateVotingConfigExclusions endpoint shape" $ do + it "POSTs /_cluster/voting_config_exclusions" $ do + let opts = + defaultVotingConfigExclusionOptions + { votingConfigExclusionOptionsNodeIds = [FullNodeId "x"] + } + req = Common.updateVotingConfigExclusions opts + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_cluster", "voting_config_exclusions"] + bhRequestMethod req `shouldBe` "POST" + + it "forwards node_ids and node_names as query parameters" $ do + let opts = + defaultVotingConfigExclusionOptions + { votingConfigExclusionOptionsNodeIds = [FullNodeId "a", FullNodeId "b"], + votingConfigExclusionOptionsNodeNames = [NodeName "n"] + } + req = Common.updateVotingConfigExclusions opts + getRawEndpointQueries (bhRequestEndpoint req) + `shouldBe` [("node_ids", Just "a,b"), ("node_names", Just "n")] + + it "sends the empty body (ES requires no body on this endpoint)" $ do + let req = + Common.updateVotingConfigExclusions + defaultVotingConfigExclusionOptions + { votingConfigExclusionOptionsNodeIds = [FullNodeId "x"] + } + -- emptyBody is "" — distinct from no body at all (which would + -- be 'Nothing'); POSTs to this endpoint carry an empty string + -- so the server sees a body-shaped request without content. + bhRequestBody req `shouldBe` Just (BL.pack "") + + -- ---------------------------------------------------------------- -- + -- clearVotingConfigExclusions endpoint shape: pure checks. -- + -- ---------------------------------------------------------------- -- + describe "clearVotingConfigExclusions endpoint shape" $ do + it "DELETEs /_cluster/voting_config_exclusions" $ do + let req = Common.clearVotingConfigExclusions + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_cluster", "voting_config_exclusions"] + bhRequestMethod req `shouldBe` "DELETE" + + it "sends no query string" $ do + let req = Common.clearVotingConfigExclusions + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + it "sends no body" $ do + let req = Common.clearVotingConfigExclusions + bhRequestBody req `shouldBe` Nothing + + -- ---------------------------------------------------------------- -- + -- Distinctness guard: prevents a copy-paste regression that -- + -- re-points updateVotingConfigExclusions at clearVotingConfig- -- + -- Exclusions's DELETE (or vice versa). Same precedent as the -- + -- clearKnnCache/warmupKnnIndex guard in Test.KnnClearCacheSpec. -- + -- ---------------------------------------------------------------- -- + describe "POST/DELETE distinctness" $ + it "the two endpoints differ in HTTP method" $ do + let postReq = + Common.updateVotingConfigExclusions + defaultVotingConfigExclusionOptions + { votingConfigExclusionOptionsNodeIds = [FullNodeId "x"] + } + deleteReq = Common.clearVotingConfigExclusions + bhRequestMethod postReq `shouldNotBe` bhRequestMethod deleteReq + + -- ---------------------------------------------------------------- -- + -- Live round-trip: gated on Elasticsearch backends only (OpenSearch -- + -- does not expose voting_config_exclusions). Verifies the empty-body -- + -- 200 -> Acknowledged True mapping that 'parseEsResponse' now handles -- + -- via null-substitution (see the Haddock on -- + -- 'updateVotingConfigExclusions' and 'Test.ParseEsResponseSpec'). -- + -- -- + -- The endpoint is self-cleaning: calling 'clearVotingConfigExclusions' -- + -- in the test body removes whatever the prior 'updateVotingConfig- -- + -- Exclusions' call added. We still wrap the round-trip in a -- + -- 'bracket_' that issues a defensive clear on teardown so a thrown -- + -- exception or unexpected 4xx from the POST can't leak test state. -- + -- ---------------------------------------------------------------- -- + describe "voting_config_exclusions live round-trip" $ + backendSpecific [ElasticSearch7, ElasticSearch8, ElasticSearch9] $ do + let clearAll = + withTestEnv $ + void $ + tryPerformBHRequest Common.clearVotingConfigExclusions + + before_ clearAll . after_ clearAll $ + it "adds an exclusion for a fake node id, then sees the clear land as Acknowledged" $ do + withTestEnv $ do + Acknowledged added <- + performBHRequest $ + Common.updateVotingConfigExclusions + defaultVotingConfigExclusionOptions + { votingConfigExclusionOptionsNodeIds = [FullNodeId "fake-node-id"] + } + liftIO $ added `shouldBe` True + + Acknowledged cleared <- + performBHRequest Common.clearVotingConfigExclusions + liftIO $ cleared `shouldBe` True diff --git a/tests/Test/WatcherSpec.hs b/tests/Test/WatcherSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/WatcherSpec.hs @@ -0,0 +1,532 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.WatcherSpec (spec) where + +import Data.Aeson +import Data.Aeson.Key (fromText, toText) +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Lazy.Char8 qualified as LBS +import Database.Bloodhound.Common.Requests qualified as Common +import TestsUtils.Import +import Prelude + +------------------------------------------------------------------------------ +-- Sample payloads (shaped after the ES 7.17 Watcher docs) +------------------------------------------------------------------------------ + +-- | Minimal @PUT /_watcher/watch/{id}@ body: a schedule + a simple input + +-- a condition + one logging action. The DSL is opaque on the Haskell side +-- (see "Database.Bloodhound.Internal.Versions.Common.Types.Watcher"), so +-- the spec only checks that the carried 'Value' round-trips verbatim. +samplePutBodyBytes :: LBS.ByteString +samplePutBodyBytes = + "{\ + \ \"trigger\": {\"schedule\": {\"cron\": \"0 0/5 * * * ?\"}},\ + \ \"input\": {\"search\": {\"request\": {\"indices\": [\"logs-*\"], \"body\": {\"size\": 0}}}},\ + \ \"condition\": {\"compare\": {\"ctx.payload.hits.total\": {\"gt\": 5}}},\ + \ \"actions\": {\"log_hits\": {\"logging\": {\"text\": \"found {{ctx.payload.hits.total}} hits\"}}}\ + \}" + +-- | @GET /_watcher/watch/{id}@ response: the typed envelope (@_id@, +-- @_version@, @found@, @_seq_no@, @_primary_term@) plus an opaque @watch@ +-- sub-object and a typed @status@ sub-object carrying @state@ + +-- @version@ + an unknown sibling (@last_checked@) that should land in +-- @wsExtras@. +sampleGetResponseBytes :: LBS.ByteString +sampleGetResponseBytes = + "{\ + \ \"_id\": \"log_event_watch\",\ + \ \"_version\": 2,\ + \ \"_seq_no\": 4,\ + \ \"_primary_term\": 1,\ + \ \"found\": true,\ + \ \"watch\": {\ + \ \"trigger\": {\"schedule\": {\"cron\": \"0 0/5 * * * ?\"}},\ + \ \"input\": {\"none\": {}},\ + \ \"condition\": {\"always\": {}},\ + \ \"actions\": {\"log_hits\": {\"logging\": {\"text\": \"hi\"}}}\ + \ },\ + \ \"status\": {\ + \ \"state\": \"active\",\ + \ \"version\": 2,\ + \ \"last_checked\": \"2024-05-29T13:37:00.000Z\"\ + \ }\ + \}" + +-- | @POST /_watcher/watch/{id}/_execute@ response: a typed @_id@ plus an +-- opaque @watch_record@, with an unknown sibling (@node@) for the extras +-- catch-all. +sampleExecuteResponseBytes :: LBS.ByteString +sampleExecuteResponseBytes = + "{\ + \ \"_id\": \"log_event_watch\",\ + \ \"watch_record\": {\ + \ \"watch_id\": \"log_event_watch\",\ + \ \"state\": \"executed\",\ + \ \"input_event\": {},\ + \ \"metadata\": {},\ + \ \"actions\": []\ + \ },\ + \ \"node\": \"node-1\"\ + \}" + +-- | @PUT /_watcher/watch/{id}/_ack@ response: top-level @ack_state@ plus a +-- nested @ack_watch_status@. +sampleAckResponseBytes :: LBS.ByteString +sampleAckResponseBytes = + "{\ + \ \"ack_state\": \"acks_needed\",\ + \ \"ack_watch_status\": {\ + \ \"ack_state\": \"acks_needed\",\ + \ \"state\": \"active\",\ + \ \"version\": 3\ + \ }\ + \}" + +-- | @PUT /_watcher/watch/{id}/_activate@ (or @_deactivate@) response. +sampleActivationResponseBytes :: LBS.ByteString +sampleActivationResponseBytes = + "{\ + \ \"ack_state\": \"acks_needed\",\ + \ \"state\": \"active\",\ + \ \"version\": 2\ + \}" + +-- | @GET /_watcher/_stats@ response. +sampleStatsResponseBytes :: LBS.ByteString +sampleStatsResponseBytes = + "{\ + \ \"_nodes\": {\"total\": 1, \"successful\": 1, \"failed\": 0},\ + \ \"cluster_name\": \"elasticsearch\",\ + \ \"stats\": {\ + \ \"watch_count\": 5,\ + \ \"execution_state\": \"started\",\ + \ \"pending_watches\": 0,\ + \ \"thread_pool\": {\"queue_size\": 0, \"max_size\": 0},\ + \ \"current_watches\": []\ + \ }\ + \}" + +-- | @GET /_watcher/settings@ response. +sampleSettingsResponseBytes :: LBS.ByteString +sampleSettingsResponseBytes = + "{\ + \ \"persistent\": {\"xpack\": {\"watcher\": {\"execution\": {\"scroll\": {\"size\": 100}}}}},\ + \ \"transient\": {},\ + \ \"defaults\": {\"xpack\": {\"watcher\": {\"enabled\": true}}}\ + \}" + +------------------------------------------------------------------------------ +-- JSON round-trip / decode tests +------------------------------------------------------------------------------ + +spec :: Spec +spec = describe "X-Pack Watcher API" $ do + describe "WatchId JSON" $ do + it "round-trips as a bare JSON string" $ do + let Just decoded = decode "\"my-watch\"" :: Maybe WatchId + unWatchId decoded `shouldBe` "my-watch" + encode (WatchId "my-watch") `shouldBe` "\"my-watch\"" + + it "rejects a non-string value" $ do + let decoded = decode "42" :: Maybe WatchId + decoded `shouldBe` Nothing + + describe "WatchBody JSON (PUT body)" $ do + it "encodes the carried Value verbatim" $ do + let body = object ["trigger" .= object ["schedule" .= object ["cron" .= String "0 0 0 * * ?"]]] + encoded = encode (WatchBody body) + encoded `shouldBe` encode body + + it "decodes an object body verbatim" $ do + let Just decoded = decode samplePutBodyBytes :: Maybe WatchBody + Just expected = decode samplePutBodyBytes :: Maybe Value + unWatchBody decoded `shouldBe` expected + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode samplePutBodyBytes :: Maybe WatchBody + (decode . encode) decoded `shouldBe` Just decoded + + it "rejects a non-object body (array)" $ do + let decoded = decode "[1,2,3]" :: Maybe WatchBody + decoded `shouldBe` Nothing + + it "rejects a non-object body (bare number)" $ do + let decoded = decode "5" :: Maybe WatchBody + decoded `shouldBe` Nothing + + describe "WatchState JSON" $ do + it "round-trips known constructors" $ do + encode WatchStateActive `shouldBe` "\"active\"" + encode WatchStateInactive `shouldBe` "\"inactive\"" + encode WatchStateAcknowledged `shouldBe` "\"acknowledged\"" + encode WatchStateExecutionFailed `shouldBe` "\"execution_failed\"" + + it "falls back to WatchStateCustom for unknown values" $ do + let Just decoded = decode "\"primordial\"" :: Maybe WatchState + decoded `shouldBe` WatchStateCustom "primordial" + encode decoded `shouldBe` "\"primordial\"" + + describe "Watch (GET response) JSON" $ do + it "decodes the typed envelope + opaque body + typed status" $ do + let Just decoded = decode sampleGetResponseBytes :: Maybe Watch + watchId decoded `shouldBe` WatchId "log_event_watch" + watchVersion decoded `shouldBe` Just 2 + watchSeqNo decoded `shouldBe` Just 4 + watchPrimaryTerm decoded `shouldBe` Just 1 + watchFound decoded `shouldBe` Just True + wsState <$> watchStatus decoded `shouldBe` Just (Just WatchStateActive) + wsVersion <$> watchStatus decoded `shouldBe` Just (Just 2) + + it "collects unknown status siblings into wsExtras" $ do + let Just decoded = decode sampleGetResponseBytes :: Maybe Watch + status = watchStatus decoded + status `shouldSatisfy` isJust + let Just s = status + Just extras = wsExtras s + extras `shouldContainKey` "last_checked" + + it "stamps a placeholder id when @_id@ is absent" $ do + let Just decoded = decode "{\"found\": false}" :: Maybe Watch + watchId decoded `shouldBe` WatchId "" + + it "round-trips through ToJSON/FromJSON (modulo the extras catch-all)" $ do + let Just decoded = decode sampleGetResponseBytes :: Maybe Watch + (decode . encode) decoded `shouldBe` Just decoded + + describe "ExecuteWatchResponse JSON" $ do + it "decodes the typed id + opaque watch_record" $ do + let Just decoded = decode sampleExecuteResponseBytes :: Maybe ExecuteWatchResponse + ewrId decoded `shouldBe` WatchId "log_event_watch" + ewrWatchRecord decoded `shouldSatisfy` isJust + + it "collects unknown siblings into ewrExtras" $ do + let Just decoded = decode sampleExecuteResponseBytes :: Maybe ExecuteWatchResponse + Just extras = ewrExtras decoded + extras `shouldContainKey` "node" + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode sampleExecuteResponseBytes :: Maybe ExecuteWatchResponse + (decode . encode) decoded `shouldBe` Just decoded + + describe "AckState JSON" $ do + it "round-trips known constructors" $ do + encode AckStateAcksNeeded `shouldBe` "\"acks_needed\"" + encode AckStateAcksRequired `shouldBe` "\"acks_required\"" + + it "falls back to AckStateCustom for unknown values" $ do + let Just decoded = decode "\"weird\"" :: Maybe AckState + decoded `shouldBe` AckStateCustom "weird" + + describe "WatchExecutionState JSON" $ do + it "round-trips known constructors" $ do + encode WatchExecutionStateActive `shouldBe` "\"active\"" + encode WatchExecutionStateInactive `shouldBe` "\"inactive\"" + encode WatchExecutionStateExecuted `shouldBe` "\"executed\"" + encode WatchExecutionStateThrottled `shouldBe` "\"throttled\"" + + it "falls back to WatchExecutionStateCustom for unknown values" $ do + let Just decoded = decode "\"frozen\"" :: Maybe WatchExecutionState + decoded `shouldBe` WatchExecutionStateCustom "frozen" + + describe "AckWatchResponse JSON" $ do + it "decodes the top-level ack_state + nested ack_watch_status" $ do + let Just decoded = decode sampleAckResponseBytes :: Maybe AckWatchResponse + awrAckState decoded `shouldBe` Just AckStateAcksNeeded + awrWatchStatus decoded `shouldSatisfy` isJust + let Just nested = awrWatchStatus decoded + wsrState nested `shouldBe` Just WatchExecutionStateActive + wsrVersion nested `shouldBe` Just 3 + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode sampleAckResponseBytes :: Maybe AckWatchResponse + (decode . encode) decoded `shouldBe` Just decoded + + describe "WatchStateResponse JSON (activate/deactivate)" $ do + it "decodes ack_state + state + version" $ do + let Just decoded = decode sampleActivationResponseBytes :: Maybe WatchStateResponse + wsrAckState decoded `shouldBe` Just AckStateAcksNeeded + wsrState decoded `shouldBe` Just WatchExecutionStateActive + wsrVersion decoded `shouldBe` Just 2 + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode sampleActivationResponseBytes :: Maybe WatchStateResponse + (decode . encode) decoded `shouldBe` Just decoded + + describe "WatcherStatsResponse JSON" $ do + it "decodes the typed summary fields" $ do + let Just decoded = decode sampleStatsResponseBytes :: Maybe WatcherStatsResponse + watcherStatsClusterName decoded `shouldBe` Just "elasticsearch" + watcherStatsStats decoded `shouldSatisfy` isJust + let Just summary = watcherStatsStats decoded + wssWatchCount summary `shouldBe` Just 5 + wssExecutionState summary `shouldBe` Just "started" + wssPendingWatches summary `shouldBe` Just 0 + wssThreadPool summary `shouldSatisfy` isJust + + it "collects unknown summary siblings into wssExtras" $ do + let Just decoded = decode sampleStatsResponseBytes :: Maybe WatcherStatsResponse + Just summary = watcherStatsStats decoded + Just extras = wssExtras summary + extras `shouldContainKey` "current_watches" + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode sampleStatsResponseBytes :: Maybe WatcherStatsResponse + (decode . encode) decoded `shouldBe` Just decoded + + describe "WatcherSettings JSON" $ do + it "decodes persistent/transient/defaults" $ do + let Just decoded = decode sampleSettingsResponseBytes :: Maybe WatcherSettings + watcherSettingsPersistent decoded `shouldSatisfy` isJust + watcherSettingsTransient decoded `shouldSatisfy` isJust + watcherSettingsDefaults decoded `shouldSatisfy` isJust + + it "round-trips through ToJSON/FromJSON" $ do + let Just decoded = decode sampleSettingsResponseBytes :: Maybe WatcherSettings + (decode . encode) decoded `shouldBe` Just decoded + + describe "ExecuteWatchOptions params" $ do + it "omits Nothing fields" $ do + executeWatchOptionsParams defaultExecuteWatchOptions `shouldBe` [] + + it "renders set fields as true/false strings" $ do + let opts = + defaultExecuteWatchOptions + { ewoDebug = Just True, + ewoRecordExecution = Just False + } + executeWatchOptionsParams opts + `shouldBe` [("debug", Just "true"), ("record_execution", Just "false")] + + describe "WatcherStatsMetric path" $ do + it "renders the built-in metrics" $ do + watcherStatsMetricPath WatcherStatsMetricAll `shouldBe` "_all" + watcherStatsMetricPath WatcherStatsMetricQueuedWatches + `shouldBe` "queued_watches" + watcherStatsMetricPath WatcherStatsMetricPendingWatches + `shouldBe` "pending_watches" + watcherStatsMetricPath WatcherStatsMetricExecutionThreadPool + `shouldBe` "execution_thread_pool" + + it "round-trips a custom metric" $ do + watcherStatsMetricPath (WatcherStatsMetricCustom "custom_metric") + `shouldBe` "custom_metric" + + ------------------------------------------------------------------------------ + -- Request-builder endpoint shapes + ------------------------------------------------------------------------------ + + describe "putWatch endpoint shape" $ do + let body = WatchBody (object ["trigger" .= object ["schedule" .= object ["cron" .= String "0 0 * * * ?"]]]) + req = Common.putWatch (WatchId "my-watch") body + + it "PUTs /_watcher/watch/{id}" $ do + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_watcher", "watch", "my-watch"] + + it "uses the PUT method" $ do + bhRequestMethod req `shouldBe` "PUT" + + it "attaches the encoded body" $ do + bhRequestBody req `shouldBe` Just (encode body) + + it "carries no query string" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "getWatch endpoint shape" $ do + let req = Common.getWatch (WatchId "log_event_watch") + + it "GETs /_watcher/watch/{id}" $ do + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_watcher", "watch", "log_event_watch"] + + it "uses the GET method" $ do + bhRequestMethod req `shouldBe` "GET" + + it "carries no request body" $ do + bhRequestBody req `shouldBe` Nothing + + it "carries no query string" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "deleteWatch endpoint shape" $ do + let req = Common.deleteWatch (WatchId "stale") + + it "DELETEs /_watcher/watch/{id}" $ do + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_watcher", "watch", "stale"] + + it "uses the DELETE method" $ do + bhRequestMethod req `shouldBe` "DELETE" + + it "carries no request body" $ do + bhRequestBody req `shouldBe` Nothing + + describe "executeWatch endpoint shape (no body, no options)" $ do + let req = Common.executeWatch (WatchId "log_event_watch") + + it "POSTs /_watcher/watch/{id}/_execute" $ do + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_watcher", "watch", "log_event_watch", "_execute"] + + it "uses the POST method" $ do + bhRequestMethod req `shouldBe` "POST" + + it "sends an empty body" $ do + bhRequestBody req `shouldBe` Just "" + + it "carries no query string by default" $ do + getRawEndpointQueries (bhRequestEndpoint req) `shouldBe` [] + + describe "executeWatchWith endpoint shape (body + options)" $ do + let opts = + defaultExecuteWatchOptions + { ewoDebug = Just True, + ewoRecordExecution = Just False + } + inlineBody = + Just + ( ExecuteWatchRequest + ( object + [ "trigger" .= object ["schedule" .= object ["cron" .= String "0 0 * * * ?"]], + "input" .= object ["none" .= object []] + ] + ) + ) + req = Common.executeWatchWith opts (WatchId "w") inlineBody + + it "POSTs /_watcher/watch/{id}/_execute with the right path" $ do + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_watcher", "watch", "w", "_execute"] + + it "uses the POST method" $ do + bhRequestMethod req `shouldBe` "POST" + + it "attaches the encoded inline body" $ do + bhRequestBody req `shouldSatisfy` isJust + + it "emits the debug and record_execution query params" $ do + getRawEndpointQueries (bhRequestEndpoint req) + `shouldContain` [("debug", Just "true"), ("record_execution", Just "false")] + + describe "ackWatch endpoint shape" $ do + let req = Common.ackWatch (WatchId "w") + + it "PUTs /_watcher/watch/{id}/_ack" $ do + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_watcher", "watch", "w", "_ack"] + + it "uses the PUT method" $ do + bhRequestMethod req `shouldBe` "PUT" + + it "sends an empty body" $ do + bhRequestBody req `shouldBe` Just "" + + describe "activateWatch endpoint shape" $ do + let req = Common.activateWatch (WatchId "w") + + it "PUTs /_watcher/watch/{id}/_activate" $ do + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_watcher", "watch", "w", "_activate"] + + it "uses the PUT method" $ do + bhRequestMethod req `shouldBe` "PUT" + + it "sends an empty body" $ do + bhRequestBody req `shouldBe` Just "" + + describe "deactivateWatch endpoint shape" $ do + let req = Common.deactivateWatch (WatchId "w") + + it "PUTs /_watcher/watch/{id}/_deactivate" $ do + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_watcher", "watch", "w", "_deactivate"] + + it "uses the PUT method" $ do + bhRequestMethod req `shouldBe` "PUT" + + it "sends an empty body" $ do + bhRequestBody req `shouldBe` Just "" + + describe "watcherStats endpoint shape" $ do + it "GETs /_watcher/_stats with Nothing" $ do + let req = Common.watcherStats + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_watcher", "_stats"] + bhRequestMethod req `shouldBe` "GET" + bhRequestBody req `shouldBe` Nothing + + it "GETs /_watcher/_stats/{metric} with a specific metric" $ do + let req = Common.watcherStatsWith (Just WatcherStatsMetricQueuedWatches) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_watcher", "_stats", "queued_watches"] + bhRequestMethod req `shouldBe` "GET" + + it "expands WatcherStatsMetricAll to /_watcher/_stats/_all" $ do + let req = Common.watcherStatsWith (Just WatcherStatsMetricAll) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_watcher", "_stats", "_all"] + + it "round-trips a custom metric through the path" $ do + let req = Common.watcherStatsWith (Just (WatcherStatsMetricCustom "custom")) + getRawEndpoint (bhRequestEndpoint req) + `shouldBe` ["_watcher", "_stats", "custom"] + + describe "getWatcherSettings endpoint shape" $ do + let req = Common.getWatcherSettings + + it "GETs /_watcher/settings" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_watcher", "settings"] + bhRequestMethod req `shouldBe` "GET" + bhRequestBody req `shouldBe` Nothing + + describe "updateWatcherSettings endpoint shape" $ do + let body = + WatcherSettings + { watcherSettingsPersistent = + Just (object ["xpack" .= object ["watcher" .= object ["enabled" .= Bool True]]]), + watcherSettingsTransient = Nothing, + watcherSettingsDefaults = Nothing, + watcherSettingsExtras = Nothing + } + req = Common.updateWatcherSettings body + + it "PUTs /_watcher/settings" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_watcher", "settings"] + bhRequestMethod req `shouldBe` "PUT" + bhRequestBody req `shouldBe` Just (encode body) + + describe "startWatcher endpoint shape" $ do + let req = Common.startWatcher + + it "POSTs /_watcher/_start" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_watcher", "_start"] + bhRequestMethod req `shouldBe` "POST" + bhRequestBody req `shouldBe` Just "" + + describe "stopWatcher endpoint shape" $ do + let req = Common.stopWatcher + + it "POSTs /_watcher/_stop" $ do + getRawEndpoint (bhRequestEndpoint req) `shouldBe` ["_watcher", "_stop"] + bhRequestMethod req `shouldBe` "POST" + bhRequestBody req `shouldBe` Just "" + +------------------------------------------------------------------------------ +-- Helpers +------------------------------------------------------------------------------ + +-- | Assert that a 'KM.KeyMap' contains the given key. The 'Text' argument +-- is converted with 'fromText' so the spec reads naturally. +shouldContainKey :: + (HasCallStack, Show a) => + KM.KeyMap a -> + Text -> + Expectation +shouldContainKey km key + | KM.member (fromText key) km = pure () + | otherwise = + expectationFailure $ + "expected KeyMap to contain key " + <> show key + <> ", got keys: " + <> show (map toText (KM.keys km)) diff --git a/tests/TestsUtils/ApproxEq.hs b/tests/TestsUtils/ApproxEq.hs --- a/tests/TestsUtils/ApproxEq.hs +++ b/tests/TestsUtils/ApproxEq.hs @@ -3,7 +3,7 @@ module TestsUtils.ApproxEq where -import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty qualified as NE import Database.Bloodhound import TestsUtils.Import @@ -58,6 +58,14 @@ instance ApproxEq InitialShardCount where (=~) = (==) instance ApproxEq FSType where (=~) = (==) + +instance ApproxEq TimeUnits where (=~) = (==) + +instance ApproxEq EsDuration where (=~) = (==) + +instance ApproxEq DiskWatermark where (=~) = (==) + +instance ApproxEq Compression where (=~) = (==) -- | Due to the way nodeattrfilters get serialized here, they may come -- out in a different order, but they are morally equivalent diff --git a/tests/TestsUtils/Common.hs b/tests/TestsUtils/Common.hs --- a/tests/TestsUtils/Common.hs +++ b/tests/TestsUtils/Common.hs @@ -4,21 +4,30 @@ module TestsUtils.Common where -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Data.Versions as Versions +import Control.Exception (SomeException, try) +import Data.Char (toLower) +import Data.List (stripPrefix) +import Data.List qualified as L +import Data.Map qualified as M +import Data.Text qualified as T +import Data.Versions qualified as Versions +import Database.Bloodhound.Client.Cluster (BackendType (..)) import Lens.Micro (toListOf) -import qualified Network.HTTP.Types.Status as NHTS +import Network.HTTP.Types.Method qualified as NHTM +import Network.HTTP.Types.Status qualified as NHTS +import System.Environment (lookupEnv) import TestsUtils.Import -testServer :: Server -testServer = Server "http://localhost:9200" +testServer :: IO Server +testServer = do + env <- lookupEnv "ES_TEST_SERVER" + return $ maybe (Server "http://localhost:9200") (Server . T.pack) env testIndex :: IndexName testIndex = [qqIndexName|bloodhound-tests-twitter-1|] withTestEnv :: BH IO a -> IO a -withTestEnv = withBH defaultManagerSettings testServer +withTestEnv action = testServer >>= withBH defaultManagerSettings <*> pure action data Location = Location { lat :: Double, @@ -81,8 +90,13 @@ Right ack -> return ack deleteExampleIndex :: (MonadBH m) => m (BHResponse StatusDependant Acknowledged, Acknowledged) -deleteExampleIndex = - performBHRequest $ keepBHResponse $ deleteIndex testIndex +deleteExampleIndex = do + result <- tryPerformBHRequest (keepBHResponse $ deleteIndex testIndex) + case result of + Left e + | errorStatus e == Just 404 -> return (error "deleteExampleIndex: 404 has no response body", Acknowledged False) + | otherwise -> throwEsError e + Right ack -> return ack validateStatus :: (Show body) => BHResponse contextualized body -> Int -> Expectation validateStatus resp expected = @@ -305,15 +319,232 @@ liftIO $ value_ `shouldBe` expected +-- --------------------------------------------------------------------------- +-- - k-NN test fixtures +-- --------------------------------------------------------------------------- + +-- | Dedicated index for kNN tests. Keeps the dense_vector mapping out of the +-- shared @testIndex@ so the rest of the suite is unaffected. +knnTestIndex :: IndexName +knnTestIndex = [qqIndexName|bloodhound-tests-knn-1|] + +-- | 5-dimensional vector document for kNN tests. The vector is small enough +-- to run on any laptop yet exercises the real @dense_vector@ pipeline. +-- +-- The vector is wrapped in 'Maybe' because ES9+ strips @dense_vector@ fields +-- from @_source@ on read by default. We only need the vector at index time; +-- assertions only inspect @label@. +data KnnDoc = KnnDoc + { knnDocLabel :: Text, + knnDocVector :: Maybe [Double] + } + deriving stock (Eq, Show) + +-- | Drop the @knnDoc@ prefix and lowercase the next character so that +-- @knnDocLabel@ serializes as @label@ (not @Label@). Inlined into the +-- splice due to Template Haskell stage restrictions. +$(deriveJSON defaultOptions {fieldLabelModifier = \s -> case stripPrefix "knnDoc" s of { Just (c : rest) -> toLower c : rest; _ -> s }} ''KnnDoc) + +-- | Mapping declaring @vector@ as an indexed @dense_vector@ with cosine +-- similarity. Required by ES8+\/ES9+ kNN search. +knnDocMapping :: Value +knnDocMapping = + object + [ "properties" + .= object + [ "label" .= object ["type" .= ("keyword" :: Text)], + "vector" + .= object + [ "type" .= ("dense_vector" :: Text), + "dims" .= (5 :: Int), + "index" .= True + ] + ] + ] + +-- | Sample kNN documents: two vectors that point roughly "toward" the query +-- vector @[0.1, 0.2, 0.3, 0.4, 0.5]@. +exampleKnnDocA :: KnnDoc +exampleKnnDocA = KnnDoc "alpha" (Just [0.1, 0.2, 0.3, 0.4, 0.5]) + +exampleKnnDocB :: KnnDoc +exampleKnnDocB = KnnDoc "beta" (Just [0.9, 0.8, 0.7, 0.6, 0.5]) + +-- | Reset (delete + recreate + map) the kNN test index. +resetKnnIndex :: BH IO () +resetKnnIndex = do + _ <- tryEsError deleteKnnExampleIndex + _ <- createKnnExampleIndex + _ <- performBHRequest $ putMapping @Value knnTestIndex knnDocMapping + return () + +deleteKnnExampleIndex :: BH IO (BHResponse StatusDependant Acknowledged, Acknowledged) +deleteKnnExampleIndex = + performBHRequest $ keepBHResponse $ deleteIndex knnTestIndex + +createKnnExampleIndex :: BH IO (BHResponse StatusDependant Acknowledged, Acknowledged) +createKnnExampleIndex = do + result <- tryPerformBHRequest (keepBHResponse $ createIndex (IndexSettings (ShardCount 1) (ReplicaCount 0) defaultIndexMappingsLimits) knnTestIndex) + case result of + Left e + | T.isSuffixOf "already exists" (errorMessage e) -> return (error "TODO rewrite this part too", Acknowledged False) + | otherwise -> throwEsError e + Right ack -> return ack + +-- | Seed the kNN index with two known documents. +insertKnnData :: BH IO () +insertKnnData = do + _ <- tryEsError resetKnnIndex + _ <- performBHRequest $ indexDocument knnTestIndex defaultIndexDocumentSettings exampleKnnDocA (DocId "a") + _ <- performBHRequest $ indexDocument knnTestIndex defaultIndexDocumentSettings exampleKnnDocB (DocId "b") + _ <- performBHRequest $ refreshIndex knnTestIndex + return () + +-- --------------------------------------------------------------------------- +-- - OpenSearch k-NN test fixtures +-- --------------------------------------------------------------------------- + +-- | Dedicated index for OpenSearch kNN tests. OS uses a different field type +-- (@knn_vector@ vs ES's @dense_vector@) and requires @index.knn: true@. +osKnnTestIndex :: IndexName +osKnnTestIndex = [qqIndexName|bloodhound-tests-os-knn-1|] + +-- | Mapping declaring @vector@ as an OpenSearch @knn_vector@. The +-- @index.knn: true@ setting is applied via 'osKnnIndexSettings'. +osKnnDocMapping :: Value +osKnnDocMapping = + object + [ "properties" + .= object + [ "label" .= object ["type" .= ("keyword" :: Text)], + "vector" + .= object + [ "type" .= ("knn_vector" :: Text), + "dimension" .= (5 :: Int) + ] + ] + ] + +-- | OpenSearch-specific index settings that enable the kNN plugin. +osKnnIndexSettings :: Value +osKnnIndexSettings = + object + [ "settings" + .= object ["index.knn" .= True], + "mappings" .= osKnnDocMapping + ] + +-- | Reset the OpenSearch kNN test index. Uses a raw JSON body because the +-- common 'IndexSettings' type does not model @index.knn@. +resetOsKnnIndex :: BH IO () +resetOsKnnIndex = do + _ <- tryEsError deleteOsKnnExampleIndex + _ <- createOsKnnExampleIndex + return () + +deleteOsKnnExampleIndex :: BH IO (BHResponse StatusDependant Acknowledged, Acknowledged) +deleteOsKnnExampleIndex = + performBHRequest $ keepBHResponse $ deleteIndex osKnnTestIndex + +createOsKnnExampleIndex :: BH IO (BHResponse StatusDependant Value, Value) +createOsKnnExampleIndex = do + result <- + tryPerformBHRequest $ + keepBHResponse $ + mkFullRequest @StatusDependant @Value NHTM.methodPut (mkEndpoint [unIndexName osKnnTestIndex]) (encode osKnnIndexSettings) + case result of + Left e + | T.isSuffixOf "already exists" (errorMessage e) -> return (error "TODO rewrite this part too", object ["acknowledged" .= True]) + | otherwise -> throwEsError e + Right ack -> return ack + +-- | Seed the OS kNN index with two known documents. +insertOsKnnData :: BH IO () +insertOsKnnData = do + _ <- tryEsError resetOsKnnIndex + _ <- performBHRequest $ indexDocument osKnnTestIndex defaultIndexDocumentSettings exampleKnnDocA (DocId "a") + _ <- performBHRequest $ indexDocument osKnnTestIndex defaultIndexDocumentSettings exampleKnnDocB (DocId "b") + _ <- performBHRequest $ refreshIndex osKnnTestIndex + return () + +-- --------------------------------------------------------------------------- +-- - OpenSearch neural-sparse test fixtures +-- --------------------------------------------------------------------------- + +-- | Dedicated index for OpenSearch neural-sparse warmup/cache tests. OS 3.x +-- requires @index.sparse: true@ for the neural warmup and clear-cache +-- endpoints to accept an index. +osNeuralSparseTestIndex :: IndexName +osNeuralSparseTestIndex = [qqIndexName|bloodhound-tests-os-neural-sparse-1|] + +-- | Mapping declaring @sparse_embedding@ as an OpenSearch @sparse_vector@ +-- field. OS 3.x requires a @method@ parameter on @sparse_vector@ fields. +osNeuralSparseDocMapping :: Value +osNeuralSparseDocMapping = + object + [ "properties" + .= object + [ "sparse_embedding" + .= object + [ "type" .= ("sparse_vector" :: Text), + "method" .= object ["name" .= ("seismic" :: Text)] + ] + ] + ] + +-- | OpenSearch-specific index settings that enable neural sparse search. +-- The @index.sparse@ setting is required for the warmup and clear-cache +-- endpoints (live-verified on OS 3.7.0, bead bloodhound-at5). +osNeuralSparseIndexSettings :: Value +osNeuralSparseIndexSettings = + object + [ "settings" + .= object ["index" .= object ["sparse" .= True]], + "mappings" .= osNeuralSparseDocMapping + ] + +-- | Reset the OpenSearch neural-sparse test index. Uses a raw JSON body +-- because the common 'IndexSettings' type does not model @index.sparse@. +resetOsNeuralSparseIndex :: BH IO () +resetOsNeuralSparseIndex = do + _ <- tryEsError deleteOsNeuralSparseExampleIndex + _ <- createOsNeuralSparseExampleIndex + return () + +deleteOsNeuralSparseExampleIndex :: BH IO (BHResponse StatusDependant Acknowledged, Acknowledged) +deleteOsNeuralSparseExampleIndex = + performBHRequest $ keepBHResponse $ deleteIndex osNeuralSparseTestIndex + +createOsNeuralSparseExampleIndex :: BH IO (BHResponse StatusDependant Value, Value) +createOsNeuralSparseExampleIndex = do + result <- + tryPerformBHRequest $ + keepBHResponse $ + mkFullRequest @StatusDependant @Value NHTM.methodPut (mkEndpoint [unIndexName osNeuralSparseTestIndex]) (encode osNeuralSparseIndexSettings) + case result of + Left e + | T.isSuffixOf "already exists" (errorMessage e) -> return (error "TODO rewrite this part too", object ["acknowledged" .= True]) + | otherwise -> throwEsError e + Right ack -> return ack + is :: Versions.Version -> IO Bool is v = getServerVersion >>= \x -> return $ x == v esOnlyIT :: (HasCallStack, Example a) => IO (String -> a -> SpecWith (Arg a)) esOnlyIT = withMajorVersionIT (>= 6) +es9OnlyIT :: (HasCallStack, Example a) => IO (String -> a -> SpecWith (Arg a)) +es9OnlyIT = withMajorVersionIT (== 9) + +os1OnlyIT :: (HasCallStack, Example a) => IO (String -> a -> SpecWith (Arg a)) +os1OnlyIT = withMajorVersionIT (== 1) + os2OnlyIT :: (HasCallStack, Example a) => IO (String -> a -> SpecWith (Arg a)) os2OnlyIT = withMajorVersionIT (== 2) +os3OnlyIT :: (HasCallStack, Example a) => IO (String -> a -> SpecWith (Arg a)) +os3OnlyIT = withMajorVersionIT (== 3) + withMajorVersionIT :: (HasCallStack, Example a) => (Word -> Bool) -> IO (String -> a -> SpecWith (Arg a)) withMajorVersionIT p = do majoreVersion <- fetchMajorVersion @@ -328,3 +559,38 @@ x <- performBHRequest $ getNodesInfo LocalNode let majoreVersion = versionNumber $ nodeInfoESVersion $ head $ nodesInfo x return $ head $ toListOf Versions.major majoreVersion + +-- | Detect backend type from the running server +-- | Returns Nothing if server is unreachable or unknown +detectBackendType :: IO (Maybe BackendType) +detectBackendType = do + result <- Control.Exception.try (withTestEnv $ performBHRequest $ getNodesInfo LocalNode) :: IO (Either Control.Exception.SomeException NodesInfo) + case result of + Left _ -> pure Nothing + Right nodesResponse -> do + let versionNum = versionNumber $ nodeInfoESVersion $ head $ nodesInfo nodesResponse + let major = head $ toListOf Versions.major versionNum + return $ case major of + 7 -> Just ElasticSearch7 + 8 -> Just ElasticSearch8 + 9 -> Just ElasticSearch9 + 1 -> Just OpenSearch1 + 2 -> Just OpenSearch2 + 3 -> Just OpenSearch3 + _ -> Nothing + +-- | Run spec only if current backend matches one of the supported backends. +-- | If not, all tests are marked pending with an informative message. +backendSpecific :: (HasCallStack) => [BackendType] -> SpecWith a -> SpecWith a +backendSpecific supported spec = do + detected <- runIO detectBackendType + case detected of + Just backend + | backend `elem` supported -> + spec + Just other -> + before_ (pendingWith $ "Requires " <> formatBackends supported <> " but running on " <> show other) spec + Nothing -> + before_ (pendingWith "Could not detect backend (server unreachable?)") spec + where + formatBackends = L.intercalate ", " . map show diff --git a/tests/TestsUtils/Generators.hs b/tests/TestsUtils/Generators.hs --- a/tests/TestsUtils/Generators.hs +++ b/tests/TestsUtils/Generators.hs @@ -4,12 +4,13 @@ module TestsUtils.Generators where -import qualified Data.Aeson.KeyMap as X -import qualified Data.List as L -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Data.Versions as Versions +import Data.Aeson.KeyMap qualified as X +import Data.List qualified as L +import Data.List.NonEmpty qualified as NE +import Data.Map qualified as M +import Data.Scientific (Scientific) +import Data.Text qualified as T +import Data.Versions qualified as Versions import Database.Bloodhound import Generic.Random import TestsUtils.ApproxEq @@ -26,6 +27,17 @@ instance Arbitrary Text where arbitrary = T.pack <$> arbitrary +-- | Used by the ReindexResponse / ReindexSliceStatus round-trip +-- properties to exercise the @requests_per_second@ 'Scientific' field +-- (documented as a potentially fractional "number"). QuickCheck-2.14.3 +-- ships no such instance; defined here as an orphan alongside the +-- existing 'Text' / 'UTCTime' / 'NominalDiffTime' orphans in this +-- module. Generates only integer values for round-trip safety — +-- 'Data.Scientific' round-trips arbitrary precision, but integer-valued +-- samples keep the property deterministic across aeson versions. +instance Arbitrary Scientific where + arbitrary = fromInteger <$> arbitrary + instance Arbitrary UTCTime where arbitrary = UTCTime @@ -38,9 +50,19 @@ shrink = (ModifiedJulianDay <$>) . shrink . toModifiedJulianDay -#if !MIN_VERSION_QuickCheck(2,9,0) +#if MIN_VERSION_QuickCheck(2,10,0) && !MIN_VERSION_QuickCheck(2,17,0) +-- QuickCheck dropped its 'Arbitrary (NonEmpty a)' instance in 2.10 and +-- re-added it in 2.17 (see 'Test.QuickCheck.Arbitrary'). Define our own +-- only for the versions in between; otherwise it would duplicate +-- QuickCheck's. +qcNonEmptyToNonEmpty :: NonEmptyList a -> NonEmpty a +qcNonEmptyToNonEmpty (NonEmpty (a : xs)) = (a :| xs) +qcNonEmptyToNonEmpty (NonEmpty []) = error "NonEmpty was empty!" + instance Arbitrary a => Arbitrary (NonEmpty a) where - arbitrary = liftA2 (:|) arbitrary arbitrary + arbitrary = + qcNonEmptyToNonEmpty + <$> arbitrary #endif arbitraryScore :: Gen Score @@ -120,18 +142,6 @@ . T.pack <$> listOf1 arbitraryAlphaNum -#if MIN_VERSION_base(4,10,0) --- Test.QuickCheck.Modifiers - -qcNonEmptyToNonEmpty :: NonEmptyList a -> NonEmpty a -qcNonEmptyToNonEmpty (NonEmpty (a : xs)) = (a :| xs) -qcNonEmptyToNonEmpty (NonEmpty []) = error "NonEmpty was empty!" - -instance Arbitrary a => Arbitrary (NonEmpty a) where - arbitrary = - qcNonEmptyToNonEmpty - <$> arbitrary -#endif instance Arbitrary ScriptFields where arbitrary = pure $ @@ -168,6 +178,9 @@ IndexAliasCreate <$> arbitrary <*> reduceSize arbitrary + <*> reduceSize arbitrary + <*> reduceSize arbitrary + <*> reduceSize arbitrary instance Arbitrary Query where arbitrary = @@ -182,8 +195,6 @@ QueryCommonTermsQuery <$> arbitrary, ConstantScoreQuery <$> arbitrary <*> arbitrary, QueryDisMaxQuery <$> arbitrary, - QueryFuzzyLikeThisQuery <$> arbitrary, - QueryFuzzyLikeFieldQuery <$> arbitrary, QueryFuzzyQuery <$> arbitrary, QueryHasChildQuery <$> arbitrary, QueryHasParentQuery <$> arbitrary, @@ -191,7 +202,6 @@ QueryIndicesQuery <$> arbitrary, MatchAllQuery <$> arbitrary, QueryMoreLikeThisQuery <$> arbitrary, - QueryMoreLikeThisFieldQuery <$> arbitrary, QueryNestedQuery <$> arbitrary, QueryPrefixQuery <$> arbitrary, QueryQueryStringQuery <$> arbitrary, @@ -285,6 +295,10 @@ indewName <- T.pack <$> replicateM n (chooseEnum ('a', 'z')) return $ either (\e -> error $ "Invalid generated IndexName " <> show indewName <> ":" <> T.unpack e) id $ mkIndexName indewName +instance Arbitrary RolloverConditions where arbitrary = genericArbitraryU + +instance Arbitrary RolloverResponse where arbitrary = genericArbitraryU + deriving newtype instance Arbitrary DocId instance Arbitrary Version where arbitrary = genericArbitraryU @@ -347,16 +361,10 @@ deriving newtype instance Arbitrary AllowLeadingWildcard -deriving newtype instance Arbitrary LowercaseExpanded - deriving newtype instance Arbitrary EnablePositionIncrements deriving newtype instance Arbitrary AnalyzeWildcard -deriving newtype instance Arbitrary GeneratePhraseQueries - -deriving newtype instance Arbitrary Locale - deriving newtype instance Arbitrary MaxWordLength deriving newtype instance Arbitrary MinWordLength @@ -369,6 +377,57 @@ deriving newtype instance Arbitrary Regexp +deriving newtype instance Arbitrary Rewrite + +deriving newtype instance Arbitrary QueryName + +deriving newtype instance Arbitrary Format + +deriving newtype instance Arbitrary RangeTimeZone + +deriving newtype instance Arbitrary CaseInsensitive + +deriving newtype instance Arbitrary Transpositions + +deriving newtype instance Arbitrary MaxDeterminizedStates + +-- | Generates from a fixed set of representative ES date-math expressions +-- rather than the orphan 'Arbitrary Text' (random Unicode). This keeps the +-- values meaningful AND guarantees they are never a valid ISO-8601 +-- timestamp, which would otherwise be claimed by the 'UTCTime' arm of +-- 'RangeValue''s decoder and break the 'RangeDateMath' round-trip. +instance Arbitrary DateMathString where + arbitrary = + DateMathString + <$> elements + [ "now", + "now/d", + "now-1d", + "now-7d/d", + "now+1h", + "now-1d/d", + "now||/d", + "2020-01-01||-1d", + "2020-01-01||+1M/d", + "now-1y/y" + ] + +-- | At least one bound must be 'Just', otherwise the encoder emits @{}@ and +-- the decoder rejects it (matching the @parseRangeValue@ 'nada' fallthrough), +-- which would break the 'RangeQuery' round-trip property. +instance Arbitrary RangeDateMathValue where + arbitrary = + (RangeDateMathValue <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary) + `suchThat` hasBound + where + hasBound v = + isJust (rangeDateMathLt v) + || isJust (rangeDateMathLte v) + || isJust (rangeDateMathGt v) + || isJust (rangeDateMathGte v) + +instance Arbitrary RangeRelation where arbitrary = genericArbitraryU + instance Arbitrary SimpleQueryStringQuery where arbitrary = genericArbitraryU instance Arbitrary FieldOrFields where arbitrary = genericArbitraryU @@ -387,8 +446,6 @@ instance Arbitrary NestedQuery where arbitrary = genericArbitraryU -instance Arbitrary MoreLikeThisFieldQuery where arbitrary = genericArbitraryU - instance Arbitrary MoreLikeThisQuery where arbitrary = genericArbitraryU instance Arbitrary IndicesQuery where arbitrary = genericArbitraryU @@ -407,10 +464,6 @@ instance Arbitrary FuzzyQuery where arbitrary = genericArbitraryU -instance Arbitrary FuzzyLikeFieldQuery where arbitrary = genericArbitraryU - -instance Arbitrary FuzzyLikeThisQuery where arbitrary = genericArbitraryU - instance Arbitrary DisMaxQuery where arbitrary = genericArbitraryU instance Arbitrary CommonTermsQuery where arbitrary = genericArbitraryU @@ -449,14 +502,16 @@ instance Arbitrary MatchQuery where arbitrary = genericArbitraryU +instance Arbitrary MatchPhraseQuery where arbitrary = genericArbitraryU + +instance Arbitrary MatchPhrasePrefixQuery where arbitrary = genericArbitraryU + instance Arbitrary MultiMatchQueryType where arbitrary = genericArbitraryU instance Arbitrary BooleanOperator where arbitrary = genericArbitraryU instance Arbitrary ZeroTermsQuery where arbitrary = genericArbitraryU -instance Arbitrary MatchQueryType where arbitrary = genericArbitraryU - instance Arbitrary SearchAliasRouting where arbitrary = genericArbitraryU instance Arbitrary ScoreType where arbitrary = genericArbitraryU @@ -535,6 +590,31 @@ instance Arbitrary Compression where arbitrary = genericArbitraryU +instance Arbitrary TimeUnits where + arbitrary = + elements + [ TimeUnitDays, + TimeUnitHours, + TimeUnitMinutes, + TimeUnitSeconds, + TimeUnitMilliseconds, + TimeUnitMicroseconds, + TimeUnitNanoseconds + ] + +instance Arbitrary EsDuration where arbitrary = genericArbitraryU + +-- | Hand-written (not generic) so the generated value always round-trips: +-- 'Bytes' must carry a non-negative count (the parser rejects a leading +-- minus sign) and the percent 'Double' must be finite (NaN breaks the +-- Eq-based 'ApproxEq' fallback). +instance Arbitrary DiskWatermark where + arbitrary = + oneof + [ DiskWatermarkPercent <$> choose (0, 1000000 :: Double), + DiskWatermarkBytes . Bytes <$> choose (0, 10 ^ (9 :: Int)) + ] + deriving newtype instance Arbitrary Bytes instance Arbitrary AllocationPolicy where arbitrary = genericArbitraryU @@ -561,8 +641,35 @@ instance Arbitrary PhraseSuggester where arbitrary = genericArbitraryU -instance Arbitrary SuggestType where arbitrary = genericArbitraryU +-- | 'SuggestTypeContextSuggester' is intentionally absent from this +-- generator: its 'ToJSON' (the @completion@ tag) decodes back as +-- 'SuggestTypeCompletionSuggester' (see 'SuggestType' docs), so +-- including it would violate the @propJSON (Proxy :: Proxy Suggest)@ +-- round-trip. 'SuggestTypeCustom' is also absent because there is no +-- 'Arbitrary' instance for its 'Value' payload. Both variants are +-- covered by the pinned wire-shape tests in "Test.SuggestSpec". +instance Arbitrary SuggestType where + arbitrary = + oneof + [ SuggestTypePhraseSuggester <$> arbitrary, + SuggestTypeTermSuggester <$> arbitrary, + SuggestTypeCompletionSuggester <$> arbitrary + ] +instance Arbitrary TermSuggesterSort where arbitrary = genericArbitraryU + +instance Arbitrary TermSuggesterStringDistance where arbitrary = genericArbitraryU + +instance Arbitrary TermSuggester where arbitrary = genericArbitraryU + +instance Arbitrary ContextQueryValue where arbitrary = genericArbitraryU + +instance Arbitrary CompletionSuggesterFuzzy where arbitrary = genericArbitraryU + +instance Arbitrary CompletionSuggester where arbitrary = genericArbitraryU + +deriving newtype instance Arbitrary ContextSuggester + instance Arbitrary Suggest where arbitrary = genericArbitraryU instance Arbitrary FunctionScoreQuery where arbitrary = genericArbitraryU @@ -623,3 +730,112 @@ shrink (UpdatableIndexSetting' x) = map UpdatableIndexSetting' (shrink x) instance Arbitrary InnerHits where arbitrary = genericArbitraryU + +-- | Drives the ReindexResponse / ReindexRetries round-trip properties +-- in "Test.ReindexResponseSpec". ReindexRetries has no recursion so a +-- plain Applicative generator is enough. +instance Arbitrary ReindexRetries where + arbitrary = + ReindexRetries + <$> arbitrary + <*> arbitrary + +-- | Recursive error-cause generator. Depth is hard-capped at 3 +-- (independent of QuickCheck's size parameter) and the @root_cause@ / +-- @suppressed@ lists carry at most 2 entries, so generated trees stay +-- small enough for 100 tests + shrinks to run in well under a second. +-- A tighter bound than the obvious @sized (n -> ... n/2 ...)@, which +-- blows up because @listOf1@ sizes its elements at the parent size. +instance Arbitrary ReindexFailureCause where + arbitrary = go maxDepth + where + maxDepth = 3 + go 0 = + pure + ReindexFailureCause + { reindexFailureCauseType = Nothing, + reindexFailureCauseReason = Nothing, + reindexFailureCauseStackTrace = Nothing, + reindexFailureCauseCausedBy = Nothing, + reindexFailureCauseRootCause = Nothing, + reindexFailureCauseSuppressed = Nothing + } + go n = + ReindexFailureCause + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> oneof [pure Nothing, Just <$> go (n - 1)] + <*> maybeShortList (go (n - 1)) + <*> maybeShortList (go (n - 1)) + maybeShortList g = do + k <- choose (0, 2) + if k == 0 + then pure Nothing + else Just <$> replicateM k g + +instance Arbitrary ReindexFailure where + arbitrary = + ReindexFailure + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +-- | Per-slice status. The bare-string 'throttled'/'throttled_until' +-- fields are 'Text' so they reuse the existing 'Arbitrary Text'. +-- 'requests_per_second' is 'Scientific' (now with an 'Arbitrary' +-- instance in this module — see the orphan at the top). +instance Arbitrary ReindexSliceStatus where + arbitrary = + ReindexSliceStatus + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +-- | 'ReindexResponse' covering the full documented response surface +-- (all seventeen top-level fields). 'requests_per_second' is +-- 'Scientific' (now with an 'Arbitrary' instance — see the orphan at +-- the top of this module). +-- +-- @failures@ / @slices@ are generated as either 'Nothing' or a +-- @Just@-non-empty list, because the 'omitNulls' encoder drops empty +-- arrays (an empty @failures@ list is semantically identical to an +-- absent @failures@ key). The explicit golden test +-- "decodes an empty failures list as Just []" pins the decode side +-- of that asymmetry. +instance Arbitrary ReindexResponse where + arbitrary = + ReindexResponse + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> maybeNonEmpty arbitrary + <*> maybeNonEmpty arbitrary + <*> arbitrary + <*> arbitrary + where + maybeNonEmpty g = + oneof [pure Nothing, Just <$> listOf1 g] diff --git a/tests/TestsUtils/Import.hs b/tests/TestsUtils/Import.hs --- a/tests/TestsUtils/Import.hs +++ b/tests/TestsUtils/Import.hs @@ -2,19 +2,24 @@ module TestsUtils.Import ( module X, - module TestsUtils.Import, + isRight, + noDuplicates, + getSource, + grabFirst, + when', + headMay, ) where import Control.Applicative as X import Control.Exception as X (evaluate) import Control.Monad as X -import Control.Monad.Catch as X +import Control.Monad.Catch as X (try) import Control.Monad.Reader as X import Data.Aeson as X import Data.Aeson.TH as X import Data.Aeson.Types as X (parseEither) -import qualified Data.List as L +import Data.List qualified as L import Data.List.NonEmpty as X (NonEmpty (..)) import Data.Maybe as X import Data.Monoid as X @@ -22,7 +27,7 @@ import Data.Proxy as X import Data.Text as X (Text) import Data.Time.Calendar as X (Day (..), fromGregorian) -import Data.Time.Clock as X +import Data.Time.Clock as X (NominalDiffTime, UTCTime (..), secondsToDiffTime) import Data.Typeable as X import Database.Bloodhound.Client as X (BH, MonadBH (..), pitSearch, scanSearch, withBH) import Database.Bloodhound.Requests as X @@ -38,6 +43,10 @@ noDuplicates :: (Eq a) => [a] -> Bool noDuplicates xs = L.nub xs == xs + +isRight :: Either a b -> Bool +isRight (Right _) = True +isRight _ = False getSource :: EsResult a -> Maybe a getSource = fmap _source . foundResult